libguile/filesys.c

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