paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-23 05:39:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

added codetools directory cache for units

Browse Source 
git-svn-id: trunk@8945 -
This commit is contained in:
mattias 2006-03-17 17:10:53 +00:00
parent c48acb6961
commit 62ffcbc9b2
14 changed files with 1566 additions and 454 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
components/codetools/codeatom.pas
View File

@ -93,12 +93,12 @@ type
FStart, FLast: integer;
procedure SetSize(NewSize: integer);
public
procedure Add(NewAtom: TAtomPosition);
procedure UndoLastAdd;
function GetValueAt(RelativePos:integer): TAtomPosition;
procedure Add(NewAtom: TAtomPosition); inline;
procedure UndoLastAdd; inline;
function GetValueAt(RelativePos:integer): TAtomPosition; inline;
// 0=current 1=prior current ...
// for LastAtoms: 0 is the last atom
function Count: integer;
function Count: integer; inline;
property Size: integer read FSize write SetSize;
procedure Clear;
procedure WriteDebugReport;

144
components/codetools/codetoolmanager.pas
View File

@ -43,7 +43,7 @@ uses
Classes, SysUtils, FileProcs, BasicCodeTools, CodeToolsStrConsts,
EventCodeTool, CodeTree, CodeAtom, SourceChanger, DefineTemplates, CodeCache,
ExprEval, LinkScanner, KeywordFuncLists, TypInfo,
AVL_Tree, LFMTrees, PascalParserTool, CodeToolsConfig,
DirectoryCache, AVL_Tree, LFMTrees, PascalParserTool, CodeToolsConfig,
CustomCodeTool, FindDeclarationTool, IdentCompletionTool, StdCodeTools,
ResourceCodeTool, CodeToolsStructs, CodeTemplatesTool, ExtractProcTool;
@ -126,6 +126,7 @@ type
procedure WriteError;
function OnGetCodeToolForBuffer(Sender: TObject;
Code: TCodeBuffer; GoToMainCode: boolean): TFindDeclarationTool;
function OnGetDirectoryCache(const ADirectory: string): TCTDirectoryCache;
procedure OnToolSetWriteLock(Lock: boolean);
procedure OnToolGetWriteLockInfo(out WriteLockIsSet: boolean;
out WriteLockStep: integer);
@ -133,12 +134,15 @@ type
function OnScannerProgress(Sender: TLinkScanner): boolean;
function GetResourceTool: TResourceCodeTool;
function GetOwnerForCodeTreeNode(ANode: TCodeTreeNode): TObject;
function DirectoryCachePoolGetString(const ADirectory: string;
const AStringType: TCTDirCacheString): string;
public
DefinePool: TDefinePool; // definition templates (rules)
DefineTree: TDefineTree; // cache for defines (e.g. initial compiler values)
SourceCache: TCodeCache; // cache for source (units, include files, ...)
SourceChangeCache: TSourceChangeCache; // cache for write accesses
GlobalValues: TExpressionEvaluator;
DirectoryCachePool: TCTDirectoryCachePool;
IdentifierList: TIdentifierList;
IdentifierHistory: TIdentifierHistoryList;
Positions: TCodeXYPositions;
@ -232,19 +236,26 @@ type
// defines
function SetGlobalValue(const VariableName, VariableValue: string): boolean;
function GetUnitPathForDirectory(const Directory: string): string;
function GetIncludePathForDirectory(const Directory: string): string;
function GetSrcPathForDirectory(const Directory: string): string;
function GetUnitPathForDirectory(const Directory: string;
UseCache: boolean = true): string;
function GetIncludePathForDirectory(const Directory: string;
UseCache: boolean = true): string;
function GetSrcPathForDirectory(const Directory: string;
UseCache: boolean = true): string;
function GetCompleteSrcPathForDirectory(const Directory: string;
UseCache: boolean = true): string;
function GetPPUSrcPathForDirectory(const Directory: string): string;
function GetPPWSrcPathForDirectory(const Directory: string): string;
function GetDCUSrcPathForDirectory(const Directory: string): string;
function GetCompiledSrcPathForDirectory(const Directory: string): string;
function GetCompiledSrcPathForDirectory(const Directory: string;
UseCache: boolean = true): string;
function GetNestedCommentsFlagForFile(const Filename: string): boolean;
function GetPascalCompilerForDirectory(const Directory: string): TPascalCompiler;
function GetCompilerModeForDirectory(const Directory: string): TCompilerMode;
function GetCompiledSrcExtForDirectory(const Directory: string): string;
function FindUnitInUnitLinks(const Directory, UnitName: string): string;
function GetUnitLinksForDirectory(const Directory: string): string;
function GetUnitLinksForDirectory(const Directory: string;
UseCache: boolean = false): string;
procedure GetFPCVersionForDirectory(const Directory: string;
out FPCVersion, FPCRelease, FPCPatch: integer);
@ -603,6 +614,8 @@ begin
SourceChangeCache.OnBeforeApplyChanges:=@BeforeApplyingChanges;
SourceChangeCache.OnAfterApplyChanges:=@AfterApplyingChanges;
GlobalValues:=TExpressionEvaluator.Create;
DirectoryCachePool:=TCTDirectoryCachePool.Create;
DirectoryCachePool.OnGetString:=@DirectoryCachePoolGetString;
FAddInheritedCodeToOverrideMethod:=true;
FAdjustTopLineDueToComment:=true;
FCatchExceptions:=true;
@ -647,6 +660,7 @@ begin
DebugLn('[TCodeToolManager.Destroy] E');
{$ENDIF}
FreeAndNil(SourceCache);
FreeAndNil(DirectoryCachePool);
{$IFDEF CTDEBUG}
DebugLn('[TCodeToolManager.Destroy] F');
{$ENDIF}
@ -939,21 +953,73 @@ begin
DefineTree.ClearCache;
end;
function TCodeToolManager.GetUnitPathForDirectory(const Directory: string): string;
function TCodeToolManager.GetUnitPathForDirectory(const Directory: string;
UseCache: boolean): string;
begin
Result:=DefineTree.GetUnitPathForDirectory(Directory);
if UseCache then
Result:=DirectoryCachePool.GetString(Directory,ctdcsUnitPath,true)
else
Result:=DefineTree.GetUnitPathForDirectory(Directory);
end;
function TCodeToolManager.GetIncludePathForDirectory(const Directory: string
): string;
function TCodeToolManager.GetIncludePathForDirectory(const Directory: string;
UseCache: boolean): string;
begin
Result:=DefineTree.GetIncludePathForDirectory(Directory);
if UseCache then
Result:=DirectoryCachePool.GetString(Directory,ctdcsIncludePath,true)
else
Result:=DefineTree.GetIncludePathForDirectory(Directory);
end;
function TCodeToolManager.GetSrcPathForDirectory(const Directory: string
): string;
function TCodeToolManager.GetSrcPathForDirectory(const Directory: string;
UseCache: boolean): string;
begin
Result:=DefineTree.GetSrcPathForDirectory(Directory);
if UseCache then
Result:=DirectoryCachePool.GetString(Directory,ctdcsSrcPath,true)
else
Result:=DefineTree.GetSrcPathForDirectory(Directory);
end;
function TCodeToolManager.GetCompleteSrcPathForDirectory(
const Directory: string; UseCache: boolean): string;
// returns the SrcPath + UnitPath + any CompiledSrcPath
var
CurUnitPath: String;
StartPos: Integer;
EndPos: LongInt;
CurSrcPath: String;
CurUnitDir: String;
CurCompiledSrcPath: String;
begin
if UseCache then
Result:=DirectoryCachePool.GetString(Directory,ctdcsCompleteSrcPath,true)
else begin
CurUnitPath:='.;'+GetUnitPathForDirectory(Directory);
CurSrcPath:=GetSrcPathForDirectory(Directory);
// for every unit path, get the CompiledSrcPath
StartPos:=1;
while StartPos<=length(CurUnitPath) do begin
EndPos:=StartPos;
while (EndPos<=length(CurUnitPath)) and (CurUnitPath[EndPos]<>';') do
inc(EndPos);
if EndPos>StartPos then begin
CurUnitDir:=TrimFilename(copy(CurUnitPath,StartPos,EndPos-StartPos));
if not FilenameIsAbsolute(CurUnitDir) then
CurUnitDir:=TrimFilename(AppendPathDelim(Directory)+CurUnitDir);
CurCompiledSrcPath:=GetCompiledSrcPathForDirectory(CurUnitDir);
if CurCompiledSrcPath<>'' then
CurSrcPath:=CurSrcPath+';'+CurCompiledSrcPath;
end;
StartPos:=EndPos+1;
end;
// combine unit, src and compiledsrc search path
Result:=CurUnitPath+';'+CurSrcPath;
// make it absolute, so the user need less string concatenations
if FilenameIsAbsolute(Directory) then
Result:=CreateAbsoluteSearchPath(Result,Directory);
// trim the paths, remove doubles and empty paths
Result:=MinimizeSearchPath(Result);
end;
end;
function TCodeToolManager.GetPPUSrcPathForDirectory(const Directory: string
@ -974,8 +1040,8 @@ begin
Result:=DefineTree.GetDCUSrcPathForDirectory(Directory);
end;
function TCodeToolManager.GetCompiledSrcPathForDirectory(const Directory: string
): string;
function TCodeToolManager.GetCompiledSrcPathForDirectory(
const Directory: string; UseCache: boolean): string;
begin
Result:=DefineTree.GetCompiledSrcPathForDirectory(Directory);
end;
@ -1044,25 +1110,23 @@ end;
function TCodeToolManager.FindUnitInUnitLinks(const Directory, UnitName: string
): string;
var
UnitLinks: string;
UnitLinkStart, UnitLinkEnd: integer;
begin
Result:='';
UnitLinks:=GetUnitLinksForDirectory(Directory);
if UnitLinks='' then exit;
SearchUnitInUnitLinks(UnitLinks,UnitName,UnitLinkStart,UnitLinkEnd,Result);
Result:=DirectoryCachePool.FindUnitInUnitLinks(Directory,UnitName);
end;
function TCodeToolManager.GetUnitLinksForDirectory(const Directory: string
): string;
function TCodeToolManager.GetUnitLinksForDirectory(const Directory: string;
UseCache: boolean): string;
var
Evaluator: TExpressionEvaluator;
begin
Result:='';
Evaluator:=DefineTree.GetDefinesForDirectory(Directory,true);
if Evaluator=nil then exit;
Result:=Evaluator[ExternalMacroStart+'UnitLinks'];
if UseCache then begin
Result:=DirectoryCachePool.GetString(Directory,ctdcsUnitLinks,true)
end else begin
Result:='';
Evaluator:=DefineTree.GetDefinesForDirectory(Directory,true);
if Evaluator=nil then exit;
Result:=Evaluator[ExternalMacroStart+'UnitLinks'];
end;
end;
procedure TCodeToolManager.GetFPCVersionForDirectory(const Directory: string;
@ -2142,7 +2206,7 @@ begin
MissingIncludeFiles:=nil;
try
Result:=FCurCodeTool.FixIncludeFilenames(Code,SourceChangeCache,
FoundIncludeFiles,MissingIncludeFiles);
FoundIncludeFiles,MissingIncludeFiles);
if (MissingIncludeFiles<>nil)
and (MissingIncludeFiles.Count>0) then begin
DebugLn('TCodeToolManager.FixIncludeFilenames Missing: ',MissingIncludeFiles.Text);
@ -3545,6 +3609,7 @@ begin
Result.JumpCentered:=FJumpCentered;
Result.CursorBeyondEOL:=FCursorBeyondEOL;
TCodeTool(Result).OnGetCodeToolForBuffer:=@OnGetCodeToolForBuffer;
TCodeTool(Result).OnGetDirectoryCache:=@OnGetDirectoryCache;
TCodeTool(Result).OnFindUsedUnit:=@DoOnFindUsedUnit;
TCodeTool(Result).OnGetSrcPathForCompiledUnit:=@DoOnGetSrcPathForCompiledUnit;
Result.OnSetGlobalWriteLock:=@OnToolSetWriteLock;
@ -3578,6 +3643,12 @@ begin
Result:=TFindDeclarationTool(GetCodeToolForSource(Code,GoToMainCode,true));
end;
function TCodeToolManager.OnGetDirectoryCache(const ADirectory: string
): TCTDirectoryCache;
begin
Result:=DirectoryCachePool.GetCache(ADirectory,true,true);
end;
procedure TCodeToolManager.ActivateWriteLock;
begin
if FWriteLockCount=0 then begin
@ -3644,6 +3715,19 @@ begin
end;
end;
function TCodeToolManager.DirectoryCachePoolGetString(const ADirectory: string;
const AStringType: TCTDirCacheString): string;
begin
case AStringType of
ctdcsUnitPath: Result:=GetUnitPathForDirectory(ADirectory,false);
ctdcsSrcPath: Result:=GetSrcPathForDirectory(ADirectory,false);
ctdcsIncludePath: Result:=GetIncludePathForDirectory(ADirectory,false);
ctdcsCompleteSrcPath: Result:=GetCompleteSrcPathForDirectory(ADirectory,false);
ctdcsUnitLinks: Result:=GetUnitLinksForDirectory(ADirectory,false)
else RaiseCatchableException('');
end;
end;
procedure TCodeToolManager.OnToolSetWriteLock(Lock: boolean);
begin
if Lock then ActivateWriteLock else DeactivateWriteLock;

143
components/codetools/codetoolsstructs.pas
View File

@ -35,7 +35,7 @@ unit CodeToolsStructs;
interface
uses
Classes, SysUtils, CodeCache, CodeAtom;
Classes, SysUtils, AVL_Tree, CodeCache, CodeAtom;
type
TResourcestringInsertPolicy = (
@ -88,10 +88,62 @@ const
'public',
'published'
);
type
TStringToStringTreeItem = record
Name: string;
Value: string;
end;
PStringToStringTreeItem = ^TStringToStringTreeItem;
{ TStringToStringTree }
TStringToStringTree = class
private
FTree: TAVLTree;// tree of TStringToStringTreeItem
FCaseSensitive: boolean;
function GetStrings(const s: string): string;
procedure SetStrings(const s: string; const AValue: string);
function FindNode(const s: string): TAVLTreeNode;
public
constructor Create(TheCaseSensitive: boolean);
destructor Destroy; override;
procedure Clear;
function Contains(const s: string): boolean;
function GetString(const Name: string; out Value: string): boolean;
property Strings[const s: string]: string read GetStrings write SetStrings; default;
property CaseSensitive: boolean read FCaseSensitive;
end;
function CompareStringToStringItems(Data1, Data2: Pointer): integer;
function CompareStringToStringItemsI(Data1, Data2: Pointer): integer;
function CompareStringAndStringToStringTreeItem(Key, Data: Pointer): integer;
function CompareStringAndStringToStringTreeItemI(Key, Data: Pointer): integer;
implementation
function CompareStringToStringItems(Data1, Data2: Pointer): integer;
begin
Result:=CompareStr(PStringToStringTreeItem(Data1)^.Name,
PStringToStringTreeItem(Data2)^.Name);
end;
function CompareStringToStringItemsI(Data1, Data2: Pointer): integer;
begin
Result:=CompareText(PStringToStringTreeItem(Data1)^.Name,
PStringToStringTreeItem(Data2)^.Name);
end;
function CompareStringAndStringToStringTreeItem(Key, Data: Pointer): integer;
begin
Result:=CompareStr(String(Key),PStringToStringTreeItem(Data)^.Name);
end;
function CompareStringAndStringToStringTreeItemI(Key, Data: Pointer): integer;
begin
Result:=CompareText(String(Key),PStringToStringTreeItem(Data)^.Name);
end;
{ TCodeXYPositions }
@ -245,5 +297,92 @@ begin
Result.Assign(Self);
end;
{ TStringToStringTree }
function TStringToStringTree.GetStrings(const s: string): string;
var
Node: TAVLTreeNode;
begin
Node:=FindNode(s);
if Node<>nil then
Result:=PStringToStringTreeItem(Node.Data)^.Value
else
Result:=''
end;
procedure TStringToStringTree.SetStrings(const s: string; const AValue: string);
var
Node: TAVLTreeNode;
NewItem: PStringToStringTreeItem;
begin
Node:=FindNode(s);
if Node<>nil then begin
PStringToStringTreeItem(Node.Data)^.Value:=AValue;
end else begin
New(NewItem);
NewItem^.Name:=s;
NewItem^.Value:=AValue;
FTree.Add(NewItem);
end;
end;
function TStringToStringTree.FindNode(const s: string): TAVLTreeNode;
begin
if CaseSensitive then
Result:=FTree.FindKey(Pointer(s),@CompareStringAndStringToStringTreeItem)
else
Result:=FTree.FindKey(Pointer(s),@CompareStringAndStringToStringTreeItemI);
end;
constructor TStringToStringTree.Create(TheCaseSensitive: boolean);
begin
FCaseSensitive:=TheCaseSensitive;
if CaseSensitive then
FTree:=TAVLTree.Create(@CompareStringToStringItems)
else
FTree:=TAVLTree.Create(@CompareStringToStringItemsI);
end;
destructor TStringToStringTree.Destroy;
begin
Clear;
FTree.Free;
FTree:=nil;
inherited Destroy;
end;
procedure TStringToStringTree.Clear;
var
Node: TAVLTreeNode;
Item: PStringToStringTreeItem;
begin
Node:=FTree.FindLowest;
while Node<>nil do begin
Item:=PStringToStringTreeItem(Node.Data);
Dispose(Item);
Node:=FTree.FindSuccessor(Node);
end;
FTree.Clear;
end;
function TStringToStringTree.Contains(const s: string): boolean;
begin
Result:=FindNode(s)<>nil;
end;
function TStringToStringTree.GetString(const Name: string; out Value: string
): boolean;
var
Node: TAVLTreeNode;
begin
Node:=FindNode(Name);
if Node<>nil then begin
Value:=PStringToStringTreeItem(Node.Data)^.Value;
Result:=true;
end else begin
Result:=false;
end;
end;
end.

200
components/codetools/definetemplates.pas
View File

@ -54,7 +54,7 @@ unit DefineTemplates;
interface
uses
Classes, SysUtils, CodeToolsStrConsts, ExprEval,
Classes, SysUtils, CodeToolsStrConsts, ExprEval, DirectoryCache,
Laz_XMLCfg, AVL_Tree,
Process, KeywordFuncLists, FileProcs;
@ -63,11 +63,11 @@ const
// 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';
StdDefTemplFPCSrc = 'Free Pascal sources';
StdDefTemplLazarusSources = 'Lazarus sources';
StdDefTemplLazarusSrcDir = 'Lazarus source directory';
StdDefTemplLazarusBuildOpts = 'Lazarus build options';
StdDefTemplLCLProject = 'LCL project';
// Standard macros
DefinePathMacroName = ExternalMacroStart+'DefinePath';
@ -270,7 +270,6 @@ type
public
Path: string;
Values: TExpressionEvaluator;
UnitLinksTree: TAVLTree;
constructor Create;
destructor Destroy; override;
end;
@ -294,6 +293,7 @@ type
TDefineTree = class
private
FDirectoryCachePool: TCTDirectoryCachePool;
FFirstDefineTemplate: TDefineTemplate;
FCache: TAVLTree; // tree of TDirectoryDefines
FChangeStep: integer;
@ -308,6 +308,7 @@ type
FVirtualDirCache: TDirectoryDefines;
function Calculate(DirDef: TDirectoryDefines): boolean;
procedure IncreaseChangeStep;
procedure SetDirectoryCachePool(const AValue: TCTDirectoryCachePool);
protected
function FindDirectoryInCache(const Path: string): TDirectoryDefines;
function GetDirDefinesForDirectory(const Path: string;
@ -353,8 +354,6 @@ type
function GetPPWSrcPathForDirectory(const Directory: string): string;
function GetSrcPathForDirectory(const Directory: string): string;
function GetUnitPathForDirectory(const Directory: string): string;
function FindUnitInUnitLinks(const AnUnitName, Directory: string;
WithVirtualDir: boolean): string;
function IsEqual(SrcDefineTree: TDefineTree): boolean;
procedure Add(ADefineTemplate: TDefineTemplate);
procedure AddChild(ParentTemplate, NewDefineTemplate: TDefineTemplate);
@ -384,6 +383,7 @@ type
ADefineTemplate: TDefineTemplate);
procedure ReplaceRootSameNameAddFirst(ADefineTemplate: TDefineTemplate);
procedure WriteDebugReport;
property DirectoryCachePool: TCTDirectoryCachePool read FDirectoryCachePool write SetDirectoryCachePool;
end;
//---------------------------------------------------------------------------
@ -455,9 +455,6 @@ const
function DefineActionNameToAction(const s: string): TDefineAction;
function DefineTemplateFlagsToString(Flags: TDefineTemplateFlags): string;
function SearchUnitInUnitLinks(const UnitLinks, TheUnitName: string;
var UnitLinkStart, UnitLinkEnd: integer; var Filename: string): boolean;
function CreateUnitLinksTree(const UnitLinks: string): TAVLTree;
function GetDefaultSrcOSForTargetOS(const TargetOS: string): string;
function GetDefaultSrcOS2ForTargetOS(const TargetOS: string): string;
procedure SplitLazarusCPUOSWidgetCombo(const Combination: string;
@ -472,7 +469,7 @@ implementation
type
TUnitNameLink = class
TDefTemplUnitNameLink = class
public
UnitName: string;
Filename: string;
@ -502,17 +499,17 @@ begin
end;
function CompareUnitLinkNodes(NodeData1, NodeData2: pointer): integer;
var Link1, Link2: TUnitNameLink;
var Link1, Link2: TDefTemplUnitNameLink;
begin
Link1:=TUnitNameLink(NodeData1);
Link2:=TUnitNameLink(NodeData2);
Link1:=TDefTemplUnitNameLink(NodeData1);
Link2:=TDefTemplUnitNameLink(NodeData2);
Result:=CompareText(Link1.UnitName,Link2.UnitName);
end;
function CompareUnitNameWithUnitLinkNode(UnitName: Pointer;
NodeData: pointer): integer;
begin
Result:=CompareText(String(UnitName),TUnitNameLink(NodeData).UnitName);
Result:=CompareText(String(UnitName),TDefTemplUnitNameLink(NodeData).UnitName);
end;
function CompareDirectoryDefines(NodeData1, NodeData2: pointer): integer;
@ -523,125 +520,6 @@ begin
Result:=CompareFilenames(DirDef1.Path,DirDef2.Path);
end;
function SearchUnitInUnitLinks(const UnitLinks, TheUnitName: string;
var UnitLinkStart, UnitLinkEnd: integer; var Filename: string): boolean;
var
UnitLinkLen: integer;
pe: TCTPascalExtType;
AliasFilename: String;
begin
Result:=false;
Filename:='';
if TheUnitName='' then exit;
{$IFDEF ShowTriedFiles}
DebugLn('SearchUnitInUnitLinks length(UnitLinks)=',length(UnitLinks));
{$ENDIF}
if UnitLinkStart<1 then
UnitLinkStart:=1;
while UnitLinkStart<=length(UnitLinks) do begin
while (UnitLinkStart<=length(UnitLinks))
and (UnitLinks[UnitLinkStart] in [#10,#13]) do
inc(UnitLinkStart);
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks)) and (UnitLinks[UnitLinkEnd]<>' ')
do
inc(UnitLinkEnd);
UnitLinkLen:=UnitLinkEnd-UnitLinkStart;
if UnitLinkLen>0 then begin
{$IFDEF ShowTriedFiles}
DebugLn(' unit "',copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart),'" ',
AnsiStrLIComp(PChar(TheUnitName),@UnitLinks[UnitLinkStart],UnitLinkLen));
{$ENDIF}
if (UnitLinkLen=length(TheUnitName))
and (AnsiStrLIComp(PChar(TheUnitName),@UnitLinks[UnitLinkStart],
UnitLinkLen)=0)
then begin
// unit found -> parse filename
UnitLinkStart:=UnitLinkEnd+1;
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks))
and (not (UnitLinks[UnitLinkEnd] in [#10,#13])) do
inc(UnitLinkEnd);
if UnitLinkEnd>UnitLinkStart then begin
Filename:=copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart);
if FileExistsCached(Filename) then begin
Result:=true;
exit;
end;
// try also different extensions
for pe:=Low(TCTPascalExtType) to High(TCTPascalExtType) do begin
if CompareFileExt(Filename,CTPascalExtension[pe],false)<>0 then
begin
AliasFilename:=ChangeFileExt(Filename,'.pas');
if FileExistsCached(AliasFilename) then begin
Filename:=AliasFilename;
Result:=true;
exit;
end;
end;
end;
end;
UnitLinkStart:=UnitLinkEnd;
end else begin
UnitLinkStart:=UnitLinkEnd+1;
while (UnitLinkStart<=length(UnitLinks))
and (not (UnitLinks[UnitLinkStart] in [#10,#13])) do
inc(UnitLinkStart);
end;
end else
break;
end;
end;
function CreateUnitLinksTree(const UnitLinks: string): TAVLTree;
var
UnitLinksTree: TAVLTree;
UnitLinkLen: integer;
UnitLinkStart: Integer;
UnitLinkEnd: Integer;
TheUnitName: String;
Filename: String;
NewNode: TUnitNameLink;
begin
UnitLinksTree:=TAVLTree.Create(@CompareUnitLinkNodes);
UnitLinkStart:=1;
while UnitLinkStart<=length(UnitLinks) do begin
while (UnitLinkStart<=length(UnitLinks))
and (UnitLinks[UnitLinkStart] in [#10,#13]) do
inc(UnitLinkStart);
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks)) and (UnitLinks[UnitLinkEnd]<>' ')
do
inc(UnitLinkEnd);
UnitLinkLen:=UnitLinkEnd-UnitLinkStart;
if UnitLinkLen>0 then begin
TheUnitName:=copy(UnitLinks,UnitLinkStart,UnitLinkLen);
if IsValidIdent(TheUnitName) then begin
UnitLinkStart:=UnitLinkEnd+1;
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks))
and (not (UnitLinks[UnitLinkEnd] in [#10,#13])) do
inc(UnitLinkEnd);
if UnitLinkEnd>UnitLinkStart then begin
Filename:=copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart);
NewNode:=TUnitNameLink.Create;
NewNode.UnitName:=TheUnitName;
NewNode.Filename:=Filename;
UnitLinksTree.Add(NewNode);
end;
UnitLinkStart:=UnitLinkEnd;
end else begin
UnitLinkStart:=UnitLinkEnd+1;
while (UnitLinkStart<=length(UnitLinks))
and (not (UnitLinks[UnitLinkStart] in [#10,#13])) do
inc(UnitLinkStart);
end;
end else
break;
end;
Result:=UnitLinksTree;
end;
function GetDefaultSrcOSForTargetOS(const TargetOS: string): string;
begin
Result:='';
@ -1685,10 +1563,6 @@ end;
destructor TDirectoryDefines.Destroy;
begin
Values.Free;
if UnitLinksTree<>nil then begin
UnitLinksTree.FreeAndClear;
UnitLinksTree.Free;
end;
inherited Destroy;
end;
@ -1935,32 +1809,6 @@ begin
end;
end;
function TDefineTree.FindUnitInUnitLinks(const AnUnitName, Directory: string;
WithVirtualDir: boolean): string;
var
DirDef: TDirectoryDefines;
UnitLinks: string;
AVLNode: TAVLTreeNode;
begin
Result:='';
if AnUnitName='' then exit;
DirDef:=GetDirDefinesForDirectory(Directory,WithVirtualDir);
if (DirDef=nil) or (DirDef.Values=nil) then exit;
if DirDef.UnitLinksTree=nil then begin
// create tree
UnitLinks:=DirDef.Values[ExternalMacroStart+'UnitLinks'];
// cache tree
DirDef.UnitLinksTree:=CreateUnitLinksTree(UnitLinks);
end;
// search in tree
if DirDef.UnitLinksTree<>nil then begin
AVLNode:=DirDef.UnitLinksTree.FindKey(PChar(AnUnitName),
@CompareUnitNameWithUnitLinkNode);
if AVLNode<>nil then
Result:=TUnitNameLink(AVLNode.Data).Filename;
end;
end;
function TDefineTree.GetIncludePathForDirectory(const Directory: string
): string;
var Evaluator: TExpressionEvaluator;
@ -2455,6 +2303,14 @@ begin
inc(FChangeStep)
else
FChangeStep:=-$7fffffff;
if DirectoryCachePool<>nil then DirectoryCachePool.IncreaseTimeStamp;
end;
procedure TDefineTree.SetDirectoryCachePool(const AValue: TCTDirectoryCachePool
);
begin
if FDirectoryCachePool=AValue then exit;
FDirectoryCachePool:=AValue;
end;
procedure TDefineTree.Add(ADefineTemplate: TDefineTemplate);
@ -2972,19 +2828,19 @@ var
Dir, TargetOS, SrcOS, SrcOS2, TargetProcessor, UnitLinks,
IncPathMacro, SrcPathMacro: string;
DS: char; // dir separator
UnitTree: TAVLTree; // tree of TUnitNameLink
UnitTree: TAVLTree; // tree of TDefTemplUnitNameLink
DefaultSrcOS, DefaultSrcOS2: string;
procedure GatherUnits; forward;
function FindUnitLink(const AnUnitName: string): TUnitNameLink;
function FindUnitLink(const AnUnitName: string): TDefTemplUnitNameLink;
var ANode: TAVLTreeNode;
cmp: integer;
begin
if UnitTree=nil then GatherUnits;
ANode:=UnitTree.Root;
while ANode<>nil do begin
Result:=TUnitNameLink(ANode.Data);
Result:=TDefTemplUnitNameLink(ANode.Data);
cmp:=CompareText(AnUnitName,Result.UnitName);
if cmp<0 then
ANode:=ANode.Left
@ -3098,7 +2954,7 @@ var
var
AFilename, Ext, UnitName, MacroFileName: string;
FileInfo: TSearchRec;
NewUnitLink, OldUnitLink: TUnitNameLink;
NewUnitLink, OldUnitLink: TDefTemplUnitNameLink;
i: integer;
DefaultMacroCount: integer;
Priority: Integer;
@ -3141,7 +2997,7 @@ var
MacroFileName:=BuildMacroFileName(AFilename,DefaultMacroCount);
if OldUnitLink=nil then begin
// first unit with this name
NewUnitLink:=TUnitNameLink.Create;
NewUnitLink:=TDefTemplUnitNameLink.Create;
NewUnitLink.UnitName:=UnitName;
NewUnitLink.FileName:=MacroFileName;
NewUnitLink.DefaultMacroCount:=DefaultMacroCount;
@ -3250,7 +3106,7 @@ var
procedure AddFPCSourceLinkForUnit(const AnUnitName: string);
var UnitLink: TUnitNameLink;
var UnitLink: TDefTemplUnitNameLink;
s: string;
begin
// search

766
components/codetools/directorycache.pas
View File

@ -35,20 +35,772 @@ unit DirectoryCache;
interface
uses
Classes, SysUtils;
type
TCTDirectoryCache = class
public
Classes, SysUtils, FileProcs, AVL_Tree, CodeToolsStructs;
{$ifdef win32}
{$define CaseInsensitiveFilenames}
{$endif}
type
TCTDirCacheString = (
ctdcsUnitPath,
ctdcsSrcPath,
ctdcsIncludePath,
ctdcsCompleteSrcPath, // including unit path, src path and compiled src paths
ctdcsUnitLinks
);
TCTDirCacheStringRecord = record
Value: string;
TimeStamp: cardinal;
end;
TCTDirectoryCachePool = class
TCTDirectoryUnitSources = (
ctdusUnitNormal,
ctdusUnitCaseInsensitive,
ctdusInFilenameNormal,
ctdusInFilenameCaseInsenstive
);
TCTDirCacheUnitSrcRecord = record
Files: TStringToStringTree;
TimeStamp: cardinal;
end;
{ TCTDirectoryListing }
TCTDirectoryListing = class
public
TimeStamp: cardinal;
Names: PChar; // all filenames separated with #0
NameCount: integer;
NameStarts: PInteger; // offsets in 'Names'
destructor Destroy; override;
procedure Clear;
end;
TCTDirectoryCachePool = class;
{ TCTDirectoryCache }
TCTDirectoryCache = class
private
FDirectory: string;
FPool: TCTDirectoryCachePool;
FRefCount: integer;
FStrings: array[TCTDirCacheString] of TCTDirCacheStringRecord;
FUnitLinksTree: TAVLTree;
FUnitLinksTreeTimeStamp: cardinal;
FListing: TCTDirectoryListing;
FUnitSources: array[TCTDirectoryUnitSources] of TCTDirCacheUnitSrcRecord;
function GetStrings(const AStringType: TCTDirCacheString): string;
procedure SetStrings(const AStringType: TCTDirCacheString;
const AValue: string);
procedure ClearUnitLinks;
procedure UpdateListing;
public
constructor Create(const TheDirectory: string;
ThePool: TCTDirectoryCachePool);
destructor Destroy; override;
procedure Reference;
procedure Release;
function FindUnitLink(const UnitName: string): string;
function FindFile(const ShortFilename: string;
const FileCase: TCTSearchFileCase): string;
function FindUnitSource(var UnitName, InFilename: string;
AnyCase: boolean): string;
public
property Directory: string read FDirectory;
property RefCount: integer read FRefCount;
property Pool: TCTDirectoryCachePool read FPool;
property Strings[const AStringType: TCTDirCacheString]: string read GetStrings write SetStrings;
end;
{ TCTDirectoryCachePool }
TCTDirCacheGetString = function(const ADirectory: string;
const AStringType: TCTDirCacheString
): string of object;
TCTDirectoryCachePool = class
private
FOnGetString: TCTDirCacheGetString;
FTimeStamp: cardinal;
FDirectories: TAVLTree;
procedure DoRemove(ACache: TCTDirectoryCache);
procedure OnFileStateCacheChangeTimeStamp(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
function GetCache(const Directory: string;
CreateIfNotExists: boolean = true;
DoReference: boolean = true): TCTDirectoryCache;
function GetString(const Directory: string; AStringType: TCTDirCacheString;
UseCache: boolean = true): string;
procedure IncreaseTimeStamp;
function FindUnitInUnitLinks(const Directory, UnitName: string): string;
property TimeStamp: cardinal read FTimeStamp;
property OnGetString: TCTDirCacheGetString read FOnGetString write FOnGetString;
end;
function CompareCTDirectoryCaches(Data1, Data2: Pointer): integer;
function ComparePAnsiStringAndDirectoryCache(Dir, Cache: Pointer): integer;
function ComparePCharFirstCaseInsThenCase(Data1, Data2: Pointer): integer;
type
TUnitNameLink = class
public
UnitName: string;
Filename: string;
end;
function SearchUnitInUnitLinks(const UnitLinks, TheUnitName: string;
var UnitLinkStart, UnitLinkEnd: integer; out Filename: string): boolean;
function CreateUnitLinksTree(const UnitLinks: string): TAVLTree;
function CompareUnitLinkNodes(NodeData1, NodeData2: pointer): integer;
function CompareUnitNameWithUnitLinkNode(UnitName: Pointer;
NodeData: pointer): integer;
implementation
function CompareCTDirectoryCaches(Data1, Data2: Pointer): integer;
begin
Result:=CompareFilenames(TCTDirectoryCache(Data1).FDirectory,
TCTDirectoryCache(Data2).FDirectory);
end;
function ComparePAnsiStringAndDirectoryCache(Dir, Cache: Pointer): integer;
begin
Result:=CompareFilenames(PAnsiString(Dir)^,TCTDirectoryCache(Cache).FDirectory);
end;
function ComparePCharFirstCaseInsThenCase(Data1, Data2: Pointer): integer;
var
p1: PChar;
p2: PChar;
begin
// first compare both filenames case insensitive
p1:=PChar(Data1);
p2:=PChar(Data2);
while (FPUpChars[p1^]=FPUpChars[p2^]) and (p1^<>#0) do begin
inc(p1);
inc(p2);
end;
Result:=ord(FPUpChars[p1^])-ord(FPUpChars[p2^]);
if Result=0 then begin
// then compare both filenames case sensitive
p1:=PChar(Data1);
p2:=PChar(Data2);
while (p1^=p2^) and (p1^<>#0) do begin
inc(p1);
inc(p2);
end;
Result:=ord(p1^)-ord(p2^);
end;
end;
function SearchUnitInUnitLinks(const UnitLinks, TheUnitName: string;
var UnitLinkStart, UnitLinkEnd: integer; out Filename: string): boolean;
var
UnitLinkLen: integer;
pe: TCTPascalExtType;
AliasFilename: String;
begin
Result:=false;
Filename:='';
if TheUnitName='' then exit;
{$IFDEF ShowTriedFiles}
DebugLn('SearchUnitInUnitLinks length(UnitLinks)=',length(UnitLinks));
{$ENDIF}
if UnitLinkStart<1 then
UnitLinkStart:=1;
while UnitLinkStart<=length(UnitLinks) do begin
while (UnitLinkStart<=length(UnitLinks))
and (UnitLinks[UnitLinkStart] in [#10,#13]) do
inc(UnitLinkStart);
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks)) and (UnitLinks[UnitLinkEnd]<>' ')
do
inc(UnitLinkEnd);
UnitLinkLen:=UnitLinkEnd-UnitLinkStart;
if UnitLinkLen>0 then begin
{$IFDEF ShowTriedFiles}
DebugLn(' unit "',copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart),'" ',
AnsiStrLIComp(PChar(TheUnitName),@UnitLinks[UnitLinkStart],UnitLinkLen));
{$ENDIF}
if (UnitLinkLen=length(TheUnitName))
and (AnsiStrLIComp(PChar(TheUnitName),@UnitLinks[UnitLinkStart],
UnitLinkLen)=0)
then begin
// unit found -> parse filename
UnitLinkStart:=UnitLinkEnd+1;
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks))
and (not (UnitLinks[UnitLinkEnd] in [#10,#13])) do
inc(UnitLinkEnd);
if UnitLinkEnd>UnitLinkStart then begin
Filename:=copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart);
if FileExistsCached(Filename) then begin
Result:=true;
exit;
end;
// try also different extensions
for pe:=Low(TCTPascalExtType) to High(TCTPascalExtType) do begin
if CompareFileExt(Filename,CTPascalExtension[pe],false)<>0 then
begin
AliasFilename:=ChangeFileExt(Filename,'.pas');
if FileExistsCached(AliasFilename) then begin
Filename:=AliasFilename;
Result:=true;
exit;
end;
end;
end;
end;
UnitLinkStart:=UnitLinkEnd;
end else begin
UnitLinkStart:=UnitLinkEnd+1;
while (UnitLinkStart<=length(UnitLinks))
and (not (UnitLinks[UnitLinkStart] in [#10,#13])) do
inc(UnitLinkStart);
end;
end else
break;
end;
end;
function CreateUnitLinksTree(const UnitLinks: string): TAVLTree;
var
UnitLinksTree: TAVLTree;
UnitLinkLen: integer;
UnitLinkStart: Integer;
UnitLinkEnd: Integer;
TheUnitName: String;
Filename: String;
NewNode: TUnitNameLink;
begin
UnitLinksTree:=TAVLTree.Create(@CompareUnitLinkNodes);
UnitLinkStart:=1;
while UnitLinkStart<=length(UnitLinks) do begin
while (UnitLinkStart<=length(UnitLinks))
and (UnitLinks[UnitLinkStart] in [#10,#13]) do
inc(UnitLinkStart);
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks)) and (UnitLinks[UnitLinkEnd]<>' ')
do
inc(UnitLinkEnd);
UnitLinkLen:=UnitLinkEnd-UnitLinkStart;
if UnitLinkLen>0 then begin
TheUnitName:=copy(UnitLinks,UnitLinkStart,UnitLinkLen);
if IsValidIdent(TheUnitName) then begin
UnitLinkStart:=UnitLinkEnd+1;
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks))
and (not (UnitLinks[UnitLinkEnd] in [#10,#13])) do
inc(UnitLinkEnd);
if UnitLinkEnd>UnitLinkStart then begin
Filename:=copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart);
NewNode:=TUnitNameLink.Create;
NewNode.UnitName:=TheUnitName;
NewNode.Filename:=Filename;
UnitLinksTree.Add(NewNode);
end;
UnitLinkStart:=UnitLinkEnd;
end else begin
UnitLinkStart:=UnitLinkEnd+1;
while (UnitLinkStart<=length(UnitLinks))
and (not (UnitLinks[UnitLinkStart] in [#10,#13])) do
inc(UnitLinkStart);
end;
end else
break;
end;
Result:=UnitLinksTree;
end;
function CompareUnitLinkNodes(NodeData1, NodeData2: pointer): integer;
var Link1, Link2: TUnitNameLink;
begin
Link1:=TUnitNameLink(NodeData1);
Link2:=TUnitNameLink(NodeData2);
Result:=CompareText(Link1.UnitName,Link2.UnitName);
end;
function CompareUnitNameWithUnitLinkNode(UnitName: Pointer;
NodeData: pointer): integer;
begin
Result:=CompareText(String(UnitName),TUnitNameLink(NodeData).UnitName);
end;
{ TCTDirectoryCache }
function TCTDirectoryCache.GetStrings(const AStringType: TCTDirCacheString
): string;
begin
if FStrings[AStringType].TimeStamp<>Pool.TimeStamp then begin
Strings[AStringType]:=Pool.GetString(Directory,AStringType,false);
end;
Result:=FStrings[AStringType].Value;
end;
procedure TCTDirectoryCache.SetStrings(const AStringType: TCTDirCacheString;
const AValue: string);
begin
FStrings[AStringType].Value:=AValue;
FStrings[AStringType].TimeStamp:=Pool.TimeStamp;
end;
procedure TCTDirectoryCache.ClearUnitLinks;
begin
if FUnitLinksTree=nil then exit;
FUnitLinksTree.FreeAndClear;
FUnitLinksTree.Free;
FUnitLinksTree:=nil
end;
procedure TCTDirectoryCache.UpdateListing;
var
WorkingListing: PAnsiString;
WorkingListingCapacity, WorkingListingCount: integer;
FileInfo: TSearchRec;
TotalLen: Integer;
i: Integer;
p: Integer;
CurFilenameLen: Integer;
NewCapacity: Integer;
begin
if (FListing<>nil) and (FListing.TimeStamp=Pool.TimeStamp) then exit;
if FListing=nil then
FListing:=TCTDirectoryListing.Create;
FListing.Clear;
FListing.TimeStamp:=Pool.TimeStamp;
// read the directory
WorkingListing:=nil;
WorkingListingCapacity:=0;
WorkingListingCount:=0;
if SysUtils.FindFirst(Directory+FileMask,faAnyFile,FileInfo)=0 then begin
repeat
// check if special file
if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
then
continue;
// add file
if WorkingListingCount=WorkingListingCapacity then begin
// grow WorkingListing
if WorkingListingCapacity>0 then
NewCapacity:=WorkingListingCapacity*2
else
NewCapacity:=8;
ReAllocMem(WorkingListing,SizeOf(Pointer)*NewCapacity);
FillChar(WorkingListing[WorkingListingCount],
SizeOf(Pointer)*(NewCapacity-WorkingListingCapacity),0);
WorkingListingCapacity:=NewCapacity;
end;
WorkingListing[WorkingListingCount]:=FileInfo.Name;
inc(WorkingListingCount);
until SysUtils.FindNext(FileInfo)<>0;
end;
SysUtils.FindClose(FileInfo);
if WorkingListingCount=0 then exit;
// sort the files
MergeSort(PPointer(WorkingListing),WorkingListingCount,
@ComparePCharFirstCaseInsThenCase);
// create listing
TotalLen:=0;
for i:=0 to WorkingListingCount-1 do
inc(TotalLen,length(WorkingListing[i])+1);
GetMem(FListing.Names,TotalLen);
FListing.NameCount:=WorkingListingCount;
p:=0;
for i:=0 to WorkingListingCount-1 do begin
CurFilenameLen:=length(WorkingListing[i]);
if CurFilenameLen>0 then begin
System.Move(WorkingListing[i][1],FListing.Names[p],CurFilenameLen);
inc(p,CurFilenameLen);
end;
FListing.Names[p]:=#0;
inc(p);
end;
end;
constructor TCTDirectoryCache.Create(const TheDirectory: string;
ThePool: TCTDirectoryCachePool);
begin
FDirectory:=AppendPathDelim(TrimFilename(TheDirectory));
FPool:=ThePool;
FRefCount:=1;
end;
destructor TCTDirectoryCache.Destroy;
var
UnitSrc: TCTDirectoryUnitSources;
begin
ClearUnitLinks;
Pool.DoRemove(Self);
FreeAndNil(FListing);
for UnitSrc:=Low(TCTDirectoryUnitSources) to High(TCTDirectoryUnitSources) do
FreeAndNil(FUnitSources[UnitSrc].Files);
inherited Destroy;
end;
procedure TCTDirectoryCache.Reference;
begin
inc(FRefCount);
end;
procedure TCTDirectoryCache.Release;
begin
if FRefCount<=0 then
raise Exception.Create('TCTDirectoryCache.Release');
dec(FRefCount);
if FRefCount=0 then Free;
end;
function TCTDirectoryCache.FindUnitLink(const UnitName: string): string;
var
Node: TAVLTreeNode;
Link: TUnitNameLink;
AliasFilename: String;
pe: TCTPascalExtType;
begin
if (FUnitLinksTree=nil) or (FUnitLinksTreeTimeStamp<>Pool.TimeStamp) then
begin
ClearUnitLinks;
FUnitLinksTreeTimeStamp:=Pool.TimeStamp;
FUnitLinksTree:=CreateUnitLinksTree(Strings[ctdcsUnitLinks]);
end;
Node:=FUnitLinksTree.FindKey(Pointer(UnitName),
@CompareUnitNameWithUnitLinkNode);
if Node<>nil then begin
Link:=TUnitNameLink(Node.Data);
Result:=Link.Filename;
if FileExistsCached(Result) then begin
exit;
end;
// try also different extensions
for pe:=Low(TCTPascalExtType) to High(TCTPascalExtType) do begin
if CompareFileExt(Result,CTPascalExtension[pe],false)<>0 then
begin
AliasFilename:=ChangeFileExt(Result,CTPascalExtension[pe]);
if FileExistsCached(AliasFilename) then begin
Link.Filename:=AliasFilename;
Result:=AliasFilename;
exit;
end;
end;
end;
end;
Result:='';
end;
function TCTDirectoryCache.FindFile(const ShortFilename: string;
const FileCase: TCTSearchFileCase): string;
procedure RaiseDontKnow;
begin
raise Exception.Create('dont know FileCase '+IntToStr(ord(FileCase)));
end;
var
l: Integer;
r: Integer;
m: Integer;
cmp: LongInt;
CurFilename: PChar;
begin
if ShortFilename='' then exit('');
UpdateListing;
Result:='';
if (FListing.Names=nil) then exit;
l:=0;
r:=FListing.NameCount-1;
while r>=l do begin
m:=(l+r) shr 1;
CurFilename:=@FListing.Names[FListing.NameStarts[m]];
case FileCase of
ctsfcDefault:
{$IFDEF CaseInsensitiveFilenames}
cmp:=stricomp(PChar(ShortFilename),CurFilename);
{$ELSE}
cmp:=strcomp(PChar(ShortFilename),CurFilename);
{$ENDIF}
ctsfcAllCase,ctsfcLoUpCase:
cmp:=stricomp(PChar(ShortFilename),CurFilename);
else RaiseDontKnow;
end;
if cmp>0 then
l:=m
else if cmp<0 then
r:=m
else begin
Result:=CurFilename;
exit;
end;
end;
end;
function TCTDirectoryCache.FindUnitSource(var UnitName, InFilename: string;
AnyCase: boolean): string;
var
UnitSrc: TCTDirectoryUnitSources;
function GetUnitSourceCacheValue(const Search: string;
var Filename: string): boolean;
var
Files: TStringToStringTree;
begin
Files:=FUnitSources[UnitSrc].Files;
if (FUnitSources[UnitSrc].TimeStamp<>Pool.TimeStamp) then begin
// cache is invalid -> clear to make it valid
if Files<>nil then
Files.Clear;
FUnitSources[UnitSrc].TimeStamp:=Pool.TimeStamp;
Result:=false;
end else begin
// cache is valid
if Files<>nil then begin
Result:=Files.GetString(Search,Filename);
end else begin
Result:=false;
end;
end;
end;
procedure AddToCache(const Search, Filename: string);
var
Files: TStringToStringTree;
begin
Files:=FUnitSources[UnitSrc].Files;
if Files=nil then begin
Files:=TStringToStringTree.Create(not AnyCase);
FUnitSources[UnitSrc].Files:=Files;
end;
Files[Search]:=Filename;
end;
var
CurDir: String;
SrcPath: string;
NewUnitName: String;
SearchCase: TCTSearchFileCase;
begin
if InFilename<>'' then begin
// uses IN parameter
InFilename:=TrimFilename(SetDirSeparators(InFilename));
if AnyCase then
UnitSrc:=ctdusInFilenameCaseInsenstive
else
UnitSrc:=ctdusInFilenameNormal;
if GetUnitSourceCacheValue(InFilename,Result) then begin
// found in cache
if Result<>'' then begin
// unit found
if Directory<>'' then
InFilename:=CreateRelativePath(Result,Directory);
end else begin
// unit not found
end;
end else begin
// not found in cache -> search
if FilenameIsAbsolute(InFilename) then begin
if AnyCase then
Result:=FindDiskFilename(InFilename)
else
Result:=InFilename;
if FileExistsCached(Result) then
InFilename:=Result
else
Result:='';
end else begin
// file is relative to current directory
// -> search file in current directory
CurDir:=Directory;
if CurDir<>'' then begin
if AnyCase then
Result:=SearchFileInDir(InFilename,CurDir,ctsfcAllCase)
else
Result:=TrimFilename(CurDir+InFilename);
if FileExistsCached(Result) then begin
InFilename:=CreateRelativePath(Result,CurDir);
end else begin
Result:='';
end;
end else begin
// virtual directory -> TODO
Result:='';
end;
end;
AddToCache(InFilename,Result);
end;
end else begin
// normal unit name
if AnyCase then
UnitSrc:=ctdusUnitCaseInsensitive
else
UnitSrc:=ctdusUnitNormal;
if GetUnitSourceCacheValue(UnitName,Result) then begin
// found in cache
if Result<>'' then begin
// unit found
end else begin
// unit not found
end;
end else begin
// not found in cache -> search
// search in unit, src and compiled src path
SrcPath:=Strings[ctdcsCompleteSrcPath];
if SysUtils.CompareText(UnitName,'Forms')=0 then begin
DebugLn('============================================================== ');
DebugLn('TFindDeclarationTool.FindUnitCaseInsensitive ',SrcPath);
end;
CurDir:=Directory;
if CurDir<>'' then begin
// search in search path
if AnyCase then
SearchCase:=ctsfcAllCase
else
SearchCase:=ctsfcLoUpCase;
Result:=SearchPascalUnitInPath(UnitName,CurDir,SrcPath,';',SearchCase);
if Result='' then begin
// search in unit links
Result:=FindUnitLink(UnitName);
end;
if Result<>'' then begin
NewUnitName:=ExtractFileNameOnly(Result);
if (NewUnitName<>lowercase(NewUnitName))
and (UnitName<>NewUnitName) then
UnitName:=NewUnitName;
end;
end else begin
// virtual directory -> TODO
Result:='';
end;
AddToCache(UnitName,Result);
end;
end;
//DebugLn('TFindDeclarationTool.FindUnitCaseInsensitive RESULT AnUnitName=',AnUnitName,' InFilename=',InFilename,' Result=',Result);
end;
{ TCTDirectoryCachePool }
procedure TCTDirectoryCachePool.DoRemove(ACache: TCTDirectoryCache);
begin
FDirectories.Remove(ACache);
end;
procedure TCTDirectoryCachePool.OnFileStateCacheChangeTimeStamp(Sender: TObject
);
begin
IncreaseTimeStamp;
end;
constructor TCTDirectoryCachePool.Create;
begin
FDirectories:=TAVLTree.Create(@CompareCTDirectoryCaches);
FTimeStamp:=1;
if FileStateCache<>nil then
FileStateCache.AddChangeTimeStampHandler(@OnFileStateCacheChangeTimeStamp);
end;
destructor TCTDirectoryCachePool.Destroy;
var
Cache: TCTDirectoryCache;
begin
if FileStateCache<>nil then
FileStateCache.RemoveChangeTimeStampHandler(@OnFileStateCacheChangeTimeStamp);
while FDirectories.Root<>nil do begin
Cache:=TCTDirectoryCache(FDirectories.Root.Data);
if Cache.RefCount<>1 then
raise Exception.Create('TCTDirectoryCachePool.Destroy');
Cache.Release;
end;
FDirectories.Free;
inherited Destroy;
end;
function TCTDirectoryCachePool.GetCache(const Directory: string;
CreateIfNotExists: boolean; DoReference: boolean): TCTDirectoryCache;
var
Node: TAVLTreeNode;
Dir: String;
begin
Dir:=AppendPathDelim(TrimFilename(Directory));
Node:=FDirectories.FindKey(@Dir,@ComparePAnsiStringAndDirectoryCache);
if Node<>nil then begin
Result:=TCTDirectoryCache(Node.Data);
if DoReference then
Result.Reference;
end else if DoReference or CreateIfNotExists then begin
Result:=TCTDirectoryCache.Create(Directory,Self);
FDirectories.Add(Result);
if DoReference then
Result.Reference;
end else
Result:=nil;
end;
function TCTDirectoryCachePool.GetString(const Directory: string;
AStringType: TCTDirCacheString; UseCache: boolean): string;
var
Cache: TCTDirectoryCache;
begin
if UseCache then begin
Cache:=GetCache(Directory,true,false);
if Cache<>nil then
Result:=Cache.Strings[AStringType]
else
Result:='';
end else begin
Result:=OnGetString(Directory,AStringType);
end;
end;
procedure TCTDirectoryCachePool.IncreaseTimeStamp;
begin
if FTimeStamp<>High(FTimeStamp) then
inc(FTimeStamp)
else
FTimeStamp:=Low(FTimeStamp);
end;
function TCTDirectoryCachePool.FindUnitInUnitLinks(const Directory,
UnitName: string): string;
var
Cache: TCTDirectoryCache;
begin
Cache:=GetCache(Directory,true,false);
Result:=Cache.FindUnitLink(UnitName);
end;
{ TCTDirectoryListing }
destructor TCTDirectoryListing.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TCTDirectoryListing.Clear;
begin
if NameStarts<>nil then begin
FreeMem(NameStarts);
NameStarts:=nil;
FreeMem(Names);
Names:=nil;
NameCount:=0;
end;
end;
end.

542
components/codetools/fileprocs.pas
View File

@ -56,7 +56,7 @@ const
type
TCTSearchFileCase = (
ctsfcDefault, // e.g. case insensitive on windows
ctsfcDefault, // e.g. case insensitive on windows
ctsfcLoUpCase, // also search for lower and upper case
ctsfcAllCase // search case insensitive
);
@ -76,6 +76,8 @@ function FileIsExecutable(const AFilename: string): boolean;
function FileIsReadable(const AFilename: string): boolean;
function FileIsWritable(const AFilename: string): boolean;
function FileIsText(const AFilename: string): boolean;
function FilenameIsTrimmed(const TheFilename: string): boolean;
function FilenameIsTrimmed(StartPos: PChar; NameLen: integer): boolean;
function TrimFilename(const AFilename: string): string;
function CleanAndExpandFilename(const Filename: string): string;
function CleanAndExpandDirectory(const Filename: string): string;
@ -105,7 +107,9 @@ function SearchPascalUnitInPath(const AnUnitName, BasePath, SearchPath,
function CreateAbsoluteSearchPath(const SearchPath, BaseDirectory: string): string;
function CreateRelativeSearchPath(const SearchPath, BaseDirectory: string): string;
function MinimizeSearchPath(const SearchPath: string): string;
function FindPathInSearchPath(APath: PChar; APathLen: integer;
SearchPath: PChar; SearchPathLen: integer): PChar;
type
TCTPascalExtType = (petNone, petPAS, petPP, petP);
@ -114,42 +118,6 @@ const
CTPascalExtension: array[TCTPascalExtType] of string =
('', '.pas', '.pp', '.p');
// debugging
procedure DebugLn;
procedure DebugLn(const s: string);
procedure DebugLn(const s1,s2: string);
procedure DebugLn(const s1,s2,s3: string);
procedure DebugLn(const s1,s2,s3,s4: string);
procedure DebugLn(const s1,s2,s3,s4,s5: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string);
procedure DbgOut(const s: string);
procedure DbgOut(const s1,s2: string);
procedure DbgOut(const s1,s2,s3: string);
procedure DbgOut(const s1,s2,s3,s4: string);
procedure DbgOut(const s1,s2,s3,s4,s5: string);
procedure DbgOut(const s1,s2,s3,s4,s5,s6: string);
function DbgS(const c: char): string; overload;
function DbgS(const c: cardinal): string; overload;
function DbgS(const i: integer): string; overload;
function DbgS(const r: TRect): string; overload;
function DbgS(const p: TPoint): string; overload;
function DbgS(const p: pointer): string; overload;
function DbgS(const e: extended): string; overload;
function DbgS(const b: boolean): string; overload;
function DbgS(const i1,i2,i3,i4: integer): string; overload;
function DbgSName(const p: TObject): string;
function DbgStr(const StringWithSpecialChars: string): string;
type
TFileStateCacheItemFlag = (
fsciExists, // file or directory exists
@ -187,6 +155,7 @@ type
FFiles: TAVLTree;
FTimeStamp: integer;
FLockCount: integer;
FChangeTimeStampHandler: array of TNotifyEvent;
procedure SetFlag(AFile: TFileStateCacheItem;
AFlag: TFileStateCacheItemFlag; NewValue: boolean);
public
@ -208,10 +177,12 @@ type
function Check(const Filename: string; AFlag: TFileStateCacheItemFlag;
var AFile: TFileStateCacheItem; var FlagIsSet: boolean): boolean;
procedure WriteDebugReport;
procedure AddChangeTimeStampHandler(const Handler: TNotifyEvent);
procedure RemoveChangeTimeStampHandler(const Handler: TNotifyEvent);
public
property TimeStamp: integer read FTimeStamp;
end;
var
FileStateCache: TFileStateCache;
@ -239,6 +210,68 @@ const
'fsciExecutable'
);
// basic utility -> should go to RTL
function ComparePointers(p1, p2: Pointer): integer;
procedure MergeSort(List: PPointer; ListLength: PtrInt;
Compare: TListSortCompare);
// debugging
procedure DebugLn;
procedure DebugLn(const s: string);
procedure DebugLn(const s1,s2: string);
procedure DebugLn(const s1,s2,s3: string);
procedure DebugLn(const s1,s2,s3,s4: string);
procedure DebugLn(const s1,s2,s3,s4,s5: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string);
procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string);
procedure DbgOut(const s: string);
procedure DbgOut(const s1,s2: string);
procedure DbgOut(const s1,s2,s3: string);
procedure DbgOut(const s1,s2,s3,s4: string);
procedure DbgOut(const s1,s2,s3,s4,s5: string);
procedure DbgOut(const s1,s2,s3,s4,s5,s6: string);
function DbgS(const c: char): string; overload;
function DbgS(const c: cardinal): string; overload;
function DbgS(const i: integer): string; overload;
function DbgS(const r: TRect): string; overload;
function DbgS(const p: TPoint): string; overload;
function DbgS(const p: pointer): string; overload;
function DbgS(const e: extended): string; overload;
function DbgS(const b: boolean): string; overload;
function DbgS(const i1,i2,i3,i4: integer): string; overload;
function DbgSName(const p: TObject): string;
function DbgStr(const StringWithSpecialChars: string): string;
function GetTicks: int64;
type
TCTStackTracePointers = array of Pointer;
TCTLineInfoCacheItem = record
Addr: Pointer;
Info: string;
end;
PCTLineInfoCacheItem = ^TCTLineInfoCacheItem;
procedure CTDumpStack;
function CTGetStackTrace(UseCache: boolean): string;
procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
function CTStackTraceAsString(const AStack: TCTStackTracePointers;
UseCache: boolean): string;
function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string;
function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
var
FPUpChars: array[char] of char;
implementation
// to get more detailed error messages consider the os
@ -248,8 +281,9 @@ uses
{$ENDIF}
var
UpChars: array[char] of char;
LineInfoCache: TAVLTree = nil;
LastTick: int64 = 0;
{-------------------------------------------------------------------------------
function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
-------------------------------------------------------------------------------}
@ -335,7 +369,7 @@ begin
and (Result[2]=':')) then begin
StartPos:=3;
if Result[1] in ['a'..'z'] then
Result[1]:=UpChars[Result[1]];
Result[1]:=FPUpChars[Result[1]];
end;
{$ENDIF}
FileNotFound:=false;
@ -407,7 +441,7 @@ end;
function CompareFilenames(const Filename1, Filename2: string): integer;
begin
{$IFDEF WIN32}
{$IFDEF CaseInsensitiveFilenames}
Result:=CompareText(Filename1, Filename2);
{$ELSE}
Result:=CompareStr(Filename1, Filename2);
@ -575,47 +609,55 @@ begin
end;
end;
function FilenameIsTrimmed(const TheFilename: string): boolean;
begin
Result:=FilenameIsTrimmed(PChar(TheFilename),length(TheFilename));
end;
function FilenameIsTrimmed(StartPos: PChar; NameLen: integer): boolean;
var
i: Integer;
begin
Result:=false;
if NameLen<=0 then begin
Result:=true;
exit;
end;
// check heading spaces
if StartPos[0]=' ' then exit;
// check trailing spaces
if StartPos[NameLen-1]=' ' then exit;
// check ./ at start
if (StartPos[0]='.') and (StartPos[1]=PathDelim) then exit;
i:=0;
while i<NameLen do begin
if StartPos[i]<>PathDelim then
inc(i)
else begin
inc(i);
if i=NameLen then break;
// check for double path delimiter
if (StartPos[i]=PathDelim) then exit;
if StartPos[i]='.' then begin
inc(i);
// check /./ or /. at end
if (StartPos[i]=PathDelim) or (i=NameLen) then exit;
if StartPos[i]='.' then begin
inc(i);
// check /../ or /.. at end
if (StartPos[i]=PathDelim) or (i=NameLen) then exit;
end;
end;
end;
end;
Result:=true;
end;
function TrimFilename(const AFilename: string): string;
// trim double path delims, heading and trailing spaces
// and special dirs . and ..
function FilenameIsTrimmed(const TheFilename: string): boolean;
var
l: Integer;
i: Integer;
begin
Result:=false;
if TheFilename='' then begin
Result:=true;
exit;
end;
l:=length(TheFilename);
// check heading spaces
if TheFilename[1]=' ' then exit;
// check trailing spaces
if TheFilename[l]=' ' then exit;
i:=1;
while i<=l do begin
case TheFilename[i] of
PathDelim:
// check for double path delimiter
if (i<l) and (TheFilename[i+1]=PathDelim) then exit;
'.':
if (i=1) or (TheFilename[i-1]=PathDelim) then begin
// check for . and .. directories
if (i=l) or (TheFilename[i+1]=PathDelim) then exit;
if (TheFilename[i+1]='.')
and ((i=l-1) or (TheFilename[i+2]=PathDelim)) then exit;
end;
end;
inc(i);
end;
Result:=true;
end;
var SrcPos, DestPos, l, DirStart: integer;
c: char;
begin
@ -632,7 +674,7 @@ begin
// skip heading spaces
while (SrcPos<=l) and (AFilename[SrcPos]=' ') do inc(SrcPos);
// trim double path delims and special dirs . and ..
// trim double path delimiters and special dirs . and ..
while (SrcPos<=l) do begin
c:=AFilename[SrcPos];
// check for double path delims
@ -778,7 +820,7 @@ begin
if MinLen>BaseDirLen then MinLen:=BaseDirLen;
SamePos:=1;
while (SamePos<=MinLen) do begin
{$IFDEF win32}
{$IFDEF CaseInsensitiveFilenames}
if AnsiStrLIComp(@FileName[SamePos],@BaseDirectory[SamePos],1)=0
{$ELSE}
if FileName[SamePos]=BaseDirectory[SamePos]
@ -857,11 +899,14 @@ begin
end;
function ChompPathDelim(const Path: string): string;
var
Len: Integer;
begin
if (Path<>'') and (Path[length(Path)]=PathDelim) then
Result:=LeftStr(Path,length(Path)-1)
else
Result:=Path;
Result:=Path;
Len:=length(Result);
while (Len>1) and (Result[Len]=PathDelim) do dec(Len);
if Len<length(Result) then
SetLength(Result,Len);
end;
function FilenameIsPascalUnit(const Filename: string;
@ -1039,6 +1084,87 @@ begin
end;
end;
function MinimizeSearchPath(const SearchPath: string): string;
// trim the paths, remove doubles and empty paths
var
StartPos: Integer;
EndPos: LongInt;
NewPath: String;
begin
Result:=SearchPath;
StartPos:=1;
while StartPos<=length(Result) do begin
EndPos:=StartPos;
while (EndPos<=length(Result)) and (Result[EndPos]<>';') do
inc(EndPos);
if StartPos<EndPos then begin
// trim path and chomp PathDelim
if (Result[EndPos-1]=PathDelim)
or (not FilenameIsTrimmed(@Result[StartPos],EndPos-StartPos)) then begin
NewPath:=ChompPathDelim(
TrimFilename(copy(Result,StartPos,EndPos-StartPos)));
Result:=copy(Result,1,StartPos-1)+NewPath+copy(Result,EndPos,length(Result));
EndPos:=StartPos+length(NewPath);
end;
// check if path already exists
if FindPathInSearchPath(@Result[StartPos],EndPos-StartPos,
@Result[1],StartPos-1)<>nil
then begin
// remove path
System.Delete(Result,StartPos,EndPos-StartPos+1);
end else begin
StartPos:=EndPos+1;
end;
end else begin
// remove empty path
System.Delete(Result,StartPos,1);
end;
end;
if (Result<>'') and (Result[length(Result)]=';') then
SetLength(Result,length(Result)-1);
end;
function FindPathInSearchPath(APath: PChar; APathLen: integer;
SearchPath: PChar; SearchPathLen: integer): PChar;
var
StartPos: Integer;
EndPos: LongInt;
NextStartPos: LongInt;
CmpPos: LongInt;
begin
Result:=nil;
if SearchPath=nil then exit;
if APath=nil then exit;
// ignore trailing PathDelim at end
while (APathLen>1) and (APath[APathLen-1]=PathDelim) do dec(APathLen);
StartPos:=0;
while StartPos<SearchPathLen do begin
// find current path bounds
NextStartPos:=StartPos;
while (SearchPath[NextStartPos]<>';') and (NextStartPos<SearchPathLen) do
inc(NextStartPos);
EndPos:=NextStartPos;
// ignore trailing PathDelim at end
while (EndPos>StartPos+1) and (SearchPath[EndPos-1]=PathDelim) do
dec(EndPos);
// compare current path
if EndPos-StartPos=APathLen then begin
CmpPos:=0;
while CmpPos<APathLen do begin
if APath[CmpPos]<>SearchPath[StartPos+CmpPos] then
break;
inc(CmpPos);
end;
if CmpPos<EndPos then begin
Result:=@SearchPath[StartPos];
exit;
end;
end;
StartPos:=NextStartPos+1;
end;
end;
function SearchFileInDir(const Filename, BaseDirectory: string;
SearchCase: TCTSearchFileCase): string;
@ -1205,7 +1331,7 @@ function FilenameIsMatching(const Mask, Filename: string;
function CharsEqual(c1, c2: char): boolean;
begin
{$ifdef CaseInsensitiveFilenames}
Result:=(UpChars[c1]=UpChars[c2]);
Result:=(FPUpChars[c1]=FPUpChars[c2]);
{$else}
Result:=(c1=c2);
{$endif}
@ -1375,8 +1501,8 @@ begin
FileChar:=Filename[FilePos];
ExtChar:=Ext[ExtPos];
if not CaseSensitive then begin
FileChar:=UpChars[FileChar];
ExtChar:=UpChars[ExtChar];
FileChar:=FPUpChars[FileChar];
ExtChar:=FPUpChars[ExtChar];
end;
if FileChar=ExtChar then begin
inc(FilePos);
@ -1407,6 +1533,83 @@ begin
end;
end;
function ComparePointers(p1, p2: Pointer): integer;
begin
if p1>p2 then
Result:=1
else if p1<p2 then
Result:=-1
else
Result:=0;
end;
procedure MergeSort(List: PPointer; ListLength: PtrInt;
Compare: TListSortCompare);
var
MergeList: PPointer;
procedure Merge(const Pos1, Pos2, Pos3: PtrInt);
// merge two sorted arrays
// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
var Src1Pos,Src2Pos,DestPos,cmp,i:PtrInt;
begin
if (Pos1>=Pos2) or (Pos2>Pos3) then exit;
Src1Pos:=Pos2-1;
Src2Pos:=Pos3;
DestPos:=Pos3;
while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin
cmp:=Compare(List[Src1Pos],List[Src2Pos]);
if cmp>0 then begin
MergeList[DestPos]:=List[Src1Pos];
dec(Src1Pos);
end else begin
MergeList[DestPos]:=List[Src2Pos];
dec(Src2Pos);
end;
dec(DestPos);
end;
while Src2Pos>=Pos2 do begin
MergeList[DestPos]:=List[Src2Pos];
dec(Src2Pos);
dec(DestPos);
end;
for i:=DestPos+1 to Pos3 do
List[i]:=MergeList[i];
end;
procedure Sort(const Pos1, Pos2: PtrInt);
// sort List from Pos1 to Pos2, usig MergeList as temporary buffer
var cmp, mid: PtrInt;
begin
if Pos1>=Pos2 then begin
// one element is always sorted -> nothing to do
end else if Pos1+1=Pos2 then begin
// two elements can be sorted easily
cmp:=Compare(List[Pos1],List[Pos2]);
if cmp>0 then begin
MergeList[Pos1]:=List[Pos1];
List[Pos1]:=List[Pos2];
List[Pos2]:=MergeList[Pos1];
end;
end else begin
mid:=(Pos1+Pos2) shr 1;
Sort(Pos1,mid);
Sort(mid+1,Pos2);
Merge(Pos1,mid+1,Pos2);
end;
end;
// sort ascending
begin
if ListLength<=1 then exit;
GetMem(MergeList,SizeOf(Pointer)*ListLength);
try
Sort(0,ListLength-1);
finally
FreeMem(MergeList);
end;
end;
procedure DebugLn;
begin
DebugLn('');
@ -1583,6 +1786,119 @@ begin
end;
end;
function GetTicks: int64;
var
CurTick: Int64;
begin
CurTick:=round(Now*86400000);
Result:=CurTick-LastTick;
LastTick:=CurTick;
end;
procedure CTDumpStack;
begin
DebugLn(CTGetStackTrace(true));
end;
function CTGetStackTrace(UseCache: boolean): string;
var
bp: Pointer;
addr: Pointer;
oldbp: Pointer;
CurAddress: Shortstring;
begin
Result:='';
{ retrieve backtrace info }
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
addr:=get_caller_addr(bp);
CurAddress:=CTGetLineInfo(addr,UseCache);
//DebugLn('GetStackTrace ',CurAddress);
Result:=Result+CurAddress+LineEnding;
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
end;
procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
var
Depth: Integer;
bp: Pointer;
oldbp: Pointer;
begin
// get stack depth
Depth:=0;
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
inc(Depth);
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
SetLength(AStack,Depth);
if Depth>0 then begin
Depth:=0;
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
AStack[Depth]:=get_caller_addr(bp);
inc(Depth);
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
end;
end;
function CTStackTraceAsString(const AStack: TCTStackTracePointers; UseCache: boolean
): string;
var
i: Integer;
CurAddress: String;
begin
Result:='';
for i:=0 to length(AStack)-1 do begin
CurAddress:=CTGetLineInfo(AStack[i],UseCache);
Result:=Result+CurAddress+LineEnding;
end;
end;
function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string;
var
ANode: TAVLTreeNode;
Item: PCTLineInfoCacheItem;
begin
if UseCache then begin
if LineInfoCache=nil then
LineInfoCache:=TAVLTree.Create(@CompareCTLineInfoCacheItems);
ANode:=LineInfoCache.FindKey(Addr,@CompareAddrWithCTLineInfoCacheItem);
if ANode=nil then begin
Result:=BackTraceStrFunc(Addr);
New(Item);
Item^.Addr:=Addr;
Item^.Info:=Result;
LineInfoCache.Add(Item);
end else begin
Result:=PCTLineInfoCacheItem(ANode.Data)^.Info;
end;
end else
Result:=BackTraceStrFunc(Addr);
end;
function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
begin
Result:=ComparePointers(PCTLineInfoCacheItem(Data1)^.Addr,
PCTLineInfoCacheItem(Data2)^.Addr);
end;
function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
begin
Result:=ComparePointers(Addr,PCTLineInfoCacheItem(Item)^.Addr);
end;
function FileExistsCached(const Filename: string): boolean;
begin
Result:=FileStateCache.FileExistsCached(Filename);
@ -1642,7 +1958,7 @@ var
begin
FileStateCache:=TFileStateCache.Create;
for c:=Low(char) to High(char) do begin
UpChars[c]:=upcase(c);
FPUpChars[c]:=upcase(c);
end;
end;
@ -1682,6 +1998,7 @@ destructor TFileStateCache.Destroy;
begin
FFiles.FreeAndClear;
FFiles.Free;
SetLength(FChangeTimeStampHandler,0);
inherited Destroy;
end;
@ -1708,12 +2025,16 @@ begin
end;
procedure TFileStateCache.IncreaseTimeStamp;
var
i: Integer;
begin
if Self<>nil then begin
if FTimeStamp<maxLongint then
inc(FTimeStamp)
else
FTimeStamp:=-maxLongint;
for i:=0 to length(FChangeTimeStampHandler)-1 do
FChangeTimeStampHandler[i](Self);
end;
//debugln('TFileStateCache.IncreaseTimeStamp FTimeStamp=',dbgs(FTimeStamp));
end;
@ -1852,12 +2173,51 @@ begin
debugln(FFiles.ReportAsString);
end;
procedure TFileStateCache.AddChangeTimeStampHandler(const Handler: TNotifyEvent
);
begin
SetLength(FChangeTimeStampHandler,length(FChangeTimeStampHandler)+1);
FChangeTimeStampHandler[length(FChangeTimeStampHandler)-1]:=Handler;
end;
procedure TFileStateCache.RemoveChangeTimeStampHandler(
const Handler: TNotifyEvent);
var
i: Integer;
begin
for i:=length(FChangeTimeStampHandler)-1 downto 0 do begin
if Handler=FChangeTimeStampHandler[i] then begin
if i<length(FChangeTimeStampHandler)-1 then
System.Move(FChangeTimeStampHandler[i+1],FChangeTimeStampHandler[i],
SizeOf(TNotifyEvent)*(length(FChangeTimeStampHandler)-i-1));
SetLength(FChangeTimeStampHandler,length(FChangeTimeStampHandler)-1);
end;
end;
end;
procedure FreeLineInfoCache;
var
ANode: TAVLTreeNode;
Item: PCTLineInfoCacheItem;
begin
if LineInfoCache=nil then exit;
ANode:=LineInfoCache.FindLowest;
while ANode<>nil do begin
Item:=PCTLineInfoCacheItem(ANode.Data);
Dispose(Item);
ANode:=LineInfoCache.FindSuccessor(ANode);
end;
LineInfoCache.Free;
LineInfoCache:=nil;
end;
initialization
InternalInit;
finalization
FileStateCache.Free;
FileStateCache:=nil;
FreeLineInfoCache;
end.

166
components/codetools/finddeclarationtool.pas
View File

@ -82,7 +82,7 @@ uses
MemCheck,
{$ENDIF}
Classes, SysUtils, CodeToolsStrConsts, CodeTree, CodeAtom, CustomCodeTool,
KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache,
KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache, DirectoryCache,
AVL_Tree, PascalParserTool,
PascalReaderTool, FileProcs, DefineTemplates, FindDeclarationCache;
@ -414,6 +414,8 @@ type
const TheUnitName, TheUnitInFilename: string): TCodeBuffer of object;
TOnGetCodeToolForBuffer = function(Sender: TObject;
Code: TCodeBuffer; GoToMainCode: boolean): TFindDeclarationTool of object;
TOnGetDirectoryCache = function(const ADirectory: string
): TCTDirectoryCache of object;
TFindDeclarationInput = record
Flags: TFindDeclarationFlags;
@ -515,11 +517,13 @@ type
TFindDeclarationTool = class(TPascalReaderTool)
private
FAdjustTopLineDueToComment: boolean;
FDirectoryValues: TCTDirectoryCache;
FInterfaceIdentifierCache: TInterfaceIdentifierCache;
FOnFindUsedUnit: TOnFindUsedUnit;
FOnGetCodeToolForBuffer: TOnGetCodeToolForBuffer;
FOnGetUnitSourceSearchPath: TOnGetSearchPath;
FOnGetDirectoryCache: TOnGetDirectoryCache;
FOnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit;
FOnGetUnitSourceSearchPath: TOnGetSearchPath;
FFirstNodeCache: TCodeTreeNodeCache;
FLastNodeCachesGlobalWriteLockStep: integer;
FRootNodeCache: TCodeTreeNodeCache;
@ -667,6 +671,7 @@ type
protected
function OpenCodeToolForUnit(UnitNameAtom, UnitInFileAtom: TAtomPosition;
ExceptionOnNotFound: boolean): TFindDeclarationTool;
function CheckDirectoryCache: boolean;
public
procedure BuildTree(OnlyInterfaceNeeded: boolean); override;
destructor Destroy; override;
@ -696,7 +701,7 @@ type
AnUnitInFilename: string; ExceptionOnNotFound: boolean): TCodeBuffer;
function FindUnitCaseInsensitive(var AnUnitName,
AnUnitInFilename: string): string;
procedure GatherUnitAndSrcPath(var UnitPath, SrcPath: string);
procedure GatherUnitAndSrcPath(var UnitPath, CompleteSrcPath: string);
function SearchUnitInUnitLinks(const TheUnitName: string): string;
function FindSmartHint(const CursorPos: TCodeXYPosition): string;
@ -734,12 +739,15 @@ type
read FOnGetUnitSourceSearchPath write FOnGetUnitSourceSearchPath;
property OnFindUsedUnit: TOnFindUsedUnit
read FOnFindUsedUnit write FOnFindUsedUnit;
property OnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit
read FOnGetSrcPathForCompiledUnit write FOnGetSrcPathForCompiledUnit;
property OnGetCodeToolForBuffer: TOnGetCodeToolForBuffer
read FOnGetCodeToolForBuffer write FOnGetCodeToolForBuffer;
property OnGetDirectoryCache: TOnGetDirectoryCache read FOnGetDirectoryCache
write FOnGetDirectoryCache;
property OnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit
read FOnGetSrcPathForCompiledUnit write fOnGetSrcPathForCompiledUnit;
property AdjustTopLineDueToComment: boolean
read FAdjustTopLineDueToComment write FAdjustTopLineDueToComment;
property DirectoryValues: TCTDirectoryCache read FDirectoryValues;
end;
function ExprTypeToString(const ExprType: TExpressionType): string;
@ -1742,10 +1750,12 @@ begin
Result:=nil;
if (AnUnitName='') or (Scanner=nil) or (Scanner.MainCode=nil)
or (not (TObject(Scanner.MainCode) is TCodeBuffer))
or (Scanner.OnLoadSource=nil) then
or (Scanner.OnLoadSource=nil)
or (not CheckDirectoryCache) then
begin
RaiseException('TFindDeclarationTool.FindUnitSource Invalid Data');
end;
SrcPathInitialized:=false;
UnitSearchPath:='';
UnitSrcSearchPath:='';
@ -1903,8 +1913,7 @@ begin
DebugLn('TFindDeclarationTool.FindUnitCaseInsensitive ',UnitPath+';'+SrcPath);
end;
Result:=SearchPascalUnitInPath(AnUnitName,CurDir,UnitPath+';'+SrcPath,';',
ctsfcAllCase);
Result:=SearchPascalUnitInPath(AnUnitName,CurDir,SrcPath,';',ctsfcAllCase);
if Result='' then begin
// search in unit links
Result:=SearchUnitInUnitLinks(AnUnitName);
@ -1921,135 +1930,22 @@ begin
end;
procedure TFindDeclarationTool.GatherUnitAndSrcPath(var UnitPath,
SrcPath: string);
var
CurDir: String;
procedure SearchCompiledSrcPaths(const APath: string);
var
PathStart, PathEnd: integer;
ADir: string;
CurCompiledSrcPath: string;
begin
if not Assigned(OnGetSrcPathForCompiledUnit) then begin
exit;
end;
PathStart:=1;
while PathStart<=length(APath) do begin
PathEnd:=PathStart;
while (PathEnd<=length(APath)) and (APath[PathEnd]<>';') do inc(PathEnd);
if PathEnd>PathStart then begin
// extract and expand current search directory
ADir:=copy(APath,PathStart,PathEnd-PathStart);
if (ADir<>'') and (ADir[length(ADir)]<>PathDelim) then
ADir:=ADir+PathDelim;
if not FilenameIsAbsolute(ADir) then ADir:=CurDir+ADir;
// get CompiledSrcPath for current search directory
CurCompiledSrcPath:=OnGetSrcPathForCompiledUnit(Self,ADir);
if CurCompiledSrcPath<>'' then begin
// this directory is an unit output directory
CurCompiledSrcPath:=CreateAbsoluteSearchPath(CurCompiledSrcPath,ADir);
SrcPath:=SrcPath+';'+CurCompiledSrcPath;
end;
end;
PathStart:=PathEnd+1;
end;
end;
var
MainCodeIsVirtual: Boolean;
CompleteSrcPath: string);
begin
UnitPath:='';
SrcPath:='';
MainCodeIsVirtual:=TCodeBuffer(Scanner.MainCode).IsVirtual;
if not MainCodeIsVirtual then begin
CurDir:=ExtractFilePath(TCodeBuffer(Scanner.MainCode).Filename);
end else begin
CurDir:='';
end;
// first search in current directory (= where the maincode is)
UnitPath:=CurDir;
// search source in search path
if Assigned(OnGetUnitSourceSearchPath) then begin
SrcPath:=SrcPath+';'+OnGetUnitSourceSearchPath(Self);
end else begin
UnitPath:=UnitPath+';'+Scanner.Values[ExternalMacroStart+'UnitPath'];
SrcPath:=SrcPath+';'+Scanner.Values[ExternalMacroStart+'SrcPath'];
end;
// search for compiled unit
// -> search in every unit path for a CompiledSrcPath and search there
SearchCompiledSrcPaths(UnitPath);
CompleteSrcPath:='';
if not CheckDirectoryCache then exit;
UnitPath:=DirectoryValues.Strings[ctdcsUnitPath];
CompleteSrcPath:=DirectoryValues.Strings[ctdcsCompleteSrcPath];
//DebugLn('TFindDeclarationTool.GatherUnitAndSrcPath UnitPath="',UnitPath,'" CompleteSrcPath="',CompleteSrcPath,'"');
end;
function TFindDeclarationTool.SearchUnitInUnitLinks(const TheUnitName: string
): string;
var
UnitLinks: string;
UnitLinkStart, UnitLinkEnd, UnitLinkLen: integer;
pe: TCTPascalExtType;
begin
Result:='';
UnitLinks:=Scanner.Values[ExternalMacroStart+'UnitLinks'];
{$IFDEF ShowTriedFiles}
DebugLn('TFindDeclarationTool.SearchUnitInUnitLinks length(UnitLinks)=',dbgs(length(UnitLinks)));
{$ENDIF}
UnitLinkStart:=1;
while UnitLinkStart<=length(UnitLinks) do begin
while (UnitLinkStart<=length(UnitLinks))
and (UnitLinks[UnitLinkStart] in [#10,#13]) do
inc(UnitLinkStart);
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks)) and (UnitLinks[UnitLinkEnd]<>' ')
do
inc(UnitLinkEnd);
UnitLinkLen:=UnitLinkEnd-UnitLinkStart;
if UnitLinkLen>0 then begin
{$IFDEF ShowTriedFiles}
DebugLn(' unit "',copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart),'" ',
dbgs(CompareSubStrings(TheUnitName,UnitLinks,1,UnitLinkStart,UnitLinkLen,false)));
{$ENDIF}
if (UnitLinkLen=length(TheUnitName))
and (CompareText(PChar(TheUnitName),length(TheUnitName),
@UnitLinks[UnitLinkStart],UnitLinkLen,false)=0)
then begin
// unit found -> parse filename
UnitLinkStart:=UnitLinkEnd+1;
UnitLinkEnd:=UnitLinkStart;
while (UnitLinkEnd<=length(UnitLinks))
and (not (UnitLinks[UnitLinkEnd] in [#10,#13])) do
inc(UnitLinkEnd);
if UnitLinkEnd>UnitLinkStart then begin
Result:=copy(UnitLinks,UnitLinkStart,UnitLinkEnd-UnitLinkStart);
if FileExistsCached(Result) then exit;
// try also different extensions
for pe:=Low(TCTPascalExtType) to High(TCTPascalExtType) do begin
if (CTPascalExtension[pe]<>'')
and (CompareFileExt(Result,CTPascalExtension[pe],false)<>0)
then begin
Result:=ChangeFileExt(Result,CTPascalExtension[pe]);
if FileExistsCached(Result) then begin
Result:=Result;
exit;
end;
end;
end;
Result:='';
exit;
end;
end else begin
UnitLinkStart:=UnitLinkEnd+1;
while (UnitLinkStart<=length(UnitLinks))
and (not (UnitLinks[UnitLinkStart] in [#10,#13])) do
inc(UnitLinkStart);
end;
end else
break;
end;
if not CheckDirectoryCache then exit;
Result:=DirectoryValues.FindUnitLink(TheUnitName);
end;
function TFindDeclarationTool.FindSmartHint(const CursorPos: TCodeXYPosition
@ -7364,6 +7260,14 @@ begin
end;
end;
function TFindDeclarationTool.CheckDirectoryCache: boolean;
begin
if FDirectoryValues<>nil then exit(true);
if Assigned(OnGetDirectoryCache) then
FDirectoryValues:=OnGetDirectoryCache(ExtractFilePath(MainFilename));
Result:=FDirectoryValues<>nil;
end;
procedure TFindDeclarationTool.DoDeleteNodes;
begin
ClearNodeCaches(true);
@ -7444,6 +7348,10 @@ begin
FDependsOnCodeTools:=nil;
FDependentCodeTools.Free;
FDependentCodeTools:=nil;
if FDirectoryValues<>nil then begin
FDirectoryValues.Release;
FDirectoryValues:=nil;
end;
inherited Destroy;
end;

36
components/codetools/stdcodetools.pas
View File

@ -806,13 +806,13 @@ begin
BuildTree(false);
UsesNode:=FindMainUsesSection;
if UsesNode=nil then exit;
MoveCursorToUsesEnd(UsesNode);
MoveCursorToUsesStart(UsesNode);
FoundInUnits:=TStringList.Create;
MissingInUnits:=TStringList.Create;
NormalUnits:=TStringList.Create;
repeat
// read prior unit name
ReadPriorUsedUnit(UnitNameAtom, InAtom);
ReadNextUsedUnit(UnitNameAtom, InAtom);
AnUnitName:=GetAtom(UnitNameAtom);
if InAtom.StartPos>0 then begin
AnUnitInFilename:=copy(Src,InAtom.StartPos+1,
@ -835,9 +835,14 @@ begin
NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,false);
NormalUnits.AddObject(AnUnitName,NewCode);
end;
// read keyword 'uses' or comma
ReadPriorAtom;
until not AtomIsChar(',');
if CurPos.Flag=cafComma then begin
// read next unit name
ReadNextAtom;
end else if CurPos.Flag=cafSemicolon then begin
break;
end else
RaiseExceptionFmt(ctsStrExpectedButAtomFound,[';',GetAtom]);
until false;
Result:=true;
end;
@ -923,10 +928,12 @@ function TStandardCodeTool.FindMissingUnits(var MissingUnits: TStrings;
ToPos: LongInt;
begin
if UsesNode=nil then exit(true);
MoveCursorToUsesEnd(UsesNode);
if not CheckDirectoryCache then exit(false);
MoveCursorToUsesStart(UsesNode);
repeat
// read prior unit name
ReadPriorUsedUnit(UnitNameAtom, InAtom);
// read next unit name
ReadNextUsedUnit(UnitNameAtom, InAtom);
OldUnitName:=GetAtom(UnitNameAtom);
if InAtom.StartPos>0 then
OldInFilename:=copy(Src,InAtom.StartPos+1,
@ -936,7 +943,7 @@ function TStandardCodeTool.FindMissingUnits(var MissingUnits: TStrings;
// find unit file
NewUnitName:=OldUnitName;
NewInFilename:=OldInFilename;
AFilename:=FindUnitCaseInsensitive(NewUnitName,NewInFilename);
AFilename:=DirectoryValues.FindUnitSource(NewUnitName,NewInFilename,true);
s:=NewUnitName;
if NewInFilename<>'' then
s:=s+' in '''+NewInFilename+'''';
@ -958,9 +965,14 @@ function TStandardCodeTool.FindMissingUnits(var MissingUnits: TStrings;
if MissingUnits=nil then MissingUnits:=TStringList.Create;
MissingUnits.Add(s);
end;
// read keyword 'uses' or comma
ReadPriorAtom;
until not AtomIsChar(',');
if CurPos.Flag=cafComma then begin
// read next unit name
ReadNextAtom;
end else if CurPos.Flag=cafSemicolon then begin
break;
end else
RaiseExceptionFmt(ctsStrExpectedButAtomFound,[';',GetAtom]);
until false;
Result:=true;
end;

2
designer/jitforms.pp
View File

@ -932,7 +932,7 @@ function TJITComponentList.CreateNewJITClass(ParentClass: TClass;
const NewClassName, NewUnitName: ShortString): TClass;
// Create a new class (vmt, virtual method table, field table and typeinfo)
// that descends from ParentClass.
// The new class will have no new variables, now new methods and no new fields.
// The new class will have no new variables, no new methods and no new fields.
var
NewVMT: Pointer;
ClassNamePShortString: Pointer;

5
ide/outputfilter.pas
View File

@ -35,7 +35,8 @@ type
OriginalIndex: integer) of object;
TOnAddFilteredLine = procedure(const Msg, Directory: String;
OriginalIndex: integer) of object;
TOnGetIncludePath = function(const Directory: string): string of object;
TOnGetIncludePath = function(const Directory: string;
UseCache: boolean): string of object;
TOuputFilterOption = (
ofoShowAll, // don't filter
@ -935,7 +936,7 @@ begin
AlreadySearchedPaths:=MergeSearchPaths(AlreadySearchedPaths,FullDir);
// search with include path of directory
if Assigned(OnGetIncludePath) then begin
IncludePath:=TrimSearchPath(OnGetIncludePath(FullDir),FullDir);
IncludePath:=TrimSearchPath(OnGetIncludePath(FullDir,false),FullDir);
IncludePath:=RemoveSearchPaths(IncludePath,AlreadySearchedIncPaths);
if IncludePath<>'' then begin
Result:=SearchFileInPath(ShortIncFilename,FullDir,IncludePath,';',[]);

1
lcl/include/customcombobox.inc
View File

@ -468,7 +468,6 @@ end;
procedure TCustomComboBox.MouseUp(Button: TMouseButton; Shift:TShiftState;
X, Y: Integer);
var R: TRect;
begin
inherited MouseUp(Button, Shift, X, Y);
//if (Style = csDropDownList) then

2
lcl/include/fileutil.inc
View File

@ -538,9 +538,9 @@ var
begin
if SysUtils.FindFirst(Filename,faAnyFile,FileInfo)=0 then begin
Result:=FileInfo.Size;
SysUtils.FindClose(FileInfo);
end else
Result:=-1;
SysUtils.FindClose(FileInfo);
end;
{------------------------------------------------------------------------------

2
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -148,7 +148,7 @@ begin
{$IFNDEF UseGTKDoubleBuf}
IsDoubleBuffered:=false;
{$ENDIF}
{$ELSE}
{$ELSE below: not GTK1}
IsDoubleBuffered:=false;
{$ENDIF}
if IsDoubleBuffered then

3
packager/pkgmanager.pas
View File

@ -955,7 +955,8 @@ end;
procedure TPkgManager.PackageGraphFindFPCUnit(const UnitName,
Directory: string; var Filename: string);
begin
Filename:=CodeToolBoss.DefineTree.FindUnitInUnitLinks(UnitName,Directory,true);
Filename:=CodeToolBoss.DirectoryCachePool.FindUnitInUnitLinks(UnitName,
Directory);
end;
function TPkgManager.PackageGraphExplorerUninstallPackage(Sender: TObject;