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