{
Copyright (C) 1998-99 Free Software Foundation, Inc.

Authors: Dr A Olowofoyeku <laa12@keele.ac.uk>
         Frank Heckenbach <frank@pascal.gnu.de>

File name routines.

This file is part of GNU Pascal Library. The GNU Pascal Library is free
software; you can redistribute it and/or modify it under the terms of
the GNU Library General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

The GNU Pascal Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA.
}

unit FileName;

interface

uses GPC;

(*@@sietse1*)const TStringSize = 2048;
type TString = String (TStringSize);

{
  Define constants for different systems:

  OSDosFlag:         flag to indicate whether the target system is Dos

  PathSeparator:     the separator of multiple paths, e.g. in the PATH
                     environment variable

  DirSeparator:      the separator of the directories within a full file name

  DirSeparators:     a set of all possible directory and drive name separators

  ExtSeparator:      the separator of a file name extension

  DirSelf:           the name of a directory in itself

  DirParent:         the name of the parent directory

  NullDeviceName:    the full file name of the null device

  TTYDeviceName:     the full file name of the current TTY

  ConsoleDeviceName: the full file name of the system console. On Dos systems,
                     this is the same as the TTY, but on systems that allow
                     remote login, this is a different thing and may reach a
                     completely different user than the one running the
                     program, so use with care.

  PathEnvVar:        the name of the environment variable which (usually)
                     contains the executable search path

  ShellEnvVar:       the name of the environment variable which (usually)
                     contains the path of the shell executable

  ConfigFileMask:    a mask for the option file name as returned by
                     ConfigFileName
}

{$ifdef __OS_DOS__}

const
  OSDosFlag         = True;
  PathSeparator     = ';';
  DirSeparator      = '\';
  DirSeparators     = [':', '\', '/'];
  ExtSeparator      = '.';
  DirSelf           = '.';
  DirParent         = '..';
  NullDeviceName    = 'nul';
  TTYDeviceName     = 'con';
  ConsoleDeviceName = 'con';
  PathEnvVar        = 'PATH';
  ShellEnvVar       = 'COMSPEC';
  ConfigFileMask    = '*.cfg';

{$else}

const
  OSDosFlag         = False;
  PathSeparator     = ':';
  DirSeparator      = '/';
  DirSeparators     = ['/'];
  ExtSeparator      = '.';
  DirSelf           = '.';
  DirParent         = '..';
  NullDeviceName    = '/dev/null';
  TTYDeviceName     = '/dev/tty';
  ConsoleDeviceName = '/dev/console';
  PathEnvVar        = 'PATH';
  ShellEnvVar       = 'SHELL';
  ConfigFileMask    = '.*';

{$endif}

const
  NewLine = {$char-escapes} "\n" {$no-char-escapes}; { the separator of lines within a file }
  WildCardChars = ['*', '?', '[', ']'];

{ libc system call }
function  CSystem (CmdLine : CString) : Integer;                           asmname 'system';

{ Like CSystem, but returns execution errors via the IOResult mechanism,
  returns only the exit status of the executed program. }
function  Execute (CmdLine : CString) : Integer;                           asmname '_p_execute';

{ Get an environment variable. If it does not exist, GetEnv returns the
  empty string, which can't be distinguished from a variable with an empty
  value, while CGetEnv returns nil then. }
function  GetEnv  (const EnvVar : String) : TString;                       asmname '_p_getenv';
function  CGetEnv (EnvVar : CString) : CString;                            asmname 'getenv';

{ If s is of the form var=value, the environment variable with the name var
  is set to value. A previous value, if any, is overwritten. The function
  returns 0 on success, and something else otherwise. NOTE: s is NOT copied
  automatically, so unless it's a constant, a copy of the actual variable
  made with StrDup/StrNew should be passed to this function. }
function  PutEnv  (s : CString) : Integer;                                 asmname 'putenv';

{ Change a file name to use the OS dependent directory separator }
function  Slash2OSDirSeparator (const s : String) : TString;               asmname '_p_slash2osdirseparator';

{ Change a file name to use '/' as directory separator }
function  OSDirSeparator2Slash (const s : String) : TString;               asmname '_p_osdirseparator2slash';

{ Like Slash2OSDirSeparator for CStrings -- NOTE: overwrites the CString }
function  Slash2OSDirSeparator_CString (s : CString) : CString;            asmname '_p_slash2osdirseparator_cstring';

{ Like OSDirSeparator2Slash for CStrings -- NOTE: overwrites the CString }
function  OSDirSeparator2Slash_CString (s : CString) : CString;            asmname '_p_osdirseparator2slash_cstring';

{ Add a DirSeparator to the end of s, if there is not already one and
  s denotes an existing directory }
function  AddDirSeparator (const s : String) : TString;                    asmname '_p_adddirseparator';

{ Remove a DirSeparator at the end of s, if there is one }
function  RemoveDirSeparator (const s : String) : TString;                 asmname '_p_removedirseparator';

{ Returns the current directory using OS dependent directory separators }
function  GetCurrentDirectory     : TString;                               asmname '_p_get_current_directory';

{ Returns a directory suitable for storing temporary files using OS dependent
  directory separators. If found, the result always ends in DirSeparator.
  If no directory is found, an empty string is returned. }
function  GetTempDirectory        : TString;                               asmname '_p_get_temp_directory';

{ Returns a non-existing file name in GetTempDirectory. If no temp
  directory is found, i.e. GetTempDirectory returns the empty string,
  a runtime error is raised. }
function  GetTempFileName         : TString;                               asmname '_p_get_temp_file_name';

{ The same as GetTempFileName, but returns a CString allocated from the heap. }
function  GetTempFileName_CString : CString;                               asmname '_p_get_temp_file_name_cstring';

{ Get the external file name }
function  FileName (var f : AnyFile) : TString;                            asmname '_p_file_name';

{ Returns true if the given file name is an existing file }
function  FileExists      (const FileName : String) : Boolean;             asmname '_p_file_exists';

{ Returns true if the given file name is an existing directory }
function  DirectoryExists (const FileName : String) : Boolean;             asmname '_p_directory_exists';

{ If a file of the given name exists in one of the directories given in
  DirList (separated by PathSeparator), returns the full path, otherwise
  returns an empty string. If FileName already contains an element of
  DirSeparators, returns Slash2OSDirSeparator (FileName) if it exists. }
function  FSearch (const FileName, DirList : String) : TString;            asmname '_p_fsearch';

{ Like FSearch, but only find executable files. Under Dos, if not found,
  the function tries appending '.com', '.exe' and '.bat', so you don't have
  to specify these extensions in FileName (and with respect to portability,
  it might be preferable to not do so). }
function  FSearchExecutable (const FileName, DirList : String) : TString;  asmname '_p_fsearch_executable';

{ Replaces all occurrences of `$FOO' and `~' in s by the value of the
  environment variables FOO or HOME, respectively. If a variable is not
  defined, the function returns False, and s contains the name of the
  undefined variable. Otherwise, if all variables are found, s contains
  the replaced string, and True is returned. }
function  ExpandEnvironment (var s : String) : Boolean;                    asmname '_p_expand_environment';

{ Expands the given path name to a full path name. Relative paths are
  expanded using the current directory, and occurrences of DirSelf and
  DirParent are removed. Under Dos, it removes a trailing ExtSeparator
  (except in a trailing DirSelf or DirParent), like Dos does.
  If the directory, i.e. the path without the file name, is invalid,
  the empty string is returned. }
function  FExpand (const Path : String) : TString;                         asmname '_p_fexpand';

{ FExpands Path, and then removes the current directory from it, if it
  is a prefix of it. If OnlyCurDir is set, the current directory will
  be removed only if Path denotes a file in, not below, it. }
function  RelativePath (const Path : String; OnlyCurDir : Boolean) : TString; asmname '_p_relative_path';

{ Is s a UNC filename? (Dos only, otherwise always returns False) }
function  isUNC (const s : String) : Boolean;                              asmname '_p_isunc';

{ Splits a file name into directory, name and extension }
procedure FSplit (const Path : String; var Dir, Name, Ext : String);       asmname '_p_fsplit';

{ Functions that extract one of the parts from FSplit }
function  DirFromPath  (const Path : String) : TString;                    asmname '_p_dir_from_path';
function  NameFromPath (const Path : String) : TString;                    asmname '_p_name_from_path';
function  ExtFromPath  (const Path : String) : TString;                    asmname '_p_ext_from_path';

{ Start reading a directory. If successful, a pointer is returned that can
  be used for subsequent calls to ReadDir and finally CloseDir. On failure,
  nil is returned. }
function  OpenDir  (Name : CString) : DirPtr;                              C;

{ Reads one entry from the directory Dir, and returns the file name. On
  errors or end of directory, the empty string is returned. }
function  ReadDir  (Dir : DirPtr) : TString;                               asmname '_p_readdir';

{ Closes a directory opened with OpenDir. Returns 0 on success, anything
  else on error. }
function  CloseDir (Dir : DirPtr) : Integer;                               asmname '_p_closedir';

{ Tests if a file name matches a shell wildcard pattern (?, *, []) }
function  FileNameMatch (const Pattern, Name : String) : Boolean;          asmname '_p_filenamematch';

{ File name globbing }
procedure Glob     (var Buf : GlobBuffer; Pattern : CString);              asmname '_p_glob';
procedure GlobFree (var Buf : GlobBuffer);                                 asmname '_p_globfree';

{ Return a file name suited for a configuration file.
  Under Unix, it is made up of '$HOME/.' plus the base name (without
  directory) of the running program (as returned by ParamStr (0)) plus 'rc',
  if Global is False (this is meant for user-specific configuration),
  and of '/etc/' plus base name plus 'rc' if Global is True (system-wide
  configuration).
  Under Dos, it is composed of the directory and base name of the running
  program plus '.cfg', regardless of Global.
  If Name is not empty, it will be used instead of the base name of the
  running program. }
function  ConfigFileName (Name : String; Global : Boolean) : TString;      asmname '_p_config_file_name';

implementation

{$I-,B-}

{ Currently needed for realpath() in rts/file.c. }
var
  DirSeparatorVar : asmname '_p_dirseparatorvar' Char;
  DirSeparatorVar : Char = DirSeparator;

function GetCWD (Buf : CString; Size : SizeType) : CString; C;
function RealPath (Path, Buf : CString) : CString; C;
function GetPID : Cardinal; C;
function ReadDir_C (Dir : Pointer) : CString; asmname '_p_readdir_c'; { in file.c }
var HaveFNMatch : asmname '_p_have_fnmatch' Integer;
function FNMatch (Pattern, Name : CString) : Integer; asmname '_p_fnmatch';

(*@@remove when built-in*)
function GetEnv (const EnvVar : String) : TString;
var Temp : CString;
begin
  Temp := CGetEnv (EnvVar);
  if Temp = nil then GetEnv := '' else GetEnv := CString2String (Temp)
end;

function Slash2OSDirSeparator (const s : String) = Result : TString;
var i : Integer;
begin
  Result := s;
  if DirSeparator <> '/' then
    for i := 1 to Length (Result) do
      if Result [i] = '/' then Result [i] := DirSeparator
end;

function OSDirSeparator2Slash (const s : String) = Result : TString;
var i : Integer;
begin
  Result := s;
  if DirSeparator <> '/' then
    for i := 1 to Length (Result) do
      if Result [i] = DirSeparator then Result [i] := '/'
end;

function Slash2OSDirSeparator_CString (s : CString) : CString;
var tmp : CString;
begin
  if DirSeparator <> '/' then
    begin
      tmp := s;
      while (tmp^ <> #0) do
        begin
          if tmp^ = '/' then tmp^ := DirSeparator;
          {$X+} Inc (tmp) {$X-}
        end
    end;
  Slash2OSDirSeparator_CString := s
end;

function OSDirSeparator2Slash_CString (s : CString) : CString;
var tmp : CString;
begin
  if DirSeparator <> '/' then
    begin
      tmp := s;
      while (tmp^ <> #0) do
        begin
          if tmp^ = DirSeparator then tmp^ := '/';
          {$X+} Inc (tmp) {$X-}
        end
    end;
  OSDirSeparator2Slash_CString := s
end;

function AddDirSeparator (const s : String) = Result : TString;
begin
  Result := s;
  if (Result <> '') and not (Result [Length (Result)] in DirSeparators)
    and DirectoryExists (Result)
    {$ifdef __OS_DOS__}
    and ((Length (Result) <> 2) or (Result [2] <> ':'))
    {$endif}
    then Result := Result + DirSeparator
end;

function RemoveDirSeparator (const s : String) = Result : TString;
begin
  Result := s;
  while (Result <> '') and (Result [Length (Result)] in ['/', DirSeparator])
    {$ifdef __OS_DOS__}
    and ((Length (Result) <> 3) or (Result [2] <> ':'))
    {$endif}
    do Delete (Result, Length (Result), 1)
end;

function GetCurrentDirectory : TString;
var Buf : TStringBuf;
begin
  GetCurrentDirectory := Slash2OSDirSeparator (CString2String (GetCWD (Buf, High (Buf))))
end;

function GetTempDirectory : TString;
var TempDirectory : static TString = '';

  function CheckDir (const s : String) : Boolean;
  var
    b : BindingType;
    f : Text;
  begin
    TempDirectory := Slash2OSDirSeparator (s);
    if TempDirectory = '' then return False;
    if TempDirectory [Length (TempDirectory)] <> DirSeparator then
      TempDirectory := TempDirectory + DirSeparator;
    Assign (f, TempDirectory);
    b := Binding (f);
    Unbind (f);
    CheckDir := b.Bound and b.Directory and b.Readable and b.Writable and b.Executable
  end;

begin
  if not (
           CheckDir (TempDirectory) or
           CheckDir (GetEnv ('TEMP')) or
           CheckDir (GetEnv ('TMP')) or
           CheckDir (GetEnv ('TEMPDIR')) or
           CheckDir (GetEnv ('TMPDIR')) or
           {$ifdef __OS_DOS__}
           CheckDir ('c:\temp\') or
           CheckDir ('c:\tmp\') or
           CheckDir ('\temp\') or
           CheckDir ('\tmp\') or
           {$else}
           CheckDir ('/var/tmp/') or
           CheckDir ('/tmp/') or
           CheckDir (GetEnv ('HOME')) or
           {$endif}
           CheckDir ('./')
         ) then TempDirectory := '';
  GetTempDirectory := TempDirectory
end;

function GetTempFileName = Result : TString;
var
  TempStr : static TString = '';
  TempDirectory : TString;
  i : Integer;
begin
  TempDirectory := GetTempDirectory;
  if TempDirectory = '' then RuntimeError (390); { no temporary file name found }
  if TempStr = '' then
    begin
      WriteStr (TempStr, 'GP9a', GetPID mod 100000 + 100000);
      TempStr [5] := 'a'
    end;
  repeat
    i := 3;
    while (i <= Length (TempStr)) and (TempStr [i] = 'z') do
      begin
        TempStr [i] := '0';
        Inc (i)
      end;
    if TempStr [i] = '9' then TempStr [i] := 'a' else Inc (TempStr [i]);
    Result := TempDirectory + TempStr
  until not FileExists (Result)
end;

function GetTempFileName_CString : CString;
begin
  GetTempFileName_CString := NewCString (GetTempFileName)
end;

function FileName (var f : AnyFile) : TString;
begin
  FileName := CString2String (FileName_CString (f))
end;

function FileExists (const FileName : String) : Boolean;
var
  b : BindingType;
  f : Text;
begin
  if FileName = '' then return False;
  Assign (f, FileName);
  b := Binding (f);
  Unbind (f);
  FileExists := b.Bound and b.Existing
end;

function DirectoryExists (const FileName : String) : Boolean;
var
  b : BindingType;
  f : Text;
begin
  if FileName = '' then return False;
  Assign (f, FileName);
  b := Binding (f);
  Unbind (f);
  DirectoryExists := b.Bound and b.Directory
end;

function InternalFSearch (const FileName, DirList : String; ExecutableFlag : Boolean) = Res : TString;
var p0, p1 : Integer;

  function Exists : Boolean;
  var
    b : BindingType;
    f : Text;
  begin
    Assign (f, Res);
    b := Binding (f);
    Unbind (f);
    Exists := b.Bound and b.Existing and (not ExecutableFlag or b.Executable)
  end;

begin
  if CharPos (DirSeparators, FileName) <> 0
    then
      begin
        Res := Slash2OSDirSeparator (FileName);
        if Exists then Exit
      end
    else
      begin
        p0 := 1;
        while p0 <= Length (DirList) do
          begin
            p1 := p0;
            while (p1 <= Length (DirList)) and (DirList [p1] <> PathSeparator) do Inc (p1);
            if p0 = p1
              then Res := DirSelf + DirSeparator + FileName
              else Res := Slash2OSDirSeparator (DirList [p0 .. p1 - 1] + DirSeparator + FileName);
            if Exists then Exit;
            p0 := p1 + 1
          end
      end;
  Res := ''
end;

function FSearch (const FileName, DirList : String) : TString;
begin
  FSearch := InternalFSearch (FileName, DirList, False)
end;

function FSearchExecutable (const FileName, DirList : String) = Result : TString;
begin
  Result := InternalFSearch (FileName, DirList, True);
  {$ifdef __OS_DOS__}
  if Result = '' then Result := InternalFSearch (FileName + '.com', DirList, True);
  if Result = '' then Result := InternalFSearch (FileName + '.exe', DirList, True);
  if Result = '' then Result := InternalFSearch (FileName + '.bat', DirList, True);
  {$endif}
end;

function ExpandEnvironment (var s : String) : Boolean;
var
  p, q : Integer;
  EnvName : TString;
  Env : CString;
begin
  p := 0;
  repeat
    repeat
      Inc (p);
      if p > Length (s) then return True
    until s [p] in ['~', '$'];
    q := p + 1;
    if s [p] = '~'
      then EnvName := 'HOME'
      else
        begin
          while (q <= Length (s)) and (s [q] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) do Inc (q);
          EnvName := Copy (s, p + 1, q - p - 1)
        end;
    Delete (s, p, q - p);
    Env := CGetEnv (EnvName);
    if Env = nil then
      begin
        s := EnvName;
        return False
      end;
    Insert (CString2String (Env), s, p)
  until False
end;

function FExpand (const Path : String) = Result : TString;
var
  Buf : TStringBuf;
  Dir, Name, Ext : TString;
begin
  FSplit (Path, Dir, Name, Ext);
  if OSDosFlag and (Ext = ExtSeparator) then Ext := '';
  Name := Name + Ext;
  if (Name = DirSelf) or (Name = DirParent) then
    begin
      Dir := Dir + Name;
      Name := ''
    end;
  Result := AddDirSeparator (Slash2OSDirSeparator (CString2String (RealPath (OSDirSeparator2Slash (Dir), Buf))));
  if DirectoryExists (Result)
    then Result := Result + Name
    else Result := ''
end;

function RelativePath (const Path : String; OnlyCurDir : Boolean) = Result : TString;
var p : TString;
begin
  Result := FExpand (Path);
  p := AddDirSeparator (FExpand (DirSelf));
  if (Length (Result) >= Length (p)) (*@@fjf226*)(*and*)then if
    (Copy (Result, 1, Length (p)) = p) and
    (not OnlyCurDir or (LastCharPos (DirSeparators, Result) <= Length (p)))
    then Delete (Result, 1, Length (p))
end;

(*@@maur3.pas inline*) function isUNC (const s : String) : Boolean;
begin
  IsUNC := {$ifdef __OS_DOS__}
           (Length (s) > 3) and
           (s [1] in [DirSeparator, '/']) and
           (s [2] in [DirSeparator, '/'])
           {$else} False
           {$endif}
end;

procedure FSplit (const Path : String; var Dir, Name, Ext : String);
var
  d, e : Integer;
  t : TString;
begin
  d := Length (Path);
  while (d > 0) and not (Path [d] in DirSeparators) do Dec (d);
  if isUNC (Path) and (d in [1, 2]) then d := Length (Path);
  t := Copy (Path, d + 1, Length (Path) - d);
  e := LastPos (ExtSeparator, t);
  if (e = 0) or (t = DirSelf) or (t = DirParent)
    then e := Length (Path) + 1
    else Inc (e, d);
  Dir  := Slash2OSDirSeparator (Copy (Path, 1, d));
  Name := Slash2OSDirSeparator (Copy (Path, d + 1, e - d - 1));
  Ext  := Slash2OSDirSeparator (Copy (Path, e, Length (Path) - e + 1))
end;

function DirFromPath (const Path : String) = Dir : TString;
var Name, Ext : TString;
begin
  FSplit (Path, Dir, Name, Ext)
end;

function NameFromPath (const Path : String) = Name : TString;
var Dir, Ext : TString;
begin
  FSplit (Path, Dir, Name, Ext)
end;

function ExtFromPath (const Path : String) = Ext : TString;
var Dir, Name : TString;
begin
  FSplit (Path, Dir, Name, Ext)
end;

function ReadDir (Dir : DirPtr) : TString;
begin
  ReadDir := CString2String (ReadDir_C (Dir))
end;

{ This routine is just a quick replacement for systems that don't have
  fnmatch() in libc. Especially, the handling of `*' is very inelegant. }
function FNMatch2 (const Pattern, Name : String) : Boolean;
var
  zp, zn, z2 : Integer;
  ch : Char;
  (*@@ s : set of Char;*)s:array[char] of boolean;
  Negate : Boolean;
  Pattern2 : TString;
begin
  FNMatch2 := False;
  zn := 1;
  zp := 1;
  while zp <= Length (Pattern) do
    begin
      ch := Pattern [zp];
      Inc (zp);
      if ch = '*' then
        begin
          while (zp <= Length (Pattern)) and (Pattern [zp] = '*') do Inc (zp);
          Pattern2 := Copy (Pattern, zp, Length (Pattern) - zp + 1);
          for z2 := Length (Name) + 1 downto zn do
            if FNMatch2 (Pattern2, Copy (Name, z2, Length (Name) - z2 + 1)) then
              begin
                FNMatch2 := True;
                Exit
              end;
          Exit
        end;
      if zn > Length (Name) then Exit;
      if ch = '['
        then
          begin
            Negate := (zp <= Length (Pattern)) and (Pattern [zp] = '^');
            if Negate then Inc (zp);
            (*s := [];*)for ch:=low(ch) to high(ch)do s[ch]:=false;
            while (zp <= Length (Pattern)) and (Pattern [zp] <> ']') do
              begin
                ch := Pattern [zp];
                Inc (zp);
                if Pattern [zp] = '-'
                  then
                    begin
(*@@fjf262                      s := s + [ch .. Pattern [zp + 1]]; *)
while ch<=pattern[zp+1] do begin s[ch]:=true;inc(ch)end;
                      Inc (zp, 2)
                    end
                  else (*s := s + [ch]*)s[ch]:=true
              end;
            Inc (zp);
            if not (*(Name [zn] in s)*)s[name[zn]] xor Negate then Exit
          end
        else
          if (Name [zn] <> ch) and (ch <> '?') then Exit;
      Inc (zn)
    end;
  FNMatch2 := zn > Length (Name)
end;

function FileNameMatch (const Pattern, Name : String) : Boolean;
begin
  if HaveFNMatch <> 0
    then FileNameMatch := FNMatch  (Pattern, Name) = 0
    else FileNameMatch := FNMatch2 (Pattern, Name)
end;

function ConfigFileName (Name : String; Global : Boolean) : TString;
var Dir, PName, Ext : TString;
begin
  {$ifdef __OS_DOS__}
  FSplit (ParamStr (0), Dir, PName, Ext);
  if Name <> '' then PName := Name;
  ConfigFileName := Dir + PName + '.cfg'
  {$else}
  if Name <> ''
    then PName := Name
    else FSplit (ParamStr (0), Dir, PName, Ext);
  if Global
    then ConfigFileName := DirSeparator + 'etc' + DirSeparator + PName + 'rc'
    else ConfigFileName := GetEnv ('HOME') + DirSeparator + '.' + PName + 'rc'
  {$endif}
end;

end.
