Commit | Line | Data |
---|---|---|
7dc6e754 | 1 | /* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. |
0f2d19dd JB |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
0f2d19dd JB |
41 | \f |
42 | ||
43 | #include <stdio.h> | |
44 | #include "_scm.h" | |
20e6290e | 45 | #include "fports.h" |
20e6290e | 46 | #include "scmsigs.h" |
20e6290e | 47 | #include "feature.h" |
0f2d19dd | 48 | |
20e6290e | 49 | #include "posix.h" |
0f2d19dd JB |
50 | \f |
51 | ||
02b754d3 GH |
52 | #ifdef HAVE_STRING_H |
53 | #include <string.h> | |
54 | #endif | |
0f2d19dd JB |
55 | #ifdef TIME_WITH_SYS_TIME |
56 | # include <sys/time.h> | |
57 | # include <time.h> | |
58 | #else | |
59 | # if HAVE_SYS_TIME_H | |
60 | # include <sys/time.h> | |
61 | # else | |
62 | # include <time.h> | |
63 | # endif | |
64 | #endif | |
65 | ||
66 | #ifdef HAVE_UNISTD_H | |
67 | #include <unistd.h> | |
95b88819 GH |
68 | #else |
69 | #ifndef ttyname | |
70 | extern char *ttyname(); | |
71 | #endif | |
0f2d19dd JB |
72 | #endif |
73 | ||
3594582b | 74 | #ifdef LIBC_H_WITH_UNISTD_H |
bab0f4e5 JB |
75 | #include <libc.h> |
76 | #endif | |
77 | ||
8cc71382 | 78 | #include <sys/types.h> |
0f2d19dd JB |
79 | #include <sys/stat.h> |
80 | #include <fcntl.h> | |
81 | ||
82 | #include <pwd.h> | |
83 | ||
84 | #if HAVE_SYS_WAIT_H | |
85 | # include <sys/wait.h> | |
86 | #endif | |
87 | #ifndef WEXITSTATUS | |
88 | # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) | |
89 | #endif | |
90 | #ifndef WIFEXITED | |
91 | # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) | |
92 | #endif | |
93 | ||
94 | #include <signal.h> | |
95 | ||
0f2d19dd JB |
96 | extern FILE *popen (); |
97 | extern char ** environ; | |
98 | ||
99 | #include <grp.h> | |
100 | #include <sys/utsname.h> | |
101 | ||
102 | #if HAVE_DIRENT_H | |
103 | # include <dirent.h> | |
104 | # define NAMLEN(dirent) strlen((dirent)->d_name) | |
105 | #else | |
106 | # define dirent direct | |
107 | # define NAMLEN(dirent) (dirent)->d_namlen | |
108 | # if HAVE_SYS_NDIR_H | |
109 | # include <sys/ndir.h> | |
110 | # endif | |
111 | # if HAVE_SYS_DIR_H | |
112 | # include <sys/dir.h> | |
113 | # endif | |
114 | # if HAVE_NDIR_H | |
115 | # include <ndir.h> | |
116 | # endif | |
117 | #endif | |
118 | ||
0f2d19dd JB |
119 | #ifdef HAVE_SETLOCALE |
120 | #include <locale.h> | |
121 | #endif | |
122 | ||
bab0f4e5 JB |
123 | /* Some Unix systems don't define these. CPP hair is dangerous, but |
124 | this seems safe enough... */ | |
125 | #ifndef R_OK | |
126 | #define R_OK 4 | |
127 | #endif | |
128 | ||
129 | #ifndef W_OK | |
130 | #define W_OK 2 | |
131 | #endif | |
132 | ||
133 | #ifndef X_OK | |
134 | #define X_OK 1 | |
135 | #endif | |
136 | ||
137 | #ifndef F_OK | |
138 | #define F_OK 0 | |
139 | #endif | |
398609a5 JB |
140 | |
141 | /* On NextStep, <utime.h> doesn't define struct utime, unless we | |
142 | #define _POSIX_SOURCE before #including it. I think this is less | |
143 | of a kludge than defining struct utimbuf ourselves. */ | |
144 | #ifdef UTIMBUF_NEEDS_POSIX | |
145 | #define _POSIX_SOURCE | |
146 | #endif | |
147 | ||
148 | #ifdef HAVE_SYS_UTIME_H | |
149 | #include <sys/utime.h> | |
150 | #endif | |
151 | ||
152 | #ifdef HAVE_UTIME_H | |
153 | #include <utime.h> | |
154 | #endif | |
155 | ||
156 | /* Please don't add any more #includes or #defines here. The hack | |
157 | above means that _POSIX_SOURCE may be #defined, which will | |
158 | encourage header files to do strange things. */ | |
159 | ||
0f2d19dd | 160 | \f |
bc45012d JB |
161 | SCM_SYMBOL (sym_read_pipe, "read pipe"); |
162 | SCM_SYMBOL (sym_write_pipe, "write pipe"); | |
0f2d19dd | 163 | |
f93ddd39 | 164 | SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe); |
1cc91f1b | 165 | |
0f2d19dd | 166 | SCM |
f93ddd39 | 167 | scm_pipe () |
0f2d19dd JB |
168 | { |
169 | int fd[2], rv; | |
170 | FILE *f_rd, *f_wt; | |
171 | SCM p_rd, p_wt; | |
02b754d3 | 172 | |
0f2d19dd JB |
173 | rv = pipe (fd); |
174 | if (rv) | |
f93ddd39 | 175 | scm_syserror (s_pipe); |
0f2d19dd JB |
176 | f_rd = fdopen (fd[0], "r"); |
177 | if (!f_rd) | |
178 | { | |
179 | SCM_SYSCALL (close (fd[0])); | |
180 | SCM_SYSCALL (close (fd[1])); | |
f93ddd39 | 181 | scm_syserror (s_pipe); |
0f2d19dd JB |
182 | } |
183 | f_wt = fdopen (fd[1], "w"); | |
184 | if (!f_wt) | |
185 | { | |
186 | int en; | |
187 | en = errno; | |
188 | fclose (f_rd); | |
189 | SCM_SYSCALL (close (fd[1])); | |
02b754d3 | 190 | errno = en; |
f93ddd39 | 191 | scm_syserror (s_pipe); |
0f2d19dd | 192 | } |
bc45012d JB |
193 | |
194 | p_rd = scm_stdio_to_port (f_rd, "r", sym_read_pipe); | |
195 | p_wt = scm_stdio_to_port (f_wt, "w", sym_write_pipe); | |
02b754d3 | 196 | |
0f2d19dd JB |
197 | SCM_ALLOW_INTS; |
198 | return scm_cons (p_rd, p_wt); | |
199 | } | |
200 | ||
201 | ||
0e958795 | 202 | #ifdef HAVE_GETGROUPS |
f93ddd39 | 203 | SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups); |
1cc91f1b | 204 | |
0f2d19dd | 205 | SCM |
f93ddd39 | 206 | scm_getgroups() |
0f2d19dd JB |
207 | { |
208 | SCM grps, ans; | |
209 | int ngroups = getgroups (0, NULL); | |
02b754d3 | 210 | if (!ngroups) |
f93ddd39 | 211 | scm_syserror (s_getgroups); |
0f2d19dd JB |
212 | SCM_NEWCELL(grps); |
213 | SCM_DEFER_INTS; | |
214 | { | |
215 | GETGROUPS_T *groups; | |
216 | int val; | |
217 | ||
bab0f4e5 | 218 | groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T), |
f93ddd39 | 219 | s_getgroups); |
0f2d19dd JB |
220 | val = getgroups(ngroups, groups); |
221 | if (val < 0) | |
222 | { | |
223 | scm_must_free((char *)groups); | |
f93ddd39 | 224 | scm_syserror (s_getgroups); |
0f2d19dd JB |
225 | } |
226 | SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ | |
227 | SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); | |
228 | SCM_ALLOW_INTS; | |
a8741caa | 229 | ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED); |
0f2d19dd JB |
230 | while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); |
231 | SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ | |
232 | return ans; | |
233 | } | |
234 | } | |
0e958795 | 235 | #endif |
0f2d19dd JB |
236 | |
237 | ||
f93ddd39 | 238 | SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid); |
1cc91f1b | 239 | |
0f2d19dd | 240 | SCM |
f93ddd39 | 241 | scm_getpwuid (user) |
0f2d19dd | 242 | SCM user; |
0f2d19dd JB |
243 | { |
244 | SCM result; | |
245 | struct passwd *entry; | |
246 | SCM *ve; | |
247 | ||
a8741caa | 248 | result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED); |
0f2d19dd JB |
249 | ve = SCM_VELTS (result); |
250 | if (SCM_UNBNDP (user) || SCM_FALSEP (user)) | |
251 | { | |
252 | SCM_DEFER_INTS; | |
253 | SCM_SYSCALL (entry = getpwent ()); | |
3d781d49 JB |
254 | if (! entry) |
255 | { | |
256 | SCM_ALLOW_INTS; | |
257 | return SCM_BOOL_F; | |
258 | } | |
0f2d19dd JB |
259 | } |
260 | else if (SCM_INUMP (user)) | |
261 | { | |
262 | SCM_DEFER_INTS; | |
263 | entry = getpwuid (SCM_INUM (user)); | |
264 | } | |
265 | else | |
266 | { | |
f93ddd39 | 267 | SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); |
0f2d19dd JB |
268 | if (SCM_SUBSTRP (user)) |
269 | user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); | |
270 | SCM_DEFER_INTS; | |
271 | entry = getpwnam (SCM_ROCHARS (user)); | |
272 | } | |
273 | if (!entry) | |
20752a34 | 274 | scm_misc_error (s_getpwuid, "entry not found", SCM_EOL); |
02b754d3 | 275 | |
0f2d19dd JB |
276 | ve[0] = scm_makfrom0str (entry->pw_name); |
277 | ve[1] = scm_makfrom0str (entry->pw_passwd); | |
278 | ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid); | |
279 | ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid); | |
280 | ve[4] = scm_makfrom0str (entry->pw_gecos); | |
281 | if (!entry->pw_dir) | |
282 | ve[5] = scm_makfrom0str (""); | |
283 | else | |
284 | ve[5] = scm_makfrom0str (entry->pw_dir); | |
285 | if (!entry->pw_shell) | |
286 | ve[6] = scm_makfrom0str (""); | |
287 | else | |
288 | ve[6] = scm_makfrom0str (entry->pw_shell); | |
289 | SCM_ALLOW_INTS; | |
290 | return result; | |
291 | } | |
292 | ||
293 | ||
0e958795 | 294 | #ifdef HAVE_SETPWENT |
0f2d19dd | 295 | SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent); |
1cc91f1b | 296 | |
0f2d19dd JB |
297 | SCM |
298 | scm_setpwent (arg) | |
299 | SCM arg; | |
0f2d19dd JB |
300 | { |
301 | if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) | |
302 | endpwent (); | |
303 | else | |
304 | setpwent (); | |
305 | return SCM_UNSPECIFIED; | |
306 | } | |
0e958795 | 307 | #endif |
0f2d19dd JB |
308 | |
309 | ||
310 | ||
311 | /* Combines getgrgid and getgrnam. */ | |
f93ddd39 | 312 | SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid); |
1cc91f1b | 313 | |
0f2d19dd | 314 | SCM |
f93ddd39 | 315 | scm_getgrgid (name) |
0f2d19dd | 316 | SCM name; |
0f2d19dd JB |
317 | { |
318 | SCM result; | |
319 | struct group *entry; | |
320 | SCM *ve; | |
a8741caa | 321 | result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); |
0f2d19dd JB |
322 | ve = SCM_VELTS (result); |
323 | SCM_DEFER_INTS; | |
324 | if (SCM_UNBNDP (name) || (name == SCM_BOOL_F)) | |
3d781d49 JB |
325 | { |
326 | SCM_SYSCALL (entry = getgrent ()); | |
327 | if (! entry) | |
328 | { | |
329 | SCM_ALLOW_INTS; | |
330 | return SCM_BOOL_F; | |
331 | } | |
332 | } | |
0f2d19dd JB |
333 | else if (SCM_INUMP (name)) |
334 | SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); | |
335 | else | |
336 | { | |
ae2fa5bc GH |
337 | SCM_ASSERT (SCM_NIMP (name) && SCM_ROSTRINGP (name), name, SCM_ARG1, |
338 | s_getgrgid); | |
89958ad0 | 339 | SCM_COERCE_SUBSTR (name); |
ae2fa5bc | 340 | SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name))); |
0f2d19dd JB |
341 | } |
342 | if (!entry) | |
f93ddd39 | 343 | scm_syserror (s_getgrgid); |
02b754d3 | 344 | |
0f2d19dd JB |
345 | ve[0] = scm_makfrom0str (entry->gr_name); |
346 | ve[1] = scm_makfrom0str (entry->gr_passwd); | |
347 | ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); | |
348 | ve[3] = scm_makfromstrs (-1, entry->gr_mem); | |
349 | SCM_ALLOW_INTS; | |
350 | return result; | |
351 | } | |
352 | ||
353 | ||
354 | ||
355 | SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent); | |
1cc91f1b | 356 | |
0f2d19dd JB |
357 | SCM |
358 | scm_setgrent (arg) | |
359 | SCM arg; | |
0f2d19dd JB |
360 | { |
361 | if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) | |
362 | endgrent (); | |
363 | else | |
364 | setgrent (); | |
365 | return SCM_UNSPECIFIED; | |
366 | } | |
367 | ||
368 | ||
369 | ||
f93ddd39 | 370 | SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill); |
1cc91f1b | 371 | |
0f2d19dd | 372 | SCM |
f93ddd39 | 373 | scm_kill (pid, sig) |
0f2d19dd JB |
374 | SCM pid; |
375 | SCM sig; | |
0f2d19dd | 376 | { |
f93ddd39 GH |
377 | SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill); |
378 | SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill); | |
0f2d19dd | 379 | /* Signal values are interned in scm_init_posix(). */ |
02b754d3 | 380 | if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) |
f93ddd39 | 381 | scm_syserror (s_kill); |
02b754d3 | 382 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
383 | } |
384 | ||
385 | ||
386 | ||
f93ddd39 | 387 | SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid); |
1cc91f1b | 388 | |
0f2d19dd | 389 | SCM |
f93ddd39 | 390 | scm_waitpid (pid, options) |
0f2d19dd JB |
391 | SCM pid; |
392 | SCM options; | |
0f2d19dd | 393 | { |
1fd838af | 394 | #ifdef HAVE_WAITPID |
0f2d19dd JB |
395 | int i; |
396 | int status; | |
397 | int ioptions; | |
f93ddd39 | 398 | SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid); |
0f2d19dd JB |
399 | if (SCM_UNBNDP (options)) |
400 | ioptions = 0; | |
401 | else | |
402 | { | |
f93ddd39 | 403 | SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid); |
0f2d19dd JB |
404 | /* Flags are interned in scm_init_posix. */ |
405 | ioptions = SCM_INUM (options); | |
406 | } | |
407 | SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); | |
02b754d3 | 408 | if (i == -1) |
f93ddd39 | 409 | scm_syserror (s_waitpid); |
02b754d3 | 410 | return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); |
1fd838af | 411 | #else |
f93ddd39 | 412 | scm_sysmissing (s_waitpid); |
1fd838af JB |
413 | /* not reached. */ |
414 | return SCM_BOOL_F; | |
415 | #endif | |
0f2d19dd JB |
416 | } |
417 | ||
67ec3667 GH |
418 | SCM_PROC (s_status_exit_val, "status:exit-val", 1, 0, 0, scm_status_exit_val); |
419 | SCM | |
420 | scm_status_exit_val (status) | |
421 | SCM status; | |
422 | { | |
e67dc2be JB |
423 | int lstatus; |
424 | ||
67ec3667 | 425 | SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_exit_val); |
e67dc2be JB |
426 | |
427 | /* On Ultrix, the WIF... macros assume their argument is an lvalue; | |
428 | go figure. SCM_INUM does not yield an lvalue. */ | |
429 | lstatus = SCM_INUM (status); | |
430 | if (WIFEXITED (lstatus)) | |
431 | return (SCM_MAKINUM (WEXITSTATUS (lstatus))); | |
67ec3667 GH |
432 | else |
433 | return SCM_BOOL_F; | |
434 | } | |
e67dc2be | 435 | |
67ec3667 GH |
436 | SCM_PROC (s_status_term_sig, "status:term-sig", 1, 0, 0, scm_status_term_sig); |
437 | SCM | |
438 | scm_status_term_sig (status) | |
439 | SCM status; | |
440 | { | |
e67dc2be JB |
441 | int lstatus; |
442 | ||
67ec3667 | 443 | SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_term_sig); |
e67dc2be JB |
444 | |
445 | lstatus = SCM_INUM (status); | |
446 | if (WIFSIGNALED (lstatus)) | |
447 | return SCM_MAKINUM (WTERMSIG (lstatus)); | |
67ec3667 GH |
448 | else |
449 | return SCM_BOOL_F; | |
450 | } | |
0f2d19dd | 451 | |
67ec3667 GH |
452 | SCM_PROC (s_status_stop_sig, "status:stop-sig", 1, 0, 0, scm_status_stop_sig); |
453 | SCM | |
454 | scm_status_stop_sig (status) | |
455 | SCM status; | |
456 | { | |
e67dc2be JB |
457 | int lstatus; |
458 | ||
67ec3667 | 459 | SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_stop_sig); |
e67dc2be JB |
460 | |
461 | lstatus = SCM_INUM (status); | |
462 | if (WIFSTOPPED (lstatus)) | |
463 | return SCM_MAKINUM (WSTOPSIG (lstatus)); | |
67ec3667 GH |
464 | else |
465 | return SCM_BOOL_F; | |
466 | } | |
0f2d19dd JB |
467 | |
468 | SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); | |
1cc91f1b | 469 | |
0f2d19dd JB |
470 | SCM |
471 | scm_getppid () | |
0f2d19dd JB |
472 | { |
473 | return SCM_MAKINUM (0L + getppid ()); | |
474 | } | |
475 | ||
476 | ||
477 | ||
478 | SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); | |
1cc91f1b | 479 | |
0f2d19dd JB |
480 | SCM |
481 | scm_getuid () | |
0f2d19dd JB |
482 | { |
483 | return SCM_MAKINUM (0L + getuid ()); | |
484 | } | |
485 | ||
486 | ||
487 | ||
488 | SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); | |
1cc91f1b | 489 | |
0f2d19dd JB |
490 | SCM |
491 | scm_getgid () | |
0f2d19dd JB |
492 | { |
493 | return SCM_MAKINUM (0L + getgid ()); | |
494 | } | |
495 | ||
496 | ||
497 | ||
498 | SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); | |
1cc91f1b | 499 | |
0f2d19dd JB |
500 | SCM |
501 | scm_geteuid () | |
0f2d19dd JB |
502 | { |
503 | #ifdef HAVE_GETEUID | |
504 | return SCM_MAKINUM (0L + geteuid ()); | |
505 | #else | |
506 | return SCM_MAKINUM (0L + getuid ()); | |
507 | #endif | |
508 | } | |
509 | ||
510 | ||
511 | ||
512 | SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid); | |
1cc91f1b | 513 | |
0f2d19dd JB |
514 | SCM |
515 | scm_getegid () | |
0f2d19dd JB |
516 | { |
517 | #ifdef HAVE_GETEUID | |
518 | return SCM_MAKINUM (0L + getegid ()); | |
519 | #else | |
520 | return SCM_MAKINUM (0L + getgid ()); | |
521 | #endif | |
522 | } | |
523 | ||
524 | ||
f93ddd39 | 525 | SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid); |
1cc91f1b | 526 | |
0f2d19dd | 527 | SCM |
f93ddd39 | 528 | scm_setuid (id) |
0f2d19dd | 529 | SCM id; |
0f2d19dd | 530 | { |
f93ddd39 | 531 | SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid); |
02b754d3 | 532 | if (setuid (SCM_INUM (id)) != 0) |
f93ddd39 | 533 | scm_syserror (s_setuid); |
02b754d3 | 534 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
535 | } |
536 | ||
f93ddd39 | 537 | SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid); |
1cc91f1b | 538 | |
0f2d19dd | 539 | SCM |
f93ddd39 | 540 | scm_setgid (id) |
0f2d19dd | 541 | SCM id; |
0f2d19dd | 542 | { |
f93ddd39 | 543 | SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid); |
02b754d3 | 544 | if (setgid (SCM_INUM (id)) != 0) |
f93ddd39 | 545 | scm_syserror (s_setgid); |
02b754d3 | 546 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
547 | } |
548 | ||
f93ddd39 | 549 | SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid); |
1cc91f1b | 550 | |
0f2d19dd | 551 | SCM |
f93ddd39 | 552 | scm_seteuid (id) |
0f2d19dd | 553 | SCM id; |
0f2d19dd | 554 | { |
02b754d3 GH |
555 | int rv; |
556 | ||
f93ddd39 | 557 | SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid); |
0f2d19dd | 558 | #ifdef HAVE_SETEUID |
02b754d3 | 559 | rv = seteuid (SCM_INUM (id)); |
0f2d19dd | 560 | #else |
02b754d3 | 561 | rv = setuid (SCM_INUM (id)); |
0f2d19dd | 562 | #endif |
02b754d3 | 563 | if (rv != 0) |
f93ddd39 | 564 | scm_syserror (s_seteuid); |
02b754d3 | 565 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
566 | } |
567 | ||
0e958795 | 568 | #ifdef HAVE_SETEGID |
f93ddd39 | 569 | SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid); |
1cc91f1b | 570 | |
0f2d19dd | 571 | SCM |
f93ddd39 | 572 | scm_setegid (id) |
0f2d19dd | 573 | SCM id; |
0f2d19dd | 574 | { |
02b754d3 GH |
575 | int rv; |
576 | ||
f93ddd39 | 577 | SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid); |
0f2d19dd | 578 | #ifdef HAVE_SETEUID |
02b754d3 | 579 | rv = setegid (SCM_INUM (id)); |
0f2d19dd | 580 | #else |
02b754d3 | 581 | rv = setgid (SCM_INUM (id)); |
0f2d19dd | 582 | #endif |
02b754d3 | 583 | if (rv != 0) |
f93ddd39 | 584 | scm_syserror (s_setegid); |
02b754d3 GH |
585 | return SCM_UNSPECIFIED; |
586 | ||
0f2d19dd | 587 | } |
0e958795 | 588 | #endif |
0f2d19dd JB |
589 | |
590 | SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); | |
591 | SCM | |
592 | scm_getpgrp () | |
593 | { | |
594 | int (*fn)(); | |
4625e44f | 595 | fn = (int (*) ()) getpgrp; |
0f2d19dd JB |
596 | return SCM_MAKINUM (fn (0)); |
597 | } | |
598 | ||
f93ddd39 | 599 | SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid); |
0f2d19dd JB |
600 | SCM |
601 | scm_setpgid (pid, pgid) | |
602 | SCM pid, pgid; | |
603 | { | |
1fd838af | 604 | #ifdef HAVE_SETPGID |
f93ddd39 GH |
605 | SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); |
606 | SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); | |
02b754d3 GH |
607 | /* FIXME(?): may be known as setpgrp. */ |
608 | if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) | |
f93ddd39 | 609 | scm_syserror (s_setpgid); |
02b754d3 | 610 | return SCM_UNSPECIFIED; |
1fd838af | 611 | #else |
f93ddd39 | 612 | scm_sysmissing (s_setpgid); |
1fd838af JB |
613 | /* not reached. */ |
614 | return SCM_BOOL_F; | |
615 | #endif | |
0f2d19dd JB |
616 | } |
617 | ||
f93ddd39 | 618 | SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid); |
0f2d19dd JB |
619 | SCM |
620 | scm_setsid () | |
621 | { | |
1fd838af | 622 | #ifdef HAVE_SETSID |
0f2d19dd | 623 | pid_t sid = setsid (); |
02b754d3 | 624 | if (sid == -1) |
f93ddd39 | 625 | scm_syserror (s_setsid); |
02b754d3 | 626 | return SCM_UNSPECIFIED; |
1fd838af | 627 | #else |
f93ddd39 | 628 | scm_sysmissing (s_setsid); |
1fd838af JB |
629 | /* not reached. */ |
630 | return SCM_BOOL_F; | |
631 | #endif | |
0f2d19dd JB |
632 | } |
633 | ||
02b754d3 | 634 | SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname); |
1cc91f1b | 635 | |
0f2d19dd JB |
636 | SCM |
637 | scm_ttyname (port) | |
638 | SCM port; | |
0f2d19dd JB |
639 | { |
640 | char *ans; | |
641 | int fd; | |
78446828 MV |
642 | |
643 | port = SCM_COERCE_OUTPORT (port); | |
0f2d19dd JB |
644 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); |
645 | if (scm_tc16_fport != SCM_TYP16 (port)) | |
646 | return SCM_BOOL_F; | |
647 | fd = fileno ((FILE *)SCM_STREAM (port)); | |
02b754d3 | 648 | if (fd == -1) |
52859adf | 649 | scm_syserror (s_ttyname); |
02b754d3 GH |
650 | SCM_SYSCALL (ans = ttyname (fd)); |
651 | if (!ans) | |
52859adf | 652 | scm_syserror (s_ttyname); |
0f2d19dd | 653 | /* ans could be overwritten by another call to ttyname */ |
02b754d3 | 654 | return (scm_makfrom0str (ans)); |
0f2d19dd JB |
655 | } |
656 | ||
657 | ||
f93ddd39 | 658 | SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid); |
0f2d19dd JB |
659 | SCM |
660 | scm_ctermid () | |
661 | { | |
1fd838af | 662 | #ifdef HAVE_CTERMID |
0f2d19dd | 663 | char *result = ctermid (NULL); |
02b754d3 | 664 | if (*result == '\0') |
f93ddd39 | 665 | scm_syserror (s_ctermid); |
02b754d3 | 666 | return scm_makfrom0str (result); |
1fd838af | 667 | #else |
f93ddd39 | 668 | scm_sysmissing (s_ctermid); |
1fd838af JB |
669 | /* not reached. */ |
670 | return SCM_BOOL_F; | |
671 | #endif | |
0f2d19dd JB |
672 | } |
673 | ||
f93ddd39 | 674 | SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); |
0f2d19dd JB |
675 | SCM |
676 | scm_tcgetpgrp (port) | |
677 | SCM port; | |
678 | { | |
1fd838af | 679 | #ifdef HAVE_TCGETPGRP |
0f2d19dd JB |
680 | int fd; |
681 | pid_t pgid; | |
78446828 MV |
682 | |
683 | port = SCM_COERCE_OUTPORT (port); | |
684 | ||
f93ddd39 | 685 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); |
0f2d19dd JB |
686 | fd = fileno ((FILE *)SCM_STREAM (port)); |
687 | if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) | |
f93ddd39 | 688 | scm_syserror (s_tcgetpgrp); |
02b754d3 | 689 | return SCM_MAKINUM (pgid); |
1fd838af | 690 | #else |
f93ddd39 | 691 | scm_sysmissing (s_tcgetpgrp); |
1fd838af JB |
692 | /* not reached. */ |
693 | return SCM_BOOL_F; | |
694 | #endif | |
0f2d19dd JB |
695 | } |
696 | ||
f93ddd39 | 697 | SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); |
0f2d19dd JB |
698 | SCM |
699 | scm_tcsetpgrp (port, pgid) | |
700 | SCM port, pgid; | |
701 | { | |
1fd838af | 702 | #ifdef HAVE_TCSETPGRP |
0f2d19dd | 703 | int fd; |
78446828 MV |
704 | |
705 | port = SCM_COERCE_OUTPORT (port); | |
706 | ||
f93ddd39 GH |
707 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); |
708 | SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); | |
0f2d19dd JB |
709 | fd = fileno ((FILE *)SCM_STREAM (port)); |
710 | if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) | |
f93ddd39 | 711 | scm_syserror (s_tcsetpgrp); |
02b754d3 | 712 | return SCM_UNSPECIFIED; |
1fd838af | 713 | #else |
f93ddd39 | 714 | scm_sysmissing (s_tcsetpgrp); |
1fd838af JB |
715 | /* not reached. */ |
716 | return SCM_BOOL_F; | |
717 | #endif | |
0f2d19dd JB |
718 | } |
719 | ||
720 | /* Copy exec args from an SCM vector into a new C array. */ | |
1cc91f1b | 721 | |
0f2d19dd | 722 | static char ** |
6afcd3b2 | 723 | scm_convert_exec_args (SCM args, int pos, char *subr) |
0f2d19dd JB |
724 | { |
725 | char **execargv; | |
726 | int num_args; | |
727 | int i; | |
6afcd3b2 GH |
728 | |
729 | SCM_ASSERT (SCM_NULLP (args) | |
730 | || (SCM_NIMP (args) && SCM_CONSP (args)), | |
731 | args, pos, subr); | |
0f2d19dd JB |
732 | SCM_DEFER_INTS; |
733 | num_args = scm_ilength (args); | |
734 | execargv = (char **) | |
6afcd3b2 | 735 | scm_must_malloc ((num_args + 1) * sizeof (char *), subr); |
0f2d19dd JB |
736 | for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) |
737 | { | |
738 | scm_sizet len; | |
739 | char *dst; | |
740 | char *src; | |
ae2fa5bc | 741 | SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), |
6afcd3b2 | 742 | SCM_CAR (args), SCM_ARGn, subr); |
0f2d19dd | 743 | len = 1 + SCM_ROLENGTH (SCM_CAR (args)); |
6afcd3b2 | 744 | dst = (char *) scm_must_malloc ((long) len, subr); |
0f2d19dd JB |
745 | src = SCM_ROCHARS (SCM_CAR (args)); |
746 | while (len--) | |
747 | dst[len] = src[len]; | |
748 | execargv[i] = dst; | |
749 | } | |
750 | execargv[i] = 0; | |
751 | SCM_ALLOW_INTS; | |
752 | return execargv; | |
753 | } | |
754 | ||
6afcd3b2 | 755 | SCM_PROC (s_execl, "execl", 1, 0, 1, scm_execl); |
1cc91f1b | 756 | |
0f2d19dd | 757 | SCM |
6afcd3b2 GH |
758 | scm_execl (filename, args) |
759 | SCM filename, args; | |
0f2d19dd JB |
760 | { |
761 | char **execargv; | |
6afcd3b2 GH |
762 | SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, |
763 | SCM_ARG1, s_execl); | |
764 | SCM_COERCE_SUBSTR (filename); | |
765 | execargv = scm_convert_exec_args (args, SCM_ARG2, s_execl); | |
0f2d19dd | 766 | execv (SCM_ROCHARS (filename), execargv); |
f93ddd39 | 767 | scm_syserror (s_execl); |
02b754d3 GH |
768 | /* not reached. */ |
769 | return SCM_BOOL_F; | |
0f2d19dd JB |
770 | } |
771 | ||
6afcd3b2 | 772 | SCM_PROC (s_execlp, "execlp", 1, 0, 1, scm_execlp); |
1cc91f1b | 773 | |
0f2d19dd | 774 | SCM |
6afcd3b2 GH |
775 | scm_execlp (filename, args) |
776 | SCM filename, args; | |
0f2d19dd JB |
777 | { |
778 | char **execargv; | |
ae2fa5bc GH |
779 | SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, |
780 | SCM_ARG1, s_execlp); | |
6afcd3b2 GH |
781 | SCM_COERCE_SUBSTR (filename); |
782 | execargv = scm_convert_exec_args (args, SCM_ARG2, s_execlp); | |
0f2d19dd | 783 | execvp (SCM_ROCHARS (filename), execargv); |
f93ddd39 | 784 | scm_syserror (s_execlp); |
02b754d3 GH |
785 | /* not reached. */ |
786 | return SCM_BOOL_F; | |
0f2d19dd JB |
787 | } |
788 | ||
6afcd3b2 GH |
789 | static char ** |
790 | environ_list_to_c (SCM envlist, int arg, char *proc) | |
791 | { | |
792 | int num_strings; | |
793 | char **result; | |
794 | int i = 0; | |
795 | ||
796 | SCM_REDEFER_INTS; | |
797 | SCM_ASSERT (SCM_NULLP (envlist) | |
798 | || (SCM_NIMP (envlist) && SCM_CONSP (envlist)), | |
799 | envlist, arg, proc); | |
800 | num_strings = scm_ilength (envlist); | |
801 | result = (char **) malloc ((num_strings + 1) * sizeof (char *)); | |
802 | if (result == NULL) | |
803 | scm_memory_error (proc); | |
804 | while (SCM_NNULLP (envlist)) | |
805 | { | |
806 | int len; | |
807 | char *src; | |
808 | ||
809 | SCM_ASSERT (SCM_NIMP (SCM_CAR (envlist)) | |
810 | && SCM_ROSTRINGP (SCM_CAR (envlist)), | |
811 | envlist, arg, proc); | |
812 | len = 1 + SCM_ROLENGTH (SCM_CAR (envlist)); | |
813 | result[i] = malloc ((long) len); | |
814 | if (result[i] == NULL) | |
815 | scm_memory_error (proc); | |
816 | src = SCM_ROCHARS (SCM_CAR (envlist)); | |
817 | while (len--) | |
818 | result[i][len] = src[len]; | |
819 | envlist = SCM_CDR (envlist); | |
820 | i++; | |
821 | } | |
822 | result[i] = 0; | |
823 | SCM_REALLOW_INTS; | |
824 | return result; | |
825 | } | |
826 | ||
827 | SCM_PROC (s_execle, "execle", 2, 0, 1, scm_execle); | |
828 | ||
829 | SCM | |
830 | scm_execle (filename, env, args) | |
831 | SCM filename, env, args; | |
832 | { | |
833 | char **execargv; | |
834 | char **exec_env; | |
835 | ||
836 | SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, | |
837 | SCM_ARG1, s_execle); | |
838 | SCM_COERCE_SUBSTR (filename); | |
839 | ||
840 | execargv = scm_convert_exec_args (args, SCM_ARG1, s_execle); | |
841 | exec_env = environ_list_to_c (env, SCM_ARG2, s_execle); | |
842 | execve (SCM_ROCHARS (filename), execargv, exec_env); | |
843 | scm_syserror (s_execle); | |
844 | /* not reached. */ | |
845 | return SCM_BOOL_F; | |
846 | } | |
847 | ||
063e05be | 848 | SCM_PROC (s_fork, "primitive-fork", 0, 0, 0, scm_fork); |
1cc91f1b | 849 | |
0f2d19dd | 850 | SCM |
f93ddd39 | 851 | scm_fork() |
0f2d19dd | 852 | { |
bab0f4e5 | 853 | int pid; |
0f2d19dd JB |
854 | pid = fork (); |
855 | if (pid == -1) | |
f93ddd39 | 856 | scm_syserror (s_fork); |
02b754d3 | 857 | return SCM_MAKINUM (0L+pid); |
0f2d19dd JB |
858 | } |
859 | ||
860 | ||
f93ddd39 | 861 | SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname); |
1cc91f1b | 862 | |
0f2d19dd | 863 | SCM |
f93ddd39 | 864 | scm_uname () |
0f2d19dd JB |
865 | { |
866 | #ifdef HAVE_UNAME | |
867 | struct utsname buf; | |
a8741caa | 868 | SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED); |
0f2d19dd | 869 | SCM *ve = SCM_VELTS (ans); |
a574455a | 870 | SCM_DEFER_INTS; |
e1a191a8 | 871 | if (uname (&buf) < 0) |
a574455a | 872 | scm_syserror (s_uname); |
0f2d19dd JB |
873 | ve[0] = scm_makfrom0str (buf.sysname); |
874 | ve[1] = scm_makfrom0str (buf.nodename); | |
875 | ve[2] = scm_makfrom0str (buf.release); | |
876 | ve[3] = scm_makfrom0str (buf.version); | |
877 | ve[4] = scm_makfrom0str (buf.machine); | |
878 | /* | |
02b754d3 | 879 | a linux special? |
0f2d19dd JB |
880 | ve[5] = scm_makfrom0str (buf.domainname); |
881 | */ | |
a574455a | 882 | SCM_ALLOW_INTS; |
0f2d19dd JB |
883 | return ans; |
884 | #else | |
f93ddd39 | 885 | scm_sysmissing (s_uname); |
02b754d3 GH |
886 | /* not reached. */ |
887 | return SCM_BOOL_F; | |
0f2d19dd JB |
888 | #endif |
889 | } | |
890 | ||
891 | SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); | |
1cc91f1b | 892 | |
0f2d19dd JB |
893 | SCM |
894 | scm_environ (env) | |
895 | SCM env; | |
0f2d19dd JB |
896 | { |
897 | if (SCM_UNBNDP (env)) | |
898 | return scm_makfromstrs (-1, environ); | |
899 | else | |
900 | { | |
0f2d19dd | 901 | char **new_environ; |
6afcd3b2 GH |
902 | |
903 | SCM_DEFER_INTS; | |
904 | new_environ = environ_list_to_c (env, SCM_ARG1, s_environ); | |
0f2d19dd JB |
905 | /* Free the old environment, except when called for the first |
906 | * time. | |
907 | */ | |
908 | { | |
909 | char **ep; | |
910 | static int first = 1; | |
911 | if (!first) | |
912 | { | |
913 | for (ep = environ; *ep != NULL; ep++) | |
19468eff GH |
914 | free (*ep); |
915 | free ((char *) environ); | |
0f2d19dd JB |
916 | } |
917 | first = 0; | |
918 | } | |
919 | environ = new_environ; | |
6afcd3b2 | 920 | SCM_ALLOW_INTS; |
0f2d19dd JB |
921 | return SCM_UNSPECIFIED; |
922 | } | |
923 | } | |
924 | ||
9ee5fce4 MD |
925 | #ifdef L_tmpnam |
926 | ||
927 | SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam); | |
928 | ||
929 | SCM scm_tmpnam() | |
930 | { | |
931 | char name[L_tmpnam]; | |
932 | SCM_SYSCALL (tmpnam (name);); | |
933 | return scm_makfrom0str (name); | |
934 | } | |
935 | #endif | |
0f2d19dd JB |
936 | |
937 | SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); | |
1cc91f1b | 938 | |
0f2d19dd JB |
939 | SCM |
940 | scm_open_pipe (pipestr, modes) | |
941 | SCM pipestr; | |
942 | SCM modes; | |
0f2d19dd JB |
943 | { |
944 | FILE *f; | |
945 | register SCM z; | |
02b754d3 GH |
946 | struct scm_port_table * pt; |
947 | ||
ae2fa5bc GH |
948 | SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, |
949 | SCM_ARG1, s_open_pipe); | |
0f2d19dd | 950 | if (SCM_SUBSTRP (pipestr)) |
ae2fa5bc GH |
951 | pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), |
952 | SCM_ROLENGTH (pipestr), 0); | |
953 | SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, | |
954 | s_open_pipe); | |
0f2d19dd JB |
955 | if (SCM_SUBSTRP (modes)) |
956 | modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); | |
957 | SCM_NEWCELL (z); | |
958 | SCM_DEFER_INTS; | |
0f2d19dd | 959 | SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); |
0f2d19dd | 960 | if (!f) |
52859adf | 961 | scm_syserror (s_open_pipe); |
02b754d3 GH |
962 | pt = scm_add_to_port_table (z); |
963 | SCM_SETPTAB_ENTRY (z, pt); | |
a6c64c3c MD |
964 | SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN |
965 | | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG)); | |
02b754d3 | 966 | SCM_SETSTREAM (z, (SCM)f); |
0f2d19dd JB |
967 | SCM_ALLOW_INTS; |
968 | return z; | |
969 | } | |
970 | ||
19468eff | 971 | SCM_PROC (s_close_pipe, "close-pipe", 1, 0, 0, scm_close_pipe); |
0f2d19dd | 972 | |
19468eff GH |
973 | SCM |
974 | scm_close_pipe (port) | |
975 | SCM port; | |
0f2d19dd | 976 | { |
19468eff | 977 | int rv; |
1cc91f1b | 978 | |
19468eff GH |
979 | SCM_ASSERT (SCM_NIMP (port) && SCM_TYP16(port) == scm_tc16_pipe |
980 | && SCM_OPENP (port), port, SCM_ARG1, s_close_pipe); | |
981 | SCM_DEFER_INTS; | |
982 | rv = pclose ((FILE *) SCM_STREAM (port)); | |
67fe060e GH |
983 | scm_remove_from_port_table (port); |
984 | SCM_SETAND_CAR (port, ~SCM_OPN); | |
19468eff GH |
985 | if (rv == -1) |
986 | scm_syserror (s_close_pipe); | |
987 | SCM_ALLOW_INTS; | |
988 | return SCM_MAKINUM (rv); | |
0f2d19dd JB |
989 | } |
990 | ||
f93ddd39 | 991 | SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); |
1cc91f1b | 992 | |
0f2d19dd | 993 | SCM |
f93ddd39 | 994 | scm_utime (pathname, actime, modtime) |
0f2d19dd JB |
995 | SCM pathname; |
996 | SCM actime; | |
997 | SCM modtime; | |
0f2d19dd JB |
998 | { |
999 | int rv; | |
1000 | struct utimbuf utm_tmp; | |
1001 | ||
89958ad0 | 1002 | SCM_ASSERT (SCM_NIMP (pathname) && SCM_ROSTRINGP (pathname), pathname, |
ae2fa5bc | 1003 | SCM_ARG1, s_utime); |
0f2d19dd | 1004 | |
89958ad0 | 1005 | SCM_COERCE_SUBSTR (pathname); |
0f2d19dd JB |
1006 | if (SCM_UNBNDP (actime)) |
1007 | SCM_SYSCALL (time (&utm_tmp.actime)); | |
1008 | else | |
f93ddd39 | 1009 | utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime); |
0f2d19dd JB |
1010 | |
1011 | if (SCM_UNBNDP (modtime)) | |
1012 | SCM_SYSCALL (time (&utm_tmp.modtime)); | |
1013 | else | |
f93ddd39 | 1014 | utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime); |
0f2d19dd | 1015 | |
89958ad0 | 1016 | SCM_SYSCALL (rv = utime (SCM_ROCHARS (pathname), &utm_tmp)); |
02b754d3 | 1017 | if (rv != 0) |
f93ddd39 | 1018 | scm_syserror (s_utime); |
02b754d3 | 1019 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
1020 | } |
1021 | ||
f93ddd39 | 1022 | SCM_PROC (s_access, "access?", 2, 0, 0, scm_access); |
1cc91f1b | 1023 | |
0f2d19dd | 1024 | SCM |
f93ddd39 | 1025 | scm_access (path, how) |
0f2d19dd JB |
1026 | SCM path; |
1027 | SCM how; | |
0f2d19dd JB |
1028 | { |
1029 | int rv; | |
1030 | ||
ae2fa5bc GH |
1031 | SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, |
1032 | s_access); | |
0f2d19dd JB |
1033 | if (SCM_SUBSTRP (path)) |
1034 | path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); | |
f93ddd39 | 1035 | SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access); |
0f2d19dd JB |
1036 | rv = access (SCM_ROCHARS (path), SCM_INUM (how)); |
1037 | return rv ? SCM_BOOL_F : SCM_BOOL_T; | |
1038 | } | |
1039 | ||
0f2d19dd | 1040 | SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); |
1cc91f1b | 1041 | |
0f2d19dd JB |
1042 | SCM |
1043 | scm_getpid () | |
0f2d19dd JB |
1044 | { |
1045 | return SCM_MAKINUM ((unsigned long) getpid ()); | |
1046 | } | |
1047 | ||
f93ddd39 | 1048 | SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv); |
1cc91f1b | 1049 | |
0f2d19dd | 1050 | SCM |
f93ddd39 | 1051 | scm_putenv (str) |
0f2d19dd | 1052 | SCM str; |
0f2d19dd | 1053 | { |
f93ddd39 | 1054 | int rv; |
19468eff | 1055 | char *ptr; |
f93ddd39 | 1056 | |
89958ad0 | 1057 | SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_putenv); |
19468eff GH |
1058 | /* must make a new copy to be left in the environment, safe from gc. */ |
1059 | ptr = malloc (SCM_LENGTH (str) + 1); | |
1060 | if (ptr == NULL) | |
1061 | scm_memory_error (s_putenv); | |
89958ad0 JB |
1062 | strncpy (ptr, SCM_ROCHARS (str), SCM_LENGTH (str)); |
1063 | ptr[SCM_LENGTH(str)] = 0; | |
19468eff | 1064 | rv = putenv (ptr); |
f93ddd39 GH |
1065 | if (rv < 0) |
1066 | scm_syserror (s_putenv); | |
1067 | return SCM_UNSPECIFIED; | |
0f2d19dd JB |
1068 | } |
1069 | ||
02b754d3 | 1070 | SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale); |
1cc91f1b | 1071 | |
0f2d19dd JB |
1072 | SCM |
1073 | scm_setlocale (category, locale) | |
1074 | SCM category; | |
1075 | SCM locale; | |
0f2d19dd JB |
1076 | { |
1077 | #ifdef HAVE_SETLOCALE | |
1078 | char *clocale; | |
1079 | char *rv; | |
1080 | ||
1081 | SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale); | |
1082 | if (SCM_UNBNDP (locale)) | |
1083 | { | |
1084 | clocale = NULL; | |
1085 | } | |
1086 | else | |
1087 | { | |
89958ad0 | 1088 | SCM_ASSERT (SCM_NIMP (locale) && SCM_ROSTRINGP (locale), locale, |
ae2fa5bc | 1089 | SCM_ARG2, s_setlocale); |
89958ad0 JB |
1090 | SCM_COERCE_SUBSTR (locale); |
1091 | clocale = SCM_ROCHARS (locale); | |
0f2d19dd JB |
1092 | } |
1093 | ||
1094 | rv = setlocale (SCM_INUM (category), clocale); | |
02b754d3 | 1095 | if (rv == NULL) |
52859adf | 1096 | scm_syserror (s_setlocale); |
02b754d3 | 1097 | return scm_makfrom0str (rv); |
0f2d19dd | 1098 | #else |
52859adf | 1099 | scm_sysmissing (s_setlocale); |
02b754d3 | 1100 | /* not reached. */ |
0f2d19dd JB |
1101 | return SCM_BOOL_F; |
1102 | #endif | |
1103 | } | |
1104 | ||
19468eff | 1105 | SCM_PROC (s_mknod, "mknod", 4, 0, 0, scm_mknod); |
1cc91f1b | 1106 | |
0f2d19dd | 1107 | SCM |
19468eff | 1108 | scm_mknod(path, type, perms, dev) |
0f2d19dd | 1109 | SCM path; |
19468eff GH |
1110 | SCM type; |
1111 | SCM perms; | |
0f2d19dd | 1112 | SCM dev; |
0f2d19dd JB |
1113 | { |
1114 | #ifdef HAVE_MKNOD | |
1115 | int val; | |
19468eff | 1116 | char *p; |
82a76bdf | 1117 | int ctype = 0; |
19468eff GH |
1118 | |
1119 | SCM_ASSERT (SCM_NIMP(path) && SCM_ROSTRINGP(path), path, SCM_ARG1, s_mknod); | |
1120 | SCM_ASSERT (SCM_NIMP(type) && SCM_SYMBOLP (type), type, SCM_ARG2, s_mknod); | |
1121 | SCM_ASSERT (SCM_INUMP (perms), perms, SCM_ARG3, s_mknod); | |
1122 | SCM_ASSERT (SCM_INUMP(dev), dev, SCM_ARG4, s_mknod); | |
89958ad0 | 1123 | SCM_COERCE_SUBSTR (path); |
19468eff GH |
1124 | |
1125 | p = SCM_CHARS (type); | |
1126 | if (strcmp (p, "regular") == 0) | |
1127 | ctype = S_IFREG; | |
1128 | else if (strcmp (p, "directory") == 0) | |
1129 | ctype = S_IFDIR; | |
1130 | else if (strcmp (p, "symlink") == 0) | |
1131 | ctype = S_IFLNK; | |
1132 | else if (strcmp (p, "block-special") == 0) | |
1133 | ctype = S_IFBLK; | |
1134 | else if (strcmp (p, "char-special") == 0) | |
1135 | ctype = S_IFCHR; | |
1136 | else if (strcmp (p, "fifo") == 0) | |
1137 | ctype = S_IFIFO; | |
1138 | else if (strcmp (p, "socket") == 0) | |
1139 | ctype = S_IFSOCK; | |
1140 | else | |
1141 | scm_out_of_range (s_mknod, type); | |
1142 | ||
1143 | SCM_DEFER_INTS; | |
1144 | SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms), | |
1145 | SCM_INUM (dev))); | |
02b754d3 | 1146 | if (val != 0) |
f93ddd39 | 1147 | scm_syserror (s_mknod); |
19468eff | 1148 | SCM_ALLOW_INTS; |
02b754d3 | 1149 | return SCM_UNSPECIFIED; |
0f2d19dd | 1150 | #else |
f93ddd39 | 1151 | scm_sysmissing (s_mknod); |
02b754d3 | 1152 | /* not reached. */ |
0f2d19dd JB |
1153 | return SCM_BOOL_F; |
1154 | #endif | |
1155 | } | |
1156 | ||
1157 | ||
f93ddd39 | 1158 | SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice); |
1cc91f1b | 1159 | |
0f2d19dd | 1160 | SCM |
f93ddd39 | 1161 | scm_nice(incr) |
0f2d19dd | 1162 | SCM incr; |
0f2d19dd JB |
1163 | { |
1164 | #ifdef HAVE_NICE | |
f93ddd39 | 1165 | SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice); |
02b754d3 | 1166 | if (nice(SCM_INUM(incr)) != 0) |
f93ddd39 | 1167 | scm_syserror (s_nice); |
02b754d3 | 1168 | return SCM_UNSPECIFIED; |
0f2d19dd | 1169 | #else |
f93ddd39 | 1170 | scm_sysmissing (s_nice); |
02b754d3 GH |
1171 | /* not reached. */ |
1172 | return SCM_BOOL_F; | |
0f2d19dd JB |
1173 | #endif |
1174 | } | |
1175 | ||
1176 | ||
1177 | SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); | |
1cc91f1b | 1178 | |
0f2d19dd JB |
1179 | SCM |
1180 | scm_sync() | |
0f2d19dd JB |
1181 | { |
1182 | #ifdef HAVE_SYNC | |
1183 | sync(); | |
52859adf GH |
1184 | #else |
1185 | scm_sysmissing (s_sync); | |
02b754d3 | 1186 | /* not reached. */ |
52859adf | 1187 | #endif |
6afcd3b2 | 1188 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
1189 | } |
1190 | ||
0f2d19dd JB |
1191 | void |
1192 | scm_init_posix () | |
0f2d19dd JB |
1193 | { |
1194 | scm_add_feature ("posix"); | |
1195 | #ifdef HAVE_GETEUID | |
1196 | scm_add_feature ("EIDs"); | |
1197 | #endif | |
1198 | #ifdef WAIT_ANY | |
1199 | scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); | |
1200 | #endif | |
1201 | #ifdef WAIT_MYPGRP | |
1202 | scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); | |
1203 | #endif | |
1204 | #ifdef WNOHANG | |
1205 | scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); | |
1206 | #endif | |
1207 | #ifdef WUNTRACED | |
1208 | scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); | |
1209 | #endif | |
1210 | ||
0f2d19dd | 1211 | /* access() symbols. */ |
bab0f4e5 JB |
1212 | scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); |
1213 | scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); | |
1214 | scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); | |
1215 | scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); | |
0f2d19dd JB |
1216 | |
1217 | #ifdef LC_COLLATE | |
1218 | scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); | |
1219 | #endif | |
1220 | #ifdef LC_CTYPE | |
1221 | scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); | |
1222 | #endif | |
1223 | #ifdef LC_MONETARY | |
1224 | scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); | |
1225 | #endif | |
1226 | #ifdef LC_NUMERIC | |
1227 | scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); | |
1228 | #endif | |
1229 | #ifdef LC_TIME | |
1230 | scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); | |
1231 | #endif | |
1232 | #ifdef LC_MESSAGES | |
1233 | scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); | |
1234 | #endif | |
1235 | #ifdef LC_ALL | |
1236 | scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); | |
1237 | #endif | |
67ec3667 | 1238 | #include "cpp_sig_symbols.c" |
0f2d19dd JB |
1239 | #include "posix.x" |
1240 | } |