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