libtexttools3-dev 2.0.7-2 / usr / share / ada / adainclude / texttools / os.adb

------------------------------------------------------------------------------
-- OS (package body)                                                        --
--                                                                          --
-- Part of TextTools                                                        --
-- Designed and Programmed by Ken O. Burtch                                 --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 1999-2007 Ken O. Burtch                    --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca/tt.html                     --
--                                                                          --
------------------------------------------------------------------------------
-- C error numbers in /usr/include/asm/errno.h for linux.
--
-- much of this should probably be rewritten now that I know more about
-- kernel programming -- KB

with Text_IO; use Text_IO;  -- for debugging
with Ada.Strings;
with Strings; use Strings;
with Interfaces.C;
with Gen_List;

package body os is

LockPath : constant string := "/home/ken/";
SessionLogPath : APathName;

ttyname : str255;
IsLocaltty : boolean;  -- true if not client/server

---> C Interface
--
-- These are all from C_code/system.c.

procedure CTime;
pragma Import( C, CTime, "CTime" );

procedure CDate;
pragma Import( C, CDate, "CDate" );

procedure CLongDate;
pragma Import( C, CLongDate, "CLongDate" );

function CUNIX return integer;
pragma Import( C, CUNIX, "CUNIX" );

function CGetUNIX( temppath : string ) return integer;
pragma Import( C, CGetUNIX, "CGetUNIX" );

--Obsolete
--procedure GetTempName;
--pragma Import( C, GetTempName, "GetTempName" );

function CNotEmpty return integer;
pragma Import( C, CNotEmpty, "CNotEmpty" ); -- 0 = file not empty

function LockIt return integer;
pragma Import( C, LockIt, "LockIt" );

procedure UnlockIt;
pragma Import( C, UnlockIt, "UnlockIt" );

function CSetPath return integer;
pragma Import( C, CSetPath, "CSetPath" );

--  procedure CSync;
--  pragma Import( C, CSync, "CSync" );

procedure CAppend( s : string );
pragma Import( C, CAppend, "CAppend" );

function CUnlink( s : string ) return integer;
pragma Import( C, CUnlink, "CUnlink" );

procedure CClearSessionLog;
pragma Import( C, CClearSessionLog, "CClearSessionLog" );

procedure CAddSessionLog;
pragma Import( C, CAddSessionLog, "CAddSessionLog" );

procedure CUSleep( usec : long_integer );
pragma Import( C, CUSleep, "CUSleep" );

function CIsDirectory( s : string ) return integer;
pragma Import( C, CIsDirectory, "CIsDirectory" );

function CFileExists( s : string ) return boolean;
pragma Import( C, CFileExists, "CFileExists" );

function CRunIt( cmd, outfile, parm1, parm2, parm3 : string ) return integer;
pragma Import( C, CRunIt, "CRunIt" );


---> Linux Kernel Functions
--
-- Use "man <function>" to get more info.
--
-- Since Linux kernel functions use a lot of C strings (and pointers
-- to C strings), I've defined some C strings here for use with
-- the "Linux_" subprograms.  To convert to and from C strings, use
-- To_C(), To_Ada(), and To255().

type ACPath is new Interfaces.C.char_array( 1..1024 );
type CPathPtr is access all ACPath;

-- A C string, pointer to same, and a another pointer.

TempCPath     : aliased  ACPath;
TempCPathPtr  : constant CPathPtr := TempCPath'access;
TempCPtr      : CPathPtr;

-- Linux_GetCWD -- returns the current working directory

function Linux_GetCWD( buf : CPathPtr; size : long_integer )
  return CPathPtr;
pragma Import(C , Linux_GetCWD, "getcwd" ); -- from unistd.h

-- Linux_ChDir -- changes the current working directory

--  function Linux_ChDir( buf : CPathPtr ) return integer;
--  pragma Import(C, Linux_ChDir, "chdir" ); -- from unistd.h

-- Linux_GetEnv - get an environment variable's value

function Linux_GetEnv( env_var :  CPathPtr ) return CPathPtr;
pragma Import( C, Linux_GetEnv, "getenv" ); -- from stdlib.h

-- Linux_SetEnv - set an environment variable's value

--  procedure Linux_SetEnv( env_var : CPathPtr; var_val : CPathPtr;
--    overwrite : integer );
--  pragma Import( C, Linux_SetEnv, "setenv" ); -- from stdlib.h

-- Linux_ErrNo -- error returned from last Linux operation

--  Linux_ErrNo : integer;
--  pragma Import( C, Linux_ErrNo, "errno" ); -- from errno.h
-- pragma volatile (errno);
-- Actually it is a thread-safe function call-macro.
-- Hope we won't need it from Ada or write a C wrapper.

--->
--
-- Lintel Pathnames
--
-- The pathnames are kept in a list of strings
-- was PathList : array( APathNumber ) of APathName := (others => NullStr255);

-- This should probably be a controlled object so it can be deleted
-- automatically.

type APathListRecord is record
   alias : str255;
   path  : APathName;
end record;

function ">=" (left, right : APathListRecord ) return boolean is
begin
  return left.alias >= right.alias;
end ">=";

package PathList is new Gen_List( APathListRecord, ">=" );

Paths : PathList.List;

--- Interface_String -- null-terminated "system" command string

Interface_String : array(0..255) of character;
pragma Import( C, Interface_String, "Interface_String" );

-- SessionLogName

SessionLogName : array(0..80) of character;
pragma Import( C, SessionLogName, "SessionLogName" );

procedure SetInterface( s : str255 ) is
begin
  if length( s ) < Interface_String'last then
     for i in 1..length(s) loop
         Interface_String(i-1) := Element( s, (i) );
     end loop;
     Interface_String( length( s ) ) := character'val(0);
  end if;
end SetInterface;

-- ESCAPE PATH: shell escape a path so it can be used in a shell function
--
-- Quick and dirty...

function EscapePath( old_path : str255 ) return str255 is
  new_path : str255;
  ch : character;
begin
  new_path := new_path & ''';
  for i in 1..length( old_path ) loop
      ch := element( old_path, i );
      if ch = ''' then
         new_path := new_path & '\';
      end if;
      new_path := new_path & ch;
  end loop;
  new_path := new_path & ''';
  return new_path;
end EscapePath;


---> Housekeeping

procedure StartupOS is
  WasRaising : boolean;

  procedure InitializeSessionLog is
  begin
    if length( SessionLogPath ) < SessionLogName'last then
       for i in 1..length( SessionLogPath ) loop
           SessionLogName(i-1) := Element( SessionLogPath, (i) );
       end loop;
       Interface_String( length( SessionLogPath ) ) := character'val(0);
    end if;
    CClearSessionLog;
    SessionLog( "StartupOS: New " & ProgramName & " session log started" );
    SessionLog( "StartupOS: " & GetLongDate & " @ " & GetTime );
    if LastError /= TT_OK then
       Put_Line( "StartupOS: Unable to write to session_log; error " &
          AnErrorCode'image( LastError ) );
       return; -- no log to write to (yet)
    end if;
  end InitializeSessionLog;

  procedure CheckOSServices is
  begin
    null;
    --MakeTempFilename( TempFile );
    --UNIX( ToString( "zoo a " & TempFile & " /etc/passwd > /dev/null" ) );
    --if LastError /= CoreOK then -- wierdness when I used if UNIX(zoo)...
    --   SessionLog( "StartupOS: Unable to find zoo command", LastError );
    --end if;
    --Erase( TempFile & ".zoo" );
  end CheckOSServices;

begin
  NoError;
  WasRaising := TrapErrors;
  TempCPath(1) := 'T';
  TempCPath(2) := 'M';
  TempCPath(3) := 'P';
  TempCPath(4) := 'D';
  TempCPath(5) := 'I';
  TempCPath(6) := 'R';
  TempCPath(7) := Interfaces.C.char( ASCII.NUL );
  TempCPtr := Linux_GetEnv( TempCPathPtr );
  if TempCPtr /= null then
     PathAlias( To255( "tmp" ), To255( To_Ada( TempCPtr.all )));
  else
     PathAlias( To255( "tmp" ), To255( "/tmp" ) );
  end if;

  -- Lookup HOME environment variable and make it an alias
  -- (Had problems with To_C, so made the C string manually
  TempCPath(1) := 'H';
  TempCPath(2) := 'O';
  TempCPath(3) := 'M';
  TempCPath(4) := 'E';
  TempCPath(5) := Interfaces.C.char( ASCII.NUL );
  TempCPtr := Linux_GetEnv( TempCPathPtr );
  if TempCPtr /= null then
     PathAlias( To255( "home" ), To255( To_Ada( TempCPtr.all )));
  end if;

  -- Make the $SYS alias by adding ShortProgramName to $HOME
  if TempCPtr = null then
     SessionLogPath := NullStr255;
  else
     PathAlias( To255( "sys" ), To_Ada( TempCPtr.all ) & "/" &
        ShortProgramName );
     SessionLogPath := ExpandPath( To255( "$SYS/session_log" ) );
  end if;

  InitializeSessionLog;
  if LastError = TT_OK then
     ttyname := UNIX( "tty" );
     IsLocaltty := (ttyname >= To255( "/dev/tty1" ) and
         ttyname <= To255( "/dev/tty9" )) and length( ttyname ) = 9;
     if LastError = TT_OK then
        CheckOSServices;
     end if;
     if LastError /= TT_OK then
        LastError := TT_OSService;
        null; --Put_Line( Standard_Error, "StartupOS: See session log for error details" );
     end if;
  end if;

  RestoreRaising( WasRaising );
  -- load system parameters
  -- load user defaults
end StartupOS;

procedure IdleOS( IdlePeriod : ATimeStamp ) is
   pragma Unreferenced (Idleperiod);
begin
  NoError;
  --UNIX( "sync" ); -- should call sync() by C
  --should really check and remove an old file from the .Trash
  --directory, once per call
end IdleOS;

procedure ShutdownOS is
begin
  NoError;
  SessionLog( "ShutdownOS: End of session log" );
  PathList.Clear( Paths );
end ShutdownOS;


---> OS Interfacing

function UNIX( s : str255 ) return boolean is
  res : integer;
begin
  NoError;
  SetInterface( s );
  res := CUNIX;
  if CUNIX /= 0 then -- DEBUG
     SessionLog( "CUNIX " & s & " returned error code" & res'img );
  end if;
  return res = 0;
end UNIX;

procedure UNIX( s : str255 ) is
begin
   NoError;
   SetInterface( s );
   if CUNIX /= 0 then
      Error( TT_SystemError );
   end if;
end UNIX;

function UNIX( s : str255 ) return str255 is
  Output       : str255;
  i            : Natural;
  temppath     : str255;
  res          : integer;
begin
  MakeTempFileName( temppath );
  Output := NullStr255;
  if length( s ) <= Interface_String'last - 50 then
     SetInterface( s );
     declare
       TempPath2 : string := toString(TempPath ) & ASCII.NUL;
     begin

     res := CGetUNIX( TempPath2 );
     if res /= 0 then
	SessionLog( "CGetUNIX " & toString(s) & " returned error code" & res'img );
        Error( TT_SystemError );
     else
        NoError;
        i := 0;
        while Interface_String(i) /= character'val(10) and then
              Interface_String(i) /= character'val(0) loop -- line feed
           Output := Append( Output, Interface_String(i) );
           i := i + 1;
        end loop;
     end if;
     end;
  else
     Error( TT_ParamError );
  end if;
  return Output;
end UNIX;

function UNIX( s : string ) return boolean is
begin
  return UNIX( To255( s ) );
end UNIX;

procedure UNIX( s : string ) is
begin
  UNIX( To255( s ) );
end UNIX;

function UNIX( s : string ) return str255 is
begin
  return UNIX( To255( s ) );
end UNIX;

procedure RunIt( cmd : string;
                 parm1, parm2, parm3 : string := "";
                 Results : in out Str255List.List ) is
  Status : integer;
  TempFile : Str255;
begin
  NoError;
  MakeTempFileName( TempFile );
  Str255List.Clear( Results );
  Status := CRunIt( cmd & ASCII.NUL,
                    ToString( TempFile ) & ASCII.NUL,
                    parm1 & ASCII.NUL,
                    parm2 & ASCII.NUL,
                    parm3 & ASCII.NUL );
  if IsFile( TempFile ) then
     LoadList( TempFile, Results );
     Erase( TempFile );
  end if;
  if Status = 0 then
     Error( TT_OK );
  else
     Error( TT_SystemError );
  end if;
end RunIt;

function NotEmpty( s : in Str255 ) return boolean is
begin
  NoError;
  SetInterface( ExpandPath( s ) );
  return CNotEmpty = 0;
end NotEmpty;

function IsDirectory( s : APathName ) return boolean is
-- should return error if file doesn't exist
  TempStr : str255;
begin
  NoError;
  TempStr := ExpandPath( s );
  return CIsDirectory( ToString( TempStr ) & ASCII.NUL ) /= 0;
end IsDirectory;

function IsFile( s : APathName ) return boolean is
  TempStr : str255;
begin
  NoError;
  TempStr := ExpandPath( s );
  return CFileExists( ToString( TempStr ) & ASCII.NUL );
end IsFile;

procedure MakeTempFileName (S : out Str255) is
   use Interfaces.C;
   procedure CMksTemp (Result   :    out Int;
                       Template : in out Char_Array);
   pragma Import (C, CMksTemp, "mkstemp" );
   pragma Import_Valued_Procedure (Cmkstemp);
   Template : Char_Array
     := To_C (ToString (ExpandPath (To255 ("$TMP/texttoolsXXXXXX"))));
   Result : Int;
begin
   Cmkstemp (Result, Template);
   pragma Assert (Result /= -1);
   S := To255 (To_Ada (Template));
end MakeTempFileName;

function Lock( file : APathName ) return boolean is
  lockname : str255;
begin
  lockname := Append( LockPath, ExpandPath( file ) );
  SetInterface( lockname );
  return LockIt = 0;
end Lock;

procedure Unlock( file : APathName ) is
  lockname : str255;
begin
  lockname := Append( LockPath, ExpandPath( file ) );
  SetInterface( lockname );
  UnlockIt;
end Unlock;

procedure ValidateFilename( fs : AFileSystem; oldfn : APathname;
  newfn : in out APathname; errmsg : in out str255 ) is

  ValidFilename : str255;
  changed : boolean;

  procedure ValidateUNIX is -- hastily assembled
    ch : character;
    s  : string(1..1);
  begin
    -- length OK
    -- leading character: no special requirements
    for i in 1..length( oldfn ) loop
        ch := Element( oldfn, i );
        if ch < ' ' then -- control character?
           ch := '_';
           Changed := true;
        elsif ch > '~' then -- control character?
           ch := '_';
           Changed := true;
        --elsif ch <= 'A' then -- special character?
        --    ch := '_';
        --    Changed := true;
        --elsif ch = '~' then
        --    ch := '-';
        --    Changed := true;
        end if;
        s(1) := ch;
        ValidFilename := ValidFilename & s;
    end loop;
    if Changed then
       newfn := ValidFilename;
       ErrMsg := To255( "bad characters for UNIX filesystem" );
    end if;
  end ValidateUNIX;

  procedure ValidateUNIX14 is
  begin
    if length( oldfn ) > 14 then
       newfn := Head( oldfn, 14 );
       Changed := true;
       ErrMsg := To255( "too many characters for old UNIX filesystem" );
    else
       ValidateUNIX;
    end if;
  end ValidateUNIX14;

  procedure ValidateDOS is
    ch : character;
    s  : string(1..1);
  begin
    -- length checks no longer applicable with vfat
    --if length(oldfn)>8 and then Element( oldfn,9 ) /= '.' then
    --   NewFn := OldFn;
    --   Insert( NewFn, 9, "." );
    --   ErrMsg := To255( "too many characters for DOS" );
    --elsif length( oldfn ) > 12 then
    --   newfn := Head( oldfn, 12 );
    --   Changed := true;
    --   ErrMsg := To255( "too many characters for DOS" );
    --else
       for i in 1..length(oldfn) loop
           ch := Element( oldfn, i );
           if ch <= ' ' then
              ch := '_';
              Changed := true;
           end if;
           s(1) := ch;
           ValidFilename := ValidFilename & s;
       end loop;
       if Changed then
          NewFn := ValidFilename;
          ErrMsg := To255( "bad characters for DOS" );
       end if;
    --end if;
  end ValidateDOS;

  procedure ValidateOS2 is
  begin
    ValidateUNIX; -- at least, for now
  end ValidateOS2;

begin
  ValidFilename := NullStr255;
  ErrMsg := NullStr255;
  Changed := false;
  if length( oldfn ) = 0 then
     Newfn := To255( "untitled" );
     ErrMsg := To255( "No filename" );
  else
     case fs is
     when UNIXFS => ValidateUNIX;
     when UNIX14FS => ValidateUNIX14;
     when DOSFS => ValidateDOS;
     when OS2FS => ValidateOS2;
     when NONE => null;
     end case;
  end if;
end ValidateFilename;

procedure ValidatePathname( fs : AFileSystem; oldfn : APathname;
  newfn : in out APathname; errmsg : in out str255 ) is
  SepChar : character;
  SepCharAsString : string( 1..1 );
  SepPos1 : integer;
  SepPos2 : integer;
  CorrectedFile : str255;
  Piece2Validate : str255;
  thefs : AFileSystem;
  LastErrMsg : str255;
begin
  newfn := NullStr255;
  LastErrMsg := NullStr255;
  ErrMsg := NullStr255;
  case fs is
  when UNIXFS =>   SepChar := '/';
                   thefs := UnixFS;
  when UNIX14FS => SepChar := '/';
                   thefs := Unix14FS;
  when DOSFS =>    SepChar := '\';
                   thefs := DosFS;
  when OS2FS =>    SepChar := ':'; -- Is this right for OS/2?
                   thefs := OS2FS;
  when NONE => -- guess at separator
      if Index( oldfn, "/" ) > 0 then
         SepChar := '/';
         thefs := UnixFS;
      elsif Index( oldfn, "\" ) > 0 then
         SepChar := '\';
         thefs := DosFS;
      elsif Index( oldfn, ":" ) > 0 then
         SepChar := ':';
         thefs := OS2FS;
      else
         SepChar := '/'; -- guess UNIX by default
         thefs := UnixFS;
      end if;
  end case;
  SepCharAsString(1) := SepChar;
  SepPos1 := Index( oldfn, SepCharAsString );
  if SepPos1 = 0 then
     ValidateFilename( fs, oldfn, newfn, Errmsg );
  else
    loop
      SepPos2 := length( oldfn );
      for i in SepPos1+1..length( oldfn ) loop
          if Element( oldfn, i ) = SepChar then
             SepPos2 := i;
             exit;
          end if;
      end loop;
      Piece2Validate := To255( Slice( oldfn, SepPos1+1, SepPos2-1 ) );
      ValidateFilename( thefs, Piece2Validate, CorrectedFile, Lasterrmsg );
      if length( CorrectedFile ) /= 0 then
         newfn := newfn & SepChar & CorrectedFile;
         if length( LastErrMsg ) > 0 then
            ErrMsg := LastErrMsg;
         end if;
      else
         newfn := newfn & SepChar & Piece2Validate;
      end if;
      exit when SepPos2 = length( oldfn );
      SepPos1 := SepPos2;
    end loop;
    if length( ErrMsg ) = 0 then -- no errors? no changes
       newfn := NullStr255;
    end if;
  end if;
end ValidatePathname;

procedure Erase( file : APathName ) is
  CErr : integer;
begin
  NoError;
  CErr := CUnlink( ToString( ExpandPath( file ) ) & ASCII.NUL );
  if CErr /= 0 then
     SessionLog( "Erase: C error " & integer'image( CErr ) );
     case CErr is
     when 1      => Error( TT_FileAccess );    -- EPERM
     when 2      => Error( TT_FileExistance ); -- ENOENT
     when 13     => Error( TT_FileAccess );    -- EACCESS
     when 20     => Error( TT_PathExistance ); -- ENOTDIR
     when 30     => Error( TT_VolAccess );     -- EROFS
     when others => Error( TT_SystemError );   -- EFAULT, etc.
     end case;
  end if;
end Erase;

procedure Trash( file : APathName ) is
-- remove a file to the trash can, erasing if necessary
  trashstr : str255;
  WasRaising : boolean;
begin
  --NoError called in UNIX
  WasRaising := RaisingErrors;
  trashstr := To255( "mv " );
  trashstr := Append( trashstr, ToString( ExpandPath( file ) ) );
  trashstr := Append( trashstr, " $HOME/.Trash 2> /dev/null" );
  TrapErrors;
  UNIX( trashstr );
  if WasRaising then
     RaiseErrors;
  end if;
  if LastError /= TT_OK then
     Erase( file );
  end if;
end Trash;

procedure EmptyTrash is
begin
  --NoError called in UNIX
  UNIX( "find $HOME/.Trash -type f -mtime +3 -exec rm {} \;" );
end EmptyTrash;

procedure Move( file1, file2 : APathName ) is
  movestr : str255;
begin
  --NoError called in UNIX
  movestr := To255( "mv " );
  movestr := Append( movestr, ToString( ExpandPath( file1 ) ) );
  movestr := Append( movestr, " " );
  movestr := Append( movestr, ToString( ExpandPath( file2 ) ) );
  movestr := Append( movestr, " 2> /dev/null" );
  UNIX( movestr );
end Move;

function Shrink( file : APathName ) return APathName is
  shrinkstr : str255;
begin
  --NoError called in UNIX
  --shrinkstr := To255( "zoo aPq " );
  shrinkstr := To255( "gzip " );
  shrinkstr := Append( shrinkstr, ToString( ExpandPath( file ) ) );
  shrinkstr := Append( shrinkstr, " " );
  shrinkstr := Append( shrinkstr, ToString( ExpandPath( file ) ) );
  UNIX( shrinkstr );
  if LastError = 0 then
     shrinkstr := file;
     shrinkstr := Append( shrinkstr, ".bak" );
     Erase( shrinkstr );
  end if;
  if LastError = 0 then
     --return Append( file, ".zoo" );
     return Append( file, ".gz" );
  else
     return NullStr255;
  end if;
end Shrink;

function Expand( file : APathName ) return APathName is
  expandstr : str255;
begin
  --NoError called in UNIX
  --expandstr := To255( "zoo x//qO " );
  expandstr := To255( "gunzip " );
  expandstr := Append( expandstr, ToString( ExpandPath( file ) ) );
  UNIX( expandstr );
  if LastError = 0 then
     return Head( file, length( file ) - 3 );
  else
     return NullStr255;
  end if;
end Expand;

procedure Archive( arch, file : APathName ) is
  ArchPath, FilePath, Cmd : str255;
  -- note possibility of overflow here!
begin
  --NoError called in UNIX
  ArchPath := ExpandPath( arch );
  FilePath := ExpandPath( file );
  if not NotEmpty( FilePath ) then -- should really be not exists
     Error( TT_FileExistance );
     return;
  end if;
  --Cmd := To255( "zoo aunqP " ) & ArchPath & To255(" " ) & FilePath;
  Cmd := To255( "tar cfz " ) & ArchPath & To255(" " ) & FilePath;
  UNIX( Cmd );
end Archive;

procedure Extract( arch, file : APathName ) is
  ArchPath, FilePath, Cmd : str255;
begin
  -- NoError called in UNIX
  ArchPath := ExpandPath( arch );
  FilePath := ExpandPath( file );
  if not NotEmpty( ArchPath ) then -- should really be not exists
     Error( TT_FileExistance );
     return;
  end if;
  --Cmd := ( To255( "zoo xqO ") & ArchPath & To255(" ") ) & ( FilePath
  --    & " > /dev/null" );
  Cmd := ( To255( "tar xfz ") & ArchPath & To255(" ") ) & ( FilePath
      & " > /dev/null" );
  UNIX( Cmd );
end Extract;

procedure Armour( file : APathName; keyfile : APathName := NullStr255 ) is
begin
  null;
end Armour;

procedure Disarmour( file : APathName; keyfile : APathName := NullStr255 ) is
begin
  null;
end Disarmour;

procedure Usage( file : APathName; me : AFileUsage := Normal;
                                   us : AFileUsage := ReadOnly;
                             everyone : AFileUsage := ReadOnly ) is
  accessstr : str255;
  AccessCodeMe : character;
  AccessCodeUs : character;
  AccessCodeEveryone : character;
  tempstr   : APathName;
begin
  --NoError called in UNIX
  if me = ReadOnly or me = None then
     AccessCodeMe := '4';
  elsif me = Normal then
     AccessCodeMe := '6';
  elsif me = Run then
     AccessCodeMe := '7';
  else
     AccessCodeMe := '0';
  end if;
  if us = ReadOnly then
     AccessCodeUs := '4';
  elsif us = Normal then
     AccessCodeUs := '6';
  elsif us = Run then
     AccessCodeUs := '7';
  else
     AccessCodeUs := '0';
  end if;
  if everyone = ReadOnly then
     AccessCodeEveryone := '4';
  elsif everyone = Normal then
     AccessCodeEveryone := '6';
  elsif everyone = Run then
     AccessCodeEveryone := '7';
  else
     AccessCodeEveryone := '0';
  end if;
  accessstr := To255( "chmod " );
  accessstr := accessstr & AccessCodeMe & AccessCodeUs & AccessCodeEveryone;
  TempStr := " " & ExpandPath( file );
  accessstr := Append( accessstr, ToString( tempStr ), Ada.Strings.Right );
  UNIX( accessstr );
end Usage;

procedure BeginSession is
begin
  null;
end BeginSession;

procedure EndSession is
begin
  null; -- sync
end EndSession;


---> Directory Utilities

function SpaceUsed( dir : APathName ) return long_integer is
  expandstr : str255;
begin
  --NoError called in UNIX
  expandstr := To255( "du -fs " );
  expandStr := expandStr & ExpandPath( dir );
  return ToLongInteger( UNIX( expandStr ) );
end SpaceUsed;


---> Device Utilities

--  function SpaceFree( dev : APathName ) return long_integer is
--     pragma Unreferenced(Dev);
--  begin
--    return 1; -- NYI
--  end SpaceFree;

--  function TotalSpace( dev : APathName ) return long_integer is
--     pragma Unreferenced(Dev);
--  begin
--    return 1;
--  end TotalSpace;

--  function EntriesFree( dev : APathName ) return long_integer is
--     pragma Unreferenced(Dev);
--  begin
--    return 1;
--  end EntriesFree;

--  function TotalEntries( dev : APathname ) return long_integer is
--     pragma Unreferenced(Dev);
--  begin
--    return 1;
--  end TotalEntries;

--  function OnDevice( path : APathName ) return APathname is
--     pragma Unreferenced(Path);
--  begin
--    return NullStr255;
--  end OnDevice;


--->

function GetFreeClusterHost return str255 is
begin
  return UNIX( "uname -n" );
end GetFreeClusterHost;


---> Str255Lists

procedure LoadList( path : APathName; StrList : in out Str255List.List ) is
-- load a string list to a file
   Expandedpath : APathName;
   f : file_type;
   s : string(1..255);
   -- 254 & EOL (won't take 255!)  When I expanded it to 256,
   -- it wouldn't load anything
   l : natural;
begin
  ExpandedPath := ExpandPath( path );
  --  SessionLog( ToString( ExpandPath( path ) ) ); ---
  Open( f, in_file, ToString( ExpandedPath ) );
  while not End_of_File( f ) loop
        Get_Line( f, s, l );
        Str255List.Queue( StrList, Head( To255( s ), l ) );
  end loop;
  Close( f );
  exception -- translate Text_IO errors into core errors
    when Status_Error     => Error( TT_FileLocking );
    when Name_Error       => Error( TT_FileExistance );
    when Constraint_Error => raise; -- shouldn't happen, but...
    when Storage_Error    => Str255List.Clear( StrList );
                             Error( TT_LowMemory );
    when others           => Error( TT_IOError );
end LoadList;

procedure SaveList( path : APathName; StrList : in out Str255List.List ) is
-- save a string list to a file
   f : file_type;
   s : Str255;
   Lines : Str255List.AListIndex;
   TruePath : APathName;
begin
  TruePath := ExpandPath( Path );
  UNIX( "touch " & EscapePath( TruePath ) ); -- file must exist
  Open( f, out_file, ToString( TruePath ) );
  Lines := Str255List.length( StrList );
  for i in 1..Lines loop
      Str255List.Find( StrList, i, s );
      Put_Line( f, ToString( s ) );
  end loop;
  Close( f );
  exception -- translate Text_IO errors into core errors
    when Status_Error     => Error( TT_FileLocking );
    when Name_Error       => Error( TT_FileExistance );
    when Constraint_Error => raise; -- shouldn't happen, but...
    when others           => Error( TT_IOError );
end SaveList;

function IsLocal return boolean is
begin
  return IsLocaltty;
end IsLocal;

procedure SetPath( s : APathName ) is
begin
  NoError;
  SetInterface( ExpandPath( s ) );
  if CSetPath /= 0 then
     SessionLog( "SetPath: can't change path to " & s );
     Put_line( standard_error, "SetPath: TT_SystemError -- can't change path" );
     Error( TT_SystemError );
  end if;
end SetPath;

function GetPath return APathName is
   Dummy : CPathPtr;
   pragma Unreferenced (Dummy);
begin
  -- execute Linux getcwd (Get Current Working Directory) function
  Dummy := Linux_getcwd( TempCPathPtr, TempCPath'length );
  -- convert to a APathName and return result
  return To255( To_Ada( TempCPath ) );
end GetPath;

--procedure SetPath( pn : APathNumber; path : APathName ) is
--  temp : APathName;
--begin
--  temp := path;
--  if Element( temp, Length( temp ) ) = '/' then
--     Delete( temp, Length( temp ), Length( temp ) );
--  end if;
--  PathList( pn ) := temp;
--end SetPath;

procedure PathAlias( alias : str255; path : APathName ) is
  PathRec    : APathListRecord;
  Result     : PathList.AListIndex;
  IsNewAlias : boolean := true;
begin
  NoError;
  -- check to make sure that alias/path doesn't exist
  if not PathList.IsEmpty( Paths ) then
     -- locate first record with same alias (if any)
     PathRec.alias := ToUpper( alias );
     PathRec.path := NullStr255;
     Result := 0;
     for i in 1..PathList.length( Paths ) loop
        -- pull record and make sure it's a different path
        PathList.Find( Paths, i, PathRec );
        if PathRec.Alias = ToUpper( alias ) then
           IsNewAlias := false; -- alias exists
           Result := i;
           exit;
        elsif PathRec.Alias > alias then
           exit; -- missed it alphabetically, so it's new
        end if;
     end loop;
  end if;
  -- old entry? then delete it first
  if not IsNewAlias then
     PathList.Clear( Paths, Result );
  end if;
  -- add new entry (alphabetically) to path list
  PathRec.alias := ToUpper( alias );
  PathRec.path := path;
  PathList.Insert( Paths, PathRec );
end PathAlias;

function ExpandPath( path : in APathName ) return APathName is
-- check for leading number and convert to a path
  posn : integer;
  result : APathName;
  Alias  : APathName;
  PathRec : APathListRecord;
begin
  Result := path;
  if Length( Result ) > 0 then
     if Element( Result, 1 ) = '$' then
        posn := 1;
        while Element( Result, posn ) /= '/' loop
          posn := posn+1;
          exit when posn > Length( path );
        end loop;
        if posn > Length( path ) then
           Alias := Delete( ToUpper( path ), 1, 1 );
           Result := NullStr255;
        else
           Alias := ToUpper( To255( Slice( Result, 2, posn-1 ) ) );
           Delete( Result, 1, posn-1 );
        end if;
        for i in 1..PathList.length( Paths ) loop
            PathList.Find( Paths, i, PathRec );
            exit when PathRec.Alias > Alias;
            if PathRec.Alias = Alias then
               Result := PathRec.Path & Result;
            end if;
        end loop;
     end if;
  end if;
  return Result;
end ExpandPath;

procedure SplitPath( path : Str255;
   dir : out Str255; file : out Str255 ) is
-- split path into directory and file
   SlashPos : natural := 0;
begin
  for i in reverse 1..length( path ) loop
      if Element( path, i ) = '/' then
         SlashPos := i;
         exit;
      end if;
  end loop;
  if SlashPos > 0 then
     Dir := To255( Slice( path, 1, SlashPos ) );
     File := To255( Slice( path, SlashPos+1, length( path ) ) );
  else
     Dir := NullStr255;
     File := NullStr255;
  end if;
end SplitPath;

procedure DecomposePath( path : APathname; PathType : out APathType;
  Host : out Str255; Filepath : out APathname ) is
  SlashPos : natural;
  TempPath : APathname;
begin
  TempPath := ExpandPath( Path );
  --
  -- Check for a standard path--process and bail out if is one
  --
  if Index( TempPath, "://" ) = 0 then       -- no ://?
     PathType := File;
     Host := To255( "localhost" );           --  then it's this machine
     FilePath := TempPath;                   --  and it's the pathname
     return;                                 --  and bail out early
  end if;
  --
  -- Must be a URL.
  -- Check for the leading transfer method in the URL.
  -- slice vs. head: slice returns an Ada string and saves a conversion.
  --
  if Slice( TempPath, 1, 7 ) = "file://" then -- is it a file://?
     Delete( TempPath, 1, 7 );                -- then remove file:// part
     PathType := File;                        -- we know it's a file URL
  elsif Slice( Temppath, 1, 7 ) = "http://" then
     Delete( TempPath, 1, 7 );
     PathType := http;
  elsif Slice( Temppath, 1, 6 ) = "ftp://" then
     Delete( TempPath, 1, 6 );
     PathType := ftp;
  elsif Slice( Temppath, 1, 9 ) = "window://" then
     Delete( TempPath, 1, 9 );
     PathType := window;
  elsif Slice( Temppath, 1, 6 ) = "run://" then
     Delete( TempPath, 1, 6 );
     PathType := runnable;
  else
     SlashPos := Index( TempPath, "://" );    -- we know there is one
     Delete( TempPath, 1, SlashPos + 2 );     -- scrap unknown URL prefix
     PathType := Unknown;                     -- and mark it as unknown
  end if;                                     -- and try to process anyway
  --
  -- all URL's are host and optional path
  --
  if Element( TempPath, length( TempPath ) ) = '/' then -- ending slash?
     Delete( TempPath, length( TempPath), length( TempPath ) ); -- delete it
  end if;
text_io.put_line( "checking " & ToString( TempPath ) );
  SlashPos := Index( TempPath, "/" );      -- where's the next slash?
  if SlashPos > 0 then                     -- if there is one
text_io.put_line("has path" );
     Host := Head( TempPath, SlashPos-1 ); --   the address is before it
text_io.put_line("path = " & ToString( TempPath ) );
     Delete( TempPath, 1, SlashPos );      --   removing it and slash
text_io.put_line("after host removal, path = " & ToString( TempPath ) );
     FilePath := TempPath;                 --   leaves the path
  else                                     -- but if there isn't a slash
text_io.put_line("has no path" );
     Host := TempPath;                     --   then it's just the address
     FilePath := NullStr255;               --   with no path
  end if;
end DecomposePath;

---> Calandar Systems

function GetDate return str255 is
  TempStr : Str255;
begin
  CDate;
  for i in 0..Interface_String'length loop
      exit when Interface_String(i) = ASCII.NUL;
      TempStr := TempStr & Interface_String(i);
  end loop;
  return TempStr;
end GetDate;

function GetTime return str255 is
  TempStr : Str255;
begin
  Ctime;
  for i in 0..Interface_String'length loop
      exit when Interface_String(i) = ASCII.NUL;
      TempStr := TempStr & Interface_String(i);
  end loop;
  return TempStr;
end GetTime;

function GetTimeStamp return ATimeStamp is
  Time     : ATime;
  TimeZone : ATimeZone;
  TheStamp : ATimeStamp;
begin
  GetClock( Time, TimeZone );
  TheStamp := long_long_integer( time.seconds ) * 1_000_000 +
              long_long_integer( time.microseconds );
  return TheStamp;
end GetTimeStamp;

-- probably need to define comparision overloads

function GetLongDate return str255 is
  TempStr : Str255;
begin
  Clongdate;
  for i in 0..Interface_String'length loop
      exit when Interface_String(i) = ASCII.NUL;
      TempStr := TempStr & Interface_String(i);
  end loop;
  return TempStr;
end GetLongDate;

---> Append for Text File

procedure AddFile( file, text : str255 ) is
begin
  SetInterface( text );
  CAppend( ToString( file ) & character'val(0) );
end AddFile;

---> Logging

procedure SessionLog( message : str255 ) is
  WasRaising : boolean;
begin
  NoError;
  WasRaising := TrapErrors;
  SetInterface( message );
  CAddSessionLog;
  RestoreRaising( WasRaising );
end SessionLog;

procedure SessionLog( ada_message : string ) is
begin
  --NoError implied
  SessionLog( message => To255( ada_message ) );
end SessionLog;

procedure SessionLog( message : str255; ErrorCode : AnErrorCode ) is
begin
  --NoError implied
  SessionLog( message => message & " (Error Code" &
    AnErrorCode'image( ErrorCode ) & ")" );
end SessionLog;

procedure SessionLog( ada_message : string; ErrorCode : AnErrorCode ) is
begin
  --NoError implied
  SessionLog( To255( ada_message ), ErrorCode );
end SessionLog;

procedure Wait( seconds : float ) is
begin
  -- no range check
  CUSleep( long_integer( seconds * 1_000_000.0 ) );
end Wait;

end os;