* universal FExpand

rtl/go32v2/dos.pp

@@ -796,110 +796,18 @@ begin
 end;
 
 
-function fexpand(const path : pathstr) : pathstr;
-var
-  s,pa : pathstr;
-  i,j  : longint;
-begin
-  getdir(0,s);
-  i:=ioresult;
-  if LFNSupport then
-   begin
-     pa:=path;
-   end
-  else
-   if FileNameCaseSensitive then
-    pa:=path
-   else
-    pa:=upcase(path);
+(*
+function FExpand (const Path: PathStr): PathStr;
+- declared in fexpand.inc
+*)
 
-  { allow slash as backslash }
-  for i:=1 to length(pa) do
-   if pa[i]='/' then
-    pa[i]:='\';
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
 
-  if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z','a'..'z']) then
-    begin
-       { Always uppercase driveletter }
-       if (pa[1] in ['a'..'z']) then
-        pa[1]:=Chr(Ord(Pa[1])-32);
-       { we must get the right directory }
-       getdir(ord(pa[1])-ord('A')+1,s);
-       i:=ioresult;
-       if (ord(pa[0])>2) and (pa[3]<>'\') then
-         if pa[1]=s[1] then
-           begin
-             { remove ending slash if it already exists }
-             if s[length(s)]='\' then
-              dec(s[0]);
-             pa:=s+'\'+copy (pa,3,length(pa));
-           end
-         else
-           pa:=pa[1]+':\'+copy (pa,3,length(pa))
-    end
-  else
-    if pa[1]='\' then
-      begin
-        { Do not touch Network drive names if LFNSupport is true }
-        if not ((Length(pa)>1) and (pa[2]='\') and LFNSupport) then
-          pa:=s[1]+':'+pa;
-      end
-    else if s[0]=#3 then
-      pa:=s+pa
-    else
-      pa:=s+'\'+pa;
-
-{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
-if length(pa) = 2 then
- begin
-   getdir(byte(pa[1])-64,s);
-   pa := s;
- end;
-
-{First remove all references to '\.\'}
-  while pos ('\.\',pa)<>0 do
-   delete (pa,pos('\.\',pa),2);
-{Now remove also all references to '\..\' + of course previous dirs..}
-  repeat
-    i:=pos('\..\',pa);
-    if i<>0 then
-     begin
-       j:=i-1;
-       while (j>1) and (pa[j]<>'\') do
-        dec (j);
-       if pa[j+1] = ':' then j := 3;
-       delete (pa,j,i-j+3);
-     end;
-  until i=0;
+{$I fexpand.inc}
 
-  { Turbo Pascal gets rid of a \.. at the end of the path }
-  { Now remove also any reference to '\..'  at end of line
-    + of course previous dir.. }
-  i:=pos('\..',pa);
-  if i<>0 then
-   begin
-     if i = length(pa) - 2 then
-      begin
-        j:=i-1;
-        while (j>1) and (pa[j]<>'\') do
-         dec (j);
-        delete (pa,j,i-j+3);
-      end;
-      pa := pa + '\';
-    end;
-  { Remove End . and \}
-  if (length(pa)>0) and (pa[length(pa)]='.') then
-   dec(byte(pa[0]));
-  { if only the drive + a '\' is left then the '\' should be left to prevtn the program
-    accessing the current directory on the drive rather than the root!}
-  { if the last char of path = '\' then leave it in as this is what TP does! }
-  if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
-   dec(byte(pa[0]));
-  { if only a drive is given in path then there should be a '\' at the
-    end of the string given back }
-  if length(pa) = 2 then pa := pa + '\';
-  fexpand:=pa;
-end;
+{$UNDEF FPC_FEXPAND_DRIVES}
+{$UNDEF FPC_FEXPAND_UNC}
 
 
 Function FSearch(path: pathstr; dirlist: string): pathstr;
@@ -1139,7 +1047,10 @@ End;
 end.
 {
   $Log$
-  Revision 1.11  2000-12-16 15:27:15  peter
+  Revision 1.12  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.11  2000/12/16 15:27:15  peter
     * fixed disksize to return -1 on error
 
   Revision 1.10  2000/10/11 15:38:03  peter

rtl/go32v2/system.pp

@@ -1280,12 +1280,15 @@ begin
 end;
 
 
-procedure getdir(drivenr : byte;var dir : shortstring);
+function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
+                                               [public, alias: 'FPC_GETDIRIO'];
 var
   temp : array[0..255] of char;
   i    : longint;
   regs : trealregs;
+  IOR: word;
 begin
+  IOR := 0;
   regs.realedx:=drivenr;
   regs.realesi:=tb_offset;
   regs.realds:=tb_segment;
@@ -1298,7 +1301,7 @@ begin
   sysrealintr($21,regs);
   if (regs.realflags and carryflag) <> 0 then
    Begin
-     GetInOutRes(lo(regs.realeax));
+     IOR := lo(regs.realeax);
      exit;
    end
   else
@@ -1331,6 +1334,12 @@ begin
    end;
 end;
 
+procedure GetDir (DriveNr: byte; var Dir: ShortString);
+
+begin
+  GetInOutRes (GetDirIO (DriveNr, Dir));
+end;
+
 
 {*****************************************************************************
                          SystemUnit Initialization
@@ -1417,7 +1426,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.4  2001-02-20 21:31:12  peter
+  Revision 1.5  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.4  2001/02/20 21:31:12  peter
     * chdir,mkdir,rmdir with empty string fixed
 
   Revision 1.3  2000/08/13 19:23:26  peter

rtl/unix/sysunix.inc

@@ -482,7 +482,8 @@ Begin
 End;
 
 
-procedure getdir(drivenr : byte;var dir : shortstring);
+function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
+                                               [public, alias: 'FPC_GETDIRIO'];
 var
   thisdir      : stat;
   rootino,
@@ -497,6 +498,7 @@ var
   mountpoint,validdir : boolean;
   predot       : string[255];
 begin
+  GetDirIO := 0;
   drivenr:=0;
   dir:='';
   thedir:='/'#0;
@@ -552,6 +554,12 @@ begin
   dir:=thedir
 end;
 
+procedure GetDir (DriveNr: byte; var Dir: ShortString);
+
+begin
+    InOutRes := GetDirIO (DriveNr, Dir);
+end;
+
 
 {*****************************************************************************
                          SystemUnit Initialization
@@ -746,7 +754,10 @@ End.
 
 {
   $Log$
-  Revision 1.5  2001-02-20 21:31:12  peter
+  Revision 1.6  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.5  2001/02/20 21:31:12  peter
     * chdir,mkdir,rmdir with empty string fixed
 
   Revision 1.4  2000/12/17 14:00:57  peter

rtl/unix/unix.pp

@@ -2124,75 +2124,21 @@ begin
 end;
 
 
+(*
+function FExpand (const Path: PathStr): PathStr;
+- declared in fexpand.inc
+*)
 
-Function FExpand(Const Path:PathStr):PathStr;
-var
-  temp  : pathstr;
-  i,j   : longint;
-  p     : pchar;
-Begin
-{Remove eventual drive - doesn't exist in Linux}
-  if path[2]=':' then
-   i:=3
-  else
-   i:=1;
-  temp:='';
-{Replace ~/ with $HOME}
-  if (path[i]='~') and ((i+1>length(path)) or (path[i+1]='/'))  then
-   begin
-     p:=getenv('HOME');
-     if not (p=nil) then
-      Insert(StrPas(p),temp,i);
-     i:=1;
-     temp:=temp+Copy(Path,2,255);
-   end;
-{Do we have an absolute path ? No - prefix the current dir}
-  if temp='' then
-   begin
-     if path[i]<>'/' then
-      begin
-        {$I-}
-         getdir(0,temp);
-        {$I+}
-        if ioresult<>0 then;
-      end
-     else
-      inc(i);
-     temp:=temp+'/'+copy(path,i,length(path)-i+1)+'/';
-   end;
-{First remove all references to '/./'}
-  while pos('/./',temp)<>0 do
-   delete(temp,pos('/./',temp),2);
-{Now remove also all references to '/../' + of course previous dirs..}
-  repeat
-    i:=pos('/../',temp);
-   {Find the pos of the previous dir}
-    if i>1 then
-     begin
-       j:=i-1;
-       while (j>1) and (temp[j]<>'/') do
-        dec (j);{temp[1] is always '/'}
-       delete(temp,j,i-j+3);
-      end
-     else
-      if i=1 then               {i=1, so we have temp='/../something', just delete '/../'}
-       delete(temp,1,3);
-  until i=0;
-  { Remove ending /.. }
-  i:=pos('/..',temp);
-  if (i<>0) and (i =length(temp)-2) then
-    begin
-    j:=i-1;
-    while (j>1) and (temp[j]<>'/') do
-      dec (j);
-    delete (temp,j,i-j+3);
-    end;
-  { if last character is / then remove it - dir is also a file :-) }
-  if (length(temp)>0) and (temp[length(temp)]='/') then
-   dec(byte(temp[0]));
-  fexpand:=temp;
-End;
+{$DEFINE FPC_FEXPAND_TILDE} (* Tilde is expanded to home *)
+{$DEFINE FPC_FEXPAND_GETENVPCHAR} (* GetEnv result is a PChar *)
+
+const
+  LFNSupport = true;
 
+{$I fexpand.inc}
+
+{$UNDEF FPC_FEXPAND_GETENVPCHAR}
+{$UNDEF FPC_FEXPAND_TILDE}
 
 
 Function FSearch(const path:pathstr;dirlist:string):pathstr;
@@ -2894,7 +2840,10 @@ End.
 
 {
   $Log$
-  Revision 1.2  2001-01-22 07:25:10  marco
+  Revision 1.3  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.2  2001/01/22 07:25:10  marco
    * IOPERM for FreeBSD. Port routines moved from linsysca to Unix again .
 
   Revision 1.1  2001/01/21 20:21:41  marco

rtl/win32/dos.pp

@@ -684,27 +684,23 @@ function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PC
 function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWORD):DWORD;
     external 'kernel32' name 'GetShortPathNameA';
 
-function FExpand(const path : pathstr) : pathstr;
-var value      : Array[0..255] of char;
-    tmp        : PChar;
-    p          : string;
-    i          : Longint;
-begin
-  { if path is empty then return the current dir }
-  if path<>'' then
-   p:=path
-  else
-   p:='.';
-  { allow slash as backslash }
-  for i:=1 to length(p) do
-   if p[i]='/' then
-    p[i]:='\';
-  StringToPchar(p);
-  tmp:=nil;
-  fillchar(value,sizeof(value),0);
-  GetFullPathName(@p, 255, value, tmp);
-  FExpand := strpas(value);
-end;
+
+(*
+function FExpand (const Path: PathStr): PathStr;
+- declared in fexpand.inc
+*)
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+const
+  LFNSupport = true;
+
+{$I fexpand.inc}
+
+{$UNDEF FPC_FEXPAND_DRIVES}
+{$UNDEF FPC_FEXPAND_UNC}
+
 
   function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
     var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
@@ -1016,7 +1012,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-12-18 17:28:58  jonas
+  Revision 1.8  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.7  2000/12/18 17:28:58  jonas
     * fixed range check errors
 
   Revision 1.6  2000/09/06 20:47:34  peter

rtl/win32/system.pp

@@ -640,19 +640,23 @@ begin
   dirfn(TDirFnType(@SetCurrentDirectory),s);
 end;
 
-procedure getdir(drivenr:byte;var dir:shortstring);
+function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
+                                               [public, alias: 'FPC_GETDIRIO'];
 const
   Drive:array[0..3]of char=(#0,':',#0,#0);
 var
   defaultdrive:boolean;
   DirBuf,SaveBuf:array[0..259] of Char;
+  IOR: word;
 begin
+  IOR := 0;
   defaultdrive:=drivenr=0;
   if not defaultdrive then
    begin
     byte(Drive[0]):=Drivenr+64;
     GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
-    SetCurrentDirectory(@Drive);
+    if SetCurrentDirectory(@Drive) <> 0 then
+     IOR := word (GetLastError);
    end;
   GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
   if not defaultdrive then
@@ -660,6 +664,14 @@ begin
   dir:=strpas(DirBuf);
   if not FileNameCaseSensitive then
    dir:=upcase(dir);
+  GetDirIO := IOR;
+end;
+
+procedure GetDir (DriveNr: byte; var Dir: ShortString);
+
+begin
+  errno := GetDirIO (DriveNr, Dir);
+  Errno2InoutRes;
 end;
 
 
@@ -1426,7 +1438,10 @@ end.
 
 {
   $Log$
-  Revision 1.6  2001-02-20 21:31:12  peter
+  Revision 1.7  2001-03-16 20:09:58  hajny
+    * universal FExpand
+
+  Revision 1.6  2001/02/20 21:31:12  peter
     * chdir,mkdir,rmdir with empty string fixed
 
   Revision 1.5  2001/01/26 16:38:03  florian