1------------------------------------------------------------------------------
2--                                                                          --
3--            FLORIST (FSU Implementation of POSIX.5) COMPONENTS            --
4--                                                                          --
5--          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         --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--                                                                          --
10--             Copyright (C) 1996-1997 Florida State University             --
11--                     Copyright (C) 1998-2014, AdaCore                     --
12--                                                                          --
13--  This file is a component of FLORIST, an  implementation of an  Ada API  --
14--  for the POSIX OS services, for use with  the  GNAT  Ada  compiler  and  --
15--  the FSU Gnu Ada Runtime Library (GNARL).   The  interface  is intended  --
16--  to be close to that specified in  IEEE STD  1003.5: 1990  and IEEE STD  --
17--  1003.5b: 1996.                                                          --
18--                                                                          --
19--  FLORIST is free software;  you can  redistribute  it and/or  modify it  --
20--  under terms of the  GNU  General  Public  License as  published by the  --
21--  Free Software Foundation;  either version  2, or (at  your option) any  --
22--  later version.  FLORIST is distributed  in  the hope  that  it will be  --
23--  useful, but WITHOUT ANY WARRANTY;  without  even the implied  warranty  --
24--  of MERCHANTABILITY or FITNESS FOR A PARTICULAR  PURPOSE.  See  the GNU  --
25--  General Public License for more details.  You  should have  received a  --
26--  copy of the GNU General Public License  distributed  with  GNARL;  see  --
27--  file  COPYING.  If not,  write to  the  Free  Software  Foundation, 59  --
28--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.                   --
29--                                                                          --
30--                                                                          --
31--                                                                          --
32--                                                                          --
33--                                                                          --
34--                                                                          --
35--                                                                          --
36--                                                                          --
37------------------------------------------------------------------------------
38
39with POSIX.Implementation;
40
41package body POSIX.Process_Identification is
42
43   use POSIX.C,
44       POSIX.Implementation;
45
46   ---------------------
47   --  Get_Process_ID --
48   ---------------------
49
50   function getpid return pid_t;
51   pragma Import (C, getpid, getpid_LINKNAME);
52
53   function Get_Process_ID return Process_ID is
54   begin
55      return Process_ID (getpid);
56   end Get_Process_ID;
57
58   -----------------------------
59   --  Get_Parent_Process_ID  --
60   -----------------------------
61
62   function Get_Parent_Process_ID return Process_ID is
63      function getppid return pid_t;
64      pragma Import (C, getppid, getppid_LINKNAME);
65   begin
66      return Process_ID (getppid);
67   end Get_Parent_Process_ID;
68
69   -----------
70   -- Image --
71   -----------
72
73   function Image (ID : Process_ID)
74      return Standard.String is
75   begin
76      return Process_ID'Image (ID);
77   end Image;
78
79   -----------
80   -- Value --
81   -----------
82
83   function Value (Str : Standard.String)
84      return Process_ID is
85   begin
86      return Process_ID'Value (Str);
87   end Value;
88
89   --------------------------
90   -- Get_Process_Group_ID --
91   --------------------------
92
93   --  The getpgrp takes an argument under BSD but not under POSIX.
94   --  We pass it an argument in all cases and hope that the function
95   --  call mechanism will not be confused by unexpected arguments.
96
97   function getpgrp (ID : Process_ID) return Process_Group_ID;
98   pragma Import (C, getpgrp, "getpgrp");
99
100   function Get_Process_Group_ID return Process_Group_ID is
101   begin
102      return getpgrp (Get_Process_ID);
103   end Get_Process_Group_ID;
104
105   --------------------------
106   -- Set_Process_Group_ID --
107   --------------------------
108
109   function setpgid (pid : pid_t; pgrp : pid_t) return int;
110   pragma Import (C, setpgid, setpgid_LINKNAME);
111
112   procedure Set_Process_Group_ID
113     (Process : Process_ID := Get_Process_ID;
114      Process_Group : Process_Group_ID := Get_Process_Group_ID) is
115   begin
116      Check (Process /= Null_Process_ID, Invalid_Argument);
117      Check (setpgid (pid_t (Process), pid_t (Process_Group)));
118   end Set_Process_Group_ID;
119
120   --------------------------
121   -- Create_Process_Group --
122   --------------------------
123
124   procedure Create_Process_Group
125     (Process : Process_ID; Process_Group : out Process_Group_ID) is
126      function setpgid (pid : pid_t; pgrp : pid_t) return int;
127      pragma Import (C, setpgid, setpgid_LINKNAME);
128   begin
129      Check (setpgid (pid_t (Process), 0));
130      Process_Group := Process_Group_ID (Process);
131   end Create_Process_Group;
132
133   ----------------------
134   --  Create_Session  --
135   ----------------------
136
137   procedure Create_Session
138     (Session_Leader : out Process_Group_ID) is
139      function setsid return pid_t;
140      pragma Import (C, setsid, setsid_LINKNAME);
141   begin
142      Session_Leader := Process_Group_ID (setsid);
143      if Session_Leader = -1 then
144         Raise_POSIX_Error;
145      end if;
146   end Create_Session;
147
148   -----------
149   -- Image --
150   -----------
151
152   function Image (ID : Process_Group_ID) return Standard.String
153   renames Process_Group_ID'Image;
154
155   -----------
156   -- Value --
157   -----------
158
159   function Value
160     (Str : Standard.String) return Process_Group_ID is
161   begin
162      return Process_Group_ID'Value (Str);
163   end Value;
164
165   ----------------------
166   -- Get_Real_User_ID --
167   ----------------------
168
169   function Get_Real_User_ID return User_ID is
170      function getuid return uid_t;
171      pragma Import (C, getuid, getuid_LINKNAME);
172   begin
173      return User_ID (getuid);
174   end Get_Real_User_ID;
175
176   ---------------------------
177   -- Get_Effective_user_ID --
178   ---------------------------
179
180   function Get_Effective_User_ID return User_ID is
181      function geteuid return uid_t;
182      pragma Import (C, geteuid, geteuid_LINKNAME);
183   begin
184      return User_ID (geteuid);
185   end Get_Effective_User_ID;
186
187   -----------------
188   -- Set_User_ID --
189   -----------------
190
191   procedure Set_User_ID (ID : User_ID) is
192      function setuid (uid : uid_t) return int;
193      pragma Import (C, setuid, setuid_LINKNAME);
194   begin
195      Check (setuid (uid => uid_t (ID)));
196   end Set_User_ID;
197
198   --------------------
199   -- Get_Login_Name --
200   --------------------
201
202--  .... Consider using getlogin_r if that is supported.
203--  Use conditional code, based on configurable constant
204--  HAVE_getlogin_r.
205
206   function Get_Login_Name return POSIX.POSIX_String is
207      function getlogin return char_ptr;
208      pragma Import (C, getlogin, getlogin_LINKNAME);
209      Name_Ptr : char_ptr;
210   begin
211      Name_Ptr := getlogin;
212      if Name_Ptr = null then
213         Raise_POSIX_Error;
214      end if;
215      return Form_POSIX_String (Name_Ptr);
216   end Get_Login_Name;
217
218   -----------
219   -- image --
220   -----------
221
222   function Image (ID : User_ID) return Standard.String is
223   begin
224      return User_ID'Image (ID);
225   end Image;
226
227   -----------
228   -- Value --
229   -----------
230
231   function Value (Str : Standard.String) return User_ID is
232   begin
233      return User_ID'Value (Str);
234   end Value;
235
236   --  User Group Identification
237
238   --  type Group_ID is private;
239
240   -----------------------
241   -- Get_Real_Group_ID --
242   -----------------------
243
244   function Get_Real_Group_ID return Group_ID is
245      function getgid return gid_t;
246      pragma Import (C, getgid, getgid_LINKNAME);
247   begin
248      return Group_ID (getgid);
249   end Get_Real_Group_ID;
250
251   ----------------------------
252   -- Get_Effective_Group_ID --
253   ----------------------------
254
255   function Get_Effective_Group_ID return Group_ID is
256      function getegid return gid_t;
257      pragma Import (C, getegid, getegid_LINKNAME);
258   begin
259      return Group_ID (getegid);
260   end Get_Effective_Group_ID;
261
262   ------------------
263   -- Set_Group_ID --
264   ------------------
265
266   procedure Set_Group_ID (ID : Group_ID) is
267      function setgid (gid : gid_t) return int;
268      pragma Import (C, setgid, setgid_LINKNAME);
269   begin
270      Check (setgid (gid_t (ID)));
271   end Set_Group_ID;
272
273   ----------------
274   -- Get_Groups --
275   ----------------
276
277   type Access_Group_ID is access all Group_ID;
278
279   function Get_Groups return Group_List is
280      function getgroups
281        (gidsetsize : int; grouplist : Access_Group_ID) return C.int;
282      pragma Import (C, getgroups, getgroups_LINKNAME);
283   begin
284      loop
285         declare
286            NGroups_1 : constant int := getgroups (0, null);
287            Groups : aliased Group_List (1 .. Integer (NGroups_1));
288            NGroups_2 : int;
289         begin
290            NGroups_2 :=
291              getgroups (Groups'Length, Groups (1)'Unchecked_Access);
292            Check (NGroups_2);
293            if NGroups_1 = NGroups_2 then
294               return Groups;
295            end if;
296         end;
297      end loop;
298      --  the loop is in case some other process changes the number of
299      --  items in the group list,
300      --  before the first and second call to getgroups
301   end Get_Groups;
302
303   -----------
304   -- Image --
305   -----------
306
307   function Image (ID : Group_ID) return Standard.String is
308   begin
309      return Trim_Leading_Blank (Group_ID'Image (ID));
310   end Image;
311
312   -----------
313   -- Value --
314   -----------
315
316   function Value (Str : Standard.String) return Group_ID is
317   begin
318      return Group_ID (Group_ID'Value (Str));
319   end Value;
320
321end POSIX.Process_Identification;
322