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;