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