1 /* Copyright (C) 1996, 1997, 1998, 1999 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
54 #include "scm_validate.h"
62 #ifdef TIME_WITH_SYS_TIME
63 # include <sys/time.h>
67 # include <sys/time.h>
77 #ifdef LIBC_H_WITH_UNISTD_H
81 #ifdef HAVE_SYS_SELECT_H
82 #include <sys/select.h>
89 #include <sys/types.h>
98 # define NAMLEN(dirent) strlen((dirent)->d_name)
100 # define dirent direct
101 # define NAMLEN(dirent) (dirent)->d_namlen
103 # include <sys/ndir.h>
106 # include <sys/dir.h>
113 /* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
114 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
115 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
125 SCM_DEFINE (scm_chown
, "chown", 3, 0, 0,
126 (SCM object
, SCM owner
, SCM group
),
127 "Change the ownership and group of the file referred to by @var{obj} to\n"
128 "the integer userid values @var{owner} and @var{group}. @var{obj} can be\n"
129 "a string containing a file name or a port or integer file descriptor\n"
130 "which is open on the file (in which case fchown is used as the underlying\n"
131 "system call). The return value\n"
132 "is unspecified.\n\n"
133 "If @var{obj} is a symbolic link, either the\n"
134 "ownership of the link or the ownership of the referenced file will be\n"
135 "changed depending on the operating system (lchown is\n"
136 "unsupported at present). If @var{owner} or @var{group} is specified\n"
137 "as @code{-1}, then that ID is not changed.")
138 #define FUNC_NAME s_scm_chown
143 object
= SCM_COERCE_OUTPORT (object
);
145 SCM_VALIDATE_INUM (2,owner
);
146 SCM_VALIDATE_INUM (3,group
);
147 if (SCM_INUMP (object
) || (SCM_OPFPORTP (object
)))
149 if (SCM_INUMP (object
))
150 fdes
= SCM_INUM (object
);
152 fdes
= SCM_FPORT_FDES (object
);
153 SCM_SYSCALL (rv
= fchown (fdes
, SCM_INUM (owner
), SCM_INUM (group
)));
157 SCM_VALIDATE_ROSTRING(1,object
);
158 SCM_COERCE_SUBSTR (object
);
159 SCM_SYSCALL (rv
= chown (SCM_ROCHARS (object
),
160 SCM_INUM (owner
), SCM_INUM (group
)));
164 return SCM_UNSPECIFIED
;
169 SCM_DEFINE (scm_chmod
, "chmod", 2, 0, 0,
170 (SCM object
, SCM mode
),
171 "Changes the permissions of the file referred to by @var{obj}.\n"
172 "@var{obj} can be a string containing a file name or a port or integer file\n"
173 "descriptor which is open on a file (in which case @code{fchmod} is used\n"
174 "as the underlying system call).\n"
175 "@var{mode} specifies\n"
176 "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
177 "The return value is unspecified.")
178 #define FUNC_NAME s_scm_chmod
183 object
= SCM_COERCE_OUTPORT (object
);
185 SCM_VALIDATE_INUM (2,mode
);
186 if (SCM_INUMP (object
) || SCM_OPFPORTP (object
))
188 if (SCM_INUMP (object
))
189 fdes
= SCM_INUM (object
);
191 fdes
= SCM_FPORT_FDES (object
);
192 SCM_SYSCALL (rv
= fchmod (fdes
, SCM_INUM (mode
)));
196 SCM_VALIDATE_ROSTRING (1,object
);
197 SCM_COERCE_SUBSTR (object
);
198 SCM_SYSCALL (rv
= chmod (SCM_ROCHARS (object
), SCM_INUM (mode
)));
202 return SCM_UNSPECIFIED
;
206 SCM_DEFINE (scm_umask
, "umask", 0, 1, 0,
208 "If @var{mode} is omitted, retuns a decimal number representing the current\n"
209 "file creation mask. Otherwise the file creation mask is set to\n"
210 "@var{mode} and the previous value is returned.\n\n"
211 "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
212 #define FUNC_NAME s_scm_umask
215 if (SCM_UNBNDP (mode
))
222 SCM_VALIDATE_INUM (1,mode
);
223 mask
= umask (SCM_INUM (mode
));
225 return SCM_MAKINUM (mask
);
231 SCM_DEFINE (scm_open_fdes
, "open-fdes", 2, 1, 0,
232 (SCM path
, SCM flags
, SCM mode
),
233 "Similar to @code{open} but returns a file descriptor instead of a\n"
235 #define FUNC_NAME s_scm_open_fdes
241 SCM_VALIDATE_ROSTRING (1,path
);
242 SCM_COERCE_SUBSTR (path
);
243 iflags
= SCM_NUM2LONG(2,flags
);
244 imode
= SCM_NUM2LONG_DEF(3,mode
,0666);
245 SCM_SYSCALL (fd
= open (SCM_ROCHARS (path
), iflags
, imode
));
248 return SCM_MAKINUM (fd
);
252 SCM_DEFINE (scm_open
, "open", 2, 1, 0,
253 (SCM path
, SCM flags
, SCM mode
),
254 "Open the file named by @var{path} for reading and/or writing.\n"
255 "@var{flags} is an integer specifying how the file should be opened.\n"
256 "@var{mode} is an integer specifying the permission bits of the file, if\n"
257 "it needs to be created, before the umask is applied. The default is 666\n"
258 "(Unix itself has no default).\n\n"
259 "@var{flags} can be constructed by combining variables using @code{logior}.\n"
260 "Basic flags are:\n\n"
262 "Open the file read-only.\n"
265 "Open the file write-only. \n"
268 "Open the file read/write.\n"
271 "Append to the file instead of truncating.\n"
274 "Create the file if it does not already exist.\n"
276 "See the Unix documentation of the @code{open} system call\n"
277 "for additional flags.")
278 #define FUNC_NAME s_scm_open
285 fd
= SCM_INUM (scm_open_fdes (path
, flags
, mode
));
286 iflags
= SCM_NUM2LONG (2,flags
);
289 if (iflags
& O_APPEND
)
291 else if (iflags
& O_CREAT
)
297 if (iflags
& O_APPEND
)
299 else if (iflags
& O_WRONLY
)
304 newpt
= scm_fdes_to_port (fd
, port_mode
, path
);
309 SCM_DEFINE (scm_close
, "close", 1, 0, 0,
311 "Similar to close-port (@pxref{Generic Port Operations, close-port}),\n"
312 "but also works on file descriptors. A side\n"
313 "effect of closing a file descriptor is that any ports using that file\n"
314 "descriptor are moved to a different file descriptor and have\n"
315 "their revealed counts set to zero.")
316 #define FUNC_NAME s_scm_close
321 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
323 if (SCM_PORTP (fd_or_port
))
324 return scm_close_port (fd_or_port
);
325 SCM_VALIDATE_INUM (1,fd_or_port
);
326 fd
= SCM_INUM (fd_or_port
);
327 scm_evict_ports (fd
); /* see scsh manual. */
328 SCM_SYSCALL (rv
= close (fd
));
329 /* following scsh, closing an already closed file descriptor is
331 if (rv
< 0 && errno
!= EBADF
)
333 return SCM_NEGATE_BOOL(rv
< 0);
341 SCM_SYMBOL (scm_sym_regular
, "regular");
342 SCM_SYMBOL (scm_sym_directory
, "directory");
344 SCM_SYMBOL (scm_sym_symlink
, "symlink");
346 SCM_SYMBOL (scm_sym_block_special
, "block-special");
347 SCM_SYMBOL (scm_sym_char_special
, "char-special");
348 SCM_SYMBOL (scm_sym_fifo
, "fifo");
349 SCM_SYMBOL (scm_sym_sock
, "socket");
350 SCM_SYMBOL (scm_sym_unknown
, "unknown");
353 scm_stat2scm (struct stat
*stat_temp
)
355 SCM ans
= scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED
);
356 SCM
*ve
= SCM_VELTS (ans
);
358 ve
[0] = scm_ulong2num ((unsigned long) stat_temp
->st_dev
);
359 ve
[1] = scm_ulong2num ((unsigned long) stat_temp
->st_ino
);
360 ve
[2] = scm_ulong2num ((unsigned long) stat_temp
->st_mode
);
361 ve
[3] = scm_ulong2num ((unsigned long) stat_temp
->st_nlink
);
362 ve
[4] = scm_ulong2num ((unsigned long) stat_temp
->st_uid
);
363 ve
[5] = scm_ulong2num ((unsigned long) stat_temp
->st_gid
);
365 ve
[6] = scm_ulong2num ((unsigned long) stat_temp
->st_rdev
);
369 ve
[7] = scm_ulong2num ((unsigned long) stat_temp
->st_size
);
370 ve
[8] = scm_ulong2num ((unsigned long) stat_temp
->st_atime
);
371 ve
[9] = scm_ulong2num ((unsigned long) stat_temp
->st_mtime
);
372 ve
[10] = scm_ulong2num ((unsigned long) stat_temp
->st_ctime
);
373 #ifdef HAVE_ST_BLKSIZE
374 ve
[11] = scm_ulong2num ((unsigned long) stat_temp
->st_blksize
);
376 ve
[11] = scm_ulong2num (4096L);
378 #ifdef HAVE_ST_BLOCKS
379 ve
[12] = scm_ulong2num ((unsigned long) stat_temp
->st_blocks
);
384 int mode
= stat_temp
->st_mode
;
387 ve
[13] = scm_sym_regular
;
388 else if (S_ISDIR (mode
))
389 ve
[13] = scm_sym_directory
;
391 else if (S_ISLNK (mode
))
392 ve
[13] = scm_sym_symlink
;
394 else if (S_ISBLK (mode
))
395 ve
[13] = scm_sym_block_special
;
396 else if (S_ISCHR (mode
))
397 ve
[13] = scm_sym_char_special
;
398 else if (S_ISFIFO (mode
))
399 ve
[13] = scm_sym_fifo
;
400 else if (S_ISSOCK (mode
))
401 ve
[13] = scm_sym_sock
;
403 ve
[13] = scm_sym_unknown
;
405 ve
[14] = SCM_MAKINUM ((~S_IFMT
) & mode
);
407 /* the layout of the bits in ve[14] is intended to be portable.
408 If there are systems that don't follow the usual convention,
409 the following could be used:
412 if (S_ISUID & mode) tmp += 1;
414 if (S_IRGRP & mode) tmp += 1;
416 if (S_ISVTX & mode) tmp += 1;
418 if (S_IRUSR & mode) tmp += 1;
420 if (S_IWUSR & mode) tmp += 1;
422 if (S_IXUSR & mode) tmp += 1;
424 if (S_IWGRP & mode) tmp += 1;
426 if (S_IXGRP & mode) tmp += 1;
428 if (S_IROTH & mode) tmp += 1;
430 if (S_IWOTH & mode) tmp += 1;
432 if (S_IXOTH & mode) tmp += 1;
434 ve[14] = SCM_MAKINUM (tmp);
442 SCM_DEFINE (scm_stat
, "stat", 1, 0, 0,
444 "Returns an object containing various information\n"
445 "about the file determined by @var{obj}.\n"
446 "@var{obj} can be a string containing a file name or a port or integer file\n"
447 "descriptor which is open on a file (in which case @code{fstat} is used\n"
448 "as the underlying system call).\n\n"
449 "The object returned by @code{stat} can be passed as a single parameter\n"
450 "to the following procedures, all of which return integers:\n\n"
453 "The device containing the file.\n"
455 "The file serial number, which distinguishes this file from all other\n"
456 "files on the same device.\n"
458 "The mode of the file. This includes file type information\n"
459 "and the file permission bits. See @code{stat:type} and @code{stat:perms}\n"
462 "The number of hard links to the file.\n"
464 "The user ID of the file's owner.\n"
466 "The group ID of the file.\n"
468 "Device ID; this entry is defined only for character or block\n"
471 "The size of a regular file in bytes.\n"
473 "The last access time for the file.\n"
475 "The last modification time for the file.\n"
477 "The last modification time for the attributes of the file.\n"
478 "@item stat:blksize\n"
479 "The optimal block size for reading or writing the file, in bytes.\n"
480 "@item stat:blocks\n"
481 "The amount of disk space that the file occupies measured in units of\n"
484 "In addition, the following procedures return the information\n"
485 "from stat:mode in a more convenient form:\n\n"
488 "A symbol representing the type of file. Possible values are\n"
489 "regular, directory, symlink, block-special, char-special,\n"
490 "fifo, socket and unknown\n"
492 "An integer representing the access permission bits.\n"
494 #define FUNC_NAME s_scm_stat
498 struct stat stat_temp
;
500 if (SCM_INUMP (object
))
501 SCM_SYSCALL (rv
= fstat (SCM_INUM (object
), &stat_temp
));
504 SCM_VALIDATE_NIM (1,object
);
505 if (SCM_ROSTRINGP (object
))
507 SCM_COERCE_SUBSTR (object
);
508 SCM_SYSCALL (rv
= stat (SCM_ROCHARS (object
), &stat_temp
));
512 object
= SCM_COERCE_OUTPORT (object
);
513 SCM_VALIDATE_OPFPORT(1,object
);
514 fdes
= SCM_FPORT_FDES (object
);
515 SCM_SYSCALL (rv
= fstat (fdes
, &stat_temp
));
522 SCM_SYSERROR_MSG ("~A: ~S",
523 scm_listify (scm_makfrom0str (strerror (errno
)),
527 return scm_stat2scm (&stat_temp
);
532 /* {Modifying Directories}
535 SCM_DEFINE (scm_link
, "link", 2, 0, 0,
536 (SCM oldpath
, SCM newpath
),
537 "Creates a new name @var{path-to} in the file system for the file\n"
538 "named by @var{path-from}. If @var{path-from} is a symbolic link, the\n"
539 "link may or may not be followed depending on the system.")
540 #define FUNC_NAME s_scm_link
544 SCM_VALIDATE_ROSTRING (1,oldpath
);
545 if (SCM_SUBSTRP (oldpath
))
546 oldpath
= scm_makfromstr (SCM_ROCHARS (oldpath
),
547 SCM_ROLENGTH (oldpath
), 0);
548 SCM_VALIDATE_ROSTRING (2,newpath
);
549 if (SCM_SUBSTRP (newpath
))
550 newpath
= scm_makfromstr (SCM_ROCHARS (newpath
),
551 SCM_ROLENGTH (newpath
), 0);
552 SCM_SYSCALL (val
= link (SCM_ROCHARS (oldpath
), SCM_ROCHARS (newpath
)));
555 return SCM_UNSPECIFIED
;
561 SCM_DEFINE (scm_rename
, "rename-file", 2, 0, 0,
562 (SCM oldname
, SCM newname
),
563 "Renames the file specified by @var{path-from} to @var{path-to}.\n"
564 "The return value is unspecified.")
565 #define FUNC_NAME s_scm_rename
568 SCM_VALIDATE_ROSTRING (1,oldname
);
569 SCM_VALIDATE_ROSTRING (2,newname
);
570 SCM_COERCE_SUBSTR (oldname
);
571 SCM_COERCE_SUBSTR (newname
);
573 SCM_SYSCALL (rv
= rename (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
575 SCM_SYSCALL (rv
= link (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
578 SCM_SYSCALL (rv
= unlink (SCM_ROCHARS (oldname
)));;
580 /* unlink failed. remove new name */
581 SCM_SYSCALL (unlink (SCM_ROCHARS (newname
)));
586 return SCM_UNSPECIFIED
;
591 SCM_DEFINE (scm_delete_file
, "delete-file", 1, 0, 0,
593 "Deletes (or \"unlinks\") the file specified by @var{path}.")
594 #define FUNC_NAME s_scm_delete_file
597 SCM_VALIDATE_ROSTRING (1,str
);
598 SCM_COERCE_SUBSTR (str
);
599 SCM_SYSCALL (ans
= unlink (SCM_ROCHARS (str
)));
602 return SCM_UNSPECIFIED
;
607 SCM_DEFINE (scm_mkdir
, "mkdir", 1, 1, 0,
608 (SCM path
, SCM mode
),
609 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
610 "then the permissions of the directory file are set using the current\n"
611 "umask. Otherwise they are set to the decimal value specified with\n"
612 "@var{mode}. The return value is unspecified.")
613 #define FUNC_NAME s_scm_mkdir
617 SCM_VALIDATE_ROSTRING (1,path
);
618 SCM_COERCE_SUBSTR (path
);
619 if (SCM_UNBNDP (mode
))
623 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), 0777 ^ mask
));
627 SCM_VALIDATE_INUM (2,mode
);
628 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), SCM_INUM (mode
)));
632 return SCM_UNSPECIFIED
;
635 #endif /* HAVE_MKDIR */
638 SCM_DEFINE (scm_rmdir
, "rmdir", 1, 0, 0,
640 "Remove the existing directory named by @var{path}. The directory must\n"
641 "be empty for this to succeed. The return value is unspecified.")
642 #define FUNC_NAME s_scm_rmdir
646 SCM_VALIDATE_ROSTRING (1,path
);
647 SCM_COERCE_SUBSTR (path
);
648 SCM_SYSCALL (val
= rmdir (SCM_ROCHARS (path
)));
651 return SCM_UNSPECIFIED
;
657 /* {Examining Directories}
662 SCM_DEFINE (scm_directory_stream_p
, "directory-stream?", 1, 0, 0,
664 "Returns a boolean indicating whether @var{object} is a directory stream\n"
665 "as returned by @code{opendir}.")
666 #define FUNC_NAME s_scm_directory_stream_p
668 return SCM_BOOL(SCM_DIRP (obj
));
672 SCM_DEFINE (scm_opendir
, "opendir", 1, 0, 0,
674 "Open the directory specified by @var{path} and return a directory\n"
676 #define FUNC_NAME s_scm_opendir
679 SCM_VALIDATE_ROSTRING (1,dirname
);
680 SCM_COERCE_SUBSTR (dirname
);
681 SCM_SYSCALL (ds
= opendir (SCM_ROCHARS (dirname
)));
684 SCM_RETURN_NEWSMOB (scm_tc16_dir
| SCM_OPN
, ds
);
689 SCM_DEFINE (scm_readdir
, "readdir", 1, 0, 0,
691 "Return (as a string) the next directory entry from the directory stream\n"
692 "@var{stream}. If there is no remaining entry to be read then the\n"
693 "end of file object is returned.")
694 #define FUNC_NAME s_scm_readdir
696 struct dirent
*rdent
;
697 SCM_VALIDATE_OPDIR (1,port
);
699 SCM_SYSCALL (rdent
= readdir ((DIR *) SCM_CDR (port
)));
702 return (rdent
? scm_makfromstr (rdent
->d_name
, NAMLEN (rdent
), 0)
709 SCM_DEFINE (scm_rewinddir
, "rewinddir", 1, 0, 0,
711 "Reset the directory port @var{stream} so that the next call to\n"
712 "@code{readdir} will return the first directory entry.")
713 #define FUNC_NAME s_scm_rewinddir
715 SCM_VALIDATE_OPDIR (1,port
);
716 rewinddir ((DIR *) SCM_CDR (port
));
717 return SCM_UNSPECIFIED
;
723 SCM_DEFINE (scm_closedir
, "closedir", 1, 0, 0,
725 "Close the directory stream @var{stream}.\n"
726 "The return value is unspecified.")
727 #define FUNC_NAME s_scm_closedir
731 SCM_VALIDATE_DIR (1,port
);
732 if (SCM_CLOSEDP (port
))
734 return SCM_UNSPECIFIED
;
736 SCM_SYSCALL (sts
= closedir ((DIR *) SCM_CDR (port
)));
739 SCM_SETCAR (port
, scm_tc16_dir
);
740 return SCM_UNSPECIFIED
;
748 scm_dir_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
750 scm_puts ("#<", port
);
751 if (SCM_CLOSEDP (exp
))
752 scm_puts ("closed: ", port
);
753 scm_puts ("directory stream ", port
);
754 scm_intprint (SCM_CDR (exp
), 16, port
);
755 scm_putc ('>', port
);
764 closedir ((DIR *) SCM_CDR (p
));
769 /* {Navigating Directories}
773 SCM_DEFINE (scm_chdir
, "chdir", 1, 0, 0,
775 "Change the current working directory to @var{path}.\n"
776 "The return value is unspecified.")
777 #define FUNC_NAME s_scm_chdir
781 SCM_VALIDATE_ROSTRING (1,str
);
782 SCM_COERCE_SUBSTR (str
);
783 SCM_SYSCALL (ans
= chdir (SCM_ROCHARS (str
)));
786 return SCM_UNSPECIFIED
;
791 SCM_DEFINE (scm_getcwd
, "getcwd", 0, 0, 0,
793 "Returns the name of the current working directory.")
794 #define FUNC_NAME s_scm_getcwd
798 scm_sizet size
= 100;
802 wd
= scm_must_malloc (size
, FUNC_NAME
);
803 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
807 wd
= scm_must_malloc (size
, FUNC_NAME
);
811 result
= scm_makfromstr (wd
, strlen (wd
), 0);
816 #endif /* HAVE_GETCWD */
821 set_element (SELECT_TYPE
*set
, SCM element
, int arg
)
824 element
= SCM_COERCE_OUTPORT (element
);
825 if (SCM_OPFPORTP (element
))
826 fd
= SCM_FPORT_FDES (element
);
828 SCM_ASSERT (SCM_INUMP (element
), element
, arg
, "select");
829 fd
= SCM_INUM (element
);
836 fill_select_type (SELECT_TYPE
*set
, SCM list
, int arg
)
839 if (SCM_VECTORP (list
))
841 int len
= SCM_LENGTH (list
);
842 SCM
*ve
= SCM_VELTS (list
);
846 fd
= set_element (set
, ve
[len
- 1], arg
);
854 while (list
!= SCM_EOL
)
856 fd
= set_element (set
, SCM_CAR (list
), arg
);
859 list
= SCM_CDR (list
);
867 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
869 element
= SCM_COERCE_OUTPORT (element
);
870 if (SCM_OPFPORTP (element
))
872 if (FD_ISSET (SCM_FPORT_FDES (element
), set
))
873 list
= scm_cons (element
, list
);
875 else if (SCM_INUMP (element
))
877 if (FD_ISSET (SCM_INUM (element
), set
))
878 list
= scm_cons (element
, list
);
884 retrieve_select_type (SELECT_TYPE
*set
, SCM list
)
886 SCM answer_list
= SCM_EOL
;
888 if (SCM_VECTORP (list
))
890 int len
= SCM_LENGTH (list
);
891 SCM
*ve
= SCM_VELTS (list
);
895 answer_list
= get_element (set
, ve
[len
- 1], answer_list
);
898 return scm_vector (answer_list
);
902 /* list is a list. */
903 while (list
!= SCM_EOL
)
905 answer_list
= get_element (set
, SCM_CAR (list
), answer_list
);
906 list
= SCM_CDR (list
);
913 /* Static helper functions above refer to s_scm_select directly as s_select */
914 SCM_DEFINE (scm_select
, "select", 3, 2, 0,
915 (SCM reads
, SCM writes
, SCM excepts
, SCM secs
, SCM usecs
),
916 "@var{reads}, @var{writes} and @var{excepts} can be lists or vectors: it\n"
917 "doesn't matter which, but the corresponding object returned will be\n"
918 "of the same type.\n"
919 "Each element is a port or file descriptor on which to wait for\n"
920 "readability, writeability\n"
921 "or exceptional conditions respectively. @var{secs} and @var{usecs}\n"
922 "optionally specify a timeout: @var{secs} can be specified alone, as\n"
923 "either an integer or a real number, or both @var{secs} and @var{usecs}\n"
924 "can be specified as integers, in which case @var{usecs} is an additional\n"
925 "timeout expressed in microseconds.\n\n"
926 "Buffered input or output data is (currently, but this may change)\n"
927 "ignored: select uses the underlying file descriptor of a port\n"
928 "(@code{char-ready?} will check input buffers, output buffers are\n"
930 "The return value is a list of subsets of the input lists or vectors for\n"
931 "which the requested condition has been met.\n\n"
932 "It is not quite compatible with scsh's select: scsh checks port buffers,\n"
933 "doesn't accept input lists or a microsecond timeout, returns multiple\n"
934 "values instead of a list and has an additional select! interface.\n"
936 #define FUNC_NAME s_scm_select
938 struct timeval timeout
;
939 struct timeval
* time_p
;
940 SELECT_TYPE read_set
;
941 SELECT_TYPE write_set
;
942 SELECT_TYPE except_set
;
946 #define assert_set(x, arg) \
947 SCM_ASSERT (scm_ilength (x) >= 0 || (SCM_VECTORP (x)), \
949 assert_set (reads
, SCM_ARG1
);
950 assert_set (writes
, SCM_ARG2
);
951 assert_set (excepts
, SCM_ARG3
);
955 FD_ZERO (&write_set
);
956 FD_ZERO (&except_set
);
958 max_fd
= fill_select_type (&read_set
, reads
, SCM_ARG1
);
959 fd
= fill_select_type (&write_set
, writes
, SCM_ARG2
);
962 fd
= fill_select_type (&except_set
, excepts
, SCM_ARG3
);
966 if (SCM_UNBNDP (secs
) || SCM_FALSEP (secs
))
970 if (SCM_INUMP (secs
))
972 timeout
.tv_sec
= SCM_INUM (secs
);
973 if (SCM_UNBNDP (usecs
))
977 SCM_VALIDATE_INUM (5,usecs
);
978 timeout
.tv_usec
= SCM_INUM (usecs
);
983 double fl
= scm_num2dbl (secs
, FUNC_NAME
);
985 if (!SCM_UNBNDP (usecs
))
986 SCM_WRONG_TYPE_ARG (4, secs
);
988 SCM_OUT_OF_RANGE (4, secs
);
989 timeout
.tv_sec
= (long) fl
;
990 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
996 sreturn
= scm_internal_select (max_fd
+ 1,
997 &read_set
, &write_set
, &except_set
, time_p
);
999 sreturn
= select (max_fd
+ 1,
1000 &read_set
, &write_set
, &except_set
, time_p
);
1004 return scm_listify (retrieve_select_type (&read_set
, reads
),
1005 retrieve_select_type (&write_set
, writes
),
1006 retrieve_select_type (&except_set
, excepts
),
1010 #endif /* HAVE_SELECT */
1014 SCM_DEFINE (scm_fcntl
, "fcntl", 2, 0, 1,
1015 (SCM object
, SCM cmd
, SCM value
),
1016 "Apply @var{command} to the specified file descriptor or the underlying\n"
1017 "file descriptor of the specified port. @var{value} is an optional\n"
1018 "integer argument.\n\n"
1019 "Values for @var{command} are:\n\n"
1022 "Duplicate a file descriptor\n"
1024 "Get flags associated with the file descriptor.\n"
1026 "Set flags associated with the file descriptor to @var{value}.\n"
1028 "Get flags associated with the open file.\n"
1030 "Set flags associated with the open file to @var{value}\n"
1032 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1034 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1035 "@item FD_CLOEXEC\n"
1036 "The value used to indicate the "close on exec
" flag with @code{F_GETFL} or
1039 #define FUNC_NAME s_scm_fcntl
1045 object
= SCM_COERCE_OUTPORT (object
);
1047 SCM_VALIDATE_INUM (2,cmd
);
1048 if (SCM_OPFPORTP (object
))
1049 fdes
= SCM_FPORT_FDES (object
);
1052 SCM_VALIDATE_INUM (1,object
);
1053 fdes
= SCM_INUM (object
);
1055 if (SCM_NULLP (value
))
1059 SCM_ASSERT (SCM_INUMP (SCM_CAR (value
)), value
, SCM_ARG3
, FUNC_NAME
);
1060 ivalue
= SCM_INUM (SCM_CAR (value
));
1062 SCM_SYSCALL (rv
= fcntl (fdes
, SCM_INUM (cmd
), ivalue
));
1065 return SCM_MAKINUM (rv
);
1069 SCM_DEFINE (scm_fsync
, "fsync", 1, 0, 0,
1071 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1072 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1073 "file descriptor is fsync'd.\n"
1074 "The return value is unspecified.")
1075 #define FUNC_NAME s_scm_fsync
1079 object
= SCM_COERCE_OUTPORT (object
);
1081 if (SCM_OPFPORTP (object
))
1084 fdes
= SCM_FPORT_FDES (object
);
1088 SCM_VALIDATE_INUM (1,object
);
1089 fdes
= SCM_INUM (object
);
1091 if (fsync (fdes
) == -1)
1093 return SCM_UNSPECIFIED
;
1098 SCM_DEFINE (scm_symlink
, "symlink", 2, 0, 0,
1099 (SCM oldpath
, SCM newpath
),
1100 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1101 "@var{path-from}. The return value is unspecified.")
1102 #define FUNC_NAME s_scm_symlink
1106 SCM_VALIDATE_ROSTRING (1,oldpath
);
1107 SCM_VALIDATE_ROSTRING (2,newpath
);
1108 SCM_COERCE_SUBSTR (oldpath
);
1109 SCM_COERCE_SUBSTR (newpath
);
1110 SCM_SYSCALL (val
= symlink(SCM_ROCHARS(oldpath
), SCM_ROCHARS(newpath
)));
1113 return SCM_UNSPECIFIED
;
1116 #endif /* HAVE_SYMLINK */
1118 #ifdef HAVE_READLINK
1119 SCM_DEFINE (scm_readlink
, "readlink", 1, 0, 0,
1121 "Returns the value of the symbolic link named by\n"
1122 "@var{path} (a string), i.e., the\n"
1123 "file that the link points to.")
1124 #define FUNC_NAME s_scm_readlink
1130 SCM_VALIDATE_ROSTRING (1,path
);
1131 SCM_COERCE_SUBSTR (path
);
1132 buf
= scm_must_malloc (size
, FUNC_NAME
);
1133 while ((rv
= readlink (SCM_ROCHARS (path
), buf
, size
)) == size
)
1135 scm_must_free (buf
);
1137 buf
= scm_must_malloc (size
, FUNC_NAME
);
1141 result
= scm_makfromstr (buf
, rv
, 0);
1142 scm_must_free (buf
);
1146 #endif /* HAVE_READLINK */
1149 SCM_DEFINE (scm_lstat
, "lstat", 1, 0, 0,
1151 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1152 "it will return information about a symbolic link itself, not the \n"
1153 "file it points to. @var{path} must be a string.")
1154 #define FUNC_NAME s_scm_lstat
1157 struct stat stat_temp
;
1159 SCM_VALIDATE_ROSTRING (1,str
);
1160 SCM_COERCE_SUBSTR (str
);
1161 SCM_SYSCALL(rv
= lstat(SCM_ROCHARS(str
), &stat_temp
));
1166 SCM_SYSERROR_MSG ("~A: ~S",
1167 scm_listify (scm_makfrom0str (strerror (errno
)),
1169 SCM_UNDEFINED
), en
);
1171 return scm_stat2scm(&stat_temp
);
1174 #endif /* HAVE_LSTAT */
1176 SCM_DEFINE (scm_copy_file
, "copy-file", 2, 0, 0,
1177 (SCM oldfile
, SCM newfile
),
1178 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1179 "The return value is unspecified.")
1180 #define FUNC_NAME s_scm_copy_file
1185 struct stat oldstat
;
1187 SCM_VALIDATE_ROSTRING (1,oldfile
);
1188 if (SCM_SUBSTRP (oldfile
))
1189 oldfile
= scm_makfromstr (SCM_ROCHARS (oldfile
), SCM_ROLENGTH (oldfile
), 0);
1190 SCM_VALIDATE_ROSTRING (2,newfile
);
1191 if (SCM_SUBSTRP (newfile
))
1192 newfile
= scm_makfromstr (SCM_ROCHARS (newfile
), SCM_ROLENGTH (newfile
), 0);
1193 if (stat (SCM_ROCHARS (oldfile
), &oldstat
) == -1)
1195 oldfd
= open (SCM_ROCHARS (oldfile
), O_RDONLY
);
1199 /* use POSIX flags instead of 07777?. */
1200 newfd
= open (SCM_ROCHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1201 oldstat
.st_mode
& 07777);
1205 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1206 if (write (newfd
, buf
, n
) != n
)
1213 if (close (newfd
) == -1)
1215 return SCM_UNSPECIFIED
;
1220 /* Filename manipulation */
1224 SCM_DEFINE (scm_dirname
, "dirname", 1, 0, 0,
1227 #define FUNC_NAME s_scm_dirname
1231 SCM_VALIDATE_ROSTRING (1,filename
);
1232 s
= SCM_ROCHARS (filename
);
1233 len
= SCM_LENGTH (filename
);
1235 while (i
>= 0 && s
[i
] == '/') --i
;
1236 while (i
>= 0 && s
[i
] != '/') --i
;
1237 while (i
>= 0 && s
[i
] == '/') --i
;
1240 if (len
> 0 && s
[0] == '/')
1241 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1243 return scm_dot_string
;
1246 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (i
+ 1));
1250 SCM_DEFINE (scm_basename
, "basename", 1, 1, 0,
1251 (SCM filename
, SCM suffix
),
1253 #define FUNC_NAME s_scm_basename
1257 SCM_VALIDATE_ROSTRING (1,filename
);
1258 SCM_ASSERT (SCM_UNBNDP (suffix
)
1259 || (SCM_ROSTRINGP (suffix
)),
1263 f
= SCM_ROCHARS (filename
);
1264 if (SCM_UNBNDP (suffix
))
1268 s
= SCM_ROCHARS (suffix
);
1269 j
= SCM_LENGTH (suffix
) - 1;
1271 len
= SCM_LENGTH (filename
);
1273 while (i
>= 0 && f
[i
] == '/') --i
;
1275 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1278 while (i
>= 0 && f
[i
] != '/') --i
;
1281 if (len
> 0 && f
[0] == '/')
1282 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1284 return scm_dot_string
;
1287 return scm_make_shared_substring (filename
,
1288 SCM_MAKINUM (i
+ 1),
1289 SCM_MAKINUM (end
+ 1));
1300 scm_tc16_dir
= scm_make_smob_type_mfpe ("directory", 0,
1301 NULL
, scm_dir_free
,scm_dir_print
, NULL
);
1303 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1306 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY
));
1309 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY
));
1312 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR
));
1315 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT
));
1318 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL
));
1321 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY
));
1324 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC
));
1327 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND
));
1330 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK
));
1333 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY
));
1336 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC
));
1340 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD
));
1343 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD
));
1346 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD
));
1349 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL
));
1352 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL
));
1355 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN
));
1358 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN
));
1361 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC
));
1364 #include "filesys.x"