paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 23:40:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix for absolute paths on platforms without drives (*nix), support for long volume names added

Browse Source
This commit is contained in:
Tomas Hajny 2001-04-07 19:37:27 +00:00
parent 6fd93ee078
commit a820a0f393
1 changed files with 133 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

199
rtl/inc/fexpand.inc
View File

@ -17,7 +17,7 @@
****************************************************************************} ****************************************************************************}
function GetDirIO (DriveNr: byte; var Dir: OpenString): word; procedure GetDirIO (DriveNr: byte; var Dir: OpenString);
(* GetDirIO is supposed to return the root of the given drive *) (* GetDirIO is supposed to return the root of the given drive *)
(* in case of an error for compatibility of FExpand with TP/BP. *) (* in case of an error for compatibility of FExpand with TP/BP. *)
@ -28,19 +28,32 @@ begin
OldInOutRes := InOutRes; OldInOutRes := InOutRes;
InOutRes := 0; InOutRes := 0;
GetDir (DriveNr, Dir); GetDir (DriveNr, Dir);
GetDirIO := InOutRes;
InOutRes := OldInOutRes; InOutRes := OldInOutRes;
end; end;
{$IFDEF FPC_FEXPAND_VOLUMES}
procedure GetDirIO (const VolumeName: OpenString; var Dir: OpenString);
var
OldInOutRes: word;
begin
OldInOutRes := InOutRes;
InOutRes := 0;
GetDir (VolumeName, Dir);
InOutRes := OldInOutRes;
end;
{$ENDIF FPC_FEXPAND_VOLUMES}
function FExpand (const Path: PathStr): PathStr; function FExpand (const Path: PathStr): PathStr;
(* LFNSupport boolean constant, variable or function must be declared for all (* LFNSupport boolean constant, variable or function must be declared for all
the platforms, at least locally in the Dos unit implementation part. the platforms, at least locally in the Dos unit implementation part.
In addition, FPC_FEXPAND_UNC, FPC_FEXPAND_DRIVES, FPC_FEXPAND_GETENV_PCHAR In addition, FPC_FEXPAND_UNC, FPC_FEXPAND_DRIVES, FPC_FEXPAND_GETENV_PCHAR,
and FPC_FEXPAND_TILDE conditionals might be defined to specify FExpand FPC_FEXPAND_TILDE and FPC_FEXPAND_VOLUMES conditionals might be defined to
behaviour. Only forward slashes are supported if UNIX conditional specify FExpand behaviour. Only forward slashes are supported if UNIX
is defined, both forward and backslashes otherwise. conditional is defined, both forward and backslashes otherwise.
*) *)
const const
@ -49,13 +62,14 @@ const
{$ELSE UNIX} {$ELSE UNIX}
DirSep = '\'; DirSep = '\';
{$ENDIF UNIX} {$ENDIF UNIX}
DriveSep = ':';
{$IFDEF FPC_FEXPAND_DRIVES} {$IFDEF FPC_FEXPAND_DRIVES}
PathStart = 3; PathStart: longint = 3;
{$ELSE FPC_FEXPAND_DRIVES} {$ELSE FPC_FEXPAND_DRIVES}
PathStart = 1; PathStart = 1;
{$ENDIF FPC_FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
var S, Pa: PathStr; var S, Pa, Dirs: PathStr;
I, J: longint; I, J: longint;
begin begin
@ -68,10 +82,13 @@ begin
for I := 1 to Length (Pa) do for I := 1 to Length (Pa) do
if Pa [I] = '/' then if Pa [I] = '/' then
Pa [I] := DirSep; Pa [I] := DirSep;
{$ENDIF} {$ENDIF UNIX}
{$IFDEF FPC_FEXPAND_VOLUMES}
PathStart := Succ (Pos (DriveSep, Pa));
{$ENDIF FPC_FEXPAND_VOLUMES}
{$IFDEF FPC_FEXPAND_TILDE} {$IFDEF FPC_FEXPAND_TILDE}
{Replace ~/ with $HOME} {Replace ~/ with $HOME/}
if (Length (Pa) >= 1) and (Pa [1] ='~') and if (Length (Pa) >= 1) and (Pa [1] = '~') and
((Pa [2] = DirSep) or (Length (Pa) = 1)) then ((Pa [2] = DirSep) or (Length (Pa) = 1)) then
begin begin
{$IFDEF FPC_FEXPAND_GETENV_PCHAR} {$IFDEF FPC_FEXPAND_GETENV_PCHAR}
@ -88,45 +105,85 @@ begin
Pa := S + Copy (Pa, 2, Pred (Length (Pa))); Pa := S + Copy (Pa, 2, Pred (Length (Pa)));
end; end;
{$ENDIF FPC_FEXPAND_TILDE} {$ENDIF FPC_FEXPAND_TILDE}
{$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 (Pa [1] in ['A'..'Z', 'a'..'z']) and
(Pa [2] = ':') then (Pa [2] = DriveSep) then
{$ENDIF FPC_FEXPAND_VOLUMES}
begin begin
{$IFDEF FPC_FEXPAND_DRIVES} {$IFDEF FPC_FEXPAND_DRIVES}
{$IFDEF FPC_FEXPAND_VOLUMES}
GetDirIO (Copy (Pa, 1, PathStart - 2), S);
{$ELSE FPC_FEXPAND_VOLUMES}
{ Always uppercase driveletter } { Always uppercase driveletter }
if (Pa [1] in ['a'..'z']) then if (Pa [1] in ['a'..'z']) then
Pa [1] := Chr (Ord (Pa [1]) and not ($20)); Pa [1] := Chr (Ord (Pa [1]) and not ($20));
if GetDirIO (Ord (Pa [1]) - Ord ('A') + 1, S) = 0 then ; GetDirIO (Ord (Pa [1]) - Ord ('A') + 1, S);
case Length (Pa) of {$ENDIF FPC_FEXPAND_VOLUMES}
2: Pa := S; if Length (Pa) = Pred (PathStart) then
Pa := S
else else
if Pa [3] <> DirSep then if Pa [PathStart] <> DirSep then
{$IFDEF FPC_FEXPAND_VOLUMES}
if Copy (Pa, 1, PathStart - 2) = Copy (S, 1, PathStart - 2)
then
{$ELSE FPC_FEXPAND_VOLUMES}
if Pa [1] = S [1] then if Pa [1] = S [1] then
{$ENDIF FPC_FEXPAND_VOLUMES}
begin begin
{ remove ending slash if it already exists } { remove ending slash if it already exists }
if S [Length (S)] = DirSep then if S [Length (S)] = DirSep then
Dec (S [0]); Dec (S [0]);
Pa := S + DirSep + Copy (Pa, 3, Length (Pa)) Pa := S + DirSep +
Copy (Pa, PathStart, Length (Pa) - PathStart + 1)
end end
else else
Pa := Pa [1] + ':' + DirSep + Copy (Pa, 3, Length (Pa)) {$IFDEF FPC_FEXPAND_VOLUMES}
end; Pa := Copy (Pa, 1, PathStart - 2) + DriveSep + DirSep +
Copy (Pa, PathStart, Length (Pa) - PathStart + 1)
{$ELSE FPC_FEXPAND_VOLUMES}
Pa := Pa [1] + DriveSep + DirSep +
Copy (Pa, PathStart, Length (Pa) - PathStart + 1)
{$ENDIF FPC_FEXPAND_VOLUMES}
end end
else else
{$ELSE FPC_FEXPAND_DRIVES} {$ELSE FPC_FEXPAND_DRIVES}
Delete (Pa, 1, 2); Delete (Pa, 1, 2);
end; end;
{Check whether we don't have an absolute path already}
if (Length (Pa) >= PathStart) and (Pa [PathStart] <> DirSep) then
{$ENDIF FPC_FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
begin begin
if GetDirIO (0, S) = 0 then ; GetDirIO (0, S);
{$IFDEF FPC_FEXPAND_DRIVES} {$IFDEF FPC_FEXPAND_DRIVES}
if (Length (Pa) > 0) and (Pa [1] = DirSep) then if (Length (Pa) > 0) and (Pa [1] = DirSep) then
begin begin
{$IFDEF FPC_FEXPAND_UNC} {$IFDEF FPC_FEXPAND_UNC}
{ Do not touch Network drive names } {Do not touch network drive names}
if not ((Length (Pa) > 1) and (Pa [2] = Pa [1]) if (Length (Pa) > 1) and (Pa [2] = DirSep)
and LFNSupport) then and LFNSupport then
begin
if Length (Pa) = 2 then
Pa := DirSep + DirSep + '.' + DirSep;
PathStart := 3;
{Find the start of the string of directories}
while (Pa [PathStart] <> DirSep) and
(PathStart <= Length (Pa)) do
Inc (PathStart);
if PathStart > Length (Pa) then Pa := Pa + DirSep;
end
else
{$ENDIF FPC_FEXPAND_UNC} {$ENDIF FPC_FEXPAND_UNC}
Pa := S [1] + ':' + Pa {$IFDEF FPC_FEXPAND_VOLUMES}
begin
I := Pos (DriveSep, S);
Pa := Copy (S, 1, Pred (I)) + DriveSep + Pa;
PathStart := Succ (I);
end;
{$ELSE FPC_FEXPAND_VOLUMES}
Pa := S [1] + DriveSep + Pa;
{$ENDIF FPC_FEXPAND_VOLUMES}
end end
else else
{$ENDIF FPC_FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
@ -141,62 +198,69 @@ begin
else else
Pa := S + DirSep + Pa; Pa := S + DirSep + Pa;
end; end;
{Get string of directories to only process relative references on this one}
Dirs := Copy (Pa, Succ (PathStart), Length (Pa) - PathStart);
{First remove all references to '\.\'} {First remove all references to '\.\'}
I := Pos (DirSep + '.' + DirSep, Pa); I := Pos (DirSep + '.' + DirSep, Dirs);
while I <> 0 do while I <> 0 do
begin begin
Delete (Pa, I, 2); Delete (Dirs, I, 2);
I := Pos (DirSep + '.' + DirSep, Pa); I := Pos (DirSep + '.' + DirSep, Dirs);
end; end;
{Now remove also all references to '\..\' + of course previous dirs..} {Now remove also all references to '\..\' + of course previous dirs..}
I := Pos (DirSep + '..' + DirSep, Pa); I := Pos (DirSep + '..' + DirSep, Dirs);
while I <> 0 do while I <> 0 do
begin begin
J := Pred (I); J := Pred (I);
while (J > 0) and (Pa [J] <> DirSep) do while (J > 0) and (Dirs [J] <> DirSep) do
Dec (J); Dec (J);
if (J = 0) Delete (Dirs, Succ (J), I - J + 3);
{$IFDEF FPC_FEXPAND_UNC} I := Pos (DirSep + '..' + DirSep, Dirs);
or (J = 1) and (I = 2)
{$ENDIF FPC_FEXPAND_UNC}
then
Delete (Pa, Succ (I), 3)
else
Delete (Pa, Succ (J), I - J + 3);
I := Pos (DirSep + '..' + DirSep, Pa);
end; end;
{Now remove also any reference to '\..' at the end of line {Then remove also a reference to '\..' at the end of line
+ of course previous dir..} + the previous directory, of course,...}
I := Pos (DirSep + '..', Pa); I := Pos (DirSep + '..', Dirs);
if (I <> 0) and (I = Length (Pa) - 2) then if (I <> 0) and (I = Length (Dirs) - 2) then
begin begin
J := Pred (I); J := Pred (I);
while (J >= 1) and (Pa [J] <> DirSep) do while (J >= 0) and (Dirs [J] <> DirSep) do
Dec (J); Dec (J);
if (J = 0) if (J = 0) then
{$IFDEF FPC_FEXPAND_UNC} Dirs := ''
or (J = 1) and (I = 2)
{$ENDIF FPC_FEXPAND_UNC}
then
Delete (Pa, Succ (I), 2)
else else
Delete (Pa, Succ (J), I - J + 2); Delete (Dirs, Succ (J), I - J + 2);
end; end;
{Now remove also any reference to '\.' at the end of line} {...and also a possible reference to '\.'}
I := Pos (DirSep + '.', Pa); if (Length (Dirs) = 1) then
if (I <> 0) and (I = Pred (Length (Pa))) then begin
{$IFDEF FPC_FEXPAND_DRIVES} if (Dirs [1] = '.') then
if (I = 3) and (Pa [2] = ':') {A special case}
{$ELSE FPC_FEXPAND_DRIVES} Dirs := ''
if (I = 1) end
{$ENDIF FPC_FEXPAND_DRIVES} else
{$IFDEF FPC_FEXPAND_UNC} if (Length (Dirs) <> 0) and (Dirs [Length (Dirs)] = '.') and
or (I = 2) and (Pa [1] = '\') (Dirs [Pred (Length (Dirs))] = DirSep) then
{$ENDIF FPC_FEXPAND_UNC} Dec (Dirs [0], 2);
then {Finally remove '.\' at the beginning of the string of directories...}
Dec (Pa [0]) while (Length (Dirs) >= 2) and (Dirs [1] = '.') and (Dirs [2] = DirSep) do
else Delete (Dirs, 1, 2);
Delete (Pa, I, 2); {...and possible (invalid) references to '..\' as well}
while (Length (Dirs) >= 3) and (Dirs [1] = '.') and (Dirs [2] = '.') and
(Dirs [3] = DirSep) do
Delete (Dirs, 1, 3);
{Two special cases - '.' and '..' alone}
if (Length (Dirs) = 1) and (Dirs [1] = '.') or
(Length (Dirs) = 2) and (Dirs [1] = '.') and (Dirs [2] = '.') then
Dirs := '';
{Join the parts back to create the complete path}
if Length (Dirs) = 0 then
begin
Pa := Copy (Pa, 1, PathStart);
if Pa [PathStart] <> DirSep then
Pa := Pa + DirSep;
end
else
Pa := Copy (Pa, 1, PathStart) + Dirs;
{Remove ending \ if not supplied originally, the original string {Remove ending \ if not supplied originally, the original string
wasn't empty (to stay compatible) and if not really needed} wasn't empty (to stay compatible) and if not really needed}
if (Length (Pa) > PathStart) and (Pa [Length (Pa)] = DirSep) if (Length (Pa) > PathStart) and (Pa [Length (Pa)] = DirSep)
@ -207,7 +271,10 @@ end;
{ {
$Log$ $Log$
Revision 1.5 2001-03-21 21:08:20 hajny Revision 1.6 2001-04-07 19:37:27 hajny
* fix for absolute paths on platforms without drives (*nix), support for long volume names added
Revision 1.5 2001/03/21 21:08:20 hajny
* GetDir fixed * GetDir fixed
Revision 1.4 2001/03/19 21:09:30 hajny Revision 1.4 2001/03/19 21:09:30 hajny