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