1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 #define _GNU_SOURCE /* ask glibc for everything */
21 #define _POSIX_C_SOURCE 199506L /* for readdir_r elsewhere */
30 #include "libguile/_scm.h"
31 #include "libguile/smob.h"
32 #include "libguile/feature.h"
33 #include "libguile/fports.h"
34 #include "libguile/iselect.h"
35 #include "libguile/strings.h"
36 #include "libguile/vectors.h"
37 #include "libguile/lang.h"
39 #include "libguile/validate.h"
40 #include "libguile/filesys.h"
51 #ifdef TIME_WITH_SYS_TIME
52 # include <sys/time.h>
56 # include <sys/time.h>
66 #ifdef LIBC_H_WITH_UNISTD_H
70 #ifdef HAVE_SYS_SELECT_H
71 #include <sys/select.h>
78 #include <sys/types.h>
87 #if defined (__MINGW32__) || defined (_MSC_VER) || defined (__BORLANDC__)
88 # include "win32-dirent.h"
89 # define NAMLEN(dirent) strlen((dirent)->d_name)
92 # define NAMLEN(dirent) strlen((dirent)->d_name)
94 # define dirent direct
95 # define NAMLEN(dirent) (dirent)->d_namlen
97 # include <sys/ndir.h>
100 # include <sys/dir.h>
107 /* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
108 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
109 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
112 /* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows
113 compiler like BorlandC or MSVC has none of these macros defined. */
135 # define _S_IFIFO 0x1000 /* FIFO */
136 # define _S_IFCHR 0x2000 /* Character */
137 # define _S_IFBLK 0x3000 /* Block */
138 # define _S_IFDIR 0x4000 /* Directory */
139 # define _S_IFREG 0x8000 /* Regular */
140 # define _S_IFSOCK 0xC000 /* Socket */
161 # define S_ISBLK(mode) (((mode) & _S_IFMT) == _S_IFBLK)
162 # define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO)
163 # define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR)
164 # define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR)
165 # define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG)
166 # define S_ISSOCK(mode) (((mode) & _S_IFMT) == _S_IFSOCK)
168 #endif /* __MINGW32__ */
170 /* Some more definitions for the native Windows port. */
172 # define mkdir(path, mode) mkdir (path)
173 # define fsync(fd) _commit (fd)
174 # define fchmod(fd, mode) (-1)
175 #endif /* __MINGW32__ */
185 SCM_DEFINE (scm_chown
, "chown", 3, 0, 0,
186 (SCM object
, SCM owner
, SCM group
),
187 "Change the ownership and group of the file referred to by @var{object} to\n"
188 "the integer values @var{owner} and @var{group}. @var{object} can be\n"
189 "a string containing a file name or, if the platform\n"
190 "supports fchown, a port or integer file descriptor\n"
191 "which is open on the file. The return value\n"
192 "is unspecified.\n\n"
193 "If @var{object} is a symbolic link, either the\n"
194 "ownership of the link or the ownership of the referenced file will be\n"
195 "changed depending on the operating system (lchown is\n"
196 "unsupported at present). If @var{owner} or @var{group} is specified\n"
197 "as @code{-1}, then that ID is not changed.")
198 #define FUNC_NAME s_scm_chown
202 object
= SCM_COERCE_OUTPORT (object
);
205 if (scm_is_integer (object
) || (SCM_OPFPORTP (object
)))
207 int fdes
= (SCM_OPFPORTP (object
)?
208 SCM_FPORT_FDES (object
) : scm_to_int (object
));
210 SCM_SYSCALL (rv
= fchown (fdes
, scm_to_int (owner
), scm_to_int (group
)));
215 SCM_VALIDATE_STRING (1, object
);
216 SCM_SYSCALL (rv
= chown (SCM_STRING_CHARS (object
),
217 scm_to_int (owner
), scm_to_int (group
)));
221 return SCM_UNSPECIFIED
;
224 #endif /* HAVE_CHOWN */
227 SCM_DEFINE (scm_chmod
, "chmod", 2, 0, 0,
228 (SCM object
, SCM mode
),
229 "Changes the permissions of the file referred to by @var{obj}.\n"
230 "@var{obj} can be a string containing a file name or a port or integer file\n"
231 "descriptor which is open on a file (in which case @code{fchmod} is used\n"
232 "as the underlying system call).\n"
233 "@var{mode} specifies\n"
234 "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
235 "The return value is unspecified.")
236 #define FUNC_NAME s_scm_chmod
241 object
= SCM_COERCE_OUTPORT (object
);
243 if (scm_is_integer (object
) || SCM_OPFPORTP (object
))
245 if (scm_is_integer (object
))
246 fdes
= scm_to_int (object
);
248 fdes
= SCM_FPORT_FDES (object
);
249 SCM_SYSCALL (rv
= fchmod (fdes
, scm_to_int (mode
)));
253 SCM_VALIDATE_STRING (1, object
);
254 SCM_SYSCALL (rv
= chmod (SCM_STRING_CHARS (object
), scm_to_int (mode
)));
258 return SCM_UNSPECIFIED
;
262 SCM_DEFINE (scm_umask
, "umask", 0, 1, 0,
264 "If @var{mode} is omitted, returns a decimal number representing the current\n"
265 "file creation mask. Otherwise the file creation mask is set to\n"
266 "@var{mode} and the previous value is returned.\n\n"
267 "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
268 #define FUNC_NAME s_scm_umask
271 if (SCM_UNBNDP (mode
))
278 mask
= umask (scm_to_uint (mode
));
280 return scm_from_uint (mask
);
286 SCM_DEFINE (scm_open_fdes
, "open-fdes", 2, 1, 0,
287 (SCM path
, SCM flags
, SCM mode
),
288 "Similar to @code{open} but return a file descriptor instead of\n"
290 #define FUNC_NAME s_scm_open_fdes
296 SCM_VALIDATE_STRING (1, path
);
297 iflags
= SCM_NUM2INT (2, flags
);
298 imode
= SCM_NUM2INT_DEF (3, mode
, 0666);
299 SCM_SYSCALL (fd
= open (SCM_STRING_CHARS (path
), iflags
, imode
));
302 return scm_from_int (fd
);
306 SCM_DEFINE (scm_open
, "open", 2, 1, 0,
307 (SCM path
, SCM flags
, SCM mode
),
308 "Open the file named by @var{path} for reading and/or writing.\n"
309 "@var{flags} is an integer specifying how the file should be opened.\n"
310 "@var{mode} is an integer specifying the permission bits of the file, if\n"
311 "it needs to be created, before the umask is applied. The default is 666\n"
312 "(Unix itself has no default).\n\n"
313 "@var{flags} can be constructed by combining variables using @code{logior}.\n"
314 "Basic flags are:\n\n"
316 "Open the file read-only.\n"
319 "Open the file write-only.\n"
322 "Open the file read/write.\n"
325 "Append to the file instead of truncating.\n"
328 "Create the file if it does not already exist.\n"
330 "See the Unix documentation of the @code{open} system call\n"
331 "for additional flags.")
332 #define FUNC_NAME s_scm_open
339 fd
= scm_to_int (scm_open_fdes (path
, flags
, mode
));
340 iflags
= SCM_NUM2INT (2, flags
);
343 if (iflags
& O_APPEND
)
345 else if (iflags
& O_CREAT
)
351 if (iflags
& O_APPEND
)
353 else if (iflags
& O_WRONLY
)
358 newpt
= scm_fdes_to_port (fd
, port_mode
, path
);
363 SCM_DEFINE (scm_close
, "close", 1, 0, 0,
365 "Similar to close-port (@pxref{Closing, close-port}),\n"
366 "but also works on file descriptors. A side\n"
367 "effect of closing a file descriptor is that any ports using that file\n"
368 "descriptor are moved to a different file descriptor and have\n"
369 "their revealed counts set to zero.")
370 #define FUNC_NAME s_scm_close
375 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
377 if (SCM_PORTP (fd_or_port
))
378 return scm_close_port (fd_or_port
);
379 fd
= scm_to_int (fd_or_port
);
380 scm_evict_ports (fd
); /* see scsh manual. */
381 SCM_SYSCALL (rv
= close (fd
));
382 /* following scsh, closing an already closed file descriptor is
384 if (rv
< 0 && errno
!= EBADF
)
386 return scm_from_bool (rv
>= 0);
390 SCM_DEFINE (scm_close_fdes
, "close-fdes", 1, 0, 0,
392 "A simple wrapper for the @code{close} system call.\n"
393 "Close file descriptor @var{fd}, which must be an integer.\n"
394 "Unlike close (@pxref{Ports and File Descriptors, close}),\n"
395 "the file descriptor will be closed even if a port is using it.\n"
396 "The return value is unspecified.")
397 #define FUNC_NAME s_scm_close_fdes
402 c_fd
= scm_to_int (fd
);
403 SCM_SYSCALL (rv
= close (c_fd
));
406 return SCM_UNSPECIFIED
;
414 SCM_SYMBOL (scm_sym_regular
, "regular");
415 SCM_SYMBOL (scm_sym_directory
, "directory");
417 SCM_SYMBOL (scm_sym_symlink
, "symlink");
419 SCM_SYMBOL (scm_sym_block_special
, "block-special");
420 SCM_SYMBOL (scm_sym_char_special
, "char-special");
421 SCM_SYMBOL (scm_sym_fifo
, "fifo");
422 SCM_SYMBOL (scm_sym_sock
, "socket");
423 SCM_SYMBOL (scm_sym_unknown
, "unknown");
426 scm_stat2scm (struct stat
*stat_temp
)
428 SCM ans
= scm_c_make_vector (15, SCM_UNSPECIFIED
);
430 SCM_VECTOR_SET(ans
, 0, scm_from_ulong (stat_temp
->st_dev
));
431 SCM_VECTOR_SET(ans
, 1, scm_from_ulong (stat_temp
->st_ino
));
432 SCM_VECTOR_SET(ans
, 2, scm_from_ulong (stat_temp
->st_mode
));
433 SCM_VECTOR_SET(ans
, 3, scm_from_ulong (stat_temp
->st_nlink
));
434 SCM_VECTOR_SET(ans
, 4, scm_from_ulong (stat_temp
->st_uid
));
435 SCM_VECTOR_SET(ans
, 5, scm_from_ulong (stat_temp
->st_gid
));
436 #ifdef HAVE_STRUCT_STAT_ST_RDEV
437 SCM_VECTOR_SET(ans
, 6, scm_from_ulong (stat_temp
->st_rdev
));
439 SCM_VECTOR_SET(ans
, 6, SCM_BOOL_F
);
441 SCM_VECTOR_SET(ans
, 7, scm_from_ulong (stat_temp
->st_size
));
442 SCM_VECTOR_SET(ans
, 8, scm_from_ulong (stat_temp
->st_atime
));
443 SCM_VECTOR_SET(ans
, 9, scm_from_ulong (stat_temp
->st_mtime
));
444 SCM_VECTOR_SET(ans
, 10, scm_from_ulong (stat_temp
->st_ctime
));
445 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
446 SCM_VECTOR_SET(ans
, 11, scm_from_ulong (stat_temp
->st_blksize
));
448 SCM_VECTOR_SET(ans
, 11, scm_from_ulong (4096L));
450 #ifdef HAVE_STRUCT_STAT_ST_BLOCKS
451 SCM_VECTOR_SET(ans
, 12, scm_from_ulong (stat_temp
->st_blocks
));
453 SCM_VECTOR_SET(ans
, 12, SCM_BOOL_F
);
456 int mode
= stat_temp
->st_mode
;
459 SCM_VECTOR_SET(ans
, 13, scm_sym_regular
);
460 else if (S_ISDIR (mode
))
461 SCM_VECTOR_SET(ans
, 13, scm_sym_directory
);
463 else if (S_ISLNK (mode
))
464 SCM_VECTOR_SET(ans
, 13, scm_sym_symlink
);
466 else if (S_ISBLK (mode
))
467 SCM_VECTOR_SET(ans
, 13, scm_sym_block_special
);
468 else if (S_ISCHR (mode
))
469 SCM_VECTOR_SET(ans
, 13, scm_sym_char_special
);
470 else if (S_ISFIFO (mode
))
471 SCM_VECTOR_SET(ans
, 13, scm_sym_fifo
);
473 else if (S_ISSOCK (mode
))
474 SCM_VECTOR_SET(ans
, 13, scm_sym_sock
);
477 SCM_VECTOR_SET(ans
, 13, scm_sym_unknown
);
479 SCM_VECTOR_SET(ans
, 14, scm_from_int ((~S_IFMT
) & mode
));
481 /* the layout of the bits in ve[14] is intended to be portable.
482 If there are systems that don't follow the usual convention,
483 the following could be used:
486 if (S_ISUID & mode) tmp += 1;
488 if (S_IRGRP & mode) tmp += 1;
490 if (S_ISVTX & mode) tmp += 1;
492 if (S_IRUSR & mode) tmp += 1;
494 if (S_IWUSR & mode) tmp += 1;
496 if (S_IXUSR & mode) tmp += 1;
498 if (S_IWGRP & mode) tmp += 1;
500 if (S_IXGRP & mode) tmp += 1;
502 if (S_IROTH & mode) tmp += 1;
504 if (S_IWOTH & mode) tmp += 1;
506 if (S_IXOTH & mode) tmp += 1;
508 SCM_VECTOR_SET(ans, 14, scm_from_int (tmp));
518 * Try getting the appropiate stat buffer for a given file descriptor
519 * under Windows. It differentiates between file, pipe and socket
522 static int fstat_Win32 (int fdes
, struct stat
*buf
)
524 int error
, optlen
= sizeof (int);
526 memset (buf
, 0, sizeof (struct stat
));
528 /* Is this a socket ? */
529 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
531 buf
->st_mode
= _S_IFSOCK
| _S_IREAD
| _S_IWRITE
| _S_IEXEC
;
533 buf
->st_atime
= buf
->st_ctime
= buf
->st_mtime
= time (NULL
);
536 /* Maybe a regular file or pipe ? */
537 return fstat (fdes
, buf
);
539 #endif /* __MINGW32__ */
541 SCM_DEFINE (scm_stat
, "stat", 1, 0, 0,
543 "Return an object containing various information about the file\n"
544 "determined by @var{obj}. @var{obj} can be a string containing\n"
545 "a file name or a port or integer file descriptor which is open\n"
546 "on a file (in which case @code{fstat} is used as the underlying\n"
549 "The object returned by @code{stat} can be passed as a single\n"
550 "parameter to the following procedures, all of which return\n"
555 "The device containing the file.\n"
557 "The file serial number, which distinguishes this file from all\n"
558 "other files on the same device.\n"
560 "The mode of the file. This includes file type information and\n"
561 "the file permission bits. See @code{stat:type} and\n"
562 "@code{stat:perms} below.\n"
564 "The number of hard links to the file.\n"
566 "The user ID of the file's owner.\n"
568 "The group ID of the file.\n"
570 "Device ID; this entry is defined only for character or block\n"
573 "The size of a regular file in bytes.\n"
575 "The last access time for the file.\n"
577 "The last modification time for the file.\n"
579 "The last modification time for the attributes of the file.\n"
580 "@item stat:blksize\n"
581 "The optimal block size for reading or writing the file, in\n"
583 "@item stat:blocks\n"
584 "The amount of disk space that the file occupies measured in\n"
585 "units of 512 byte blocks.\n"
588 "In addition, the following procedures return the information\n"
589 "from stat:mode in a more convenient form:\n"
593 "A symbol representing the type of file. Possible values are\n"
594 "regular, directory, symlink, block-special, char-special, fifo,\n"
595 "socket and unknown\n"
597 "An integer representing the access permission bits.\n"
599 #define FUNC_NAME s_scm_stat
603 struct stat stat_temp
;
605 if (scm_is_integer (object
))
608 SCM_SYSCALL (rv
= fstat_Win32 (scm_to_int (object
), &stat_temp
));
610 SCM_SYSCALL (rv
= fstat (scm_to_int (object
), &stat_temp
));
613 else if (scm_is_string (object
))
615 char *file
= scm_to_locale_string (object
);
618 p
= file
+ strlen (file
) - 1;
619 while (p
> file
&& (*p
== '/' || *p
== '\\'))
622 SCM_SYSCALL (rv
= stat (file
, &stat_temp
));
627 object
= SCM_COERCE_OUTPORT (object
);
628 SCM_VALIDATE_OPFPORT (1, object
);
629 fdes
= SCM_FPORT_FDES (object
);
631 SCM_SYSCALL (rv
= fstat_Win32 (fdes
, &stat_temp
));
633 SCM_SYSCALL (rv
= fstat (fdes
, &stat_temp
));
641 SCM_SYSERROR_MSG ("~A: ~S",
642 scm_list_2 (scm_strerror (scm_from_int (en
)),
646 return scm_stat2scm (&stat_temp
);
651 /* {Modifying Directories}
655 SCM_DEFINE (scm_link
, "link", 2, 0, 0,
656 (SCM oldpath
, SCM newpath
),
657 "Creates a new name @var{newpath} in the file system for the\n"
658 "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n"
659 "link, the link may or may not be followed depending on the\n"
661 #define FUNC_NAME s_scm_link
665 SCM_VALIDATE_STRING (1, oldpath
);
666 SCM_VALIDATE_STRING (2, newpath
);
667 SCM_SYSCALL (val
= link (SCM_STRING_CHARS (oldpath
),
668 SCM_STRING_CHARS (newpath
)));
671 return SCM_UNSPECIFIED
;
674 #endif /* HAVE_LINK */
678 SCM_DEFINE (scm_rename
, "rename-file", 2, 0, 0,
679 (SCM oldname
, SCM newname
),
680 "Renames the file specified by @var{oldname} to @var{newname}.\n"
681 "The return value is unspecified.")
682 #define FUNC_NAME s_scm_rename
685 SCM_VALIDATE_STRING (1, oldname
);
686 SCM_VALIDATE_STRING (2, newname
);
688 SCM_SYSCALL (rv
= rename (SCM_STRING_CHARS (oldname
), SCM_STRING_CHARS (newname
)));
690 SCM_SYSCALL (rv
= link (SCM_STRING_CHARS (oldname
), SCM_STRING_CHARS (newname
)));
693 SCM_SYSCALL (rv
= unlink (SCM_STRING_CHARS (oldname
)));;
695 /* unlink failed. remove new name */
696 SCM_SYSCALL (unlink (SCM_STRING_CHARS (newname
)));
701 return SCM_UNSPECIFIED
;
706 SCM_DEFINE (scm_delete_file
, "delete-file", 1, 0, 0,
708 "Deletes (or \"unlinks\") the file specified by @var{path}.")
709 #define FUNC_NAME s_scm_delete_file
712 SCM_VALIDATE_STRING (1, str
);
713 SCM_SYSCALL (ans
= unlink (SCM_STRING_CHARS (str
)));
716 return SCM_UNSPECIFIED
;
721 SCM_DEFINE (scm_mkdir
, "mkdir", 1, 1, 0,
722 (SCM path
, SCM mode
),
723 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
724 "then the permissions of the directory file are set using the current\n"
725 "umask. Otherwise they are set to the decimal value specified with\n"
726 "@var{mode}. The return value is unspecified.")
727 #define FUNC_NAME s_scm_mkdir
731 SCM_VALIDATE_STRING (1, path
);
732 if (SCM_UNBNDP (mode
))
736 SCM_SYSCALL (rv
= mkdir (SCM_STRING_CHARS (path
), 0777 ^ mask
));
740 SCM_SYSCALL (rv
= mkdir (SCM_STRING_CHARS (path
), scm_to_uint (mode
)));
744 return SCM_UNSPECIFIED
;
747 #endif /* HAVE_MKDIR */
750 SCM_DEFINE (scm_rmdir
, "rmdir", 1, 0, 0,
752 "Remove the existing directory named by @var{path}. The directory must\n"
753 "be empty for this to succeed. The return value is unspecified.")
754 #define FUNC_NAME s_scm_rmdir
758 SCM_VALIDATE_STRING (1, path
);
759 SCM_SYSCALL (val
= rmdir (SCM_STRING_CHARS (path
)));
762 return SCM_UNSPECIFIED
;
769 /* {Examining Directories}
772 scm_t_bits scm_tc16_dir
;
775 SCM_DEFINE (scm_directory_stream_p
, "directory-stream?", 1, 0, 0,
777 "Return a boolean indicating whether @var{object} is a directory\n"
778 "stream as returned by @code{opendir}.")
779 #define FUNC_NAME s_scm_directory_stream_p
781 return scm_from_bool (SCM_DIRP (obj
));
786 SCM_DEFINE (scm_opendir
, "opendir", 1, 0, 0,
788 "Open the directory specified by @var{path} and return a directory\n"
790 #define FUNC_NAME s_scm_opendir
793 SCM_VALIDATE_STRING (1, dirname
);
794 SCM_SYSCALL (ds
= opendir (SCM_STRING_CHARS (dirname
)));
797 SCM_RETURN_NEWSMOB (scm_tc16_dir
| SCM_DIR_FLAG_OPEN
, ds
);
802 /* FIXME: The glibc manual has a portability note that readdir_r may not
803 null-terminate its return string. The circumstances outlined for this
804 are not clear, nor is it clear what should be done about it. Lets worry
805 about this if/when someone can figure it out. */
807 SCM_DEFINE (scm_readdir
, "readdir", 1, 0, 0,
809 "Return (as a string) the next directory entry from the directory stream\n"
810 "@var{stream}. If there is no remaining entry to be read then the\n"
811 "end of file object is returned.")
812 #define FUNC_NAME s_scm_readdir
814 struct dirent
*rdent
;
816 SCM_VALIDATE_DIR (1, port
);
817 if (!SCM_DIR_OPEN_P (port
))
818 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port
));
823 /* On Solaris 2.7, struct dirent only contains "char d_name[1]" and one is
824 expected to provide a buffer of "sizeof(struct dirent) + NAME_MAX"
825 bytes. The glibc 2.3.2 manual notes this sort of thing too, and
826 advises "offsetof(struct dirent,d_name) + NAME_MAX + 1". Either should
827 suffice, we give both to be certain. */
830 char pad1
[sizeof(struct dirent
) + NAME_MAX
];
831 char pad2
[offsetof (struct dirent
, d_name
) + NAME_MAX
+ 1];
833 SCM_SYSCALL (readdir_r ((DIR *) SCM_CELL_WORD_1 (port
), &u
.ent
, &rdent
));
835 SCM_SYSCALL (rdent
= readdir ((DIR *) SCM_CELL_WORD_1 (port
)));
840 return (rdent
? scm_mem2string (rdent
->d_name
, NAMLEN (rdent
))
847 SCM_DEFINE (scm_rewinddir
, "rewinddir", 1, 0, 0,
849 "Reset the directory port @var{stream} so that the next call to\n"
850 "@code{readdir} will return the first directory entry.")
851 #define FUNC_NAME s_scm_rewinddir
853 SCM_VALIDATE_DIR (1, port
);
854 if (!SCM_DIR_OPEN_P (port
))
855 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port
));
857 rewinddir ((DIR *) SCM_CELL_WORD_1 (port
));
859 return SCM_UNSPECIFIED
;
864 SCM_DEFINE (scm_closedir
, "closedir", 1, 0, 0,
866 "Close the directory stream @var{stream}.\n"
867 "The return value is unspecified.")
868 #define FUNC_NAME s_scm_closedir
870 SCM_VALIDATE_DIR (1, port
);
872 if (SCM_DIR_OPEN_P (port
))
876 SCM_SYSCALL (sts
= closedir ((DIR *) SCM_CELL_WORD_1 (port
)));
880 SCM_SET_CELL_WORD_0 (port
, scm_tc16_dir
);
883 return SCM_UNSPECIFIED
;
889 scm_dir_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
891 scm_puts ("#<", port
);
892 if (!SCM_DIR_OPEN_P (exp
))
893 scm_puts ("closed: ", port
);
894 scm_puts ("directory stream ", port
);
895 scm_intprint (SCM_CELL_WORD_1 (exp
), 16, port
);
896 scm_putc ('>', port
);
904 if (SCM_DIR_OPEN_P (p
))
905 closedir ((DIR *) SCM_CELL_WORD_1 (p
));
910 /* {Navigating Directories}
914 SCM_DEFINE (scm_chdir
, "chdir", 1, 0, 0,
916 "Change the current working directory to @var{path}.\n"
917 "The return value is unspecified.")
918 #define FUNC_NAME s_scm_chdir
922 SCM_VALIDATE_STRING (1, str
);
923 SCM_SYSCALL (ans
= chdir (SCM_STRING_CHARS (str
)));
926 return SCM_UNSPECIFIED
;
931 SCM_DEFINE (scm_getcwd
, "getcwd", 0, 0, 0,
933 "Return the name of the current working directory.")
934 #define FUNC_NAME s_scm_getcwd
941 wd
= scm_malloc (size
);
942 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
946 wd
= scm_malloc (size
);
950 int save_errno
= errno
;
955 result
= scm_mem2string (wd
, strlen (wd
));
960 #endif /* HAVE_GETCWD */
966 /* check that element is a port or file descriptor. if it's a port
967 and its buffer is ready for use, add it to the ports_ready list.
968 otherwise add its file descriptor to *set. the type of list can be
969 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
970 SCM_ARG3 for excepts. */
972 set_element (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM element
, int pos
)
976 if (scm_is_integer (element
))
978 fd
= scm_to_int (element
);
984 element
= SCM_COERCE_OUTPORT (element
);
985 SCM_ASSERT (SCM_OPFPORTP (element
), element
, pos
, "select");
988 /* check whether port has buffered input. */
989 scm_t_port
*pt
= SCM_PTAB_ENTRY (element
);
991 if (pt
->read_pos
< pt
->read_end
)
994 else if (pos
== SCM_ARG2
)
996 /* check whether port's output buffer has room. */
997 scm_t_port
*pt
= SCM_PTAB_ENTRY (element
);
999 /* > 1 since writing the last byte in the buffer causes flush. */
1000 if (pt
->write_end
- pt
->write_pos
> 1)
1003 fd
= use_buf
? -1 : SCM_FPORT_FDES (element
);
1006 *ports_ready
= scm_cons (element
, *ports_ready
);
1012 /* check list_or_vec, a list or vector of ports or file descriptors,
1013 adding each member to either the ports_ready list (if it's a port
1014 with a usable buffer) or to *set. the kind of list_or_vec can be
1015 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
1016 SCM_ARG3 for excepts. */
1018 fill_select_type (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM list_or_vec
, int pos
)
1022 if (SCM_VECTORP (list_or_vec
))
1024 int i
= SCM_VECTOR_LENGTH (list_or_vec
);
1025 SCM
const *ve
= SCM_VELTS (list_or_vec
);
1029 int fd
= set_element (set
, ports_ready
, ve
[i
], pos
);
1037 while (!SCM_NULL_OR_NIL_P (list_or_vec
))
1039 int fd
= set_element (set
, ports_ready
, SCM_CAR (list_or_vec
), pos
);
1043 list_or_vec
= SCM_CDR (list_or_vec
);
1050 /* if element (a file descriptor or port) appears in *set, cons it to
1051 list. return list. */
1053 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
1057 if (scm_is_integer (element
))
1059 fd
= scm_to_int (element
);
1063 fd
= SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element
));
1065 if (FD_ISSET (fd
, set
))
1066 list
= scm_cons (element
, list
);
1070 /* construct component of scm_select return value.
1071 set: pointer to set of file descriptors found by select to be ready
1072 ports_ready: ports ready due to buffering
1073 list_or_vec: original list/vector handed to scm_select.
1074 the return value is a list/vector of ready ports/file descriptors.
1075 works by finding the objects in list which correspond to members of
1076 *set and appending them to ports_ready. result is converted to a
1077 vector if list_or_vec is a vector. */
1079 retrieve_select_type (SELECT_TYPE
*set
, SCM ports_ready
, SCM list_or_vec
)
1081 SCM answer_list
= ports_ready
;
1083 if (SCM_VECTORP (list_or_vec
))
1085 int i
= SCM_VECTOR_LENGTH (list_or_vec
);
1086 SCM
const *ve
= SCM_VELTS (list_or_vec
);
1090 answer_list
= get_element (set
, ve
[i
], answer_list
);
1092 return scm_vector (answer_list
);
1096 /* list_or_vec must be a list. */
1097 while (!SCM_NULL_OR_NIL_P (list_or_vec
))
1099 answer_list
= get_element (set
, SCM_CAR (list_or_vec
), answer_list
);
1100 list_or_vec
= SCM_CDR (list_or_vec
);
1106 /* Static helper functions above refer to s_scm_select directly as s_select */
1107 SCM_DEFINE (scm_select
, "select", 3, 2, 0,
1108 (SCM reads
, SCM writes
, SCM excepts
, SCM secs
, SCM usecs
),
1109 "This procedure has a variety of uses: waiting for the ability\n"
1110 "to provide input, accept output, or the existence of\n"
1111 "exceptional conditions on a collection of ports or file\n"
1112 "descriptors, or waiting for a timeout to occur.\n"
1113 "It also returns if interrupted by a signal.\n\n"
1114 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
1115 "vectors, with each member a port or a file descriptor.\n"
1116 "The value returned is a list of three corresponding\n"
1117 "lists or vectors containing only the members which meet the\n"
1118 "specified requirement. The ability of port buffers to\n"
1119 "provide input or accept output is taken into account.\n"
1120 "Ordering of the input lists or vectors is not preserved.\n\n"
1121 "The optional arguments @var{secs} and @var{usecs} specify the\n"
1122 "timeout. Either @var{secs} can be specified alone, as\n"
1123 "either an integer or a real number, or both @var{secs} and\n"
1124 "@var{usecs} can be specified as integers, in which case\n"
1125 "@var{usecs} is an additional timeout expressed in\n"
1126 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
1127 "select will wait for as long as it takes for one of the other\n"
1128 "conditions to be satisfied.\n\n"
1129 "The scsh version of @code{select} differs as follows:\n"
1130 "Only vectors are accepted for the first three arguments.\n"
1131 "The @var{usecs} argument is not supported.\n"
1132 "Multiple values are returned instead of a list.\n"
1133 "Duplicates in the input vectors appear only once in output.\n"
1134 "An additional @code{select!} interface is provided.")
1135 #define FUNC_NAME s_scm_select
1137 struct timeval timeout
;
1138 struct timeval
* time_ptr
;
1139 SELECT_TYPE read_set
;
1140 SELECT_TYPE write_set
;
1141 SELECT_TYPE except_set
;
1145 /* these lists accumulate ports which are ready due to buffering.
1146 their file descriptors don't need to be added to the select sets. */
1147 SCM read_ports_ready
= SCM_EOL
;
1148 SCM write_ports_ready
= SCM_EOL
;
1151 if (SCM_VECTORP (reads
))
1153 read_count
= SCM_VECTOR_LENGTH (reads
);
1157 read_count
= scm_ilength (reads
);
1158 SCM_ASSERT (read_count
>= 0, reads
, SCM_ARG1
, FUNC_NAME
);
1160 if (SCM_VECTORP (writes
))
1162 write_count
= SCM_VECTOR_LENGTH (writes
);
1166 write_count
= scm_ilength (writes
);
1167 SCM_ASSERT (write_count
>= 0, writes
, SCM_ARG2
, FUNC_NAME
);
1169 if (SCM_VECTORP (excepts
))
1171 except_count
= SCM_VECTOR_LENGTH (excepts
);
1175 except_count
= scm_ilength (excepts
);
1176 SCM_ASSERT (except_count
>= 0, excepts
, SCM_ARG3
, FUNC_NAME
);
1179 FD_ZERO (&read_set
);
1180 FD_ZERO (&write_set
);
1181 FD_ZERO (&except_set
);
1183 max_fd
= fill_select_type (&read_set
, &read_ports_ready
, reads
, SCM_ARG1
);
1186 int write_max
= fill_select_type (&write_set
, &write_ports_ready
,
1188 int except_max
= fill_select_type (&except_set
, NULL
,
1191 if (write_max
> max_fd
)
1193 if (except_max
> max_fd
)
1194 max_fd
= except_max
;
1197 /* if there's a port with a ready buffer, don't block, just
1198 check for ready file descriptors. */
1199 if (!SCM_NULLP (read_ports_ready
) || !SCM_NULLP (write_ports_ready
))
1202 timeout
.tv_usec
= 0;
1203 time_ptr
= &timeout
;
1205 else if (SCM_UNBNDP (secs
) || scm_is_false (secs
))
1209 if (scm_is_unsigned_integer (secs
, 0, ULONG_MAX
))
1211 timeout
.tv_sec
= scm_to_ulong (secs
);
1212 if (SCM_UNBNDP (usecs
))
1213 timeout
.tv_usec
= 0;
1215 timeout
.tv_usec
= scm_to_long (usecs
);
1219 double fl
= scm_to_double (secs
);
1221 if (!SCM_UNBNDP (usecs
))
1222 SCM_WRONG_TYPE_ARG (4, secs
);
1224 SCM_OUT_OF_RANGE (4, secs
);
1225 timeout
.tv_sec
= (long) fl
;
1226 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
1228 time_ptr
= &timeout
;
1232 int rv
= scm_internal_select (max_fd
+ 1,
1233 &read_set
, &write_set
, &except_set
,
1238 return scm_list_3 (retrieve_select_type (&read_set
, read_ports_ready
, reads
),
1239 retrieve_select_type (&write_set
, write_ports_ready
, writes
),
1240 retrieve_select_type (&except_set
, SCM_EOL
, excepts
));
1243 #endif /* HAVE_SELECT */
1248 SCM_DEFINE (scm_fcntl
, "fcntl", 2, 1, 0,
1249 (SCM object
, SCM cmd
, SCM value
),
1250 "Apply @var{command} to the specified file descriptor or the underlying\n"
1251 "file descriptor of the specified port. @var{value} is an optional\n"
1252 "integer argument.\n\n"
1253 "Values for @var{command} are:\n\n"
1256 "Duplicate a file descriptor\n"
1258 "Get flags associated with the file descriptor.\n"
1260 "Set flags associated with the file descriptor to @var{value}.\n"
1262 "Get flags associated with the open file.\n"
1264 "Set flags associated with the open file to @var{value}\n"
1266 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1268 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1269 "@item FD_CLOEXEC\n"
1270 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
1273 #define FUNC_NAME s_scm_fcntl
1279 object
= SCM_COERCE_OUTPORT (object
);
1281 if (SCM_OPFPORTP (object
))
1282 fdes
= SCM_FPORT_FDES (object
);
1284 fdes
= scm_to_int (object
);
1286 if (SCM_UNBNDP (value
))
1289 ivalue
= scm_to_int (value
);
1291 SCM_SYSCALL (rv
= fcntl (fdes
, scm_to_int (cmd
), ivalue
));
1294 return scm_from_int (rv
);
1297 #endif /* HAVE_FCNTL */
1299 SCM_DEFINE (scm_fsync
, "fsync", 1, 0, 0,
1301 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1302 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1303 "file descriptor is fsync'd.\n"
1304 "The return value is unspecified.")
1305 #define FUNC_NAME s_scm_fsync
1309 object
= SCM_COERCE_OUTPORT (object
);
1311 if (SCM_OPFPORTP (object
))
1314 fdes
= SCM_FPORT_FDES (object
);
1317 fdes
= scm_to_int (object
);
1319 if (fsync (fdes
) == -1)
1321 return SCM_UNSPECIFIED
;
1326 SCM_DEFINE (scm_symlink
, "symlink", 2, 0, 0,
1327 (SCM oldpath
, SCM newpath
),
1328 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1329 "@var{path-from}. The return value is unspecified.")
1330 #define FUNC_NAME s_scm_symlink
1334 SCM_VALIDATE_STRING (1, oldpath
);
1335 SCM_VALIDATE_STRING (2, newpath
);
1336 SCM_SYSCALL (val
= symlink (SCM_STRING_CHARS (oldpath
), SCM_STRING_CHARS (newpath
)));
1339 return SCM_UNSPECIFIED
;
1342 #endif /* HAVE_SYMLINK */
1344 #ifdef HAVE_READLINK
1345 SCM_DEFINE (scm_readlink
, "readlink", 1, 0, 0,
1347 "Return the value of the symbolic link named by @var{path} (a\n"
1348 "string), i.e., the file that the link points to.")
1349 #define FUNC_NAME s_scm_readlink
1355 SCM_VALIDATE_STRING (1, path
);
1356 buf
= scm_malloc (size
);
1357 while ((rv
= readlink (SCM_STRING_CHARS (path
), buf
, size
)) == size
)
1361 buf
= scm_malloc (size
);
1365 int save_errno
= errno
;
1370 result
= scm_mem2string (buf
, rv
);
1375 #endif /* HAVE_READLINK */
1378 SCM_DEFINE (scm_lstat
, "lstat", 1, 0, 0,
1380 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1381 "it will return information about a symbolic link itself, not the\n"
1382 "file it points to. @var{path} must be a string.")
1383 #define FUNC_NAME s_scm_lstat
1386 struct stat stat_temp
;
1388 SCM_VALIDATE_STRING (1, str
);
1389 SCM_SYSCALL (rv
= lstat (SCM_STRING_CHARS (str
), &stat_temp
));
1394 SCM_SYSERROR_MSG ("~A: ~S",
1395 scm_list_2 (scm_strerror (scm_from_int (en
)), str
),
1398 return scm_stat2scm(&stat_temp
);
1401 #endif /* HAVE_LSTAT */
1403 SCM_DEFINE (scm_copy_file
, "copy-file", 2, 0, 0,
1404 (SCM oldfile
, SCM newfile
),
1405 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1406 "The return value is unspecified.")
1407 #define FUNC_NAME s_scm_copy_file
1412 struct stat oldstat
;
1414 SCM_VALIDATE_STRING (1, oldfile
);
1415 SCM_VALIDATE_STRING (2, newfile
);
1417 oldfd
= open (SCM_STRING_CHARS (oldfile
), O_RDONLY
);
1422 SCM_SYSCALL (rv
= fstat_Win32 (oldfd
, &oldstat
));
1424 SCM_SYSCALL (rv
= fstat (oldfd
, &oldstat
));
1427 goto err_close_oldfd
;
1429 /* use POSIX flags instead of 07777?. */
1430 newfd
= open (SCM_STRING_CHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1431 oldstat
.st_mode
& 07777);
1439 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1440 if (write (newfd
, buf
, n
) != n
)
1447 if (close (newfd
) == -1)
1449 return SCM_UNSPECIFIED
;
1454 /* Filename manipulation */
1458 SCM_DEFINE (scm_dirname
, "dirname", 1, 0, 0,
1460 "Return the directory name component of the file name\n"
1461 "@var{filename}. If @var{filename} does not contain a directory\n"
1462 "component, @code{.} is returned.")
1463 #define FUNC_NAME s_scm_dirname
1467 unsigned long int len
;
1469 SCM_VALIDATE_STRING (1, filename
);
1471 s
= SCM_STRING_CHARS (filename
);
1472 len
= SCM_STRING_LENGTH (filename
);
1476 while (i
>= 0 && (s
[i
] == '/' || s
[i
] == '\\')) --i
;
1477 while (i
>= 0 && (s
[i
] != '/' && s
[i
] != '\\')) --i
;
1478 while (i
>= 0 && (s
[i
] == '/' || s
[i
] == '\\')) --i
;
1480 while (i
>= 0 && s
[i
] == '/') --i
;
1481 while (i
>= 0 && s
[i
] != '/') --i
;
1482 while (i
>= 0 && s
[i
] == '/') --i
;
1483 #endif /* ndef __MINGW32__ */
1487 if (len
> 0 && (s
[0] == '/' || s
[0] == '\\'))
1489 if (len
> 0 && s
[0] == '/')
1490 #endif /* ndef __MINGW32__ */
1491 return scm_substring (filename
, SCM_INUM0
, scm_from_int (1));
1493 return scm_dot_string
;
1496 return scm_substring (filename
, SCM_INUM0
, scm_from_int (i
+ 1));
1500 SCM_DEFINE (scm_basename
, "basename", 1, 1, 0,
1501 (SCM filename
, SCM suffix
),
1502 "Return the base name of the file name @var{filename}. The\n"
1503 "base name is the file name without any directory components.\n"
1504 "If @var{suffix} is provided, and is equal to the end of\n"
1505 "@var{basename}, it is removed also.")
1506 #define FUNC_NAME s_scm_basename
1511 SCM_VALIDATE_STRING (1, filename
);
1512 f
= SCM_STRING_CHARS (filename
);
1513 len
= SCM_STRING_LENGTH (filename
);
1515 if (SCM_UNBNDP (suffix
))
1519 SCM_VALIDATE_STRING (2, suffix
);
1520 s
= SCM_STRING_CHARS (suffix
);
1521 j
= SCM_STRING_LENGTH (suffix
) - 1;
1525 while (i
>= 0 && (f
[i
] == '/' || f
[i
] == '\\')) --i
;
1527 while (i
>= 0 && f
[i
] == '/') --i
;
1528 #endif /* ndef __MINGW32__ */
1530 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1534 while (i
>= 0 && f
[i
] != '/' && f
[i
] != '\\') --i
;
1536 while (i
>= 0 && f
[i
] != '/') --i
;
1537 #endif /* ndef __MINGW32__ */
1541 if (len
> 0 && (f
[0] == '/' || f
[0] == '\\'))
1543 if (len
> 0 && f
[0] == '/')
1544 #endif /* ndef __MINGW32__ */
1545 return scm_substring (filename
, SCM_INUM0
, scm_from_int (1));
1547 return scm_dot_string
;
1550 return scm_substring (filename
, scm_from_int (i
+1), scm_from_int (end
+1));
1561 scm_tc16_dir
= scm_make_smob_type ("directory", 0);
1562 scm_set_smob_free (scm_tc16_dir
, scm_dir_free
);
1563 scm_set_smob_print (scm_tc16_dir
, scm_dir_print
);
1565 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1568 scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY
));
1571 scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY
));
1574 scm_c_define ("O_RDWR", scm_from_long (O_RDWR
));
1577 scm_c_define ("O_CREAT", scm_from_long (O_CREAT
));
1580 scm_c_define ("O_EXCL", scm_from_long (O_EXCL
));
1583 scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY
));
1586 scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC
));
1589 scm_c_define ("O_APPEND", scm_from_long (O_APPEND
));
1592 scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK
));
1595 scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY
));
1598 scm_c_define ("O_SYNC", scm_from_long (O_SYNC
));
1602 scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD
));
1605 scm_c_define ("F_GETFD", scm_from_long (F_GETFD
));
1608 scm_c_define ("F_SETFD", scm_from_long (F_SETFD
));
1611 scm_c_define ("F_GETFL", scm_from_long (F_GETFL
));
1614 scm_c_define ("F_SETFL", scm_from_long (F_SETFL
));
1617 scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN
));
1620 scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN
));
1623 scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC
));
1626 #include "libguile/filesys.x"