libguile/posix.c

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