1 /* Copyright (C) 1996, 1997, 1998, 1999, 2000 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 */
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{object} to\n"
128 "the integer values @var{owner} and @var{group}. @var{object} can be\n"
129 "a string containing a file name or, if the platform\n"
130 "supports fchown, a port or integer file descriptor\n"
131 "which is open on the file. The return value\n"
132 "is unspecified.\n\n"
133 "If @var{object} 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
142 object
= SCM_COERCE_OUTPORT (object
);
144 SCM_VALIDATE_INUM (2,owner
);
145 SCM_VALIDATE_INUM (3,group
);
147 if (SCM_INUMP (object
) || (SCM_OPFPORTP (object
)))
149 int fdes
= SCM_INUMP (object
) ? SCM_INUM (object
)
150 : SCM_FPORT_FDES (object
);
152 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 ((int)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
797 scm_sizet size
= 100;
801 wd
= scm_must_malloc (size
, FUNC_NAME
);
802 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
806 wd
= scm_must_malloc (size
, FUNC_NAME
);
810 result
= scm_makfromstr (wd
, strlen (wd
), 0);
815 #endif /* HAVE_GETCWD */
821 /* check that element is a port or file descriptor. if it's a port
822 and its buffer is ready for use, add it to the ports_ready list.
823 otherwise add its file descriptor to *set. the type of list can be
824 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
825 SCM_ARG3 for excepts. */
827 set_element (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM element
, int pos
)
831 if (SCM_INUMP (element
))
833 fd
= SCM_INUM (element
);
839 element
= SCM_COERCE_OUTPORT (element
);
840 SCM_ASSERT (SCM_OPFPORTP (element
), element
, pos
, "select");
843 /* check whether port has buffered input. */
844 scm_port
*pt
= SCM_PTAB_ENTRY (element
);
846 if (pt
->read_pos
< pt
->read_end
)
849 else if (pos
== SCM_ARG2
)
851 /* check whether port's output buffer has room. */
852 scm_port
*pt
= SCM_PTAB_ENTRY (element
);
854 /* > 1 since writing the last byte in the buffer causes flush. */
855 if (pt
->write_end
- pt
->write_pos
> 1)
858 fd
= use_buf
? -1 : SCM_FPORT_FDES (element
);
861 *ports_ready
= scm_cons (element
, *ports_ready
);
867 /* check list_or_vec, a list or vector of ports or file descriptors,
868 adding each member to either the ports_ready list (if it's a port
869 with a usable buffer) or to *set. the kind of list_or_vec can be
870 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
871 SCM_ARG3 for excepts. */
873 fill_select_type (SELECT_TYPE
*set
, SCM
*ports_ready
, SCM list_or_vec
, int pos
)
877 if (SCM_VECTORP (list_or_vec
))
879 int i
= SCM_LENGTH (list_or_vec
);
880 SCM
*ve
= SCM_VELTS (list_or_vec
);
884 int fd
= set_element (set
, ports_ready
, ve
[i
], pos
);
892 while (list_or_vec
!= SCM_EOL
)
894 int fd
= set_element (set
, ports_ready
, SCM_CAR (list_or_vec
), pos
);
898 list_or_vec
= SCM_CDR (list_or_vec
);
905 /* if element (a file descriptor or port) appears in *set, cons it to
906 list. return list. */
908 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
912 if (SCM_INUMP (element
))
914 fd
= SCM_INUM (element
);
918 fd
= SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element
));
920 if (FD_ISSET (fd
, set
))
921 list
= scm_cons (element
, list
);
925 /* construct component of scm_select return value.
926 set: pointer to set of file descriptors found by select to be ready
927 ports_ready: ports ready due to buffering
928 list_or_vec: original list/vector handed to scm_select.
929 the return value is a list/vector of ready ports/file descriptors.
930 works by finding the objects in list which correspond to members of
931 *set and appending them to ports_ready. result is converted to a
932 vector if list_or_vec is a vector. */
934 retrieve_select_type (SELECT_TYPE
*set
, SCM ports_ready
, SCM list_or_vec
)
936 SCM answer_list
= ports_ready
;
938 if (SCM_VECTORP (list_or_vec
))
940 int i
= SCM_LENGTH (list_or_vec
);
941 SCM
*ve
= SCM_VELTS (list_or_vec
);
945 answer_list
= get_element (set
, ve
[i
], answer_list
);
947 return scm_vector (answer_list
);
951 /* list_or_vec must be a list. */
952 while (list_or_vec
!= SCM_EOL
)
954 answer_list
= get_element (set
, SCM_CAR (list_or_vec
), answer_list
);
955 list_or_vec
= SCM_CDR (list_or_vec
);
961 /* Static helper functions above refer to s_scm_select directly as s_select */
962 SCM_DEFINE (scm_select
, "select", 3, 2, 0,
963 (SCM reads
, SCM writes
, SCM excepts
, SCM secs
, SCM usecs
),
964 "This procedure has a variety of uses: waiting for the ability\n"
965 "to provide input, accept output, or the existance of\n"
966 "exceptional conditions on a collection of ports or file\n"
967 "descriptors, or waiting for a timeout to occur.\n"
968 "It also returns if interrupted by a signal.\n\n"
969 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
970 "vectors, with each member a port or a file descriptor.\n"
971 "The value returned is a list of three corresponding\n"
972 "lists or vectors containing only the members which meet the\n"
973 "specified requirement. The ability of port buffers to\n"
974 "provide input or accept output is taken into account.\n"
975 "Ordering of the input lists or vectors is not preserved.\n\n"
976 "The optional arguments @var{secs} and @var{usecs} specify the\n"
977 "timeout. Either @var{secs} can be specified alone, as\n"
978 "either an integer or a real number, or both @var{secs} and\n"
979 "@var{usecs} can be specified as integers, in which case\n"
980 "@var{usecs} is an additional timeout expressed in\n"
981 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
982 "select will wait for as long as it takes for one of the other\n"
983 "conditions to be satisfied.\n\n"
984 "The scsh version of @code{select} differs as follows:\n"
985 "Only vectors are accepted for the first three arguments.\n"
986 "The @var{usecs} argument is not supported.\n"
987 "Multiple values are returned instead of a list.\n"
988 "Duplicates in the input vectors appear only once in output.\n"
989 "An additional @code{select!} interface is provided.\n"
991 #define FUNC_NAME s_scm_select
993 struct timeval timeout
;
994 struct timeval
* time_ptr
;
995 SELECT_TYPE read_set
;
996 SELECT_TYPE write_set
;
997 SELECT_TYPE except_set
;
1001 /* these lists accumulate ports which are ready due to buffering.
1002 their file descriptors don't need to be added to the select sets. */
1003 SCM read_ports_ready
= SCM_EOL
;
1004 SCM write_ports_ready
= SCM_EOL
;
1007 if (SCM_VECTORP (reads
))
1009 read_count
= SCM_LENGTH (reads
);
1013 read_count
= scm_ilength (reads
);
1014 SCM_ASSERT (read_count
>= 0, reads
, SCM_ARG1
, FUNC_NAME
);
1016 if (SCM_VECTORP (writes
))
1018 write_count
= SCM_LENGTH (writes
);
1022 write_count
= scm_ilength (writes
);
1023 SCM_ASSERT (write_count
>= 0, writes
, SCM_ARG2
, FUNC_NAME
);
1025 if (SCM_VECTORP (excepts
))
1027 except_count
= SCM_LENGTH (excepts
);
1031 except_count
= scm_ilength (excepts
);
1032 SCM_ASSERT (except_count
>= 0, excepts
, SCM_ARG3
, FUNC_NAME
);
1035 FD_ZERO (&read_set
);
1036 FD_ZERO (&write_set
);
1037 FD_ZERO (&except_set
);
1039 max_fd
= fill_select_type (&read_set
, &read_ports_ready
, reads
, SCM_ARG1
);
1042 int write_max
= fill_select_type (&write_set
, &write_ports_ready
,
1044 int except_max
= fill_select_type (&except_set
, NULL
,
1047 if (write_max
> max_fd
)
1049 if (except_max
> max_fd
)
1050 max_fd
= except_max
;
1053 /* if there's a port with a ready buffer, don't block, just
1054 check for ready file descriptors. */
1055 if (read_ports_ready
!= SCM_EOL
|| write_ports_ready
!= SCM_EOL
)
1058 timeout
.tv_usec
= 0;
1059 time_ptr
= &timeout
;
1061 else if (SCM_UNBNDP (secs
) || SCM_FALSEP (secs
))
1065 if (SCM_INUMP (secs
))
1067 timeout
.tv_sec
= SCM_INUM (secs
);
1068 if (SCM_UNBNDP (usecs
))
1069 timeout
.tv_usec
= 0;
1072 SCM_VALIDATE_INUM (5,usecs
);
1073 timeout
.tv_usec
= SCM_INUM (usecs
);
1078 double fl
= scm_num2dbl (secs
, FUNC_NAME
);
1080 if (!SCM_UNBNDP (usecs
))
1081 SCM_WRONG_TYPE_ARG (4, secs
);
1083 SCM_OUT_OF_RANGE (4, secs
);
1084 timeout
.tv_sec
= (long) fl
;
1085 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
1087 time_ptr
= &timeout
;
1091 #ifdef GUILE_ISELECT
1092 int rv
= scm_internal_select (max_fd
+ 1,
1093 &read_set
, &write_set
, &except_set
,
1096 int rv
= select (max_fd
+ 1,
1097 &read_set
, &write_set
, &except_set
, time_ptr
);
1102 return scm_listify (retrieve_select_type (&read_set
, read_ports_ready
,
1104 retrieve_select_type (&write_set
, write_ports_ready
,
1106 retrieve_select_type (&except_set
, SCM_EOL
, excepts
),
1110 #endif /* HAVE_SELECT */
1114 SCM_DEFINE (scm_fcntl
, "fcntl", 2, 0, 1,
1115 (SCM object
, SCM cmd
, SCM value
),
1116 "Apply @var{command} to the specified file descriptor or the underlying\n"
1117 "file descriptor of the specified port. @var{value} is an optional\n"
1118 "integer argument.\n\n"
1119 "Values for @var{command} are:\n\n"
1122 "Duplicate a file descriptor\n"
1124 "Get flags associated with the file descriptor.\n"
1126 "Set flags associated with the file descriptor to @var{value}.\n"
1128 "Get flags associated with the open file.\n"
1130 "Set flags associated with the open file to @var{value}\n"
1132 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1134 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1135 "@item FD_CLOEXEC\n"
1136 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or"
1139 #define FUNC_NAME s_scm_fcntl
1145 object
= SCM_COERCE_OUTPORT (object
);
1147 SCM_VALIDATE_INUM (2,cmd
);
1148 if (SCM_OPFPORTP (object
))
1149 fdes
= SCM_FPORT_FDES (object
);
1152 SCM_VALIDATE_INUM (1,object
);
1153 fdes
= SCM_INUM (object
);
1155 if (SCM_NULLP (value
))
1159 SCM_ASSERT (SCM_INUMP (SCM_CAR (value
)), value
, SCM_ARG3
, FUNC_NAME
);
1160 ivalue
= SCM_INUM (SCM_CAR (value
));
1162 SCM_SYSCALL (rv
= fcntl (fdes
, SCM_INUM (cmd
), ivalue
));
1165 return SCM_MAKINUM (rv
);
1169 SCM_DEFINE (scm_fsync
, "fsync", 1, 0, 0,
1171 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1172 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1173 "file descriptor is fsync'd.\n"
1174 "The return value is unspecified.")
1175 #define FUNC_NAME s_scm_fsync
1179 object
= SCM_COERCE_OUTPORT (object
);
1181 if (SCM_OPFPORTP (object
))
1184 fdes
= SCM_FPORT_FDES (object
);
1188 SCM_VALIDATE_INUM (1,object
);
1189 fdes
= SCM_INUM (object
);
1191 if (fsync (fdes
) == -1)
1193 return SCM_UNSPECIFIED
;
1198 SCM_DEFINE (scm_symlink
, "symlink", 2, 0, 0,
1199 (SCM oldpath
, SCM newpath
),
1200 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1201 "@var{path-from}. The return value is unspecified.")
1202 #define FUNC_NAME s_scm_symlink
1206 SCM_VALIDATE_ROSTRING (1,oldpath
);
1207 SCM_VALIDATE_ROSTRING (2,newpath
);
1208 SCM_COERCE_SUBSTR (oldpath
);
1209 SCM_COERCE_SUBSTR (newpath
);
1210 SCM_SYSCALL (val
= symlink(SCM_ROCHARS(oldpath
), SCM_ROCHARS(newpath
)));
1213 return SCM_UNSPECIFIED
;
1216 #endif /* HAVE_SYMLINK */
1218 #ifdef HAVE_READLINK
1219 SCM_DEFINE (scm_readlink
, "readlink", 1, 0, 0,
1221 "Returns the value of the symbolic link named by\n"
1222 "@var{path} (a string), i.e., the\n"
1223 "file that the link points to.")
1224 #define FUNC_NAME s_scm_readlink
1230 SCM_VALIDATE_ROSTRING (1,path
);
1231 SCM_COERCE_SUBSTR (path
);
1232 buf
= scm_must_malloc (size
, FUNC_NAME
);
1233 while ((rv
= readlink (SCM_ROCHARS (path
), buf
, size
)) == size
)
1235 scm_must_free (buf
);
1237 buf
= scm_must_malloc (size
, FUNC_NAME
);
1241 result
= scm_makfromstr (buf
, rv
, 0);
1242 scm_must_free (buf
);
1246 #endif /* HAVE_READLINK */
1249 SCM_DEFINE (scm_lstat
, "lstat", 1, 0, 0,
1251 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1252 "it will return information about a symbolic link itself, not the \n"
1253 "file it points to. @var{path} must be a string.")
1254 #define FUNC_NAME s_scm_lstat
1257 struct stat stat_temp
;
1259 SCM_VALIDATE_ROSTRING (1,str
);
1260 SCM_COERCE_SUBSTR (str
);
1261 SCM_SYSCALL(rv
= lstat(SCM_ROCHARS(str
), &stat_temp
));
1266 SCM_SYSERROR_MSG ("~A: ~S",
1267 scm_listify (scm_makfrom0str (strerror (errno
)),
1269 SCM_UNDEFINED
), en
);
1271 return scm_stat2scm(&stat_temp
);
1274 #endif /* HAVE_LSTAT */
1276 SCM_DEFINE (scm_copy_file
, "copy-file", 2, 0, 0,
1277 (SCM oldfile
, SCM newfile
),
1278 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1279 "The return value is unspecified.")
1280 #define FUNC_NAME s_scm_copy_file
1285 struct stat oldstat
;
1287 SCM_VALIDATE_ROSTRING (1,oldfile
);
1288 if (SCM_SUBSTRP (oldfile
))
1289 oldfile
= scm_makfromstr (SCM_ROCHARS (oldfile
), SCM_ROLENGTH (oldfile
), 0);
1290 SCM_VALIDATE_ROSTRING (2,newfile
);
1291 if (SCM_SUBSTRP (newfile
))
1292 newfile
= scm_makfromstr (SCM_ROCHARS (newfile
), SCM_ROLENGTH (newfile
), 0);
1293 if (stat (SCM_ROCHARS (oldfile
), &oldstat
) == -1)
1295 oldfd
= open (SCM_ROCHARS (oldfile
), O_RDONLY
);
1299 /* use POSIX flags instead of 07777?. */
1300 newfd
= open (SCM_ROCHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1301 oldstat
.st_mode
& 07777);
1305 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1306 if (write (newfd
, buf
, n
) != n
)
1313 if (close (newfd
) == -1)
1315 return SCM_UNSPECIFIED
;
1320 /* Filename manipulation */
1324 SCM_DEFINE (scm_dirname
, "dirname", 1, 0, 0,
1327 #define FUNC_NAME s_scm_dirname
1331 SCM_VALIDATE_ROSTRING (1,filename
);
1332 s
= SCM_ROCHARS (filename
);
1333 len
= SCM_LENGTH (filename
);
1335 while (i
>= 0 && s
[i
] == '/') --i
;
1336 while (i
>= 0 && s
[i
] != '/') --i
;
1337 while (i
>= 0 && s
[i
] == '/') --i
;
1340 if (len
> 0 && s
[0] == '/')
1341 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1343 return scm_dot_string
;
1346 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (i
+ 1));
1350 SCM_DEFINE (scm_basename
, "basename", 1, 1, 0,
1351 (SCM filename
, SCM suffix
),
1353 #define FUNC_NAME s_scm_basename
1357 SCM_VALIDATE_ROSTRING (1,filename
);
1358 SCM_ASSERT (SCM_UNBNDP (suffix
)
1359 || (SCM_ROSTRINGP (suffix
)),
1363 f
= SCM_ROCHARS (filename
);
1364 if (SCM_UNBNDP (suffix
))
1368 s
= SCM_ROCHARS (suffix
);
1369 j
= SCM_LENGTH (suffix
) - 1;
1371 len
= SCM_LENGTH (filename
);
1373 while (i
>= 0 && f
[i
] == '/') --i
;
1375 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1378 while (i
>= 0 && f
[i
] != '/') --i
;
1381 if (len
> 0 && f
[0] == '/')
1382 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1384 return scm_dot_string
;
1387 return scm_make_shared_substring (filename
,
1388 SCM_MAKINUM (i
+ 1),
1389 SCM_MAKINUM (end
+ 1));
1400 scm_tc16_dir
= scm_make_smob_type_mfpe ("directory", 0,
1401 NULL
, scm_dir_free
,scm_dir_print
, NULL
);
1403 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1406 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY
));
1409 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY
));
1412 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR
));
1415 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT
));
1418 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL
));
1421 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY
));
1424 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC
));
1427 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND
));
1430 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK
));
1433 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY
));
1436 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC
));
1440 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD
));
1443 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD
));
1446 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD
));
1449 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL
));
1452 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL
));
1455 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN
));
1458 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN
));
1461 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC
));
1464 #include "filesys.x"