libtexttools4-dev 2.1.0-6build2 / 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                     --
--                                                                          --
------------------------------------------------------------------------------

with Interfaces.C; use Interfaces.C;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Directories;
with Ada.Calendar.Formatting;
with Ada.Environment_Variables;
with Ada.Strings.Fixed;

--  Implement some facilities not yet in GNAT.
--  with Ada.Strings.Fixed.Hash_Case_Insensitive;
with Hash_Case_Insensitive;
--  with Ada.Strings.Fixed.Equal_Case_Insensitive;
with Equal_Case_Insensitive;

package body os is

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

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

---> C Interface
--
-- These are POSIX system calls.

function System (Command : in char_array) return int;
pragma Import( C, System, "system");

-- These are all from C_code/system.c.

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

function CRunIt (Cmd, Outfile, Parm1, Parm2, Parm3 : in char_array) return int;
pragma Import( C, CRunIt, "CRunIt" );

--->
--
-- Lintel Pathnames

package PathList is new Ada.Containers.Indefinite_Hashed_Maps
  (Key_Type => String,
   Element_Type => String,
   Hash => Hash_Case_Insensitive,
   Equivalent_Keys => Equal_Case_Insensitive);
Paths : PathList.Map;

---> Housekeeping

procedure StartupOS is
  WasRaising : boolean;
  
  procedure InitializeSessionLog is
     use Ada.Directories;
  begin
     if Exists (Containing_Directory (To_String (Sessionlogpath))) then
        declare
           use Ada.Text_IO;
           File : File_Type;
        begin
           Create (File, Out_File, To_String (Sessionlogpath));
           Close (File);
           pragma Unreferenced (File);
        end;
        SessionLog( "StartupOS: New " & To_String (ProgramName) & " session log started" );
        SessionLog( "StartupOS: " & Ada.Calendar.Formatting.Image (Ada.Calendar.Clock));
        if LastError /= TT_OK then
           Ada.Text_IO.Put_Line ( "StartupOS: Unable to write to session_log; error "
                                    & AnErrorCode'Image (LastError));
        end if;
     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;

  use Ada.Environment_Variables;
begin
  NoError;
  WasRaising := TrapErrors;

  if Exists ("TMPDIR") then
     PathAlias ("tmp", Value ("TMPDIR"));
  else
     PathAlias ("tmp", "/tmp");
  end if;

  if Exists ("HOME") then
     PathAlias ("home", Value ("HOME"));
     -- Make the $SYS alias by adding ShortProgramName to $HOME
     PathAlias ("sys", Value ("HOME") & "/" & To_String (ShortProgramName));
     SessionLogPath := To_Unbounded_String (ExpandPath ("$SYS/session_log"));
  else
     SessionLogPath := Null_Unbounded_String;
  end if;

  InitializeSessionLog;
  if LastError = TT_OK then
     ttyname := To_Unbounded_String (UNIX( "tty" ));
     IsLocaltty := (ttyname >= "/dev/tty1" and
         ttyname <= "/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 : in Duration ) 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 : in String) return boolean is
   Res : constant Int := System (To_C (S));
begin
   NoError;
   if res /= 0 then -- DEBUG
      SessionLog( "Call to system(""" & s & """) returned error code" & Int'Image (Res));
   end if;
   return res = 0;
end UNIX;

procedure UNIX( s : in String ) is
   Command : constant Char_Array := To_C (S);
begin
   NoError;
   if System (Command) /= 0 then
      Error( TT_SystemError );
   end if;
end UNIX;

function UNIX ( s : string ) return String is
   use Ada.Text_IO;
   File : File_Type;
   Output : Unbounded_String := Null_Unbounded_String;
   Res : Int;
begin
   NoError;
   Create (File, In_File, Name => "");	--  temp file
   Res := System (To_C (S & " > " & Name (File)));
   if Res /= 0 then
      SessionLog ("Call to system(""" & S & """) returned error code" & Int'Image (Res));
      Error( TT_SystemError );
   else
      while not End_Of_File (File) loop
	 Append (Output, Get_Line (File));
      end loop;
      Delete (File);
   end if;
   return To_String (Output);
end UNIX;

procedure RunIt( cmd : string;
                 parm1, parm2, parm3 : string := "";
                 Results : out StrList.Vector) is
   use Ada.Text_IO;
   File : File_Type;
   Status : Int;
begin
   NoError;
   Create (File, In_File, Name => "");	--  temp file
   Status := CRunIt (To_C (Cmd), To_C (Name (File)), To_C (Parm1), To_C (Parm2), To_C (Parm3));
   if Status = 0 then
      LoadList (File, Results );
      Error( TT_OK );
   else
      Error( TT_SystemError );
   end if;
   Delete (File);
   pragma Unreferenced (File);
end RunIt;

function NotEmpty (S : in APathName ) return boolean is
   P : constant String := Expandpath (S);
   use Ada.Directories;
begin
   NoError;
   return Exists (P) and then Size (P) /= 0;
end NotEmpty;

function IsDirectory (S : in APathName ) return boolean is
   P : constant String := Expandpath (S);
   use Ada.Directories;
begin
   NoError;
   return Exists (P) and then Kind (P) = Directory;
end Isdirectory;

function IsFile (S : in APathName ) return boolean is
begin
  NoError;
  return Ada.Directories.Exists (ExpandPath (S));
end IsFile;

function Lock (File : in APathName) return Boolean is
   --  This is equivalent to the previous version, but arguably
   --  efficient since another instance is allowed to take the
   --  lock...
   use Ada.Text_IO;
   File_Handler : File_Type;
begin
   Create (File_Handler, Out_File, LockPath & ExpandPath (File));
   Close (File_Handler);
   return True;
exception
   when others =>
      return False;
end Lock;

procedure Unlock (File : in APathName ) is
begin
   Ada.Directories.Delete_File (LockPath & Expandpath (File));
end Unlock;

procedure ValidateFilename (fs : in AFileSystem;
			    oldfn : in APathname;
			    newfn : out Unbounded_String;
			    errmsg : out Unbounded_String) is
   Changed : Boolean := False;
   
   procedure ValidateUNIX is -- hastily assembled
      ch : character;
   begin
      -- length OK
      -- leading character: no special requirements
      Newfn := Null_Unbounded_String;
      for i in Oldfn'Range loop
	 Ch := 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;
	 Append (Newfn, Ch);
      end loop;
      if Changed then
	 ErrMsg := To_Unbounded_String ( "bad characters for UNIX filesystem" );
    end if;
  end ValidateUNIX;

  procedure ValidateUNIX14 is
  begin
     if Oldfn'Length > 14 then
	newfn := To_Unbounded_String (Ada.Strings.Fixed.Head (oldfn, 14 ));
	Changed := true;
	ErrMsg := To_Unbounded_String ("too many characters for old UNIX filesystem" );
     else
	ValidateUNIX;
     end if;
  end ValidateUNIX14;

  procedure ValidateDOS is
    ch : character;
  begin
     Newfn := Null_Unbounded_String;
     for i in Oldfn'Range loop
	ch := Oldfn (i);
	if ch <= ' ' then
	   ch := '_';
	   Changed := true;
	end if;
	Append (Newfn, Ch);
     end loop;
     if Changed then
	ErrMsg := To_Unbounded_String ( "bad characters for DOS" );
       end if;
  end ValidateDOS;

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

begin
  ErrMsg := Null_Unbounded_String;
  if Oldfn'Length = 0 then
     Newfn := To_Unbounded_String ("untitled");
     ErrMsg := To_Unbounded_String ("Empty file name.");
  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 : in AFileSystem;
    oldfn : in APathname;
    Newfn : out unbounded_string;
    errmsg : out unbounded_string) is
   SepChar : character;
   SepPos1 : integer;
   SepPos2 : integer;
   CorrectedFile : Unbounded_String := null_unbounded_string;
   thefs : AFileSystem;
   LastErrMsg : Unbounded_String := Null_Unbounded_String;
begin
   newfn := Null_Unbounded_String;
   ErrMsg := Null_Unbounded_String;
   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 Ada.Strings.Fixed.Index( oldfn, "/" ) > 0 then
	    SepChar := '/';
	    thefs := UnixFS;
	 elsif Ada.Strings.Fixed.Index( oldfn, "\" ) > 0 then
	    SepChar := '\';
	    thefs := DosFS;
	 elsif Ada.Strings.Fixed.Index( oldfn, ":" ) > 0 then
	    SepChar := ':';
	    thefs := OS2FS;
	 else
	    SepChar := '/'; -- guess UNIX by default
	    thefs := UnixFS;
	 end if;
   end case;
   SepPos1 := Ada.Strings.Fixed.Index( oldfn, (1 => SepChar));
   if SepPos1 = 0 then
      ValidateFilename( fs, oldfn, newfn, Errmsg );
   else
      loop
	 SepPos2 := Oldfn'length;
	 for i in SepPos1+1..Oldfn'Last loop
	    if Oldfn (i) = SepChar then
	       SepPos2 := i;
	       exit;
	    end if;
	 end loop;
	 ValidateFilename ( thefs, Oldfn (SepPos1 + 1 .. SepPos2 - 1), CorrectedFile, Lasterrmsg );
	 if length( CorrectedFile ) /= 0 then
	    Append (Newfn, SepChar & CorrectedFile);
	    if length( LastErrMsg ) > 0 then
	       ErrMsg := LastErrMsg;
	    end if;
	 else
	    Append (Newfn, SepChar & Oldfn (SepPos1 + 1 .. SepPos2 - 1));
	 end if;
	 exit when SepPos2 = Oldfn'Last;
	 SepPos1 := SepPos2;
      end loop;
      if length( ErrMsg ) = 0 then -- no errors? no changes
	 newfn := Null_Unbounded_String;
      end if;
   end if;
end ValidatePathname;

procedure Erase( File : APathName ) is
   use Ada.Directories;
begin
   NoError;
   Delete_File (Expandpath (File));
exception
   when Name_Error | Use_Error =>
      Error (TT_FileAccess);
end Erase;

procedure Trash( file : APathName ) is
   -- remove a file to the trash can, erasing if necessary
   WasRaising : boolean;
begin
  --NoError called in UNIX
   WasRaising := RaisingErrors;
   TrapErrors;
   UNIX ("mv " & Expandpath (File) & " $HOME/.Trash 2> /dev/null");
   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
begin
   --NoError called in UNIX
   UNIX ("mv " & ExpandPath (File1) & " " & ExpandPath (File2) & " 2> /dev/null");
end Move;

function Shrink( file : APathName ) return APathName is
   Path : constant String := Expandpath (File);
begin
  --NoError called in UNIX
  --shrinkstr := To255( "zoo aPq " );
   UNIX ("gzip " & Path & " " & Path);
   --  if LastError = 0 then
   --     Erase (Path & ".bak");
   --  end if;
   if LastError = 0 then
      --return Append( path, ".zoo" );
      return Path & ".gz";
   else
      return "";
   end if;
end Shrink;

function Expand( file : APathName ) return APathName is
   Path : constant String := Expandpath (File);
begin
  --NoError called in UNIX
  --expandstr := To255( "zoo x//qO " );
  UNIX ("gunzip " & Path);
  if LastError = 0 then
     pragma Assert (Ada.Strings.Fixed.Tail (Path, 3) = ".gz");
     return Ada.Strings.Fixed.Head (Path, Path'Length - 3);
  else
     return "";
  end if;
end Expand;

procedure Archive( arch, file : APathName ) is
   -- note possibility of overflow here!
   ArchPath : constant String := ExpandPath (Arch);
   FilePath : constant String := ExpandPath (File);
begin
   --NoError called in UNIX
   if Ada.Strings.Fixed.Tail (Archpath, 4) /= ".tgz"
     or NotEmpty (Filepath) then
      -- should really be not exists
      Error( TT_FileExistance );
   else
      --Cmd := To255( "zoo aunqP " ) & ArchPath & To255(" " ) & FilePath;
      UNIX ("tar cfz " & ArchPath & " " & FilePath);
   end if;
end Archive;

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

procedure Usage (file : in APathName;
		 me : in AFileUsage := Normal;
		 us : in AFileUsage := ReadOnly;
		 everyone : in AFileUsage := ReadOnly ) is
   Octal : constant array (Afileusage) of Character
     := (ReadOnly => '4',
	 Normal => '6',
	 Run => '7',
	 None => '0');
begin
   --NoError called in UNIX
   UNIX ("chmod " & Octal (Me) & Octal (Us) & Octal (Everyone) & " " & ExpandPath (file));
end Usage;

procedure BeginSession is
begin
  null;
end BeginSession;

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


---> Directory Utilities

function SpaceUsed( dir : APathName ) return integer is
begin
   --NoError called in UNIX
   return Integer'Value (UNIX ("du -fs " & ExpandPath (dir)));
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 string is
begin
  return UNIX( "uname -n" );
end GetFreeClusterHost;


---> Str255Lists

procedure Loadlist (File : in Ada.Text_IO.File_Type;
		    StringList : out Strlist.Vector) is
   use Ada.Text_IO;
begin
   Stringlist.Clear;
   while not End_Of_File (File) loop
      StringList.Append (Get_Line (File));
   end loop;
exception
   when Storage_Error =>
      StringList.Clear;
      Error( TT_LowMemory );
end Loadlist;

procedure Loadlist (Path : in String;
		    StringList : out StrList.Vector) is
   -- load a string list from a file
   use Ada.Text_IO;
   File : File_Type;
begin
   begin
      Open (File, In_File, Expandpath (Path));
   exception
      when Status_Error =>
	 Error( TT_FileLocking );
	 return;
      when Name_Error =>
	 Error( TT_FileExistance );
	 return;
   end;
   Loadlist (File, Stringlist);
   Close (File);
exception
   when others =>
      if Is_Open (File) then
	 Close (File);
      end if;
end LoadList;

procedure savelist (File : in Ada.Text_IO.File_Type;
		    StringList : in Strlist.Vector) is
   use Ada.Text_IO;
   procedure Process (Position : in Strlist.Cursor);
   procedure Process (Position : in Strlist.Cursor) is
   begin
      Put_Line (File, Strlist.Element (Position));
   end Process;
begin
   StringList.Iterate (Process'Access);
end Savelist;

procedure SaveList (Path : in APathName;
		    StringList : in StrList.Vector ) is
   -- save a string list to a file
   use Ada.Text_IO;
   File : file_type;
begin
   begin
      Create (File, Out_File, ExpandPath (Path));
   exception
      when Status_Error =>
	 Error( TT_FileLocking );
	 return;
      when Name_Error =>
	 Error( TT_FileExistance );
	 return;
   end;
   Savelist (File, Stringlist);
   Close (File);
exception -- translate Text_IO errors into core errors
   when others =>
      if Is_Open (File) then
	 Close (File);
      end if;
end SaveList;

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

procedure SetPath( s : APathName ) is
   use Ada.Directories;
   Path : constant String := Expandpath (S);
begin
   Set_Directory (Path);
exception
   when Name_Error | Use_Error =>
      SessionLog( "SetPath: can't change path to " & Path);
      Ada.Text_IO.Put_Line( Ada.Text_IO.Standard_Error, "SetPath: TT_SystemError -- can't change path" );
      Error( TT_SystemError );
end SetPath;

procedure PathAlias (Alias : in String;
                     Path  : in APathName) is
begin
  NoError;
  Paths.Include (Alias, Path);
end PathAlias;

function ExpandPath (Path : in APathName )
                    return APathName is
   -- check for leading number and convert to a path
   use Pathlist;
   posn : Natural;
   Position : Cursor;
begin
   if Path'Length = 0 or else Path (Path'First) /= '$' then
      return Path;
   end if;
   Posn := Ada.Strings.Fixed.Index
     (Source => Path (Path'First + 1 .. Path'Last),
      Pattern => (1 => '/'));
   if Posn = 0 then
      Posn := Path'Last + 1;
   end if;
   Position := Paths.Find (Path (Path'First + 1 .. Posn - 1));
   if Position = No_Element then
      return Path (Posn .. Path'Last);
   end if;
   return Element (Position) & Path (Posn .. Path'Last);
end ExpandPath;

procedure SplitPath (path : in String;
		     dir : out Unbounded_String;
		     file : out unbounded_string) is
   -- split path into directory and file
   use Ada.Directories;
begin
   Dir := To_Unbounded_String (Containing_Directory (Path));
   File := To_Unbounded_String (Simple_Name (Path));
end SplitPath;

procedure DecomposePath( path : in APathname;
			 PathType : out APathType;
			 Host : out unbounded_string;
			 Filepath : out unbounded_string) is
   SlashPos : Natural;
begin
   FilePath := To_Unbounded_String (ExpandPath (Path));
   
   --
   -- Check for a standard path--process and bail out if is one
   --
   Slashpos := Index (FilePath, "://");
   if slashPos = 0 then       -- no ://?
      PathType := File;
      Host := To_Unbounded_String ("localhost"); --  then it's this machine
      return;
   end if;
   --
   -- Must be a URL.
   -- Check for the leading transfer method in the URL.
   --
   Pathtype := Unknown;
   for Kind in Apathtype'Succ (Unknown) .. Apathtype'Last loop
      if Equal_Case_Insensitive (To_String (Head (FilePath, Slashpos + 2)),
				 Apathtype'Image (Kind) & "://") then
	 Tail (Filepath, Length (Filepath) - Slashpos - 2);
	 PathType := Kind;
	 exit;
      end if;
   end loop;
   if Pathtype = Unknown then
      Delete (Filepath, 1, SlashPos + 2);     -- scrap unknown URL prefix
   end if;                                     -- and try to process anyway
   --
   -- all URL's are host and optional path
   --
   if Element( Filepath, length( Filepath ) ) = '/' then -- ending slash?
      Head (Filepath, Length (Filepath) - 1); -- delete it
   end if;
   Ada.text_io.put_line( "checking " & To_String( Filepath ) );
   SlashPos := Index( Filepath, "/" );      -- where's the next slash?
   if SlashPos > 0 then                     -- if there is one
      Ada.text_io.put_line("has path" );
      Host := Head( Filepath, SlashPos-1 ); --   the address is before it
      Ada.text_io.put_line("path = " & To_String( Filepath ) );
      Delete( Filepath, 1, SlashPos );      --   removing it and slash
      Ada.text_io.put_line("after host removal, path = " & To_String( Filepath ) );
  else                                     -- but if there isn't a slash
     Ada.text_io.put_line("has no path" );
     Host := Filepath;                     --   then it's just the address
     FilePath := Null_Unbounded_String;    --   with no path
  end if;
end DecomposePath;

---> Append for Text File

procedure AddFile( file, text : in String ) is
   use Ada.Text_IO;
   F : File_Type;
begin
   if Ada.Directories.Exists (File) then
      Open (F, Append_File, File);
      Put_Line (F, Text);
      Close (F);
   end if;
exception
   when others =>
      if Is_Open (F) then
	 Close (F);
      end if;
      raise;
end AddFile;

---> Logging

procedure SessionLog (Message : in String) is
   WasRaising : boolean;
begin
   NoError;
   WasRaising := TrapErrors;
   Addfile (To_String (Sessionlogpath), Message);
   RestoreRaising( WasRaising );
end SessionLog;

procedure SessionLog (Message : in String;
		      ErrorCode : in AnErrorCode ) is
begin
   --NoError implied
   SessionLog (Message & " (Error Code" &
		 AnErrorCode'Image (ErrorCode) & ")" );
end SessionLog;

end os;