1 /* process.c
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "unix.h"
32
33 #include <string.h>
34 #include <stdio.h>
35
36 #ifdef HAVE_SYS_TIMES_H
37 # include <sys/times.h>
38 #endif
39
40 #ifndef WIN32
41
42 #if defined(__APPLE__)
43 # include <crt_externs.h>
44 # define environ (* _NSGetEnviron())
45 #elif defined(__ENVIRON_IN_UNISTD_H)
46 # define environ __environ
47 #elif defined(ENVIRON_IN_UNISTD_H)
48 /* Nothing to do */
49 #else
50 /* "extern" in front of the next declaration causes the Ultrix 4.2 linker
51 * to fail, but omitting it no longer works with modern C compilers: */
52 extern char **environ;
53 #endif
54
55 #if defined(HAVE_ENVIRON)
P_Environ()56 static Object P_Environ() {
57 Object ret, cell, str;
58 char *p, **ep;
59 static char c[2];
60 GC_Node2;
61
62 cell = ret = Null;
63 GC_Link2(ret, cell);
64 for (ep = environ; *ep; ep++) {
65 cell = Cons(Null, Null);
66 p = strchr(*ep, '=');
67 if (p)
68 *p++ = 0;
69 else p = c+1;
70 str = Make_String(p, strlen(p));
71 Cdr(cell) = str;
72 str = Make_String(*ep, strlen(*ep));
73 Car(cell) = str;
74 ret = Cons(cell, ret);
75 *--p = '=';
76 }
77 GC_Unlink;
78 return P_Reverse(ret);
79 }
80 #endif
81
General_Exec(int argc,Object * argv,int path)82 static Object General_Exec(int argc, Object *argv, int path) {
83 Object fn, args, p, e;
84 char *fnp, **argp, **envp;
85 int i, len;
86 Alloca_Begin;
87
88 fn = argv[0], args = argv[1];
89 fnp = Get_Strsym(fn);
90 Check_List(args);
91 len = Fast_Length(args);
92 Alloca(argp, char**, (len+1) * sizeof(char*));
93 for (i = 0, p = args; i < len; i++, p = Cdr(p)) {
94 e = Car(p);
95 Get_String_Stack(e, argp[i]);
96 }
97 argp[i] = 0;
98 if (argc == 3) {
99 args = argv[2];
100 Check_List(args);
101 len = Fast_Length(args);
102 Alloca(envp, char**, (len+1) * sizeof(char*));
103 for (i = 0, p = args; i < len; i++, p = Cdr(p)) {
104 struct S_String *s1, *s2;
105
106 e = Car(p);
107 Check_Type(e, T_Pair);
108 Check_Type(Car(e), T_String);
109 Check_Type(Cdr(e), T_String);
110 s1 = STRING(Car(e));
111 s2 = STRING(Cdr(e));
112 Alloca(envp[i], char*, s1->size + 1 + s2->size + 1);
113 sprintf(envp[i], "%.*s=%.*s", s1->size, s1->data,
114 s2->size, s2->data);
115 }
116 envp[i] = 0;
117 Exit_Handler();
118 #if 0
119 if (path)
120 (void)execvpe(fnp, argp, envp); /* ... doesn't exist */
121 else
122 #endif
123 (void)execve(fnp, argp, envp);
124 } else {
125 Exit_Handler();
126 if (path)
127 (void)execvp(fnp, argp);
128 else
129 (void)execv(fnp, argp);
130 }
131 Alloca_End;
132 Raise_System_Error1("~s: ~E", fn);
133 }
134
P_Exec(int argc,Object * argv)135 static Object P_Exec(int argc, Object *argv) {
136 return General_Exec(argc, argv, 0);
137 }
138
P_Exec_Path(int argc,Object * argv)139 static Object P_Exec_Path(int argc, Object *argv) {
140 if (argc == 3) /* There is no execvpe (yet?). */
141 Primitive_Error("environment argument not supported");
142 return General_Exec(argc, argv, 1);
143 }
144
P_Fork()145 static Object P_Fork() {
146 int pid;
147
148 switch (pid = fork()) {
149 case -1:
150 Raise_System_Error("~E");
151 case 0:
152 Call_Onfork();
153 }
154 return Make_Integer(pid);
155 }
156
P_Getenv(Object e)157 static Object P_Getenv(Object e) {
158 extern char *getenv();
159 char *s;
160
161 return (s = getenv(Get_String(e))) ? Make_String(s, strlen(s)) : False;
162 }
163
P_Getlogin()164 static Object P_Getlogin() {
165 extern char *getlogin();
166 char *s;
167
168 Disable_Interrupts;
169 s = getlogin();
170 Enable_Interrupts;
171 if (s == 0)
172 Raise_Error("cannot get login name");
173 return Make_String(s, strlen(s));
174 }
175
P_Getgids()176 static Object P_Getgids() { return Integer_Pair(getgid(), getegid()); }
177
P_Getpids()178 static Object P_Getpids() { return Integer_Pair(getpid(), getppid()); }
179
P_Getuids()180 static Object P_Getuids() { return Integer_Pair(getuid(), geteuid()); }
181
P_Getgroups()182 static Object P_Getgroups() {
183 int i, n;
184 GETGROUPS_TYPE *p;
185 Object ret, next;
186 Alloca_Begin;
187 GC_Node2;
188
189 /* gcc may complain under SunOS 4.x, because the prototype says
190 * that the type of the 2nd argument is unsigned short*, not int.
191 * But int is right.
192 */
193 if ((n = getgroups(0, (GETGROUPS_TYPE *)0)) == -1)
194 #ifdef NGROUPS
195 n = NGROUPS; /* 4.3BSD */
196 #else
197 Raise_System_Error("~E");
198 #endif
199 Alloca(p, GETGROUPS_TYPE*, n*sizeof(GETGROUPS_TYPE));
200 (void)getgroups(n, p);
201 next = ret = P_Make_List(Make_Integer(n), Null);
202 GC_Link2(ret, next);
203 for (i = 0; i < n; i++, next = Cdr(next)) {
204 Object x;
205
206 x = Make_Unsigned((unsigned)p[i]);
207 Car(next) = x;
208 }
209 GC_Unlink;
210 Alloca_End;
211 return ret;
212 }
213
P_Nice(Object incr)214 static Object P_Nice(Object incr) {
215 int ret;
216
217 errno = 0;
218 if ((ret = nice(Get_Integer(incr))) == -1 && errno != 0)
219 Raise_System_Error("~E");
220 return Make_Integer(ret);
221 }
222
Open_Pipe(Object cmd,int flags)223 static Object Open_Pipe(Object cmd, int flags) {
224 FILE *fp;
225 Object ret;
226
227 Disable_Interrupts;
228 if ((fp = popen(Get_String(cmd), flags == P_INPUT ? "r" : "w")) == 0) {
229 Enable_Interrupts;
230 Raise_Error("cannot open pipe to process");
231 }
232 ret = Make_Port(flags, fp, Make_String("pipe-port", 9));
233 PORT(ret)->closefun = pclose;
234 Register_Object(ret, (GENERIC)0, Terminate_File, 0);
235 Enable_Interrupts;
236 return ret;
237 }
238
P_Open_Input_Pipe(Object cmd)239 static Object P_Open_Input_Pipe(Object cmd) {
240 return Open_Pipe(cmd, P_INPUT);
241 }
242
P_Open_Output_Pipe(Object cmd)243 static Object P_Open_Output_Pipe(Object cmd) {
244 return Open_Pipe(cmd, 0);
245 }
246
P_Process_Resources(Object ret1,Object ret2)247 static Object P_Process_Resources(Object ret1, Object ret2) {
248 static int hzval;
249 struct tms tms;
250 Object x;
251 GC_Node2;
252
253 if (hzval == 0) {
254 #ifdef HZ
255 hzval = HZ;
256 #else
257 #ifdef CLK_TCK
258 hzval = CLK_TCK;
259 #else
260 #ifdef _SC_CLK_TCK
261 hzval = (int)sysconf(_SC_CLK_TCK);
262 #else
263 hzval = 60; /* Fallback for 4.3BSD. I don't have a better idea. */
264 #endif
265 #endif
266 #endif
267 }
268 Check_Result_Vector(ret1, 2);
269 Check_Result_Vector(ret2, 2);
270 (void)times(&tms);
271 GC_Link2(ret1, ret2);
272 x = Make_Unsigned_Long((unsigned long)tms.tms_utime);
273 VECTOR(ret1)->data[0] = x;
274 x = Make_Unsigned_Long((unsigned long)tms.tms_stime);
275 VECTOR(ret1)->data[1] = x;
276 x = Make_Unsigned_Long((unsigned long)tms.tms_cutime);
277 VECTOR(ret2)->data[0] = x;
278 x = Make_Unsigned_Long((unsigned long)tms.tms_cstime);
279 VECTOR(ret2)->data[1] = x;
280 GC_Unlink;
281 return Make_Integer(hzval);
282 }
283
P_Sleep(Object s)284 static Object P_Sleep(Object s) {
285 (void)sleep(Get_Unsigned(s));
286 return Void;
287 }
288
P_System(Object cmd)289 static Object P_System(Object cmd) {
290 int n, pid, status;
291 char *s = Get_String(cmd);
292
293 #ifdef HAVE_VFORK
294 switch (pid = vfork()) {
295 #else
296 switch (pid = fork()) {
297 #endif
298 case -1:
299 Raise_System_Error("fork: ~E");
300 case 0:
301 for (n = Num_Filedescriptors(); n >= 3; n--)
302 (void)close(n);
303 execl("/bin/sh", "sh", "-c", s, (char *)0);
304 _exit(127);
305 default:
306 Disable_Interrupts;
307 while ((n = wait(&status)) != pid && n != -1)
308 ;
309 Enable_Interrupts;
310 }
311 /* Can this happen?
312 if (n == -1)
313 return False;
314 */
315 n = status & 0377;
316 if (n)
317 return Cons(Make_Integer(n), Null);
318 return Make_Integer((status >> 8) & 0377);
319 }
320
321 static Object P_Umask(Object mask) {
322 return Make_Integer(umask(Get_Integer(mask)));
323 }
324
325 static Object P_Working_Directory() {
326 char *buf;
327 int max = Path_Max()+2; /* getcwd() needs two extra bytes */
328 Object ret;
329 #if !defined(HAVE_GETCWD) && !defined(HAVE_GETWD)
330 FILE *fp;
331 char *p;
332 #endif
333 Alloca_Begin;
334
335 Alloca(buf, char*, max);
336 Disable_Interrupts;
337 #ifdef HAVE_GETCWD
338 if (getcwd(buf, max) == 0) {
339 Saved_Errno = errno;
340 Alloca_End;
341 Enable_Interrupts;
342 Raise_System_Error("~E");
343 }
344 #else
345 #ifdef HAVE_GETWD
346 if (getwd(buf) == 0) {
347 Alloca_End;
348 Enable_Interrupts;
349 Raise_Error(buf);
350 }
351 #else
352 if ((fp = popen("pwd", "r")) == 0) {
353 err:
354 Alloca_End;
355 Enable_Interrupts;
356 Raise_Error("cannot get output from pwd");
357 }
358 if (fgets(buf, max, fp) == 0)
359 goto err;
360 if (p = strchr(buf, '\n')) *p = '\0';
361 (void)pclose(fp);
362 #endif
363 #endif
364 Enable_Interrupts;
365 ret = Make_String(buf, strlen(buf));
366 Alloca_End;
367 return ret;
368 }
369
370 void elk_init_unix_process() {
371 #if defined(HAVE_ENVIRON)
372 Def_Prim(P_Environ, "unix-environ", 0, 0, EVAL);
373 #endif
374 Def_Prim(P_Exec, "unix-exec", 2, 3, VARARGS);
375 Def_Prim(P_Exec_Path, "unix-exec-path", 2, 3, VARARGS);
376 Def_Prim(P_Fork, "unix-fork", 0, 0, EVAL);
377 Def_Prim(P_Getenv, "unix-getenv", 1, 1, EVAL);
378 Def_Prim(P_Getlogin, "unix-getlogin", 0, 0, EVAL);
379 Def_Prim(P_Getgids, "unix-getgids", 0, 0, EVAL);
380 Def_Prim(P_Getpids, "unix-getpids", 0, 0, EVAL);
381 Def_Prim(P_Getuids, "unix-getuids", 0, 0, EVAL);
382 Def_Prim(P_Getgroups, "unix-getgroups", 0, 0, EVAL);
383 Def_Prim(P_Nice, "unix-nice", 1, 1, EVAL);
384 Def_Prim(P_Open_Input_Pipe, "unix-open-input-pipe", 1, 1, EVAL);
385 Def_Prim(P_Open_Output_Pipe, "unix-open-output-pipe", 1, 1, EVAL);
386 Def_Prim(P_Process_Resources, "unix-process-resources-vector-fill!",
387 2, 2, EVAL);
388 Def_Prim(P_Sleep, "unix-sleep", 1, 1, EVAL);
389 Def_Prim(P_System, "unix-system", 1, 1, EVAL);
390 Def_Prim(P_Umask, "unix-umask", 1, 1, EVAL);
391 Def_Prim(P_Working_Directory, "unix-working-directory", 0, 0, EVAL);
392 }
393 #endif
394