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