File : posix-process_identification.adb


pragma Source_Reference (1, "posix-process_identification.gpb");
------------------------------------------------------------------------------
--                                                                          --
--            FLORIST (FSU Implementation of POSIX.5) COMPONENTS            --
--                                                                          --
--          P O S I X . P R O C E S S _ I D E N T I F I C A T I O N         --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                                                                          --
--  Copyright (c) 1996-1998             Florida  State  University  (FSU),  --
--  All Rights Reserved.                                                    --
--                                                                          --
--  This file is a component of FLORIST, an  implementation of an  Ada API  --
--  for the POSIX OS services, for use with  the  GNAT  Ada  compiler  and  --
--  the FSU Gnu Ada Runtime Library (GNARL).   The  interface  is intended  --
--  to be close to that specified in  IEEE STD  1003.5: 1990  and IEEE STD  --
--  1003.5b: 1996.                                                          --
--                                                                          --
--  FLORIST is free software;  you can  redistribute  it and/or  modify it  --
--  under terms of the  GNU  General  Public  License as  published by the  --
--  Free Software Foundation;  either version  2, or (at  your option) any  --
--  later version.  FLORIST 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  --
--  General Public License for more details.  You  should have  received a  --
--  copy of the GNU General Public License  distributed  with  GNARL;  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.                                      --
--                                                                          --
------------------------------------------------------------------------------
--  [$Revision: 1.5 $]

with POSIX.C,
     POSIX.Implementation;
package body POSIX.Process_Identification is

   use POSIX.C,
       POSIX.Implementation;

   ---------------------
   --  Get_Process_ID --
   ---------------------

   function getpid return pid_t;
   pragma Import (C, getpid, getpid_LINKNAME);

   function Get_Process_ID return Process_ID is
   begin

      return Process_ID (This_Process);



   end Get_Process_ID;

   -----------------------------
   --  Get_Parent_Process_ID  --
   -----------------------------

   function Get_Parent_Process_ID return Process_ID is
      function getppid return pid_t;
      pragma Import (C, getppid, getppid_LINKNAME);
   begin
      return Process_ID (getppid);
   end Get_Parent_Process_ID;

   -----------
   -- Image --
   -----------

   function Image (ID : Process_ID)
      return Standard.String is
   begin
      return Process_ID'Image (ID);
   end Image;

   -----------
   -- Value --
   -----------

   function Value (Str : Standard.String)
      return Process_ID is
   begin
      return Process_ID'Value (Str);
   end Value;

   --------------------------
   -- Get_Process_Group_ID --
   --------------------------

   --  The getpgrp takes an argument under BSD but not under POSIX.
   --  We pass it an argument in all cases and hope that the function
   --  call mechanism will not be confused by unexpected arguments.

   function getpgrp (ID : Process_ID) return Process_Group_ID;
   pragma Import (C, getpgrp, "getpgrp");

   function Get_Process_Group_ID return Process_Group_ID is
   begin
      return getpgrp (Get_Process_ID);
   end Get_Process_Group_ID;

   --------------------------
   -- Set_Process_Group_ID --
   --------------------------

   function setpgid (pid : pid_t; pgrp : pid_t) return int;
   pragma Import (C, setpgid, setpgid_LINKNAME);

   procedure Set_Process_Group_ID
     (Process : in Process_ID := Get_Process_ID;
      Process_Group : in Process_Group_ID := Get_Process_Group_ID) is
   begin
      Check (Process /= Null_Process_ID, Invalid_Argument);
      Check (setpgid (pid_t (Process), pid_t (Process_Group)));
   end Set_Process_Group_ID;

   --------------------------
   -- Create_Process_Group --
   --------------------------

   procedure Create_Process_Group
     (Process : in Process_ID; Process_Group : out Process_Group_ID) is
      function setpgid (pid : pid_t; pgrp : pid_t) return int;
      pragma Import (C, setpgid, setpgid_LINKNAME);
   begin
      Check (setpgid (pid_t (Process), 0));
      Process_Group := Process_Group_ID (Process);
   end Create_Process_Group;

   ----------------------
   --  Create_Session  --
   ----------------------

   procedure Create_Session
     (Session_Leader : out Process_Group_ID) is
      function setsid return pid_t;
      pragma Import (C, setsid, setsid_LINKNAME);
   begin
      Session_Leader := Process_Group_ID (setsid);
      if Session_Leader = -1 then Raise_POSIX_Error;
      end if;
   end Create_Session;

   -----------
   -- Image --
   -----------

   function Image (ID : Process_Group_ID) return Standard.String
   renames Process_Group_ID'Image;

   -----------
   -- Value --
   -----------

   function Value
     (Str : Standard.String) return Process_Group_ID is
   begin
      return Process_Group_ID'Value (Str);
   end Value;

   ----------------------
   -- Get_Real_User_ID --
   ----------------------

   function Get_Real_User_ID return User_ID is
      function getuid return uid_t;
      pragma Import (C, getuid, getuid_LINKNAME);
   begin
      return User_ID (getuid);
   end Get_Real_User_ID;

   ---------------------------
   -- Get_Effective_user_ID --
   ---------------------------

   function Get_Effective_User_ID return User_ID is
      function geteuid return uid_t;
      pragma Import (C, geteuid, geteuid_LINKNAME);
   begin
      return User_ID (geteuid);
   end Get_Effective_User_ID;

   -----------------
   -- Set_User_ID --
   -----------------

   procedure Set_User_ID (ID : in User_ID) is
      function setuid (uid : uid_t) return int;
      pragma Import (C, setuid, setuid_LINKNAME);
   begin
      Check (setuid (uid => uid_t (ID)));
   end Set_User_ID;

   --------------------
   -- Get_Login_Name --
   --------------------

--  .... Consider using getlogin_r if that is supported.
--  Use conditional code, based on configurable constant
--  HAVE_getlogin_r.

   function Get_Login_Name return POSIX.POSIX_String is
      function getlogin return char_ptr;
      pragma Import (C, getlogin, getlogin_LINKNAME);
      Name_Ptr : char_ptr;
   begin
      Name_Ptr := getlogin;
      if (Name_Ptr = null) then Raise_POSIX_Error; end if;
      return Form_POSIX_String (Name_Ptr);
   end Get_Login_Name;

   -----------
   -- image --
   -----------

   function Image (ID : User_ID) return Standard.String is
   begin
      return User_ID'Image (ID);
   end Image;

   -----------
   -- Value --
   -----------

   function Value (Str : Standard.String) return User_ID is
   begin
      return User_ID'Value (Str);
   end Value;

   --  User Group Identification

   --  type Group_ID is private;

   -----------------------
   -- Get_Real_Group_ID --
   -----------------------

   function Get_Real_Group_ID return Group_ID is
      function getgid return gid_t;
      pragma Import (C, getgid, getgid_LINKNAME);
   begin
      return Group_ID (getgid);
   end Get_Real_Group_ID;

   ----------------------------
   -- Get_Effective_Group_ID --
   ----------------------------

   function Get_Effective_Group_ID return Group_ID is
      function getegid return gid_t;
      pragma Import (C, getegid, getegid_LINKNAME);
   begin
      return Group_ID (getegid);
   end Get_Effective_Group_ID;

   ------------------
   -- Set_Group_ID --
   ------------------

   procedure Set_Group_ID (ID : in Group_ID) is
      function setgid (gid : gid_t) return int;
      pragma Import (C, setgid, setgid_LINKNAME);
   begin
      Check (setgid (gid_t (ID)));
   end Set_Group_ID;

   ----------------
   -- Get_Groups --
   ----------------

   type Access_Group_ID is access all Group_ID;

   function Get_Groups return Group_List is
      function getgroups
        (gidsetsize : int; grouplist : Access_Group_ID) return C.int;
      pragma Import (C, getgroups, getgroups_LINKNAME);
   begin
      loop
         declare
            NGroups_1 : constant int := getgroups (0, null);
            Groups : aliased Group_List (1 .. Integer (NGroups_1));
            NGroups_2 : int;
         begin
            NGroups_2 :=
              getgroups (Groups'Length, Groups (1)'Unchecked_Access);
            Check (NGroups_2);
            if NGroups_1 = NGroups_2 then return Groups; end if;
         end;
      end loop;
      --  the loop is in case some other process changes the number of
      --  items in the group list,
      --  before the first and second call to getgroups
   end Get_Groups;

   -----------
   -- Image --
   -----------

   function Image (ID : Group_ID) return Standard.String is
   begin
      return Trim_Leading_Blank (Group_ID'Image (ID));
   end Image;

   -----------
   -- Value --
   -----------

   function Value (Str : Standard.String) return Group_ID is
   begin
      return Group_ID (Group_ID'Value (Str));
   end Value;

end POSIX.Process_Identification;