1 /* Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
47 #include "libguile/_scm.h"
48 #include "libguile/smob.h"
49 #include "libguile/feature.h"
50 #include "libguile/fports.h"
51 #include "libguile/iselect.h"
52 #include "libguile/strings.h"
53 #include "libguile/vectors.h"
55 #include "libguile/validate.h"
56 #include "libguile/filesys.h"
63 #ifdef TIME_WITH_SYS_TIME
64 # include <sys/time.h>
68 # include <sys/time.h>
78 #ifdef LIBC_H_WITH_UNISTD_H
82 #ifdef HAVE_SYS_SELECT_H
83 #include <sys/select.h>
90 #include <sys/types.h>
101 # define NAMLEN(dirent) strlen((dirent)->d_name)
103 # define dirent direct
104 # define NAMLEN(dirent) (dirent)->d_namlen
106 # include <sys/ndir.h>
109 # include <sys/dir.h>
116 /* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
117 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
118 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
121 /* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows
122 compiler like BorlandC or MSVC has none of these macros defined. */
124 # define S_ISSOCK(mode) (0)
126 #if defined (__BORLANDC__) || defined (_MSC_VER)
127 # define S_ISBLK(mode) (0)
128 # define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO)
129 # define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR)
130 # define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR)
131 # define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG)
134 /* Some more definitions for the native Windows port. */
136 # define mkdir(path, mode) mkdir (path)
137 # define fsync(fd) _commit (fd)
138 # define fchmod(fd, mode) (-1)
139 #endif /* __MINGW32__ */
149 SCM_DEFINE (scm_chown
, "chown", 3, 0, 0,
150 (SCM object
, SCM owner
, SCM group
),
151 "Change the ownership and group of the file referred to by @var{object} to\n"
152 "the integer values @var{owner} and @var{group}. @var{object} can be\n"
153 "a string containing a file name or, if the platform\n"
154 "supports fchown, a port or integer file descriptor\n"
155 "which is open on the file. The return value\n"
156 "is unspecified.\n\n"
157 "If @var{object} is a symbolic link, either the\n"
158 "ownership of the link or the ownership of the referenced file will be\n"
159 "changed depending on the operating system (lchown is\n"
160 "unsupported at present). If @var{owner} or @var{group} is specified\n"
161 "as @code{-1}, then that ID is not changed.")
162 #define FUNC_NAME s_scm_chown
166 object
= SCM_COERCE_OUTPORT (object
);
168 SCM_VALIDATE_INUM (2,owner
);
169 SCM_VALIDATE_INUM (3,group
);
171 if (SCM_INUMP (object
) || (SCM_OPFPORTP (object
)))
173 int fdes
= SCM_INUMP (object
) ? SCM_INUM (object
)
174 : SCM_FPORT_FDES (object
);
176 SCM_SYSCALL (rv
= fchown (fdes
, SCM_INUM (owner
), SCM_INUM (group
)));
181 SCM_VALIDATE_STRING (1, object
);
182 SCM_SYSCALL (rv
= chown (SCM_STRING_CHARS (object
),
183 SCM_INUM (owner
), SCM_INUM (group
)));
187 return SCM_UNSPECIFIED
;
190 #endif /* HAVE_CHOWN */
193 SCM_DEFINE (scm_chmod
, "chmod", 2, 0, 0,
194 (SCM object
, SCM mode
),
195 "Changes the permissions of the file referred to by @var{obj}.\n"
196 "@var{obj} can be a string containing a file name or a port or integer file\n"
197 "descriptor which is open on a file (in which case @code{fchmod} is used\n"
198 "as the underlying system call).\n"
199 "@var{mode} specifies\n"
200 "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
201 "The return value is unspecified.")
202 #define FUNC_NAME s_scm_chmod
207 object
= SCM_COERCE_OUTPORT (object
);
209 SCM_VALIDATE_INUM (2,mode
);
210 if (SCM_INUMP (object
) || SCM_OPFPORTP (object
))
212 if (SCM_INUMP (object
))
213 fdes
= SCM_INUM (object
);
215 fdes
= SCM_FPORT_FDES (object
);
216 SCM_SYSCALL (rv
= fchmod (fdes
, SCM_INUM (mode
)));
220 SCM_VALIDATE_STRING (1, object
);
221 SCM_SYSCALL (rv
= chmod (SCM_STRING_CHARS (object
), SCM_INUM (mode
)));
225 return SCM_UNSPECIFIED
;
229 SCM_DEFINE (scm_umask
, "umask", 0, 1, 0,
231 "If @var{mode} is omitted, retuns a decimal number representing the current\n"
232 "file creation mask. Otherwise the file creation mask is set to\n"
233 "@var{mode} and the previous value is returned.\n\n"
234 "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
235 #define FUNC_NAME s_scm_umask
238 if (SCM_UNBNDP (mode
))
245 SCM_VALIDATE_INUM (1,mode
);
246 mask
= umask (SCM_INUM (mode
));
248 return SCM_MAKINUM (mask
);
254 SCM_DEFINE (scm_open_fdes
, "open-fdes", 2, 1, 0,
255 (SCM path
, SCM flags
, SCM mode
),
256 "Similar to @code{open} but return a file descriptor instead of\n"
258 #define FUNC_NAME s_scm_open_fdes
264 SCM_VALIDATE_STRING (1, path
);
265 iflags
= SCM_NUM2INT (2, flags
);
266 imode
= SCM_NUM2INT_DEF (3, mode
, 0666);
267 SCM_SYSCALL (fd
= open (SCM_STRING_CHARS (path
), iflags
, imode
));
270 return SCM_MAKINUM (fd
);
274 SCM_DEFINE (scm_open
, "open", 2, 1, 0,
275 (SCM path
, SCM flags
, SCM mode
),
276 "Open the file named by @var{path} for reading and/or writing.\n"
277 "@var{flags} is an integer specifying how the file should be opened.\n"
278 "@var{mode} is an integer specifying the permission bits of the file, if\n"
279 "it needs to be created, before the umask is applied. The default is 666\n"
280 "(Unix itself has no default).\n\n"
281 "@var{flags} can be constructed by combining variables using @code{logior}.\n"
282 "Basic flags are:\n\n"
284 "Open the file read-only.\n"
287 "Open the file write-only. \n"
290 "Open the file read/write.\n"
293 "Append to the file instead of truncating.\n"
296 "Create the file if it does not already exist.\n"
298 "See the Unix documentation of the @code{open} system call\n"
299 "for additional flags.")
300 #define FUNC_NAME s_scm_open
307 fd
= SCM_INUM (scm_open_fdes (path
, flags
, mode
));
308 iflags
= SCM_NUM2INT (2, flags
);
311 if (iflags
& O_APPEND
)
313 else if (iflags
& O_CREAT
)
319 if (iflags
& O_APPEND
)
321 else if (iflags
& O_WRONLY
)
326 newpt
= scm_fdes_to_port (fd
, port_mode
, path
);
331 SCM_DEFINE (scm_close
, "close", 1, 0, 0,
333 "Similar to close-port (@pxref{Generic Port Operations, close-port}),\n"
334 "but also works on file descriptors. A side\n"
335 "effect of closing a file descriptor is that any ports using that file\n"
336 "descriptor are moved to a different file descriptor and have\n"
337 "their revealed counts set to zero.")
338 #define FUNC_NAME s_scm_close
343 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
345 if (SCM_PORTP (fd_or_port
))
346 return scm_close_port (fd_or_port
);
347 SCM_VALIDATE_INUM (1,fd_or_port
);
348 fd
= SCM_INUM (fd_or_port
);
349 scm_evict_ports (fd
); /* see scsh manual. */
350 SCM_SYSCALL (rv
= close (fd
));
351 /* following scsh, closing an already closed file descriptor is
353 if (rv
< 0 && errno
!= EBADF
)
355 return SCM_BOOL (rv
>= 0);
359 SCM_DEFINE (scm_close_fdes
, "close-fdes", 1, 0, 0,
361 "A simple wrapper for the @code{close} system call.\n"
362 "Close file descriptor @var{fd}, which must be an integer.\n"
363 "Unlike close (@pxref{Ports and File Descriptors, close}),\n"
364 "the file descriptor will be closed even if a port is using it.\n"
365 "The return value is unspecified.")
366 #define FUNC_NAME s_scm_close_fdes
371 SCM_VALIDATE_INUM_COPY (1, fd
, c_fd
);
372 SCM_SYSCALL (rv
= close (c_fd
));
375 return SCM_UNSPECIFIED
;
383 SCM_SYMBOL (scm_sym_regular
, "regular");
384 SCM_SYMBOL (scm_sym_directory
, "directory");
386 SCM_SYMBOL (scm_sym_symlink
, "symlink");
388 SCM_SYMBOL (scm_sym_block_special
, "block-special");
389 SCM_SYMBOL (scm_sym_char_special
, "char-special");
390 SCM_SYMBOL (scm_sym_fifo
, "fifo");
391 SCM_SYMBOL (scm_sym_sock
, "socket");
392 SCM_SYMBOL (scm_sym_unknown
, "unknown");
395 scm_stat2scm (struct stat
*stat_temp
)
397 SCM ans
= scm_c_make_vector (15, SCM_UNSPECIFIED
);
398 SCM
*ve
= SCM_VELTS (ans
);
400 ve
[0] = scm_ulong2num ((unsigned long) stat_temp
->st_dev
);
401 ve
[1] = scm_ulong2num ((unsigned long) stat_temp
->st_ino
);
402 ve
[2] = scm_ulong2num ((unsigned long) stat_temp
->st_mode
);
403 ve
[3] = scm_ulong2num ((unsigned long) stat_temp
->st_nlink
);
404 ve
[4] = scm_ulong2num ((unsigned long) stat_temp
->st_uid
);
405 ve
[5] = scm_ulong2num ((unsigned long) stat_temp
->st_gid
);
406 #ifdef HAVE_STRUCT_STAT_ST_RDEV
407 ve
[6] = scm_ulong2num ((unsigned long) stat_temp
->st_rdev
);
411 ve
[7] = scm_ulong2num ((unsigned long) stat_temp
->st_size
);
412 ve
[8] = scm_ulong2num ((unsigned long) stat_temp
->st_atime
);
413 ve
[9] = scm_ulong2num ((unsigned long) stat_temp
->st_mtime
);
414 ve
[10] = scm_ulong2num ((unsigned long) stat_temp
->st_ctime
);
415 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
416 ve
[11] = scm_ulong2num ((unsigned long) stat_temp
->st_blksize
);
418 ve
[11] = scm_ulong2num (4096L);
420 #ifdef HAVE_STRUCT_STAT_ST_BLOCKS
421 ve
[12] = scm_ulong2num ((unsigned long) stat_temp
->st_blocks
);
426 int mode
= stat_temp
->st_mode
;
429 ve
[13] = scm_sym_regular
;
430 else if (S_ISDIR (mode
))
431 ve
[13] = scm_sym_directory
;
433 else if (S_ISLNK (mode
))
434 ve
[13] = scm_sym_symlink
;
436 else if (S_ISBLK (mode
))
437 ve
[13] = scm_sym_block_special
;
438 else if (S_ISCHR (mode
))
439 ve
[13] = scm_sym_char_special
;
440 else if (S_ISFIFO (mode
))
441 ve
[13] = scm_sym_fifo
;
443 else if (S_ISSOCK (mode
))
444 ve
[13] = scm_sym_sock
;
447 ve
[13] = scm_sym_unknown
;
449 ve
[14] = SCM_MAKINUM ((~S_IFMT
) & mode
);
451 /* the layout of the bits in ve[14] is intended to be portable.
452 If there are systems that don't follow the usual convention,
453 the following could be used:
456 if (S_ISUID & mode) tmp += 1;
458 if (S_IRGRP & mode) tmp += 1;
460 if (S_ISVTX & mode) tmp += 1;
462 if (S_IRUSR & mode) tmp += 1;
464 if (S_IWUSR & mode) tmp += 1;
466 if (S_IXUSR & mode) tmp += 1;
468 if (S_IWGRP & mode) tmp += 1;
470 if (S_IXGRP & mode) tmp += 1;
472 if (S_IROTH & mode) tmp += 1;
474 if (S_IWOTH & mode) tmp += 1;
476 if (S_IXOTH & mode) tmp += 1;
478 ve[14] = SCM_MAKINUM (tmp);
486 SCM_DEFINE (scm_stat
, "stat", 1, 0, 0,
488 "Return an object containing various information about the file\n"
489 "determined by @var{obj}. @var{obj} can be a string containing\n"
490 "a file name or a port or integer file descriptor which is open\n"
491 "on a file (in which case @code{fstat} is used as the underlying\n"
494 "The object returned by @code{stat} can be passed as a single\n"
495 "parameter to the following procedures, all of which return\n"
500 "The device containing the file.\n"
502 "The file serial number, which distinguishes this file from all\n"
503 "other files on the same device.\n"
505 "The mode of the file. This includes file type information and\n"
506 "the file permission bits. See @code{stat:type} and\n"
507 "@code{stat:perms} below.\n"
509 "The number of hard links to the file.\n"
511 "The user ID of the file's owner.\n"
513 "The group ID of the file.\n"
515 "Device ID; this entry is defined only for character or block\n"
518 "The size of a regular file in bytes.\n"
520 "The last access time for the file.\n"
522 "The last modification time for the file.\n"
524 "The last modification time for the attributes of the file.\n"
525 "@item stat:blksize\n"
526 "The optimal block size for reading or writing the file, in\n"
528 "@item stat:blocks\n"
529 "The amount of disk space that the file occupies measured in\n"
530 "units of 512 byte blocks.\n"
533 "In addition, the following procedures return the information\n"
534 "from stat:mode in a more convenient form:\n"
538 "A symbol representing the type of file. Possible values are\n"
539 "regular, directory, symlink, block-special, char-special, fifo,\n"
540 "socket and unknown\n"
542 "An integer representing the access permission bits.\n"
544 #define FUNC_NAME s_scm_stat
548 struct stat stat_temp
;
550 if (SCM_INUMP (object
))
552 SCM_SYSCALL (rv
= fstat (SCM_INUM (object
), &stat_temp
));
554 else if (SCM_STRINGP (object
))
556 SCM_SYSCALL (rv
= stat (SCM_STRING_CHARS (object
), &stat_temp
));
560 object
= SCM_COERCE_OUTPORT (object
);
561 SCM_VALIDATE_OPFPORT (1, object
);
562 fdes
= SCM_FPORT_FDES (object
);
563 SCM_SYSCALL (rv
= fstat (fdes
, &stat_temp
));
570 SCM_SYSERROR_MSG ("~A: ~S",
571 scm_list_2 (scm_makfrom0str (strerror (errno
)),
575 return scm_stat2scm (&stat_temp
);
580 /* {Modifying Directories}
584 SCM_DEFINE (scm_link
, "link", 2, 0, 0,
585 (SCM oldpath
, SCM newpath
),
586 "Creates a new name @var{newpath} in the file system for the\n"
587 "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n"
588 "link, the link may or may not be followed depending on the\n"
590 #define FUNC_NAME s_scm_link
594 SCM_VALIDATE_STRING (1, oldpath
);
595 SCM_VALIDATE_STRING (2, newpath
);
596 SCM_SYSCALL (val
= link (SCM_STRING_CHARS (oldpath
),
597 SCM_STRING_CHARS (newpath
)));
600 return SCM_UNSPECIFIED
;
603 #endif /* HAVE_LINK */
607 SCM_DEFINE (scm_rename
, "rename-file", 2, 0, 0,
608 (SCM oldname
, SCM newname
),
609 "Renames the file specified by @var{oldname} to @var{newname}.\n"
610 "The return value is unspecified.")
611 #define FUNC_NAME s_scm_rename
614 SCM_VALIDATE_STRING (1, oldname
);
615 SCM_VALIDATE_STRING (2, newname
);
617 SCM_SYSCALL (rv
= rename (SCM_STRING_CHARS (oldname
), SCM_STRING_CHARS (newname
)));
619 SCM_SYSCALL (rv
= link (SCM_STRING_CHARS (oldname
), SCM_STRING_CHARS (newname
)));
622 SCM_SYSCALL (rv
= unlink (SCM_STRING_CHARS (oldname
)));;
624 /* unlink failed. remove new name */
625 SCM_SYSCALL (unlink (SCM_STRING_CHARS (newname
)));
630 return SCM_UNSPECIFIED
;
635 SCM_DEFINE (scm_delete_file
, "delete-file", 1, 0, 0,
637 "Deletes (or \"unlinks\") the file specified by @var{path}.")
638 #define FUNC_NAME s_scm_delete_file
641 SCM_VALIDATE_STRING (1, str
);
642 SCM_SYSCALL (ans
= unlink (SCM_STRING_CHARS (str
)));
645 return SCM_UNSPECIFIED
;
650 SCM_DEFINE (scm_mkdir
, "mkdir", 1, 1, 0,
651 (SCM path
, SCM mode
),
652 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
653 "then the permissions of the directory file are set using the current\n"
654 "umask. Otherwise they are set to the decimal value specified with\n"
655 "@var{mode}. The return value is unspecified.")
656 #define FUNC_NAME s_scm_mkdir
660 SCM_VALIDATE_STRING (1, path
);
661 if (SCM_UNBNDP (mode
))
665 SCM_SYSCALL (rv
= mkdir (SCM_STRING_CHARS (path
), 0777 ^ mask
));
669 SCM_VALIDATE_INUM (2,mode
);
670 SCM_SYSCALL (rv
= mkdir (SCM_STRING_CHARS (path
), SCM_INUM (mode
)));
674 return SCM_UNSPECIFIED
;
677 #endif /* HAVE_MKDIR */
680 SCM_DEFINE (scm_rmdir
, "rmdir", 1, 0, 0,
682 "Remove the existing directory named by @var{path}. The directory must\n"
683 "be empty for this to succeed. The return value is unspecified.")
684 #define FUNC_NAME s_scm_rmdir
688 SCM_VALIDATE_STRING (1, path
);
689 SCM_SYSCALL (val
= rmdir (SCM_STRING_CHARS (path
)));
692 return SCM_UNSPECIFIED
;
699 /* {Examining Directories}
702 scm_t_bits scm_tc16_dir
;
705 SCM_DEFINE (scm_directory_stream_p
, "directory-stream?", 1, 0, 0,
707 "Return a boolean indicating whether @var{object} is a directory\n"
708 "stream as returned by @code{opendir}.")
709 #define FUNC_NAME s_scm_directory_stream_p
711 return SCM_BOOL (SCM_DIRP (obj
));
716 SCM_DEFINE (scm_opendir
, "opendir", 1, 0, 0,
718 "Open the directory specified by @var{path} and return a directory\n"
720 #define FUNC_NAME s_scm_opendir
723 SCM_VALIDATE_STRING (1, dirname
);
724 SCM_SYSCALL (ds
= opendir (SCM_STRING_CHARS (dirname
)));
727 SCM_RETURN_NEWSMOB (scm_tc16_dir
| SCM_DIR_FLAG_OPEN
, ds
);
732 SCM_DEFINE (scm_readdir
, "readdir", 1, 0, 0,
734 "Return (as a string) the next directory entry from the directory stream\n"
735 "@var{stream}. If there is no remaining entry to be read then the\n"
736 "end of file object is returned.")
737 #define FUNC_NAME s_scm_readdir
739 struct dirent
*rdent
;
741 SCM_VALIDATE_DIR (1, port
);
742 if (!SCM_DIR_OPEN_P (port
))
743 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port
));
746 SCM_SYSCALL (rdent
= readdir ((DIR *) SCM_CELL_WORD_1 (port
)));
750 return (rdent
? scm_mem2string (rdent
->d_name
, NAMLEN (rdent
))
756 SCM_DEFINE (scm_rewinddir
, "rewinddir", 1, 0, 0,
758 "Reset the directory port @var{stream} so that the next call to\n"
759 "@code{readdir} will return the first directory entry.")
760 #define FUNC_NAME s_scm_rewinddir
762 SCM_VALIDATE_DIR (1, port
);
763 if (!SCM_DIR_OPEN_P (port
))
764 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port
));
766 rewinddir ((DIR *) SCM_CELL_WORD_1 (port
));
768 return SCM_UNSPECIFIED
;
773 SCM_DEFINE (scm_closedir
, "closedir", 1, 0, 0,
775 "Close the directory stream @var{stream}.\n"
776 "The return value is unspecified.")
777 #define FUNC_NAME s_scm_closedir
779 SCM_VALIDATE_DIR (1, port
);
781 if (SCM_DIR_OPEN_P (port
))
785 SCM_SYSCALL (sts
= closedir ((DIR *) SCM_CELL_WORD_1 (port
)));
789 SCM_SET_CELL_WORD_0 (port
, scm_tc16_dir
);
792 return SCM_UNSPECIFIED
;
798 scm_dir_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
800 scm_puts ("#<", port
);
801 if (!SCM_DIR_OPEN_P (exp
))
802 scm_puts ("closed: ", port
);
803 scm_puts ("directory stream ", port
);
804 scm_intprint (SCM_CELL_WORD_1 (exp
), 16, port
);
805 scm_putc ('>', port
);
813 if (SCM_DIR_OPEN_P (p
))
814 closedir ((DIR *) SCM_CELL_WORD_1 (p
));
819 /* {Navigating Directories}
823 SCM_DEFINE (scm_chdir
, "chdir", 1, 0, 0,
825 "Change the current working directory to @var{path}.\n"
826 "The return value is unspecified.")
827 #define FUNC_NAME s_scm_chdir
831 SCM_VALIDATE_STRING (1, str
);
832 SCM_SYSCALL (ans
= chdir (SCM_STRING_CHARS (str
)));
835 return SCM_UNSPECIFIED
;
840 SCM_DEFINE (scm_getcwd
, "getcwd", 0, 0, 0,
842 "Return the name of the current working directory.")
843 #define FUNC_NAME s_scm_getcwd
850 wd
= scm_must_malloc (size
, FUNC_NAME
);
851 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
855 wd
= scm_must_malloc (size
, FUNC_NAME
);
859 result
= scm_mem2string (wd
, strlen (wd
));
864 #endif /* HAVE_GETCWD */
870 /* check that element is a port or file descriptor. if it's a port
871 and its buffer is ready for use, add it to the ports_ready list.
872 otherwise add its file descriptor to *set. the type of list can be
873 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
874 SCM_ARG3 for excepts. */
876 set_element (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM element
, int pos
)
880 if (SCM_INUMP (element
))
882 fd
= SCM_INUM (element
);
888 element
= SCM_COERCE_OUTPORT (element
);
889 SCM_ASSERT (SCM_OPFPORTP (element
), element
, pos
, "select");
892 /* check whether port has buffered input. */
893 scm_t_port
*pt
= SCM_PTAB_ENTRY (element
);
895 if (pt
->read_pos
< pt
->read_end
)
898 else if (pos
== SCM_ARG2
)
900 /* check whether port's output buffer has room. */
901 scm_t_port
*pt
= SCM_PTAB_ENTRY (element
);
903 /* > 1 since writing the last byte in the buffer causes flush. */
904 if (pt
->write_end
- pt
->write_pos
> 1)
907 fd
= use_buf
? -1 : SCM_FPORT_FDES (element
);
910 *ports_ready
= scm_cons (element
, *ports_ready
);
916 /* check list_or_vec, a list or vector of ports or file descriptors,
917 adding each member to either the ports_ready list (if it's a port
918 with a usable buffer) or to *set. the kind of list_or_vec can be
919 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
920 SCM_ARG3 for excepts. */
922 fill_select_type (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM list_or_vec
, int pos
)
926 if (SCM_VECTORP (list_or_vec
))
928 int i
= SCM_VECTOR_LENGTH (list_or_vec
);
929 SCM
*ve
= SCM_VELTS (list_or_vec
);
933 int fd
= set_element (set
, ports_ready
, ve
[i
], pos
);
941 while (!SCM_NULLP (list_or_vec
))
943 int fd
= set_element (set
, ports_ready
, SCM_CAR (list_or_vec
), pos
);
947 list_or_vec
= SCM_CDR (list_or_vec
);
954 /* if element (a file descriptor or port) appears in *set, cons it to
955 list. return list. */
957 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
961 if (SCM_INUMP (element
))
963 fd
= SCM_INUM (element
);
967 fd
= SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element
));
969 if (FD_ISSET (fd
, set
))
970 list
= scm_cons (element
, list
);
974 /* construct component of scm_select return value.
975 set: pointer to set of file descriptors found by select to be ready
976 ports_ready: ports ready due to buffering
977 list_or_vec: original list/vector handed to scm_select.
978 the return value is a list/vector of ready ports/file descriptors.
979 works by finding the objects in list which correspond to members of
980 *set and appending them to ports_ready. result is converted to a
981 vector if list_or_vec is a vector. */
983 retrieve_select_type (SELECT_TYPE
*set
, SCM ports_ready
, SCM list_or_vec
)
985 SCM answer_list
= ports_ready
;
987 if (SCM_VECTORP (list_or_vec
))
989 int i
= SCM_VECTOR_LENGTH (list_or_vec
);
990 SCM
*ve
= SCM_VELTS (list_or_vec
);
994 answer_list
= get_element (set
, ve
[i
], answer_list
);
996 return scm_vector (answer_list
);
1000 /* list_or_vec must be a list. */
1001 while (!SCM_NULLP (list_or_vec
))
1003 answer_list
= get_element (set
, SCM_CAR (list_or_vec
), answer_list
);
1004 list_or_vec
= SCM_CDR (list_or_vec
);
1010 /* Static helper functions above refer to s_scm_select directly as s_select */
1011 SCM_DEFINE (scm_select
, "select", 3, 2, 0,
1012 (SCM reads
, SCM writes
, SCM excepts
, SCM secs
, SCM usecs
),
1013 "This procedure has a variety of uses: waiting for the ability\n"
1014 "to provide input, accept output, or the existance of\n"
1015 "exceptional conditions on a collection of ports or file\n"
1016 "descriptors, or waiting for a timeout to occur.\n"
1017 "It also returns if interrupted by a signal.\n\n"
1018 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
1019 "vectors, with each member a port or a file descriptor.\n"
1020 "The value returned is a list of three corresponding\n"
1021 "lists or vectors containing only the members which meet the\n"
1022 "specified requirement. The ability of port buffers to\n"
1023 "provide input or accept output is taken into account.\n"
1024 "Ordering of the input lists or vectors is not preserved.\n\n"
1025 "The optional arguments @var{secs} and @var{usecs} specify the\n"
1026 "timeout. Either @var{secs} can be specified alone, as\n"
1027 "either an integer or a real number, or both @var{secs} and\n"
1028 "@var{usecs} can be specified as integers, in which case\n"
1029 "@var{usecs} is an additional timeout expressed in\n"
1030 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
1031 "select will wait for as long as it takes for one of the other\n"
1032 "conditions to be satisfied.\n\n"
1033 "The scsh version of @code{select} differs as follows:\n"
1034 "Only vectors are accepted for the first three arguments.\n"
1035 "The @var{usecs} argument is not supported.\n"
1036 "Multiple values are returned instead of a list.\n"
1037 "Duplicates in the input vectors appear only once in output.\n"
1038 "An additional @code{select!} interface is provided.\n"
1040 #define FUNC_NAME s_scm_select
1042 struct timeval timeout
;
1043 struct timeval
* time_ptr
;
1044 SELECT_TYPE read_set
;
1045 SELECT_TYPE write_set
;
1046 SELECT_TYPE except_set
;
1050 /* these lists accumulate ports which are ready due to buffering.
1051 their file descriptors don't need to be added to the select sets. */
1052 SCM read_ports_ready
= SCM_EOL
;
1053 SCM write_ports_ready
= SCM_EOL
;
1056 if (SCM_VECTORP (reads
))
1058 read_count
= SCM_VECTOR_LENGTH (reads
);
1062 read_count
= scm_ilength (reads
);
1063 SCM_ASSERT (read_count
>= 0, reads
, SCM_ARG1
, FUNC_NAME
);
1065 if (SCM_VECTORP (writes
))
1067 write_count
= SCM_VECTOR_LENGTH (writes
);
1071 write_count
= scm_ilength (writes
);
1072 SCM_ASSERT (write_count
>= 0, writes
, SCM_ARG2
, FUNC_NAME
);
1074 if (SCM_VECTORP (excepts
))
1076 except_count
= SCM_VECTOR_LENGTH (excepts
);
1080 except_count
= scm_ilength (excepts
);
1081 SCM_ASSERT (except_count
>= 0, excepts
, SCM_ARG3
, FUNC_NAME
);
1084 FD_ZERO (&read_set
);
1085 FD_ZERO (&write_set
);
1086 FD_ZERO (&except_set
);
1088 max_fd
= fill_select_type (&read_set
, &read_ports_ready
, reads
, SCM_ARG1
);
1091 int write_max
= fill_select_type (&write_set
, &write_ports_ready
,
1093 int except_max
= fill_select_type (&except_set
, NULL
,
1096 if (write_max
> max_fd
)
1098 if (except_max
> max_fd
)
1099 max_fd
= except_max
;
1102 /* if there's a port with a ready buffer, don't block, just
1103 check for ready file descriptors. */
1104 if (!SCM_NULLP (read_ports_ready
) || !SCM_NULLP (write_ports_ready
))
1107 timeout
.tv_usec
= 0;
1108 time_ptr
= &timeout
;
1110 else if (SCM_UNBNDP (secs
) || SCM_FALSEP (secs
))
1114 if (SCM_INUMP (secs
))
1116 timeout
.tv_sec
= SCM_INUM (secs
);
1117 if (SCM_UNBNDP (usecs
))
1118 timeout
.tv_usec
= 0;
1121 SCM_VALIDATE_INUM (5,usecs
);
1122 timeout
.tv_usec
= SCM_INUM (usecs
);
1127 double fl
= scm_num2dbl (secs
, FUNC_NAME
);
1129 if (!SCM_UNBNDP (usecs
))
1130 SCM_WRONG_TYPE_ARG (4, secs
);
1132 SCM_OUT_OF_RANGE (4, secs
);
1133 timeout
.tv_sec
= (long) fl
;
1134 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
1136 time_ptr
= &timeout
;
1140 #ifdef GUILE_ISELECT
1141 int rv
= scm_internal_select (max_fd
+ 1,
1142 &read_set
, &write_set
, &except_set
,
1145 int rv
= select (max_fd
+ 1,
1146 &read_set
, &write_set
, &except_set
, time_ptr
);
1151 return scm_list_3 (retrieve_select_type (&read_set
, read_ports_ready
, reads
),
1152 retrieve_select_type (&write_set
, write_ports_ready
, writes
),
1153 retrieve_select_type (&except_set
, SCM_EOL
, excepts
));
1156 #endif /* HAVE_SELECT */
1161 SCM_DEFINE (scm_fcntl
, "fcntl", 2, 1, 0,
1162 (SCM object
, SCM cmd
, SCM value
),
1163 "Apply @var{command} to the specified file descriptor or the underlying\n"
1164 "file descriptor of the specified port. @var{value} is an optional\n"
1165 "integer argument.\n\n"
1166 "Values for @var{command} are:\n\n"
1169 "Duplicate a file descriptor\n"
1171 "Get flags associated with the file descriptor.\n"
1173 "Set flags associated with the file descriptor to @var{value}.\n"
1175 "Get flags associated with the open file.\n"
1177 "Set flags associated with the open file to @var{value}\n"
1179 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1181 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1182 "@item FD_CLOEXEC\n"
1183 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
1186 #define FUNC_NAME s_scm_fcntl
1192 object
= SCM_COERCE_OUTPORT (object
);
1194 SCM_VALIDATE_INUM (2,cmd
);
1195 if (SCM_OPFPORTP (object
))
1196 fdes
= SCM_FPORT_FDES (object
);
1199 SCM_VALIDATE_INUM (1,object
);
1200 fdes
= SCM_INUM (object
);
1203 if (SCM_UNBNDP (value
)) {
1206 SCM_VALIDATE_INUM_COPY (SCM_ARG3
, value
, ivalue
);
1209 SCM_SYSCALL (rv
= fcntl (fdes
, SCM_INUM (cmd
), ivalue
));
1212 return SCM_MAKINUM (rv
);
1215 #endif /* HAVE_FCNTL */
1217 SCM_DEFINE (scm_fsync
, "fsync", 1, 0, 0,
1219 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1220 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1221 "file descriptor is fsync'd.\n"
1222 "The return value is unspecified.")
1223 #define FUNC_NAME s_scm_fsync
1227 object
= SCM_COERCE_OUTPORT (object
);
1229 if (SCM_OPFPORTP (object
))
1232 fdes
= SCM_FPORT_FDES (object
);
1236 SCM_VALIDATE_INUM (1,object
);
1237 fdes
= SCM_INUM (object
);
1239 if (fsync (fdes
) == -1)
1241 return SCM_UNSPECIFIED
;
1246 SCM_DEFINE (scm_symlink
, "symlink", 2, 0, 0,
1247 (SCM oldpath
, SCM newpath
),
1248 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1249 "@var{path-from}. The return value is unspecified.")
1250 #define FUNC_NAME s_scm_symlink
1254 SCM_VALIDATE_STRING (1, oldpath
);
1255 SCM_VALIDATE_STRING (2, newpath
);
1256 SCM_SYSCALL (val
= symlink (SCM_STRING_CHARS (oldpath
), SCM_STRING_CHARS (newpath
)));
1259 return SCM_UNSPECIFIED
;
1262 #endif /* HAVE_SYMLINK */
1264 #ifdef HAVE_READLINK
1265 SCM_DEFINE (scm_readlink
, "readlink", 1, 0, 0,
1267 "Return the value of the symbolic link named by @var{path} (a\n"
1268 "string), i.e., the file that the link points to.")
1269 #define FUNC_NAME s_scm_readlink
1275 SCM_VALIDATE_STRING (1, path
);
1276 buf
= scm_must_malloc (size
, FUNC_NAME
);
1277 while ((rv
= readlink (SCM_STRING_CHARS (path
), buf
, size
)) == size
)
1279 scm_must_free (buf
);
1281 buf
= scm_must_malloc (size
, FUNC_NAME
);
1285 result
= scm_mem2string (buf
, rv
);
1286 scm_must_free (buf
);
1290 #endif /* HAVE_READLINK */
1293 SCM_DEFINE (scm_lstat
, "lstat", 1, 0, 0,
1295 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1296 "it will return information about a symbolic link itself, not the \n"
1297 "file it points to. @var{path} must be a string.")
1298 #define FUNC_NAME s_scm_lstat
1301 struct stat stat_temp
;
1303 SCM_VALIDATE_STRING (1, str
);
1304 SCM_SYSCALL (rv
= lstat (SCM_STRING_CHARS (str
), &stat_temp
));
1309 SCM_SYSERROR_MSG ("~A: ~S",
1310 scm_list_2 (scm_makfrom0str (strerror (errno
)), str
),
1313 return scm_stat2scm(&stat_temp
);
1316 #endif /* HAVE_LSTAT */
1318 SCM_DEFINE (scm_copy_file
, "copy-file", 2, 0, 0,
1319 (SCM oldfile
, SCM newfile
),
1320 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1321 "The return value is unspecified.")
1322 #define FUNC_NAME s_scm_copy_file
1327 struct stat oldstat
;
1329 SCM_VALIDATE_STRING (1, oldfile
);
1330 SCM_VALIDATE_STRING (2, newfile
);
1331 if (stat (SCM_STRING_CHARS (oldfile
), &oldstat
) == -1)
1333 oldfd
= open (SCM_STRING_CHARS (oldfile
), O_RDONLY
);
1337 /* use POSIX flags instead of 07777?. */
1338 newfd
= open (SCM_STRING_CHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1339 oldstat
.st_mode
& 07777);
1343 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1344 if (write (newfd
, buf
, n
) != n
)
1351 if (close (newfd
) == -1)
1353 return SCM_UNSPECIFIED
;
1358 /* Filename manipulation */
1362 SCM_DEFINE (scm_dirname
, "dirname", 1, 0, 0,
1364 "Return the directory name component of the file name\n"
1365 "@var{filename}. If @var{filename} does not contain a directory\n"
1366 "component, @code{.} is returned.")
1367 #define FUNC_NAME s_scm_dirname
1371 unsigned long int len
;
1373 SCM_VALIDATE_STRING (1,filename
);
1375 s
= SCM_STRING_CHARS (filename
);
1376 len
= SCM_STRING_LENGTH (filename
);
1380 while (i
>= 0 && (s
[i
] == '/' || s
[i
] == '\\')) --i
;
1381 while (i
>= 0 && (s
[i
] != '/' || s
[i
] != '\\')) --i
;
1382 while (i
>= 0 && (s
[i
] == '/' || s
[i
] == '\\')) --i
;
1384 while (i
>= 0 && s
[i
] == '/') --i
;
1385 while (i
>= 0 && s
[i
] != '/') --i
;
1386 while (i
>= 0 && s
[i
] == '/') --i
;
1387 #endif /* ndef __MINGW32__ */
1391 if (len
> 0 && (s
[0] == '/' || s
[0] == '\\'))
1393 if (len
> 0 && s
[0] == '/')
1394 #endif /* ndef __MINGW32__ */
1395 return scm_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1397 return scm_dot_string
;
1400 return scm_substring (filename
, SCM_INUM0
, SCM_MAKINUM (i
+ 1));
1404 SCM_DEFINE (scm_basename
, "basename", 1, 1, 0,
1405 (SCM filename
, SCM suffix
),
1406 "Return the base name of the file name @var{filename}. The\n"
1407 "base name is the file name without any directory components.\n"
1408 "If @var{suffix} is privided, and is equal to the end of\n"
1409 "@var{basename}, it is removed also.")
1410 #define FUNC_NAME s_scm_basename
1415 SCM_VALIDATE_STRING (1,filename
);
1416 f
= SCM_STRING_CHARS (filename
);
1417 len
= SCM_STRING_LENGTH (filename
);
1419 if (SCM_UNBNDP (suffix
))
1423 SCM_VALIDATE_STRING (2, suffix
);
1424 s
= SCM_STRING_CHARS (suffix
);
1425 j
= SCM_STRING_LENGTH (suffix
) - 1;
1429 while (i
>= 0 && (f
[i
] == '/' || f
[i
] == '\\')) --i
;
1431 while (i
>= 0 && f
[i
] == '/') --i
;
1432 #endif /* ndef __MINGW32__ */
1434 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1438 while (i
>= 0 && (f
[i
] != '/' || f
[i
] != '\\')) --i
;
1440 while (i
>= 0 && f
[i
] != '/') --i
;
1441 #endif /* ndef __MINGW32__ */
1445 if (len
> 0 && (f
[0] == '/' || f
[i
] == '\\'))
1447 if (len
> 0 && f
[0] == '/')
1448 #endif /* ndef __MINGW32__ */
1449 return scm_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1451 return scm_dot_string
;
1454 return scm_substring (filename
, SCM_MAKINUM (i
+ 1), SCM_MAKINUM (end
+ 1));
1465 scm_tc16_dir
= scm_make_smob_type ("directory", 0);
1466 scm_set_smob_free (scm_tc16_dir
, scm_dir_free
);
1467 scm_set_smob_print (scm_tc16_dir
, scm_dir_print
);
1469 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1472 scm_c_define ("O_RDONLY", scm_long2num (O_RDONLY
));
1475 scm_c_define ("O_WRONLY", scm_long2num (O_WRONLY
));
1478 scm_c_define ("O_RDWR", scm_long2num (O_RDWR
));
1481 scm_c_define ("O_CREAT", scm_long2num (O_CREAT
));
1484 scm_c_define ("O_EXCL", scm_long2num (O_EXCL
));
1487 scm_c_define ("O_NOCTTY", scm_long2num (O_NOCTTY
));
1490 scm_c_define ("O_TRUNC", scm_long2num (O_TRUNC
));
1493 scm_c_define ("O_APPEND", scm_long2num (O_APPEND
));
1496 scm_c_define ("O_NONBLOCK", scm_long2num (O_NONBLOCK
));
1499 scm_c_define ("O_NDELAY", scm_long2num (O_NDELAY
));
1502 scm_c_define ("O_SYNC", scm_long2num (O_SYNC
));
1506 scm_c_define ("F_DUPFD", scm_long2num (F_DUPFD
));
1509 scm_c_define ("F_GETFD", scm_long2num (F_GETFD
));
1512 scm_c_define ("F_SETFD", scm_long2num (F_SETFD
));
1515 scm_c_define ("F_GETFL", scm_long2num (F_GETFL
));
1518 scm_c_define ("F_SETFL", scm_long2num (F_SETFL
));
1521 scm_c_define ("F_GETOWN", scm_long2num (F_GETOWN
));
1524 scm_c_define ("F_SETOWN", scm_long2num (F_SETOWN
));
1527 scm_c_define ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC
));
1530 #ifndef SCM_MAGIC_SNARFER
1531 #include "libguile/filesys.x"