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