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