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. */
57 #ifdef TIME_WITH_SYS_TIME
58 # include <sys/time.h>
62 # include <sys/time.h>
72 #ifdef LIBC_H_WITH_UNISTD_H
76 #ifdef HAVE_SYS_SELECT_H
77 #include <sys/select.h>
84 #include <sys/types.h>
93 # define NAMLEN(dirent) strlen((dirent)->d_name)
95 # define dirent direct
96 # define NAMLEN(dirent) (dirent)->d_namlen
98 # include <sys/ndir.h>
101 # include <sys/dir.h>
108 /* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
109 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
110 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
120 SCM_PROC (s_chown
, "chown", 3, 0, 0, scm_chown
);
123 scm_chown (object
, owner
, group
)
131 object
= SCM_COERCE_OUTPORT (object
);
133 SCM_ASSERT (SCM_INUMP (owner
), owner
, SCM_ARG2
, s_chown
);
134 SCM_ASSERT (SCM_INUMP (group
), group
, SCM_ARG3
, s_chown
);
135 if (SCM_INUMP (object
) || (SCM_NIMP (object
) && SCM_OPFPORTP (object
)))
137 if (SCM_INUMP (object
))
138 fdes
= SCM_INUM (object
);
140 fdes
= SCM_FPORT_FDES (object
);
141 SCM_SYSCALL (rv
= fchown (fdes
, SCM_INUM (owner
), SCM_INUM (group
)));
145 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
146 object
, SCM_ARG1
, s_chown
);
147 SCM_COERCE_SUBSTR (object
);
148 SCM_SYSCALL (rv
= chown (SCM_ROCHARS (object
),
149 SCM_INUM (owner
), SCM_INUM (group
)));
152 scm_syserror (s_chown
);
153 return SCM_UNSPECIFIED
;
157 SCM_PROC (s_chmod
, "chmod", 2, 0, 0, scm_chmod
);
160 scm_chmod (object
, mode
)
167 object
= SCM_COERCE_OUTPORT (object
);
169 SCM_ASSERT (SCM_INUMP (mode
), mode
, SCM_ARG2
, s_chmod
);
170 if (SCM_INUMP (object
) || (SCM_NIMP (object
) && SCM_OPFPORTP (object
)))
172 if (SCM_INUMP (object
))
173 fdes
= SCM_INUM (object
);
175 fdes
= SCM_FPORT_FDES (object
);
176 SCM_SYSCALL (rv
= fchmod (fdes
, SCM_INUM (mode
)));
180 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
181 object
, SCM_ARG1
, s_chmod
);
182 SCM_COERCE_SUBSTR (object
);
183 SCM_SYSCALL (rv
= chmod (SCM_ROCHARS (object
), SCM_INUM (mode
)));
186 scm_syserror (s_chmod
);
187 return SCM_UNSPECIFIED
;
190 SCM_PROC (s_umask
, "umask", 0, 1, 0, scm_umask
);
197 if (SCM_UNBNDP (mode
))
204 SCM_ASSERT (SCM_INUMP (mode
), mode
, SCM_ARG1
, s_umask
);
205 mask
= umask (SCM_INUM (mode
));
207 return SCM_MAKINUM (mask
);
212 SCM_PROC (s_open_fdes
, "open-fdes", 2, 1, 0, scm_open_fdes
);
214 scm_open_fdes (SCM path
, SCM flags
, SCM mode
)
220 SCM_ASSERT (SCM_NIMP (path
) && SCM_ROSTRINGP (path
), path
, SCM_ARG1
,
222 SCM_COERCE_SUBSTR (path
);
223 iflags
= scm_num2long (flags
, (char *) SCM_ARG2
, s_open_fdes
);
225 if (SCM_UNBNDP (mode
))
229 SCM_ASSERT (SCM_INUMP (mode
), mode
, SCM_ARG3
, s_open_fdes
);
230 imode
= SCM_INUM (mode
);
232 SCM_SYSCALL (fd
= open (SCM_ROCHARS (path
), iflags
, imode
));
234 scm_syserror (s_open_fdes
);
235 return SCM_MAKINUM (fd
);
238 SCM_PROC (s_open
, "open", 2, 1, 0, scm_open
);
240 scm_open (SCM path
, SCM flags
, SCM mode
)
247 fd
= SCM_INUM (scm_open_fdes (path
, flags
, mode
));
248 iflags
= scm_num2long (flags
, (char *) SCM_ARG2
, s_open_fdes
);
251 if (iflags
& O_APPEND
)
253 else if (iflags
& O_CREAT
)
259 if (iflags
& O_APPEND
)
261 else if (iflags
& O_WRONLY
)
266 newpt
= scm_fdes_to_port (fd
, port_mode
, path
);
270 SCM_PROC (s_close
, "close", 1, 0, 0, scm_close
);
272 scm_close (SCM fd_or_port
)
277 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
279 if (SCM_NIMP (fd_or_port
) && SCM_PORTP (fd_or_port
))
280 return scm_close_port (fd_or_port
);
281 SCM_ASSERT (SCM_INUMP (fd_or_port
), fd_or_port
, SCM_ARG1
, s_close
);
282 fd
= SCM_INUM (fd_or_port
);
283 scm_evict_ports (fd
); /* see scsh manual. */
284 SCM_SYSCALL (rv
= close (fd
));
285 /* following scsh, closing an already closed file descriptor is
287 if (rv
< 0 && errno
!= EBADF
)
288 scm_syserror (s_close
);
289 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
296 SCM_SYMBOL (scm_sym_regular
, "regular");
297 SCM_SYMBOL (scm_sym_directory
, "directory");
299 SCM_SYMBOL (scm_sym_symlink
, "symlink");
301 SCM_SYMBOL (scm_sym_block_special
, "block-special");
302 SCM_SYMBOL (scm_sym_char_special
, "char-special");
303 SCM_SYMBOL (scm_sym_fifo
, "fifo");
304 SCM_SYMBOL (scm_sym_sock
, "socket");
305 SCM_SYMBOL (scm_sym_unknown
, "unknown");
307 static SCM scm_stat2scm
SCM_P ((struct stat
*stat_temp
));
310 scm_stat2scm (stat_temp
)
311 struct stat
*stat_temp
;
313 SCM ans
= scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED
);
314 SCM
*ve
= SCM_VELTS (ans
);
316 ve
[0] = scm_ulong2num ((unsigned long) stat_temp
->st_dev
);
317 ve
[1] = scm_ulong2num ((unsigned long) stat_temp
->st_ino
);
318 ve
[2] = scm_ulong2num ((unsigned long) stat_temp
->st_mode
);
319 ve
[3] = scm_ulong2num ((unsigned long) stat_temp
->st_nlink
);
320 ve
[4] = scm_ulong2num ((unsigned long) stat_temp
->st_uid
);
321 ve
[5] = scm_ulong2num ((unsigned long) stat_temp
->st_gid
);
323 ve
[6] = scm_ulong2num ((unsigned long) stat_temp
->st_rdev
);
327 ve
[7] = scm_ulong2num ((unsigned long) stat_temp
->st_size
);
328 ve
[8] = scm_ulong2num ((unsigned long) stat_temp
->st_atime
);
329 ve
[9] = scm_ulong2num ((unsigned long) stat_temp
->st_mtime
);
330 ve
[10] = scm_ulong2num ((unsigned long) stat_temp
->st_ctime
);
331 #ifdef HAVE_ST_BLKSIZE
332 ve
[11] = scm_ulong2num ((unsigned long) stat_temp
->st_blksize
);
334 ve
[11] = scm_ulong2num (4096L);
336 #ifdef HAVE_ST_BLOCKS
337 ve
[12] = scm_ulong2num ((unsigned long) stat_temp
->st_blocks
);
342 int mode
= stat_temp
->st_mode
;
345 ve
[13] = scm_sym_regular
;
346 else if (S_ISDIR (mode
))
347 ve
[13] = scm_sym_directory
;
349 else if (S_ISLNK (mode
))
350 ve
[13] = scm_sym_symlink
;
352 else if (S_ISBLK (mode
))
353 ve
[13] = scm_sym_block_special
;
354 else if (S_ISCHR (mode
))
355 ve
[13] = scm_sym_char_special
;
356 else if (S_ISFIFO (mode
))
357 ve
[13] = scm_sym_fifo
;
358 else if (S_ISSOCK (mode
))
359 ve
[13] = scm_sym_sock
;
361 ve
[13] = scm_sym_unknown
;
363 ve
[14] = SCM_MAKINUM ((~S_IFMT
) & mode
);
365 /* the layout of the bits in ve[14] is intended to be portable.
366 If there are systems that don't follow the usual convention,
367 the following could be used:
370 if (S_ISUID & mode) tmp += 1;
372 if (S_IRGRP & mode) tmp += 1;
374 if (S_ISVTX & mode) tmp += 1;
376 if (S_IRUSR & mode) tmp += 1;
378 if (S_IWUSR & mode) tmp += 1;
380 if (S_IXUSR & mode) tmp += 1;
382 if (S_IWGRP & mode) tmp += 1;
384 if (S_IXGRP & mode) tmp += 1;
386 if (S_IROTH & mode) tmp += 1;
388 if (S_IWOTH & mode) tmp += 1;
390 if (S_IXOTH & mode) tmp += 1;
392 ve[14] = SCM_MAKINUM (tmp);
400 SCM_PROC (s_stat
, "stat", 1, 0, 0, scm_stat
);
408 struct stat stat_temp
;
410 if (SCM_INUMP (object
))
411 SCM_SYSCALL (rv
= fstat (SCM_INUM (object
), &stat_temp
));
414 SCM_ASSERT (SCM_NIMP (object
), object
, SCM_ARG1
, s_stat
);
415 if (SCM_ROSTRINGP (object
))
417 SCM_COERCE_SUBSTR (object
);
418 SCM_SYSCALL (rv
= stat (SCM_ROCHARS (object
), &stat_temp
));
422 object
= SCM_COERCE_OUTPORT (object
);
423 SCM_ASSERT (SCM_OPFPORTP (object
), object
, SCM_ARG1
, s_stat
);
424 fdes
= SCM_FPORT_FDES (object
);
425 SCM_SYSCALL (rv
= fstat (fdes
, &stat_temp
));
432 scm_syserror_msg (s_stat
, "%s: %S",
433 scm_listify (scm_makfrom0str (strerror (errno
)),
438 return scm_stat2scm (&stat_temp
);
442 /* {Modifying Directories}
445 SCM_PROC (s_link
, "link", 2, 0, 0, scm_link
);
448 scm_link (oldpath
, newpath
)
454 SCM_ASSERT (SCM_NIMP (oldpath
) && SCM_ROSTRINGP (oldpath
), oldpath
,
456 if (SCM_SUBSTRP (oldpath
))
457 oldpath
= scm_makfromstr (SCM_ROCHARS (oldpath
),
458 SCM_ROLENGTH (oldpath
), 0);
459 SCM_ASSERT (SCM_NIMP (newpath
) && SCM_ROSTRINGP (newpath
), newpath
,
461 if (SCM_SUBSTRP (newpath
))
462 newpath
= scm_makfromstr (SCM_ROCHARS (newpath
),
463 SCM_ROLENGTH (newpath
), 0);
464 SCM_SYSCALL (val
= link (SCM_ROCHARS (oldpath
), SCM_ROCHARS (newpath
)));
466 scm_syserror (s_link
);
467 return SCM_UNSPECIFIED
;
472 SCM_PROC (s_rename
, "rename-file", 2, 0, 0, scm_rename
);
475 scm_rename (oldname
, newname
)
480 SCM_ASSERT (SCM_NIMP (oldname
) && SCM_ROSTRINGP (oldname
), oldname
, SCM_ARG1
,
482 SCM_ASSERT (SCM_NIMP (newname
) && SCM_ROSTRINGP (newname
), newname
, SCM_ARG2
,
484 SCM_COERCE_SUBSTR (oldname
);
485 SCM_COERCE_SUBSTR (newname
);
487 SCM_SYSCALL (rv
= rename (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
489 SCM_SYSCALL (rv
= link (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
492 SCM_SYSCALL (rv
= unlink (SCM_ROCHARS (oldname
)));;
494 /* unlink failed. remove new name */
495 SCM_SYSCALL (unlink (SCM_ROCHARS (newname
)));
499 scm_syserror (s_rename
);
500 return SCM_UNSPECIFIED
;
504 SCM_PROC(s_delete_file
, "delete-file", 1, 0, 0, scm_delete_file
);
507 scm_delete_file (str
)
511 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, SCM_ARG1
,
513 SCM_COERCE_SUBSTR (str
);
514 SCM_SYSCALL (ans
= unlink (SCM_ROCHARS (str
)));
516 scm_syserror (s_delete_file
);
517 return SCM_UNSPECIFIED
;
520 SCM_PROC (s_mkdir
, "mkdir", 1, 1, 0, scm_mkdir
);
523 scm_mkdir (path
, mode
)
530 SCM_ASSERT (SCM_NIMP (path
) && SCM_ROSTRINGP (path
), path
, SCM_ARG1
,
532 SCM_COERCE_SUBSTR (path
);
533 if (SCM_UNBNDP (mode
))
537 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), 0777 ^ mask
));
541 SCM_ASSERT (SCM_INUMP (mode
), mode
, SCM_ARG2
, s_mkdir
);
542 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), SCM_INUM (mode
)));
545 scm_syserror (s_mkdir
);
546 return SCM_UNSPECIFIED
;
548 scm_sysmissing (s_mkdir
);
555 SCM_PROC (s_rmdir
, "rmdir", 1, 0, 0, scm_rmdir
);
564 SCM_ASSERT (SCM_NIMP (path
) && SCM_ROSTRINGP (path
), path
, SCM_ARG1
,
566 SCM_COERCE_SUBSTR (path
);
567 SCM_SYSCALL (val
= rmdir (SCM_ROCHARS (path
)));
569 scm_syserror (s_rmdir
);
570 return SCM_UNSPECIFIED
;
572 scm_sysmissing (s_rmdir
);
579 /* {Examining Directories}
584 SCM_PROC (s_directory_stream_p
, "directory-stream?", 1, 0, 0, scm_directory_stream_p
);
586 scm_directory_stream_p (SCM obj
)
588 return SCM_NIMP (obj
) && SCM_DIRP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
591 SCM_PROC (s_opendir
, "opendir", 1, 0, 0, scm_opendir
);
594 scm_opendir (dirname
)
598 SCM_ASSERT (SCM_NIMP (dirname
) && SCM_ROSTRINGP (dirname
), dirname
, SCM_ARG1
,
600 SCM_COERCE_SUBSTR (dirname
);
601 SCM_SYSCALL (ds
= opendir (SCM_ROCHARS (dirname
)));
603 scm_syserror (s_opendir
);
604 SCM_RETURN_NEWSMOB (scm_tc16_dir
| SCM_OPN
, ds
);
608 SCM_PROC (s_readdir
, "readdir", 1, 0, 0, scm_readdir
);
614 struct dirent
*rdent
;
615 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPDIRP (port
), port
, SCM_ARG1
, s_readdir
);
617 SCM_SYSCALL (rdent
= readdir ((DIR *) SCM_CDR (port
)));
619 scm_syserror (s_readdir
);
620 return (rdent
? scm_makfromstr (rdent
->d_name
, NAMLEN (rdent
), 0)
626 SCM_PROC (s_rewinddir
, "rewinddir", 1, 0, 0, scm_rewinddir
);
632 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPDIRP (port
), port
, SCM_ARG1
, s_rewinddir
);
633 rewinddir ((DIR *) SCM_CDR (port
));
634 return SCM_UNSPECIFIED
;
639 SCM_PROC (s_closedir
, "closedir", 1, 0, 0, scm_closedir
);
647 SCM_ASSERT (SCM_NIMP (port
) && SCM_DIRP (port
), port
, SCM_ARG1
, s_closedir
);
648 if (SCM_CLOSEDP (port
))
650 return SCM_UNSPECIFIED
;
652 SCM_SYSCALL (sts
= closedir ((DIR *) SCM_CDR (port
)));
654 scm_syserror (s_closedir
);
655 SCM_SETCAR (port
, scm_tc16_dir
);
656 return SCM_UNSPECIFIED
;
662 static int scm_dir_print
SCM_P ((SCM sexp
, SCM port
, scm_print_state
*pstate
));
665 scm_dir_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
667 scm_puts ("#<", port
);
668 if (SCM_CLOSEDP (exp
))
669 scm_puts ("closed: ", port
);
670 scm_puts ("directory stream ", port
);
671 scm_intprint (SCM_CDR (exp
), 16, port
);
672 scm_putc ('>', port
);
677 static scm_sizet scm_dir_free
SCM_P ((SCM p
));
684 closedir ((DIR *) SCM_CDR (p
));
689 /* {Navigating Directories}
693 SCM_PROC (s_chdir
, "chdir", 1, 0, 0, scm_chdir
);
701 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, SCM_ARG1
, s_chdir
);
702 SCM_COERCE_SUBSTR (str
);
703 SCM_SYSCALL (ans
= chdir (SCM_ROCHARS (str
)));
705 scm_syserror (s_chdir
);
706 return SCM_UNSPECIFIED
;
711 SCM_PROC (s_getcwd
, "getcwd", 0, 0, 0, scm_getcwd
);
719 scm_sizet size
= 100;
723 wd
= scm_must_malloc (size
, s_getcwd
);
724 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
728 wd
= scm_must_malloc (size
, s_getcwd
);
731 scm_syserror (s_getcwd
);
732 result
= scm_makfromstr (wd
, strlen (wd
), 0);
736 scm_sysmissing (s_getcwd
);
744 SCM_PROC (s_select
, "select", 3, 2, 0, scm_select
);
748 set_element (SELECT_TYPE
*set
, SCM element
, int arg
)
751 element
= SCM_COERCE_OUTPORT (element
);
752 if (SCM_NIMP (element
) && SCM_OPFPORTP (element
))
753 fd
= SCM_FPORT_FDES (element
);
755 SCM_ASSERT (SCM_INUMP (element
), element
, arg
, s_select
);
756 fd
= SCM_INUM (element
);
763 fill_select_type (SELECT_TYPE
*set
, SCM list
, int arg
)
766 if (SCM_NIMP (list
) && SCM_VECTORP (list
))
768 int len
= SCM_LENGTH (list
);
769 SCM
*ve
= SCM_VELTS (list
);
773 fd
= set_element (set
, ve
[len
- 1], arg
);
781 while (list
!= SCM_EOL
)
783 fd
= set_element (set
, SCM_CAR (list
), arg
);
786 list
= SCM_CDR (list
);
794 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
796 element
= SCM_COERCE_OUTPORT (element
);
797 if (SCM_NIMP (element
) && SCM_OPFPORTP (element
))
799 if (FD_ISSET (SCM_FPORT_FDES (element
), set
))
800 list
= scm_cons (element
, list
);
802 else if (SCM_INUMP (element
))
804 if (FD_ISSET (SCM_INUM (element
), set
))
805 list
= scm_cons (element
, list
);
811 retrieve_select_type (SELECT_TYPE
*set
, SCM list
)
813 SCM answer_list
= SCM_EOL
;
815 if (SCM_NIMP (list
) && SCM_VECTORP (list
))
817 int len
= SCM_LENGTH (list
);
818 SCM
*ve
= SCM_VELTS (list
);
822 answer_list
= get_element (set
, ve
[len
- 1], answer_list
);
825 return scm_vector (answer_list
);
829 /* list is a list. */
830 while (list
!= SCM_EOL
)
832 answer_list
= get_element (set
, SCM_CAR (list
), answer_list
);
833 list
= SCM_CDR (list
);
841 scm_select (reads
, writes
, excepts
, secs
, usecs
)
849 struct timeval timeout
;
850 struct timeval
* time_p
;
851 SELECT_TYPE read_set
;
852 SELECT_TYPE write_set
;
853 SELECT_TYPE except_set
;
857 #define assert_set(x, arg) \
858 SCM_ASSERT (scm_ilength (x) > -1 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
860 assert_set (reads
, SCM_ARG1
);
861 assert_set (writes
, SCM_ARG2
);
862 assert_set (excepts
, SCM_ARG3
);
866 FD_ZERO (&write_set
);
867 FD_ZERO (&except_set
);
869 max_fd
= fill_select_type (&read_set
, reads
, SCM_ARG1
);
870 fd
= fill_select_type (&write_set
, writes
, SCM_ARG2
);
873 fd
= fill_select_type (&except_set
, excepts
, SCM_ARG3
);
877 if (SCM_UNBNDP (secs
) || SCM_FALSEP (secs
))
881 if (SCM_INUMP (secs
))
883 timeout
.tv_sec
= SCM_INUM (secs
);
884 if (SCM_UNBNDP (usecs
))
888 SCM_ASSERT (SCM_INUMP (usecs
), usecs
, SCM_ARG5
, s_select
);
890 timeout
.tv_usec
= SCM_INUM (usecs
);
895 double fl
= scm_num2dbl (secs
, s_select
);
897 if (!SCM_UNBNDP (usecs
))
898 scm_wrong_type_arg (s_select
, 4, secs
);
900 scm_out_of_range (s_select
, secs
);
901 timeout
.tv_sec
= (long) fl
;
902 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
908 sreturn
= scm_internal_select (max_fd
+ 1,
909 &read_set
, &write_set
, &except_set
, time_p
);
911 sreturn
= select (max_fd
+ 1,
912 &read_set
, &write_set
, &except_set
, time_p
);
915 scm_syserror (s_select
);
916 return scm_listify (retrieve_select_type (&read_set
, reads
),
917 retrieve_select_type (&write_set
, writes
),
918 retrieve_select_type (&except_set
, excepts
),
921 scm_sysmissing (s_select
);
929 SCM_PROC (s_fcntl
, "fcntl", 2, 0, 1, scm_fcntl
);
931 scm_fcntl (SCM object
, SCM cmd
, SCM value
)
937 object
= SCM_COERCE_OUTPORT (object
);
939 SCM_ASSERT (SCM_INUMP (cmd
), cmd
, SCM_ARG2
, s_fcntl
);
940 if (SCM_NIMP (object
) && SCM_OPFPORTP (object
))
941 fdes
= SCM_FPORT_FDES (object
);
944 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_fcntl
);
945 fdes
= SCM_INUM (object
);
947 if (SCM_NULLP (value
))
951 SCM_ASSERT (SCM_INUMP (SCM_CAR (value
)), value
, SCM_ARG3
, s_fcntl
);
952 ivalue
= SCM_INUM (SCM_CAR (value
));
954 SCM_SYSCALL (rv
= fcntl (fdes
, SCM_INUM (cmd
), ivalue
));
956 scm_syserror (s_fcntl
);
957 return SCM_MAKINUM (rv
);
960 SCM_PROC (s_fsync
, "fsync", 1, 0, 0, scm_fsync
);
962 scm_fsync (SCM object
)
966 object
= SCM_COERCE_OUTPORT (object
);
968 if (SCM_NIMP (object
) && SCM_OPFPORTP (object
))
971 fdes
= SCM_FPORT_FDES (object
);
975 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_fsync
);
976 fdes
= SCM_INUM (object
);
978 if (fsync (fdes
) == -1)
979 scm_syserror (s_fsync
);
980 return SCM_UNSPECIFIED
;
983 SCM_PROC (s_symlink
, "symlink", 2, 0, 0, scm_symlink
);
986 scm_symlink(oldpath
, newpath
)
993 SCM_ASSERT (SCM_NIMP (oldpath
) && SCM_ROSTRINGP (oldpath
), oldpath
, SCM_ARG1
,
995 SCM_ASSERT (SCM_NIMP (newpath
) && SCM_ROSTRINGP (newpath
), newpath
, SCM_ARG2
,
997 SCM_COERCE_SUBSTR (oldpath
);
998 SCM_COERCE_SUBSTR (newpath
);
999 SCM_SYSCALL (val
= symlink(SCM_ROCHARS(oldpath
), SCM_ROCHARS(newpath
)));
1001 scm_syserror (s_symlink
);
1002 return SCM_UNSPECIFIED
;
1004 scm_sysmissing (s_symlink
);
1011 SCM_PROC (s_readlink
, "readlink", 1, 0, 0, scm_readlink
);
1017 #ifdef HAVE_READLINK
1022 SCM_ASSERT (SCM_NIMP (path
) && SCM_ROSTRINGP (path
), path
, (char *) SCM_ARG1
,
1024 SCM_COERCE_SUBSTR (path
);
1025 buf
= scm_must_malloc (size
, s_readlink
);
1026 while ((rv
= readlink (SCM_ROCHARS (path
), buf
, size
)) == size
)
1028 scm_must_free (buf
);
1030 buf
= scm_must_malloc (size
, s_readlink
);
1033 scm_syserror (s_readlink
);
1034 result
= scm_makfromstr (buf
, rv
, 0);
1035 scm_must_free (buf
);
1038 scm_sysmissing (s_readlink
);
1045 SCM_PROC (s_lstat
, "lstat", 1, 0, 0, scm_lstat
);
1053 struct stat stat_temp
;
1055 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, (char *) SCM_ARG1
,
1057 SCM_COERCE_SUBSTR (str
);
1058 SCM_SYSCALL(rv
= lstat(SCM_ROCHARS(str
), &stat_temp
));
1063 scm_syserror_msg (s_lstat
, "%s: %S",
1064 scm_listify (scm_makfrom0str (strerror (errno
)),
1069 return scm_stat2scm(&stat_temp
);
1071 scm_sysmissing (s_lstat
);
1078 SCM_PROC (s_copy_file
, "copy-file", 2, 0, 0, scm_copy_file
);
1081 scm_copy_file (oldfile
, newfile
)
1088 struct stat oldstat
;
1090 SCM_ASSERT (SCM_NIMP (oldfile
) && SCM_ROSTRINGP (oldfile
), oldfile
, SCM_ARG1
, s_copy_file
);
1091 if (SCM_SUBSTRP (oldfile
))
1092 oldfile
= scm_makfromstr (SCM_ROCHARS (oldfile
), SCM_ROLENGTH (oldfile
), 0);
1093 SCM_ASSERT (SCM_NIMP (newfile
) && SCM_ROSTRINGP (newfile
), newfile
, SCM_ARG2
, s_copy_file
);
1094 if (SCM_SUBSTRP (newfile
))
1095 newfile
= scm_makfromstr (SCM_ROCHARS (newfile
), SCM_ROLENGTH (newfile
), 0);
1096 if (stat (SCM_ROCHARS (oldfile
), &oldstat
) == -1)
1097 scm_syserror (s_copy_file
);
1098 oldfd
= open (SCM_ROCHARS (oldfile
), O_RDONLY
);
1100 scm_syserror (s_copy_file
);
1102 /* use POSIX flags instead of 07777?. */
1103 newfd
= open (SCM_ROCHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1104 oldstat
.st_mode
& 07777);
1106 scm_syserror (s_copy_file
);
1108 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1109 if (write (newfd
, buf
, n
) != n
)
1113 scm_syserror (s_copy_file
);
1116 if (close (newfd
) == -1)
1117 scm_syserror (s_copy_file
);
1118 return SCM_UNSPECIFIED
;
1122 /* Filename manipulation */
1126 SCM_PROC (s_dirname
, "dirname", 1, 0, 0, scm_dirname
);
1129 scm_dirname (SCM filename
)
1133 SCM_ASSERT (SCM_NIMP (filename
) && SCM_ROSTRINGP (filename
),
1137 s
= SCM_ROCHARS (filename
);
1138 len
= SCM_LENGTH (filename
);
1140 while (i
>= 0 && s
[i
] == '/') --i
;
1141 while (i
>= 0 && s
[i
] != '/') --i
;
1142 while (i
>= 0 && s
[i
] == '/') --i
;
1145 if (len
> 0 && s
[0] == '/')
1146 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1148 return scm_dot_string
;
1151 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (i
+ 1));
1154 SCM_PROC (s_basename
, "basename", 1, 1, 0, scm_basename
);
1157 scm_basename (SCM filename
, SCM suffix
)
1161 SCM_ASSERT (SCM_NIMP (filename
) && SCM_ROSTRINGP (filename
),
1165 SCM_ASSERT (SCM_UNBNDP (suffix
)
1166 || (SCM_NIMP (suffix
) && SCM_ROSTRINGP (suffix
)),
1170 f
= SCM_ROCHARS (filename
);
1171 if (SCM_UNBNDP (suffix
))
1175 s
= SCM_ROCHARS (suffix
);
1176 j
= SCM_LENGTH (suffix
) - 1;
1178 len
= SCM_LENGTH (filename
);
1180 while (i
>= 0 && f
[i
] == '/') --i
;
1182 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1185 while (i
>= 0 && f
[i
] != '/') --i
;
1188 if (len
> 0 && f
[0] == '/')
1189 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1191 return scm_dot_string
;
1194 return scm_make_shared_substring (filename
,
1195 SCM_MAKINUM (i
+ 1),
1196 SCM_MAKINUM (end
+ 1));
1206 scm_tc16_dir
= scm_make_smob_type_mfpe ("directory", 0,
1207 NULL
, scm_dir_free
,scm_dir_print
, NULL
);
1209 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1212 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY
));
1215 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY
));
1218 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR
));
1221 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT
));
1224 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL
));
1227 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY
));
1230 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC
));
1233 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND
));
1236 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK
));
1239 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY
));
1242 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC
));
1246 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD
));
1249 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD
));
1252 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD
));
1255 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL
));
1258 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL
));
1261 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN
));
1264 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN
));
1267 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC
));
1270 #include "filesys.x"