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