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 dir;
 614   SCM_ASSERT (SCM_NIMP (dirname) && SCM_ROSTRINGP (dirname), dirname, SCM_ARG1,
 615               s_opendir);
 616   SCM_COERCE_SUBSTR (dirname);
 617   SCM_NEWCELL (dir);
 618   SCM_DEFER_INTS;
 619   SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
 620   if (ds == NULL)
 621     scm_syserror (s_opendir);
 622   SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
 623   SCM_SETCDR (dir, ds);
 624   SCM_ALLOW_INTS;
 625   return dir;
 626 }
 627
 628
 629 SCM_PROC (s_readdir, "readdir", 1, 0, 0, scm_readdir);
 630
 631 SCM
 632 scm_readdir (port)
 633      SCM port;
 634 {
 635   struct dirent *rdent;
 636   SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_readdir);
 637   errno = 0;
 638   SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
 639   if (errno != 0)
 640     scm_syserror (s_readdir);
 641   return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
 642           : SCM_EOF_VAL);
 643 }
 644
 645
 646
 647 SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir);
 648
 649 SCM
 650 scm_rewinddir (port)
 651      SCM port;
 652 {
 653   SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir);
 654   rewinddir ((DIR *) SCM_CDR (port));
 655   return SCM_UNSPECIFIED;
 656 }
 657
 658
 659
 660 SCM_PROC (s_closedir, "closedir", 1, 0, 0, scm_closedir);
 661
 662 SCM
 663 scm_closedir (port)
 664      SCM port;
 665 {
 666   int sts;
 667
 668   SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_closedir);
 669   if (SCM_CLOSEDP (port))
 670     {
 671       return SCM_UNSPECIFIED;
 672     }
 673   SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
 674   if (sts != 0)
 675     scm_syserror (s_closedir);
 676   SCM_SETCAR (port, scm_tc16_dir);
 677   return SCM_UNSPECIFIED;
 678 }
 679
 680
 681
 682
 683 static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
 684
 685 static int
 686 scm_dir_print (sexp, port, pstate)
 687      SCM sexp;
 688      SCM port;
 689      scm_print_state *pstate;
 690 {
 691   scm_prinport (sexp, port, "directory");
 692   return 1;
 693 }
 694
 695
 696 static scm_sizet scm_dir_free SCM_P ((SCM p));
 697
 698 static scm_sizet
 699 scm_dir_free (p)
 700      SCM p;
 701 {
 702   if (SCM_OPENP (p))
 703     closedir ((DIR *) SCM_CDR (p));
 704   return 0;
 705 }
 706
 707 static scm_smobfuns dir_smob = {0, scm_dir_free, scm_dir_print, 0};
 708
 709 \f
 710 /* {Navigating Directories}
 711  */
 712
 713
 714 SCM_PROC (s_chdir, "chdir", 1, 0, 0, scm_chdir);
 715
 716 SCM
 717 scm_chdir (str)
 718      SCM str;
 719 {
 720   int ans;
 721
 722   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_chdir);
 723   SCM_COERCE_SUBSTR (str);
 724   SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
 725   if (ans != 0)
 726     scm_syserror (s_chdir);
 727   return SCM_UNSPECIFIED;
 728 }
 729
 730
 731
 732 SCM_PROC (s_getcwd, "getcwd", 0, 0, 0, scm_getcwd);
 733
 734 SCM
 735 scm_getcwd ()
 736 {
 737 #ifdef HAVE_GETCWD
 738   char *rv;
 739
 740   scm_sizet size = 100;
 741   char *wd;
 742   SCM result;
 743
 744   wd = scm_must_malloc (size, s_getcwd);
 745   while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
 746     {
 747       scm_must_free (wd);
 748       size *= 2;
 749       wd = scm_must_malloc (size, s_getcwd);
 750     }
 751   if (rv == 0)
 752     scm_syserror (s_getcwd);
 753   result = scm_makfromstr (wd, strlen (wd), 0);
 754   scm_must_free (wd);
 755   return result;
 756 #else
 757   scm_sysmissing (s_getcwd);
 758   /* not reached.  */
 759   return SCM_BOOL_F;
 760 #endif
 761 }
 762
 763 \f
 764
 765 SCM_PROC (s_select, "select", 3, 2, 0, scm_select);
 766
 767
 768 static int
 769 set_element (SELECT_TYPE *set, SCM element, int arg)
 770 {
 771   int fd;
 772   element = SCM_COERCE_OUTPORT (element);
 773   if (SCM_NIMP (element) && SCM_OPFPORTP (element))
 774     fd = SCM_FPORT_FDES (element);
 775   else {
 776     SCM_ASSERT (SCM_INUMP (element), element, arg, s_select);
 777     fd = SCM_INUM (element);
 778   }
 779   FD_SET (fd, set);
 780   return fd;
 781 }
 782
 783 static int
 784 fill_select_type (SELECT_TYPE *set, SCM list, int arg)
 785 {
 786   int max_fd = 0, fd;
 787   if (SCM_NIMP (list) && SCM_VECTORP (list))
 788     {
 789       int len = SCM_LENGTH (list);
 790       SCM *ve = SCM_VELTS (list);
 791
 792       while (len > 0)
 793         {
 794           fd = set_element (set, ve[len - 1], arg);
 795           if (fd > max_fd)
 796             max_fd = fd;
 797           len--;
 798         }
 799     }
 800   else
 801     {
 802       while (list != SCM_EOL)
 803         {
 804           fd = set_element (set, SCM_CAR (list), arg);
 805           if (fd > max_fd)
 806             max_fd = fd;
 807           list = SCM_CDR (list);
 808         }
 809     }
 810
 811   return max_fd;
 812 }
 813
 814 static SCM
 815 get_element (SELECT_TYPE *set, SCM element, SCM list)
 816 {
 817   element = SCM_COERCE_OUTPORT (element);
 818   if (SCM_NIMP (element) && SCM_OPFPORTP (element))
 819     {
 820       if (FD_ISSET (SCM_FPORT_FDES (element), set))
 821         list = scm_cons (element, list);
 822     }
 823   else if (SCM_INUMP (element))
 824     {
 825       if (FD_ISSET (SCM_INUM (element), set))
 826         list = scm_cons (element, list);
 827     }
 828   return list;
 829 }
 830
 831 static SCM
 832 retrieve_select_type (SELECT_TYPE *set, SCM list)
 833 {
 834   SCM answer_list = SCM_EOL;
 835
 836   if (SCM_NIMP (list) && SCM_VECTORP (list))
 837     {
 838       int len = SCM_LENGTH (list);
 839       SCM *ve = SCM_VELTS (list);
 840
 841       while (len > 0)
 842         {
 843           answer_list = get_element (set, ve[len - 1], answer_list);
 844           len--;
 845         }
 846       return scm_vector (answer_list);
 847     }
 848   else
 849     {
 850       /* list is a list.  */
 851       while (list != SCM_EOL)
 852         {
 853           answer_list = get_element (set, SCM_CAR (list), answer_list);
 854           list = SCM_CDR (list);
 855         }
 856       return answer_list;
 857     }
 858 }
 859
 860
 861 SCM
 862 scm_select (reads, writes, excepts, secs, usecs)
 863      SCM reads;
 864      SCM writes;
 865      SCM excepts;
 866      SCM secs;
 867      SCM usecs;
 868 {
 869 #ifdef HAVE_SELECT
 870   struct timeval timeout;
 871   struct timeval * time_p;
 872   SELECT_TYPE read_set;
 873   SELECT_TYPE write_set;
 874   SELECT_TYPE except_set;
 875   int max_fd, fd;
 876   int sreturn;
 877
 878 #define assert_set(x, arg) \
 879   SCM_ASSERT (scm_ilength (x) > -1 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
 880               x, arg, s_select)
 881   assert_set (reads, SCM_ARG1);
 882   assert_set (writes, SCM_ARG2);
 883   assert_set (excepts, SCM_ARG3);
 884 #undef assert_set
 885
 886   FD_ZERO (&read_set);
 887   FD_ZERO (&write_set);
 888   FD_ZERO (&except_set);
 889
 890   max_fd = fill_select_type (&read_set, reads, SCM_ARG1);
 891   fd = fill_select_type (&write_set, writes, SCM_ARG2);
 892   if (fd > max_fd)
 893     max_fd = fd;
 894   fd = fill_select_type (&except_set, excepts, SCM_ARG3);
 895   if (fd > max_fd)
 896     max_fd = fd;
 897
 898   if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
 899     time_p = 0;
 900   else
 901     {
 902       if (SCM_INUMP (secs))
 903         {
 904           timeout.tv_sec = SCM_INUM (secs);
 905           if (SCM_UNBNDP (usecs))
 906             timeout.tv_usec = 0;
 907           else
 908             {
 909               SCM_ASSERT (SCM_INUMP (usecs), usecs, SCM_ARG5, s_select);
 910
 911               timeout.tv_usec = SCM_INUM (usecs);
 912             }
 913         }
 914       else
 915         {
 916           double fl = scm_num2dbl (secs, s_select);
 917
 918           if (!SCM_UNBNDP (usecs))
 919             scm_wrong_type_arg (s_select, 4, secs);
 920           if (fl > LONG_MAX)
 921             scm_out_of_range (s_select, secs);
 922           timeout.tv_sec = (long) fl;
 923           timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
 924         }
 925       time_p = &timeout;
 926     }
 927
 928 #ifdef GUILE_ISELECT
 929   sreturn = scm_internal_select (max_fd + 1,
 930                                  &read_set, &write_set, &except_set, time_p);
 931 #else
 932   sreturn = select (max_fd + 1,
 933                     &read_set, &write_set, &except_set, time_p);
 934 #endif
 935   if (sreturn < 0)
 936     scm_syserror (s_select);
 937   return scm_listify (retrieve_select_type (&read_set, reads),
 938                       retrieve_select_type (&write_set, writes),
 939                       retrieve_select_type (&except_set, excepts),
 940                       SCM_UNDEFINED);
 941 #else
 942   scm_sysmissing (s_select);
 943   /* not reached.  */
 944   return SCM_BOOL_F;
 945 #endif
 946 }
 947
 948 \f
 949
 950 SCM_PROC (s_fcntl, "fcntl", 2, 0, 1, scm_fcntl);
 951 SCM
 952 scm_fcntl (SCM object, SCM cmd, SCM value)
 953 {
 954   int rv;
 955   int fdes;
 956   int ivalue;
 957
 958   object = SCM_COERCE_OUTPORT (object);
 959
 960   SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl);
 961   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
 962     fdes = SCM_FPORT_FDES (object);
 963   else
 964     {
 965       SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fcntl);
 966       fdes = SCM_INUM (object);
 967     }
 968   if (SCM_NULLP (value))
 969     ivalue = 0;
 970   else
 971     {
 972       SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, s_fcntl);
 973       ivalue = SCM_INUM (SCM_CAR (value));
 974     }
 975   SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
 976   if (rv == -1)
 977     scm_syserror (s_fcntl);
 978   return SCM_MAKINUM (rv);
 979 }
 980
 981 SCM_PROC (s_fsync, "fsync", 1, 0, 0, scm_fsync);
 982 SCM
 983 scm_fsync (SCM object)
 984 {
 985   int fdes;
 986
 987   object = SCM_COERCE_OUTPORT (object);
 988
 989   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
 990     {
 991       scm_fflush (object);
 992       fdes = SCM_FPORT_FDES (object);
 993     }
 994   else
 995     {
 996       SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fsync);
 997       fdes = SCM_INUM (object);
 998     }
 999   if (fsync (fdes) == -1)
1000     scm_syserror (s_fsync);
1001   return SCM_UNSPECIFIED;
1002 }
1003
1004 SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink);
1005
1006 SCM
1007 scm_symlink(oldpath, newpath)
1008      SCM oldpath;
1009      SCM newpath;
1010 {
1011 #ifdef HAVE_SYMLINK
1012   int val;
1013
1014   SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1,
1015               s_symlink);
1016   SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2,
1017               s_symlink);
1018   SCM_COERCE_SUBSTR (oldpath);
1019   SCM_COERCE_SUBSTR (newpath);
1020   SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
1021   if (val != 0)
1022     scm_syserror (s_symlink);
1023   return SCM_UNSPECIFIED;
1024 #else
1025   scm_sysmissing (s_symlink);
1026   /* not reached.  */
1027   return SCM_BOOL_F;
1028 #endif
1029 }
1030
1031
1032 SCM_PROC (s_readlink, "readlink", 1, 0, 0, scm_readlink);
1033
1034 SCM
1035 scm_readlink(path)
1036   SCM path;
1037 {
1038 #ifdef HAVE_READLINK
1039   int rv;
1040   int size = 100;
1041   char *buf;
1042   SCM result;
1043   SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, (char *) SCM_ARG1,
1044               s_readlink);
1045   SCM_COERCE_SUBSTR (path);
1046   buf = scm_must_malloc (size, s_readlink);
1047   while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
1048     {
1049       scm_must_free (buf);
1050       size *= 2;
1051       buf = scm_must_malloc (size, s_readlink);
1052     }
1053   if (rv == -1)
1054     scm_syserror (s_readlink);
1055   result = scm_makfromstr (buf, rv, 0);
1056   scm_must_free (buf);
1057   return result;
1058 #else
1059   scm_sysmissing (s_readlink);
1060   /* not reached.  */
1061   return SCM_BOOL_F;
1062 #endif
1063 }
1064
1065
1066 SCM_PROC (s_lstat, "lstat", 1, 0, 0, scm_lstat);
1067
1068 SCM
1069 scm_lstat(str)
1070   SCM str;
1071 {
1072 #ifdef HAVE_LSTAT
1073   int rv;
1074   struct stat stat_temp;
1075
1076   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, (char *) SCM_ARG1,
1077               s_lstat);
1078   SCM_COERCE_SUBSTR (str);
1079   SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
1080   if (rv != 0)
1081     {
1082       int en = errno;
1083
1084       scm_syserror_msg (s_lstat, "%s: %S",
1085                         scm_listify (scm_makfrom0str (strerror (errno)),
1086                                      str,
1087                                      SCM_UNDEFINED),
1088                         en);
1089     }
1090   return scm_stat2scm(&stat_temp);
1091 #else
1092   scm_sysmissing (s_lstat);
1093   /* not reached.  */
1094   return SCM_BOOL_F;
1095 #endif
1096 }
1097
1098
1099 SCM_PROC (s_copy_file, "copy-file", 2, 0, 0, scm_copy_file);
1100
1101 SCM
1102 scm_copy_file (oldfile, newfile)
1103      SCM oldfile;
1104      SCM newfile;
1105 {
1106   int oldfd, newfd;
1107   int n;
1108   char buf[BUFSIZ];
1109   struct stat oldstat;
1110
1111   SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_copy_file);
1112   if (SCM_SUBSTRP (oldfile))
1113     oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
1114   SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_copy_file);
1115   if (SCM_SUBSTRP (newfile))
1116     newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1117   if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1118     scm_syserror (s_copy_file);
1119   oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1120   if (oldfd == -1)
1121     scm_syserror (s_copy_file);
1122
1123   /* use POSIX flags instead of 07777?.  */
1124   newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1125                 oldstat.st_mode & 07777);
1126   if (newfd == -1)
1127     scm_syserror (s_copy_file);
1128
1129   while ((n = read (oldfd, buf, sizeof buf)) > 0)
1130     if (write (newfd, buf, n) != n)
1131       {
1132         close (oldfd);
1133         close (newfd);
1134         scm_syserror (s_copy_file);
1135       }
1136   close (oldfd);
1137   if (close (newfd) == -1)
1138     scm_syserror (s_copy_file);
1139   return SCM_UNSPECIFIED;
1140 }
1141
1142 \f
1143 /* Filename manipulation */
1144
1145 SCM scm_dot_string;
1146
1147 SCM_PROC (s_dirname, "dirname", 1, 0, 0, scm_dirname);
1148
1149 SCM
1150 scm_dirname (SCM filename)
1151 {
1152   char *s;
1153   int i, len;
1154   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
1155               filename,
1156               SCM_ARG1,
1157               s_dirname);
1158   s = SCM_ROCHARS (filename);
1159   len = SCM_LENGTH (filename);
1160   i = len - 1;
1161   while (i >= 0 && s[i] == '/') --i;
1162   while (i >= 0 && s[i] != '/') --i;
1163   while (i >= 0 && s[i] == '/') --i;
1164   if (i < 0)
1165     {
1166       if (len > 0 && s[0] == '/')
1167         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1168       else
1169         return scm_dot_string;
1170     }
1171   else
1172     return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1173 }
1174
1175 SCM_PROC (s_basename, "basename", 1, 1, 0, scm_basename);
1176
1177 SCM
1178 scm_basename (SCM filename, SCM suffix)
1179 {
1180   char *f, *s = 0;
1181   int i, j, len, end;
1182   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
1183               filename,
1184               SCM_ARG1,
1185               s_basename);
1186   SCM_ASSERT (SCM_UNBNDP (suffix)
1187               || (SCM_NIMP (suffix) && SCM_ROSTRINGP (suffix)),
1188               suffix,
1189               SCM_ARG2,
1190               s_basename);
1191   f = SCM_ROCHARS (filename);
1192   if (SCM_UNBNDP (suffix))
1193     j = -1;
1194   else
1195     {
1196       s = SCM_ROCHARS (suffix);
1197       j = SCM_LENGTH (suffix) - 1;
1198     }
1199   len = SCM_LENGTH (filename);
1200   i = len - 1;
1201   while (i >= 0 && f[i] == '/') --i;
1202   end = i;
1203   while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1204   if (j == -1)
1205     end = i;
1206   while (i >= 0 && f[i] != '/') --i;
1207   if (i == end)
1208     {
1209       if (len > 0 && f[0] == '/')
1210         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1211       else
1212         return scm_dot_string;
1213     }
1214   else
1215     return scm_make_shared_substring (filename,
1216                                       SCM_MAKINUM (i + 1),
1217                                       SCM_MAKINUM (end + 1));
1218 }
1219
1220
1221
1222 \f
1223
1224 void
1225 scm_init_filesys ()
1226 {
1227   scm_add_feature ("i/o-extensions");
1228
1229   scm_tc16_dir = scm_newsmob (&dir_smob);
1230
1231   scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1232
1233 #ifdef O_RDONLY
1234 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1235 #endif
1236 #ifdef O_WRONLY
1237 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1238 #endif
1239 #ifdef O_RDWR
1240 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1241 #endif
1242 #ifdef O_CREAT
1243 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1244 #endif
1245 #ifdef O_EXCL
1246 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1247 #endif
1248 #ifdef O_NOCTTY
1249 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1250 #endif
1251 #ifdef O_TRUNC
1252 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1253 #endif
1254 #ifdef O_APPEND
1255 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1256 #endif
1257 #ifdef O_NONBLOCK
1258 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1259 #endif
1260 #ifdef O_NDELAY
1261 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1262 #endif
1263 #ifdef O_SYNC
1264 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1265 #endif
1266
1267 #ifdef F_DUPFD
1268 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1269 #endif
1270 #ifdef F_GETFD
1271 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1272 #endif
1273 #ifdef F_SETFD
1274 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1275 #endif
1276 #ifdef F_GETFL
1277 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1278 #endif
1279 #ifdef F_SETFL
1280 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1281 #endif
1282 #ifdef F_GETOWN
1283 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1284 #endif
1285 #ifdef F_SETOWN
1286 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1287 #endif
1288 #ifdef FD_CLOEXEC
1289 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
1290 #endif
1291
1292 #include "filesys.x"
1293 }