libguile/filesys.c

   1 /*      Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "genio.h"
  49 #include "smob.h"
  50 #include "feature.h"
  51 #include "fports.h"
  52 #include "iselect.h"
  53
  54 #include "scm_validate.h"
  55 #include "filesys.h"
  56
  57 \f
  58 #ifdef HAVE_IO_H
  59 #include <io.h>
  60 #endif
  61
  62 #ifdef TIME_WITH_SYS_TIME
  63 # include <sys/time.h>
  64 # include <time.h>
  65 #else
  66 # if HAVE_SYS_TIME_H
  67 #  include <sys/time.h>
  68 # else
  69 #  include <time.h>
  70 # endif
  71 #endif
  72
  73 #ifdef HAVE_UNISTD_H
  74 #include <unistd.h>
  75 #endif
  76
  77 #ifdef LIBC_H_WITH_UNISTD_H
  78 #include <libc.h>
  79 #endif
  80
  81 #ifdef HAVE_SYS_SELECT_H
  82 #include <sys/select.h>
  83 #endif
  84
  85 #ifdef HAVE_STRING_H
  86 #include <string.h>
  87 #endif
  88
  89 #include <sys/types.h>
  90 #include <sys/stat.h>
  91 #include <fcntl.h>
  92
  93 #include <pwd.h>
  94
  95
  96 #if HAVE_DIRENT_H
  97 # include <dirent.h>
  98 # define NAMLEN(dirent) strlen((dirent)->d_name)
  99 #else
 100 # define dirent direct
 101 # define NAMLEN(dirent) (dirent)->d_namlen
 102 # if HAVE_SYS_NDIR_H
 103 #  include <sys/ndir.h>
 104 # endif
 105 # if HAVE_SYS_DIR_H
 106 #  include <sys/dir.h>
 107 # endif
 108 # if HAVE_NDIR_H
 109 #  include <ndir.h>
 110 # endif
 111 #endif
 112
 113 /* Ultrix has S_IFSOCK, but no S_ISSOCK.  Ipe!  */
 114 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
 115 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
 116 #endif
 117 \f
 118
 119
 120 \f
 121
 122 /* {Permissions}
 123  */
 124
 125 GUILE_PROC (scm_chown, "chown", 3, 0, 0,
 126             (SCM object, SCM owner, SCM group),
 127 "")
 128 #define FUNC_NAME s_scm_chown
 129 {
 130   int rv;
 131   int fdes;
 132
 133   object = SCM_COERCE_OUTPORT (object);
 134
 135   SCM_VALIDATE_INT(2,owner);
 136   SCM_VALIDATE_INT(3,group);
 137   if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
 138     {
 139       if (SCM_INUMP (object))
 140         fdes = SCM_INUM (object);
 141       else
 142         fdes = SCM_FPORT_FDES (object);
 143       SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group)));
 144     }
 145   else
 146     {
 147       SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
 148                   object, SCM_ARG1, FUNC_NAME);
 149       SCM_COERCE_SUBSTR (object);
 150       SCM_SYSCALL (rv = chown (SCM_ROCHARS (object),
 151                                SCM_INUM (owner), SCM_INUM (group)));
 152     }
 153   if (rv == -1)
 154     SCM_SYSERROR;
 155   return SCM_UNSPECIFIED;
 156 }
 157 #undef FUNC_NAME
 158
 159
 160 GUILE_PROC (scm_chmod, "chmod", 2, 0, 0,
 161             (SCM object, SCM mode),
 162 "")
 163 #define FUNC_NAME s_scm_chmod
 164 {
 165   int rv;
 166   int fdes;
 167
 168   object = SCM_COERCE_OUTPORT (object);
 169
 170   SCM_VALIDATE_INT(2,mode);
 171   if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
 172     {
 173       if (SCM_INUMP (object))
 174         fdes = SCM_INUM (object);
 175       else
 176         fdes = SCM_FPORT_FDES (object);
 177       SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode)));
 178     }
 179   else
 180     {
 181       SCM_VALIDATE_ROSTRING(1,object);
 182       SCM_COERCE_SUBSTR (object);
 183       SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode)));
 184     }
 185   if (rv == -1)
 186     SCM_SYSERROR;
 187   return SCM_UNSPECIFIED;
 188 }
 189 #undef FUNC_NAME
 190
 191 GUILE_PROC (scm_umask, "umask", 0, 1, 0,
 192             (SCM mode),
 193 "")
 194 #define FUNC_NAME s_scm_umask
 195 {
 196   mode_t mask;
 197   if (SCM_UNBNDP (mode))
 198     {
 199       mask = umask (0);
 200       umask (mask);
 201     }
 202   else
 203     {
 204       SCM_VALIDATE_INT(1,mode);
 205       mask = umask (SCM_INUM (mode));
 206     }
 207   return SCM_MAKINUM (mask);
 208 }
 209 #undef FUNC_NAME
 210
 211 \f
 212
 213 GUILE_PROC (scm_open_fdes, "open-fdes", 2, 1, 0,
 214             (SCM path, SCM flags, SCM mode),
 215 "")
 216 #define FUNC_NAME s_scm_open_fdes
 217 {
 218   int fd;
 219   int iflags;
 220   int imode;
 221
 222   SCM_VALIDATE_ROSTRING(1,path);
 223   SCM_COERCE_SUBSTR (path);
 224   SCM_VALIDATE_INT_COPY(2,flags,iflags);
 225   SCM_VALIDATE_INT_DEF_COPY(3,mode,0666,imode);
 226   SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode));
 227   if (fd == -1)
 228     SCM_SYSERROR;
 229   return SCM_MAKINUM (fd);
 230 }
 231 #undef FUNC_NAME
 232
 233 GUILE_PROC (scm_open, "open", 2, 1, 0,
 234             (SCM path, SCM flags, SCM mode),
 235 "")
 236 #define FUNC_NAME s_scm_open
 237 {
 238   SCM newpt;
 239   char *port_mode;
 240   int fd;
 241   int iflags;
 242
 243   fd = SCM_INUM (scm_open_fdes (path, flags, mode));
 244   SCM_VALIDATE_INT_COPY(2,flags,iflags);
 245   if (iflags & O_RDWR)
 246     {
 247       if (iflags & O_APPEND)
 248         port_mode = "a+";
 249       else if (iflags & O_CREAT)
 250         port_mode = "w+";
 251       else
 252         port_mode = "r+";
 253     }
 254   else {
 255     if (iflags & O_APPEND)
 256       port_mode = "a";
 257     else if (iflags & O_WRONLY)
 258       port_mode = "w";
 259     else
 260       port_mode = "r";
 261   }
 262   newpt = scm_fdes_to_port (fd, port_mode, path);
 263   return newpt;
 264 }
 265 #undef FUNC_NAME
 266
 267 GUILE_PROC (scm_close, "close", 1, 0, 0,
 268             (SCM fd_or_port),
 269 "")
 270 #define FUNC_NAME s_scm_close
 271 {
 272   int rv;
 273   int fd;
 274
 275   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 276
 277   if (SCM_NIMP (fd_or_port) && SCM_PORTP (fd_or_port))
 278     return scm_close_port (fd_or_port);
 279   SCM_VALIDATE_INT(1,fd_or_port);
 280   fd = SCM_INUM (fd_or_port);
 281   scm_evict_ports (fd);         /* see scsh manual.  */
 282   SCM_SYSCALL (rv = close (fd));
 283   /* following scsh, closing an already closed file descriptor is
 284      not an error.  */
 285   if (rv < 0 && errno != EBADF)
 286     SCM_SYSERROR;
 287   return SCM_NEGATE_BOOL(rv < 0);
 288 }
 289 #undef FUNC_NAME
 290
 291 \f
 292 /* {Files}
 293  */
 294
 295 SCM_SYMBOL (scm_sym_regular, "regular");
 296 SCM_SYMBOL (scm_sym_directory, "directory");
 297 #ifdef HAVE_S_ISLNK
 298 SCM_SYMBOL (scm_sym_symlink, "symlink");
 299 #endif
 300 SCM_SYMBOL (scm_sym_block_special, "block-special");
 301 SCM_SYMBOL (scm_sym_char_special, "char-special");
 302 SCM_SYMBOL (scm_sym_fifo, "fifo");
 303 SCM_SYMBOL (scm_sym_sock, "socket");
 304 SCM_SYMBOL (scm_sym_unknown, "unknown");
 305
 306 static SCM
 307 scm_stat2scm (struct stat *stat_temp)
 308 {
 309   SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED);
 310   SCM *ve = SCM_VELTS (ans);
 311
 312   ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
 313   ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
 314   ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
 315   ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink);
 316   ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid);
 317   ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid);
 318 #ifdef HAVE_ST_RDEV
 319   ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev);
 320 #else
 321   ve[6] = SCM_BOOL_F;
 322 #endif
 323   ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size);
 324   ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime);
 325   ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime);
 326   ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime);
 327 #ifdef HAVE_ST_BLKSIZE
 328   ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize);
 329 #else
 330   ve[11] = scm_ulong2num (4096L);
 331 #endif
 332 #ifdef HAVE_ST_BLOCKS
 333   ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks);
 334 #else
 335   ve[12] = SCM_BOOL_F;
 336 #endif
 337   {
 338     int mode = stat_temp->st_mode;
 339
 340     if (S_ISREG (mode))
 341       ve[13] = scm_sym_regular;
 342     else if (S_ISDIR (mode))
 343       ve[13] = scm_sym_directory;
 344 #ifdef HAVE_S_ISLNK
 345     else if (S_ISLNK (mode))
 346       ve[13] = scm_sym_symlink;
 347 #endif
 348     else if (S_ISBLK (mode))
 349       ve[13] = scm_sym_block_special;
 350     else if (S_ISCHR (mode))
 351       ve[13] = scm_sym_char_special;
 352     else if (S_ISFIFO (mode))
 353       ve[13] = scm_sym_fifo;
 354     else if (S_ISSOCK (mode))
 355       ve[13] = scm_sym_sock;
 356     else
 357       ve[13] = scm_sym_unknown;
 358
 359     ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
 360
 361     /* the layout of the bits in ve[14] is intended to be portable.
 362        If there are systems that don't follow the usual convention,
 363        the following could be used:
 364
 365        tmp = 0;
 366        if (S_ISUID & mode) tmp += 1;
 367        tmp <<= 1;
 368        if (S_IRGRP & mode) tmp += 1;
 369        tmp <<= 1;
 370        if (S_ISVTX & mode) tmp += 1;
 371        tmp <<= 1;
 372        if (S_IRUSR & mode) tmp += 1;
 373        tmp <<= 1;
 374        if (S_IWUSR & mode) tmp += 1;
 375        tmp <<= 1;
 376        if (S_IXUSR & mode) tmp += 1;
 377        tmp <<= 1;
 378        if (S_IWGRP & mode) tmp += 1;
 379        tmp <<= 1;
 380        if (S_IXGRP & mode) tmp += 1;
 381        tmp <<= 1;
 382        if (S_IROTH & mode) tmp += 1;
 383        tmp <<= 1;
 384        if (S_IWOTH & mode) tmp += 1;
 385        tmp <<= 1;
 386        if (S_IXOTH & mode) tmp += 1;
 387
 388        ve[14] = SCM_MAKINUM (tmp);
 389
 390        */
 391   }
 392
 393   return ans;
 394 }
 395
 396 GUILE_PROC (scm_stat, "stat", 1, 0, 0,
 397             (SCM object),
 398 "")
 399 #define FUNC_NAME s_scm_stat
 400 {
 401   int rv;
 402   int fdes;
 403   struct stat stat_temp;
 404
 405   if (SCM_INUMP (object))
 406     SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
 407   else
 408     {
 409       SCM_VALIDATE_NIMP(1,object);
 410       if (SCM_ROSTRINGP (object))
 411         {
 412           SCM_COERCE_SUBSTR (object);
 413           SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
 414         }
 415       else
 416         {
 417           object = SCM_COERCE_OUTPORT (object);
 418           SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, FUNC_NAME);
 419           fdes = SCM_FPORT_FDES (object);
 420           SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
 421         }
 422     }
 423   if (rv == -1)
 424     {
 425       int en = errno;
 426
 427       scm_syserror_msg (FUNC_NAME, "%s: %S",
 428                         scm_listify (scm_makfrom0str (strerror (errno)),
 429                                      object,
 430                                      SCM_UNDEFINED),
 431                         en);
 432     }
 433   return scm_stat2scm (&stat_temp);
 434 }
 435 #undef FUNC_NAME
 436
 437 \f
 438 /* {Modifying Directories}
 439  */
 440
 441 GUILE_PROC (scm_link, "link", 2, 0, 0,
 442             (SCM oldpath, SCM newpath),
 443 "")
 444 #define FUNC_NAME s_scm_link
 445 {
 446   int val;
 447
 448   SCM_VALIDATE_ROSTRING(1,oldpath);
 449   if (SCM_SUBSTRP (oldpath))
 450     oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
 451                               SCM_ROLENGTH (oldpath), 0);
 452   SCM_VALIDATE_ROSTRING(2,newpath);
 453   if (SCM_SUBSTRP (newpath))
 454     newpath = scm_makfromstr (SCM_ROCHARS (newpath),
 455                               SCM_ROLENGTH (newpath), 0);
 456   SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
 457   if (val != 0)
 458     SCM_SYSERROR;
 459   return SCM_UNSPECIFIED;
 460 }
 461 #undef FUNC_NAME
 462
 463
 464
 465 GUILE_PROC (scm_rename, "rename-file", 2, 0, 0,
 466             (SCM oldname, SCM newname),
 467 "")
 468 #define FUNC_NAME s_scm_rename
 469 {
 470   int rv;
 471   SCM_VALIDATE_ROSTRING(1,oldname);
 472   SCM_VALIDATE_ROSTRING(2,newname);
 473   SCM_COERCE_SUBSTR (oldname);
 474   SCM_COERCE_SUBSTR (newname);
 475 #ifdef HAVE_RENAME
 476   SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 477 #else
 478   SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 479   if (rv == 0)
 480     {
 481       SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
 482       if (rv != 0)
 483         /* unlink failed.  remove new name */
 484         SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
 485     }
 486 #endif
 487   if (rv != 0)
 488     SCM_SYSERROR;
 489   return SCM_UNSPECIFIED;
 490 }
 491 #undef FUNC_NAME
 492
 493
 494 GUILE_PROC(scm_delete_file, "delete-file", 1, 0, 0,
 495            (SCM str),
 496 "")
 497 #define FUNC_NAME s_scm_delete_file
 498 {
 499   int ans;
 500   SCM_VALIDATE_ROSTRING(1,str);
 501   SCM_COERCE_SUBSTR (str);
 502   SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
 503   if (ans != 0)
 504     SCM_SYSERROR;
 505   return SCM_UNSPECIFIED;
 506 }
 507 #undef FUNC_NAME
 508
 509 GUILE_PROC (scm_mkdir, "mkdir", 1, 1, 0,
 510             (SCM path, SCM mode),
 511 "")
 512 #define FUNC_NAME s_scm_mkdir
 513 {
 514 #ifdef HAVE_MKDIR
 515   int rv;
 516   mode_t mask;
 517   SCM_VALIDATE_ROSTRING(1,path);
 518   SCM_COERCE_SUBSTR (path);
 519   if (SCM_UNBNDP (mode))
 520     {
 521       mask = umask (0);
 522       umask (mask);
 523       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
 524     }
 525   else
 526     {
 527       SCM_VALIDATE_INT(2,mode);
 528       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
 529     }
 530   if (rv != 0)
 531     SCM_SYSERROR;
 532   return SCM_UNSPECIFIED;
 533 #else
 534   SCM_SYSMISSING;
 535   /* not reached.  */
 536   return SCM_BOOL_F;
 537 #endif
 538 }
 539 #undef FUNC_NAME
 540
 541
 542 GUILE_PROC (scm_rmdir, "rmdir", 1, 0, 0,
 543             (SCM path),
 544 "")
 545 #define FUNC_NAME s_scm_rmdir
 546 {
 547 #ifdef HAVE_RMDIR
 548   int val;
 549
 550   SCM_VALIDATE_ROSTRING(1,path);
 551   SCM_COERCE_SUBSTR (path);
 552   SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
 553   if (val != 0)
 554     SCM_SYSERROR;
 555   return SCM_UNSPECIFIED;
 556 #else
 557   SCM_SYSMISSING;
 558   /* not reached.  */
 559   return SCM_BOOL_F;
 560 #endif
 561 }
 562 #undef FUNC_NAME
 563
 564 \f
 565 /* {Examining Directories}
 566  */
 567
 568 long scm_tc16_dir;
 569
 570 GUILE_PROC (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
 571             (SCM obj),
 572 "")
 573 #define FUNC_NAME s_scm_directory_stream_p
 574 {
 575   return SCM_BOOL(SCM_NIMP (obj) && SCM_DIRP (obj));
 576 }
 577 #undef FUNC_NAME
 578
 579 GUILE_PROC (scm_opendir, "opendir", 1, 0, 0,
 580             (SCM dirname),
 581 "")
 582 #define FUNC_NAME s_scm_opendir
 583 {
 584   DIR *ds;
 585   SCM_VALIDATE_ROSTRING(1,dirname);
 586   SCM_COERCE_SUBSTR (dirname);
 587   SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
 588   if (ds == NULL)
 589     SCM_SYSERROR;
 590   SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
 591 }
 592 #undef FUNC_NAME
 593
 594
 595 GUILE_PROC (scm_readdir, "readdir", 1, 0, 0,
 596             (SCM port),
 597 "")
 598 #define FUNC_NAME s_scm_readdir
 599 {
 600   struct dirent *rdent;
 601   SCM_VALIDATE_OPDIR(1,port);
 602   errno = 0;
 603   SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
 604   if (errno != 0)
 605     SCM_SYSERROR;
 606   return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
 607           : SCM_EOF_VAL);
 608 }
 609 #undef FUNC_NAME
 610
 611
 612
 613 GUILE_PROC (scm_rewinddir, "rewinddir", 1, 0, 0,
 614             (SCM port),
 615 "")
 616 #define FUNC_NAME s_scm_rewinddir
 617 {
 618   SCM_VALIDATE_OPDIR(1,port);
 619   rewinddir ((DIR *) SCM_CDR (port));
 620   return SCM_UNSPECIFIED;
 621 }
 622 #undef FUNC_NAME
 623
 624
 625
 626 GUILE_PROC (scm_closedir, "closedir", 1, 0, 0,
 627             (SCM port),
 628 "")
 629 #define FUNC_NAME s_scm_closedir
 630 {
 631   int sts;
 632
 633   SCM_VALIDATE_DIR(1,port);
 634   if (SCM_CLOSEDP (port))
 635     {
 636       return SCM_UNSPECIFIED;
 637     }
 638   SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
 639   if (sts != 0)
 640     SCM_SYSERROR;
 641   SCM_SETCAR (port, scm_tc16_dir);
 642   return SCM_UNSPECIFIED;
 643 }
 644 #undef FUNC_NAME
 645
 646
 647
 648
 649 static int
 650 scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
 651 {
 652   scm_puts ("#<", port);
 653   if (SCM_CLOSEDP (exp))
 654     scm_puts ("closed: ", port);
 655   scm_puts ("directory stream ", port);
 656   scm_intprint (SCM_CDR (exp), 16, port);
 657   scm_putc ('>', port);
 658   return 1;
 659 }
 660
 661
 662 static scm_sizet
 663 scm_dir_free (SCM p)
 664 {
 665   if (SCM_OPENP (p))
 666     closedir ((DIR *) SCM_CDR (p));
 667   return 0;
 668 }
 669
 670 \f
 671 /* {Navigating Directories}
 672  */
 673
 674
 675 GUILE_PROC (scm_chdir, "chdir", 1, 0, 0,
 676             (SCM str),
 677 "")
 678 #define FUNC_NAME s_scm_chdir
 679 {
 680   int ans;
 681
 682   SCM_VALIDATE_ROSTRING(1,str);
 683   SCM_COERCE_SUBSTR (str);
 684   SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
 685   if (ans != 0)
 686     SCM_SYSERROR;
 687   return SCM_UNSPECIFIED;
 688 }
 689 #undef FUNC_NAME
 690
 691
 692
 693 GUILE_PROC (scm_getcwd, "getcwd", 0, 0, 0,
 694             (),
 695 "")
 696 #define FUNC_NAME s_scm_getcwd
 697 {
 698 #ifdef HAVE_GETCWD
 699   char *rv;
 700
 701   scm_sizet size = 100;
 702   char *wd;
 703   SCM result;
 704
 705   wd = scm_must_malloc (size, FUNC_NAME);
 706   while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
 707     {
 708       scm_must_free (wd);
 709       size *= 2;
 710       wd = scm_must_malloc (size, FUNC_NAME);
 711     }
 712   if (rv == 0)
 713     SCM_SYSERROR;
 714   result = scm_makfromstr (wd, strlen (wd), 0);
 715   scm_must_free (wd);
 716   return result;
 717 #else
 718   SCM_SYSMISSING;
 719   /* not reached.  */
 720   return SCM_BOOL_F;
 721 #endif
 722 }
 723 #undef FUNC_NAME
 724
 725 \f
 726
 727 static int
 728 set_element (SELECT_TYPE *set, SCM element, int arg)
 729 {
 730   int fd;
 731   element = SCM_COERCE_OUTPORT (element);
 732   if (SCM_NIMP (element) && SCM_OPFPORTP (element))
 733     fd = SCM_FPORT_FDES (element);
 734   else {
 735     SCM_ASSERT (SCM_INUMP (element), element, arg, "select");
 736     fd = SCM_INUM (element);
 737   }
 738   FD_SET (fd, set);
 739   return fd;
 740 }
 741
 742 static int
 743 fill_select_type (SELECT_TYPE *set, SCM list, int arg)
 744 {
 745   int max_fd = 0, fd;
 746   if (SCM_NIMP (list) && SCM_VECTORP (list))
 747     {
 748       int len = SCM_LENGTH (list);
 749       SCM *ve = SCM_VELTS (list);
 750
 751       while (len > 0)
 752         {
 753           fd = set_element (set, ve[len - 1], arg);
 754           if (fd > max_fd)
 755             max_fd = fd;
 756           len--;
 757         }
 758     }
 759   else
 760     {
 761       while (list != SCM_EOL)
 762         {
 763           fd = set_element (set, SCM_CAR (list), arg);
 764           if (fd > max_fd)
 765             max_fd = fd;
 766           list = SCM_CDR (list);
 767         }
 768     }
 769
 770   return max_fd;
 771 }
 772
 773 static SCM
 774 get_element (SELECT_TYPE *set, SCM element, SCM list)
 775 {
 776   element = SCM_COERCE_OUTPORT (element);
 777   if (SCM_NIMP (element) && SCM_OPFPORTP (element))
 778     {
 779       if (FD_ISSET (SCM_FPORT_FDES (element), set))
 780         list = scm_cons (element, list);
 781     }
 782   else if (SCM_INUMP (element))
 783     {
 784       if (FD_ISSET (SCM_INUM (element), set))
 785         list = scm_cons (element, list);
 786     }
 787   return list;
 788 }
 789
 790 static SCM
 791 retrieve_select_type (SELECT_TYPE *set, SCM list)
 792 {
 793   SCM answer_list = SCM_EOL;
 794
 795   if (SCM_NIMP (list) && SCM_VECTORP (list))
 796     {
 797       int len = SCM_LENGTH (list);
 798       SCM *ve = SCM_VELTS (list);
 799
 800       while (len > 0)
 801         {
 802           answer_list = get_element (set, ve[len - 1], answer_list);
 803           len--;
 804         }
 805       return scm_vector (answer_list);
 806     }
 807   else
 808     {
 809       /* list is a list.  */
 810       while (list != SCM_EOL)
 811         {
 812           answer_list = get_element (set, SCM_CAR (list), answer_list);
 813           list = SCM_CDR (list);
 814         }
 815       return answer_list;
 816     }
 817 }
 818
 819 /* Static helper functions above refer to s_scm_select directly as s_select */
 820 GUILE_PROC (scm_select, "select", 3, 2, 0,
 821             (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
 822 "")
 823 #define FUNC_NAME s_scm_select
 824 {
 825 #ifdef HAVE_SELECT
 826   struct timeval timeout;
 827   struct timeval * time_p;
 828   SELECT_TYPE read_set;
 829   SELECT_TYPE write_set;
 830   SELECT_TYPE except_set;
 831   int max_fd, fd;
 832   int sreturn;
 833
 834 #define assert_set(x, arg) \
 835   SCM_ASSERT (scm_ilength (x) >= 0 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
 836               x, arg, FUNC_NAME)
 837   assert_set (reads, SCM_ARG1);
 838   assert_set (writes, SCM_ARG2);
 839   assert_set (excepts, SCM_ARG3);
 840 #undef assert_set
 841
 842   FD_ZERO (&read_set);
 843   FD_ZERO (&write_set);
 844   FD_ZERO (&except_set);
 845
 846   max_fd = fill_select_type (&read_set, reads, SCM_ARG1);
 847   fd = fill_select_type (&write_set, writes, SCM_ARG2);
 848   if (fd > max_fd)
 849     max_fd = fd;
 850   fd = fill_select_type (&except_set, excepts, SCM_ARG3);
 851   if (fd > max_fd)
 852     max_fd = fd;
 853
 854   if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
 855     time_p = 0;
 856   else
 857     {
 858       if (SCM_INUMP (secs))
 859         {
 860           timeout.tv_sec = SCM_INUM (secs);
 861           if (SCM_UNBNDP (usecs))
 862             timeout.tv_usec = 0;
 863           else
 864             {
 865               SCM_VALIDATE_INT(5,usecs);
 866               timeout.tv_usec = SCM_INUM (usecs);
 867             }
 868         }
 869       else
 870         {
 871           double fl = scm_num2dbl (secs, FUNC_NAME);
 872
 873           if (!SCM_UNBNDP (usecs))
 874             scm_wrong_type_arg (FUNC_NAME, 4, secs);
 875           if (fl > LONG_MAX)
 876             scm_out_of_range (FUNC_NAME, secs);
 877           timeout.tv_sec = (long) fl;
 878           timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
 879         }
 880       time_p = &timeout;
 881     }
 882
 883 #ifdef GUILE_ISELECT
 884   sreturn = scm_internal_select (max_fd + 1,
 885                                  &read_set, &write_set, &except_set, time_p);
 886 #else
 887   sreturn = select (max_fd + 1,
 888                     &read_set, &write_set, &except_set, time_p);
 889 #endif
 890   if (sreturn < 0)
 891     SCM_SYSERROR;
 892   return scm_listify (retrieve_select_type (&read_set, reads),
 893                       retrieve_select_type (&write_set, writes),
 894                       retrieve_select_type (&except_set, excepts),
 895                       SCM_UNDEFINED);
 896 #else
 897   SCM_SYSMISSING;
 898   /* not reached.  */
 899   return SCM_BOOL_F;
 900 #endif
 901 }
 902 #undef FUNC_NAME
 903
 904 \f
 905
 906 GUILE_PROC (scm_fcntl, "fcntl", 2, 0, 1,
 907             (SCM object, SCM cmd, SCM value),
 908 "")
 909 #define FUNC_NAME s_scm_fcntl
 910 {
 911   int rv;
 912   int fdes;
 913   int ivalue;
 914
 915   object = SCM_COERCE_OUTPORT (object);
 916
 917   SCM_VALIDATE_INT(2,cmd);
 918   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
 919     fdes = SCM_FPORT_FDES (object);
 920   else
 921     {
 922       SCM_VALIDATE_INT(1,object);
 923       fdes = SCM_INUM (object);
 924     }
 925   if (SCM_NULLP (value))
 926     ivalue = 0;
 927   else
 928     {
 929       SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, FUNC_NAME);
 930       ivalue = SCM_INUM (SCM_CAR (value));
 931     }
 932   SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
 933   if (rv == -1)
 934     SCM_SYSERROR;
 935   return SCM_MAKINUM (rv);
 936 }
 937 #undef FUNC_NAME
 938
 939 GUILE_PROC (scm_fsync, "fsync", 1, 0, 0,
 940             (SCM object),
 941 "")
 942 #define FUNC_NAME s_scm_fsync
 943 {
 944   int fdes;
 945
 946   object = SCM_COERCE_OUTPORT (object);
 947
 948   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
 949     {
 950       scm_flush (object);
 951       fdes = SCM_FPORT_FDES (object);
 952     }
 953   else
 954     {
 955       SCM_VALIDATE_INT(1,object);
 956       fdes = SCM_INUM (object);
 957     }
 958   if (fsync (fdes) == -1)
 959     SCM_SYSERROR;
 960   return SCM_UNSPECIFIED;
 961 }
 962 #undef FUNC_NAME
 963
 964 GUILE_PROC (scm_symlink, "symlink", 2, 0, 0,
 965             (SCM oldpath, SCM newpath),
 966 "")
 967 #define FUNC_NAME s_scm_symlink
 968 {
 969 #ifdef HAVE_SYMLINK
 970   int val;
 971
 972   SCM_VALIDATE_ROSTRING(1,oldpath);
 973   SCM_VALIDATE_ROSTRING(2,newpath);
 974   SCM_COERCE_SUBSTR (oldpath);
 975   SCM_COERCE_SUBSTR (newpath);
 976   SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
 977   if (val != 0)
 978     SCM_SYSERROR;
 979   return SCM_UNSPECIFIED;
 980 #else
 981   SCM_SYSMISSING;
 982   /* not reached.  */
 983   return SCM_BOOL_F;
 984 #endif
 985 }
 986 #undef FUNC_NAME
 987
 988
 989 GUILE_PROC (scm_readlink, "readlink", 1, 0, 0,
 990             (SCM path),
 991 "")
 992 #define FUNC_NAME s_scm_readlink
 993 {
 994 #ifdef HAVE_READLINK
 995   int rv;
 996   int size = 100;
 997   char *buf;
 998   SCM result;
 999   SCM_VALIDATE_ROSTRING(1,path);
1000   SCM_COERCE_SUBSTR (path);
1001   buf = scm_must_malloc (size, FUNC_NAME);
1002   while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
1003     {
1004       scm_must_free (buf);
1005       size *= 2;
1006       buf = scm_must_malloc (size, FUNC_NAME);
1007     }
1008   if (rv == -1)
1009     SCM_SYSERROR;
1010   result = scm_makfromstr (buf, rv, 0);
1011   scm_must_free (buf);
1012   return result;
1013 #else
1014   SCM_SYSMISSING;
1015   /* not reached.  */
1016   return SCM_BOOL_F;
1017 #endif
1018 }
1019 #undef FUNC_NAME
1020
1021
1022 GUILE_PROC (scm_lstat, "lstat", 1, 0, 0,
1023             (SCM str),
1024 "")
1025 #define FUNC_NAME s_scm_lstat
1026 {
1027 #ifdef HAVE_LSTAT
1028   int rv;
1029   struct stat stat_temp;
1030
1031   SCM_VALIDATE_ROSTRING(1,str);
1032   SCM_COERCE_SUBSTR (str);
1033   SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
1034   if (rv != 0)
1035     {
1036       int en = errno;
1037
1038       scm_syserror_msg (FUNC_NAME, "%s: %S",
1039                         scm_listify (scm_makfrom0str (strerror (errno)),
1040                                      str,
1041                                      SCM_UNDEFINED),
1042                         en);
1043     }
1044   return scm_stat2scm(&stat_temp);
1045 #else
1046   SCM_SYSMISSING;
1047   /* not reached.  */
1048   return SCM_BOOL_F;
1049 #endif
1050 }
1051 #undef FUNC_NAME
1052
1053
1054 GUILE_PROC (scm_copy_file, "copy-file", 2, 0, 0,
1055             (SCM oldfile, SCM newfile),
1056 "")
1057 #define FUNC_NAME s_scm_copy_file
1058 {
1059   int oldfd, newfd;
1060   int n;
1061   char buf[BUFSIZ];
1062   struct stat oldstat;
1063
1064   SCM_VALIDATE_ROSTRING(1,oldfile);
1065   if (SCM_SUBSTRP (oldfile))
1066     oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
1067   SCM_VALIDATE_ROSTRING(2,newfile);
1068   if (SCM_SUBSTRP (newfile))
1069     newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1070   if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1071     SCM_SYSERROR;
1072   oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1073   if (oldfd == -1)
1074     SCM_SYSERROR;
1075
1076   /* use POSIX flags instead of 07777?.  */
1077   newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1078                 oldstat.st_mode & 07777);
1079   if (newfd == -1)
1080     SCM_SYSERROR;
1081
1082   while ((n = read (oldfd, buf, sizeof buf)) > 0)
1083     if (write (newfd, buf, n) != n)
1084       {
1085         close (oldfd);
1086         close (newfd);
1087         SCM_SYSERROR;
1088       }
1089   close (oldfd);
1090   if (close (newfd) == -1)
1091     SCM_SYSERROR;
1092   return SCM_UNSPECIFIED;
1093 }
1094 #undef FUNC_NAME
1095
1096 \f
1097 /* Filename manipulation */
1098
1099 SCM scm_dot_string;
1100
1101 GUILE_PROC (scm_dirname, "dirname", 1, 0, 0,
1102             (SCM filename),
1103 "")
1104 #define FUNC_NAME s_scm_dirname
1105 {
1106   char *s;
1107   int i, len;
1108   SCM_VALIDATE_ROSTRING(1,filename);
1109   s = SCM_ROCHARS (filename);
1110   len = SCM_LENGTH (filename);
1111   i = len - 1;
1112   while (i >= 0 && s[i] == '/') --i;
1113   while (i >= 0 && s[i] != '/') --i;
1114   while (i >= 0 && s[i] == '/') --i;
1115   if (i < 0)
1116     {
1117       if (len > 0 && s[0] == '/')
1118         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1119       else
1120         return scm_dot_string;
1121     }
1122   else
1123     return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1124 }
1125 #undef FUNC_NAME
1126
1127 GUILE_PROC (scm_basename, "basename", 1, 1, 0,
1128             (SCM filename, SCM suffix),
1129 "")
1130 #define FUNC_NAME s_scm_basename
1131 {
1132   char *f, *s = 0;
1133   int i, j, len, end;
1134   SCM_VALIDATE_ROSTRING(1,filename);
1135   SCM_ASSERT (SCM_UNBNDP (suffix)
1136               || (SCM_NIMP (suffix) && SCM_ROSTRINGP (suffix)),
1137               suffix,
1138               SCM_ARG2,
1139               FUNC_NAME);
1140   f = SCM_ROCHARS (filename);
1141   if (SCM_UNBNDP (suffix))
1142     j = -1;
1143   else
1144     {
1145       s = SCM_ROCHARS (suffix);
1146       j = SCM_LENGTH (suffix) - 1;
1147     }
1148   len = SCM_LENGTH (filename);
1149   i = len - 1;
1150   while (i >= 0 && f[i] == '/') --i;
1151   end = i;
1152   while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1153   if (j == -1)
1154     end = i;
1155   while (i >= 0 && f[i] != '/') --i;
1156   if (i == end)
1157     {
1158       if (len > 0 && f[0] == '/')
1159         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1160       else
1161         return scm_dot_string;
1162     }
1163   else
1164     return scm_make_shared_substring (filename,
1165                                       SCM_MAKINUM (i + 1),
1166                                       SCM_MAKINUM (end + 1));
1167 }
1168 #undef FUNC_NAME
1169
1170
1171
1172 \f
1173
1174 void
1175 scm_init_filesys ()
1176 {
1177   scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
1178                                          NULL, scm_dir_free,scm_dir_print, NULL);
1179
1180   scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1181
1182 #ifdef O_RDONLY
1183 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1184 #endif
1185 #ifdef O_WRONLY
1186 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1187 #endif
1188 #ifdef O_RDWR
1189 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1190 #endif
1191 #ifdef O_CREAT
1192 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1193 #endif
1194 #ifdef O_EXCL
1195 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1196 #endif
1197 #ifdef O_NOCTTY
1198 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1199 #endif
1200 #ifdef O_TRUNC
1201 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1202 #endif
1203 #ifdef O_APPEND
1204 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1205 #endif
1206 #ifdef O_NONBLOCK
1207 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1208 #endif
1209 #ifdef O_NDELAY
1210 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1211 #endif
1212 #ifdef O_SYNC
1213 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1214 #endif
1215
1216 #ifdef F_DUPFD
1217 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1218 #endif
1219 #ifdef F_GETFD
1220 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1221 #endif
1222 #ifdef F_SETFD
1223 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1224 #endif
1225 #ifdef F_GETFL
1226 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1227 #endif
1228 #ifdef F_SETFL
1229 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1230 #endif
1231 #ifdef F_GETOWN
1232 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1233 #endif
1234 #ifdef F_SETOWN
1235 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1236 #endif
1237 #ifdef FD_CLOEXEC
1238 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
1239 #endif
1240
1241 #include "filesys.x"
1242 }