libguile/posix.c

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