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;