libguile/filesys.c

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