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

* made fexpand unicodestring-safe (use charinset instead of "in" --

Browse Source 
"widechar in set" compiles, but results in a runtime conversion of
    the widechar into an ansistring and then getting the first character
    of that ansistring, which is horribly slow -- and Delphi-incompatible,
    but introduced a long time ago because of bug #7758)
  * replaced all "in" operations in sysutils fina.inc with CharInSet for
    the same reason
  * replaced all "string" declarations in finah.inc/fina.inc with "PathStr"
    and "pchar" with "PathPChar", and include them twice in sysutilh.inc/
    sysutils.inc, once with PathStr=UnicodeString/PathPChar=PWideChar and
    once with PathStr=AnsiString/PathPChar=PAnsiChar (not rawbytestring
    because there are several routines with var-parameters and then the
    string type has to match exactly; the "rtlproc" modifier could circumvent
    this, but should be used sparingly, and additionally the routine's
    internals would then first also have to be reviewed to ensure that at
    no point they start mixing in strings with the defaultsystemcodepage
    (e.g. directory separators) without first adjusting their codepage)
  * call GetShortPathNameA or GetShortPathNameW in ExtractShortPathName on
    Windows depending on whether we are parsing the RawByteString/UnicodeString
    version of fina.inc
  + ExpandUNCFileName(unicode) version for Windows, let its
    ExpandUNCFileName(ansistring) call the unicode version (avoid data loss
    due to ansi conversion) and convert the result to
    DefaultRTLFileSystemCodePage (to have no more data loss than what's
    specified by the user)

git-svn-id: branches/cpstrrtl@24999 -
This commit is contained in:
Jonas Maebe 2013-06-27 21:38:10 +00:00
parent 746546ed09
commit b08d8091b2
6 changed files with 137 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
rtl/inc/fexpand.inc
View File

@ -50,7 +50,25 @@
{$DEFINE FPC_FEXPAND_UPDIR_HELPER}
{$ENDIF FPC_FEXPAND_DIRSEP_IS_UPDIR}
procedure GetDirIO (DriveNr: byte; var Dir: String);
{ this code is used both in sysutils and in the dos unit, and the dos
unit does not have a charinset routine }
{$if not defined(FPC_FEXPAND_SYSUTILS) and not defined(FPC_FEXPAND_HAS_CHARINSET)}
{$define FPC_FEXPAND_HAS_CHARINSET}
type
TFExpandSysCharSet = set of ansichar;
Function CharInSet(Ch:AnsiChar;Const CSet : TFExpandSysCharSet) : Boolean; inline;
begin
CharInSet:=ch in CSet;
end;
Function CharInSet(Ch:WideChar;Const CSet : TFExpandSysCharSet) : Boolean;
begin
CharInSet:=(Ch<=#$FF) and (ansichar(byte(ch)) in CSet);
end;
{$endif}
procedure GetDirIO (DriveNr: byte; var Dir: PathStr);
(* GetDirIO is supposed to return the root of the given drive *)
(* in case of an error for compatibility of FExpand with TP/BP. *)
@ -67,7 +85,7 @@ end;
{$IFDEF FPC_FEXPAND_VOLUMES}
{$IFNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
procedure GetDirIO (const VolumeName: OpenString; var Dir: string);
procedure GetDirIO (const VolumeName: OpenString; var Dir: PathStr);
var
OldInOutRes: word;
@ -128,7 +146,7 @@ begin
(* by converting all to the native one. *)
{$warnings off}
for I := 1 to Length (Pa) do
if Pa [I] in AllowDirectorySeparators then
if CharInSet(Pa [I], AllowDirectorySeparators) then
Pa [I] := DirectorySeparator;
{$warnings on}
@ -176,7 +194,7 @@ begin
{$IFDEF FPC_FEXPAND_VOLUMES}
if PathStart > 1 then
{$ELSE FPC_FEXPAND_VOLUMES}
if (Length (Pa) > 1) and (Pa [1] in ['A'..'Z', 'a'..'z']) and
if (Length (Pa) > 1) and CharInSet(Pa [1], ['A'..'Z', 'a'..'z']) and
(Pa [2] = DriveSeparator) and (DriveSeparator <> DirectorySeparator) then
{$ENDIF FPC_FEXPAND_VOLUMES}
begin
@ -189,7 +207,7 @@ begin
GetDirIO (Copy (Pa, 1, PathStart - 2), S);
{$ELSE FPC_FEXPAND_VOLUMES}
{ Always uppercase driveletter }
if (Pa [1] in ['a'..'z']) then
if CharInSet(Pa [1], ['a'..'z']) then
Pa [1] := Chr (Ord (Pa [1]) and not ($20));
GetDirIO (Ord (Pa [1]) - Ord ('A') + 1, S);
{$ENDIF FPC_FEXPAND_VOLUMES}

120
rtl/objpas/sysutils/fina.inc
View File

@ -14,7 +14,7 @@
System Utilities For Free Pascal
}
function ChangeFileExt(const FileName, Extension: string): string;
function ChangeFileExt(const FileName, Extension: PathStr): PathStr;
var
i : longint;
EndSep : Set of Char;
@ -28,14 +28,14 @@ begin
Result := Copy(FileName, 1, I - 1) + Extension;
end;
function ExtractFilePath(const FileName: string): string;
function ExtractFilePath(const FileName: PathStr): PathStr;
var
i : longint;
EndSep : Set of Char;
begin
i := Length(FileName);
EndSep:=AllowDirectorySeparators+AllowDriveSeparators;
while (i > 0) and not (FileName[i] in EndSep) do
while (i > 0) and not CharInSet(FileName[i],EndSep) do
Dec(i);
If I>0 then
Result := Copy(FileName, 1, i)
@ -43,22 +43,22 @@ begin
Result:='';
end;
function ExtractFileDir(const FileName: string): string;
function ExtractFileDir(const FileName: PathStr): PathStr;
var
i : longint;
EndSep : Set of Char;
begin
I := Length(FileName);
EndSep:=AllowDirectorySeparators+AllowDriveSeparators;
while (I > 0) and not (FileName[I] in EndSep) do
while (I > 0) and not CharInSet(FileName[I],EndSep) do
Dec(I);
if (I > 1) and (FileName[I] in AllowDirectorySeparators) and
not (FileName[I - 1] in EndSep) then
if (I > 1) and CharInSet(FileName[I],AllowDirectorySeparators) and
not CharInSet(FileName[I - 1],EndSep) then
Dec(I);
Result := Copy(FileName, 1, I);
end;
function ExtractFileDrive(const FileName: string): string;
function ExtractFileDrive(const FileName: PathStr): PathStr;
var
i,l: longint;
begin
@ -70,45 +70,45 @@ begin
i:=Pos(DriveSeparator,FileName);
if (i > 0) then Result:=Copy(FileName,1,i);
{$ELSE}
If (FileName[2] in AllowDriveSeparators) then
If CharInSet(FileName[2],AllowDriveSeparators) then
result:=Copy(FileName,1,2)
else if (FileName[1] in AllowDirectorySeparators) and
(FileName[2] in AllowDirectorySeparators) then
else if CharInSet(FileName[1],AllowDirectorySeparators) and
CharInSet(FileName[2],AllowDirectorySeparators) then
begin
i := 2;
{ skip share }
While (i<l) and Not (Filename[i+1] in AllowDirectorySeparators) do
While (i<l) and Not CharInSet(Filename[i+1],AllowDirectorySeparators) do
inc(i);
inc(i);
While (i<l) and Not (Filename[i+1] in AllowDirectorySeparators) do
While (i<l) and Not CharInSet(Filename[i+1],AllowDirectorySeparators) do
inc(i);
Result:=Copy(FileName,1,i);
end;
{$ENDIF}
end;
function ExtractFileName(const FileName: string): string;
function ExtractFileName(const FileName: PathStr): PathStr;
var
i : longint;
EndSep : Set of Char;
begin
I := Length(FileName);
EndSep:=AllowDirectorySeparators+AllowDriveSeparators;
while (I > 0) and not (FileName[I] in EndSep) do
while (I > 0) and not CharInSet(FileName[I],EndSep) do
Dec(I);
Result := Copy(FileName, I + 1, MaxInt);
end;
function ExtractFileExt(const FileName: string): string;
function ExtractFileExt(const FileName: PathStr): PathStr;
var
i : longint;
EndSep : Set of Char;
begin
I := Length(FileName);
EndSep:=AllowDirectorySeparators+AllowDriveSeparators+[ExtensionSeparator];
while (I > 0) and not (FileName[I] in EndSep) do
while (I > 0) and not CharInSet(FileName[I],EndSep) do
Dec(I);
if (I > 0) and (FileName[I] = ExtensionSeparator) then
Result := Copy(FileName, I, MaxInt)
@ -116,28 +116,26 @@ begin
Result := '';
end;
function ExtractShortPathName(Const FileName : String) : String;
function ExtractShortPathName(Const FileName : PathStr) : PathStr;
begin
{$ifdef MSWINDOWS}
SetLength(Result,Max_Path);
SetLength(Result,GetShortPathName(PChar(FileName), Pchar(Result),Length(Result)));
if sizeof(FileName[1])=1 then
SetLength(Result,GetShortPathNameA(PChar(FileName), PChar(Result),Length(Result)))
else
SetLength(Result,GetShortPathNameW(PWideChar(FileName), PWideChar(Result),Length(Result)));
{$else}
Result:=FileName;
{$endif}
end;
type
PathStr=string;
{$DEFINE FPC_FEXPAND_SYSUTILS}
{$I fexpand.inc}
function ExpandFileName (Const FileName : PathStr): PathStr;
function ExpandFileName (Const FileName : string): String;
Var S : String;
Var S : PathStr;
Begin
S:=FileName;
@ -147,7 +145,7 @@ end;
{$ifndef HASEXPANDUNCFILENAME}
function ExpandUNCFileName (Const FileName : string): String;
function ExpandUNCFileName (Const FileName : PathStr): PathStr;
begin
Result:=ExpandFileName (FileName);
//!! Here should follow code to replace the drive: part with UNC...
@ -155,38 +153,38 @@ end;
{$endif HASEXPANDUNCFILENAME}
function ExpandFileNameCase (const FileName: string; out MatchFound: TFilenameCaseMatch): string;
function ExpandFileNameCase (const FileName: PathStr; out MatchFound: TFilenameCaseMatch): PathStr;
var
SR: TSearchRec;
ItemsFound: byte;
FoundPath: string;
FoundPath: PathStr;
RestPos: SizeUInt;
Root: string;
Root: PathStr;
procedure TryCase (const Base, Rest: string);
procedure TryCase (const Base, Rest: PathStr);
var
SR: TSearchRec;
RC: longint;
NextDirPos: SizeUInt;
NextPart: string;
NextRest: string;
SearchBase: string;
NextPart: PathStr;
NextRest: PathStr;
SearchBase: PathStr;
begin
NextDirPos := 1;
while (NextDirPos <= Length (Rest)) and
not (Rest [NextDirPos] in (AllowDirectorySeparators)) do
not CharInSet(Rest[NextDirPos],(AllowDirectorySeparators)) do
Inc (NextDirPos);
NextPart := Copy (Rest, 1, Pred (NextDirPos));
{$IFDEF FPC_FEXPAND_DIRSEP_IS_UPDIR}
if (Length (Rest) >= NextDirPos) and
(Rest [NextDirPos] in AllowDirectorySeparators) then
CharInSet(Rest[NextDirPos],AllowDirectorySeparators) then
{$ELSE FPC_FEXPAND_DIRSEP_IS_UPDIR}
while (Length (Rest) >= NextDirPos) and
(Rest [NextDirPos] in AllowDirectorySeparators) do
CharInSet(Rest[NextDirPos],AllowDirectorySeparators) do
{$ENDIF FPC_FEXPAND_DIRSEP_IS_UPDIR}
Inc (NextDirPos);
NextRest := Copy (Rest, NextDirPos, Length (Rest) - Pred (NextDirPos));
if (Base = '') or (Base [Length (Base)] in AllowDirectorySeparators) then
if (Base = '') or CharInSet(Base[Length (Base)],AllowDirectorySeparators) then
SearchBase := Base
else
SearchBase := Base + DirectorySeparator;
@ -238,10 +236,10 @@ begin
begin
{$IFDEF FPC_FEXPAND_DIRSEP_IS_UPDIR}
if (Length (FileName) >= RestPos) and
(FileName [RestPos] in AllowDirectorySeparators) then
CharInSet(FileName[RestPos],AllowDirectorySeparators) then
{$ELSE FPC_FEXPAND_DIRSEP_IS_UPDIR}
while (Length (FileName) >= RestPos) and
(FileName [RestPos] in AllowDirectorySeparators) do
CharInSet(FileName[RestPos],AllowDirectorySeparators) do
{$ENDIF FPC_FEXPAND_DIRSEP_IS_UPDIR}
Inc (RestPos);
Root := Copy (FileName, 1, Pred (RestPos));
@ -265,11 +263,11 @@ Const
MaxDirs = 129;
{$endif}
function ExtractRelativepath (Const BaseName,DestName : String): String;
function ExtractRelativepath (Const BaseName,DestName : PathStr): PathStr;
Var Source, Dest : String;
Var Source, Dest : PathStr;
Sc,Dc,I,J : Longint;
SD,DD : Array[1..MaxDirs] of PChar;
SD,DD : Array[1..MaxDirs] of PathPChar;
Const OneLevelBack = '..'+DirectorySeparator;
@ -297,18 +295,18 @@ begin
Result:=Result+ExtractFileName(DestNAme);
end;
Procedure DoDirSeparators (Var FileName : String);
Procedure DoDirSeparators (Var FileName : PathStr);
VAr I : longint;
begin
For I:=1 to Length(FileName) do
If FileName[I] in AllowDirectorySeparators then
If CharInSet(FileName[I],AllowDirectorySeparators) then
FileName[i]:=DirectorySeparator;
end;
Function SetDirSeparators (Const FileName : string) : String;
Function SetDirSeparators (Const FileName : PathStr) : PathStr;
begin
Result:=FileName;
@ -322,7 +320,7 @@ end;
if none were found.
}
Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint;
Function GetDirs (Var DirName : PathStr; Var Dirs : Array of PathPChar) : Longint;
Var I : Longint;
@ -331,7 +329,7 @@ begin
Result:=-1;
While I<=Length(DirName) do
begin
If (DirName[i] in AllowDirectorySeparators) and
If CharInSet(DirName[i],AllowDirectorySeparators) and
{ avoid error in case last char=pathdelim }
(length(dirname)>i) then
begin
@ -344,7 +342,7 @@ begin
If Result>-1 then inc(Result);
end;
function IncludeTrailingPathDelimiter(Const Path : String) : String;
function IncludeTrailingPathDelimiter(Const Path : PathStr) : PathStr;
Var
l : Integer;
@ -352,35 +350,35 @@ Var
begin
Result:=Path;
l:=Length(Result);
If (L=0) or not(Result[l] in AllowDirectorySeparators) then
If (L=0) or not CharInSet(Result[l],AllowDirectorySeparators) then
Result:=Result+DirectorySeparator;
end;
function IncludeTrailingBackslash(Const Path : String) : String;
function IncludeTrailingBackslash(Const Path : PathStr) : PathStr;
begin
Result:=IncludeTrailingPathDelimiter(Path);
end;
function ExcludeTrailingBackslash(Const Path: string): string;
function ExcludeTrailingBackslash(Const Path: PathStr): PathStr;
begin
Result:=ExcludeTrailingPathDelimiter(Path);
end;
function ExcludeTrailingPathDelimiter(Const Path: string): string;
function ExcludeTrailingPathDelimiter(Const Path: PathStr): PathStr;
Var
L : Integer;
begin
L:=Length(Path);
If (L>0) and (Path[L] in AllowDirectorySeparators) then
If (L>0) and CharInSet(Path[L],AllowDirectorySeparators) then
Dec(L);
Result:=Copy(Path,1,L);
end;
function IncludeLeadingPathDelimiter(Const Path : String) : String;
function IncludeLeadingPathDelimiter(Const Path : PathStr) : PathStr;
Var
l : Integer;
@ -388,11 +386,11 @@ Var
begin
Result:=Path;
l:=Length(Result);
If (L=0) or not(Result[1] in AllowDirectorySeparators) then
If (L=0) or not CharInSet(Result[1],AllowDirectorySeparators) then
Result:=DirectorySeparator+Result;
end;
function ExcludeLeadingPathDelimiter(Const Path: string): string;
function ExcludeLeadingPathDelimiter(Const Path: PathStr): PathStr;
Var
L : Integer;
@ -400,17 +398,17 @@ Var
begin
Result:=Path;
L:=Length(Result);
If (L>0) and (Result[1] in AllowDirectorySeparators) then
If (L>0) and CharInSet(Result[1],AllowDirectorySeparators) then
Delete(Result,1,1);
end;
function IsPathDelimiter(Const Path: string; Index: Integer): Boolean;
function IsPathDelimiter(Const Path: PathStr; Index: Integer): Boolean;
begin
Result:=(Index>0) and (Index<=Length(Path)) and (Path[Index] in AllowDirectorySeparators);
Result:=(Index>0) and (Index<=Length(Path)) and CharInSet(Path[Index],AllowDirectorySeparators);
end;
function ConcatPaths(const Paths: array of String): String;
function ConcatPaths(const Paths: array of PathStr): PathStr;
var
I: Integer;
begin

44
rtl/objpas/sysutils/finah.inc
View File

@ -19,26 +19,26 @@ type
TFilenameCaseMatch = (mkNone, mkExactMatch, mkSingleMatch, mkAmbiguous);
{$endif}
function ChangeFileExt(const FileName, Extension: string): string;
function ExtractFilePath(const FileName: string): string;
function ExtractFileDrive(const FileName: string): string;
function ExtractFileName(const FileName: string): string;
function ExtractFileExt(const FileName: string): string;
function ExtractFileDir(Const FileName : string): string;
function ExtractShortPathName(Const FileName : String) : String;
function ExpandFileName (Const FileName : string): String;
function ExpandFileNameCase (const FileName: string; out MatchFound: TFilenameCaseMatch): string;
function ExpandUNCFileName (Const FileName : string): String;
function ExtractRelativepath (Const BaseName,DestNAme : String): String;
function IncludeTrailingPathDelimiter(Const Path : String) : String;
function IncludeTrailingBackslash(Const Path : String) : String;
function ExcludeTrailingBackslash(Const Path: string): string;
function ExcludeTrailingPathDelimiter(Const Path: string): string;
function IncludeLeadingPathDelimiter(Const Path : String) : String;
function ExcludeLeadingPathDelimiter(Const Path: string): string;
function IsPathDelimiter(Const Path: string; Index: Integer): Boolean;
Procedure DoDirSeparators (Var FileName : String);
Function SetDirSeparators (Const FileName : String) : String;
Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint;
function ConcatPaths(const Paths: array of String): String;
function ChangeFileExt(const FileName, Extension: PathStr): PathStr;
function ExtractFilePath(const FileName: PathStr): PathStr;
function ExtractFileDrive(const FileName: PathStr): PathStr;
function ExtractFileName(const FileName: PathStr): PathStr;
function ExtractFileExt(const FileName: PathStr): PathStr;
function ExtractFileDir(Const FileName : PathStr): PathStr;
function ExtractShortPathName(Const FileName : PathStr) : PathStr;
function ExpandFileName (Const FileName : PathStr): PathStr;
function ExpandFileNameCase (const FileName: PathStr; out MatchFound: TFilenameCaseMatch): PathStr;
function ExpandUNCFileName (Const FileName : PathStr): PathStr;
function ExtractRelativepath (Const BaseName,DestNAme : PathStr): PathStr;
function IncludeTrailingPathDelimiter(Const Path : PathStr) : PathStr;
function IncludeTrailingBackslash(Const Path : PathStr) : PathStr;
function ExcludeTrailingBackslash(Const Path: PathStr): PathStr;
function ExcludeTrailingPathDelimiter(Const Path: PathStr): PathStr;
function IncludeLeadingPathDelimiter(Const Path : PathStr) : PathStr;
function ExcludeLeadingPathDelimiter(Const Path: PathStr): PathStr;
function IsPathDelimiter(Const Path: PathStr; Index: Integer): Boolean;
Procedure DoDirSeparators (Var FileName : PathStr);
Function SetDirSeparators (Const FileName : PathStr) : PathStr;
Function GetDirs (Var DirName : PathStr; Var Dirs : Array of PathPChar) : Longint;
function ConcatPaths(const Paths: array of PathStr): PathStr;

9
rtl/objpas/sysutils/sysutilh.inc
View File

@ -288,8 +288,17 @@ Type
{$i sysencodingh.inc}
{$endif FPC_HAS_UNICODESTRING}
{$macro on}
{$define PathStr:=UnicodeString}
{$define PathPChar:=PWideChar}
{ Read filename handling functions declaration }
{$i finah.inc}
{$define PathStr:=AnsiString}
{$define PathPChar:=PAnsiChar}
{ Read filename handling functions declaration }
{$i finah.inc}
{$undef PathStr}
{$undef PathPChar}
{ Read other file handling function declarations }
{$i filutilh.inc}

9
rtl/objpas/sysutils/sysutils.inc
View File

@ -12,8 +12,17 @@
**********************************************************************}
{$macro on}
{$define PathStr:=UnicodeString}
{$define PathPChar:=PWideChar}
{ Read filename handling functions implementation }
{$i fina.inc}
{$define PathStr:=AnsiString}
{$define PathPChar:=PAnsiChar}
{ Read filename handling functions implementation }
{$i fina.inc}
{$undef PathStr}
{$undef PathPChar}
{ Read file utility functions implementation }
{$i filutil.inc}

19
rtl/win/sysutils.pp
View File

@ -181,10 +181,21 @@ end;
function ExpandUNCFileName (const filename:string) : string;
{ returns empty string on errors }
var
s : ansistring;
u: unicodestring;
begin
{ prevent data loss due to unsupported characters in ansi code page }
u:=ExpandUNCFileName(filename);
widestringmanager.Unicode2AnsiMoveProc(punicodechar(u),result,DefaultRTLFileSystemCodePage,length(u));
end;
function ExpandUNCFileName (const filename:unicodestring) : unicodestring;
{ returns empty string on errors }
var
s : unicodestring;
size : dword;
rc : dword;
buf : pchar;
buf : pwidechar;
begin
s := ExpandFileName (filename);
@ -194,12 +205,12 @@ begin
getmem(buf,size);
try
rc := WNetGetUniversalName (pchar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
rc := WNetGetUniversalNameW (pwidechar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
if rc=ERROR_MORE_DATA then
begin
buf:=reallocmem(buf,size);
rc := WNetGetUniversalName (pchar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
rc := WNetGetUniversalNameW (pwidechar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
end;
if rc = NO_ERROR then
Result := PRemoteNameInfo(buf)^.lpUniversalName