File : s-shamem.adb


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                 S Y S T E M . S H A R E D _ M E M O R Y                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.4 $                              --
--                                                                          --
--            Copyright (C) 1998, Free Software Foundation, Inc.            --
--                                                                          --
-- GNAT 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.  GNAT 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 GNAT;  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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Exceptions;
with Ada.IO_Exceptions;

with GNAT.HTable;
with GNAT.Lock_Files;
with GNAT.OS_Lib;

use type GNAT.OS_Lib.String_Access;

with System;
with System.File_Control_Block;
with System.File_IO;
with Unchecked_Deallocation;
with Unchecked_Conversion;

package body System.Shared_Memory is

   package OS renames GNAT.OS_Lib;

   package IOX renames Ada.IO_Exceptions;

   package FCB renames System.File_Control_Block;

   package SFI renames System.File_IO;

   Direc : OS.String_Access;
   --  Holds the directory

   ----------------------------------------------
   -- Variables for Shared Memory Access Files --
   ----------------------------------------------

   Max_Shared_Mem_Files : constant := 20;
   --  Maximum number of lock files that can be open

   Shared_Mem_Files_Open : Natural := 0;
   --  Number of shared memory access files currently open

   subtype Hash_Header is Natural range 0 .. 30;
   --  Number of hash headers, related (for efficiency purposes only)
   --  to the maximum number of lock files..

   type Shared_Mem_File_Entry;
   type Shared_Mem_File_Entry_Ptr is access Shared_Mem_File_Entry;

   type Shared_Mem_File_Entry is record
      Name : OS.String_Access;
      --  Name of variable, as passed to Read_File/Write_File routines

      File : SIO.File_Type;
      --  Stream_IO file for the shared memory file

      Next : Shared_Mem_File_Entry_Ptr;
      Prev : Shared_Mem_File_Entry_Ptr;
      --  Links for LRU chain
   end record;

   procedure Free is new Unchecked_Deallocation
     (Object => Shared_Mem_File_Entry,
      Name   => Shared_Mem_File_Entry_Ptr);

   function To_AFCB_Ptr is
     new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);

   LRU_Head : Shared_Mem_File_Entry_Ptr;
   LRU_Tail : Shared_Mem_File_Entry_Ptr;
   --  As lock files are opened, they are organized into a least recently
   --  used chain, which is a doubly linked list using the Next and Prev
   --  fields of Shared_Mem_File_Entry records. The field LRU_Head points
   --  to the least recently used entry, whose prev pointer is null, and
   --  LRU_Tail points to the most recently used entry, whose next pointer
   --  is null. These pointers are null only if the list is empty.

   function Hash  (F : OS.String_Access)      return Hash_Header;
   function Equal (F1, F2 : OS.String_Access) return Boolean;
   --  Hash and equality functions for hash table

   package SFT is new GNAT.HTable.Simple_HTable
     (Header_Num => Hash_Header,
      Element    => Shared_Mem_File_Entry_Ptr,
      No_Element => null,
      Key        => OS.String_Access,
      Hash       => Hash,
      Equal      => Equal);

   --------------------------------
   -- Variables for Lock Control --
   --------------------------------

   Lock_File : OS.String_Access;
   --  Pointer to null terminated name of lock file, which is the directory
   --  name concatenated with _lock_file.

   Lock_Count : Natural := 0;
   --  Counts nesting of lock calls, 0 means lock is not held

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Initialize;
   --  Called to initialize data structures for this package.
   --  Has no effect except on the first call.

   procedure Enter_SFE (SFE : Shared_Mem_File_Entry_Ptr; Fname : String);
   --  The first parameter is a pointer to a newly allocated SFE, whose
   --  File field is already set appropriately. Fname is the name of the
   --  variable as passed to Shared_Mem_RFile/Shared_Mem_WFile. Enter_SFE
   --  completes the SFE value, and enters it into the hash table. If the
   --  hash table is already full, the least recently used entry is first
   --  closed and discarded.

   function Retrieve (File : String) return Shared_Mem_File_Entry_Ptr;
   --  Given a file name, this function searches the hash table to see if
   --  the file is currently open. If so, then a pointer to the already
   --  created entry is returned, after first moving it to the head of
   --  the LRU chain. If not, then null is returned.

   ---------------
   -- Enter_SFE --
   ---------------

   procedure Enter_SFE (SFE : Shared_Mem_File_Entry_Ptr; Fname : String) is
      Freed : Shared_Mem_File_Entry_Ptr;

   begin
      SFE.Name := new String'(Fname);

      --  Release least recently used entry if we have to

      if Shared_Mem_Files_Open =  Max_Shared_Mem_Files then
         Freed := LRU_Head;

         if Freed.Next /= null then
            Freed.Next.Prev := null;
         end if;

         LRU_Head := Freed.Next;
         SFT.Remove (Freed.Name);
         SIO.Close (Freed.File);
         OS.Free (Freed.Name);
         Free (Freed);
      end if;

      --  Add new entry to hash table

      SFT.Set (SFE.Name, SFE);

      --  Add new entry at end of LRU chain

      Shared_Mem_Files_Open := Shared_Mem_Files_Open + 1;

      if LRU_Head = null then
         LRU_Head := SFE;
         LRU_Tail := SFE;

      else
         SFE.Prev := LRU_Tail;
         LRU_Tail.Next := SFE;
         LRU_Tail := SFE;
      end if;
   end Enter_SFE;

   -----------
   -- Equal --
   -----------

   function Equal (F1, F2 : OS.String_Access) return Boolean is
   begin
      return F1.all = F2.all;
   end Equal;

   ----------
   -- Hash --
   ----------

   function Hash (F : OS.String_Access) return Hash_Header is
      N : Natural := 0;

   begin
      --  Add up characters of name, mod our table size

      for J in F'Range loop
         N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
      end loop;

      return N;
   end Hash;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      if Direc = null then
         Direc := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
         Lock_File := new String'(Direc.all & "__lock" & Ascii.NUL);
      end if;
   end Initialize;

   --------------
   -- Retrieve --
   --------------

   function Retrieve (File : String) return Shared_Mem_File_Entry_Ptr is
      SFE : Shared_Mem_File_Entry_Ptr;

   begin
      Initialize;
      SFE := SFT.Get (File'Unrestricted_Access);

      if SFE /= null then

         --  Move to head of LRU chain

         if SFE = LRU_Head then
            null;

         elsif SFE = LRU_Tail then
            LRU_Tail := LRU_Tail.Prev;
            LRU_Tail.Next := null;

         else
            SFE.Next.Prev := SFE.Prev;
            SFE.Prev.Next := SFE.Next;
         end if;

         SFE.Prev := null;
         SFE.Next := LRU_Head;
         LRU_Head.Prev := SFE;
         LRU_Head := SFE;
      end if;

      return SFE;
   end Retrieve;

   ----------------------
   -- Shared_Mem_RFile --
   ----------------------

   function Shared_Mem_RFile (Fname : String) return SIO.Stream_Access is
      SFE : Shared_Mem_File_Entry_Ptr;

      use type Ada.Streams.Stream_IO.File_Mode;

   begin
      SFE := Retrieve (Fname);

      --  Here if file is not already open, try to open it

      if SFE = null then
         declare
            S  : aliased constant String := Direc.all & Fname & Ascii.Nul;

         begin
            SFE := new Shared_Mem_File_Entry;
            SIO.Open (SFE.File, SIO.In_File, Name => S);
            SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.File));

            --  File opened successfully, put new entry in hash table. Note
            --  that in this case, file is positioned correctly for read.

            Enter_SFE (SFE, Fname);

            exception
               --  If we get an exception, it means that the file does not
               --  exist, and in this case, we don't need the SFE and we
               --  return null;

               when IOX.Name_Error =>
                  Free (SFE);
                  return null;
         end;

      --  Here if file is already open, set file for reading

      else
         if SIO.Mode (SFE.File) /= SIO.In_File then
            SIO.Set_Mode (SFE.File, SIO.In_File);
            SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.File));
         end if;

         SIO.Set_Index (SFE.File, 1);
      end if;

      return SIO.Stream (SFE.File);
   end Shared_Mem_RFile;

   ---------------------
   -- Share_Mem_Wfile --
   ---------------------

   function Shared_Mem_WFile (Fname : String) return SIO.Stream_Access is
      SFE : Shared_Mem_File_Entry_Ptr;

      use type Ada.Streams.Stream_IO.File_Mode;

   begin
      SFE := Retrieve (Fname);

      if SFE = null then
         declare
            S  : aliased constant String := Direc.all & Fname & Ascii.Nul;

         begin
            SFE := new Shared_Mem_File_Entry;
            SIO.Open (SFE.File, SIO.Out_File, Name => S);
            SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.File));

         exception
            --  If we get an exception, it means that the file does not
            --  exist, and in this case, we create the file.

            when IOX.Name_Error =>

               begin
                  SIO.Create (SFE.File, SIO.Out_File, Name => S);

               exception
                  --  Error if we cannot create the file

                  when others =>
                     Ada.Exceptions.Raise_Exception
                       (Program_Error'Identity,
                        "Cannot create shared memory file for """ &
                         Fname & '"');
               end;
         end;

         --  Make new hash table entry for opened/created file. Note that
         --  in both cases, the file is already in write mode at the start
         --  of the file, ready to be written.

         Enter_SFE (SFE, Fname);

      --  Here if file is already open, set file for writing

      else
         if SIO.Mode (SFE.File) /= SIO.Out_File then
            SIO.Set_Mode (SFE.File, SIO.Out_File);
            SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.File));
         end if;

         SIO.Set_Index (SFE.File, 1);
      end if;

      return SIO.Stream (SFE.File);
   end Shared_Mem_WFile;

   ---------------------
   -- Shared_Mem_Lock --
   ---------------------

   procedure Shared_Mem_Lock is
   begin
      Initialize;

      if Lock_Count /= 0 then
         Lock_Count := Lock_Count + 1;

      else
         GNAT.Lock_Files.Lock_File (Lock_File.all, Wait => 0.1);
         Lock_Count := 1;
      end if;
   end Shared_Mem_Lock;

   -----------------------
   -- Shared_Mem_Unlock --
   -----------------------

   procedure Shared_Mem_Unlock is
   begin
      Initialize;
      Lock_Count := Lock_Count - 1;

      if Lock_Count = 0 then
         GNAT.Lock_Files.Unlock_File (Lock_File.all);
      end if;
   end Shared_Mem_Unlock;

end System.Shared_Memory;