paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-06 05:33:19 +02:00
Code Issues Packages Projects Releases Wiki Activity
5d85ab44f3
lazarus/components/codetools/definetemplates.pas
mattias 5d85ab44f3 implemented build lazarus extra options -d 
git-svn-id: trunk@3964 -
2003-03-26 00:21:25 +00:00

2934 lines
94 KiB
ObjectPascal
Raw Blame History

{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
This unit is a support unit for the code tools. It manages compilation
information, which is not stored in the source, like Makefile information
and compiler command line options. This information is needed to
successfully find the right units, include files, predefined variables,
etc..
The information is stored in a TDefineTree, which contains nodes of type
TDefineTemplate. Each TDefineTemplate is a tree of defines, undefines,
definerecurses, ifdefs, ifndefs, elses, elseifs, directories ... .
Simply give a TDefineTree a directory and it will return all predefined
variables for that directory. These values can be used to parse a unit in
the directory.
TDefineTree can be saved to and loaded from a XML file.
The TDefinePool contains a list of TDefineTemplate trees, and can generate
some default templates for Lazarus and FPC sources.
ToDo:
Error handling for DefinePool
}
unit DefineTemplates;
{$ifdef FPC} {$mode objfpc} {$endif}{$H+}
interface
uses
Classes, SysUtils, CodeToolsStrConsts, ExprEval
{$ifdef FPC}, Laz_XMLCfg{$endif}, AVL_Tree, Process,
KeywordFuncLists, FileProcs;
const
ExternalMacroStart = ExprEval.ExternalMacroStart;
// Standard Template Names (do not translate them)
StdDefTemplFPC = 'Free Pascal Compiler';
StdDefTemplFPCSrc = 'Free Pascal Sources';
StdDefTemplLazarusSources = 'Lazarus Sources';
StdDefTemplLazarusSrcDir = 'Lazarus Source Directory';
StdDefTemplLazarusBuildOpts = 'Build options';
StdDefTemplLCLProject = 'LCL Project';
// Standard macros
DefinePathMacroName = ExternalMacroStart+'DefinePath';
UnitPathMacroName = ExternalMacroStart+'UnitPath';
IncludePathMacroName = ExternalMacroStart+'IncPath';
SrcPathMacroName = ExternalMacroStart+'SrcPath';
// virtual directory
VirtualDirectory='VIRTUALDIRECTORY';
// FPC operating systems and processor types
FPCOperatingSystemNames: array[1..11] of shortstring =(
'linux', 'freebsd', 'win32', 'go32v1', 'go32v2', 'beos', 'os2', 'amiga',
'atari', 'sunos', 'palmos'
);
FPCOperatingSystemAlternativeNames: array[1..1] of shortstring =(
'unix'
);
FPCProcessorNames: array[1..3] of shortstring =(
'i386', 'powerpc', 'm68k'
);
type
//---------------------------------------------------------------------------
// TDefineTemplate is a list of TDefineEntry
// TDefineEntry stores a define action, the variablename and the value
TDefineAction = (
da_None,
da_Block,
da_Define,
da_DefineRecurse,
da_Undefine,
da_UndefineRecurse,
da_UndefineAll,
da_If,
da_IfDef,
da_IfNDef,
da_ElseIf,
da_Else,
da_Directory
);
const
DefineActionBlocks = [da_Block, da_Directory, da_If, da_IfDef, da_IfNDef,
da_ElseIf, da_Else];
DefineActionNames: array[TDefineAction] of string = (
'None', 'Block', 'Define', 'DefineRecurse', 'Undefine', 'UndefineRecurse',
'UndefineAll', 'If', 'IfDef', 'IfNDef', 'ElseIf', 'Else', 'Directory'
);
type
TDefineTree = class;
TDefineTemplateFlag = (dtfAutoGenerated, dtfProjectSpecific);
TDefineTemplateFlags = set of TDefineTemplateFlag;
TDefineTemplate = class
private
FChildCount: integer;
FParent: TDefineTemplate;
FNext: TDefineTemplate;
FPrior: TDefineTemplate;
FFirstChild: TDefineTemplate;
FLastChild: TDefineTemplate;
FMarked: boolean;
FChildFlags: TDefineTemplateFlags;
FParentFlags: TDefineTemplateFlags;
procedure ComputeChildFlags;
procedure ComputeParentFlags;
public
Name: string;
Description: string;
Variable: string;
Value: string;
Action: TDefineAction;
Flags: TDefineTemplateFlags;
function Level: integer;
function GetFirstSibling: TDefineTemplate;
procedure AddChild(ADefineTemplate: TDefineTemplate);
procedure InsertBehind(APrior: TDefineTemplate);
procedure InsertInFront(ANext: TDefineTemplate);
procedure Assign(ADefineTemplate: TDefineTemplate;
WithSubNodes, WithNextSiblings: boolean); virtual;
function IsEqual(ADefineTemplate: TDefineTemplate;
CheckSubNodes, CheckNextSiblings: boolean): boolean;
function CreateCopy(OnlyMarked: boolean): TDefineTemplate;
function FindRoot: TDefineTemplate;
function FindChildByName(const AName: string): TDefineTemplate;
function FindByName(const AName: string;
WithSubChilds, WithNextSiblings: boolean): TDefineTemplate;
function FindUniqueName(const Prefix: string): string;
function LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string): boolean;
procedure LoadValuesFromXMLConfig(XMLConfig: TXMLConfig; const Path: string);
procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string;
OnlyMarked, WithMergeInfo: boolean);
class procedure MergeXMLConfig(ParentDefTempl: TDefineTemplate;
var FirstSibling,LastSibling:TDefineTemplate;
XMLConfig: TXMLConfig; const Path, NewNamePrefix: string);
function SelfOrParentContainsFlag(AFlag: TDefineTemplateFlag): boolean;
function IsAutoGenerated: boolean;
function IsProjectSpecific: boolean;
procedure RemoveFlags(TheFlags: TDefineTemplateFlags);
procedure MarkGlobals;
procedure MarkProjectSpecificOnly;
procedure MarkProjectSpecificAndParents;
procedure MarkNonAutoCreated;
procedure RemoveMarked;
procedure Unbind;
procedure Clear;
constructor Create;
constructor Create(const AName, ADescription, AVariable, AValue: string;
AnAction: TDefineAction);
destructor Destroy; override;
function ConsistencyCheck: integer; // 0 = ok
procedure WriteDebugReport;
public
property ChildCount: integer read FChildCount;
property Parent: TDefineTemplate read FParent;
property Next: TDefineTemplate read FNext;
property Prior: TDefineTemplate read FPrior;
property FirstChild: TDefineTemplate read FFirstChild;
property LastChild: TDefineTemplate read FLastChild;
property Marked: boolean read FMarked write FMarked;
end;
//---------------------------------------------------------------------------
//
TDirectoryDefines = class
public
Path: string;
Values: TExpressionEvaluator;
constructor Create;
destructor Destroy; override;
end;
TOnGetVirtualDirectoryDefines = procedure(Sender: TDefineTree;
Defines: TDirectoryDefines) of object;
//---------------------------------------------------------------------------
// TDefineTree caches the define values for directories
TOnReadValue = procedure(Sender: TObject; const VariableName: string;
var Value: string) of object;
TDefineTreeSavePolicy = (
dtspAll, // save all DefineTemplates
dtspProjectSpecific, // save all (not auto) and project specific nodes
dtspGlobals // save all (not auto) and (not proj spec) nodes
);
TDefineTreeLoadPolicy = (
dtlpAll, // replace all DefineTemplates
dtlpProjectSpecific, // replace all (not auto) and project specific nodes
dtlpGlobals // replace all (not auto) and (not proj spec) nodes
);
TOnGetVirtualDirectoryAlias = procedure(Sender: TObject;
var RealDir: string) of object;
TDefineTree = class
private
FFirstDefineTemplate: TDefineTemplate;
FCache: TAVLTree; // tree of TDirectoryDefines
FChangeStep: integer;
FErrorDescription: string;
FErrorTemplate: TDefineTemplate;
FOnGetVirtualDirectoryAlias: TOnGetVirtualDirectoryAlias;
FOnGetVirtualDirectoryDefines: TOnGetVirtualDirectoryDefines;
FOnReadValue: TOnReadValue;
FVirtualDirCache: TDirectoryDefines;
function Calculate(DirDef: TDirectoryDefines): boolean;
procedure IncreaseChangeStep;
protected
function FindDirectoryInCache(const Path: string): TDirectoryDefines;
public
property RootTemplate: TDefineTemplate
read FFirstDefineTemplate write FFirstDefineTemplate;
property ChangeStep: integer read FChangeStep;
property ErrorTemplate: TDefineTemplate read FErrorTemplate;
property ErrorDescription: string read FErrorDescription;
property OnGetVirtualDirectoryAlias: TOnGetVirtualDirectoryAlias
read FOnGetVirtualDirectoryAlias write FOnGetVirtualDirectoryAlias;
property OnGetVirtualDirectoryDefines: TOnGetVirtualDirectoryDefines
read FOnGetVirtualDirectoryDefines write FOnGetVirtualDirectoryDefines;
property OnReadValue: TOnReadValue read FOnReadValue write FOnReadValue;
public
function GetDefinesForDirectory(const Path: string;
WithVirtualDir: boolean): TExpressionEvaluator;
function GetDefinesForVirtualDirectory: TExpressionEvaluator;
procedure AddFirst(ADefineTemplate: TDefineTemplate);
procedure Add(ADefineTemplate: TDefineTemplate);
function FindDefineTemplateByName(const AName: string;
OnlyRoots: boolean): TDefineTemplate;
procedure ReplaceRootSameName(const Name: string;
ADefineTemplate: TDefineTemplate);
procedure ReplaceRootSameName(ADefineTemplate: TDefineTemplate);
procedure ReplaceRootSameNameAddFirst(ADefineTemplate: TDefineTemplate);
procedure RemoveRootDefineTemplateByName(const AName: string);
procedure ReplaceChild(ParentTemplate, NewDefineTemplate: TDefineTemplate;
const ChildName: string);
function LoadFromXMLConfig(XMLConfig: TXMLConfig;
const Path: string; Policy: TDefineTreeLoadPolicy;
const NewNamePrefix: string): boolean;
function SaveToXMLConfig(XMLConfig: TXMLConfig;
const Path: string; Policy: TDefineTreeSavePolicy): boolean;
procedure ClearCache;
procedure Clear;
function IsEqual(SrcDefineTree: TDefineTree): boolean;
procedure Assign(SrcDefineTree: TDefineTree);
procedure RemoveMarked;
procedure RemoveGlobals;
procedure RemoveProjectSpecificOnly;
procedure RemoveProjectSpecificAndParents;
procedure RemoveNonAutoCreated;
function GetUnitPathForDirectory(const Directory: string): string;
function GetIncludePathForDirectory(const Directory: string): string;
function GetSrcPathForDirectory(const Directory: string): string;
function GetPPUSrcPathForDirectory(const Directory: string): string;
function GetPPWSrcPathForDirectory(const Directory: string): string;
function GetDCUSrcPathForDirectory(const Directory: string): string;
function ReadValue(const DirDef: TDirectoryDefines;
const PreValue, CurDefinePath: string): string;
constructor Create;
destructor Destroy; override;
function ConsistencyCheck: integer; // 0 = ok
procedure WriteDebugReport;
end;
//---------------------------------------------------------------------------
TDefinePool = class
private
FEnglishErrorMsgFilename: string;
FItems: TList; // list of TDefineTemplate;
function GetItems(Index: integer): TDefineTemplate;
procedure SetEnglishErrorMsgFilename(const AValue: string);
public
property Items[Index: integer]: TDefineTemplate read GetItems; default;
function Count: integer;
procedure Add(ADefineTemplate: TDefineTemplate);
procedure Insert(Index: integer; ADefineTemplate: TDefineTemplate);
procedure Delete(Index: integer);
procedure Move(SrcIndex, DestIndex: integer);
property EnglishErrorMsgFilename: string
read FEnglishErrorMsgFilename write SetEnglishErrorMsgFilename;
function CreateFPCTemplate(const PPC386Path, TestPascalFile: string;
var UnitSearchPath: string): TDefineTemplate;
function CreateFPCSrcTemplate(const FPCSrcDir,
UnitSearchPath: string;
UnitLinkListValid: boolean; var UnitLinkList: string): TDefineTemplate;
function CreateLazarusSrcTemplate(
const LazarusSrcDir, WidgetType, ExtraOptions: string): TDefineTemplate;
function CreateLCLProjectTemplate(const LazarusSrcDir, WidgetType,
ProjectDir: string): TDefineTemplate;
function CreateDelphiSrcPath(DelphiVersion: integer;
const PathPrefix: string): string;
function CreateDelphiCompilerDefinesTemplate(
DelphiVersion: integer): TDefineTemplate;
function CreateDelphiDirectoryTemplate(const DelphiDirectory: string;
DelphiVersion: integer): TDefineTemplate;
function CreateDelphiProjectTemplate(
const ProjectDir, DelphiDirectory: string;
DelphiVersion: integer): TDefineTemplate;
function CreateFPCCommandLineDefines(const Name,
CmdLine: string): TDefineTemplate;
procedure Clear;
constructor Create;
destructor Destroy; override;
function ConsistencyCheck: integer; // 0 = ok
procedure WriteDebugReport;
end;
const
DefineTemplateFlagNames: array[TDefineTemplateFlag] of shortstring = (
'AutoGenerated', 'ProjectSpecific'
);
function DefineActionNameToAction(const s: string): TDefineAction;
function DefineTemplateFlagsToString(Flags: TDefineTemplateFlags): string;
implementation
type
TUnitNameLink = class
public
UnitName: string;
Filename: string;
end;
// some useful functions
function DefineActionNameToAction(const s: string): TDefineAction;
begin
for Result:=Low(TDefineAction) to High(TDefineAction) do
if AnsiCompareText(s,DefineActionNames[Result])=0 then exit;
Result:=da_None;
end;
function DefineTemplateFlagsToString(Flags: TDefineTemplateFlags): string;
var f: TDefineTemplateFlag;
begin
Result:='';
for f:=Low(TDefineTemplateFlag) to High(TDefineTemplateFlag) do begin
if f in Flags then begin
if Result<>'' then Result:=Result+',';
Result:=Result+DefineTemplateFlagNames[f];
end;
end;
end;
function CompareUnitLinkNodes(NodeData1, NodeData2: pointer): integer;
var Link1, Link2: TUnitNameLink;
begin
Link1:=TUnitNameLink(NodeData1);
Link2:=TUnitNameLink(NodeData2);
Result:=AnsiCompareText(Link1.UnitName,Link2.UnitName);
end;
function CompareDirectoryDefines(NodeData1, NodeData2: pointer): integer;
var DirDef1, DirDef2: TDirectoryDefines;
begin
DirDef1:=TDirectoryDefines(NodeData1);
DirDef2:=TDirectoryDefines(NodeData2);
Result:=CompareFilenames(DirDef1.Path,DirDef2.Path);
end;
{ TDefineTemplate }
procedure TDefineTemplate.ComputeChildFlags;
// accumulate flags of all childs in FChildFlags
var ANode: TDefineTemplate;
begin
ANode:=Self;
while ANode<>nil do begin
ANode.FChildFlags:=[];
if ANode.FirstChild<>nil then
ANode.FirstChild.ComputeChildFlags;
if ANode.Parent<>nil then
ANode.Parent.FChildFlags:=ANode.Parent.FChildFlags
+ANode.Flags+ANode.FChildFlags;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.ComputeParentFlags;
// accumulate flags of all parents in FParentFlags
var ANode: TDefineTemplate;
begin
ANode:=Self;
while ANode<>nil do begin
if ANode.Parent<>nil then
ANode.FParentFlags:=ANode.Parent.Flags+ANode.Parent.FParentFlags
else
ANode.FParentFlags:=[];
if ANode.FirstChild<>nil then
ANode.FirstChild.ComputeParentFlags;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.MarkGlobals;
// mark every node, that itself and its parents are not auto generated and
// not project specific
var ANode: TDefineTemplate;
begin
ComputeParentFlags;
ANode:=Self;
while ANode<>nil do begin
ANode.FMarked:=((ANode.Flags+ANode.FParentFlags)
*[dtfAutoGenerated,dtfProjectSpecific]=[]);
if ANode.FirstChild<>nil then
ANode.FirstChild.MarkGlobals;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.MarkProjectSpecificOnly;
// mark every node, that itself and its parents are not auto generated and
// itself or one of its parents is project specific
var ANode: TDefineTemplate;
begin
ComputeParentFlags;
ComputeChildFlags;
ANode:=Self;
while ANode<>nil do begin
ANode.FMarked:=((ANode.Flags+ANode.FParentFlags)*[dtfAutoGenerated]=[])
and (dtfProjectSpecific in (ANode.Flags+ANode.FParentFlags));
if ANode.FirstChild<>nil then
ANode.FirstChild.MarkProjectSpecificOnly;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.MarkProjectSpecificAndParents;
// mark every node, that itself and its parents are not auto generated and
// itself or one of its parents or one of its childs is project specific
// Note: this can contain globals with project specific childs
var ANode: TDefineTemplate;
begin
ComputeParentFlags;
ComputeChildFlags;
ANode:=Self;
while ANode<>nil do begin
ANode.FMarked:=((ANode.Flags+ANode.FParentFlags)*[dtfAutoGenerated]=[])
and (dtfProjectSpecific
in (ANode.Flags+ANode.FParentFlags+ANode.FChildFlags));
if ANode.FirstChild<>nil then
ANode.FirstChild.MarkProjectSpecificAndParents;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.MarkNonAutoCreated;
// mark every node, that itself and its parent are not auto generated
var ANode: TDefineTemplate;
begin
ComputeParentFlags;
ANode:=Self;
while ANode<>nil do begin
ANode.FMarked:=not (dtfAutoGenerated in (ANode.Flags+ANode.FParentFlags));
if ANode.FirstChild<>nil then
ANode.FirstChild.MarkNonAutoCreated;
ANode:=ANode.Next;
end;
end;
procedure TDefineTemplate.RemoveMarked;
var ANode, NextNode: TDefineTemplate;
begin
ANode:=Self;
while ANode<>nil do begin
NextNode:=ANode.Next;
if ANode.FMarked then begin
ANode.Unbind;
ANode.Free;
end else begin
if ANode.FirstChild<>nil then begin
ANode.FirstChild.RemoveMarked;
end;
end;
ANode:=NextNode;
end;
end;
procedure TDefineTemplate.AddChild(ADefineTemplate: TDefineTemplate);
// add as last child
begin
if ADefineTemplate=nil then exit;
if LastChild=nil then begin
while ADefineTemplate<>nil do begin
ADefineTemplate.fParent:=Self;
if ADefineTemplate.Prior=nil then FFirstChild:=ADefineTemplate;
if ADefineTemplate.Next=nil then FLastChild:=ADefineTemplate;
inc(FChildCount);
ADefineTemplate:=ADefineTemplate.Next;
end;
end else begin
ADefineTemplate.InsertBehind(LastChild);
end;
end;
procedure TDefineTemplate.InsertBehind(APrior: TDefineTemplate);
// insert this and all next siblings behind APrior
var ANode, LastSibling, NewParent: TDefineTemplate;
begin
if APrior=nil then exit;
NewParent:=APrior.Parent;
if FParent<>nil then begin
ANode:=Self;
while ANode<>nil do begin
if ANode=APrior then
raise Exception.Create('internal error: '
+'TDefineTemplate.InsertBehind: APrior=ANode');
dec(FParent.FChildCount);
ANode.FParent:=nil;
ANode:=ANode.Next;
end;
end;
LastSibling:=Self;
while LastSibling.Next<>nil do LastSibling:=LastSibling.Next;
FParent:=NewParent;
if Parent<>nil then begin
ANode:=Self;
while (ANode<>nil) do begin
ANode.FParent:=Parent;
inc(Parent.FChildCount);
ANode:=ANode.Next;
end;
if Parent.LastChild=APrior then Parent.FLastChild:=LastSibling;
end;
FPrior:=APrior;
LastSibling.FNext:=APrior.Next;
APrior.FNext:=Self;
if LastSibling.Next<>nil then LastSibling.Next.FPrior:=LastSibling;
end;
procedure TDefineTemplate.InsertInFront(ANext: TDefineTemplate);
// insert this and all next siblings in front of ANext
var ANode, LastSibling: TDefineTemplate;
begin
if ANext=nil then exit;
if FParent<>nil then begin
ANode:=Self;
while ANode<>nil do begin
if ANode=ANext then
raise Exception.Create('internal error: '
+'TDefineTemplate.InsertInFront: ANext=ANode');
dec(FParent.FChildCount);
ANode.FParent:=nil;
ANode:=ANode.Next;
end;
end;
LastSibling:=Self;
while LastSibling.Next<>nil do LastSibling:=LastSibling.Next;
FParent:=ANext.Parent;
if Parent<>nil then begin
ANode:=Self;
while ANode<>nil do begin
ANode.FParent:=Parent;
inc(Parent.FChildCount);
ANode:=ANode.Next;
end;
if Parent.FirstChild=ANext then Parent.FFirstChild:=Self;
end;
FPrior:=ANext.Prior;
if Prior<>nil then Prior.FNext:=Self;
LastSibling.FNext:=ANext;
ANext.FPrior:=LastSibling;
end;
procedure TDefineTemplate.Assign(ADefineTemplate: TDefineTemplate;
WithSubNodes, WithNextSiblings: boolean);
var ChildTemplate, CopyTemplate, NextTemplate: TDefineTemplate;
begin
Clear;
if ADefineTemplate=nil then exit;
Name:=ADefineTemplate.Name;
Description:=ADefineTemplate.Description;
Variable:=ADefineTemplate.Variable;
Value:=ADefineTemplate.Value;
Action:=ADefineTemplate.Action;
Flags:=ADefineTemplate.Flags;
if WithSubNodes then begin
ChildTemplate:=ADefineTemplate.FirstChild;
if ChildTemplate<>nil then begin
CopyTemplate:=TDefineTemplate.Create;
AddChild(CopyTemplate);
CopyTemplate.Assign(ChildTemplate,true,true);
end;
end;
if WithNextSiblings then begin
NextTemplate:=ADefineTemplate.Next;
if NextTemplate<>nil then begin
CopyTemplate:=TDefineTemplate.Create;
CopyTemplate.InsertBehind(Self);
CopyTemplate.Assign(NextTemplate,WithSubNodes,true);
end;
end;
end;
procedure TDefineTemplate.Unbind;
begin
if FPrior<>nil then FPrior.FNext:=FNext;
if FNext<>nil then FNext.FPrior:=FPrior;
if FParent<>nil then begin
if FParent.FFirstChild=Self then FParent.FFirstChild:=FNext;
if FParent.FLastChild=Self then FParent.FLastChild:=FPrior;
dec(FParent.FChildCount);
end;
FNext:=nil;
FPrior:=nil;
FParent:=nil;
end;
procedure TDefineTemplate.Clear;
begin
while FFirstChild<>nil do FFirstChild.Free;
while FNext<>nil do FNext.Free;
Name:='';
Description:='';
Value:='';
Variable:='';
Flags:=[];
end;
constructor TDefineTemplate.Create;
begin
inherited Create;
end;
constructor TDefineTemplate.Create(const AName, ADescription, AVariable,
AValue: string; AnAction: TDefineAction);
begin
inherited Create;
Name:=AName;
Description:=ADescription;
Variable:=AVariable;
Value:=AValue;
Action:=AnAction;
end;
function TDefineTemplate.CreateCopy(OnlyMarked: boolean): TDefineTemplate;
var LastNewNode, NewNode, ANode: TDefineTemplate;
begin
Result:=nil;
LastNewNode:=nil;
ANode:=Self;
while ANode<>nil do begin
if (ANode.FMarked) or (not OnlyMarked) then begin
// copy node
NewNode:=TDefineTemplate.Create;
NewNode.Assign(ANode,true,false);
if LastNewNode<>nil then
NewNode.InsertBehind(LastNewNode)
else
Result:=NewNode;
LastNewNode:=NewNode;
// copy childs
if FirstChild<>nil then begin
NewNode:=ANode.FirstChild.CreateCopy(OnlyMarked);
if NewNode<>nil then
LastNewNode.AddChild(NewNode);
end;
end;
ANode:=ANode.Next;
end;
end;
function TDefineTemplate.FindRoot: TDefineTemplate;
begin
Result:=Self;
repeat
if Result.Parent<>nil then
Result:=Result.Parent
else if Result.Prior<>nil then
Result:=Result.Prior
else
break;
until false;
end;
destructor TDefineTemplate.Destroy;
begin
Clear;
Unbind;
inherited Destroy;
end;
function TDefineTemplate.LoadFromXMLConfig(XMLConfig: TXMLConfig;
const Path: string): boolean;
// obsolete
var IndexedPath: string;
i, LvlCount: integer;
DefTempl, LastDefTempl: TDefineTemplate;
begin
Clear;
LvlCount:=XMLConfig.GetValue(Path+'Count/Value',0);
DefTempl:=nil;
for i:=0 to LvlCount-1 do begin
if i=0 then begin
LastDefTempl:=nil;
DefTempl:=Self
end else begin
LastDefTempl:=DefTempl;
DefTempl:=TDefineTemplate.Create;
DefTempl.FPrior:=LastDefTempl;
DefTempl.FParent:=LastDefTempl.Parent;
if DefTempl.FParent<>nil then begin
DefTempl.FParent.FLastChild:=DefTempl;
inc(DefTempl.FParent.FChildCount);
end;
end;
IndexedPath:=Path+'Node'+IntToStr(i)+'/';
DefTempl.LoadValuesFromXMLConfig(XMLConfig,IndexedPath);
// load childs
if XMLConfig.GetValue(IndexedPath+'Count/Value',0)>0 then begin
FFirstChild:=TDefineTemplate.Create;
if not FFirstChild.LoadFromXMLConfig(XMLConfig,IndexedPath) then begin
Result:=false; exit;
end;
end;
end;
Result:=true;
end;
procedure TDefineTemplate.LoadValuesFromXMLConfig(XMLConfig: TXMLConfig;
const Path: string);
var f: TDefineTemplateFlag;
begin
Name:=XMLConfig.GetValue(Path+'Name/Value','no name');
Description:=XMLConfig.GetValue(Path+'Description/Value','');
Value:=XMLConfig.GetValue(Path+'Value/Value','');
Variable:=XMLConfig.GetValue(Path+'Variable/Value','');
Action:=DefineActionNameToAction(
XMLConfig.GetValue(Path+'Action/Value',''));
Flags:=[];
for f:=Low(TDefineTemplateFlag) to High(TDefineTemplateFlag) do begin
if (f<>dtfAutoGenerated)
and (XMLConfig.GetValue(Path+'Flags/'+DefineTemplateFlagNames[f],false))
then
Include(Flags,f);
end;
end;
procedure TDefineTemplate.SaveToXMLConfig(XMLConfig: TXMLConfig;
const Path: string; OnlyMarked, WithMergeInfo: boolean);
var IndexedPath, MergeNameInFront, MergeNameBehind: string;
Index, LvlCount: integer;
DefTempl: TDefineTemplate;
f: TDefineTemplateFlag;
begin
DefTempl:=Self;
LvlCount:=0;
while DefTempl<>nil do begin
inc(LvlCount);
DefTempl:=DefTempl.Next;
end;
DefTempl:=Self;
Index:=0;
repeat
if (DefTempl.FMarked) or (not OnlyMarked) then begin
// save node
inc(Index);
IndexedPath:=Path+'Node'+IntToStr(Index)+'/';
XMLConfig.SetDeleteValue(IndexedPath+'Name/Value',DefTempl.Name,'');
XMLConfig.SetDeleteValue(IndexedPath+'Description/Value',DefTempl.Description,'');
XMLConfig.SetDeleteValue(IndexedPath+'Value/Value',DefTempl.Value,'');
XMLConfig.SetDeleteValue(IndexedPath+'Variable/Value',DefTempl.Variable,'');
XMLConfig.SetDeleteValue(IndexedPath+'Action/Value',
DefineActionNames[DefTempl.Action],
DefineActionNames[da_None]);
for f:=Low(TDefineTemplateFlag) to High(TDefineTemplateFlag) do begin
if (f<>dtfAutoGenerated) then
XMLConfig.SetValue(IndexedPath+'Flags/'+DefineTemplateFlagNames[f]
,f in DefTempl.Flags);
end;
if WithMergeInfo then begin
if DefTempl.Prior<>nil then
MergeNameInFront:=DefTempl.Prior.Name
else
MergeNameInFront:='';
XMLConfig.SetValue(IndexedPath+'MergeNameInFront/Value',
MergeNameInFront);
if DefTempl.Next<>nil then
MergeNameBehind:=DefTempl.Next.Name
else
MergeNameBehind:='';
XMLConfig.SetValue(IndexedPath+'MergeNameBehind/Value',
MergeNameBehind);
end;
// save childs
if DefTempl.FFirstChild<>nil then
DefTempl.FirstChild.SaveToXMLConfig(XMLConfig,IndexedPath,
OnlyMarked,WithMergeInfo)
else
XMLConfig.SetDeleteValue(IndexedPath+'Count/Value',0,0);
end;
DefTempl:=DefTempl.Next;
until DefTempl=nil;
XMLConfig.SetDeleteValue(Path+'Count/Value',Index,0);
end;
procedure TDefineTemplate.MergeXMLConfig(ParentDefTempl: TDefineTemplate;
var FirstSibling, LastSibling: TDefineTemplate;
XMLConfig: TXMLConfig; const Path, NewNamePrefix: string);
var i, NewCount: integer;
NewNode, PosNode: TDefineTemplate;
MergeNameInFront, MergeNameBehind, IndexedPath: string;
Inserted: boolean;
begin
NewCount:=XMLConfig.GetValue(Path+'Count/Value',0);
if NewCount=0 then exit;
for i:=1 to NewCount do begin
// load each node and merge it
IndexedPath:=Path+'Node'+IntToStr(i)+'/';
NewNode:=TDefineTemplate.Create;
NewNode.LoadValuesFromXMLConfig(XMLConfig,IndexedPath);
Inserted:=false;
if NewNode.Name<>'' then begin
// node has a name -> test if already exists
PosNode:=FirstSibling;
while (PosNode<>nil)
and (AnsiCompareText(PosNode.Name,NewNode.Name)<>0) do
PosNode:=PosNode.Next;
if PosNode<>nil then begin
// node with same name already exists -> check if it is a copy
if NewNode.IsEqual(PosNode,false,false) then begin
// node already exists
NewNode.Free;
NewNode:=PosNode;
end else begin
// node has same name, but different values
// -> rename node
NewNode.Name:=NewNode.FindUniqueName(NewNamePrefix);
if (not PosNode.IsProjectSpecific) or (NewNode.IsProjectSpecific) then
begin
// insert behind PosNode
NewNode.InsertBehind(PosNode);
end else begin
// insert global NewNode in front of project specific PosNode
NewNode.InsertInFront(PosNode);
end;
end;
Inserted:=true;
end;
end;
if not Inserted then begin
// node name is unique or empty -> insert node
MergeNameInFront:=XMLConfig.GetValue(
IndexedPath+'MergeNameInFront/Value','');
if MergeNameInFront<>'' then begin
// last time, node was inserted behind MergeNameInFront
// -> search MergeNameInFront
PosNode:=LastSibling;
while (PosNode<>nil)
and (AnsiCompareText(PosNode.Name,MergeNameInFront)<>0) do
PosNode:=PosNode.Prior;
if PosNode<>nil then begin
// MergeNameInFront found -> insert behind
NewNode.InsertBehind(PosNode);
Inserted:=true;
end;
end;
if not Inserted then begin
MergeNameBehind:=XMLConfig.GetValue(
IndexedPath+'MergeNameBehind/Value','');
if MergeNameBehind<>'' then begin
// last time, node was inserted in front of MergeNameBehind
// -> search MergeNameBehind
PosNode:=FirstSibling;
while (PosNode<>nil)
and (AnsiCompareText(PosNode.Name,MergeNameBehind)<>0) do
PosNode:=PosNode.Next;
if PosNode<>nil then begin
// MergeNameBehind found -> insert in front
NewNode.InsertInFront(PosNode);
Inserted:=true;
end;
end;
end;
if not Inserted then begin
// no merge position found -> add as last
if LastSibling<>nil then begin
NewNode.InsertBehind(LastSibling);
end else if ParentDefTempl<>nil then begin
ParentDefTempl.AddChild(NewNode);
end;
end;
end;
// NewNode is now inserted -> update FirstSibling and LastSibling
if FirstSibling=nil then begin
FirstSibling:=NewNode;
LastSibling:=NewNode;
end else begin
while FirstSibling.Prior<>nil do
FirstSibling:=FirstSibling.Prior;
while LastSibling.Next<>nil do
LastSibling:=LastSibling.Next;
end;
// insert childs
MergeXMLConfig(NewNode,NewNode.FFirstChild,NewNode.FLastChild,
XMLConfig,IndexedPath,NewNamePrefix);
end;
end;
function TDefineTemplate.ConsistencyCheck: integer;
var RealChildCount: integer;
DefTempl: TDefineTemplate;
begin
RealChildCount:=0;
DefTempl:=FFirstChild;
if DefTempl<>nil then begin
if DefTempl.Prior<>nil then begin
// not first child
Result:=-2; exit;
end;
while DefTempl<>nil do begin
if DefTempl.Parent<>Self then begin
writeln(' C: ',Name,',',DefTempl.Name);
Result:=-3; exit;
end;
if (DefTempl.Next<>nil) and (DefTempl.Next.Prior<>DefTempl) then begin
Result:=-4; exit;
end;
if (DefTempl.Prior<>nil) and (DefTempl.Prior.Next<>DefTempl) then begin
Result:=-5; exit;
end;
Result:=DefTempl.ConsistencyCheck;
if Result<>0 then begin
dec(Result,100); exit;
end;
DefTempl:=DefTempl.Next;
inc(RealChildCount);
end;
end;
if (Parent<>nil) then begin
if (Prior=nil) and (Parent.FirstChild<>Self) then begin
Result:=-6; exit;
end;
if (Next=nil) and (Parent.LastChild<>Self) then begin
Result:=-7; exit;
end;
end;
if RealChildCount<>FChildCount then begin
Result:=-1; exit;
end;
Result:=0;
end;
procedure TDefineTemplate.WriteDebugReport;
procedure WriteNode(ANode: TDefineTemplate; const Prefix: string);
var ActionStr: string;
begin
if ANode=nil then exit;
ActionStr:=DefineActionNames[ANode.Action];
writeln(Prefix,'Self=',HexStr(Cardinal(ANode),8),
' Name="',ANode.Name,'"',
' Consistency=',ANode.ConsistencyCheck,
' Next=',HexStr(Cardinal(ANode.Next),8),
' Prior=',HexStr(Cardinal(ANode.Prior),8),
' Action=',ActionStr,
' Flags=[',DefineTemplateFlagsToString(ANode.Flags),']',
' FParentFlags=[',DefineTemplateFlagsToString(ANode.FParentFlags),']',
' FChildFlags=[',DefineTemplateFlagsToString(ANode.FChildFlags),']',
' Marked=',ANode.Marked
);
writeln(Prefix+' + Description="',ANode.Description,'"');
writeln(Prefix+' + Variable="',ANode.Variable,'"');
writeln(Prefix+' + Value="',ANode.Value,'"');
WriteNode(ANode.FirstChild,Prefix+' ');
WriteNode(ANode.Next,Prefix);
end;
begin
WriteNode(Self,' ');
end;
function TDefineTemplate.IsEqual(ADefineTemplate: TDefineTemplate;
CheckSubNodes, CheckNextSiblings: boolean): boolean;
var SrcNode, DestNode: TDefineTemplate;
begin
Result:=(ADefineTemplate<>nil)
and (Name=ADefineTemplate.Name)
and (Description=ADefineTemplate.Description)
and (Variable=ADefineTemplate.Variable)
and (Value=ADefineTemplate.Value)
and (Action=ADefineTemplate.Action)
and (Flags=ADefineTemplate.Flags);
if Result and CheckSubNodes then begin
if (ChildCount<>ADefineTemplate.ChildCount) then begin
Result:=false;
exit;
end;
SrcNode:=FirstChild;
DestNode:=ADefineTemplate.FirstChild;
if SrcNode<>nil then
Result:=SrcNode.IsEqual(DestNode,CheckSubNodes,true);
end;
if Result and CheckNextSiblings then begin
SrcNode:=Next;
DestNode:=ADefineTemplate.Next;
while (SrcNode<>nil) and (DestNode<>nil) do begin
Result:=SrcNode.IsEqual(DestNode,CheckSubNodes,false);
if not Result then exit;
SrcNode:=SrcNode.Next;
DestNode:=DestNode.Next;
end;
Result:=(SrcNode=nil) and (DestNode=nil);
end;
end;
function TDefineTemplate.IsAutoGenerated: boolean;
begin
Result:=SelfOrParentContainsFlag(dtfAutoGenerated);
end;
function TDefineTemplate.IsProjectSpecific: boolean;
begin
Result:=SelfOrParentContainsFlag(dtfProjectSpecific);
end;
procedure TDefineTemplate.RemoveFlags(TheFlags: TDefineTemplateFlags);
var ANode: TDefineTemplate;
begin
ANode:=Self;
while ANode<>nil do begin
Flags:=Flags-TheFlags;
if FirstChild<>nil then FirstChild.RemoveFlags(TheFlags);
ANode:=ANode.Next;
end;
end;
function TDefineTemplate.Level: integer;
var ANode: TDefineTemplate;
begin
Result:=-1;
ANode:=Self;
while ANode<>nil do begin
inc(Result);
ANode:=ANode.Parent;
end;
end;
function TDefineTemplate.GetFirstSibling: TDefineTemplate;
begin
Result:=Self;
while Result.Prior<>nil do Result:=Result.Prior;
end;
function TDefineTemplate.SelfOrParentContainsFlag(
AFlag: TDefineTemplateFlag): boolean;
var Node: TDefineTemplate;
begin
Node:=Self;
while (Node<>nil) do begin
if AFlag in Node.Flags then begin
Result:=true;
exit;
end;
Node:=Node.Parent;
end;
Result:=false;
end;
function TDefineTemplate.FindChildByName(const AName: string): TDefineTemplate;
begin
if FirstChild<>nil then begin
Result:=FirstChild.FindByName(AName,false,true)
end else
Result:=nil;
end;
function TDefineTemplate.FindByName(const AName: string; WithSubChilds,
WithNextSiblings: boolean): TDefineTemplate;
var ANode: TDefineTemplate;
begin
if AnsiCompareText(AName,Name)=0 then begin
Result:=Self;
end else begin
if WithSubChilds and (FirstChild<>nil) then
Result:=FirstChild.FindByName(AName,true,true)
else
Result:=nil;
if (Result=nil) and WithNextSiblings then begin
ANode:=Next;
while (ANode<>nil) do begin
Result:=ANode.FindByName(AName,WithSubChilds,false);
if Result<>nil then break;
ANode:=ANode.Next;
end;
end;
end;
end;
function TDefineTemplate.FindUniqueName(const Prefix: string): string;
var Root: TDefineTemplate;
i: integer;
begin
Root:=FindRoot;
i:=0;
repeat
inc(i);
Result:=Prefix+IntToStr(i);
until Root.FindByName(Result,true,true)=nil;
end;
{ TDirectoryDefines }
constructor TDirectoryDefines.Create;
begin
inherited Create;
Values:=TExpressionEvaluator.Create;
Path:='';
end;
destructor TDirectoryDefines.Destroy;
begin
Values.Free;
inherited Destroy;
end;
{ TDefineTree }
procedure TDefineTree.Clear;
begin
FFirstDefineTemplate.Free;
FFirstDefineTemplate:=nil;
ClearCache;
end;
function TDefineTree.IsEqual(SrcDefineTree: TDefineTree): boolean;
begin
Result:=false;
if SrcDefineTree=nil then exit;
if (FFirstDefineTemplate=nil) xor (SrcDefineTree.FFirstDefineTemplate=nil)
then exit;
if (FFirstDefineTemplate<>nil)
and (not FFirstDefineTemplate.IsEqual(
SrcDefineTree.FFirstDefineTemplate,true,true))
then exit;
Result:=true;
end;
procedure TDefineTree.Assign(SrcDefineTree: TDefineTree);
begin
if IsEqual(SrcDefineTree) then exit;
Clear;
if SrcDefineTree.FFirstDefineTemplate<>nil then begin
FFirstDefineTemplate:=TDefineTemplate.Create;
FFirstDefineTemplate.Assign(SrcDefineTree.FFirstDefineTemplate,true,true);
end;
end;
procedure TDefineTree.ClearCache;
begin
if (FCache.Count=0) and (FVirtualDirCache=nil) then exit;
FCache.FreeAndClear;
FVirtualDirCache.Free;
FVirtualDirCache:=nil;
IncreaseChangeStep;
end;
constructor TDefineTree.Create;
begin
inherited Create;
FFirstDefineTemplate:=nil;
FCache:=TAVLTree.Create(@CompareDirectoryDefines);
end;
destructor TDefineTree.Destroy;
begin
Clear;
FCache.Free;
inherited Destroy;
end;
function TDefineTree.FindDirectoryInCache(
const Path: string): TDirectoryDefines;
var cmp: integer;
ANode: TAVLTreeNode;
begin
ANode:=FCache.Root;
while (ANode<>nil) do begin
cmp:=CompareFilenames(Path,TDirectoryDefines(ANode.Data).Path);
if cmp<0 then
ANode:=ANode.Left
else if cmp>0 then
ANode:=ANode.Right
else
break;
end;
if ANode<>nil then
Result:=TDirectoryDefines(ANode.Data)
else
Result:=nil;
end;
procedure TDefineTree.RemoveMarked;
var NewFirstNode: TDefineTemplate;
begin
if FFirstDefineTemplate=nil then exit;
NewFirstNode:=FFirstDefineTemplate;
while (NewFirstNode<>nil) and NewFirstNode.Marked do
NewFirstNode:=NewFirstNode.Next;
FFirstDefineTemplate.RemoveMarked;
FFirstDefineTemplate:=NewFirstNode;
ClearCache;
end;
procedure TDefineTree.RemoveGlobals;
begin
if FFirstDefineTemplate=nil then exit;
FFirstDefineTemplate.MarkGlobals;
RemoveMarked;
end;
procedure TDefineTree.RemoveProjectSpecificOnly;
begin
if FFirstDefineTemplate=nil then exit;
FFirstDefineTemplate.MarkProjectSpecificOnly;
RemoveMarked;
end;
procedure TDefineTree.RemoveProjectSpecificAndParents;
begin
if FFirstDefineTemplate=nil then exit;
FFirstDefineTemplate.MarkProjectSpecificAndParents;
RemoveMarked;
end;
procedure TDefineTree.RemoveNonAutoCreated;
begin
if FFirstDefineTemplate=nil then exit;
FFirstDefineTemplate.MarkNonAutoCreated;
RemoveMarked;
end;
function TDefineTree.GetUnitPathForDirectory(const Directory: string): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[UnitPathMacroName];
end else begin
Result:='';
end;
end;
function TDefineTree.GetIncludePathForDirectory(const Directory: string
): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[IncludePathMacroName];
end else begin
Result:='';
end;
end;
function TDefineTree.GetSrcPathForDirectory(const Directory: string): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[SrcPathMacroName];
end else begin
Result:='';
end;
end;
function TDefineTree.GetPPUSrcPathForDirectory(const Directory: string
): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[ExternalMacroStart+'PPUSrcPath'];
end else begin
Result:='';
end;
end;
function TDefineTree.GetPPWSrcPathForDirectory(const Directory: string
): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[ExternalMacroStart+'PPWSrcPath'];
end else begin
Result:='';
end;
end;
function TDefineTree.GetDCUSrcPathForDirectory(const Directory: string
): string;
var ExprEval: TExpressionEvaluator;
begin
ExprEval:=GetDefinesForDirectory(Directory,true);
if ExprEval<>nil then begin
Result:=ExprEval.Variables[ExternalMacroStart+'DCUSrcPath'];
end else begin
Result:='';
end;
end;
function TDefineTree.GetDefinesForDirectory(
const Path: string; WithVirtualDir: boolean): TExpressionEvaluator;
var ExpPath: string;
DirDef: TDirectoryDefines;
begin
//writeln('[TDefineTree.GetDefinesForDirectory] "',Path,'"');
if (Path<>'') or (not WithVirtualDir) then begin
ExpPath:=Path;
if (ExpPath<>'') and (ExpPath[length(ExpPath)]<>PathDelim) then
ExpPath:=ExpPath+PathDelim;
DirDef:=FindDirectoryInCache(ExpPath);
if DirDef<>nil then begin
Result:=DirDef.Values;
end else begin
DirDef:=TDirectoryDefines.Create;
DirDef.Path:=ExpPath;
//writeln('[TDefineTree.GetDefinesForDirectory] B ',ExpPath,' ');
if Calculate(DirDef) then begin
FCache.Add(DirDef);
Result:=DirDef.Values;
end else begin
DirDef.Free;
Result:=nil;
end;
end;
end else begin
Result:=GetDefinesForVirtualDirectory;
end;
end;
function TDefineTree.GetDefinesForVirtualDirectory: TExpressionEvaluator;
begin
if FVirtualDirCache<>nil then
Result:=FVirtualDirCache.Values
else begin
//writeln('################ TDefineTree.GetDefinesForVirtualDirectory');
FVirtualDirCache:=TDirectoryDefines.Create;
FVirtualDirCache.Path:=VirtualDirectory;
if Calculate(FVirtualDirCache) then begin
Result:=FVirtualDirCache.Values;
//writeln('TDefineTree.GetDefinesForVirtualDirectory ',Result.AsString);
end else begin
FVirtualDirCache.Free;
FVirtualDirCache:=nil;
Result:=nil;
end;
end;
end;
function TDefineTree.ReadValue(const DirDef: TDirectoryDefines;
const PreValue, CurDefinePath: string): string;
// replace variables of the form $() and functions of the form $name()
// replace SpecialChar
function SearchBracketClose(const s: string; Position:integer): integer;
var BracketClose:char;
begin
if s[Position]='(' then BracketClose:=')'
else BracketClose:='{';
inc(Position);
while (Position<=length(s)) and (s[Position]<>BracketClose) do begin
if s[Position]=SpecialChar then
inc(Position)
else if (s[Position] in ['(','{']) then
Position:=SearchBracketClose(s,Position);
inc(Position);
end;
Result:=Position;
end;
function ExecuteMacroFunction(const FuncName, Params: string): string;
var UpFuncName, Ext: string;
begin
UpFuncName:=UpperCaseStr(FuncName);
if UpFuncName='EXT' then begin
Result:=ExtractFileExt(Params);
end else if UpFuncName='PATH' then begin
Result:=ExtractFilePath(Params);
end else if UpFuncName='NAME' then begin
Result:=ExtractFileName(Params);
end else if UpFuncName='NAMEONLY' then begin
Result:=ExtractFileName(Params);
Ext:=ExtractFileExt(Result);
Result:=copy(Result,1,length(Result)-length(Ext));
end else
Result:='<'+Format(ctsUnknownFunction,[FuncName])+'>';
end;
// function ReadValue(const PreValue, CurDefinePath: string): string;
var MacroStart,MacroEnd: integer;
MacroFuncName, MacroStr, MacroParam: string;
begin
// writeln(' [ReadValue] A "',PreValue,'"');
Result:=PreValue;
MacroStart:=1;
while MacroStart<=length(Result) do begin
// search for macro
while (MacroStart<=length(Result)) and (Result[MacroStart]<>'$') do begin
if (Result[MacroStart]=SpecialChar) then inc(MacroStart);
inc(MacroStart);
end;
if MacroStart>length(Result) then break;
// read macro function name
MacroEnd:=MacroStart+1;
while (MacroEnd<=length(Result))
and (Result[MacroEnd] in ['a'..'z','A'..'Z','0'..'9','_']) do
inc(MacroEnd);
MacroFuncName:=copy(Result,MacroStart+1,MacroEnd-MacroStart-1);
// read macro name / parameters
if (MacroEnd<length(Result)) and (Result[MacroEnd] in ['(','{']) then
begin
MacroEnd:=SearchBracketClose(Result,MacroEnd)+1;
if MacroEnd>length(Result)+1 then break;
MacroStr:=copy(Result,MacroStart,MacroEnd-MacroStart);
// Macro found
if MacroFuncName<>'' then begin
// Macro function -> substitute macro parameter first
MacroParam:=ReadValue(DirDef,copy(MacroStr,length(MacroFuncName)+3
,length(MacroStr)-length(MacroFuncName)-3),CurDefinePath);
// execute the macro function
MacroStr:=ExecuteMacroFunction(MacroFuncName,MacroParam);
end else begin
// Macro variable
MacroStr:=copy(Result,MacroStart+2,MacroEnd-MacroStart-3);
//writeln('**** MacroStr=',MacroStr);
//writeln('DirDef.Values=',DirDef.Values.AsString);
if MacroStr=DefinePathMacroName then begin
MacroStr:=CurDefinePath;
end else begin
if DirDef.Values.IsDefined(MacroStr) then
MacroStr:=DirDef.Values.Variables[MacroStr]
else if Assigned(FOnReadValue) then begin
MacroParam:=MacroStr;
MacroStr:='';
FOnReadValue(Self,MacroParam,MacroStr);
end else
MacroStr:='';
end;
//writeln('**** Result MacroStr=',MacroStr);
end;
Result:=copy(Result,1,MacroStart-1)+MacroStr
+copy(Result,MacroEnd,length(Result)-MacroEnd+1);
MacroEnd:=MacroStart+length(MacroStr);
end;
MacroStart:=MacroEnd;
end;
//writeln(' [ReadValue] END "',Result,'"');
end;
function TDefineTree.Calculate(DirDef: TDirectoryDefines): boolean;
// calculates the values for a single directory
// returns false on error
var
ExpandedDirectory, EvalResult: string;
procedure CalculateTemplate(DefTempl: TDefineTemplate; const CurPath: string);
procedure CalculateIfChilds;
begin
// execute childs
CalculateTemplate(DefTempl.FirstChild,CurPath);
// jump to end of else templates
DefTempl:=DefTempl.Next;
while (DefTempl<>nil) and (DefTempl.Action in [da_Else,da_ElseIf])
do
DefTempl:=DefTempl.Next;
if DefTempl=nil then exit;
end;
// procedure CalculateTemplate(DefTempl: TDefineTemplate; const CurPath: string);
var SubPath: string;
begin
while DefTempl<>nil do begin
//writeln(' [CalculateTemplate] CurPath="',CurPath,'" DefTempl.Name="',DefTempl.Name,'"');
case DefTempl.Action of
da_Block:
// calculate children
CalculateTemplate(DefTempl.FirstChild,CurPath);
da_Define:
// Define for a single Directory (not SubDirs)
if FilenameIsMatching(CurPath,ExpandedDirectory,true) then begin
DirDef.Values.Variables[DefTempl.Variable]:=
ReadValue(DirDef,DefTempl.Value,CurPath);
end;
da_DefineRecurse:
// Define for current and sub directories
DirDef.Values.Variables[DefTempl.Variable]:=
ReadValue(DirDef,DefTempl.Value,CurPath);
da_Undefine:
// Undefine for a single Directory (not SubDirs)
if FilenameIsMatching(CurPath,ExpandedDirectory,true) then begin
DirDef.Values.Undefine(DefTempl.Variable);
end;
da_UndefineRecurse:
// Undefine for current and sub directories
DirDef.Values.Undefine(DefTempl.Variable);
da_UndefineAll:
// Undefine every value for current and sub directories
DirDef.Values.Clear;
da_If, da_ElseIf:
begin
// test expression in value
EvalResult:=DirDef.Values.Eval(
ReadValue(DirDef,DefTempl.Value,CurPath));
if DirDef.Values.ErrorPosition>=0 then begin
FErrorDescription:=Format(ctsSyntaxErrorInExpr,
[ReadValue(DirDef,DefTempl.Value,CurPath)]);
FErrorTemplate:=DefTempl;
end else if EvalResult='1' then
CalculateIfChilds;
end;
da_IfDef:
// test if variable is defined
if DirDef.Values.IsDefined(DefTempl.Variable) then
CalculateIfChilds;
da_IfNDef:
// test if variable is not defined
if not DirDef.Values.IsDefined(DefTempl.Variable) then
CalculateIfChilds;
da_Else:
// execute childs
CalculateTemplate(DefTempl.FirstChild,CurPath);
da_Directory:
begin
// template for a sub directory
{$ifdef win32}
if CurPath='' then
SubPath:=ReadValue(DirDef,DefTempl.Value,CurPath)
else
{$endif}
SubPath:=CurPath+PathDelim+ReadValue(DirDef,DefTempl.Value,CurPath);
// test if ExpandedDirectory is part of SubPath
if FilenameIsMatching(SubPath,ExpandedDirectory,false) then
CalculateTemplate(DefTempl.FirstChild,SubPath);
end;
end;
if ErrorTemplate<>nil then exit;
if DefTempl<>nil then
DefTempl:=DefTempl.Next;
end;
end;
// function TDefineTree.Calculate(DirDef: TDirectoryDefines): boolean;
begin
//writeln('[TDefineTree.Calculate] "',DirDef.Path,'"');
Result:=true;
FErrorTemplate:=nil;
ExpandedDirectory:=DirDef.Path;
if (ExpandedDirectory=VirtualDirectory)
and Assigned(OnGetVirtualDirectoryAlias) then
OnGetVirtualDirectoryAlias(Self,ExpandedDirectory);
if (ExpandedDirectory<>VirtualDirectory) then
ExpandedDirectory:=ReadValue(DirDef,ExpandedDirectory,'');
DirDef.Values.Clear;
// compute the result of all matching DefineTemplates
CalculateTemplate(FFirstDefineTemplate,'');
if (ExpandedDirectory=VirtualDirectory)
and (Assigned(OnGetVirtualDirectoryDefines)) then
OnGetVirtualDirectoryDefines(Self,DirDef);
Result:=(ErrorTemplate=nil);
end;
procedure TDefineTree.IncreaseChangeStep;
begin
if FChangeStep<>$7fffffff then
inc(FChangeStep)
else
FChangeStep:=-$7fffffff;
end;
function TDefineTree.LoadFromXMLConfig(XMLConfig: TXMLConfig;
const Path: string; Policy: TDefineTreeLoadPolicy;
const NewNamePrefix: string): boolean;
var LastDefTempl: TDefineTemplate;
begin
case Policy of
dtlpGlobals:
begin
// replace globals
RemoveGlobals;
end;
dtlpProjectSpecific:
begin
// replace project specific
RemoveProjectSpecificOnly;
end;
else
begin
// replace all
FreeAndNil(FFirstDefineTemplate);
end;
end;
// import new defines
ClearCache;
LastDefTempl:=FFirstDefineTemplate;
if LastDefTempl<>nil then begin
while LastDefTempl.Next<>nil do
LastDefTempl:=LastDefTempl.Next;
end;
TDefineTemplate.MergeXMLConfig(nil,FFirstDefineTemplate,LastDefTempl,
XMLConfig,Path,NewNamePrefix);
Result:=true;
end;
function TDefineTree.SaveToXMLConfig(XMLConfig: TXMLConfig;
const Path: string; Policy: TDefineTreeSavePolicy): boolean;
begin
if FFirstDefineTemplate=nil then begin
XMLConfig.SetDeleteValue(Path+'Count/Value',0,0);
exit;
end;
case Policy of
dtspProjectSpecific:
begin
FFirstDefineTemplate.MarkProjectSpecificAndParents;
FFirstDefineTemplate.SaveToXMLConfig(XMLConfig,Path,true,true);
end;
dtspGlobals:
begin
FFirstDefineTemplate.MarkGlobals;
FFirstDefineTemplate.SaveToXMLConfig(XMLConfig,Path,true,true);
end;
else
FFirstDefineTemplate.SaveToXMLConfig(XMLConfig,Path,false,false);
end;
Result:=true;
end;
procedure TDefineTree.Add(ADefineTemplate: TDefineTemplate);
// add as last
var LastDefTempl: TDefineTemplate;
begin
if ADefineTemplate=nil then exit;
if RootTemplate=nil then
RootTemplate:=ADefineTemplate
else begin
// add as last
LastDefTempl:=RootTemplate;
while LastDefTempl.Next<>nil do
LastDefTempl:=LastDefTempl.Next;
ADefineTemplate.InsertBehind(LastDefTempl);
end;
ClearCache;
end;
procedure TDefineTree.AddFirst(ADefineTemplate: TDefineTemplate);
// add as first
begin
if ADefineTemplate=nil then exit;
if RootTemplate=nil then
RootTemplate:=ADefineTemplate
else begin
RootTemplate.InsertBehind(ADefineTemplate);
RootTemplate:=ADefineTemplate;
end;
ClearCache;
end;
function TDefineTree.FindDefineTemplateByName(
const AName: string; OnlyRoots: boolean): TDefineTemplate;
begin
Result:=RootTemplate;
if RootTemplate<>nil then
Result:=RootTemplate.FindByName(AName,not OnlyRoots,true)
else
Result:=nil;
end;
procedure TDefineTree.ReplaceRootSameName(const Name: string;
ADefineTemplate: TDefineTemplate);
// if there is a DefineTemplate with the same name then replace it
// else add as last
var OldDefineTemplate: TDefineTemplate;
begin
if (Name='') then exit;
OldDefineTemplate:=FindDefineTemplateByName(Name,true);
if OldDefineTemplate<>nil then begin
if not OldDefineTemplate.IsEqual(ADefineTemplate,true,false) then begin
ClearCache;
end;
if ADefineTemplate<>nil then
ADefineTemplate.InsertBehind(OldDefineTemplate);
if OldDefineTemplate=FFirstDefineTemplate then
FFirstDefineTemplate:=FFirstDefineTemplate.Next;
OldDefineTemplate.Unbind;
OldDefineTemplate.Free;
end else
Add(ADefineTemplate);
end;
procedure TDefineTree.RemoveRootDefineTemplateByName(const AName: string);
var ADefTempl: TDefineTemplate;
begin
ADefTempl:=FindDefineTemplateByName(AName,true);
if ADefTempl<>nil then begin
if ADefTempl=FFirstDefineTemplate then
FFirstDefineTemplate:=FFirstDefineTemplate.Next;
ADefTempl.Unbind;
ADefTempl.Free;
end;
end;
procedure TDefineTree.ReplaceChild(ParentTemplate,
NewDefineTemplate: TDefineTemplate; const ChildName: string);
// if there is a DefineTemplate with the same name then replace it
// else add as last
var OldDefineTemplate: TDefineTemplate;
begin
if (ChildName='') or (ParentTemplate=nil) then exit;
OldDefineTemplate:=ParentTemplate.FindChildByName(ChildName);
if OldDefineTemplate<>nil then begin
if not OldDefineTemplate.IsEqual(NewDefineTemplate,true,false) then begin
ClearCache;
end;
if NewDefineTemplate<>nil then
NewDefineTemplate.InsertBehind(OldDefineTemplate);
if OldDefineTemplate=FFirstDefineTemplate then
FFirstDefineTemplate:=FFirstDefineTemplate.Next;
OldDefineTemplate.Unbind;
OldDefineTemplate.Free;
end else begin
ClearCache;
ParentTemplate.AddChild(NewDefineTemplate);
end;
end;
procedure TDefineTree.ReplaceRootSameName(ADefineTemplate: TDefineTemplate);
begin
if (ADefineTemplate=nil) then exit;
ReplaceRootSameName(ADefineTemplate.Name,ADefineTemplate);
end;
procedure TDefineTree.ReplaceRootSameNameAddFirst(
ADefineTemplate: TDefineTemplate);
var OldDefineTemplate: TDefineTemplate;
begin
if ADefineTemplate=nil then exit;
OldDefineTemplate:=FindDefineTemplateByName(ADefineTemplate.Name,true);
if OldDefineTemplate<>nil then begin
if not OldDefineTemplate.IsEqual(ADefineTemplate,true,false) then begin
ClearCache;
end;
ADefineTemplate.InsertBehind(OldDefineTemplate);
if OldDefineTemplate=FFirstDefineTemplate then
FFirstDefineTemplate:=FFirstDefineTemplate.Next;
OldDefineTemplate.Unbind;
OldDefineTemplate.Free;
end else
AddFirst(ADefineTemplate);
end;
function TDefineTree.ConsistencyCheck: integer;
begin
if FFirstDefineTemplate<>nil then begin
Result:=FFirstDefineTemplate.ConsistencyCheck;
if Result<>0 then begin
dec(Result,1000); exit;
end;
end;
Result:=FCache.ConsistencyCheck;
if Result<>0 then begin
dec(Result,2000); exit;
end;
Result:=0;
end;
procedure TDefineTree.WriteDebugReport;
begin
writeln('TDefineTree.WriteDebugReport Consistency=',ConsistencyCheck);
if FFirstDefineTemplate<>nil then
FFirstDefineTemplate.WriteDebugReport
else
writeln(' No templates defined');
writeln(FCache.ReportAsString);
writeln('');
end;
{ TDefinePool }
constructor TDefinePool.Create;
begin
inherited Create;
FItems:=TList.Create;
end;
destructor TDefinePool.Destroy;
begin
Clear;
FItems.Free;
inherited Destroy;
end;
procedure TDefinePool.Clear;
var i: integer;
begin
for i:=0 to Count-1 do Items[i].Free;
FItems.Clear;
end;
function TDefinePool.GetItems(Index: integer): TDefineTemplate;
begin
Result:=TDefineTemplate(FItems[Index]);
end;
procedure TDefinePool.SetEnglishErrorMsgFilename(const AValue: string);
begin
if FEnglishErrorMsgFilename=AValue then exit;
FEnglishErrorMsgFilename:=AValue;
end;
procedure TDefinePool.Add(ADefineTemplate: TDefineTemplate);
begin
if ADefineTemplate<>nil then
FItems.Add(ADefineTemplate);
end;
procedure TDefinePool.Insert(Index: integer; ADefineTemplate: TDefineTemplate);
begin
FItems.Insert(Index,ADefineTemplate);
end;
procedure TDefinePool.Delete(Index: integer);
begin
Items[Index].Free;
FItems.Delete(Index);
end;
procedure TDefinePool.Move(SrcIndex, DestIndex: integer);
begin
FItems.Move(SrcIndex,DestIndex);
end;
function TDefinePool.Count: integer;
begin
Result:=FItems.Count;
end;
function TDefinePool.CreateFPCTemplate(
const PPC386Path, TestPascalFile: string;
var UnitSearchPath: string): TDefineTemplate;
// create symbol definitions for the freepascal compiler
// To get reliable values the compiler itself is asked for
var
LastDefTempl: TDefineTemplate;
ShortTestFile: string;
procedure AddTemplate(NewDefTempl: TDefineTemplate);
begin
if NewDefTempl=nil then exit;
if LastDefTempl<>nil then
NewDefTempl.InsertBehind(LastDefTempl);
LastDefTempl:=NewDefTempl;
end;
function FindSymbol(const SymbolName: string): TDefineTemplate;
begin
Result:=LastDefTempl;
while (Result<>nil)
and (AnsiComparetext(Result.Variable,SymbolName)<>0) do
Result:=Result.Prior;
end;
procedure DefineSymbol(const SymbolName, SymbolValue: string);
var NewDefTempl: TDefineTemplate;
begin
NewDefTempl:=FindSymbol(SymbolName);
if NewDefTempl=nil then begin
NewDefTempl:=TDefineTemplate.Create('Define '+SymbolName,
ctsDefaultppc386Symbol,SymbolName,'',da_DefineRecurse);
AddTemplate(NewDefTempl);
end else begin
NewDefTempl.Value:=SymbolValue;
end;
end;
procedure UndefineSymbol(const SymbolName: string);
var
ADefTempl: TDefineTemplate;
begin
ADefTempl:=FindSymbol(SymbolName);
if ADefTempl=nil then exit;
if LastDefTempl=ADefTempl then LastDefTempl:=ADefTempl.Prior;
ADefTempl.Free;
end;
procedure ProcessOutputLine(var Line: string);
var
SymbolName, SymbolValue, UpLine: string;
i: integer;
begin
UpLine:=UpperCaseStr(Line);
i:=length(ShortTestFile);
if (length(Line)>i)
and (AnsiCompareText(LeftStr(Line,i),ShortTestFile)=0)
and (Line[i+1]='(') then begin
inc(i);
while (i<length(Line)) and (Line[i]<>')') do inc(i);
inc(i);
while (i<length(Line)) and (Line[i]=' ') do inc(i);
if (i<=length(Line)) then begin
System.Delete(Line,1,i-1);
System.Delete(UpLine,1,i-1);
end;
end;
if copy(UpLine,1,15)='MACRO DEFINED: ' then begin
SymbolName:=copy(UpLine,16,length(Line)-15);
DefineSymbol(SymbolName,'');
end else if copy(UpLine,1,17)='MACRO UNDEFINED: ' then begin
SymbolName:=copy(UpLine,18,length(Line)-17);
UndefineSymbol(SymbolName);
end else if copy(UpLine,1,6)='MACRO ' then begin
System.Delete(Line,1,6);
System.Delete(UpLine,1,6);
i:=1;
while (i<=length(Line)) and (Line[i]<>' ') do inc(i);
SymbolName:=copy(UpLine,1,i-1);
inc(i); // skip '='
System.Delete(Line,1,i-1);
System.Delete(UpLine,1,i-1);
if copy(UpLine,1,7)='SET TO ' then begin
SymbolValue:=copy(Line,8,length(Line)-7);
DefineSymbol(SymbolName,SymbolValue);
end;
end else if copy(UpLine,1,17)='USING UNIT PATH: ' then begin
UnitSearchPath:=UnitSearchPath+copy(Line,18,length(Line)-17)+#13;
end;
end;
// function TDefinePool.CreateFPCTemplate(
// const PPC386Path: string): TDefineTemplate;
var CmdLine: string;
i, OutLen, LineStart: integer;
TheProcess : TProcess;
OutputLine, Buf, TargetOS, SrcOS, TargetProcessor: String;
NewDefTempl: TDefineTemplate;
begin
Result:=nil;
UnitSearchPath:='';
if (PPC386Path='') or (not FileIsExecutable(PPC386Path)) then exit;
LastDefTempl:=nil;
// find all initial compiler macros and all unit paths
// -> ask compiler with the -va switch
SetLength(Buf,1024);
try
CmdLine:=PPC386Path+' -va ';
if FileExists(EnglishErrorMsgFilename) then
CmdLine:=CmdLine+'-Fr'+EnglishErrorMsgFilename+' ';
CmdLine:=CmdLine+TestPascalFile;
ShortTestFile:=ExtractFileName(TestPascalFile);
TheProcess := TProcess.Create(nil);
TheProcess.CommandLine := CmdLine;
TheProcess.Options:= [poUsePipes, poNoConsole, poStdErrToOutPut];
TheProcess.ShowWindow := swoNone;
try
TheProcess.Execute;
OutputLine:='';
repeat
if TheProcess.Output<>nil then
OutLen:=TheProcess.Output.Read(Buf[1],length(Buf))
else
OutLen:=0;
LineStart:=1;
i:=1;
while i<=OutLen do begin
if Buf[i] in [#10,#13] then begin
OutputLine:=OutputLine+copy(Buf,LineStart,i-LineStart);
ProcessOutputLine(OutputLine);
OutputLine:='';
if (i<OutLen) and (Buf[i+1] in [#10,#13]) and (Buf[i]<>Buf[i+1])
then
inc(i);
LineStart:=i+1;
end;
inc(i);
end;
OutputLine:=copy(Buf,LineStart,OutLen-LineStart+1);
until OutLen=0;
TheProcess.WaitOnExit;
finally
TheProcess.Free;
end;
// ask for target operating system -> ask compiler with switch -iTO
CmdLine:=PPC386Path+' -iTO';
TheProcess := TProcess.Create(nil);
TheProcess.CommandLine := CmdLine;
TheProcess.Options:= [poUsePipes, poNoConsole, poStdErrToOutPut];
TheProcess.ShowWindow := swoNone;
try
TheProcess.Execute;
if TheProcess.Output<>nil then
OutLen:=TheProcess.Output.Read(Buf[1],length(Buf))
else
OutLen:=0;
i:=1;
while i<=OutLen do begin
if Buf[i] in [#10,#13] then begin
TargetOS:=copy(Buf,1,i-1);
NewDefTempl:=TDefineTemplate.Create('Define TargetOS',
ctsDefaultppc386TargetOperatingSystem,
ExternalMacroStart+'TargetOS',TargetOS,da_DefineRecurse);
AddTemplate(NewDefTempl);
if TargetOS='linux' then
SrcOS:='unix'
else
SrcOS:=TargetOS;
NewDefTempl:=TDefineTemplate.Create('Define SrcOS',
ctsDefaultppc386SourceOperatingSystem,
ExternalMacroStart+'SrcOS',SrcOS,da_DefineRecurse);
AddTemplate(NewDefTempl);
break;
end;
inc(i);
end;
TheProcess.WaitOnExit;
finally
TheProcess.Free;
end;
// ask for target processor -> ask compiler with switch -iTP
TheProcess := TProcess.Create(nil);
TheProcess.CommandLine := PPC386Path+' -iTP';
TheProcess.Options:= [poUsePipes, poNoConsole, poStdErrToOutPut];
TheProcess.ShowWindow := swoNone;
try
TheProcess.Execute;
if TheProcess.Output<>nil then
OutLen:=TheProcess.Output.Read(Buf[1],length(Buf))
else
OutLen:=0;
i:=1;
while i<=OutLen do begin
if Buf[i] in [#10,#13] then begin
TargetProcessor:=copy(Buf,1,i-1);
NewDefTempl:=TDefineTemplate.Create('Define TargetProcessor',
ctsDefaultppc386TargetProcessor,
ExternalMacroStart+'TargetProcessor',TargetProcessor,
da_DefineRecurse);
AddTemplate(NewDefTempl);
break;
end;
inc(i);
end;
TheProcess.WaitOnExit;
finally
TheProcess.Free;
end;
// add
if (LastDefTempl<>nil) then begin
Result:=TDefineTemplate.Create('Free Pascal Compiler',
ctsFreePascalCompilerInitialMacros,'','',da_Block);
Result.AddChild(LastDefTempl.GetFirstSibling);
Result.Flags:=[dtfAutoGenerated];
end;
except
on E: Exception do begin
writeln('ERROR: TDefinePool.CreateFPCTemplate: ',E.Message);
end;
end;
end;
function TDefinePool.CreateFPCSrcTemplate(
const FPCSrcDir, UnitSearchPath: string;
UnitLinkListValid: boolean; var UnitLinkList: string): TDefineTemplate;
var
Dir, TargetOS, SrcOS, TargetProcessor, UnitLinks,
IncPathMacro: string;
DS: char;
UnitTree: TAVLTree; // tree of TUnitNameLink
procedure GatherUnits; forward;
function FindUnitLink(const AnUnitName: string): TUnitNameLink;
var ANode: TAVLTreeNode;
cmp: integer;
begin
if UnitTree=nil then GatherUnits;
ANode:=UnitTree.Root;
while ANode<>nil do begin
Result:=TUnitNameLink(ANode.Data);
cmp:=AnsiCompareText(AnUnitName,Result.UnitName);
if cmp<0 then
ANode:=ANode.Left
else if cmp>0 then
ANode:=ANode.Right
else
exit;
end;
Result:=nil;
end;
procedure GatherUnits;
function FileNameMacroCount(const AFilename: string): integer;
// count number of macros in filename
// a macro looks like this '$(name)' without a SpecialChar in front
// macronames can contain macros themselves
var i: integer;
begin
Result:=0;
i:=1;
while (i<=length(AFilename)) do begin
if (AFilename[i]=SpecialChar) then
inc(i,2)
else if (AFilename[i]='$') then begin
inc(i);
if (i<=length(AFilename)) and (AFilename[i]='(') then
inc(Result);
end else
inc(i);
end;
end;
function BuildMacroFilename(const AFilename: string;
var SrcOSMacroUsed: boolean): string;
// replace Operating System and Processor Type with macros
var DirStart, DirEnd, i: integer;
DirName: string;
begin
SrcOSMacroUsed:=false;
Result:=copy(AFilename,length(FPCSrcDir)+1,
length(AFilename)-length(FPCSrcDir));
DirStart:=1;
while (DirStart<=length(Result)) do begin
while (DirStart<=length(Result)) and (Result[DirStart]=PathDelim)
do
inc(DirStart);
DirEnd:=DirStart;
while (DirEnd<=length(Result)) and (Result[DirEnd]<>PathDelim) do
inc(DirEnd);
if DirEnd>length(Result) then break;
if DirEnd>DirStart then begin
DirName:=copy(Result,DirStart,DirEnd-DirStart);
// replace operating system
for i:=Low(FPCOperatingSystemNames) to High(FPCOperatingSystemNames)
do
if FPCOperatingSystemNames[i]=DirName then begin
Result:=copy(Result,1,DirStart-1)+TargetOS+
copy(Result,DirEnd,length(Result)-DirEnd+1);
inc(DirEnd,length(TargetOS)-length(DirName));
DirName:=TargetOS;
break;
end;
// replace operating system class
for i:=Low(FPCOperatingSystemAlternativeNames)
to High(FPCOperatingSystemAlternativeNames)
do
if FPCOperatingSystemAlternativeNames[i]=DirName then begin
Result:=copy(Result,1,DirStart-1)+SrcOS+
copy(Result,DirEnd,length(Result)-DirEnd+1);
inc(DirEnd,length(SrcOS)-length(DirName));
DirName:=SrcOS;
SrcOSMacroUsed:=true;
break;
end;
// replace processor type
for i:=Low(FPCProcessorNames) to High(FPCProcessorNames) do
if FPCProcessorNames[i]=DirName then begin
Result:=copy(Result,1,DirStart-1)+TargetProcessor+
copy(Result,DirEnd,length(Result)-DirEnd+1);
inc(DirEnd,length(TargetProcessor)-length(DirName));
DirName:=TargetProcessor;
break;
end;
end;
DirStart:=DirEnd;
end;
Result:=FPCSrcDir+Result;
end;
procedure BrowseDirectory(ADirPath: string);
const
IgnoreDirs: array[1..12] of shortstring =(
'.', '..', 'CVS', 'examples', 'example', 'tests', 'fake', 'ide',
'demo', 'docs', 'template', 'fakertl'
);
var
AFilename, Ext, UnitName, MacroFileName: string;
FileInfo: TSearchRec;
NewUnitLink, OldUnitLink: TUnitNameLink;
SrcOSMacroUsed: boolean;
i: integer;
begin
// writeln('%%%Browse ',ADirPath);
if ADirPath='' then exit;
if not (ADirPath[length(ADirPath)]=PathDelim) then
ADirPath:=ADirPath+PathDelim;
if FindFirst(ADirPath+'*.*',faAnyFile,FileInfo)=0 then begin
repeat
AFilename:=FileInfo.Name;
i:=High(IgnoreDirs);
while (i>=Low(IgnoreDirs)) and (AFilename<>IgnoreDirs[i]) do dec(i);
if i>=Low(IgnoreDirs) then continue;
AFilename:=ADirPath+AFilename;
if (FileInfo.Attr and faDirectory)>0 then begin
// ToDo: prevent cycling in links
BrowseDirectory(AFilename);
end else begin
Ext:=UpperCaseStr(ExtractFileExt(AFilename));
if (Ext='.PP') or (Ext='.PAS') then begin
// pascal unit found
UnitName:=FileInfo.Name;
UnitName:=copy(UnitName,1,length(UnitName)-length(Ext));
if UnitName<>'' then begin
OldUnitLink:=FindUnitLink(UnitName);
MacroFileName:=BuildMacroFileName(AFilename,SrcOSMacroUsed);
if OldUnitLink=nil then begin
// first unit with this name
NewUnitLink:=TUnitNameLink.Create;
NewUnitLink.UnitName:=UnitName;
NewUnitLink.FileName:=MacroFileName;
UnitTree.Add(NewUnitLink);
end else begin
{ there is another unit with this name
the decision which filename is the right one is based on a
simple heuristic:
FPC stores a unit many times, if there is different version
for each Operating System or Processor Type. And sometimes
units are stored in a combined OS (e.g. 'unix').
Therefore every occurence of such values is replaced by a
macro. And filenames without macros are always deleted if
there is a filename with a macro. (The filename without
macro is only used by the FPC team as a template source
for the OS specific)
For example:
classes.pp can be found in several places
<FPCSrcDir>/fcl/os2/classes.pp
<FPCSrcDir>/fcl/linux/classes.pp
<FPCSrcDir>/fcl/win32/classes.pp
<FPCSrcDir>/fcl/go32v2/classes.pp
<FPCSrcDir>/fcl/freebsd/classes.pp
<FPCSrcDir>/fcl/template/classes.pp
This will result in a single filename:
$(#FPCSrcDir)/fcl/$(#TargetOS)/classes.pp
}
if (FileNameMacroCount(OldUnitLink.Filename)=0)
or (SrcOSMacroUsed) then begin
// old filename has no macros -> take the macro filename
OldUnitLink.Filename:=MacroFileName;
end;
end;
end;
end;
end;
until FindNext(FileInfo)<>0;
end;
FindClose(FileInfo);
end;
begin
if UnitTree=nil then
UnitTree:=TAVLTree.Create(@CompareUnitLinkNodes)
else
UnitTree.FreeAndClear;
BrowseDirectory(FPCSrcDir);
end;
procedure AddFPCSourceLinkForUnit(const AnUnitName: string);
var UnitLink: TUnitNameLink;
s: string;
begin
// search
if AnUnitName='' then exit;
UnitLink:=FindUnitLink(AnUnitName);
//writeln('AddFPCSourceLinkForUnit ',AnUnitName,' ',UnitLink<>nil);
if UnitLink=nil then exit;
s:=AnUnitName+' '+UnitLink.Filename+EndOfLine;
UnitLinkList:=UnitLinkList+s;
end;
procedure FindStandardPPUSources;
var PathStart, PathEnd: integer;
ADirPath, UnitName: string;
FileInfo: TSearchRec;
begin
// try every ppu file in every reachable directory (CompUnitPath)
if UnitLinkListValid then exit;
UnitLinkList:='';
PathStart:=1;
while PathStart<=length(UnitSearchPath) do begin
while (PathStart<=length(UnitSearchPath))
and (UnitSearchPath[PathStart]=#13) do
inc(PathStart);
PathEnd:=PathStart;
// extract single path from unit search path
while (PathEnd<=length(UnitSearchPath))
and (UnitSearchPath[PathEnd]<>#13) do
inc(PathEnd);
if PathEnd>PathStart then begin
ADirPath:=copy(UnitSearchPath,PathStart,PathEnd-PathStart);
//writeln('&&& FindStandardPPUSources ',ADirPath);
// search all ppu files in this directory
if FindFirst(ADirPath+'*.ppu',faAnyFile,FileInfo)=0 then begin
repeat
UnitName:=ExtractFileName(FileInfo.Name);
UnitName:=copy(UnitName,1,length(UnitName)-4);
//writeln('&&& FindStandardPPUSources B ',UnitName);
AddFPCSourceLinkForUnit(UnitName);
until FindNext(FileInfo)<>0;
end;
FindClose(FileInfo);
end;
PathStart:=PathEnd;
end;
UnitLinkListValid:=true;
end;
// function CreateFPCSrcTemplate(const FPCSrcDir,
// UnitSearchPath: string;
// UnitLinkListValid: boolean; var UnitLinkList: string): TDefineTemplate;
var
DefTempl, MainDir, FCLDir, RTLDir, PackagesDir, CompilerDir,
UtilsDir, DebugSvrDir: TDefineTemplate;
s: string;
begin
Result:=nil;
if (FPCSrcDir='') or (not DirectoryExists(FPCSrcDir)) then exit;
DS:=PathDelim;
Dir:=FPCSrcDir;
if Dir[length(Dir)]<>DS then Dir:=Dir+DS;
TargetOS:='$('+ExternalMacroStart+'TargetOS)';
SrcOS:='$('+ExternalMacroStart+'SrcOS)';
TargetProcessor:='$('+ExternalMacroStart+'TargetProcessor)';
IncPathMacro:='$('+ExternalMacroStart+'IncPath)';
UnitLinks:=ExternalMacroStart+'UnitLinks';
UnitTree:=nil;
Result:=TDefineTemplate.Create(StdDefTemplFPCSrc,
Format(ctsFreePascalSourcesPlusDesc,['RTL, FCL, Packages, Compiler']),
'','',da_Block);
Result.Flags:=[dtfAutoGenerated];
// try to find for every reachable ppu file the unit file in the FPC sources
FindStandardPPUSources;
DefTempl:=TDefineTemplate.Create('FPC Unit Links',
ctsSourceFilenamesForStandardFPCUnits,
UnitLinks,UnitLinkList,da_DefineRecurse);
Result.AddChild(DefTempl);
// The free pascal sources build a world of their own,
// reset source search path
MainDir:=TDefineTemplate.Create('Free Pascal Source Directory',
ctsFreePascalSourceDir,'',FPCSrcDir,da_Directory);
Result.AddChild(MainDir);
DefTempl:=TDefineTemplate.Create('Reset SrcPath',
ctsSrcPathInitialization,ExternalMacroStart+'SrcPath','',da_DefineRecurse);
MainDir.AddChild(DefTempl);
// turn Nested comments on
DefTempl:=TDefineTemplate.Create('Nested Comments',
ctsNestedCommentsOn,ExternalMacroStart+'NestedComments','',da_DefineRecurse);
MainDir.AddChild(DefTempl);
// compiler
CompilerDir:=TDefineTemplate.Create('Compiler',ctsCompiler,'','compiler',
da_Directory);
MainDir.AddChild(CompilerDir);
// define 'i386' ToDo: other types like m68k
DefTempl:=TDefineTemplate.Create('Define i386',
ctsDefineProzessorType,'i386','',da_DefineRecurse);
CompilerDir.AddChild(DefTempl);
// rtl
RTLDir:=TDefineTemplate.Create('RTL',ctsRuntimeLibrary,'','rtl',da_Directory);
MainDir.AddChild(RTLDir);
s:=IncPathMacro
+';'+Dir+'rtl'+DS+'objpas'+DS
+';'+Dir+'rtl'+DS+'inc'+DS
+';'+Dir+'rtl'+DS+TargetProcessor+DS
+';'+Dir+'rtl'+DS+SrcOS+DS
+';'+Dir+'rtl'+DS+TargetOS+DS+TargetProcessor+DS
+';'+Dir+'rtl'+DS+SrcOS+DS+TargetProcessor+DS;
if (TargetOS<>'') and (TargetOS<>SrcOS) then
s:=s+';'+Dir+'rtl'+DS+TargetOS+DS;
RTLDir.AddChild(TDefineTemplate.Create('Include Path',
Format(ctsIncludeDirectoriesPlusDirs,
['objpas, inc,'+TargetProcessor+','+SrcOS]),
ExternalMacroStart+'IncPath',s,da_DefineRecurse));
// define 'i386' ToDo: other types like m68k
DefTempl:=TDefineTemplate.Create('Define i386',
ctsDefineProzessorType,'i386','',da_DefineRecurse);
RTLDir.AddChild(DefTempl);
// fcl
FCLDir:=TDefineTemplate.Create('FCL',ctsFreePascalComponentLibrary,'','fcl',
da_Directory);
MainDir.AddChild(FCLDir);
FCLDir.AddChild(TDefineTemplate.Create('Include Path',
Format(ctsIncludeDirectoriesPlusDirs,['inc,'+SrcOS]),
ExternalMacroStart+'IncPath',
IncPathMacro
+';'+Dir+'fcl'+DS+'inc'+DS
+';'+Dir+'fcl'+DS+SrcOS+DS
,da_DefineRecurse));
// packages
PackagesDir:=TDefineTemplate.Create('Packages',ctsPackageDirectories,'',
'packages',da_Directory);
MainDir.AddChild(PackagesDir);
// utils
UtilsDir:=TDefineTemplate.Create('Utils',ctsUtilsDirectories,'',
'utils',da_Directory);
MainDir.AddChild(UtilsDir);
// utils/debugsvr
DebugSvrDir:=TDefineTemplate.Create('DebugSvr','Debug Server','',
'debugsvr',da_Directory);
UtilsDir.AddChild(DebugSvrDir);
DebugSvrDir.AddChild(TDefineTemplate.Create('Interface Path',
Format(ctsAddsDirToSourcePath,['..']),ExternalMacroStart+'SrcPath',
'..;'+ExternalMacroStart+'SrcPath',da_DefineRecurse));
// clean upt
if UnitTree<>nil then begin
UnitTree.FreeAndClear;
UnitTree.Free;
end;
end;
function TDefinePool.CreateDelphiSrcPath(DelphiVersion: integer;
const PathPrefix: string): string;
begin
case DelphiVersion of
6:
Result:=PathPrefix+'Source/Rtl/Win;'
+PathPrefix+'Source/Rtl/Sys;'
+PathPrefix+'Source/Rtl/Common;'
+PathPrefix+'Source/Rtl/Corba40;'
+PathPrefix+'Source/Vcl;';
else
Result:=PathPrefix+'Source/Rtl/Win;'
+PathPrefix+'Source/Rtl/Sys;'
+PathPrefix+'Source/Rtl/Corba;'
+PathPrefix+'Source/Vcl;';
end;
end;
function TDefinePool.CreateLazarusSrcTemplate(
const LazarusSrcDir, WidgetType, ExtraOptions: string): TDefineTemplate;
const
ds: char = PathDelim;
var
MainDir, DirTempl, SubDirTempl, IntfDirTemplate, IfTemplate,
SubTempl: TDefineTemplate;
TargetOS, SrcPath: string;
begin
Result:=nil;
if (LazarusSrcDir='') or (WidgetType='') then exit;
TargetOS:='$('+ExternalMacroStart+'TargetOS)';
SrcPath:='$('+ExternalMacroStart+'SrcPath)';
// <LazarusSrcDir>
MainDir:=TDefineTemplate.Create(
StdDefTemplLazarusSrcDir, ctsDefsForLazarusSources,'',LazarusSrcDir,
da_Directory);
MainDir.AddChild(TDefineTemplate.Create(
'LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),ExternalMacroStart+'SrcPath',
'lcl;lcl'+ds+'interfaces'+ds+WidgetType+';'+SrcPath
,da_Define));
MainDir.AddChild(TDefineTemplate.Create(
'Component path addition',
Format(ctsAddsDirToSourcePath,['designer, debugger, components']),
ExternalMacroStart+'SrcPath',
'designer;'
+'designer'+ds+'jitform;'
+'debugger;'
+'packager;'
+'components'+ds+'synedit;'
+'components'+ds+'codetools;'
+'components'+ds+'custom;'
+SrcPath
,da_Define));
MainDir.AddChild(TDefineTemplate.Create('includepath addition',
Format(ctsSetsIncPathTo,['include, include/TargetOS']),
ExternalMacroStart+'IncPath',
'include;include'+ds+TargetOS,
da_Define));
// turn Nested comments on
MainDir.AddChild(TDefineTemplate.Create('Nested Comments',
ctsNestedCommentsOn,ExternalMacroStart+'NestedComments','',da_DefineRecurse));
// include
// designer
DirTempl:=TDefineTemplate.Create('Designer',ctsDesignerDirectory,
'','designer',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
'..'+ds+'lcl'
+';..'+ds+'lcl'+ds+'interfaces'+ds+WidgetType
+';'+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('main path addition',
Format(ctsAddsDirToSourcePath,[ctsLazarusMainDirectory]),
ExternalMacroStart+'SrcPath',
'..;'+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('components path addition',
Format(ctsAddsDirToSourcePath,['synedit']),
ExternalMacroStart+'SrcPath',
'..'+ds+'components'+ds+'synedit;'
+'..'+ds+'components'+ds+'codetools;'
+'..'+ds+'components'+ds+'custom;'
+'jitform;'
+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('includepath addition',
Format(ctsIncludeDirectoriesPlusDirs,['include']),
ExternalMacroStart+'IncPath',
'..'+ds+'include;..'+ds+'include'+ds+TargetOS,
da_Define));
MainDir.AddChild(DirTempl);
// images
// debugger
DirTempl:=TDefineTemplate.Create('Debugger',ctsDebuggerDirectory,
'','debugger',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
'..'+ds+'lcl'
+';..'+ds+'lcl'+ds+'interfaces'+ds+WidgetType
+';'+SrcPath
,da_DefineRecurse));
MainDir.AddChild(DirTempl);
// packager
DirTempl:=TDefineTemplate.Create('Packager',ctsDesignerDirectory,
'','packager',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
'..'+ds+'lcl'
+';..'+ds+'lcl'+ds+'interfaces'+ds+WidgetType
+';'+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('main path addition',
Format(ctsAddsDirToSourcePath,[ctsLazarusMainDirectory]),
ExternalMacroStart+'SrcPath',
'..;'+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('components path addition',
Format(ctsAddsDirToSourcePath,['synedit']),
ExternalMacroStart+'SrcPath',
'..'+ds+'components'+ds+'synedit;'
+'..'+ds+'components'+ds+'codetools;'
+'..'+ds+'components'+ds+'custom;'
+SrcPath
,da_Define));
DirTempl.AddChild(TDefineTemplate.Create('includepath addition',
Format(ctsIncludeDirectoriesPlusDirs,['include']),
ExternalMacroStart+'IncPath',
'..'+ds+'include;..'+ds+'include'+ds+TargetOS,
da_Define));
MainDir.AddChild(DirTempl);
// examples
DirTempl:=TDefineTemplate.Create('Examples',
Format(ctsNamedDirectory,['Examples']),
'','examples',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
'..'+ds+'lcl;..'+ds+'lcl'+ds+'interfaces'+ds+WidgetType+';'+SrcPath
,da_Define));
MainDir.AddChild(DirTempl);
// lcl
DirTempl:=TDefineTemplate.Create('LCL',Format(ctsNamedDirectory,['LCL']),
'','lcl',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('IncludePath',
Format(ctsIncludeDirectoriesPlusDirs,['include']),
ExternalMacroStart+'IncPath',
'include',da_Define));
MainDir.AddChild(DirTempl);
// lcl/interfaces
SubDirTempl:=TDefineTemplate.Create('WidgetDirectory',
ctsWidgetDirectory,'','interfaces',da_Directory);
// add lcl to the source path of all widget set directories
SubDirTempl.AddChild(TDefineTemplate.Create('LCL Path',
Format(ctsAddsDirToSourcePath,['lcl']),ExternalMacroStart+'SrcPath',
LazarusSrcDir+ds+'lcl;'+SrcPath,da_DefineRecurse));
DirTempl.AddChild(SubDirTempl);
// lcl/interfaces/gtk
IntfDirTemplate:=TDefineTemplate.Create('gtkIntfDirectory',
ctsGtkIntfDirectory,'','gtk',da_Directory);
// if LCLWidgetType=gtk2
IfTemplate:=TDefineTemplate.Create('IF '+WidgetType+'=gtk2',
ctsIfLCLWidgetTypeEqualsGtk2,'',WidgetType+'=gtk2',da_If);
// then define gtk2
IfTemplate.AddChild(TDefineTemplate.Create('Define gtk2',
ctsDefineMacroGTK2,'gtk2','',da_Define));
IntfDirTemplate.AddChild(IfTemplate);
SubDirTempl.AddChild(IntfDirTemplate);
// lcl/interfaces/gtk2
IntfDirTemplate:=TDefineTemplate.Create('gtk2IntfDirectory',
ctsGtk2IntfDirectory,'','gtk2',da_Directory);
// add '../gtk' to the SrcPath
IntfDirTemplate.AddChild(TDefineTemplate.Create('SrcPath',
Format(ctsAddsDirToSourcePath,['gtk']),ExternalMacroStart+'SrcPath',
'..'+ds+'gtk;'+SrcPath,da_Define));
SubDirTempl.AddChild(IntfDirTemplate);
// lcl/interfaces/gnome
IntfDirTemplate:=TDefineTemplate.Create('gnomeIntfDirectory',
ctsGnomeIntfDirectory,'','gnome',da_Directory);
// add '../gtk' to the SrcPath
IntfDirTemplate.AddChild(TDefineTemplate.Create('SrcPath',
Format(ctsAddsDirToSourcePath,['gtk']),ExternalMacroStart+'SrcPath',
'..'+ds+'gtk;'+SrcPath,da_Define));
// if LCLWidgetType=gnome2
IfTemplate:=TDefineTemplate.Create('IF '+WidgetType+'=gnome2',
ctsIfLCLWidgetTypeEqualsGnome2,'',WidgetType+'=gnome2',da_If);
// then define gnome2
IfTemplate.AddChild(TDefineTemplate.Create('Define gnome2',
ctsDefineMacroGTK2,'gnome2','',da_Define));
IntfDirTemplate.AddChild(IfTemplate);
SubDirTempl.AddChild(IntfDirTemplate);
// lcl/interfaces/win32
// no special
// components
DirTempl:=TDefineTemplate.Create('Components',ctsComponentsDirectory,
'','components',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL Path',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
LazarusSrcDir+ds+'lcl'
+';'+LazarusSrcDir+ds+'lcl'+ds+'interfaces'+ds+WidgetType
+';'+SrcPath
,da_DefineRecurse));
MainDir.AddChild(DirTempl);
// components/htmllite
SubDirTempl:=TDefineTemplate.Create('HTMLLite',
'HTMLLite',
'','htmllite',da_Directory);
SubDirTempl.AddChild(TDefineTemplate.Create('HL_LAZARUS',
'Define HL_LAZARUS','HL_LAZARUS','',da_DefineRecurse));
DirTempl.AddChild(SubDirTempl);
// components/custom
SubDirTempl:=TDefineTemplate.Create('Custom Components',
ctsCustomComponentsDirectory,
'','custom',da_Directory);
SubDirTempl.AddChild(TDefineTemplate.Create('lazarus standard components',
Format(ctsAddsDirToSourcePath,['synedit']),
ExternalMacroStart+'SrcPath',
'..'+ds+'synedit'
+';'+SrcPath
,da_DefineRecurse));
DirTempl.AddChild(SubDirTempl);
// tools
DirTempl:=TDefineTemplate.Create('Tools',
ctsToolsDirectory,
'','tools',da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
'..'+ds+'lcl;..'+ds+'lcl'+ds+'interfaces'+ds+WidgetType
+';..'+ds+'components'+ds+'codetools'
+';'+SrcPath
,da_Define));
MainDir.AddChild(DirTempl);
// extra options
SubTempl:=CreateFPCCommandLineDefines(StdDefTemplLazarusBuildOpts,ExtraOptions);
MainDir.AddChild(SubTempl);
// put it all into a block
if MainDir<>nil then begin
Result:=TDefineTemplate.Create(StdDefTemplLazarusSources,
ctsLazarusSources,'','',da_Block);
Result.AddChild(MainDir);
Result.Flags:=[dtfAutoGenerated];
end;
end;
function TDefinePool.CreateLCLProjectTemplate(
const LazarusSrcDir, WidgetType, ProjectDir: string): TDefineTemplate;
var DirTempl: TDefineTemplate;
begin
Result:=nil;
if (LazarusSrcDir='') or (WidgetType='') or (ProjectDir='') then exit;
DirTempl:=TDefineTemplate.Create('ProjectDir',ctsAnLCLProject,
'',ProjectDir,da_Directory);
DirTempl.AddChild(TDefineTemplate.Create('LCL',
Format(ctsAddsDirToSourcePath,['lcl']),
ExternalMacroStart+'SrcPath',
LazarusSrcDir+PathDelim+'lcl;'
+LazarusSrcDir+PathDelim+'lcl'+PathDelim+'interfaces'
+PathDelim+WidgetType
+';$('+ExternalMacroStart+'SrcPath)'
,da_DefineRecurse));
Result:=TDefineTemplate.Create(StdDefTemplLCLProject,
'LCL Project','','',da_Block);
Result.Flags:=[dtfAutoGenerated];
Result.AddChild(DirTempl);
end;
function TDefinePool.CreateDelphiCompilerDefinesTemplate(
DelphiVersion: integer): TDefineTemplate;
var DefTempl: TDefineTemplate;
begin
DefTempl:=TDefineTemplate.Create('Delphi'+IntToStr(DelphiVersion)
+' Compiler Defines',
Format(ctsOtherCompilerDefines,['Delphi'+IntToStr(DelphiVersion)]),
'','',da_Block);
DefTempl.AddChild(TDefineTemplate.Create('Reset',
ctsResetAllDefines,
'','',da_UndefineAll));
DefTempl.AddChild(TDefineTemplate.Create('Define macro DELPHI',
Format(ctsDefineMacroName,['DELPHI']),
'DELPHI','',da_DefineRecurse));
DefTempl.AddChild(TDefineTemplate.Create('Define macro FPC_DELPHI',
Format(ctsDefineMacroName,['FPC_DELPHI']),
'FPC_DELPHI','',da_DefineRecurse));
DefTempl.AddChild(TDefineTemplate.Create('Define macro MSWINDOWS',
Format(ctsDefineMacroName,['MSWINDOWS']),
'MSWINDOWS','',da_DefineRecurse));
// version
case DelphiVersion of
3:
DefTempl.AddChild(TDefineTemplate.Create('Define macro VER_110',
Format(ctsDefineMacroName,['VER_110']),
'VER_130','',da_DefineRecurse));
4:
DefTempl.AddChild(TDefineTemplate.Create('Define macro VER_125',
Format(ctsDefineMacroName,['VER_125']),
'VER_130','',da_DefineRecurse));
5:
DefTempl.AddChild(TDefineTemplate.Create('Define macro VER_130',
Format(ctsDefineMacroName,['VER_130']),
'VER_130','',da_DefineRecurse));
else
// else define Delphi 6
DefTempl.AddChild(TDefineTemplate.Create('Define macro VER_140',
Format(ctsDefineMacroName,['VER_140']),
'VER_140','',da_DefineRecurse));
end;
DefTempl.AddChild(TDefineTemplate.Create(
Format(ctsDefineMacroName,[ExternalMacroStart+'Compiler']),
'Define '+ExternalMacroStart+'Compiler variable',
ExternalMacroStart+'Compiler','DELPHI',da_DefineRecurse));
Result:=DefTempl;
end;
function TDefinePool.CreateDelphiDirectoryTemplate(
const DelphiDirectory: string; DelphiVersion: integer): TDefineTemplate;
var MainDirTempl: TDefineTemplate;
begin
MainDirTempl:=TDefineTemplate.Create('Delphi'+IntToStr(DelphiVersion)
+' Directory',
Format(ctsNamedDirectory,['Delphi'+IntToStr(DelphiVersion)]),
'',DelphiDirectory,da_Directory);
MainDirTempl.AddChild(CreateDelphiCompilerDefinesTemplate(DelphiVersion));
MainDirTempl.AddChild(TDefineTemplate.Create('SrcPath',
Format(ctsSetsSrcPathTo,['RTL, VCL']),
ExternalMacroStart+'SrcPath',
SetDirSeparators(CreateDelphiSrcPath(DelphiVersion,'$(#DefinePath)/')
+'$(#SrcPath)'),
da_DefineRecurse));
Result:=MainDirTempl;
end;
function TDefinePool.CreateDelphiProjectTemplate(
const ProjectDir, DelphiDirectory: string;
DelphiVersion: integer): TDefineTemplate;
var MainDirTempl: TDefineTemplate;
begin
MainDirTempl:=TDefineTemplate.Create('Delphi'+IntToStr(DelphiVersion)+' Project',
Format(ctsNamedProject,['Delphi'+IntToStr(DelphiVersion)]),
'',ProjectDir,da_Directory);
MainDirTempl.AddChild(CreateDelphiCompilerDefinesTemplate(DelphiVersion));
MainDirTempl.AddChild(TDefineTemplate.Create(
'Define '+ExternalMacroStart+'DelphiDir',
Format(ctsDefineMacroName,[ExternalMacroStart+'DelphiDir']),
ExternalMacroStart+'DelphiDir',DelphiDirectory,da_DefineRecurse));
MainDirTempl.AddChild(TDefineTemplate.Create('SrcPath',
Format(ctsAddsDirToSourcePath,['Delphi RTL+VCL']),
ExternalMacroStart+'SrcPath',
SetDirSeparators(CreateDelphiSrcPath(DelphiVersion,'$(#DelphiDir)/')
+'$(#SrcPath)'),
da_DefineRecurse));
Result:=MainDirTempl;
end;
function TDefinePool.CreateFPCCommandLineDefines(const Name, CmdLine: string
): TDefineTemplate;
function ReadNextParam(LastEndPos: integer;
var StartPos, EndPos: integer): boolean;
begin
StartPos:=LastEndPos;
while (StartPos<=length(CmdLine)) and (CmdLine[StartPos] in [' ',#9]) do
inc(StartPos);
EndPos:=StartPos;
while (EndPos<=length(CmdLine)) and (not (CmdLine[EndPos] in [' ',#9])) do
inc(EndPos);
Result:=StartPos<=length(CmdLine);
end;
procedure AddDefine(const AName, ADescription, AVariable, AValue: string;
AnAction: TDefineAction);
var
NewTempl: TDefineTemplate;
begin
if AName='' then exit;
NewTempl:=TDefineTemplate.Create(AName, ADescription, AVariable, AValue,
AnAction);
if Result=nil then
Result:=TDefineTemplate.Create(Name,ctsCommandLineParameters,'','',
da_Block);
Result.AddChild(NewTempl);
end;
var
StartPos, EndPos: Integer;
s: string;
begin
Result:=nil;
EndPos:=1;
while ReadNextParam(EndPos,StartPos,EndPos) do begin
if (StartPos<length(CmdLine)) and (CmdLine[StartPos]='-') then begin
// a parameter
case CmdLine[StartPos+1] of
'd':
begin
// define
s:=copy(CmdLine,StartPos+2,EndPos-StartPos-2);
AddDefine('Define '+s,ctsDefine+s,s,'',da_DefineRecurse);
end;
end;
end;
end;
end;
function TDefinePool.ConsistencyCheck: integer;
var i: integer;
begin
for i:=0 to Count-1 do begin
Result:=Items[i].ConsistencyCheck;
if Result<>0 then begin
dec(Result,100); exit;
end;
end;
Result:=0;
end;
procedure TDefinePool.WriteDebugReport;
var i: integer;
begin
writeln('TDefinePool.WriteDebugReport Consistency=',ConsistencyCheck);
for i:=0 to Count-1 do begin
Items[i].WriteDebugReport;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink