mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-07 12:18:03 +02:00
IDE: implemented parsing LCLVersion from lfm, added ResourceBaseClass to TUnitInfo and TPkgFile
git-svn-id: trunk@15106 -
This commit is contained in:
mattias
parent
bb5587c1c8
commit
5d66571b44
@ -30,7 +30,8 @@ unit LFMTrees;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, AVL_Tree, FileProcs, CodeCache, CodeAtom, TypInfo;
|
||||
Classes, SysUtils, AVL_Tree, FileProcs, BasicCodeTools, CodeCache, CodeAtom,
|
||||
TypInfo;
|
||||
|
||||
type
|
||||
{ TLFMTreeNode }
|
||||
@ -132,6 +133,7 @@ type
|
||||
public
|
||||
ValueType: TLFMValueType;
|
||||
constructor CreateVirtual; override;
|
||||
function ReadString: string;
|
||||
end;
|
||||
|
||||
|
||||
@ -238,6 +240,8 @@ type
|
||||
TLFMTree = class
|
||||
protected
|
||||
Parser: TParser;
|
||||
TokenStart: LongInt;
|
||||
function NextToken: Char;
|
||||
procedure ProcessValue;
|
||||
procedure ProcessProperty;
|
||||
procedure ProcessObject;
|
||||
@ -266,6 +270,11 @@ type
|
||||
function FindErrorAtNode(Node: TLFMTreeNode): TLFMError;
|
||||
function FindError(ErrorTypes: TLFMErrorTypes): TLFMError;
|
||||
function FirstErrorAsString: string;
|
||||
|
||||
function FindProperty(PropertyPath: string;
|
||||
ContextNode: TLFMTreeNode): TLFMPropertyNode;
|
||||
|
||||
procedure WriteDebugReport;
|
||||
end;
|
||||
|
||||
{ TLFMTrees }
|
||||
@ -301,6 +310,18 @@ const
|
||||
'EndNotFound'
|
||||
);
|
||||
|
||||
TLFMValueTypeNames: array[TLFMValueType] of string = (
|
||||
'None',
|
||||
'Integer',
|
||||
'Float',
|
||||
'String',
|
||||
'Symbol',
|
||||
'Set',
|
||||
'List',
|
||||
'Collection',
|
||||
'Binary'
|
||||
);
|
||||
|
||||
procedure FreeListOfPInstancePropInfo(List: TFPList);
|
||||
function CompareLFMTreesByLFMBuffer(Data1, Data2: Pointer): integer;
|
||||
function CompareLFMBufWithTree(Buf, Tree: Pointer): integer;
|
||||
@ -334,6 +355,7 @@ begin
|
||||
Result:=ComparePointers(Buf,TLFMTree(Tree).LFMBuffer);
|
||||
end;
|
||||
|
||||
|
||||
{ TLFMTree }
|
||||
|
||||
constructor TLFMTree.Create;
|
||||
@ -349,7 +371,8 @@ end;
|
||||
|
||||
procedure TLFMTree.Clear;
|
||||
begin
|
||||
LFMBuffer:=nil;
|
||||
// do not set LFMBuffer to nil
|
||||
TokenStart:=0;
|
||||
CurNode:=nil;
|
||||
ClearErrors;
|
||||
while Root<>nil do Root.Free;
|
||||
@ -368,6 +391,8 @@ begin
|
||||
Result:=false;
|
||||
Clear;
|
||||
if LFMBuf<>LFMBuffer then begin
|
||||
DebugLn(['TLFMTree.Parse New=',LFMBuf.Filename]);
|
||||
DebugLn(['TLFMTree.Parse Old=',LFMBuffer.Filename]);
|
||||
if Trees<>nil then
|
||||
raise Exception.Create('TLFMTree.Parse: changing LFMBuffer in Tree is not allowed');
|
||||
LFMBuffer:=LFMBuf;
|
||||
@ -466,10 +491,81 @@ begin
|
||||
if FirstError<>nil then Result:=FirstError.ErrorMessage;
|
||||
end;
|
||||
|
||||
function TLFMTree.FindProperty(PropertyPath: string; ContextNode: TLFMTreeNode
|
||||
): TLFMPropertyNode;
|
||||
var
|
||||
Node: TLFMTreeNode;
|
||||
ObjNode: TLFMObjectNode;
|
||||
p: LongInt;
|
||||
FirstPart: String;
|
||||
RestParts: String;
|
||||
begin
|
||||
if ContextNode=nil then
|
||||
Node:=Root
|
||||
else
|
||||
Node:=ContextNode.FirstChild;
|
||||
p:=System.Pos(PropertyPath,'.');
|
||||
FirstPart:=copy(PropertyPath,1,p-1);
|
||||
RestParts:=copy(PropertyPath,p+1,length(PropertyPath));
|
||||
while Node<>nil do begin
|
||||
if Node is TLFMPropertyNode then begin
|
||||
Result:=TLFMPropertyNode(Node);
|
||||
if SysUtils.CompareText(Result.CompleteName,PropertyPath)=0 then
|
||||
exit;
|
||||
end else if (Node is TLFMObjectNode)
|
||||
and (RestParts<>'') then begin
|
||||
ObjNode:=TLFMObjectNode(Node);
|
||||
if CompareIdentifierPtrs(Pointer(ObjNode.Name),Pointer(FirstPart))=0 then
|
||||
begin
|
||||
Result:=FindProperty(RestParts,ObjNode);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
Node:=Node.NextSibling;
|
||||
end;
|
||||
Result:=nil;
|
||||
end;
|
||||
|
||||
procedure TLFMTree.WriteDebugReport;
|
||||
var
|
||||
Src: string;
|
||||
|
||||
procedure WriteNode(const Prefix: string; Node: TLFMTreeNode);
|
||||
var
|
||||
Child: TLFMTreeNode;
|
||||
EndPos: LongInt;
|
||||
begin
|
||||
if Node=nil then exit;
|
||||
Child:=Node.FirstChild;
|
||||
EndPos:=Node.EndPos;
|
||||
if (Child<>nil) and (EndPos>Child.StartPos) then
|
||||
EndPos:=Child.StartPos;
|
||||
DebugLn([Prefix,dbgstr(copy(Src,Node.StartPos,EndPos-Node.StartPos))]);
|
||||
while Child<>nil do begin
|
||||
WriteNode(Prefix+' ',Child);
|
||||
Child:=Child.NextSibling;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if LFMBuffer=nil then begin
|
||||
DebugLn(['TLFMTree.WriteDebugReport LFMBuffer=nil']);
|
||||
end;
|
||||
DebugLn(['TLFMTree.WriteDebugReport ',LFMBuffer.Filename]);
|
||||
Src:=LFMBuffer.Source;
|
||||
WriteNode('',Root);
|
||||
end;
|
||||
|
||||
{$if not declared(toWString)}
|
||||
const toWString = char(5);
|
||||
{$endif}
|
||||
|
||||
function TLFMTree.NextToken: Char;
|
||||
begin
|
||||
TokenStart:=Parser.SourcePos+1;
|
||||
Result:=Parser.NextToken;
|
||||
end;
|
||||
|
||||
procedure TLFMTree.ProcessValue;
|
||||
var
|
||||
s: String;
|
||||
@ -482,7 +578,7 @@ begin
|
||||
begin
|
||||
CreateChildNode(TLFMValueNode);
|
||||
TLFMValueNode(CurNode).ValueType:=lfmvInteger;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -490,7 +586,7 @@ begin
|
||||
begin
|
||||
CreateChildNode(TLFMValueNode);
|
||||
TLFMValueNode(CurNode).ValueType:=lfmvFloat;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -498,8 +594,8 @@ begin
|
||||
begin
|
||||
CreateChildNode(TLFMValueNode);
|
||||
TLFMValueNode(CurNode).ValueType:=lfmvString;
|
||||
while Parser.NextToken = '+' do begin
|
||||
Parser.NextToken; // Get next string fragment
|
||||
while NextToken = '+' do begin
|
||||
NextToken; // Get next string fragment
|
||||
if not (Parser.Token in [toString,toWString]) then
|
||||
Parser.CheckToken(toString);
|
||||
end;
|
||||
@ -512,13 +608,13 @@ begin
|
||||
SymbolNode:=TLFMValueNodeSymbol(CurNode);
|
||||
if SymbolNode=nil then ;
|
||||
s := Parser.TokenString;
|
||||
if CompareText(s, 'End') = 0 then
|
||||
if SysUtils.CompareText(s, 'End') = 0 then
|
||||
SymbolNode.SymbolType:=lfmsNone
|
||||
else if CompareText(s, 'True') = 0 then
|
||||
else if SysUtils.CompareText(s, 'True') = 0 then
|
||||
SymbolNode.SymbolType:=lfmsTrue
|
||||
else if CompareText(s, 'False') = 0 then
|
||||
else if SysUtils.CompareText(s, 'False') = 0 then
|
||||
SymbolNode.SymbolType:=lfmsFalse
|
||||
else if CompareText(s, 'nil') = 0 then
|
||||
else if SysUtils.CompareText(s, 'nil') = 0 then
|
||||
SymbolNode.SymbolType:=lfmsNil
|
||||
else
|
||||
begin
|
||||
@ -526,7 +622,7 @@ begin
|
||||
Parser.TokenComponentIdent;
|
||||
end;
|
||||
if SymbolNode.SymbolType<>lfmsNone then
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -534,20 +630,20 @@ begin
|
||||
'[':
|
||||
begin
|
||||
CreateChildNode(TLFMValueNodeSet);
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
if Parser.Token <> ']' then
|
||||
while True do
|
||||
begin
|
||||
CreateChildNode(TLFMEnumNode);
|
||||
Parser.CheckToken(toSymbol);
|
||||
CloseChildNode;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
if Parser.Token = ']' then
|
||||
break;
|
||||
Parser.CheckToken(',');
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
end;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -555,10 +651,10 @@ begin
|
||||
'(':
|
||||
begin
|
||||
CreateChildNode(TLFMValueNodeList);
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
while Parser.Token <> ')' do
|
||||
ProcessValue;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -566,18 +662,18 @@ begin
|
||||
'<':
|
||||
begin
|
||||
CreateChildNode(TLFMValueNodeCollection);
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
while Parser.Token <> '>' do
|
||||
begin
|
||||
Parser.CheckTokenSymbol('item');
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CreateChildNode(TLFMValueNodeList);
|
||||
while not Parser.TokenSymbolIs('end') do
|
||||
ProcessProperty;
|
||||
Parser.NextToken; // Skip 'end'
|
||||
NextToken; // Skip 'end'
|
||||
CloseChildNode;
|
||||
end;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -591,7 +687,7 @@ begin
|
||||
finally
|
||||
MemStream.Free;
|
||||
end;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
CloseChildNode;
|
||||
end;
|
||||
|
||||
@ -611,14 +707,14 @@ begin
|
||||
Parser.CheckToken(toSymbol);
|
||||
PropertyNode.Add(Parser.TokenString,Parser.SourcePos+1);
|
||||
while True do begin
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
if Parser.Token <> '.' then break;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
Parser.CheckToken(toSymbol);
|
||||
PropertyNode.Add(Parser.TokenString,Parser.SourcePos+1);
|
||||
end;
|
||||
Parser.CheckToken('=');
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
ProcessValue;
|
||||
CloseChildNode;
|
||||
end;
|
||||
@ -636,7 +732,7 @@ begin
|
||||
Parser.CheckTokenSymbol('INHERITED');
|
||||
ObjectNode.IsInherited := True;
|
||||
end;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
Parser.CheckToken(toSymbol);
|
||||
if not Parser.TokenSymbolIs('END') then begin
|
||||
ObjectStartLine:=Parser.SourceLine;
|
||||
@ -644,21 +740,21 @@ begin
|
||||
ObjectNode.TypeName := Parser.TokenString;
|
||||
ObjectNode.TypeNamePosition:=Parser.SourcePos+1;
|
||||
ObjectNode.ChildPos := -1;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
if Parser.Token = ':' then begin
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
Parser.CheckToken(toSymbol);
|
||||
ObjectNode.Name := ObjectNode.TypeName;
|
||||
ObjectNode.NamePosition:=ObjectNode.TypeNamePosition;
|
||||
ObjectNode.TypeName := Parser.TokenString;
|
||||
ObjectNode.TypeNamePosition:=Parser.SourcePos+1;
|
||||
Parser.NextToken;
|
||||
NextToken;
|
||||
if parser.Token = '[' then begin
|
||||
parser.NextToken;
|
||||
NextToken;
|
||||
ObjectNode.ChildPos := parser.TokenInt;
|
||||
parser.NextToken;
|
||||
NextToken;
|
||||
parser.CheckToken(']');
|
||||
parser.NextToken;
|
||||
NextToken;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -678,7 +774,7 @@ begin
|
||||
ProcessObject;
|
||||
end;
|
||||
end;
|
||||
Parser.NextToken; // Skip 'END' token
|
||||
NextToken; // Skip 'END' token
|
||||
|
||||
CloseChildNode;
|
||||
end;
|
||||
@ -689,8 +785,8 @@ var
|
||||
begin
|
||||
NewNode:=NodeClass.CreateVirtual;
|
||||
NewNode.Tree:=Self;
|
||||
NewNode.StartPos:=Parser.SourcePos+1;
|
||||
NewNode.EndPos:=NewNode.StartPos;
|
||||
NewNode.StartPos:=TokenStart;
|
||||
NewNode.EndPos:=0;
|
||||
if CurNode<>nil then begin
|
||||
CurNode.AddChild(NewNode);
|
||||
end else begin
|
||||
@ -701,7 +797,8 @@ end;
|
||||
|
||||
procedure TLFMTree.CloseChildNode;
|
||||
begin
|
||||
CurNode.EndPos:=Parser.SourcePos+1;
|
||||
if CurNode.EndPos<1 then
|
||||
CurNode.EndPos:=TokenStart;
|
||||
CurNode:=CurNode.Parent;
|
||||
end;
|
||||
|
||||
@ -884,6 +981,34 @@ begin
|
||||
ValueType:=lfmvNone;
|
||||
end;
|
||||
|
||||
function TLFMValueNode.ReadString: string;
|
||||
var
|
||||
p: LongInt;
|
||||
Src: String;
|
||||
i: integer;
|
||||
AtomStart: LongInt;
|
||||
begin
|
||||
Result:='';
|
||||
if ValueType<>lfmvString then exit;
|
||||
p:=StartPos;
|
||||
AtomStart:=p;
|
||||
Src:=Tree.LFMBuffer.Source;
|
||||
repeat
|
||||
ReadRawNextPascalAtom(Src,p,AtomStart);
|
||||
if AtomStart>length(Src) then exit;
|
||||
if Src[AtomStart]='''' then begin
|
||||
Result:=Result+copy(Src,AtomStart+1,p-AtomStart-2)
|
||||
end else if Src[AtomStart]='+' then begin
|
||||
// skip
|
||||
end else if Src[AtomStart]='#' then begin
|
||||
i:=StrToIntDef(copy(Src,AtomStart+1,p-AtomStart-1),-1);
|
||||
if (i<0) or (i>255) then exit;
|
||||
Result:=Result+chr(i);
|
||||
end else
|
||||
exit;
|
||||
until false;
|
||||
end;
|
||||
|
||||
{ TLFMValueNodeSymbol }
|
||||
|
||||
constructor TLFMValueNodeSymbol.CreateVirtual;
|
||||
|
||||
@ -4140,7 +4140,7 @@ begin
|
||||
if ProcNode.Desc=ctnProcedureHead then
|
||||
ProcNode:=ProcNode.Parent;
|
||||
if ProcNode.Desc<>ctnProcedure then
|
||||
RaiseException('INTERNAL ERROR: TPascalParserTool.BuildSubTreeForProcHead');
|
||||
RaiseException('INTERNAL ERROR: TPascalParserTool.BuildSubTreeForProcHead with FunctionResult');
|
||||
BuildSubTreeForProcHead(ProcNode);
|
||||
FunctionResult:=ProcNode.FirstChild.FirstChild;
|
||||
if (FunctionResult<>nil) and (FunctionResult.Desc=ctnParameterList) then
|
||||
|
||||
@ -727,7 +727,7 @@ begin
|
||||
if HasDFMFile and (LFMCode=nil) then
|
||||
DebugLn('WARNING: ConvertDelphiToLazarusUnit unable to load LFMCode');
|
||||
if (LFMCode<>nil)
|
||||
and (CheckLFMBuffer(UnitCode,LFMCode,@IDEMessagesWindow.AddMsg,true,true)<>mrOk)
|
||||
and (RepairLFMBuffer(UnitCode,LFMCode,@IDEMessagesWindow.AddMsg,true,true)<>mrOk)
|
||||
then begin
|
||||
LazarusIDE.DoJumpToCompilerMessage(-1,true);
|
||||
exit(mrAbort);
|
||||
|
||||
@ -218,7 +218,7 @@ var
|
||||
|
||||
function CheckProperties: boolean;
|
||||
begin
|
||||
Result:=CheckLFMBuffer(UnitCode,LFMBuffer,nil,false,false)=mrOk;
|
||||
Result:=RepairLFMBuffer(UnitCode,LFMBuffer,nil,false,false)=mrOk;
|
||||
if not Result and (CodeToolBoss.ErrorMessage<>'') then
|
||||
MainIDEInterface.DoJumpToCodeToolBossError;
|
||||
end;
|
||||
|
||||
@ -39,7 +39,7 @@ uses
|
||||
SynHighlighterLFM, SynEdit, BasicCodeTools, CodeCache, CodeToolManager,
|
||||
LFMTrees,
|
||||
// IDE
|
||||
PropEdits, ComponentReg, PackageIntf, IDEWindowIntf,
|
||||
PropEdits, IDEDialogs, ComponentReg, PackageIntf, IDEWindowIntf,
|
||||
LazarusIDEStrConsts, OutputFilter, IDEProcs, IDEOptionDefs, EditorOptions;
|
||||
|
||||
type
|
||||
@ -77,16 +77,22 @@ type
|
||||
property LFMTree: TLFMTree read FLFMTree write SetLFMTree;
|
||||
property LFMSource: TCodeBuffer read FLFMSource write SetLFMSource;
|
||||
end;
|
||||
|
||||
function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
|
||||
|
||||
// check and repair lfm files
|
||||
function QuickCheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
|
||||
out LCLVersion: string;
|
||||
out MissingClasses: TStrings// e.g. MyFrame2:TMyFrame
|
||||
): TModalResult;
|
||||
function RepairLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
|
||||
const OnOutput: TOnAddFilteredLine;
|
||||
RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
|
||||
function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
|
||||
function RepairLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
|
||||
const OnOutput: TOnAddFilteredLine;
|
||||
RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
|
||||
function ShowRepairLFMWizard(LFMBuffer: TCodeBuffer;
|
||||
LFMTree: TLFMTree): TModalResult;
|
||||
|
||||
// dangling events
|
||||
function RemoveDanglingEvents(RootComponent: TComponent;
|
||||
PascalBuffer: TCodeBuffer; OkOnCodeErrors: boolean;
|
||||
out ComponentModified: boolean): TModalResult;
|
||||
@ -101,7 +107,42 @@ type
|
||||
NewText: string;
|
||||
end;
|
||||
|
||||
function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
|
||||
function QuickCheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer; out
|
||||
LCLVersion: string; out MissingClasses: TStrings): TModalResult;
|
||||
var
|
||||
LFMTree: TLFMTree;
|
||||
LCLVersionNode: TLFMPropertyNode;
|
||||
LCLVersionValueNode: TLFMValueNode;
|
||||
begin
|
||||
DebugLn(['QuickCheckLFMBuffer LFMBuffer=',LFMBuffer.Filename]);
|
||||
LCLVersion:='';
|
||||
MissingClasses:=nil;
|
||||
|
||||
LFMTree:=DefaultLFMTrees.GetLFMTree(LFMBuffer,true);
|
||||
if not LFMTree.ParseIfNeeded then begin
|
||||
DebugLn(['QuickCheckLFMBuffer LFM error: ',LFMTree.FirstErrorAsString]);
|
||||
exit(mrCancel);
|
||||
end;
|
||||
|
||||
//LFMTree.WriteDebugReport;
|
||||
|
||||
// first search the version
|
||||
LCLVersionNode:=LFMTree.FindProperty('LCLVersion',LFMTree.Root);
|
||||
//DebugLn(['QuickCheckLFMBuffer LCLVersionNode=',LCLVersionNode<>nil]);
|
||||
if (LCLVersionNode<>nil) and (LCLVersionNode.FirstChild is TLFMValueNode) then
|
||||
begin
|
||||
LCLVersionValueNode:=TLFMValueNode(LCLVersionNode.FirstChild);
|
||||
//DebugLn(['QuickCheckLFMBuffer ',TLFMValueTypeNames[LCLVersionValueNode.ValueType]]);
|
||||
if LCLVersionValueNode.ValueType=lfmvString then begin
|
||||
LCLVersion:=LCLVersionValueNode.ReadString;
|
||||
//DebugLn(['QuickCheckLFMBuffer LCLVersion=',LCLVersion]);
|
||||
end;
|
||||
end;
|
||||
|
||||
Result:=mrOk;
|
||||
end;
|
||||
|
||||
function RepairLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
|
||||
const OnOutput: TOnAddFilteredLine;
|
||||
RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
|
||||
var
|
||||
@ -257,7 +298,6 @@ begin
|
||||
DebugLn(['CheckLFMBuffer failed parsing unit: ',PascalBuffer.Filename]);
|
||||
exit;
|
||||
end;
|
||||
|
||||
if CodeToolBoss.CheckLFM(PascalBuffer,LFMBuffer,LFMTree,
|
||||
RootMustBeClassInIntf,ObjectsMustExists)
|
||||
then begin
|
||||
@ -274,7 +314,7 @@ begin
|
||||
Result:=ShowRepairLFMWizard(LFMBuffer,LFMTree);
|
||||
end;
|
||||
|
||||
function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
|
||||
function RepairLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
|
||||
const OnOutput: TOnAddFilteredLine;
|
||||
RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
|
||||
var
|
||||
@ -284,8 +324,8 @@ begin
|
||||
LFMBuf:=CodeToolBoss.CreateTempFile('temp.lfm');
|
||||
try
|
||||
LFMBuf.Source:=LFMText;
|
||||
Result:=CheckLFMBuffer(PascalBuffer,LFMBuf,OnOutput,RootMustBeClassInIntf,
|
||||
ObjectsMustExists);
|
||||
Result:=RepairLFMBuffer(PascalBuffer,LFMBuf,OnOutput,RootMustBeClassInIntf,
|
||||
ObjectsMustExists);
|
||||
LFMText:=LFMBuf.Source;
|
||||
finally
|
||||
CodeToolBoss.ReleaseTempFile(LFMBuf);
|
||||
|
||||
@ -5401,6 +5401,8 @@ var
|
||||
NewUnitName: String;
|
||||
AncestorUnitInfo: TUnitInfo;
|
||||
ReferencesLocked: Boolean;
|
||||
LCLVersion: string;
|
||||
MissingClasses: TStrings;
|
||||
begin
|
||||
debugln('TMainIDE.DoLoadLFM A ',AnUnitInfo.Filename,' IsPartOfProject=',dbgs(AnUnitInfo.IsPartOfProject),' ');
|
||||
|
||||
@ -5444,6 +5446,8 @@ begin
|
||||
|
||||
if AnUnitInfo.Component=nil then begin
|
||||
// load/create new instance
|
||||
|
||||
QuickCheckLFMBuffer(AnUnitInfo.Source,LFMBuf,LCLVersion,MissingClasses);
|
||||
|
||||
// find the classname of the LFM, and check for inherited form
|
||||
ReadLFMHeader(LFMBuf.Source,NewClassName,LFMType);
|
||||
@ -9924,8 +9928,8 @@ begin
|
||||
DoArrangeSourceEditorAndMessageView(false);
|
||||
|
||||
// parse the LFM file and the pascal unit
|
||||
if CheckLFMBuffer(PascalBuf,LFMUnitInfo.Source,@MessagesView.AddMsg,
|
||||
true,true)<>mrOk
|
||||
if RepairLFMBuffer(PascalBuf,LFMUnitInfo.Source,@MessagesView.AddMsg,
|
||||
true,true)<>mrOk
|
||||
then begin
|
||||
DoJumpToCompilerMessage(-1,true);
|
||||
end;
|
||||
|
||||
@ -155,7 +155,7 @@ type
|
||||
uifMarked
|
||||
);
|
||||
TUnitInfoFlags = set of TUnitInfoFlag;
|
||||
|
||||
|
||||
{ TUnitInfo }
|
||||
|
||||
TUnitInfo = class(TLazProjectFile)
|
||||
@ -165,6 +165,7 @@ type
|
||||
fBookmarks: TFileBookmarks;
|
||||
FBuildFileIfActive: boolean;
|
||||
fComponent: TComponent;
|
||||
FResourceBaseClass: TPFComponentBaseClass;
|
||||
fComponentName: string; { classname is always T<ComponentName>
|
||||
this attribute contains the component name,
|
||||
even if the unit is not loaded,
|
||||
@ -176,6 +177,7 @@ type
|
||||
FComponentLastLRSStreamSize: TStreamSeekType;
|
||||
fCursorPos: TPoint;
|
||||
fCustomHighlighter: boolean; // do not change highlighter on file extension change
|
||||
FDirectives: TStrings;
|
||||
fEditorIndex: integer;
|
||||
fFileName: string;
|
||||
fFileReadOnly: Boolean;
|
||||
@ -222,6 +224,7 @@ type
|
||||
function GetPrevUnitWithEditorIndex: TUnitInfo;
|
||||
procedure SetAutoReferenceSourceDir(const AValue: boolean);
|
||||
procedure SetBuildFileIfActive(const AValue: boolean);
|
||||
procedure SetDirectives(const AValue: TStrings);
|
||||
procedure SetEditorIndex(const AValue: integer);
|
||||
procedure SetFileReadOnly(const AValue: Boolean);
|
||||
procedure SetComponent(const AValue: TComponent);
|
||||
@ -264,12 +267,12 @@ type
|
||||
procedure IgnoreCurrentFileDateOnDisk;
|
||||
procedure IncreaseAutoRevertLock;
|
||||
procedure DecreaseAutoRevertLock;
|
||||
procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string;
|
||||
Merge: boolean);
|
||||
function ParseUnitNameFromSource(TryCache: boolean): string;
|
||||
procedure ReadUnitNameFromSource(TryCache: boolean);
|
||||
function CreateUnitName: string;
|
||||
procedure ImproveUnitNameCache(const NewUnitName: string);
|
||||
procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string;
|
||||
Merge: boolean);
|
||||
procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string;
|
||||
SaveData, SaveSession: boolean);
|
||||
procedure UpdateUsageCount(Min, IfBelowThis, IncIfBelow: extended);
|
||||
@ -315,6 +318,8 @@ type
|
||||
property ComponentName: string read fComponentName write fComponentName;
|
||||
property ComponentResourceName: string read fComponentResourceName
|
||||
write fComponentResourceName;
|
||||
property ResourceBaseClass: TPFComponentBaseClass read FResourceBaseClass
|
||||
write FResourceBaseClass;
|
||||
property ComponentLastBinStreamSize: TStreamSeekType
|
||||
read FComponentLastBinStreamSize write FComponentLastBinStreamSize;
|
||||
property ComponentLastLRSStreamSize: TStreamSeekType
|
||||
@ -324,7 +329,7 @@ type
|
||||
property CursorPos: TPoint read fCursorPos write fCursorPos; // physical (screen) position
|
||||
property CustomHighlighter: boolean
|
||||
read fCustomHighlighter write fCustomHighlighter;
|
||||
property Directives: TStrings;
|
||||
property Directives: TStrings read FDirectives write SetDirectives;
|
||||
property EditorIndex: integer read fEditorIndex write SetEditorIndex;
|
||||
property FileReadOnly: Boolean read fFileReadOnly write SetFileReadOnly;
|
||||
property FirstRequiredComponent: TUnitComponentDependency
|
||||
@ -869,14 +874,14 @@ type
|
||||
property EnableI18N: boolean read FEnableI18N write SetEnableI18N;
|
||||
property POOutputDirectory: string read FPOOutputDirectory
|
||||
write SetPOOutputDirectory;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
ResourceFileExt = '.lrs';
|
||||
|
||||
var
|
||||
Project1: TProject = nil;
|
||||
Project1: TProject = nil;// the main project
|
||||
|
||||
procedure AddCompileReasonsDiff(Tool: TCompilerDiffTool;
|
||||
const PropertyName: string; const Old, New: TCompileReasons);
|
||||
@ -1148,6 +1153,9 @@ begin
|
||||
XMLConfig.SetDeleteValue(Path+'ComponentName/Value',fComponentName,'');
|
||||
XMLConfig.SetDeleteValue(Path+'HasResources/Value',fHasResources,false);
|
||||
XMLConfig.SetDeleteValue(Path+'IsPartOfProject/Value',IsPartOfProject,false);
|
||||
XMLConfig.SetDeleteValue(Path+'ResourceBaseClass/Value',
|
||||
PFComponentBaseClassNames[FResourceBaseClass],
|
||||
PFComponentBaseClassNames[pfcbcNone]);
|
||||
AFilename:=FResourceFilename;
|
||||
if Assigned(fOnLoadSaveFilename) then
|
||||
fOnLoadSaveFilename(AFilename,false);
|
||||
@ -1198,6 +1206,8 @@ begin
|
||||
if fComponentName='' then
|
||||
fComponentName:=XMLConfig.GetValue(Path+'FormName/Value','');
|
||||
HasResources:=XMLConfig.GetValue(Path+'HasResources/Value',false);
|
||||
FResourceBaseClass:=StrToComponentBaseClass(
|
||||
XMLConfig.GetValue(Path+'ResourceBaseClass/Value',''));
|
||||
IsPartOfProject:=XMLConfig.GetValue(Path+'IsPartOfProject/Value',false);
|
||||
AFilename:=XMLConfig.GetValue(Path+'ResourceFilename/Value','');
|
||||
if (AFilename<>'') and Assigned(fOnLoadSaveFilename) then
|
||||
@ -1695,6 +1705,12 @@ begin
|
||||
SessionModified:=true;
|
||||
end;
|
||||
|
||||
procedure TUnitInfo.SetDirectives(const AValue: TStrings);
|
||||
begin
|
||||
if FDirectives=AValue then exit;
|
||||
FDirectives:=AValue;
|
||||
end;
|
||||
|
||||
procedure TUnitInfo.SetEditorIndex(const AValue: integer);
|
||||
begin
|
||||
if fEditorIndex=AValue then exit;
|
||||
@ -1717,7 +1733,10 @@ begin
|
||||
if fComponent=AValue then exit;
|
||||
fComponent:=AValue;
|
||||
UpdateList(uilWithComponent,fComponent<>nil);
|
||||
if fComponent=nil then ClearComponentDependencies;
|
||||
if fComponent=nil then
|
||||
ClearComponentDependencies
|
||||
else
|
||||
FResourceBaseClass:=GetComponentBaseClass(fComponent.ClassType);
|
||||
end;
|
||||
|
||||
procedure TUnitInfo.SetIsPartOfProject(const AValue: boolean);
|
||||
|
||||
@ -147,6 +147,25 @@ type
|
||||
const
|
||||
PkgFileUnitTypes = [pftUnit,pftVirtualUnit];
|
||||
|
||||
type
|
||||
TPFComponentBaseClass = (
|
||||
pfcbcNone, // unknown
|
||||
pfcbcForm, // is TForm
|
||||
pfcbcFrame, // is TFrame
|
||||
pfcbcDataModule // is TDataModule
|
||||
);
|
||||
|
||||
const
|
||||
PFComponentBaseClassNames: array[TPFComponentBaseClass] of string = (
|
||||
'None',
|
||||
'Form',
|
||||
'Frame',
|
||||
'DataModule'
|
||||
);
|
||||
|
||||
function StrToComponentBaseClass(const s: string): TPFComponentBaseClass;
|
||||
function GetComponentBaseClass(aClass: TClass): TPFComponentBaseClass;
|
||||
|
||||
type
|
||||
TPkgFileFlag = (
|
||||
pffHasRegisterProc, // file is unit and has a 'register' procedure
|
||||
@ -170,6 +189,7 @@ type
|
||||
fFullFilename: string;
|
||||
fFullFilenameStamp: integer;
|
||||
FPackage: TLazPackage;
|
||||
FResourceBaseClass: TPFComponentBaseClass;
|
||||
FSourceDirectoryReferenced: boolean;
|
||||
FSourceDirNeedReference: boolean;
|
||||
FUnitName: string;
|
||||
@ -204,23 +224,25 @@ type
|
||||
procedure UpdateSourceDirectoryReference;
|
||||
function GetFullFilename: string;
|
||||
public
|
||||
property Removed: boolean read FRemoved write SetRemoved;
|
||||
property AddToUsesPkgSection: boolean
|
||||
read GetAddToUsesPkgSection write SetAddToUsesPkgSection;
|
||||
property AutoReferenceSourceDir: boolean read FAutoReferenceSourceDir
|
||||
write SetAutoReferenceSourceDir;
|
||||
property ResourceBaseClass: TPFComponentBaseClass read FResourceBaseClass
|
||||
write FResourceBaseClass;
|
||||
property ComponentPriority: TComponentPriority read FComponentPriority
|
||||
write FComponentPriority;
|
||||
property Components[Index: integer]: TPkgComponent read GetComponents;// registered components
|
||||
property Directory: string read FDirectory;
|
||||
property Filename: string read FFilename write SetFilename;
|
||||
property FileType: TPkgFileType read FFileType write SetFileType;
|
||||
property Flags: TPkgFileFlags read FFlags write SetFlags;
|
||||
property HasRegisterProc: boolean
|
||||
read GetHasRegisterProc write SetHasRegisterProc;
|
||||
property AddToUsesPkgSection: boolean
|
||||
read GetAddToUsesPkgSection write SetAddToUsesPkgSection;
|
||||
property LazPackage: TLazPackage read FPackage;
|
||||
property UnitName: string read FUnitName write FUnitName;
|
||||
property ComponentPriority: TComponentPriority read FComponentPriority
|
||||
write FComponentPriority;
|
||||
property Components[Index: integer]: TPkgComponent read GetComponents;
|
||||
property Removed: boolean read FRemoved write SetRemoved;
|
||||
property SourceDirectoryReferenced: boolean read FSourceDirectoryReferenced;
|
||||
property AutoReferenceSourceDir: boolean read FAutoReferenceSourceDir
|
||||
write SetAutoReferenceSourceDir;
|
||||
property UnitName: string read FUnitName write FUnitName;
|
||||
end;
|
||||
|
||||
|
||||
@ -1109,6 +1131,25 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function StrToComponentBaseClass(const s: string): TPFComponentBaseClass;
|
||||
begin
|
||||
for Result:=low(TPFComponentBaseClass) to high(TPFComponentBaseClass) do
|
||||
if SysUtils.CompareText(PFComponentBaseClassNames[Result],s)=0 then exit;
|
||||
Result:=pfcbcNone;
|
||||
end;
|
||||
|
||||
function GetComponentBaseClass(aClass: TClass): TPFComponentBaseClass;
|
||||
begin
|
||||
Result:=pfcbcNone;
|
||||
if aClass=nil then exit;
|
||||
if aClass.InheritsFrom(TForm) then
|
||||
Result:=pfcbcForm
|
||||
else if aClass.InheritsFrom(TFrame) then
|
||||
Result:=pfcbcFrame
|
||||
else if aClass.InheritsFrom(TDataModule) then
|
||||
Result:=pfcbcDataModule;
|
||||
end;
|
||||
|
||||
function CompareLazPackageID(Data1, Data2: Pointer): integer;
|
||||
var
|
||||
Pkg1: TLazPackageID;
|
||||
@ -1541,6 +1582,8 @@ begin
|
||||
if CompareText(fUnitName,CaseInsensitiveUnitName)<>0 then
|
||||
fUnitName:=CaseInsensitiveUnitName;
|
||||
end;
|
||||
FResourceBaseClass:=StrToComponentBaseClass(
|
||||
XMLConfig.GetValue(Path+'ResourceBaseClass/Value',''));
|
||||
end;
|
||||
|
||||
procedure TPkgFile.SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string);
|
||||
@ -1557,6 +1600,9 @@ begin
|
||||
XMLConfig.SetDeleteValue(Path+'Type/Value',PkgFileTypeIdents[FileType],
|
||||
PkgFileTypeIdents[pftUnit]);
|
||||
XMLConfig.SetDeleteValue(Path+'UnitName/Value',FUnitName,'');
|
||||
XMLConfig.SetDeleteValue(Path+'ResourceBaseClass/Value',
|
||||
PFComponentBaseClassNames[FResourceBaseClass],
|
||||
PFComponentBaseClassNames[pfcbcNone]);
|
||||
end;
|
||||
|
||||
procedure TPkgFile.ConsistencyCheck;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user