From 7c54d2cab42ac3e6ce0b18051d38173c3671634b Mon Sep 17 00:00:00 2001 From: mattias Date: Sat, 20 Aug 2005 14:00:31 +0000 Subject: [PATCH] implemented auto removing dangling component events git-svn-id: trunk@7527 - --- components/codetools/codetoolmanager.pas | 24 +++- components/codetools/codetree.pas | 35 +++++ components/codetools/keywordfunclists.pas | 1 + components/codetools/lfmtrees.pas | 23 +++- components/codetools/stdcodetools.pas | 161 +++++++++++++++++++++- ide/checklfmdlg.pas | 86 +++++++++++- ide/main.pp | 34 +++++ lcl/include/promptdialog.inc | 66 --------- 8 files changed, 359 insertions(+), 71 deletions(-) diff --git a/components/codetools/codetoolmanager.pas b/components/codetools/codetoolmanager.pas index aba965eba7..ec4cee71a5 100644 --- a/components/codetools/codetoolmanager.pas +++ b/components/codetools/codetoolmanager.pas @@ -482,7 +482,11 @@ type function RenamePublishedVariable(Code: TCodeBuffer; const AClassName, OldVariableName, NewVarName, VarType: shortstring; ErrorOnClassNotFound: boolean): boolean; - + function FindDanglingComponentEvents(Code: TCodeBuffer; + const AClassName: string; + RootComponent: TComponent; ExceptionOnClassNotFound: boolean; + out ListOfPInstancePropInfo: TFPList): boolean; + // functions for events in the object inspector function GetCompatiblePublishedMethods(Code: TCodeBuffer; const AClassName: string; TypeData: PTypeData; @@ -2940,6 +2944,24 @@ begin end; end; +function TCodeToolManager.FindDanglingComponentEvents(Code: TCodeBuffer; + const AClassName: string; RootComponent: TComponent; + ExceptionOnClassNotFound: boolean; out ListOfPInstancePropInfo: TFPList + ): boolean; +begin + Result:=false; + {$IFDEF CTDEBUG} + DebugLn('TCodeToolManager.FindDanglingComponentEvents A ',Code.Filename,' ',AClassName); + {$ENDIF} + if not InitCurCodeTool(Code) then exit; + try + Result:=FCurCodeTool.FindDanglingComponentEvents(AClassName,RootComponent, + ExceptionOnClassNotFound,ListOfPInstancePropInfo); + except + on e: Exception do Result:=HandleException(e); + end; +end; + function TCodeToolManager.HasInterfaceRegisterProc(Code: TCodeBuffer; var HasRegisterProc: boolean): boolean; begin diff --git a/components/codetools/codetree.pas b/components/codetools/codetree.pas index 06bf97ae1f..d79ffc8d81 100644 --- a/components/codetools/codetree.pas +++ b/components/codetools/codetree.pas @@ -264,6 +264,11 @@ var //----------------------------------------------------------------------------- // useful functions function NodeDescriptionAsString(Desc: TCodeTreeNodeDesc): string; +function FindCodeTreeNodeExt(Tree: TAVLTree; const Txt: string + ): TCodeTreeNodeExtension; +function FindCodeTreeNodeExtAVLNode(Tree: TAVLTree; const Txt: string): TAVLTreeNode; +function CompareTxtWithCodeTreeNodeExt(p: Pointer; + NodeData: pointer): integer; function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer; function CompareCodeTreeNodeExtWithPos(NodeData1, NodeData2: pointer): integer; function CompareCodeTreeNodeExtWithNodeStartPos( @@ -354,6 +359,36 @@ begin end; end; +function FindCodeTreeNodeExt(Tree: TAVLTree; const Txt: string + ): TCodeTreeNodeExtension; +var + AVLNode: TAVLTreeNode; +begin + AVLNode:=FindCodeTreeNodeExtAVLNode(Tree,Txt); + if AVLNode<>nil then + Result:=TCodeTreeNodeExtension(AVLNode.Data) + else + Result:=nil; +end; + +function FindCodeTreeNodeExtAVLNode(Tree: TAVLTree; const Txt: string + ): TAVLTreeNode; +begin + Result:=Tree.FindKey(@Txt,@CompareTxtWithCodeTreeNodeExt); +end; + +function CompareTxtWithCodeTreeNodeExt(p: Pointer; NodeData: pointer + ): integer; +var + s: String; + NodeExt: TCodeTreeNodeExtension; +begin + NodeExt:=TCodeTreeNodeExtension(NodeData); + s:=PAnsistring(p)^; + Result:=CompareTextIgnoringSpace(s,NodeExt.Txt,false); + //debugln('CompareTxtWithCodeTreeNodeExt ',NodeExt.Txt,' ',s,' ',dbgs(Result)); +end; + function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer; var NodeExt1, NodeExt2: TCodeTreeNodeExtension; begin diff --git a/components/codetools/keywordfunclists.pas b/components/codetools/keywordfunclists.pas index 32552de1fa..e4ef82060a 100644 --- a/components/codetools/keywordfunclists.pas +++ b/components/codetools/keywordfunclists.pas @@ -786,6 +786,7 @@ begin Add('OF',{$ifdef FPC}@{$endif}AllwaysTrue); Add('OPERATOR',{$ifdef FPC}@{$endif}AllwaysTrue); // not for Delphi //Add('ON',{$ifdef FPC}@{$endif}AllwaysTrue); // not for Delphi + Add('OUT',{$ifdef FPC}@{$endif}AllwaysTrue); Add('OR',{$ifdef FPC}@{$endif}AllwaysTrue); Add('PACKED',{$ifdef FPC}@{$endif}AllwaysTrue); Add('PROCEDURE',{$ifdef FPC}@{$endif}AllwaysTrue); diff --git a/components/codetools/lfmtrees.pas b/components/codetools/lfmtrees.pas index d9fafca16f..81a7bf7b1a 100644 --- a/components/codetools/lfmtrees.pas +++ b/components/codetools/lfmtrees.pas @@ -30,7 +30,7 @@ unit LFMTrees; interface uses - Classes, SysUtils, FileProcs, CodeCache, CodeAtom; + Classes, SysUtils, FileProcs, CodeCache, CodeAtom, TypInfo; type { TLFMTreeNode } @@ -257,6 +257,12 @@ type function FirstErrorAsString: string; end; + TInstancePropInfo = record + Instance: TPersistent; + PropInfo: PPropInfo; + end; + PInstancePropInfo = ^TInstancePropInfo; + const LFMErrorTypeNames: array[TLFMErrorType] of string = ( 'NoError', @@ -269,9 +275,24 @@ const 'PropertyHasNoSubProperties', 'IdentifierNotPublished' ); + +procedure FreeListOfPInstancePropInfo(List: TFPList); implementation +procedure FreeListOfPInstancePropInfo(List: TFPList); +var + i: Integer; + p: PInstancePropInfo; +begin + if List=nil then exit; + for i:=0 to List.Count-1 do begin + p:=PInstancePropInfo(List[i]); + Dispose(p); + end; + List.Free; +end; + { TLFMTree } constructor TLFMTree.Create; diff --git a/components/codetools/stdcodetools.pas b/components/codetools/stdcodetools.pas index 20c56453f4..b2b78aaf12 100644 --- a/components/codetools/stdcodetools.pas +++ b/components/codetools/stdcodetools.pas @@ -48,7 +48,7 @@ uses {$IFDEF MEM_CHECK} MemCheck, {$ENDIF} - Classes, SysUtils, CodeToolsStrConsts, FileProcs, CodeTree, CodeAtom, + Classes, SysUtils, TypInfo, CodeToolsStrConsts, FileProcs, CodeTree, CodeAtom, FindDeclarationTool, IdentCompletionTool, PascalReaderTool, PascalParserTool, KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache, AVL_Tree, LFMTrees, SourceChanger, @@ -182,6 +182,13 @@ type UpperOldVarName: string; const NewVarName, VarType: shortstring; ExceptionOnClassNotFound: boolean; SourceChangeCache: TSourceChangeCache): boolean; + function GatherPublishedClassElements(const TheClassName: string; + ExceptionOnClassNotFound, WithVariables, WithMethods, + WithProperties: boolean; + out TreeOfCodeTreeNodeExtension: TAVLTree): boolean; + function FindDanglingComponentEvents(const TheClassName: string; + RootComponent: TComponent; ExceptionOnClassNotFound: boolean; + out ListOfPInstancePropInfo: TFPList): boolean; // blocks (e.g. begin..end) function FindBlockCounterPart(const CursorPos: TCodeXYPosition; @@ -3728,6 +3735,158 @@ begin end; end; +function TStandardCodeTool.GatherPublishedClassElements( + const TheClassName: string; + ExceptionOnClassNotFound, WithVariables, WithMethods, WithProperties: boolean; + out TreeOfCodeTreeNodeExtension: TAVLTree): boolean; +var + ClassNode, SectionNode: TCodeTreeNode; + ANode: TCodeTreeNode; + CurProcName: String; + NewNodeExt: TCodeTreeNodeExtension; + CurVarName: String; + CurPropName: String; +begin + Result:=false; + TreeOfCodeTreeNodeExtension:=nil; + if (TheClassName='') or (length(TheClassName)>255) then + RaiseException(Format(ctsInvalidClassName, ['"', TheClassName, '"'])); + BuildTree(true); + ClassNode:=FindClassNodeInInterface(TheClassName,true,false, + ExceptionOnClassNotFound); + if ClassNode=nil then exit; + TreeOfCodeTreeNodeExtension:=TAVLTree.Create(@CompareCodeTreeNodeExt); + BuildSubTreeForClass(ClassNode); + SectionNode:=ClassNode.FirstChild; + while (SectionNode<>nil) do begin + if SectionNode.Desc=ctnClassPublished then begin + ANode:=SectionNode.FirstChild; + while ANode<>nil do begin + if (ANode.Desc=ctnProcedure) and WithMethods then begin + CurProcName:=ExtractProcName(ANode,[]); + //debugln('TStandardCodeTool.GatherPublishedClassElements CurProcName="',CurProcName,'"'); + NewNodeExt:=NodeExtMemManager.NewNode; + with NewNodeExt do begin + Node:=ANode; + Txt:=CurProcName; + end; + TreeOfCodeTreeNodeExtension.Add(NewNodeExt); + end + else if (ANode.Desc=ctnVarDefinition) and WithVariables then begin + CurVarName:=ExtractDefinitionName(ANode); + NewNodeExt:=NodeExtMemManager.NewNode; + with NewNodeExt do begin + Node:=ANode; + Txt:=CurVarName; + end; + TreeOfCodeTreeNodeExtension.Add(NewNodeExt); + end + else if (ANode.Desc=ctnProperty) and WithProperties then begin + CurPropName:=ExtractPropName(ANode,false); + NewNodeExt:=NodeExtMemManager.NewNode; + with NewNodeExt do begin + Node:=ANode; + Txt:=CurPropName; + end; + TreeOfCodeTreeNodeExtension.Add(NewNodeExt); + end; + ANode:=ANode.NextBrother; + end; + end; + SectionNode:=SectionNode.NextBrother; + end; + Result:=true; +end; + +function TStandardCodeTool.FindDanglingComponentEvents( + const TheClassName: string; RootComponent: TComponent; + ExceptionOnClassNotFound: boolean; + out ListOfPInstancePropInfo: TFPList): boolean; +var + PublishedMethods: TAVLTree; + + procedure AddDanglingEvent(Instance: TPersistent; PropInfo: PPropInfo); + var + NewItem: PInstancePropInfo; + begin + New(NewItem); + NewItem^.Instance:=Instance; + NewItem^.PropInfo:=PropInfo; + if ListOfPInstancePropInfo=nil then ListOfPInstancePropInfo:=TFPList.Create; + ListOfPInstancePropInfo.Add(NewItem); + //debugln('AddDanglingEvent ',DbgSName(Instance),' ',PropInfo^.Name); + end; + + procedure CheckMethodsInComponent(AComponent: TComponent); + var + TypeInfo: PTypeInfo; + TypeData: PTypeData; + PropInfo: PPropInfo; + CurCount: integer; + PropType: PTypeInfo; + NodeExt: TCodeTreeNodeExtension; + CurMethod: TMethod; + CurMethodName: String; + begin + if AComponent=nil then exit; + //debugln('TStandardCodeTool.FindDanglingComponentEvents Checking ',DbgSName(AComponent)); + // read all properties and remove doubles + TypeInfo:=AComponent.ClassInfo; + repeat + // read all property infos of current class + TypeData:=GetTypeData(TypeInfo); + // skip unitname + PropInfo:=(@TypeData^.UnitName+Length(TypeData^.UnitName)+1); + // read property count + CurCount:=PWord(PropInfo)^; + inc(PtrInt(PropInfo),SizeOf(Word)); + //debugln(' UnitName=',TypeData^.UnitName,' Type=',TypeInfo^.Name,' CurPropCount=',dbgs(CurCount)); + // read properties + while CurCount>0 do begin + // point PropInfo to next propinfo record. + // Located at Name[Length(Name)+1] ! + //debugln(' Property ',PropInfo^.Name,' Type=',PropInfo^.PropType^.Name); + PropType:=PropInfo^.PropType; + if PropType^.Kind=tkMethod then begin + // RTTI property is method + // -> search method in source + CurMethod:=GetMethodProp(AComponent,PropInfo); + CurMethodName:=RootComponent.MethodName(CurMethod.Code); + if CurMethodName<>'' then begin + NodeExt:=FindCodeTreeNodeExt(PublishedMethods,CurMethodName); + if NodeExt=nil then begin + // method not found -> dangling event + AddDanglingEvent(AComponent,PropInfo); + end; + end; + end; + PropInfo:=PPropInfo(pointer(@PropInfo^.Name)+PByte(@PropInfo^.Name)^+1); + dec(CurCount); + end; + TypeInfo:=TypeData^.ParentInfo; + until TypeInfo=nil; + end; + +var + i: Integer; +begin + PublishedMethods:=nil; + ListOfPInstancePropInfo:=nil; + try + // search all available published methods + //debugln('TStandardCodeTool.FindDanglingComponentEvents A ',MainFilename,' ',DbgSName(RootComponent)); + Result:=GatherPublishedClassElements(TheClassName,ExceptionOnClassNotFound, + false,true,false,PublishedMethods); + if not Result then exit; + // go through all components + CheckMethodsInComponent(RootComponent); + for i:=0 to RootComponent.ComponentCount-1 do + CheckMethodsInComponent(RootComponent.Components[i]); + finally + NodeExtMemManager.DisposeAVLTree(PublishedMethods); + end; +end; + function TStandardCodeTool.FindBlockCounterPart( const CursorPos: TCodeXYPosition; var NewPos: TCodeXYPosition; var NewTopLine: integer): boolean; diff --git a/ide/checklfmdlg.pas b/ide/checklfmdlg.pas index 38d8435b6a..7ceafc7a86 100644 --- a/ide/checklfmdlg.pas +++ b/ide/checklfmdlg.pas @@ -33,8 +33,8 @@ interface uses // FCL+LCL - Classes, SysUtils, Math, LCLProc, LResources, Forms, Controls, Graphics, - Dialogs, Buttons, StdCtrls, + Classes, SysUtils, Math, TypInfo, LCLProc, LResources, Forms, Controls, + Graphics, Dialogs, Buttons, StdCtrls, // components SynHighlighterLFM, SynEdit, BasicCodeTools, CodeCache, CodeToolManager, LFMTrees, @@ -87,6 +87,10 @@ function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string; function ShowRepairLFMWizard(LFMBuffer: TCodeBuffer; LFMTree: TLFMTree): TModalResult; +function RemoveDanglingEvents(RootComponent: TComponent; + PascalBuffer: TCodeBuffer; OkOnCodeErrors: boolean; + out ComponentModified: boolean): TModalResult; +procedure ClearDanglingEvents(ListOfPInstancePropInfo: TFPList); implementation @@ -224,6 +228,84 @@ begin CheckLFMDialog.Free; end; +function RemoveDanglingEvents(RootComponent: TComponent; + PascalBuffer: TCodeBuffer; OkOnCodeErrors: boolean; out + ComponentModified: boolean): TModalResult; +var + ListOfPInstancePropInfo: TFPList; + p: PInstancePropInfo; + i: Integer; + CurMethod: TMethod; + CurMethodName: String; + PropName: String; + s: String; + MsgResult: TModalResult; +begin + try + // find all dangling events + //debugln('RemoveDanglingEvents A ',PascalBuffer.Filename,' ',DbgSName(RootComponent)); + if not CodeToolBoss.FindDanglingComponentEvents(PascalBuffer, + RootComponent.ClassName,RootComponent,false,ListOfPInstancePropInfo) + then begin + //debugln('RemoveDanglingEvents Errors in code'); + if OkOnCodeErrors then + exit(mrOk) + else + exit(mrCancel); + end; + if ListOfPInstancePropInfo=nil then + exit(mrOk); + + // show the user the list of dangling events + //debugln('RemoveDanglingEvents Dangling Events: Count=',dbgs(ListOfPInstancePropInfo.Count)); + s:=''; + for i:=0 to ListOfPInstancePropInfo.Count-1 do begin + p:=PInstancePropInfo(ListOfPInstancePropInfo[i]); + PropName:=p^.PropInfo^.Name; + CurMethod:=GetMethodProp(p^.Instance,p^.PropInfo); + CurMethodName:=RootComponent.MethodName(CurMethod.Code); + s:=s+DbgSName(p^.Instance)+' '+PropName+'='+CurMethodName+#13; + end; + //debugln('RemoveDanglingEvents ',s); + + MsgResult:=QuestionDlg('Missing Events', + 'The following methods used by '+DbgSName(RootComponent) + +' are not in the source'#13 + +PascalBuffer.Filename+#13 + +#13 + +s + +#13 + +'Remove the dangling references?' + ,mtConfirmation, + [mrYes,'Remove',mrIgnore,'Keep them and continue',mrCancel],0); + if MsgResult=mrYes then begin + ClearDanglingEvents(ListOfPInstancePropInfo); + ComponentModified:=true; + end else if MsgResult=mrIgnore then + exit(mrOk) + else + exit(mrCancel); + finally + FreeListOfPInstancePropInfo(ListOfPInstancePropInfo); + end; + Result:=mrOk; +end; + +procedure ClearDanglingEvents(ListOfPInstancePropInfo: TFPList); +const + EmtpyMethod: TMethod = (code:nil; data:nil); +var + i: Integer; + p: PInstancePropInfo; +begin + if ListOfPInstancePropInfo=nil then exit; + for i:=0 to ListOfPInstancePropInfo.Count-1 do begin + p:=PInstancePropInfo(ListOfPInstancePropInfo[i]); + debugln('ClearDanglingEvents ',DbgSName(p^.Instance),' ',p^.PropInfo^.Name); + SetMethodProp(p^.Instance,p^.PropInfo,EmtpyMethod); + end; +end; + { TCheckLFMDialog } procedure TCheckLFMDialog.RemoveAllButtonClick(Sender: TObject); diff --git a/ide/main.pp b/ide/main.pp index 4d16626bd5..4bd2141452 100644 --- a/ide/main.pp +++ b/ide/main.pp @@ -509,6 +509,8 @@ type var ResourceCode: TCodeBuffer): TModalResult; function DoSaveFileResources(AnUnitInfo: TUnitInfo; ResourceCode, LFMCode: TCodeBuffer; Flags: TSaveFlags): TModalResult; + function DoRemoveDanglingEvents(AnUnitInfo: TUnitInfo; + OkOnCodeErrors: boolean): TModalResult; function DoRenameUnit(AnUnitInfo: TUnitInfo; NewFilename, NewUnitName: string; var ResourceCode: TCodeBuffer): TModalresult; @@ -3659,6 +3661,10 @@ begin // stream component to resource code and to lfm file ComponentSavingOk:=true; + // clean up component + Result:=DoRemoveDanglingEvents(AnUnitInfo,true); + if Result<>mrOk then exit; + // save designer form properties to the component FormEditor1.SaveHiddenDesignerFormProperties(AnUnitInfo.Component); @@ -3883,6 +3889,34 @@ begin {$ENDIF} end; +function TMainIDE.DoRemoveDanglingEvents(AnUnitInfo: TUnitInfo; + OkOnCodeErrors: boolean): TModalResult; +var + ComponentModified: boolean; + ActiveSrcEdit: TSourceEditor; + ActiveUnitInfo: TUnitInfo; +begin + Result:=mrOk; + if (AnUnitInfo.Component=nil) then exit; + if not BeginCodeTool(ActiveSrcEdit,ActiveUnitInfo,[]) then exit; + // unselect methods in ObjectInspector1 + if (ObjectInspector1.PropertyEditorHook.LookupRoot=AnUnitInfo.Component) then + begin + ObjectInspector1.EventGrid.ItemIndex:=-1; + ObjectInspector1.FavouriteGrid.ItemIndex:=-1; + end; + // remove dangling methods + Result:=RemoveDanglingEvents(AnUnitInfo.Component,AnUnitInfo.Source,true, + ComponentModified); + // update ObjectInspector1 + if ComponentModified + and (ObjectInspector1.PropertyEditorHook.LookupRoot=AnUnitInfo.Component) then + begin + ObjectInspector1.EventGrid.RefreshPropertyValues; + ObjectInspector1.FavouriteGrid.RefreshPropertyValues; + end; +end; + function TMainIDE.DoRenameUnit(AnUnitInfo: TUnitInfo; NewFilename, NewUnitName: string; var ResourceCode: TCodeBuffer): TModalresult; diff --git a/lcl/include/promptdialog.inc b/lcl/include/promptdialog.inc index 8433e340e1..3b43a0576d 100644 --- a/lcl/include/promptdialog.inc +++ b/lcl/include/promptdialog.inc @@ -738,71 +738,5 @@ begin end; end; - - - // included by dialogs.pp -{ - $Log$ - Revision 1.20 2005/06/03 20:58:23 mattias - fixed focussing modal forms on gtk intf - - Revision 1.19 2005/01/28 10:48:28 mattias - fixed compilation - - Revision 1.18 2005/01/27 19:03:51 mattias - added QuestionDlg - a MessageDlg with custom buttons - - Revision 1.17 2004/09/24 13:45:32 mattias - fixed TCanvas.TextRect Delphi compatible Rect and added TBarChart from Michael VC - - Revision 1.16 2004/07/15 10:43:38 mattias - added TCustomButton, TCustomBitBtn, TCustomSpeedButton - - Revision 1.15 2004/04/20 09:18:44 micha - reserve enough space for glyph on button in message dialogs - - Revision 1.14 2004/04/10 17:58:57 mattias - implemented mainunit hints for include files - - Revision 1.13 2004/03/06 17:12:19 mattias - fixed CreateBrushIndirect - - Revision 1.12 2004/03/06 16:11:27 mattias - fixed TextStyle in dialogs - - Revision 1.11 2004/02/17 00:32:25 mattias - fixed TCustomImage.DoAutoSize fixing uninitialized vars - - Revision 1.10 2003/10/16 16:43:57 ajgenius - fix opaque brush - - Revision 1.9 2003/10/15 20:33:37 ajgenius - add csForm, start fixing Style matching for syscolors and fonts - - Revision 1.8 2003/09/18 09:21:03 mattias - renamed LCLLinux to LCLIntf - - Revision 1.7 2003/08/27 08:14:37 mattias - fixed system fonts for win32 intf - - Revision 1.6 2003/07/04 10:30:02 mattias - removed unused label from Micha - - Revision 1.5 2003/06/23 09:42:09 mattias - fixes for debugging lazarus - - Revision 1.4 2003/03/25 10:45:41 mattias - reduced focus handling and improved focus setting - - Revision 1.3 2003/03/04 09:21:09 mattias - added localization for env options from Olivier - - Revision 1.2 2002/11/05 21:21:36 lazarus - MG: fixed moving button with LEFT and RIGHT in messagedlgs - - Revision 1.1 2002/10/25 10:06:34 lazarus - MG: broke interfacebase uses circles - -}