1 /* -*-C-*- 2 3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8 This file is part of MIT/GNU Scheme. 9 10 MIT/GNU Scheme is free software; you can redistribute it and/or modify 11 it under the terms of the GNU General Public License as published by 12 the Free Software Foundation; either version 2 of the License, or (at 13 your option) any later version. 14 15 MIT/GNU Scheme is distributed in the hope that it will be useful, but 16 WITHOUT ANY WARRANTY; without even the implied warranty of 17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 General Public License for more details. 19 20 You should have received a copy of the GNU General Public License 21 along with MIT/GNU Scheme; if not, write to the Free Software 22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23 USA. 24 25 */ 26 27 /* Unix-specific process-environment primitives. */ 28 29 #include "scheme.h" 30 #include "prims.h" 31 #include "ux.h" 32 #include "uxtop.h" 33 #include "uxtrap.h" 34 35 extern const char * OS_current_user_name (void); 36 extern const char * OS_current_user_home_directory (void); 37 38 #ifdef HAVE_SOCKETS 39 # include "uxsock.h" 40 #endif 41 42 DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1, 43 "Convert a file system time stamp into a date/time string.") 44 { 45 PRIMITIVE_HEADER (1); 46 CHECK_ARG (1, INTEGER_P); 47 { 48 time_t clock = (arg_index_integer_to_intmax (1, TIME_T_MAX)); 49 char * time_string = (UX_ctime (&clock)); 50 (time_string[24]) = '\0'; 51 PRIMITIVE_RETURN (char_pointer_to_string (time_string)); 52 } 53 } 54 55 DEFINE_PRIMITIVE ("GET-USER-HOME-DIRECTORY", Prim_get_user_home_directory, 1, 1, 56 "Return the file name of a given user's home directory.\n\ 57 The user name argument must be a string.\n\ 58 If no such user is known, #F is returned.") 59 { 60 PRIMITIVE_HEADER (1); 61 { 62 struct passwd * entry = (UX_getpwnam (STRING_ARG (1))); 63 PRIMITIVE_RETURN ((entry == 0) 64 ? SHARP_F 65 : (char_pointer_to_string (entry -> pw_dir))); 66 } 67 } 68 69 DEFINE_PRIMITIVE ("UID->STRING", Prim_uid_to_string, 1, 1, 70 "Return the user name corresponding to UID.\n\ 71 If the argument is not a known user ID, #F is returned.") 72 { 73 PRIMITIVE_HEADER (1); 74 { 75 struct passwd * entry = (UX_getpwuid (arg_nonnegative_integer (1))); 76 PRIMITIVE_RETURN ((entry == 0) 77 ? SHARP_F 78 : (char_pointer_to_string (entry -> pw_name))); 79 } 80 } 81 82 DEFINE_PRIMITIVE ("GID->STRING", Prim_gid_to_string, 1, 1, 83 "Return the group name corresponding to GID.\n\ 84 If the argument is not a known group ID, #F is returned.") 85 { 86 PRIMITIVE_HEADER (1); 87 { 88 struct group * entry = (UX_getgrgid (arg_nonnegative_integer (1))); 89 PRIMITIVE_RETURN ((entry == 0) 90 ? SHARP_F 91 : (char_pointer_to_string (entry -> gr_name))); 92 } 93 } 94 95 DEFINE_PRIMITIVE ("CURRENT-PID", Prim_current_pid, 0, 0, 96 "Return Scheme's PID.") 97 { 98 PRIMITIVE_HEADER (0); 99 PRIMITIVE_RETURN (long_to_integer (UX_getpid ())); 100 } 101 102 DEFINE_PRIMITIVE ("CURRENT-UID", Prim_current_uid, 0, 0, 103 "Return Scheme's effective UID.") 104 { 105 PRIMITIVE_HEADER (0); 106 PRIMITIVE_RETURN (long_to_integer (UX_geteuid ())); 107 } 108 109 DEFINE_PRIMITIVE ("CURRENT-GID", Prim_current_gid, 0, 0, 110 "Return Scheme's effective GID.") 111 { 112 PRIMITIVE_HEADER (0); 113 PRIMITIVE_RETURN (long_to_integer (UX_getegid ())); 114 } 115 116 DEFINE_PRIMITIVE ("REAL-UID", Prim_real_uid, 0, 0, 117 "Return Scheme's real UID.") 118 { 119 PRIMITIVE_HEADER (0); 120 PRIMITIVE_RETURN (long_to_integer (UX_getuid ())); 121 } 122 123 DEFINE_PRIMITIVE ("REAL-GID", Prim_real_gid, 0, 0, 124 "Return Scheme's real GID.") 125 { 126 PRIMITIVE_HEADER (0); 127 PRIMITIVE_RETURN (long_to_integer (UX_getgid ())); 128 } 129 130 DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_current_user_name, 0, 0, 131 "Return (as a string) the user name of the user running Scheme.") 132 { 133 PRIMITIVE_HEADER (0); 134 PRIMITIVE_RETURN (char_pointer_to_string (OS_current_user_name ())); 135 } 136 137 DEFINE_PRIMITIVE ("CURRENT-USER-HOME-DIRECTORY", Prim_current_user_home_directory, 0, 0, 138 "Return the name of the current user's home directory.") 139 { 140 PRIMITIVE_HEADER (0); 141 PRIMITIVE_RETURN 142 (char_pointer_to_string (OS_current_user_home_directory ())); 143 } 144 145 DEFINE_PRIMITIVE ("SYSTEM", Prim_system, 1, 1, 146 "Invoke sh (the Bourne shell) on the string argument.\n\ 147 Wait until the shell terminates, returning its exit status as an integer.") 148 { 149 PRIMITIVE_HEADER (1); 150 PRIMITIVE_RETURN (long_to_integer (UX_system (STRING_ARG (1)))); 151 } 152 153 DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1, 154 "Look up the value of a variable in the user's shell environment.\n\ 155 The argument, a variable name, must be a string.\n\ 156 The result is either a string (the variable's value),\n\ 157 or #F indicating that the variable does not exist.") 158 { 159 PRIMITIVE_HEADER (1); 160 { 161 const char * variable_value = (UX_getenv (STRING_ARG (1))); 162 PRIMITIVE_RETURN ((variable_value == 0) 163 ? SHARP_F 164 : (char_pointer_to_string (variable_value))); 165 } 166 } 167 168 #define HOSTNAMESIZE 1024 169 170 DEFINE_PRIMITIVE ("FULL-HOSTNAME", Prim_full_hostname, 0, 0, 171 "Returns the full hostname (including domain if available) as a string.") 172 { 173 PRIMITIVE_HEADER (0); 174 { 175 char this_host_name [HOSTNAMESIZE]; 176 #ifdef HAVE_SOCKETS 177 struct hostent * this_host_entry; 178 179 STD_VOID_SYSTEM_CALL 180 (syscall_gethostname, 181 (UX_gethostname (this_host_name, HOSTNAMESIZE))); 182 #else 183 strcpy (this_host_name, "unknown-host.unknown.unknown"); 184 #endif 185 186 #ifdef HAVE_SOCKETS 187 this_host_entry = (gethostbyname (this_host_name)); 188 PRIMITIVE_RETURN ((this_host_entry == 0) 189 ? SHARP_F 190 : (char_pointer_to_string (this_host_entry -> h_name))); 191 #else 192 PRIMITIVE_RETURN (char_pointer_to_string (this_host_name)); 193 #endif 194 } 195 } 196 197 DEFINE_PRIMITIVE ("HOSTNAME", Prim_hostname, 0, 0, 198 "Returns the hostname of the machine as a string.") 199 { 200 PRIMITIVE_HEADER (0); 201 { 202 char this_host_name[HOSTNAMESIZE]; 203 204 #ifdef HAVE_SOCKETS 205 STD_VOID_SYSTEM_CALL (syscall_gethostname, 206 UX_gethostname (this_host_name, HOSTNAMESIZE)); 207 #else 208 strcpy (this_host_name, "unknown-host"); 209 #endif 210 PRIMITIVE_RETURN (char_pointer_to_string (this_host_name)); 211 } 212 } 213 214 DEFINE_PRIMITIVE ("INSTRUCTION-ADDRESS->COMPILED-CODE-BLOCK", 215 Prim_instruction_address_to_compiled_code_block, 1, 1, 0) 216 { 217 PRIMITIVE_HEADER (1); 218 #ifdef CC_SUPPORT_P 219 { 220 SCHEME_OBJECT object = (ARG_REF (1)); 221 unsigned long pc; 222 if (INTEGER_P (object)) 223 { 224 if (! (integer_to_ulong_p (object))) 225 error_bad_range_arg (1); 226 pc = (integer_to_ulong (object)); 227 } 228 else 229 { 230 if (!CC_ENTRY_P (object)) 231 error_bad_range_arg (1); 232 pc = ((unsigned long) (CC_ENTRY_ADDRESS (object))); 233 } 234 PRIMITIVE_RETURN (find_ccblock (pc)); 235 } 236 #else 237 error_unimplemented_primitive (); 238 PRIMITIVE_RETURN (UNSPECIFIC); 239 #endif 240 } 241 242 DEFINE_PRIMITIVE ("MACOSX-MAIN-BUNDLE-DIR", 243 Prim_macosx_main_bundle_dir, 0, 0, 0) 244 { 245 PRIMITIVE_HEADER (0); 246 #ifdef __APPLE__ 247 { 248 const char * path = (macosx_main_bundle_dir ()); 249 unsigned int n_words; 250 SCHEME_OBJECT result; 251 252 if (path == 0) 253 PRIMITIVE_RETURN (SHARP_F); 254 n_words = (1 + (STRING_LENGTH_TO_GC_LENGTH (strlen (path)))); 255 if (GC_NEEDED_P (n_words)) 256 { 257 UX_free ((void *) path); 258 Primitive_GC (n_words); 259 } 260 result = (char_pointer_to_string_no_gc (path)); 261 UX_free ((void *) path); 262 PRIMITIVE_RETURN (result); 263 } 264 #else 265 error_unimplemented_primitive (); 266 PRIMITIVE_RETURN (UNSPECIFIC); 267 #endif 268 } 269