paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 04:09:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

change component class dlg now works with child controls

Browse Source 
git-svn-id: trunk@5752 -
This commit is contained in:
mattias 2004-08-08 21:52:02 +00:00
parent dffc4d0999
commit c30685c57e
5 changed files with 158 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
components/codetools/codetoolmanager.pas
View File

@ -353,7 +353,8 @@ type
read FOnGetDefineProperties write FOnGetDefineProperties;
function FindLFMFileName(Code: TCodeBuffer): string;
function CheckLFM(UnitCode, LFMBuf: TCodeBuffer;
var LFMTree: TLFMTree; RootMustBeClassInIntf: boolean): boolean;
var LFMTree: TLFMTree;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
function FindNextResourceFile(Code: TCodeBuffer;
var LinkIndex: integer): TCodeBuffer;
function AddLazarusResourceHeaderComment(Code: TCodeBuffer;
@ -2032,7 +2033,8 @@ begin
end;
function TCodeToolManager.CheckLFM(UnitCode, LFMBuf: TCodeBuffer;
var LFMTree: TLFMTree; RootMustBeClassInIntf: boolean): boolean;
var LFMTree: TLFMTree; RootMustBeClassInIntf, ObjectsMustExists: boolean
): boolean;
begin
Result:=false;
{$IFDEF CTDEBUG}
@ -2041,7 +2043,7 @@ begin
if not InitCurCodeTool(UnitCode) then exit;
try
Result:=FCurCodeTool.CheckLFM(LFMBuf,LFMTree,OnGetDefineProperties,
RootMustBeClassInIntf);
RootMustBeClassInIntf,ObjectsMustExists);
except
on e: Exception do HandleException(e);
end;

207
components/codetools/stdcodetools.pas
View File

@ -117,7 +117,7 @@ type
SourceChangeCache: TSourceChangeCache): boolean;
function CheckLFM(LFMBuf: TCodeBuffer; var LFMTree: TLFMTree;
const OnGetDefineProperties: TOnGetDefineProperties;
RootMustBeClassInIntf: boolean): boolean;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
// Application.Createform statements
function FindCreateFormStatement(StartPos: integer;
@ -894,7 +894,7 @@ end;
function TStandardCodeTool.CheckLFM(LFMBuf: TCodeBuffer; var LFMTree: TLFMTree;
const OnGetDefineProperties: TOnGetDefineProperties;
RootMustBeClassInIntf: boolean): boolean;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
var
RootContext: TFindContext;
@ -932,7 +932,7 @@ var
function FindLFMIdentifier(LFMNode: TLFMTreeNode;
DefaultErrorPosition: integer;
const IdentName: string; const ClassContext: TFindContext;
SearchAlsoInDefineProperties: boolean;
SearchAlsoInDefineProperties, ErrorOnNotFound: boolean;
var IdentContext: TFindContext): boolean;
var
Params: TFindDeclarationParams;
@ -971,6 +971,14 @@ var
if IdentContext.Node<>nil then begin
Result:=true;
if (IdentContext.Node.Parent<>nil)
and (IdentContext.Node.Parent.Desc<>ctnClassPublished)
then begin
LFMTree.AddError(lfmeIdentifierNotPublished,LFMNode,
'identifier '+IdentName+' is not published',
DefaultErrorPosition);
exit;
end;
end else begin
// no node found
if SearchAlsoInDefineProperties then begin
@ -981,7 +989,7 @@ var
end;
end;
end;
if not Result then begin
if (not Result) and ErrorOnNotFound then begin
LFMTree.AddError(lfmeIdentifierNotFound,LFMNode,
'identifier '+IdentName+' not found',
DefaultErrorPosition);
@ -1039,8 +1047,45 @@ var
Result:=Result+'('+IntToStr(Caret.Y)+','+IntToStr(Caret.X)+')';
end;
function FindClassContext(const ClassName: string): TFindContext;
var
Params: TFindDeclarationParams;
Identifier: PChar;
OldInput: TFindDeclarationInput;
StartTool: TStandardCodeTool;
begin
Result:=CleanFindContext;
Params:=TFindDeclarationParams.Create;
StartTool:=Self;
Identifier:=PChar(ClassName);
try
Params.Flags:=[fdfExceptionOnNotFound,
fdfSearchInParentNodes,
fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
fdfIgnoreOverloadedProcs];
Params.ContextNode:=FindInterfaceNode;
if Params.ContextNode=nil then
Params.ContextNode:=FindMainUsesSection;
Params.SetIdentifier(StartTool,Identifier,nil);
try
Params.Save(OldInput);
if FindIdentifierInContext(Params) then begin
Params.Load(OldInput);
Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
if (Result.Node=nil) or (Result.Node.Desc<>ctnClass) then
Result:=CleanFindContext;
end;
except
// ignore search/parse errors
on E: ECodeToolError do ;
end;
finally
Params.Free;
end;
end;
procedure CheckLFMChildObject(LFMObject: TLFMObjectNode;
const ParentContext: TFindContext);
const ParentContext: TFindContext; SearchAlsoInDefineProperties: boolean);
var
LFMObjectName: String;
ChildContext: TFindContext;
@ -1058,60 +1103,80 @@ var
LFMObject.StartPos);
exit;
end;
if not FindLFMIdentifier(LFMObject,LFMObject.NamePosition,
LFMObjectName,RootContext,false,ChildContext) then exit;
if ChildContext.Node=nil then begin
// this is an extra entry, created via DefineProperties.
// There is no generic way to test such things
exit;
LFMObjectName,RootContext,SearchAlsoInDefineProperties,ObjectsMustExists,
ChildContext)
then begin
// object name not found
if ObjectsMustExists then
exit;
end;
// check if identifier is variable
if not ChildContext.Node.Desc=ctnVarDefinition then begin
LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
LFMObjectName+' is not a variable'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
exit;
end;
DefinitionNode:=ChildContext.Tool.FindTypeNodeOfDefinition(
ChildContext.Node);
if DefinitionNode=nil then begin
ChildContext.Node:=DefinitionNode;
LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
LFMObjectName+' is not a variable.'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
exit;
end;
if ObjectsMustExists or (ChildContext.Node<>nil) then begin
if ChildContext.Node=nil then begin
// this is an extra entry, created via DefineProperties.
// There is no generic way to test such things
exit;
end;
// check if variable has a compatible type
if LFMObject.TypeName<>'' then begin
VariableTypeName:=ChildContext.Tool.ExtractDefinitionNodeType(
ChildContext.Node);
if (VariableTypeName='')
or (AnsiCompareText(VariableTypeName,LFMObject.TypeName)<>0) then begin
// check if identifier is variable
if (not ChildContext.Node.Desc=ctnVarDefinition) then begin
LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
LFMObjectName+' is not a variable'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
exit;
end;
DefinitionNode:=ChildContext.Tool.FindTypeNodeOfDefinition(
ChildContext.Node);
if DefinitionNode=nil then begin
ChildContext.Node:=DefinitionNode;
LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
VariableTypeName+' expected, but '+LFMObject.TypeName+' found.'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
LFMObjectName+' is not a variable.'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
exit;
end;
// check if variable has a compatible type
if LFMObject.TypeName<>'' then begin
VariableTypeName:=ChildContext.Tool.ExtractDefinitionNodeType(
ChildContext.Node);
if (VariableTypeName='')
or (AnsiCompareText(VariableTypeName,LFMObject.TypeName)<>0) then begin
ChildContext.Node:=DefinitionNode;
LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
VariableTypeName+' expected, but '+LFMObject.TypeName+' found.'
+CreateFootNote(ChildContext),
LFMObject.NamePosition);
exit;
end;
end;
// check if variable is published
if (ChildContext.Node.Parent=nil)
or (ChildContext.Node.Parent.Desc<>ctnClassPublished) then begin
LFMTree.AddError(lfmeIdentifierNotPublished,LFMObject,
LFMObjectName+' is not published',
LFMObject.NamePosition);
exit;
end;
// find class node
ClassContext:=FindClassNodeForLFMObject(LFMObject,LFMObject.TypeNamePosition,
ChildContext.Tool,DefinitionNode);
end else begin
// try the object type
ClassContext:=FindClassContext(LFMObject.TypeName);
if ClassContext.Node=nil then begin
// object type not found
LFMTree.AddError(lfmeIdentifierNotFound,LFMObject,
'type '+LFMObject.TypeName+' not found',
LFMObject.TypeNamePosition);
exit;
end;
end;
// check if variable is published
if (ChildContext.Node.Parent=nil)
or (ChildContext.Node.Parent.Desc<>ctnClassPublished) then begin
LFMTree.AddError(lfmeIdentifierNotPublished,LFMObject,
LFMObjectName+' is not published',
LFMObject.NamePosition);
exit;
end;
// find class node
ClassContext:=FindClassNodeForLFMObject(LFMObject,LFMObject.TypeNamePosition,
ChildContext.Tool,DefinitionNode);
if ClassContext.Node=nil then exit;
// check child LFM nodes
@ -1185,7 +1250,8 @@ var
CurName:=LFMProperty.NameParts.Names[i];
if not FindLFMIdentifier(LFMProperty,
LFMProperty.NameParts.NamePositions[i],
CurName,SearchContext,true,CurPropertyContext)
CurName,SearchContext,true,true,
CurPropertyContext)
then
break;
if CurPropertyContext.Node=nil then begin
@ -1211,7 +1277,7 @@ var
case CurLFMNode.TheType of
lfmnObject:
CheckLFMChildObject(TLFMObjectNode(CurLFMNode),ClassContext);
CheckLFMChildObject(TLFMObjectNode(CurLFMNode),ClassContext,false);
lfmnProperty:
CheckLFMProperty(TLFMPropertyNode(CurLFMNode),ClassContext);
@ -1222,43 +1288,6 @@ var
Result:=true;
end;
function FindClassContext(const ClassName: string): TFindContext;
var
Params: TFindDeclarationParams;
Identifier: PChar;
OldInput: TFindDeclarationInput;
StartTool: TStandardCodeTool;
begin
Result:=CleanFindContext;
Params:=TFindDeclarationParams.Create;
StartTool:=Self;
Identifier:=PChar(ClassName);
try
Params.Flags:=[fdfExceptionOnNotFound,
fdfSearchInParentNodes,
fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
fdfIgnoreOverloadedProcs];
Params.ContextNode:=FindInterfaceNode;
if Params.ContextNode=nil then
Params.ContextNode:=FindMainUsesSection;
Params.SetIdentifier(StartTool,Identifier,nil);
try
Params.Save(OldInput);
if FindIdentifierInContext(Params) then begin
Params.Load(OldInput);
Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
if (Result.Node=nil) or (Result.Node.Desc<>ctnClass) then
Result:=CleanFindContext;
end;
except
// ignore search/parse errors
on E: ECodeToolError do ;
end;
finally
Params.Free;
end;
end;
function CheckLFMRoot(RootLFMNode: TLFMTreeNode): boolean;
var
LookupRootLFMNode: TLFMObjectNode;

5
designer/changeclassdialog.pas
View File

@ -167,7 +167,8 @@ var
end;
ComponentStream.Position:=0;
LFMBuffer.LoadFromStream(ComponentStream);
if not CodeToolBoss.CheckLFM(UnitCode,LFMBuffer,LFMTree,false) then begin
if not CodeToolBoss.CheckLFM(UnitCode,LFMBuffer,LFMTree,false,false) then
begin
debugln('ChangePersistentClass-Before--------------------------------------------');
debugln(LFMBuffer.Source);
debugln('ChangePersistentClass-Before--------------------------------------------');
@ -210,7 +211,7 @@ var
function CheckProperties: boolean;
begin
Result:=CheckLFMBuffer(UnitCode,LFMBuffer,nil,false);
Result:=CheckLFMBuffer(UnitCode,LFMBuffer,nil,false,false);
if not Result and (CodeToolBoss.ErrorMessage<>'') then
MainIDEInterface.DoJumpToCodeToolBossError;
end;

54
ide/checklfmdlg.pas
View File

@ -33,8 +33,8 @@ interface
uses
// FCL+LCL
Classes, SysUtils, Math, LResources, Forms, Controls, Graphics, Dialogs,
Buttons, StdCtrls,
Classes, SysUtils, Math, LCLProc, LResources, Forms, Controls, Graphics,
Dialogs, Buttons, StdCtrls,
// components
SynHighlighterLFM, SynEdit, BasicCodeTools, CodeCache, CodeToolManager,
LFMTrees,
@ -78,9 +78,11 @@ type
end;
function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
const OnOutput: TOnOutputString; RootMustBeClassInIntf: boolean): boolean;
const OnOutput: TOnOutputString;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
const OnOutput: TOnOutputString; RootMustBeClassInIntf: boolean): boolean;
const OnOutput: TOnOutputString;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
function ShowRepairLFMWizard(LFMBuffer: TCodeBuffer;
LFMTree: TLFMTree): boolean;
@ -95,7 +97,8 @@ type
end;
function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
const OnOutput: TOnOutputString; RootMustBeClassInIntf: boolean): boolean;
const OnOutput: TOnOutputString;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
var
LFMTree: TLFMTree;
@ -125,7 +128,7 @@ begin
LFMTree:=nil;
try
Result:=CodeToolBoss.CheckLFM(PascalBuffer,LFMBuffer,LFMTree,
RootMustBeClassInIntf);
RootMustBeClassInIntf,ObjectsMustExists);
if Result then exit;
WriteLFMErrors;
Result:=ShowRepairLFMWizard(LFMBuffer,LFMTree);
@ -135,7 +138,8 @@ begin
end;
function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
const OnOutput: TOnOutputString; RootMustBeClassInIntf: boolean): boolean;
const OnOutput: TOnOutputString;
RootMustBeClassInIntf, ObjectsMustExists: boolean): boolean;
var
LFMBuf: TCodeBuffer;
begin
@ -143,7 +147,8 @@ begin
LFMBuf:=CodeToolBoss.CreateTempFile('temp.lfm');
try
LFMBuf.Source:=LFMText;
Result:=CheckLFMBuffer(PascalBuffer,LFMBuf,OnOutput,RootMustBeClassInIntf);
Result:=CheckLFMBuffer(PascalBuffer,LFMBuf,OnOutput,RootMustBeClassInIntf,
ObjectsMustExists);
LFMText:=LFMBuf.Source;
finally
CodeToolBoss.ReleaseTempFile(LFMBuf);
@ -293,6 +298,7 @@ begin
// New and Entry intersects
if (Entry.NewText='') and (NewText='') then begin
// both are deletes => combine
debugln('TCheckLFMDialog.AddReplacement Combine Deletion: Old=',dbgs(Entry.StartPos),'-',dbgs(Entry.EndPos),' New=',dbgs(StartPos),'-',dbgs(EndPos));
StartPos:=Min(StartPos,Entry.StartPos);
EndPos:=Max(EndPos,Entry.EndPos);
end else begin
@ -304,20 +310,14 @@ begin
// combine deletions
if NewText='' then begin
for i:=0 to LFMChangeList.Count-1 do begin
for i:=LFMChangeList.Count-1 downto 0 do begin
Entry:=TLFMChangeEntry(LFMChangeList[i]);
if ((Entry.StartPos<EndPos) and (Entry.EndPos>StartPos)) then begin
// New and Entry intersects
Entry.StartPos:=Min(StartPos,Entry.StartPos);
Entry.EndPos:=Max(EndPos,Entry.EndPos);
if (i<LFMChangeList.Count-1) then begin
NextEntry:=TLFMChangeEntry(LFMChangeList[i+1]);
if NextEntry.StartPos<EndPos then begin
// next entry can be merged
LFMChangeList.Delete(i+1);
NextEntry.Free;
end;
end;
// -> remove Entry
debugln('TCheckLFMDialog.AddReplacement Intersecting Deletion: Old=',dbgs(Entry.StartPos),'-',dbgs(Entry.EndPos),' New=',dbgs(StartPos),'-',dbgs(EndPos));
LFMChangeList.Delete(i);
Entry.Free;
end;
end;
end;
@ -332,18 +332,14 @@ begin
end else begin
for i:=0 to LFMChangeList.Count-1 do begin
Entry:=TLFMChangeEntry(LFMChangeList[i]);
if Entry.StartPos>EndPos then begin
if EndPos<=Entry.StartPos then begin
// insert in front
LFMChangeList.Insert(i,NewEntry);
break;
end else begin
if (i<LFMChangeList.Count-1) then
NextEntry:=TLFMChangeEntry(LFMChangeList[i+1])
else
NextEntry:=nil;
if NextEntry.StartPos>EndPos then begin
LFMChangeList.Insert(i+1,NewEntry);
break;
end;
end else if i=LFMChangeList.Count-1 then begin
// insert behind
LFMChangeList.Add(NewEntry);
break;
end;
end;
end;

10
ide/main.pp
View File

@ -6550,7 +6550,8 @@ begin
DoArrangeSourceEditorAndMessageView(false);
// parse the LFM file and the pascal unit
if not CheckLFMBuffer(PascalBuf,LFMUnitInfo.Source,@MessagesView.AddMsg,true)
if not CheckLFMBuffer(PascalBuf,LFMUnitInfo.Source,@MessagesView.AddMsg,
true,true)
then begin
DoJumpToCompilerMessage(-1,true);
end;
@ -6637,8 +6638,8 @@ begin
if HasDFMFile and (LFMCode=nil) then
writeln('WARNING: TMainIDE.DoConvertDelphiUnit unable to load LFMCode');
if (LFMCode<>nil)
and (not CheckLFMBuffer(UnitCode,LFMCode,@MessagesView.AddMsg,true)) then
begin
and (not CheckLFMBuffer(UnitCode,LFMCode,@MessagesView.AddMsg,true,true))
then begin
DoJumpToCompilerMessage(-1,true);
exit;
end;
@ -10532,6 +10533,9 @@ end.
{ =============================================================================
$Log$
Revision 1.748 2004/08/08 21:52:01 mattias
change component class dlg now works with child controls
Revision 1.747 2004/08/08 20:51:15 mattias
replaced TDBEdit.WMKillFocus by EditingDone, Change Class basically working