*** empty log message ***
[bpt/guile.git] / libguile / posix.c
CommitLineData
d675a50f 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
0f2d19dd 2 *
73be1d9e
MV
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
0f2d19dd 7 *
73be1d9e
MV
8 * This library 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 GNU
11 * Lesser General Public License for more details.
0f2d19dd 12 *
73be1d9e
MV
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
16 */
1bbd0b84 17
1bbd0b84 18
0f2d19dd 19\f
2546b5c3
RB
20#if HAVE_CONFIG_H
21# include <config.h>
22#endif
0f2d19dd 23
8b50fe8e
MV
24/* Make GNU/Linux libc declare everything it has. */
25#define _GNU_SOURCE
26
0f2d19dd 27#include <stdio.h>
e6e2e95a
MD
28#include <errno.h>
29
a0599745 30#include "libguile/_scm.h"
b28f5b3c 31#include "libguile/dynwind.h"
a0599745
MD
32#include "libguile/fports.h"
33#include "libguile/scmsigs.h"
34#include "libguile/feature.h"
35#include "libguile/strings.h"
c44ca4fe 36#include "libguile/srfi-13.h"
a0599745 37#include "libguile/vectors.h"
c96d76b8 38#include "libguile/lang.h"
a0599745
MD
39
40#include "libguile/validate.h"
41#include "libguile/posix.h"
0f2d19dd
JB
42\f
43
02b754d3
GH
44#ifdef HAVE_STRING_H
45#include <string.h>
46#endif
0f2d19dd
JB
47#ifdef TIME_WITH_SYS_TIME
48# include <sys/time.h>
49# include <time.h>
50#else
51# if HAVE_SYS_TIME_H
52# include <sys/time.h>
53# else
54# include <time.h>
55# endif
56#endif
57
58#ifdef HAVE_UNISTD_H
59#include <unistd.h>
95b88819
GH
60#else
61#ifndef ttyname
62extern char *ttyname();
63#endif
0f2d19dd
JB
64#endif
65
3594582b 66#ifdef LIBC_H_WITH_UNISTD_H
bab0f4e5
JB
67#include <libc.h>
68#endif
69
8cc71382 70#include <sys/types.h>
0f2d19dd
JB
71#include <sys/stat.h>
72#include <fcntl.h>
73
82893676 74#ifdef HAVE_PWD_H
0f2d19dd 75#include <pwd.h>
82893676
MG
76#endif
77#ifdef HAVE_IO_H
78#include <io.h>
79#endif
f87c105a 80#ifdef HAVE_WINSOCK2_H
82893676
MG
81#include <winsock2.h>
82#endif
83
84#ifdef __MINGW32__
85/* Some defines for Windows here. */
7beabedb 86# include <process.h>
82893676
MG
87# define pipe(fd) _pipe (fd, 256, O_BINARY)
88#endif /* __MINGW32__ */
0f2d19dd
JB
89
90#if HAVE_SYS_WAIT_H
91# include <sys/wait.h>
92#endif
93#ifndef WEXITSTATUS
94# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
95#endif
96#ifndef WIFEXITED
97# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
98#endif
99
100#include <signal.h>
101
0f2d19dd
JB
102extern char ** environ;
103
82893676 104#ifdef HAVE_GRP_H
0f2d19dd 105#include <grp.h>
82893676
MG
106#endif
107#ifdef HAVE_SYS_UTSNAME_H
0f2d19dd 108#include <sys/utsname.h>
82893676 109#endif
0f2d19dd 110
0f2d19dd
JB
111#ifdef HAVE_SETLOCALE
112#include <locale.h>
113#endif
114
b9a7b725 115#if HAVE_CRYPT_H
94e6d793
MG
116# include <crypt.h>
117#endif
118
0eaf1055
KR
119#ifdef HAVE_NETDB_H
120#include <netdb.h> /* for MAXHOSTNAMELEN on Solaris */
121#endif
122
123#ifdef HAVE_SYS_PARAM_H
124#include <sys/param.h> /* for MAXHOSTNAMELEN */
125#endif
126
94e6d793
MG
127#if HAVE_SYS_RESOURCE_H
128# include <sys/resource.h>
129#endif
130
131#if HAVE_SYS_FILE_H
132# include <sys/file.h>
133#endif
134
eb7e1603
KR
135#if HAVE_CRT_EXTERNS_H
136#include <crt_externs.h> /* for Darwin _NSGetEnviron */
137#endif
138
bab0f4e5
JB
139/* Some Unix systems don't define these. CPP hair is dangerous, but
140 this seems safe enough... */
141#ifndef R_OK
142#define R_OK 4
143#endif
144
145#ifndef W_OK
146#define W_OK 2
147#endif
148
149#ifndef X_OK
150#define X_OK 1
151#endif
152
153#ifndef F_OK
154#define F_OK 0
155#endif
398609a5
JB
156
157/* On NextStep, <utime.h> doesn't define struct utime, unless we
158 #define _POSIX_SOURCE before #including it. I think this is less
159 of a kludge than defining struct utimbuf ourselves. */
160#ifdef UTIMBUF_NEEDS_POSIX
161#define _POSIX_SOURCE
162#endif
163
164#ifdef HAVE_SYS_UTIME_H
165#include <sys/utime.h>
166#endif
167
168#ifdef HAVE_UTIME_H
169#include <utime.h>
170#endif
171
172/* Please don't add any more #includes or #defines here. The hack
173 above means that _POSIX_SOURCE may be #defined, which will
eb7e1603
KR
174 encourage header files to do strange things.
175
176 FIXME: Maybe should undef _POSIX_SOURCE after it's done its job.
177
178 FIXME: Probably should do all the includes first, then all the fallback
179 declarations and defines, in case things are not in the header we
180 imagine. */
181
182
183
184
185/* On Apple Darwin in a shared library there's no "environ" to access
186 directly, instead the address of that variable must be obtained with
187 _NSGetEnviron(). */
188#if HAVE__NSGETENVIRON && defined (PIC)
189#define environ (*_NSGetEnviron())
190#endif
398609a5 191
0f2d19dd 192\f
f015614a
MV
193
194/* Two often used patterns
195 */
196
197#define WITH_STRING(str,cstr,code) \
198 do { \
199 char *cstr = scm_to_locale_string (str); \
200 code; \
201 free (cstr); \
202 } while (0)
203
204#define STRING_SYSCALL(str,cstr,code) \
205 do { \
206 int eno; \
207 char *cstr = scm_to_locale_string (str); \
208 SCM_SYSCALL (code); \
209 eno = errno; free (cstr); errno = eno; \
210 } while (0)
211
212
213\f
bc45012d
JB
214SCM_SYMBOL (sym_read_pipe, "read pipe");
215SCM_SYMBOL (sym_write_pipe, "write pipe");
0f2d19dd 216
a1ec6916 217SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
1bbd0b84 218 (),
1e6808ea
MG
219 "Return a newly created pipe: a pair of ports which are linked\n"
220 "together on the local machine. The @emph{car} is the input\n"
221 "port and the @emph{cdr} is the output port. Data written (and\n"
222 "flushed) to the output port can be read from the input port.\n"
223 "Pipes are commonly used for communication with a newly forked\n"
224 "child process. The need to flush the output port can be\n"
225 "avoided by making it unbuffered using @code{setvbuf}.\n"
226 "\n"
227 "Writes occur atomically provided the size of the data in bytes\n"
228 "is not greater than the value of @code{PIPE_BUF}. Note that\n"
229 "the output port is likely to block if too much data (typically\n"
230 "equal to @code{PIPE_BUF}) has been written but not yet read\n"
231 "from the input port.")
1bbd0b84 232#define FUNC_NAME s_scm_pipe
0f2d19dd
JB
233{
234 int fd[2], rv;
0f2d19dd 235 SCM p_rd, p_wt;
02b754d3 236
0f2d19dd
JB
237 rv = pipe (fd);
238 if (rv)
1bbd0b84 239 SCM_SYSERROR;
ee149d03
JB
240
241 p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe);
242 p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe);
0f2d19dd
JB
243 return scm_cons (p_rd, p_wt);
244}
1bbd0b84 245#undef FUNC_NAME
0f2d19dd
JB
246
247
0e958795 248#ifdef HAVE_GETGROUPS
a1ec6916 249SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
1bbd0b84 250 (),
1e6808ea 251 "Return a vector of integers representing the current\n"
bb2c02f2 252 "supplementary group IDs.")
1bbd0b84 253#define FUNC_NAME s_scm_getgroups
0f2d19dd 254{
1d1559ce 255 SCM result;
66460dfb 256 int ngroups;
1be6b49c 257 size_t size;
66460dfb
DH
258 GETGROUPS_T *groups;
259
260 ngroups = getgroups (0, NULL);
261 if (ngroups <= 0)
1bbd0b84 262 SCM_SYSERROR;
66460dfb
DH
263
264 size = ngroups * sizeof (GETGROUPS_T);
4c9419ac 265 groups = scm_malloc (size);
66460dfb
DH
266 getgroups (ngroups, groups);
267
f360a962
MV
268 result = scm_c_make_vector (ngroups, SCM_BOOL_F);
269 while (--ngroups >= 0)
b9bd8526 270 SCM_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
66460dfb 271
4c9419ac 272 free (groups);
1d1559ce 273 return result;
1bbd0b84
GB
274}
275#undef FUNC_NAME
0e958795 276#endif
0f2d19dd 277
f360a962
MV
278#ifdef HAVE_SETGROUPS
279SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0,
280 (SCM group_vec),
fcc3adc2
KR
281 "Set the current set of supplementary group IDs to the integers\n"
282 "in the given vector @var{vec}. The return value is\n"
283 "unspecified.\n"
284 "\n"
285 "Generally only the superuser can set the process group IDs.")
f360a962
MV
286#define FUNC_NAME s_scm_setgroups
287{
288 size_t ngroups;
289 size_t size;
290 size_t i;
291 int result;
292 int save_errno;
293 GETGROUPS_T *groups;
294
295 SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
296
297 ngroups = SCM_VECTOR_LENGTH (group_vec);
298
299 /* validate before allocating, so we don't have to worry about leaks */
300 for (i = 0; i < ngroups; i++)
301 {
302 unsigned long ulong_gid;
303 GETGROUPS_T gid;
304 SCM_VALIDATE_ULONG_COPY (1, SCM_VECTOR_REF (group_vec, i), ulong_gid);
305 gid = ulong_gid;
306 if (gid != ulong_gid)
307 SCM_OUT_OF_RANGE (1, SCM_VECTOR_REF (group_vec, i));
308 }
309
310 size = ngroups * sizeof (GETGROUPS_T);
2eb78d06 311 if (size / sizeof (GETGROUPS_T) != ngroups)
e11e83f3 312 SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups));
f360a962
MV
313 groups = scm_malloc (size);
314 for(i = 0; i < ngroups; i++)
315 groups [i] = SCM_NUM2ULONG (1, SCM_VECTOR_REF (group_vec, i));
316
317 result = setgroups (ngroups, groups);
318 save_errno = errno; /* don't let free() touch errno */
319 free (groups);
320 errno = save_errno;
321 if (result < 0)
322 SCM_SYSERROR;
323 return SCM_UNSPECIFIED;
324}
325#undef FUNC_NAME
326#endif
327
82893676 328#ifdef HAVE_GETPWENT
a1ec6916 329SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
1bbd0b84 330 (SCM user),
b380b885
MD
331 "Look up an entry in the user database. @var{obj} can be an integer,\n"
332 "a string, or omitted, giving the behaviour of getpwuid, getpwnam\n"
333 "or getpwent respectively.")
1bbd0b84 334#define FUNC_NAME s_scm_getpwuid
0f2d19dd 335{
0f2d19dd 336 struct passwd *entry;
0f2d19dd 337
1d1559ce 338 SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED);
7888309b 339 if (SCM_UNBNDP (user) || scm_is_false (user))
0f2d19dd 340 {
0f2d19dd 341 SCM_SYSCALL (entry = getpwent ());
3d781d49
JB
342 if (! entry)
343 {
3d781d49
JB
344 return SCM_BOOL_F;
345 }
0f2d19dd 346 }
e11e83f3 347 else if (scm_is_integer (user))
0f2d19dd 348 {
e11e83f3 349 entry = getpwuid (scm_to_int (user));
0f2d19dd
JB
350 }
351 else
352 {
f015614a
MV
353 WITH_STRING (user, c_user,
354 entry = getpwnam (c_user));
0f2d19dd
JB
355 }
356 if (!entry)
1bbd0b84 357 SCM_MISC_ERROR ("entry not found", SCM_EOL);
02b754d3 358
cc95e00a
MV
359 SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name));
360 SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd));
b9bd8526
MV
361 SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid));
362 SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid));
cc95e00a 363 SCM_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos));
0f2d19dd 364 if (!entry->pw_dir)
cc95e00a 365 SCM_VECTOR_SET(result, 5, scm_from_locale_string (""));
0f2d19dd 366 else
cc95e00a 367 SCM_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
0f2d19dd 368 if (!entry->pw_shell)
cc95e00a 369 SCM_VECTOR_SET(result, 6, scm_from_locale_string (""));
0f2d19dd 370 else
cc95e00a 371 SCM_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
1d1559ce 372 return result;
0f2d19dd 373}
1bbd0b84 374#undef FUNC_NAME
82893676 375#endif /* HAVE_GETPWENT */
0f2d19dd
JB
376
377
0e958795 378#ifdef HAVE_SETPWENT
a1ec6916 379SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0,
1bbd0b84 380 (SCM arg),
b380b885
MD
381 "If called with a true argument, initialize or reset the password data\n"
382 "stream. Otherwise, close the stream. The @code{setpwent} and\n"
383 "@code{endpwent} procedures are implemented on top of this.")
1bbd0b84 384#define FUNC_NAME s_scm_setpwent
0f2d19dd 385{
7888309b 386 if (SCM_UNBNDP (arg) || scm_is_false (arg))
0f2d19dd
JB
387 endpwent ();
388 else
389 setpwent ();
390 return SCM_UNSPECIFIED;
391}
1bbd0b84 392#undef FUNC_NAME
0e958795 393#endif
0f2d19dd
JB
394
395
82893676 396#ifdef HAVE_GETGRENT
0f2d19dd 397/* Combines getgrgid and getgrnam. */
a1ec6916 398SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
1bbd0b84 399 (SCM name),
b380b885
MD
400 "Look up an entry in the group database. @var{obj} can be an integer,\n"
401 "a string, or omitted, giving the behaviour of getgrgid, getgrnam\n"
402 "or getgrent respectively.")
1bbd0b84 403#define FUNC_NAME s_scm_getgrgid
0f2d19dd 404{
0f2d19dd 405 struct group *entry;
1d1559ce 406 SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
34d19ef6 407
7888309b 408 if (SCM_UNBNDP (name) || scm_is_false (name))
3d781d49
JB
409 {
410 SCM_SYSCALL (entry = getgrent ());
411 if (! entry)
412 {
3d781d49
JB
413 return SCM_BOOL_F;
414 }
415 }
e11e83f3
MV
416 else if (scm_is_integer (name))
417 SCM_SYSCALL (entry = getgrgid (scm_to_int (name)));
0f2d19dd 418 else
f015614a
MV
419 STRING_SYSCALL (name, c_name,
420 entry = getgrnam (c_name));
0f2d19dd 421 if (!entry)
1bbd0b84 422 SCM_SYSERROR;
02b754d3 423
cc95e00a
MV
424 SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name));
425 SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd));
b9bd8526 426 SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid));
1d1559ce
HWN
427 SCM_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
428 return result;
0f2d19dd 429}
1bbd0b84 430#undef FUNC_NAME
0f2d19dd
JB
431
432
433
a1ec6916 434SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0,
1bbd0b84 435 (SCM arg),
b380b885
MD
436 "If called with a true argument, initialize or reset the group data\n"
437 "stream. Otherwise, close the stream. The @code{setgrent} and\n"
438 "@code{endgrent} procedures are implemented on top of this.")
1bbd0b84 439#define FUNC_NAME s_scm_setgrent
0f2d19dd 440{
7888309b 441 if (SCM_UNBNDP (arg) || scm_is_false (arg))
0f2d19dd
JB
442 endgrent ();
443 else
444 setgrent ();
445 return SCM_UNSPECIFIED;
446}
1bbd0b84 447#undef FUNC_NAME
82893676 448#endif /* HAVE_GETGRENT */
0f2d19dd
JB
449
450
a1ec6916 451SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
1bbd0b84 452 (SCM pid, SCM sig),
b380b885
MD
453 "Sends a signal to the specified process or group of processes.\n\n"
454 "@var{pid} specifies the processes to which the signal is sent:\n\n"
455 "@table @r\n"
456 "@item @var{pid} greater than 0\n"
457 "The process whose identifier is @var{pid}.\n"
458 "@item @var{pid} equal to 0\n"
459 "All processes in the current process group.\n"
460 "@item @var{pid} less than -1\n"
461 "The process group whose identifier is -@var{pid}\n"
462 "@item @var{pid} equal to -1\n"
463 "If the process is privileged, all processes except for some special\n"
464 "system processes. Otherwise, all processes with the current effective\n"
465 "user ID.\n"
466 "@end table\n\n"
467 "@var{sig} should be specified using a variable corresponding to\n"
468 "the Unix symbolic name, e.g.,\n\n"
469 "@defvar SIGHUP\n"
470 "Hang-up signal.\n"
471 "@end defvar\n\n"
472 "@defvar SIGINT\n"
473 "Interrupt signal.\n"
474 "@end defvar")
1bbd0b84 475#define FUNC_NAME s_scm_kill
0f2d19dd 476{
0f2d19dd 477 /* Signal values are interned in scm_init_posix(). */
82893676 478#ifdef HAVE_KILL
a55c2b68 479 if (kill (scm_to_int (pid), scm_to_int (sig)) != 0)
82893676 480#else
a55c2b68
MV
481 if (scm_to_int (pid) == getpid ())
482 if (raise (scm_to_int (sig)) != 0)
82893676
MG
483#endif
484 SCM_SYSERROR;
02b754d3 485 return SCM_UNSPECIFIED;
0f2d19dd 486}
1bbd0b84 487#undef FUNC_NAME
0f2d19dd 488
d00ae47e 489#ifdef HAVE_WAITPID
a1ec6916 490SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
1bbd0b84 491 (SCM pid, SCM options),
b380b885
MD
492 "This procedure collects status information from a child process which\n"
493 "has terminated or (optionally) stopped. Normally it will\n"
494 "suspend the calling process until this can be done. If more than one\n"
495 "child process is eligible then one will be chosen by the operating system.\n\n"
496 "The value of @var{pid} determines the behaviour:\n\n"
497 "@table @r\n"
498 "@item @var{pid} greater than 0\n"
499 "Request status information from the specified child process.\n"
500 "@item @var{pid} equal to -1 or WAIT_ANY\n"
501 "Request status information for any child process.\n"
502 "@item @var{pid} equal to 0 or WAIT_MYPGRP\n"
503 "Request status information for any child process in the current process\n"
504 "group.\n"
505 "@item @var{pid} less than -1\n"
506 "Request status information for any child process whose process group ID\n"
507 "is -@var{PID}.\n"
508 "@end table\n\n"
509 "The @var{options} argument, if supplied, should be the bitwise OR of the\n"
510 "values of zero or more of the following variables:\n\n"
511 "@defvar WNOHANG\n"
512 "Return immediately even if there are no child processes to be collected.\n"
513 "@end defvar\n\n"
514 "@defvar WUNTRACED\n"
515 "Report status information for stopped processes as well as terminated\n"
516 "processes.\n"
517 "@end defvar\n\n"
518 "The return value is a pair containing:\n\n"
519 "@enumerate\n"
520 "@item\n"
521 "The process ID of the child process, or 0 if @code{WNOHANG} was\n"
522 "specified and no process was collected.\n"
523 "@item\n"
524 "The integer status value.\n"
525 "@end enumerate")
1bbd0b84 526#define FUNC_NAME s_scm_waitpid
0f2d19dd
JB
527{
528 int i;
529 int status;
530 int ioptions;
0f2d19dd
JB
531 if (SCM_UNBNDP (options))
532 ioptions = 0;
533 else
534 {
0f2d19dd 535 /* Flags are interned in scm_init_posix. */
a55c2b68 536 ioptions = scm_to_int (options);
0f2d19dd 537 }
a55c2b68 538 SCM_SYSCALL (i = waitpid (scm_to_int (pid), &status, ioptions));
02b754d3 539 if (i == -1)
1bbd0b84 540 SCM_SYSERROR;
a55c2b68 541 return scm_cons (scm_from_int (i), scm_from_int (status));
0f2d19dd 542}
1bbd0b84 543#undef FUNC_NAME
d00ae47e 544#endif /* HAVE_WAITPID */
0f2d19dd 545
82893676 546#ifndef __MINGW32__
a1ec6916 547SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0,
1bbd0b84 548 (SCM status),
1e6808ea
MG
549 "Return the exit status value, as would be set if a process\n"
550 "ended normally through a call to @code{exit} or @code{_exit},\n"
551 "if any, otherwise @code{#f}.")
1bbd0b84 552#define FUNC_NAME s_scm_status_exit_val
67ec3667 553{
e67dc2be
JB
554 int lstatus;
555
e67dc2be 556 /* On Ultrix, the WIF... macros assume their argument is an lvalue;
e11e83f3 557 go figure. */
a55c2b68 558 lstatus = scm_to_int (status);
e67dc2be 559 if (WIFEXITED (lstatus))
a55c2b68 560 return (scm_from_int (WEXITSTATUS (lstatus)));
67ec3667
GH
561 else
562 return SCM_BOOL_F;
563}
1bbd0b84 564#undef FUNC_NAME
e67dc2be 565
a1ec6916 566SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0,
1bbd0b84 567 (SCM status),
1e6808ea
MG
568 "Return the signal number which terminated the process, if any,\n"
569 "otherwise @code{#f}.")
1bbd0b84 570#define FUNC_NAME s_scm_status_term_sig
67ec3667 571{
e67dc2be
JB
572 int lstatus;
573
a55c2b68 574 lstatus = scm_to_int (status);
e67dc2be 575 if (WIFSIGNALED (lstatus))
a55c2b68 576 return scm_from_int (WTERMSIG (lstatus));
67ec3667
GH
577 else
578 return SCM_BOOL_F;
579}
1bbd0b84 580#undef FUNC_NAME
0f2d19dd 581
a1ec6916 582SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
1bbd0b84 583 (SCM status),
1e6808ea
MG
584 "Return the signal number which stopped the process, if any,\n"
585 "otherwise @code{#f}.")
1bbd0b84 586#define FUNC_NAME s_scm_status_stop_sig
67ec3667 587{
e67dc2be
JB
588 int lstatus;
589
a55c2b68 590 lstatus = scm_to_int (status);
e67dc2be 591 if (WIFSTOPPED (lstatus))
a55c2b68 592 return scm_from_int (WSTOPSIG (lstatus));
67ec3667
GH
593 else
594 return SCM_BOOL_F;
595}
1bbd0b84 596#undef FUNC_NAME
82893676 597#endif /* __MINGW32__ */
0f2d19dd 598
82893676 599#ifdef HAVE_GETPPID
a1ec6916 600SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
1bbd0b84 601 (),
1e6808ea
MG
602 "Return an integer representing the process ID of the parent\n"
603 "process.")
1bbd0b84 604#define FUNC_NAME s_scm_getppid
0f2d19dd 605{
e11e83f3 606 return scm_from_int (getppid ());
0f2d19dd 607}
1bbd0b84 608#undef FUNC_NAME
82893676 609#endif /* HAVE_GETPPID */
0f2d19dd
JB
610
611
82893676 612#ifndef __MINGW32__
a1ec6916 613SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
1bbd0b84 614 (),
1e6808ea 615 "Return an integer representing the current real user ID.")
1bbd0b84 616#define FUNC_NAME s_scm_getuid
0f2d19dd 617{
e11e83f3 618 return scm_from_int (getuid ());
0f2d19dd 619}
1bbd0b84 620#undef FUNC_NAME
0f2d19dd
JB
621
622
623
a1ec6916 624SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0,
1bbd0b84 625 (),
1e6808ea 626 "Return an integer representing the current real group ID.")
1bbd0b84 627#define FUNC_NAME s_scm_getgid
0f2d19dd 628{
e11e83f3 629 return scm_from_int (getgid ());
0f2d19dd 630}
1bbd0b84 631#undef FUNC_NAME
0f2d19dd
JB
632
633
634
a1ec6916 635SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0,
1bbd0b84 636 (),
1e6808ea 637 "Return an integer representing the current effective user ID.\n"
b380b885 638 "If the system does not support effective IDs, then the real ID\n"
480fa28d 639 "is returned. @code{(provided? 'EIDs)} reports whether the\n"
1e6808ea 640 "system supports effective IDs.")
1bbd0b84 641#define FUNC_NAME s_scm_geteuid
0f2d19dd
JB
642{
643#ifdef HAVE_GETEUID
e11e83f3 644 return scm_from_int (geteuid ());
0f2d19dd 645#else
e11e83f3 646 return scm_from_int (getuid ());
0f2d19dd
JB
647#endif
648}
1bbd0b84 649#undef FUNC_NAME
0f2d19dd
JB
650
651
a1ec6916 652SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0,
1bbd0b84 653 (),
1e6808ea 654 "Return an integer representing the current effective group ID.\n"
b380b885 655 "If the system does not support effective IDs, then the real ID\n"
480fa28d 656 "is returned. @code{(provided? 'EIDs)} reports whether the\n"
1e6808ea 657 "system supports effective IDs.")
1bbd0b84 658#define FUNC_NAME s_scm_getegid
0f2d19dd
JB
659{
660#ifdef HAVE_GETEUID
e11e83f3 661 return scm_from_int (getegid ());
0f2d19dd 662#else
e11e83f3 663 return scm_from_int (getgid ());
0f2d19dd
JB
664#endif
665}
1bbd0b84 666#undef FUNC_NAME
0f2d19dd
JB
667
668
a1ec6916 669SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0,
1bbd0b84 670 (SCM id),
b380b885
MD
671 "Sets both the real and effective user IDs to the integer @var{id}, provided\n"
672 "the process has appropriate privileges.\n"
673 "The return value is unspecified.")
1bbd0b84 674#define FUNC_NAME s_scm_setuid
0f2d19dd 675{
a55c2b68 676 if (setuid (scm_to_int (id)) != 0)
1bbd0b84 677 SCM_SYSERROR;
02b754d3 678 return SCM_UNSPECIFIED;
0f2d19dd 679}
1bbd0b84 680#undef FUNC_NAME
0f2d19dd 681
a1ec6916 682SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0,
1bbd0b84 683 (SCM id),
b380b885
MD
684 "Sets both the real and effective group IDs to the integer @var{id}, provided\n"
685 "the process has appropriate privileges.\n"
686 "The return value is unspecified.")
1bbd0b84 687#define FUNC_NAME s_scm_setgid
0f2d19dd 688{
a55c2b68 689 if (setgid (scm_to_int (id)) != 0)
1bbd0b84 690 SCM_SYSERROR;
02b754d3 691 return SCM_UNSPECIFIED;
0f2d19dd 692}
1bbd0b84 693#undef FUNC_NAME
0f2d19dd 694
a1ec6916 695SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
1bbd0b84 696 (SCM id),
b380b885
MD
697 "Sets the effective user ID to the integer @var{id}, provided the process\n"
698 "has appropriate privileges. If effective IDs are not supported, the\n"
480fa28d 699 "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
b380b885
MD
700 "system supports effective IDs.\n"
701 "The return value is unspecified.")
1bbd0b84 702#define FUNC_NAME s_scm_seteuid
0f2d19dd 703{
02b754d3
GH
704 int rv;
705
0f2d19dd 706#ifdef HAVE_SETEUID
a55c2b68 707 rv = seteuid (scm_to_int (id));
0f2d19dd 708#else
a55c2b68 709 rv = setuid (scm_to_int (id));
0f2d19dd 710#endif
02b754d3 711 if (rv != 0)
1bbd0b84 712 SCM_SYSERROR;
02b754d3 713 return SCM_UNSPECIFIED;
0f2d19dd 714}
1bbd0b84 715#undef FUNC_NAME
7beabedb
MG
716#endif /* __MINGW32__ */
717
0f2d19dd 718
0e958795 719#ifdef HAVE_SETEGID
a1ec6916 720SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
1bbd0b84 721 (SCM id),
b380b885
MD
722 "Sets the effective group ID to the integer @var{id}, provided the process\n"
723 "has appropriate privileges. If effective IDs are not supported, the\n"
480fa28d 724 "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
b380b885
MD
725 "system supports effective IDs.\n"
726 "The return value is unspecified.")
1bbd0b84 727#define FUNC_NAME s_scm_setegid
0f2d19dd 728{
02b754d3
GH
729 int rv;
730
0f2d19dd 731#ifdef HAVE_SETEUID
a55c2b68 732 rv = setegid (scm_to_int (id));
0f2d19dd 733#else
a55c2b68 734 rv = setgid (scm_to_int (id));
0f2d19dd 735#endif
02b754d3 736 if (rv != 0)
1bbd0b84 737 SCM_SYSERROR;
02b754d3
GH
738 return SCM_UNSPECIFIED;
739
0f2d19dd 740}
1bbd0b84 741#undef FUNC_NAME
0e958795 742#endif
0f2d19dd 743
82893676
MG
744
745#ifdef HAVE_GETPGRP
a1ec6916 746SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0,
1bbd0b84 747 (),
1e6808ea 748 "Return an integer representing the current process group ID.\n"
b380b885 749 "This is the POSIX definition, not BSD.")
1bbd0b84 750#define FUNC_NAME s_scm_getpgrp
0f2d19dd
JB
751{
752 int (*fn)();
4625e44f 753 fn = (int (*) ()) getpgrp;
e11e83f3 754 return scm_from_int (fn (0));
0f2d19dd 755}
1bbd0b84 756#undef FUNC_NAME
82893676
MG
757#endif /* HAVE_GETPGRP */
758
0f2d19dd 759
f25f761d 760#ifdef HAVE_SETPGID
a1ec6916 761SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0,
1bbd0b84 762 (SCM pid, SCM pgid),
b380b885
MD
763 "Move the process @var{pid} into the process group @var{pgid}. @var{pid} or\n"
764 "@var{pgid} must be integers: they can be zero to indicate the ID of the\n"
765 "current process.\n"
766 "Fails on systems that do not support job control.\n"
767 "The return value is unspecified.")
1bbd0b84 768#define FUNC_NAME s_scm_setpgid
0f2d19dd 769{
02b754d3 770 /* FIXME(?): may be known as setpgrp. */
a55c2b68 771 if (setpgid (scm_to_int (pid), scm_to_int (pgid)) != 0)
1bbd0b84 772 SCM_SYSERROR;
02b754d3 773 return SCM_UNSPECIFIED;
0f2d19dd 774}
1bbd0b84 775#undef FUNC_NAME
f25f761d 776#endif /* HAVE_SETPGID */
0f2d19dd 777
f25f761d 778#ifdef HAVE_SETSID
a1ec6916 779SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0,
1bbd0b84 780 (),
b380b885
MD
781 "Creates a new session. The current process becomes the session leader\n"
782 "and is put in a new process group. The process will be detached\n"
783 "from its controlling terminal if it has one.\n"
784 "The return value is an integer representing the new process group ID.")
1bbd0b84 785#define FUNC_NAME s_scm_setsid
0f2d19dd
JB
786{
787 pid_t sid = setsid ();
02b754d3 788 if (sid == -1)
1bbd0b84 789 SCM_SYSERROR;
02b754d3 790 return SCM_UNSPECIFIED;
0f2d19dd 791}
1bbd0b84 792#undef FUNC_NAME
f25f761d 793#endif /* HAVE_SETSID */
0f2d19dd 794
e8a59063
KR
795
796/* ttyname returns its result in a single static buffer, hence
797 scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads
798 continuously calling ttyname will otherwise get an overwrite quite
799 easily.
800
801 ttyname_r (when available) could be used instead of scm_i_misc_mutex, but
802 there's probably little to be gained in either speed or parallelism. */
803
82893676 804#ifdef HAVE_TTYNAME
a1ec6916 805SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
1bbd0b84 806 (SCM port),
1e6808ea
MG
807 "Return a string with the name of the serial terminal device\n"
808 "underlying @var{port}.")
1bbd0b84 809#define FUNC_NAME s_scm_ttyname
0f2d19dd 810{
1d1559ce 811 char *result;
e8a59063
KR
812 int fd, err;
813 SCM ret;
78446828
MV
814
815 port = SCM_COERCE_OUTPORT (port);
34d19ef6 816 SCM_VALIDATE_OPPORT (1, port);
a98bddfd 817 if (!SCM_FPORTP (port))
0f2d19dd 818 return SCM_BOOL_F;
ee149d03 819 fd = SCM_FPORT_FDES (port);
e8a59063
KR
820
821 scm_mutex_lock (&scm_i_misc_mutex);
1d1559ce 822 SCM_SYSCALL (result = ttyname (fd));
e8a59063 823 err = errno;
cc95e00a 824 ret = scm_from_locale_string (result);
e8a59063
KR
825 scm_mutex_unlock (&scm_i_misc_mutex);
826
1d1559ce 827 if (!result)
e8a59063
KR
828 {
829 errno = err;
830 SCM_SYSERROR;
831 }
832 return ret;
0f2d19dd 833}
1bbd0b84 834#undef FUNC_NAME
82893676 835#endif /* HAVE_TTYNAME */
0f2d19dd 836
e8a59063 837
0a9d83b0
KR
838/* For thread safety "buf" is used instead of NULL for the ctermid static
839 buffer. Actually it's unlikely the controlling terminal will change
840 during program execution, and indeed on glibc (2.3.2) it's always just
841 "/dev/tty", but L_ctermid on the stack is easy and fast and guarantees
842 safety everywhere. */
f25f761d 843#ifdef HAVE_CTERMID
a1ec6916 844SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0,
1bbd0b84 845 (),
1e6808ea
MG
846 "Return a string containing the file name of the controlling\n"
847 "terminal for the current process.")
1bbd0b84 848#define FUNC_NAME s_scm_ctermid
0f2d19dd 849{
0a9d83b0
KR
850 char buf[L_ctermid];
851 char *result = ctermid (buf);
02b754d3 852 if (*result == '\0')
1bbd0b84 853 SCM_SYSERROR;
cc95e00a 854 return scm_from_locale_string (result);
0f2d19dd 855}
1bbd0b84 856#undef FUNC_NAME
f25f761d 857#endif /* HAVE_CTERMID */
0f2d19dd 858
f25f761d 859#ifdef HAVE_TCGETPGRP
a1ec6916 860SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
1bbd0b84 861 (SCM port),
1e6808ea
MG
862 "Return the process group ID of the foreground process group\n"
863 "associated with the terminal open on the file descriptor\n"
864 "underlying @var{port}.\n"
865 "\n"
b380b885
MD
866 "If there is no foreground process group, the return value is a\n"
867 "number greater than 1 that does not match the process group ID\n"
868 "of any existing process group. This can happen if all of the\n"
869 "processes in the job that was formerly the foreground job have\n"
870 "terminated, and no other job has yet been moved into the\n"
871 "foreground.")
1bbd0b84 872#define FUNC_NAME s_scm_tcgetpgrp
0f2d19dd
JB
873{
874 int fd;
875 pid_t pgid;
78446828
MV
876
877 port = SCM_COERCE_OUTPORT (port);
878
34d19ef6 879 SCM_VALIDATE_OPFPORT (1, port);
ee149d03
JB
880 fd = SCM_FPORT_FDES (port);
881 if ((pgid = tcgetpgrp (fd)) == -1)
1bbd0b84 882 SCM_SYSERROR;
e11e83f3 883 return scm_from_int (pgid);
1bbd0b84
GB
884}
885#undef FUNC_NAME
f25f761d 886#endif /* HAVE_TCGETPGRP */
0f2d19dd 887
f25f761d 888#ifdef HAVE_TCSETPGRP
a1ec6916 889SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
1bbd0b84 890 (SCM port, SCM pgid),
b380b885
MD
891 "Set the foreground process group ID for the terminal used by the file\n"
892 "descriptor underlying @var{port} to the integer @var{pgid}.\n"
893 "The calling process\n"
894 "must be a member of the same session as @var{pgid} and must have the same\n"
895 "controlling terminal. The return value is unspecified.")
1bbd0b84 896#define FUNC_NAME s_scm_tcsetpgrp
0f2d19dd
JB
897{
898 int fd;
78446828
MV
899
900 port = SCM_COERCE_OUTPORT (port);
901
34d19ef6 902 SCM_VALIDATE_OPFPORT (1, port);
ee149d03 903 fd = SCM_FPORT_FDES (port);
a55c2b68 904 if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)
1bbd0b84 905 SCM_SYSERROR;
02b754d3 906 return SCM_UNSPECIFIED;
1bbd0b84
GB
907}
908#undef FUNC_NAME
f25f761d 909#endif /* HAVE_TCSETPGRP */
0f2d19dd 910
7f03f970
MV
911static void
912free_string_pointers (void *data)
0f2d19dd 913{
7f03f970 914 scm_i_free_string_pointers ((char **)data);
0f2d19dd
JB
915}
916
a1ec6916 917SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
1bbd0b84 918 (SCM filename, SCM args),
b380b885
MD
919 "Executes the file named by @var{path} as a new process image.\n"
920 "The remaining arguments are supplied to the process; from a C program\n"
bb2c02f2 921 "they are accessible as the @code{argv} argument to @code{main}.\n"
b380b885 922 "Conventionally the first @var{arg} is the same as @var{path}.\n"
8f85c0c6 923 "All arguments must be strings.\n\n"
b380b885
MD
924 "If @var{arg} is missing, @var{path} is executed with a null\n"
925 "argument list, which may have system-dependent side-effects.\n\n"
926 "This procedure is currently implemented using the @code{execv} system\n"
927 "call, but we call it @code{execl} because of its Scheme calling interface.")
1bbd0b84 928#define FUNC_NAME s_scm_execl
0f2d19dd 929{
7f03f970
MV
930 char *exec_file;
931 char **exec_argv;
932
933 scm_frame_begin (0);
934
935 exec_file = scm_to_locale_string (filename);
936 scm_frame_free (exec_file);
937
938 exec_argv = scm_i_allocate_string_pointers (args);
939 scm_frame_unwind_handler (free_string_pointers, exec_argv,
940 SCM_F_WIND_EXPLICITLY);
941
942 execv (exec_file, exec_argv);
1bbd0b84 943 SCM_SYSERROR;
7f03f970 944
02b754d3 945 /* not reached. */
7f03f970 946 scm_frame_end ();
02b754d3 947 return SCM_BOOL_F;
0f2d19dd 948}
1bbd0b84 949#undef FUNC_NAME
0f2d19dd 950
a1ec6916 951SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
1bbd0b84 952 (SCM filename, SCM args),
b380b885
MD
953 "Similar to @code{execl}, however if\n"
954 "@var{filename} does not contain a slash\n"
955 "then the file to execute will be located by searching the\n"
956 "directories listed in the @code{PATH} environment variable.\n\n"
6bcd01fc 957 "This procedure is currently implemented using the @code{execvp} system\n"
b380b885 958 "call, but we call it @code{execlp} because of its Scheme calling interface.")
1bbd0b84 959#define FUNC_NAME s_scm_execlp
0f2d19dd 960{
7f03f970
MV
961 char *exec_file;
962 char **exec_argv;
963
964 scm_frame_begin (0);
965
966 exec_file = scm_to_locale_string (filename);
967 scm_frame_free (exec_file);
968
969 exec_argv = scm_i_allocate_string_pointers (args);
970 scm_frame_unwind_handler (free_string_pointers, exec_argv,
971 SCM_F_WIND_EXPLICITLY);
972
973 execvp (exec_file, exec_argv);
1bbd0b84 974 SCM_SYSERROR;
7f03f970 975
02b754d3 976 /* not reached. */
7f03f970 977 scm_frame_end ();
02b754d3 978 return SCM_BOOL_F;
0f2d19dd 979}
1bbd0b84 980#undef FUNC_NAME
0f2d19dd 981
6afcd3b2 982
807f353f
KR
983/* OPTIMIZE-ME: scm_execle doesn't need malloced copies of the environment
984 list strings the way environ_list_to_c gives. */
985
a1ec6916 986SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
1bbd0b84 987 (SCM filename, SCM env, SCM args),
b380b885
MD
988 "Similar to @code{execl}, but the environment of the new process is\n"
989 "specified by @var{env}, which must be a list of strings as returned by the\n"
990 "@code{environ} procedure.\n\n"
991 "This procedure is currently implemented using the @code{execve} system\n"
992 "call, but we call it @code{execle} because of its Scheme calling interface.")
1bbd0b84 993#define FUNC_NAME s_scm_execle
6afcd3b2 994{
7f03f970 995 char **exec_argv;
6afcd3b2 996 char **exec_env;
7f03f970 997 char *exec_file;
6afcd3b2 998
7f03f970
MV
999 scm_frame_begin (0);
1000
1001 exec_file = scm_to_locale_string (filename);
1002 scm_frame_free (exec_file);
1003
1004 exec_argv = scm_i_allocate_string_pointers (args);
1005 scm_frame_unwind_handler (free_string_pointers, exec_argv,
1006 SCM_F_WIND_EXPLICITLY);
1007
1008 exec_env = scm_i_allocate_string_pointers (env);
1009 scm_frame_unwind_handler (free_string_pointers, exec_env,
1010 SCM_F_WIND_EXPLICITLY);
1011
1012 execve (exec_file, exec_argv, exec_env);
1bbd0b84 1013 SCM_SYSERROR;
7f03f970 1014
6afcd3b2 1015 /* not reached. */
7f03f970 1016 scm_frame_end ();
6afcd3b2
GH
1017 return SCM_BOOL_F;
1018}
1bbd0b84 1019#undef FUNC_NAME
6afcd3b2 1020
82893676 1021#ifdef HAVE_FORK
a1ec6916 1022SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
1bbd0b84 1023 (),
b380b885
MD
1024 "Creates a new \"child\" process by duplicating the current \"parent\" process.\n"
1025 "In the child the return value is 0. In the parent the return value is\n"
1026 "the integer process ID of the child.\n\n"
1027 "This procedure has been renamed from @code{fork} to avoid a naming conflict\n"
1028 "with the scsh fork.")
1bbd0b84 1029#define FUNC_NAME s_scm_fork
0f2d19dd 1030{
bab0f4e5 1031 int pid;
0f2d19dd
JB
1032 pid = fork ();
1033 if (pid == -1)
1bbd0b84 1034 SCM_SYSERROR;
e11e83f3 1035 return scm_from_int (pid);
0f2d19dd 1036}
1bbd0b84 1037#undef FUNC_NAME
82893676 1038#endif /* HAVE_FORK */
0f2d19dd 1039
4f68365d
MV
1040#ifdef __MINGW32__
1041# include "win32-uname.h"
1042#endif
1043
1044#if defined (HAVE_UNAME) || defined (__MINGW32__)
a1ec6916 1045SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
1bbd0b84 1046 (),
1e6808ea
MG
1047 "Return an object with some information about the computer\n"
1048 "system the program is running on.")
1bbd0b84 1049#define FUNC_NAME s_scm_uname
0f2d19dd 1050{
0f2d19dd 1051 struct utsname buf;
1d1559ce 1052 SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
e1a191a8 1053 if (uname (&buf) < 0)
1bbd0b84 1054 SCM_SYSERROR;
cc95e00a
MV
1055 SCM_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname));
1056 SCM_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename));
1057 SCM_VECTOR_SET(result, 2, scm_from_locale_string (buf.release));
1058 SCM_VECTOR_SET(result, 3, scm_from_locale_string (buf.version));
1059 SCM_VECTOR_SET(result, 4, scm_from_locale_string (buf.machine));
0f2d19dd 1060/*
02b754d3 1061 a linux special?
cc95e00a 1062 SCM_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
0f2d19dd 1063*/
1d1559ce 1064 return result;
0f2d19dd 1065}
1bbd0b84 1066#undef FUNC_NAME
f25f761d 1067#endif /* HAVE_UNAME */
0f2d19dd 1068
a1ec6916 1069SCM_DEFINE (scm_environ, "environ", 0, 1, 0,
1bbd0b84 1070 (SCM env),
1e6808ea
MG
1071 "If @var{env} is omitted, return the current environment (in the\n"
1072 "Unix sense) as a list of strings. Otherwise set the current\n"
1073 "environment, which is also the default environment for child\n"
1074 "processes, to the supplied list of strings. Each member of\n"
1075 "@var{env} should be of the form @code{NAME=VALUE} and values of\n"
1076 "@code{NAME} should not be duplicated. If @var{env} is supplied\n"
1077 "then the return value is unspecified.")
1bbd0b84 1078#define FUNC_NAME s_scm_environ
0f2d19dd
JB
1079{
1080 if (SCM_UNBNDP (env))
1081 return scm_makfromstrs (-1, environ);
1082 else
1083 {
0f2d19dd 1084 char **new_environ;
6afcd3b2 1085
7f03f970 1086 new_environ = scm_i_allocate_string_pointers (env);
0f2d19dd
JB
1087 /* Free the old environment, except when called for the first
1088 * time.
1089 */
1090 {
0f2d19dd
JB
1091 static int first = 1;
1092 if (!first)
7f03f970 1093 scm_i_free_string_pointers (environ);
0f2d19dd
JB
1094 first = 0;
1095 }
1096 environ = new_environ;
1097 return SCM_UNSPECIFIED;
1098 }
1099}
1bbd0b84 1100#undef FUNC_NAME
0f2d19dd 1101
9ee5fce4
MD
1102#ifdef L_tmpnam
1103
a1ec6916 1104SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0,
1bbd0b84 1105 (),
1e6808ea
MG
1106 "Return a name in the file system that does not match any\n"
1107 "existing file. However there is no guarantee that another\n"
1108 "process will not create the file after @code{tmpnam} is called.\n"
1109 "Care should be taken if opening the file, e.g., use the\n"
1110 "@code{O_EXCL} open flag or use @code{mkstemp!} instead.")
1bbd0b84 1111#define FUNC_NAME s_scm_tmpnam
9ee5fce4
MD
1112{
1113 char name[L_tmpnam];
6d163216
GH
1114 char *rv;
1115
1116 SCM_SYSCALL (rv = tmpnam (name));
1117 if (rv == NULL)
1118 /* not SCM_SYSERROR since errno probably not set. */
1119 SCM_MISC_ERROR ("tmpnam failed", SCM_EOL);
cc95e00a 1120 return scm_from_locale_string (name);
9ee5fce4 1121}
0f981281 1122#undef FUNC_NAME
0f2d19dd 1123
1bbd0b84 1124#endif
1cc91f1b 1125
4f68365d
MV
1126#ifndef HAVE_MKSTEMP
1127extern int mkstemp (char *);
1128#endif
1129
6d163216
GH
1130SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
1131 (SCM tmpl),
1e6808ea
MG
1132 "Create a new unique file in the file system and returns a new\n"
1133 "buffered port open for reading and writing to the file.\n"
1134 "@var{tmpl} is a string specifying where the file should be\n"
1135 "created: it must end with @code{XXXXXX} and will be changed in\n"
1136 "place to return the name of the temporary file.")
6d163216
GH
1137#define FUNC_NAME s_scm_mkstemp
1138{
1139 char *c_tmpl;
71978ac9 1140 int rv;
6d163216 1141
892065da
MV
1142 scm_frame_begin (0);
1143
1144 c_tmpl = scm_to_locale_string (tmpl);
1145 scm_frame_free (c_tmpl);
1146
6d163216
GH
1147 SCM_SYSCALL (rv = mkstemp (c_tmpl));
1148 if (rv == -1)
1149 SCM_SYSERROR;
892065da
MV
1150
1151 scm_substring_move_x (scm_from_locale_string (c_tmpl),
1152 SCM_INUM0, scm_string_length (tmpl),
1153 tmpl, SCM_INUM0);
1154
1155 scm_frame_end ();
6d163216
GH
1156 return scm_fdes_to_port (rv, "w+", tmpl);
1157}
1158#undef FUNC_NAME
1159
a1ec6916 1160SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
1bbd0b84 1161 (SCM pathname, SCM actime, SCM modtime),
1e6808ea
MG
1162 "@code{utime} sets the access and modification times for the\n"
1163 "file named by @var{path}. If @var{actime} or @var{modtime} is\n"
1164 "not supplied, then the current time is used. @var{actime} and\n"
1165 "@var{modtime} must be integer time values as returned by the\n"
1166 "@code{current-time} procedure.\n"
1167 "@lisp\n"
b380b885 1168 "(utime \"foo\" (- (current-time) 3600))\n"
1e6808ea
MG
1169 "@end lisp\n"
1170 "will set the access time to one hour in the past and the\n"
1171 "modification time to the current time.")
1bbd0b84 1172#define FUNC_NAME s_scm_utime
0f2d19dd
JB
1173{
1174 int rv;
1175 struct utimbuf utm_tmp;
1176
0f2d19dd
JB
1177 if (SCM_UNBNDP (actime))
1178 SCM_SYSCALL (time (&utm_tmp.actime));
1179 else
e4b265d8 1180 utm_tmp.actime = SCM_NUM2ULONG (2, actime);
0f2d19dd
JB
1181
1182 if (SCM_UNBNDP (modtime))
1183 SCM_SYSCALL (time (&utm_tmp.modtime));
1184 else
e4b265d8 1185 utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
0f2d19dd 1186
f015614a
MV
1187 STRING_SYSCALL (pathname, c_pathname,
1188 rv = utime (c_pathname, &utm_tmp));
02b754d3 1189 if (rv != 0)
1bbd0b84 1190 SCM_SYSERROR;
02b754d3 1191 return SCM_UNSPECIFIED;
0f2d19dd 1192}
1bbd0b84 1193#undef FUNC_NAME
0f2d19dd 1194
a1ec6916 1195SCM_DEFINE (scm_access, "access?", 2, 0, 0,
1bbd0b84 1196 (SCM path, SCM how),
1e6808ea
MG
1197 "Return @code{#t} if @var{path} corresponds to an existing file\n"
1198 "and the current process has the type of access specified by\n"
1199 "@var{how}, otherwise @code{#f}. @var{how} should be specified\n"
1200 "using the values of the variables listed below. Multiple\n"
1201 "values can be combined using a bitwise or, in which case\n"
1202 "@code{#t} will only be returned if all accesses are granted.\n"
1203 "\n"
1204 "Permissions are checked using the real id of the current\n"
1205 "process, not the effective id, although it's the effective id\n"
1206 "which determines whether the access would actually be granted.\n"
1207 "\n"
b380b885
MD
1208 "@defvar R_OK\n"
1209 "test for read permission.\n"
1210 "@end defvar\n"
1211 "@defvar W_OK\n"
1212 "test for write permission.\n"
1213 "@end defvar\n"
1214 "@defvar X_OK\n"
1215 "test for execute permission.\n"
1216 "@end defvar\n"
1217 "@defvar F_OK\n"
1218 "test for existence of the file.\n"
1219 "@end defvar")
1bbd0b84 1220#define FUNC_NAME s_scm_access
0f2d19dd
JB
1221{
1222 int rv;
1223
f015614a
MV
1224 WITH_STRING (path, c_path,
1225 rv = access (c_path, scm_to_int (how)));
7888309b 1226 return scm_from_bool (!rv);
0f2d19dd 1227}
1bbd0b84 1228#undef FUNC_NAME
0f2d19dd 1229
a1ec6916 1230SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0,
1bbd0b84 1231 (),
1e6808ea 1232 "Return an integer representing the current process ID.")
1bbd0b84 1233#define FUNC_NAME s_scm_getpid
0f2d19dd 1234{
e11e83f3 1235 return scm_from_ulong (getpid ());
0f2d19dd 1236}
1bbd0b84 1237#undef FUNC_NAME
0f2d19dd 1238
a1ec6916 1239SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
1bbd0b84 1240 (SCM str),
b380b885
MD
1241 "Modifies the environment of the current process, which is\n"
1242 "also the default environment inherited by child processes.\n\n"
1243 "If @var{string} is of the form @code{NAME=VALUE} then it will be written\n"
1244 "directly into the environment, replacing any existing environment string\n"
1245 "with\n"
1246 "name matching @code{NAME}. If @var{string} does not contain an equal\n"
1247 "sign, then any existing string with name matching @var{string} will\n"
1248 "be removed.\n\n"
1249 "The return value is unspecified.")
1bbd0b84 1250#define FUNC_NAME s_scm_putenv
0f2d19dd 1251{
f158788f 1252 int rv;
f015614a
MV
1253 char *c_str = scm_to_locale_string (str);
1254#ifdef __MINGW32__
1255 size_t len = strlen (c_str);
1256#endif
002409fe 1257
f015614a 1258 if (strchr (c_str, '=') == NULL)
002409fe 1259 {
1e498fbd 1260#ifdef HAVE_UNSETENV
002409fe 1261 /* No '=' in argument means we should remove the variable from
ff4b8391
KR
1262 the environment. Not all putenvs understand this (for instance
1263 FreeBSD 4.8 doesn't). To be safe, we do it explicitely using
1264 unsetenv. */
f015614a
MV
1265 unsetenv (c_str);
1266 free (c_str);
1e498fbd
SJ
1267#else
1268 /* On e.g. Win32 hosts putenv() called with 'name=' removes the
1269 environment variable 'name'. */
f158788f 1270 int e;
f015614a
MV
1271 ptr = scm_malloc (len + 2);
1272 strcpy (ptr, c_str);
1273 strcpy (ptr+len, "=");
1e498fbd 1274 rv = putenv (ptr);
f015614a 1275 e = errno; free (ptr); free (c_str); errno = e;
1e498fbd
SJ
1276 if (rv < 0)
1277 SCM_SYSERROR;
fcc5d734 1278#endif /* !HAVE_UNSETENV */
002409fe
MV
1279 }
1280 else
1281 {
fcc5d734
SJ
1282#ifdef __MINGW32__
1283 /* If str is "FOO=", ie. attempting to set an empty string, then
1284 we need to see if it's been successful. On MINGW, "FOO="
1285 means remove FOO from the environment. As a workaround, we
1286 set "FOO= ", ie. a space, and then modify the string returned
1287 by getenv. It's not enough just to modify the string we set,
1288 because MINGW putenv copies it. */
f015614a
MV
1289
1290 if (c_str[len-1] == '=')
fcc5d734 1291 {
f015614a
MV
1292 char *ptr = scm_malloc (len+2);
1293 strcpy (ptr, c_str);
1294 strcpy (ptr+len, " ");
1295 rv = putenv (ptr);
1296 if (rv < 0)
1297 {
1298 int eno = errno;
1299 free (c_str);
1300 errno = eno;
1301 SCM_SYSERROR;
fcc5d734 1302 }
f015614a
MV
1303 /* truncate to just the name */
1304 c_str[len-1] = '\0';
1305 ptr = getenv (c_str);
1306 if (ptr)
1307 ptr[0] = '\0';
fcc5d734
SJ
1308 return SCM_UNSPECIFIED;
1309 }
1310#endif /* __MINGW32__ */
1311
f015614a
MV
1312 /* Leave c_str in the environment. */
1313
1314 rv = putenv (c_str);
002409fe
MV
1315 if (rv < 0)
1316 SCM_SYSERROR;
1317 }
f93ddd39 1318 return SCM_UNSPECIFIED;
0f2d19dd 1319}
1bbd0b84 1320#undef FUNC_NAME
0f2d19dd 1321
f25f761d 1322#ifdef HAVE_SETLOCALE
a1ec6916 1323SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
1bbd0b84 1324 (SCM category, SCM locale),
1e6808ea
MG
1325 "If @var{locale} is omitted, return the current value of the\n"
1326 "specified locale category as a system-dependent string.\n"
1327 "@var{category} should be specified using the values\n"
1328 "@code{LC_COLLATE}, @code{LC_ALL} etc.\n"
1329 "\n"
1330 "Otherwise the specified locale category is set to the string\n"
1331 "@var{locale} and the new value is returned as a\n"
1332 "system-dependent string. If @var{locale} is an empty string,\n"
bb2c02f2 1333 "the locale will be set using environment variables.")
1bbd0b84 1334#define FUNC_NAME s_scm_setlocale
0f2d19dd 1335{
0f2d19dd
JB
1336 char *clocale;
1337 char *rv;
1338
f015614a
MV
1339 scm_frame_begin (0);
1340
0f2d19dd
JB
1341 if (SCM_UNBNDP (locale))
1342 {
1343 clocale = NULL;
1344 }
1345 else
1346 {
f015614a
MV
1347 clocale = scm_to_locale_string (locale);
1348 scm_frame_free (clocale);
0f2d19dd
JB
1349 }
1350
a55c2b68 1351 rv = setlocale (scm_to_int (category), clocale);
02b754d3 1352 if (rv == NULL)
1bbd0b84 1353 SCM_SYSERROR;
f015614a
MV
1354
1355 scm_frame_end ();
1356 return scm_from_locale_string (rv);
0f2d19dd 1357}
1bbd0b84 1358#undef FUNC_NAME
f25f761d 1359#endif /* HAVE_SETLOCALE */
0f2d19dd 1360
f25f761d 1361#ifdef HAVE_MKNOD
a1ec6916 1362SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
1bbd0b84 1363 (SCM path, SCM type, SCM perms, SCM dev),
b380b885
MD
1364 "Creates a new special file, such as a file corresponding to a device.\n"
1365 "@var{path} specifies the name of the file. @var{type} should\n"
1366 "be one of the following symbols:\n"
1367 "regular, directory, symlink, block-special, char-special,\n"
1368 "fifo, or socket. @var{perms} (an integer) specifies the file permissions.\n"
1369 "@var{dev} (an integer) specifies which device the special file refers\n"
1370 "to. Its exact interpretation depends on the kind of special file\n"
1371 "being created.\n\n"
1372 "E.g.,\n"
1e6808ea 1373 "@lisp\n"
09831f94 1374 "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n"
1e6808ea 1375 "@end lisp\n\n"
a3c8b9fc 1376 "The return value is unspecified.")
1bbd0b84 1377#define FUNC_NAME s_scm_mknod
0f2d19dd 1378{
0f2d19dd 1379 int val;
cc95e00a 1380 const char *p;
82a76bdf 1381 int ctype = 0;
19468eff 1382
a6d9e5ab 1383 SCM_VALIDATE_STRING (1, path);
34d19ef6 1384 SCM_VALIDATE_SYMBOL (2, type);
19468eff 1385
cc95e00a 1386 p = scm_i_symbol_chars (type);
19468eff
GH
1387 if (strcmp (p, "regular") == 0)
1388 ctype = S_IFREG;
1389 else if (strcmp (p, "directory") == 0)
1390 ctype = S_IFDIR;
1391 else if (strcmp (p, "symlink") == 0)
1392 ctype = S_IFLNK;
1393 else if (strcmp (p, "block-special") == 0)
1394 ctype = S_IFBLK;
1395 else if (strcmp (p, "char-special") == 0)
1396 ctype = S_IFCHR;
1397 else if (strcmp (p, "fifo") == 0)
1398 ctype = S_IFIFO;
e655d034 1399#ifdef S_IFSOCK
19468eff
GH
1400 else if (strcmp (p, "socket") == 0)
1401 ctype = S_IFSOCK;
e655d034 1402#endif
19468eff 1403 else
34d19ef6 1404 SCM_OUT_OF_RANGE (2, type);
19468eff 1405
f015614a
MV
1406 STRING_SYSCALL (path, c_path,
1407 val = mknod (c_path,
1408 ctype | scm_to_int (perms),
1409 scm_to_int (dev)));
02b754d3 1410 if (val != 0)
1bbd0b84 1411 SCM_SYSERROR;
02b754d3 1412 return SCM_UNSPECIFIED;
0f2d19dd 1413}
1bbd0b84 1414#undef FUNC_NAME
f25f761d 1415#endif /* HAVE_MKNOD */
0f2d19dd 1416
f25f761d 1417#ifdef HAVE_NICE
a1ec6916 1418SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
1bbd0b84 1419 (SCM incr),
b380b885
MD
1420 "Increment the priority of the current process by @var{incr}. A higher\n"
1421 "priority value means that the process runs less often.\n"
1422 "The return value is unspecified.")
1bbd0b84 1423#define FUNC_NAME s_scm_nice
0f2d19dd 1424{
a55c2b68 1425 if (nice (scm_to_int (incr)) != 0)
1bbd0b84 1426 SCM_SYSERROR;
02b754d3 1427 return SCM_UNSPECIFIED;
0f2d19dd 1428}
1bbd0b84 1429#undef FUNC_NAME
f25f761d 1430#endif /* HAVE_NICE */
0f2d19dd 1431
f25f761d 1432#ifdef HAVE_SYNC
a1ec6916 1433SCM_DEFINE (scm_sync, "sync", 0, 0, 0,
1bbd0b84 1434 (),
b380b885
MD
1435 "Flush the operating system disk buffers.\n"
1436 "The return value is unspecified.")
1bbd0b84 1437#define FUNC_NAME s_scm_sync
0f2d19dd 1438{
0f2d19dd 1439 sync();
127ec750 1440 return SCM_UNSPECIFIED;
0f2d19dd 1441}
1bbd0b84 1442#undef FUNC_NAME
f25f761d 1443#endif /* HAVE_SYNC */
0f2d19dd 1444
33bea692
KR
1445
1446/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex
1447 to avoid another thread overwriting it. A test program running crypt
1448 continuously in two threads can be quickly seen tripping this problem.
1449 crypt() is pretty slow normally, so a mutex shouldn't add much overhead.
1450
1451 glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot
1452 slower (about 5x) than plain crypt if you pass an uninitialized data
1453 block each time. Presumably there's some one-time setups. The best way
1454 to use crypt_r for parallel execution in multiple threads would probably
1455 be to maintain a little pool of initialized crypt_data structures, take
1456 one and use it, then return it to the pool. That pool could be garbage
1457 collected so it didn't add permanently to memory use if only a few crypt
1458 calls are made. But we expect crypt will be used rarely, and even more
1459 rarely will there be any desire for lots of parallel execution on
1460 multiple cpus. So for now we don't bother with anything fancy, just
1461 ensure it works. */
1462
b9a7b725 1463#if HAVE_CRYPT
33bea692 1464SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
94e6d793
MG
1465 (SCM key, SCM salt),
1466 "Encrypt @var{key} using @var{salt} as the salt value to the\n"
9401323e 1467 "crypt(3) library call.")
94e6d793
MG
1468#define FUNC_NAME s_scm_crypt
1469{
33bea692 1470 SCM ret;
f015614a 1471 char *c_key, *c_salt;
94e6d793 1472
33bea692
KR
1473 scm_frame_begin (0);
1474 scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock,
1475 &scm_i_misc_mutex,
1476 SCM_F_WIND_EXPLICITLY);
1477 scm_mutex_lock (&scm_i_misc_mutex);
1478
f015614a
MV
1479 c_key = scm_to_locale_string (key);
1480 scm_frame_free (c_key);
1481 c_salt = scm_to_locale_string (salt);
1482 scm_frame_free (c_key);
1483
1484 ret = scm_from_locale_string (crypt (c_key, c_salt));
33bea692
KR
1485
1486 scm_frame_end ();
1487 return ret;
94e6d793
MG
1488}
1489#undef FUNC_NAME
b9a7b725 1490#endif /* HAVE_CRYPT */
94e6d793
MG
1491
1492#if HAVE_CHROOT
1493SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
1494 (SCM path),
1495 "Change the root directory to that specified in @var{path}.\n"
1496 "This directory will be used for path names beginning with\n"
1497 "@file{/}. The root directory is inherited by all children\n"
1498 "of the current process. Only the superuser may change the\n"
1499 "root directory.")
1500#define FUNC_NAME s_scm_chroot
1501{
f015614a 1502 int rv;
94e6d793 1503
f015614a
MV
1504 WITH_STRING (path, c_path,
1505 rv = chroot (c_path));
1506 if (rv == -1)
94e6d793
MG
1507 SCM_SYSERROR;
1508 return SCM_UNSPECIFIED;
1509}
1510#undef FUNC_NAME
1511#endif /* HAVE_CHROOT */
1512
7beabedb
MG
1513
1514#ifdef __MINGW32__
1515/* Wrapper function to supplying `getlogin()' under Windows. */
1516static char * getlogin (void)
1517{
1518 static char user[256];
1519 static unsigned long len = 256;
1520
1521 if (!GetUserName (user, &len))
1522 return NULL;
1523 return user;
1524}
1525#endif /* __MINGW32__ */
1526
1527
4f68365d 1528#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
94e6d793
MG
1529SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
1530 (void),
1531 "Return a string containing the name of the user logged in on\n"
1532 "the controlling terminal of the process, or @code{#f} if this\n"
1533 "information cannot be obtained.")
1534#define FUNC_NAME s_scm_getlogin
1535{
1536 char * p;
1537
1538 p = getlogin ();
1539 if (!p || !*p)
1540 return SCM_BOOL_F;
cc95e00a 1541 return scm_from_locale_string (p);
94e6d793
MG
1542}
1543#undef FUNC_NAME
1544#endif /* HAVE_GETLOGIN */
1545
1546#if HAVE_CUSERID
1547SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
1548 (void),
1549 "Return a string containing a user name associated with the\n"
1550 "effective user id of the process. Return @code{#f} if this\n"
1551 "information cannot be obtained.")
1552#define FUNC_NAME s_scm_cuserid
1553{
1b317eb1 1554 char buf[L_cuserid];
94e6d793
MG
1555 char * p;
1556
1b317eb1 1557 p = cuserid (buf);
94e6d793
MG
1558 if (!p || !*p)
1559 return SCM_BOOL_F;
cc95e00a 1560 return scm_from_locale_string (p);
94e6d793
MG
1561}
1562#undef FUNC_NAME
1563#endif /* HAVE_CUSERID */
1564
1565#if HAVE_GETPRIORITY
1566SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
1567 (SCM which, SCM who),
1568 "Return the scheduling priority of the process, process group\n"
1569 "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
1570 "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
1571 "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
1572 "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
1573 "process group identifier for @code{PRIO_PGRP}, and a user\n"
1574 "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
1575 "denotes the current process, process group, or user. Return\n"
1576 "the highest priority (lowest numerical value) of any of the\n"
1577 "specified processes.")
1578#define FUNC_NAME s_scm_getpriority
1579{
1580 int cwhich, cwho, ret;
1581
a55c2b68
MV
1582 cwhich = scm_to_int (which);
1583 cwho = scm_to_int (who);
94e6d793
MG
1584
1585 /* We have to clear errno and examine it later, because -1 is a
1586 legal return value for getpriority(). */
1587 errno = 0;
1588 ret = getpriority (cwhich, cwho);
1589 if (errno != 0)
1590 SCM_SYSERROR;
a55c2b68 1591 return scm_from_int (ret);
94e6d793
MG
1592}
1593#undef FUNC_NAME
1594#endif /* HAVE_GETPRIORITY */
1595
1596#if HAVE_SETPRIORITY
1597SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
1598 (SCM which, SCM who, SCM prio),
1599 "Set the scheduling priority of the process, process group\n"
1600 "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
1601 "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
1602 "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
1603 "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
1604 "process group identifier for @code{PRIO_PGRP}, and a user\n"
1605 "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
1606 "denotes the current process, process group, or user.\n"
1607 "@var{prio} is a value in the range -20 and 20, the default\n"
1608 "priority is 0; lower priorities cause more favorable\n"
1609 "scheduling. Sets the priority of all of the specified\n"
1610 "processes. Only the super-user may lower priorities.\n"
1611 "The return value is not specified.")
1612#define FUNC_NAME s_scm_setpriority
1613{
1614 int cwhich, cwho, cprio;
1615
a55c2b68
MV
1616 cwhich = scm_to_int (which);
1617 cwho = scm_to_int (who);
1618 cprio = scm_to_int (prio);
94e6d793
MG
1619
1620 if (setpriority (cwhich, cwho, cprio) == -1)
1621 SCM_SYSERROR;
1622 return SCM_UNSPECIFIED;
1623}
1624#undef FUNC_NAME
1625#endif /* HAVE_SETPRIORITY */
1626
1627#if HAVE_GETPASS
1628SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
1629 (SCM prompt),
1630 "Display @var{prompt} to the standard error output and read\n"
1631 "a password from @file{/dev/tty}. If this file is not\n"
1632 "accessible, it reads from standard input. The password may be\n"
1633 "up to 127 characters in length. Additional characters and the\n"
1634 "terminating newline character are discarded. While reading\n"
1635 "the password, echoing and the generation of signals by special\n"
1636 "characters is disabled.")
1637#define FUNC_NAME s_scm_getpass
1638{
1639 char * p;
1640 SCM passwd;
1641
1642 SCM_VALIDATE_STRING (1, prompt);
94e6d793 1643
f015614a
MV
1644 WITH_STRING (prompt, c_prompt,
1645 p = getpass(c_prompt));
1646 passwd = scm_from_locale_string (p);
94e6d793
MG
1647
1648 /* Clear out the password in the static buffer. */
1649 memset (p, 0, strlen (p));
1650
1651 return passwd;
1652}
1653#undef FUNC_NAME
1654#endif /* HAVE_GETPASS */
1655
8f99e3f3
SJ
1656/* Wrapper function for flock() support under M$-Windows. */
1657#ifdef __MINGW32__
1658# include <io.h>
1659# include <sys/locking.h>
1660# include <errno.h>
1661# ifndef _LK_UNLCK
1662 /* Current MinGW package fails to define this. *sigh* */
1663# define _LK_UNLCK 0
1664# endif
1665# define LOCK_EX 1
1666# define LOCK_UN 2
1667# define LOCK_SH 4
1668# define LOCK_NB 8
1669
1670static int flock (int fd, int operation)
1671{
1672 long pos, len;
1673 int ret, err;
1674
1675 /* Disable invalid arguments. */
1676 if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
1677 ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
1678 ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
1679 {
1680 errno = EINVAL;
1681 return -1;
1682 }
1683
1684 /* Determine mode of operation and discard unsupported ones. */
1685 if (operation == (LOCK_NB | LOCK_EX))
1686 operation = _LK_NBLCK;
1687 else if (operation & LOCK_UN)
1688 operation = _LK_UNLCK;
1689 else if (operation == LOCK_EX)
1690 operation = _LK_LOCK;
1691 else
1692 {
1693 errno = EINVAL;
1694 return -1;
1695 }
1696
1697 /* Save current file pointer and seek to beginning. */
1698 if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
1699 return -1;
1700 lseek (fd, 0L, SEEK_SET);
1701
1702 /* Deadlock if necessary. */
1703 do
1704 {
1705 ret = _locking (fd, operation, len);
1706 }
1707 while (ret == -1 && errno == EDEADLOCK);
1708
1709 /* Produce meaningful error message. */
1710 if (errno == EACCES && operation == _LK_NBLCK)
1711 err = EDEADLOCK;
1712 else
1713 err = errno;
1714
1715 /* Return to saved file position pointer. */
1716 lseek (fd, pos, SEEK_SET);
1717 errno = err;
1718 return ret;
1719}
1720#endif /* __MINGW32__ */
1721
1722#if HAVE_FLOCK || defined (__MINGW32__)
94e6d793
MG
1723SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
1724 (SCM file, SCM operation),
1725 "Apply or remove an advisory lock on an open file.\n"
1726 "@var{operation} specifies the action to be done:\n"
1727 "@table @code\n"
1728 "@item LOCK_SH\n"
1729 "Shared lock. More than one process may hold a shared lock\n"
1730 "for a given file at a given time.\n"
1731 "@item LOCK_EX\n"
1732 "Exclusive lock. Only one process may hold an exclusive lock\n"
1733 "for a given file at a given time.\n"
1734 "@item LOCK_UN\n"
1735 "Unlock the file.\n"
1736 "@item LOCK_NB\n"
1737 "Don't block when locking. May be specified by bitwise OR'ing\n"
1738 "it to one of the other operations.\n"
1739 "@end table\n"
1740 "The return value is not specified. @var{file} may be an open\n"
bb2c02f2 1741 "file descriptor or an open file descriptor port.")
94e6d793
MG
1742#define FUNC_NAME s_scm_flock
1743{
a55c2b68 1744 int fdes;
94e6d793 1745
a55c2b68
MV
1746 if (scm_is_integer (file))
1747 fdes = scm_to_int (file);
94e6d793
MG
1748 else
1749 {
1750 SCM_VALIDATE_OPFPORT (2, file);
1751
1752 fdes = SCM_FPORT_FDES (file);
1753 }
a55c2b68 1754 if (flock (fdes, scm_to_int (operation)) == -1)
94e6d793
MG
1755 SCM_SYSERROR;
1756 return SCM_UNSPECIFIED;
1757}
1758#undef FUNC_NAME
1759#endif /* HAVE_FLOCK */
1760
1761#if HAVE_SETHOSTNAME
1762SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
1763 (SCM name),
1764 "Set the host name of the current processor to @var{name}. May\n"
1765 "only be used by the superuser. The return value is not\n"
1766 "specified.")
1767#define FUNC_NAME s_scm_sethostname
1768{
f015614a 1769 int rv;
94e6d793 1770
f015614a
MV
1771 WITH_STRING (name, c_name,
1772 rv = sethostname (c_name, strlen(c_name)));
1773 if (rv == -1)
94e6d793
MG
1774 SCM_SYSERROR;
1775 return SCM_UNSPECIFIED;
1776}
1777#undef FUNC_NAME
1778#endif /* HAVE_SETHOSTNAME */
1779
b28f5b3c 1780
94e6d793
MG
1781#if HAVE_GETHOSTNAME
1782SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
1783 (void),
1784 "Return the host name of the current processor.")
1785#define FUNC_NAME s_scm_gethostname
1786{
b28f5b3c
DH
1787#ifdef MAXHOSTNAMELEN
1788
1789 /* Various systems define MAXHOSTNAMELEN (including Solaris in fact).
1790 * On GNU/Linux this doesn't include the terminating '\0', hence "+ 1". */
1791 const int len = MAXHOSTNAMELEN + 1;
1792 char *const p = scm_malloc (len);
1793 const int res = gethostname (p, len);
1794
1795 scm_frame_begin (0);
1796 scm_frame_unwind_handler (free, p, 0);
1797
1798#else
94e6d793 1799
0eaf1055 1800 /* Default 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
b28f5b3c
DH
1801 * large enough. SUSv2 specifies 255 maximum too, apparently. */
1802 int len = 256;
1803 int res;
1804 char *p;
0eaf1055 1805
b28f5b3c 1806# if HAVE_SYSCONF && defined (_SC_HOST_NAME_MAX)
0eaf1055
KR
1807
1808 /* POSIX specifies the HOST_NAME_MAX system parameter for the max size,
b28f5b3c
DH
1809 * which may reflect a particular kernel configuration.
1810 * Must watch out for this existing but giving -1, as happens for instance
1811 * in gnu/linux glibc 2.3.2. */
0eaf1055 1812 {
b28f5b3c 1813 const long int n = sysconf (_SC_HOST_NAME_MAX);
0eaf1055
KR
1814 if (n != -1L)
1815 len = n;
1816 }
b28f5b3c
DH
1817
1818# endif
1819
1820 p = scm_malloc (len);
1821
1822 scm_frame_begin (0);
1823 scm_frame_unwind_handler (free, p, 0);
0eaf1055 1824
94e6d793
MG
1825 res = gethostname (p, len);
1826 while (res == -1 && errno == ENAMETOOLONG)
1827 {
94e6d793 1828 len *= 2;
b28f5b3c
DH
1829
1830 /* scm_realloc may throw an exception. */
1831 p = scm_realloc (p, len);
94e6d793
MG
1832 res = gethostname (p, len);
1833 }
b28f5b3c
DH
1834
1835#endif
1836
94e6d793
MG
1837 if (res == -1)
1838 {
b28f5b3c
DH
1839 const int save_errno = errno;
1840
1841 // No guile exceptions can occur before we have freed p's memory.
1842 scm_frame_end ();
4c9419ac 1843 free (p);
b28f5b3c 1844
22865124 1845 errno = save_errno;
94e6d793
MG
1846 SCM_SYSERROR;
1847 }
b28f5b3c
DH
1848 else
1849 {
cc95e00a
MV
1850 /* scm_from_locale_string may throw an exception. */
1851 const SCM name = scm_from_locale_string (p);
b28f5b3c
DH
1852
1853 // No guile exceptions can occur before we have freed p's memory.
1854 scm_frame_end ();
1855 free (p);
1856
1857 return name;
1858 }
94e6d793
MG
1859}
1860#undef FUNC_NAME
1861#endif /* HAVE_GETHOSTNAME */
1862
b28f5b3c 1863
0f2d19dd
JB
1864void
1865scm_init_posix ()
0f2d19dd
JB
1866{
1867 scm_add_feature ("posix");
1868#ifdef HAVE_GETEUID
1869 scm_add_feature ("EIDs");
1870#endif
1871#ifdef WAIT_ANY
e11e83f3 1872 scm_c_define ("WAIT_ANY", scm_from_int (WAIT_ANY));
0f2d19dd
JB
1873#endif
1874#ifdef WAIT_MYPGRP
e11e83f3 1875 scm_c_define ("WAIT_MYPGRP", scm_from_int (WAIT_MYPGRP));
0f2d19dd
JB
1876#endif
1877#ifdef WNOHANG
e11e83f3 1878 scm_c_define ("WNOHANG", scm_from_int (WNOHANG));
0f2d19dd
JB
1879#endif
1880#ifdef WUNTRACED
e11e83f3 1881 scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED));
0f2d19dd
JB
1882#endif
1883
0f2d19dd 1884 /* access() symbols. */
e11e83f3
MV
1885 scm_c_define ("R_OK", scm_from_int (R_OK));
1886 scm_c_define ("W_OK", scm_from_int (W_OK));
1887 scm_c_define ("X_OK", scm_from_int (X_OK));
1888 scm_c_define ("F_OK", scm_from_int (F_OK));
0f2d19dd
JB
1889
1890#ifdef LC_COLLATE
e11e83f3 1891 scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE));
0f2d19dd
JB
1892#endif
1893#ifdef LC_CTYPE
e11e83f3 1894 scm_c_define ("LC_CTYPE", scm_from_int (LC_CTYPE));
0f2d19dd
JB
1895#endif
1896#ifdef LC_MONETARY
e11e83f3 1897 scm_c_define ("LC_MONETARY", scm_from_int (LC_MONETARY));
0f2d19dd
JB
1898#endif
1899#ifdef LC_NUMERIC
e11e83f3 1900 scm_c_define ("LC_NUMERIC", scm_from_int (LC_NUMERIC));
0f2d19dd
JB
1901#endif
1902#ifdef LC_TIME
e11e83f3 1903 scm_c_define ("LC_TIME", scm_from_int (LC_TIME));
0f2d19dd
JB
1904#endif
1905#ifdef LC_MESSAGES
e11e83f3 1906 scm_c_define ("LC_MESSAGES", scm_from_int (LC_MESSAGES));
0f2d19dd
JB
1907#endif
1908#ifdef LC_ALL
e11e83f3 1909 scm_c_define ("LC_ALL", scm_from_int (LC_ALL));
0f2d19dd 1910#endif
bd9e24b3 1911#ifdef PIPE_BUF
b9bd8526 1912 scm_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF));
bd9e24b3
GH
1913#endif
1914
94e6d793 1915#ifdef PRIO_PROCESS
e11e83f3 1916 scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS));
94e6d793
MG
1917#endif
1918#ifdef PRIO_PGRP
e11e83f3 1919 scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP));
94e6d793
MG
1920#endif
1921#ifdef PRIO_USER
e11e83f3 1922 scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER));
94e6d793
MG
1923#endif
1924
1925#ifdef LOCK_SH
e11e83f3 1926 scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH));
94e6d793
MG
1927#endif
1928#ifdef LOCK_EX
e11e83f3 1929 scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX));
94e6d793
MG
1930#endif
1931#ifdef LOCK_UN
e11e83f3 1932 scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN));
94e6d793
MG
1933#endif
1934#ifdef LOCK_NB
e11e83f3 1935 scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB));
94e6d793
MG
1936#endif
1937
a0599745
MD
1938#include "libguile/cpp_sig_symbols.c"
1939#include "libguile/posix.x"
0f2d19dd 1940}
89e00824
ML
1941
1942/*
1943 Local Variables:
1944 c-file-style: "gnu"
1945 End:
1946*/