paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 12:49:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* store the original filename on case-aware systems in the dircache, so

Browse Source 
we can return it from FileExistsNonCase in case of {$define usedircache}
    (which is the default). This is needed so we write the correct file
    names in the debug info, which is required by gdb (mantis #9172)

git-svn-id: trunk@7879 -
This commit is contained in:
Jonas Maebe 2007-06-30 21:41:47 +00:00
parent b8822c88b5
commit 3fa669594a
1 changed files with 111 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
compiler/cfileutl.pas
View File

@ -50,11 +50,14 @@ interface
TCachedDirectory = class(TFPHashObject)
private
FDirectoryEntries : TFPHashList;
procedure FreeDirectoryEntries;
function GetItemAttr(const AName: TCmdStr): byte;
public
constructor Create(AList:TFPHashObjectList;const AName:TCmdStr);
destructor destroy;override;
procedure Reload;
function FileExists(const AName:TCmdStr):boolean;
function FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
function DirectoryExists(const AName:TCmdStr):boolean;
property DirectoryEntries:TFPHashList read FDirectoryEntries;
end;
@ -67,6 +70,12 @@ interface
EntryIndex : longint;
end;
PCachedDirectoryEntry = ^TCachedDirectoryEntry;
TCachedDirectoryEntry = record
RealName: TCmdStr;
Attr : byte;
end;
TDirectoryCache = class
private
FDirectories : TFPHashObjectList;
@ -75,6 +84,7 @@ interface
constructor Create;
destructor destroy;override;
function FileExists(const AName:TCmdStr):boolean;
function FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
function DirectoryExists(const AName:TCmdStr):boolean;
function FindFirst(const APattern:TCmdStr;var Res:TCachedSearchRec):boolean;
function FindNext(var Res:TCachedSearchRec):boolean;
@ -136,15 +146,49 @@ implementation
destructor TCachedDirectory.destroy;
begin
FreeDirectoryEntries;
FDirectoryEntries.Free;
inherited destroy;
end;
procedure TCachedDirectory.FreeDirectoryEntries;
var
i: Integer;
begin
if not(tf_files_case_aware in source_info.flags) then
exit;
for i := 0 to DirectoryEntries.Count-1 do
dispose(PCachedDirectoryEntry(DirectoryEntries[i]));
end;
function TCachedDirectory.GetItemAttr(const AName: TCmdStr): byte;
var
entry: PCachedDirectoryEntry;
begin
if not(tf_files_case_sensitive in source_info.flags) then
if (tf_files_case_aware in source_info.flags) then
begin
entry:=PCachedDirectoryEntry(DirectoryEntries.Find(Lower(AName)));
if assigned(entry) then
Result:=entry^.Attr
else
Result:=0;
end
else
Result:=PtrInt(DirectoryEntries.Find(Lower(AName)))
else
Result:=PtrInt(DirectoryEntries.Find(AName));
end;
procedure TCachedDirectory.Reload;
var
dir : TSearchRec;
dir : TSearchRec;
entry : PCachedDirectoryEntry;
begin
FreeDirectoryEntries;
DirectoryEntries.Clear;
if findfirst(IncludeTrailingPathDelimiter(Name)+'*',faAnyFile or faDirectory,dir) = 0 then
begin
@ -154,7 +198,15 @@ implementation
(dir.Name<>'..') then
begin
if not(tf_files_case_sensitive in source_info.flags) then
DirectoryEntries.Add(Lower(Dir.Name),Pointer(Ptrint(Dir.Attr)))
if (tf_files_case_aware in source_info.flags) then
begin
new(entry);
entry^.RealName:=Dir.Name;
entry^.Attr:=Dir.Attr;
DirectoryEntries.Add(Lower(Dir.Name),entry)
end
else
DirectoryEntries.Add(Lower(Dir.Name),Pointer(Ptrint(Dir.Attr)))
else
DirectoryEntries.Add(Dir.Name,Pointer(Ptrint(Dir.Attr)));
end;
@ -168,10 +220,7 @@ implementation
var
Attr : Longint;
begin
if not(tf_files_case_sensitive in source_info.flags) then
Attr:=PtrInt(DirectoryEntries.Find(Lower(AName)))
else
Attr:=PtrInt(DirectoryEntries.Find(AName));
Attr:=GetItemAttr(AName);
if Attr<>0 then
Result:=((Attr and faDirectory)=0)
else
@ -179,14 +228,37 @@ implementation
end;
function TCachedDirectory.FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
var
entry : PCachedDirectoryEntry;
Attr : Longint;
begin
if (tf_files_case_aware in source_info.flags) then
begin
entry:=PCachedDirectoryEntry(DirectoryEntries.Find(Lower(AName)));
if assigned(entry) then
begin
Attr:=entry^.Attr;
FoundName:=entry^.RealName
end
else
Attr:=0;
if Attr<>0 then
Result:=((Attr and faDirectory)=0)
else
Result:=false
end
else
{ should not be called in this case, use plain FileExists }
Result:=False;
end;
function TCachedDirectory.DirectoryExists(const AName:TCmdStr):boolean;
var
Attr : Longint;
begin
if not(tf_files_case_sensitive in source_info.flags) then
Attr:=PtrInt(DirectoryEntries.Find(Lower(AName)))
else
Attr:=PtrInt(DirectoryEntries.Find(AName));
Attr:=GetItemAttr(AName);
if Attr<>0 then
Result:=((Attr and faDirectory)=faDirectory)
else
@ -242,6 +314,17 @@ implementation
end;
function TDirectoryCache.FileExistsCaseAware(const AName:TCmdStr; out FoundName:TCmdStr):boolean;
var
CachedDir : TCachedDirectory;
begin
Result:=false;
CachedDir:=GetDirectory(ExtractFileDir(AName));
if assigned(CachedDir) then
Result:=CachedDir.FileExistsCaseAware(ExtractFileName(AName),FoundName);
end;
function TDirectoryCache.DirectoryExists(const AName:TCmdStr):boolean;
var
CachedDir : TCachedDirectory;
@ -418,11 +501,24 @@ implementation
1. NormalCase
}
FoundFile:=path+fn;
If FileExists(FoundFile,allowcache) then
begin
result:=true;
exit;
end;
{$ifdef usedircache}
if allowcache then
begin
result:=DirCache.FileExistsCaseAware(FoundFile,fn2);
if (result) then
begin
FoundFile:=path+fn2;
exit
end
end
else
{$endif usedircache}
If FileExists(FoundFile,allowcache) then
begin
{ don't know the real name in this case }
result:=true;
exit;
end;
end
else
begin