libguile/posix.c

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