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 GUILE_PROC (scm_chown
, "chown", 3, 0, 0,
126 (SCM object
, SCM owner
, SCM group
),
128 #define FUNC_NAME s_scm_chown
133 object
= SCM_COERCE_OUTPORT (object
);
135 SCM_VALIDATE_INT(2,owner
);
136 SCM_VALIDATE_INT(3,group
);
137 if (SCM_INUMP (object
) || (SCM_NIMP (object
) && SCM_OPFPORTP (object
)))
139 if (SCM_INUMP (object
))
140 fdes
= SCM_INUM (object
);
142 fdes
= SCM_FPORT_FDES (object
);
143 SCM_SYSCALL (rv
= fchown (fdes
, SCM_INUM (owner
), SCM_INUM (group
)));
147 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
148 object
, SCM_ARG1
, FUNC_NAME
);
149 SCM_COERCE_SUBSTR (object
);
150 SCM_SYSCALL (rv
= chown (SCM_ROCHARS (object
),
151 SCM_INUM (owner
), SCM_INUM (group
)));
155 return SCM_UNSPECIFIED
;
160 GUILE_PROC (scm_chmod
, "chmod", 2, 0, 0,
161 (SCM object
, SCM mode
),
163 #define FUNC_NAME s_scm_chmod
168 object
= SCM_COERCE_OUTPORT (object
);
170 SCM_VALIDATE_INT(2,mode
);
171 if (SCM_INUMP (object
) || (SCM_NIMP (object
) && SCM_OPFPORTP (object
)))
173 if (SCM_INUMP (object
))
174 fdes
= SCM_INUM (object
);
176 fdes
= SCM_FPORT_FDES (object
);
177 SCM_SYSCALL (rv
= fchmod (fdes
, SCM_INUM (mode
)));
181 SCM_VALIDATE_ROSTRING(1,object
);
182 SCM_COERCE_SUBSTR (object
);
183 SCM_SYSCALL (rv
= chmod (SCM_ROCHARS (object
), SCM_INUM (mode
)));
187 return SCM_UNSPECIFIED
;
191 GUILE_PROC (scm_umask
, "umask", 0, 1, 0,
194 #define FUNC_NAME s_scm_umask
197 if (SCM_UNBNDP (mode
))
204 SCM_VALIDATE_INT(1,mode
);
205 mask
= umask (SCM_INUM (mode
));
207 return SCM_MAKINUM (mask
);
213 GUILE_PROC (scm_open_fdes
, "open-fdes", 2, 1, 0,
214 (SCM path
, SCM flags
, SCM mode
),
216 #define FUNC_NAME s_scm_open_fdes
222 SCM_VALIDATE_ROSTRING(1,path
);
223 SCM_COERCE_SUBSTR (path
);
224 SCM_VALIDATE_INT_COPY(2,flags
,iflags
);
225 SCM_VALIDATE_INT_DEF_COPY(3,mode
,0666,imode
);
226 SCM_SYSCALL (fd
= open (SCM_ROCHARS (path
), iflags
, imode
));
229 return SCM_MAKINUM (fd
);
233 GUILE_PROC (scm_open
, "open", 2, 1, 0,
234 (SCM path
, SCM flags
, SCM mode
),
236 #define FUNC_NAME s_scm_open
243 fd
= SCM_INUM (scm_open_fdes (path
, flags
, mode
));
244 SCM_VALIDATE_INT_COPY(2,flags
,iflags
);
247 if (iflags
& O_APPEND
)
249 else if (iflags
& O_CREAT
)
255 if (iflags
& O_APPEND
)
257 else if (iflags
& O_WRONLY
)
262 newpt
= scm_fdes_to_port (fd
, port_mode
, path
);
267 GUILE_PROC (scm_close
, "close", 1, 0, 0,
270 #define FUNC_NAME s_scm_close
275 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
277 if (SCM_NIMP (fd_or_port
) && SCM_PORTP (fd_or_port
))
278 return scm_close_port (fd_or_port
);
279 SCM_VALIDATE_INT(1,fd_or_port
);
280 fd
= SCM_INUM (fd_or_port
);
281 scm_evict_ports (fd
); /* see scsh manual. */
282 SCM_SYSCALL (rv
= close (fd
));
283 /* following scsh, closing an already closed file descriptor is
285 if (rv
< 0 && errno
!= EBADF
)
287 return SCM_NEGATE_BOOL(rv
< 0);
295 SCM_SYMBOL (scm_sym_regular
, "regular");
296 SCM_SYMBOL (scm_sym_directory
, "directory");
298 SCM_SYMBOL (scm_sym_symlink
, "symlink");
300 SCM_SYMBOL (scm_sym_block_special
, "block-special");
301 SCM_SYMBOL (scm_sym_char_special
, "char-special");
302 SCM_SYMBOL (scm_sym_fifo
, "fifo");
303 SCM_SYMBOL (scm_sym_sock
, "socket");
304 SCM_SYMBOL (scm_sym_unknown
, "unknown");
307 scm_stat2scm (struct stat
*stat_temp
)
309 SCM ans
= scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED
);
310 SCM
*ve
= SCM_VELTS (ans
);
312 ve
[0] = scm_ulong2num ((unsigned long) stat_temp
->st_dev
);
313 ve
[1] = scm_ulong2num ((unsigned long) stat_temp
->st_ino
);
314 ve
[2] = scm_ulong2num ((unsigned long) stat_temp
->st_mode
);
315 ve
[3] = scm_ulong2num ((unsigned long) stat_temp
->st_nlink
);
316 ve
[4] = scm_ulong2num ((unsigned long) stat_temp
->st_uid
);
317 ve
[5] = scm_ulong2num ((unsigned long) stat_temp
->st_gid
);
319 ve
[6] = scm_ulong2num ((unsigned long) stat_temp
->st_rdev
);
323 ve
[7] = scm_ulong2num ((unsigned long) stat_temp
->st_size
);
324 ve
[8] = scm_ulong2num ((unsigned long) stat_temp
->st_atime
);
325 ve
[9] = scm_ulong2num ((unsigned long) stat_temp
->st_mtime
);
326 ve
[10] = scm_ulong2num ((unsigned long) stat_temp
->st_ctime
);
327 #ifdef HAVE_ST_BLKSIZE
328 ve
[11] = scm_ulong2num ((unsigned long) stat_temp
->st_blksize
);
330 ve
[11] = scm_ulong2num (4096L);
332 #ifdef HAVE_ST_BLOCKS
333 ve
[12] = scm_ulong2num ((unsigned long) stat_temp
->st_blocks
);
338 int mode
= stat_temp
->st_mode
;
341 ve
[13] = scm_sym_regular
;
342 else if (S_ISDIR (mode
))
343 ve
[13] = scm_sym_directory
;
345 else if (S_ISLNK (mode
))
346 ve
[13] = scm_sym_symlink
;
348 else if (S_ISBLK (mode
))
349 ve
[13] = scm_sym_block_special
;
350 else if (S_ISCHR (mode
))
351 ve
[13] = scm_sym_char_special
;
352 else if (S_ISFIFO (mode
))
353 ve
[13] = scm_sym_fifo
;
354 else if (S_ISSOCK (mode
))
355 ve
[13] = scm_sym_sock
;
357 ve
[13] = scm_sym_unknown
;
359 ve
[14] = SCM_MAKINUM ((~S_IFMT
) & mode
);
361 /* the layout of the bits in ve[14] is intended to be portable.
362 If there are systems that don't follow the usual convention,
363 the following could be used:
366 if (S_ISUID & mode) tmp += 1;
368 if (S_IRGRP & mode) tmp += 1;
370 if (S_ISVTX & mode) tmp += 1;
372 if (S_IRUSR & mode) tmp += 1;
374 if (S_IWUSR & mode) tmp += 1;
376 if (S_IXUSR & mode) tmp += 1;
378 if (S_IWGRP & mode) tmp += 1;
380 if (S_IXGRP & mode) tmp += 1;
382 if (S_IROTH & mode) tmp += 1;
384 if (S_IWOTH & mode) tmp += 1;
386 if (S_IXOTH & mode) tmp += 1;
388 ve[14] = SCM_MAKINUM (tmp);
396 GUILE_PROC (scm_stat
, "stat", 1, 0, 0,
399 #define FUNC_NAME s_scm_stat
403 struct stat stat_temp
;
405 if (SCM_INUMP (object
))
406 SCM_SYSCALL (rv
= fstat (SCM_INUM (object
), &stat_temp
));
409 SCM_VALIDATE_NIM (1,object
);
410 if (SCM_ROSTRINGP (object
))
412 SCM_COERCE_SUBSTR (object
);
413 SCM_SYSCALL (rv
= stat (SCM_ROCHARS (object
), &stat_temp
));
417 object
= SCM_COERCE_OUTPORT (object
);
418 SCM_ASSERT (SCM_OPFPORTP (object
), object
, SCM_ARG1
, FUNC_NAME
);
419 fdes
= SCM_FPORT_FDES (object
);
420 SCM_SYSCALL (rv
= fstat (fdes
, &stat_temp
));
427 scm_syserror_msg (FUNC_NAME
, "%s: %S",
428 scm_listify (scm_makfrom0str (strerror (errno
)),
433 return scm_stat2scm (&stat_temp
);
438 /* {Modifying Directories}
441 GUILE_PROC (scm_link
, "link", 2, 0, 0,
442 (SCM oldpath
, SCM newpath
),
444 #define FUNC_NAME s_scm_link
448 SCM_VALIDATE_ROSTRING(1,oldpath
);
449 if (SCM_SUBSTRP (oldpath
))
450 oldpath
= scm_makfromstr (SCM_ROCHARS (oldpath
),
451 SCM_ROLENGTH (oldpath
), 0);
452 SCM_VALIDATE_ROSTRING(2,newpath
);
453 if (SCM_SUBSTRP (newpath
))
454 newpath
= scm_makfromstr (SCM_ROCHARS (newpath
),
455 SCM_ROLENGTH (newpath
), 0);
456 SCM_SYSCALL (val
= link (SCM_ROCHARS (oldpath
), SCM_ROCHARS (newpath
)));
459 return SCM_UNSPECIFIED
;
465 GUILE_PROC (scm_rename
, "rename-file", 2, 0, 0,
466 (SCM oldname
, SCM newname
),
468 #define FUNC_NAME s_scm_rename
471 SCM_VALIDATE_ROSTRING(1,oldname
);
472 SCM_VALIDATE_ROSTRING(2,newname
);
473 SCM_COERCE_SUBSTR (oldname
);
474 SCM_COERCE_SUBSTR (newname
);
476 SCM_SYSCALL (rv
= rename (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
478 SCM_SYSCALL (rv
= link (SCM_ROCHARS (oldname
), SCM_ROCHARS (newname
)));
481 SCM_SYSCALL (rv
= unlink (SCM_ROCHARS (oldname
)));;
483 /* unlink failed. remove new name */
484 SCM_SYSCALL (unlink (SCM_ROCHARS (newname
)));
489 return SCM_UNSPECIFIED
;
494 GUILE_PROC(scm_delete_file
, "delete-file", 1, 0, 0,
497 #define FUNC_NAME s_scm_delete_file
500 SCM_VALIDATE_ROSTRING(1,str
);
501 SCM_COERCE_SUBSTR (str
);
502 SCM_SYSCALL (ans
= unlink (SCM_ROCHARS (str
)));
505 return SCM_UNSPECIFIED
;
509 GUILE_PROC (scm_mkdir
, "mkdir", 1, 1, 0,
510 (SCM path
, SCM mode
),
512 #define FUNC_NAME s_scm_mkdir
517 SCM_VALIDATE_ROSTRING(1,path
);
518 SCM_COERCE_SUBSTR (path
);
519 if (SCM_UNBNDP (mode
))
523 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), 0777 ^ mask
));
527 SCM_VALIDATE_INT(2,mode
);
528 SCM_SYSCALL (rv
= mkdir (SCM_ROCHARS (path
), SCM_INUM (mode
)));
532 return SCM_UNSPECIFIED
;
542 GUILE_PROC (scm_rmdir
, "rmdir", 1, 0, 0,
545 #define FUNC_NAME s_scm_rmdir
550 SCM_VALIDATE_ROSTRING(1,path
);
551 SCM_COERCE_SUBSTR (path
);
552 SCM_SYSCALL (val
= rmdir (SCM_ROCHARS (path
)));
555 return SCM_UNSPECIFIED
;
565 /* {Examining Directories}
570 GUILE_PROC (scm_directory_stream_p
, "directory-stream?", 1, 0, 0,
573 #define FUNC_NAME s_scm_directory_stream_p
575 return SCM_BOOL(SCM_NIMP (obj
) && SCM_DIRP (obj
));
579 GUILE_PROC (scm_opendir
, "opendir", 1, 0, 0,
582 #define FUNC_NAME s_scm_opendir
585 SCM_VALIDATE_ROSTRING(1,dirname
);
586 SCM_COERCE_SUBSTR (dirname
);
587 SCM_SYSCALL (ds
= opendir (SCM_ROCHARS (dirname
)));
590 SCM_RETURN_NEWSMOB (scm_tc16_dir
| SCM_OPN
, ds
);
595 GUILE_PROC (scm_readdir
, "readdir", 1, 0, 0,
598 #define FUNC_NAME s_scm_readdir
600 struct dirent
*rdent
;
601 SCM_VALIDATE_OPDIR(1,port
);
603 SCM_SYSCALL (rdent
= readdir ((DIR *) SCM_CDR (port
)));
606 return (rdent
? scm_makfromstr (rdent
->d_name
, NAMLEN (rdent
), 0)
613 GUILE_PROC (scm_rewinddir
, "rewinddir", 1, 0, 0,
616 #define FUNC_NAME s_scm_rewinddir
618 SCM_VALIDATE_OPDIR(1,port
);
619 rewinddir ((DIR *) SCM_CDR (port
));
620 return SCM_UNSPECIFIED
;
626 GUILE_PROC (scm_closedir
, "closedir", 1, 0, 0,
629 #define FUNC_NAME s_scm_closedir
633 SCM_VALIDATE_DIR(1,port
);
634 if (SCM_CLOSEDP (port
))
636 return SCM_UNSPECIFIED
;
638 SCM_SYSCALL (sts
= closedir ((DIR *) SCM_CDR (port
)));
641 SCM_SETCAR (port
, scm_tc16_dir
);
642 return SCM_UNSPECIFIED
;
650 scm_dir_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
652 scm_puts ("#<", port
);
653 if (SCM_CLOSEDP (exp
))
654 scm_puts ("closed: ", port
);
655 scm_puts ("directory stream ", port
);
656 scm_intprint (SCM_CDR (exp
), 16, port
);
657 scm_putc ('>', port
);
666 closedir ((DIR *) SCM_CDR (p
));
671 /* {Navigating Directories}
675 GUILE_PROC (scm_chdir
, "chdir", 1, 0, 0,
678 #define FUNC_NAME s_scm_chdir
682 SCM_VALIDATE_ROSTRING(1,str
);
683 SCM_COERCE_SUBSTR (str
);
684 SCM_SYSCALL (ans
= chdir (SCM_ROCHARS (str
)));
687 return SCM_UNSPECIFIED
;
693 GUILE_PROC (scm_getcwd
, "getcwd", 0, 0, 0,
696 #define FUNC_NAME s_scm_getcwd
701 scm_sizet size
= 100;
705 wd
= scm_must_malloc (size
, FUNC_NAME
);
706 while ((rv
= getcwd (wd
, size
)) == 0 && errno
== ERANGE
)
710 wd
= scm_must_malloc (size
, FUNC_NAME
);
714 result
= scm_makfromstr (wd
, strlen (wd
), 0);
728 set_element (SELECT_TYPE
*set
, SCM element
, int arg
)
731 element
= SCM_COERCE_OUTPORT (element
);
732 if (SCM_NIMP (element
) && SCM_OPFPORTP (element
))
733 fd
= SCM_FPORT_FDES (element
);
735 SCM_ASSERT (SCM_INUMP (element
), element
, arg
, "select");
736 fd
= SCM_INUM (element
);
743 fill_select_type (SELECT_TYPE
*set
, SCM list
, int arg
)
746 if (SCM_NIMP (list
) && SCM_VECTORP (list
))
748 int len
= SCM_LENGTH (list
);
749 SCM
*ve
= SCM_VELTS (list
);
753 fd
= set_element (set
, ve
[len
- 1], arg
);
761 while (list
!= SCM_EOL
)
763 fd
= set_element (set
, SCM_CAR (list
), arg
);
766 list
= SCM_CDR (list
);
774 get_element (SELECT_TYPE
*set
, SCM element
, SCM list
)
776 element
= SCM_COERCE_OUTPORT (element
);
777 if (SCM_NIMP (element
) && SCM_OPFPORTP (element
))
779 if (FD_ISSET (SCM_FPORT_FDES (element
), set
))
780 list
= scm_cons (element
, list
);
782 else if (SCM_INUMP (element
))
784 if (FD_ISSET (SCM_INUM (element
), set
))
785 list
= scm_cons (element
, list
);
791 retrieve_select_type (SELECT_TYPE
*set
, SCM list
)
793 SCM answer_list
= SCM_EOL
;
795 if (SCM_NIMP (list
) && SCM_VECTORP (list
))
797 int len
= SCM_LENGTH (list
);
798 SCM
*ve
= SCM_VELTS (list
);
802 answer_list
= get_element (set
, ve
[len
- 1], answer_list
);
805 return scm_vector (answer_list
);
809 /* list is a list. */
810 while (list
!= SCM_EOL
)
812 answer_list
= get_element (set
, SCM_CAR (list
), answer_list
);
813 list
= SCM_CDR (list
);
819 /* Static helper functions above refer to s_scm_select directly as s_select */
820 GUILE_PROC (scm_select
, "select", 3, 2, 0,
821 (SCM reads
, SCM writes
, SCM excepts
, SCM secs
, SCM usecs
),
823 #define FUNC_NAME s_scm_select
826 struct timeval timeout
;
827 struct timeval
* time_p
;
828 SELECT_TYPE read_set
;
829 SELECT_TYPE write_set
;
830 SELECT_TYPE except_set
;
834 #define assert_set(x, arg) \
835 SCM_ASSERT (scm_ilength (x) >= 0 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
837 assert_set (reads
, SCM_ARG1
);
838 assert_set (writes
, SCM_ARG2
);
839 assert_set (excepts
, SCM_ARG3
);
843 FD_ZERO (&write_set
);
844 FD_ZERO (&except_set
);
846 max_fd
= fill_select_type (&read_set
, reads
, SCM_ARG1
);
847 fd
= fill_select_type (&write_set
, writes
, SCM_ARG2
);
850 fd
= fill_select_type (&except_set
, excepts
, SCM_ARG3
);
854 if (SCM_UNBNDP (secs
) || SCM_FALSEP (secs
))
858 if (SCM_INUMP (secs
))
860 timeout
.tv_sec
= SCM_INUM (secs
);
861 if (SCM_UNBNDP (usecs
))
865 SCM_VALIDATE_INT(5,usecs
);
866 timeout
.tv_usec
= SCM_INUM (usecs
);
871 double fl
= scm_num2dbl (secs
, FUNC_NAME
);
873 if (!SCM_UNBNDP (usecs
))
874 scm_wrong_type_arg (FUNC_NAME
, 4, secs
);
876 scm_out_of_range (FUNC_NAME
, secs
);
877 timeout
.tv_sec
= (long) fl
;
878 timeout
.tv_usec
= (long) ((fl
- timeout
.tv_sec
) * 1000000);
884 sreturn
= scm_internal_select (max_fd
+ 1,
885 &read_set
, &write_set
, &except_set
, time_p
);
887 sreturn
= select (max_fd
+ 1,
888 &read_set
, &write_set
, &except_set
, time_p
);
892 return scm_listify (retrieve_select_type (&read_set
, reads
),
893 retrieve_select_type (&write_set
, writes
),
894 retrieve_select_type (&except_set
, excepts
),
906 GUILE_PROC (scm_fcntl
, "fcntl", 2, 0, 1,
907 (SCM object
, SCM cmd
, SCM value
),
909 #define FUNC_NAME s_scm_fcntl
915 object
= SCM_COERCE_OUTPORT (object
);
917 SCM_VALIDATE_INT(2,cmd
);
918 if (SCM_NIMP (object
) && SCM_OPFPORTP (object
))
919 fdes
= SCM_FPORT_FDES (object
);
922 SCM_VALIDATE_INT(1,object
);
923 fdes
= SCM_INUM (object
);
925 if (SCM_NULLP (value
))
929 SCM_ASSERT (SCM_INUMP (SCM_CAR (value
)), value
, SCM_ARG3
, FUNC_NAME
);
930 ivalue
= SCM_INUM (SCM_CAR (value
));
932 SCM_SYSCALL (rv
= fcntl (fdes
, SCM_INUM (cmd
), ivalue
));
935 return SCM_MAKINUM (rv
);
939 GUILE_PROC (scm_fsync
, "fsync", 1, 0, 0,
942 #define FUNC_NAME s_scm_fsync
946 object
= SCM_COERCE_OUTPORT (object
);
948 if (SCM_NIMP (object
) && SCM_OPFPORTP (object
))
951 fdes
= SCM_FPORT_FDES (object
);
955 SCM_VALIDATE_INT(1,object
);
956 fdes
= SCM_INUM (object
);
958 if (fsync (fdes
) == -1)
960 return SCM_UNSPECIFIED
;
964 GUILE_PROC (scm_symlink
, "symlink", 2, 0, 0,
965 (SCM oldpath
, SCM newpath
),
967 #define FUNC_NAME s_scm_symlink
972 SCM_VALIDATE_ROSTRING(1,oldpath
);
973 SCM_VALIDATE_ROSTRING(2,newpath
);
974 SCM_COERCE_SUBSTR (oldpath
);
975 SCM_COERCE_SUBSTR (newpath
);
976 SCM_SYSCALL (val
= symlink(SCM_ROCHARS(oldpath
), SCM_ROCHARS(newpath
)));
979 return SCM_UNSPECIFIED
;
989 GUILE_PROC (scm_readlink
, "readlink", 1, 0, 0,
992 #define FUNC_NAME s_scm_readlink
999 SCM_VALIDATE_ROSTRING(1,path
);
1000 SCM_COERCE_SUBSTR (path
);
1001 buf
= scm_must_malloc (size
, FUNC_NAME
);
1002 while ((rv
= readlink (SCM_ROCHARS (path
), buf
, size
)) == size
)
1004 scm_must_free (buf
);
1006 buf
= scm_must_malloc (size
, FUNC_NAME
);
1010 result
= scm_makfromstr (buf
, rv
, 0);
1011 scm_must_free (buf
);
1022 GUILE_PROC (scm_lstat
, "lstat", 1, 0, 0,
1025 #define FUNC_NAME s_scm_lstat
1029 struct stat stat_temp
;
1031 SCM_VALIDATE_ROSTRING(1,str
);
1032 SCM_COERCE_SUBSTR (str
);
1033 SCM_SYSCALL(rv
= lstat(SCM_ROCHARS(str
), &stat_temp
));
1038 scm_syserror_msg (FUNC_NAME
, "%s: %S",
1039 scm_listify (scm_makfrom0str (strerror (errno
)),
1044 return scm_stat2scm(&stat_temp
);
1054 GUILE_PROC (scm_copy_file
, "copy-file", 2, 0, 0,
1055 (SCM oldfile
, SCM newfile
),
1057 #define FUNC_NAME s_scm_copy_file
1062 struct stat oldstat
;
1064 SCM_VALIDATE_ROSTRING(1,oldfile
);
1065 if (SCM_SUBSTRP (oldfile
))
1066 oldfile
= scm_makfromstr (SCM_ROCHARS (oldfile
), SCM_ROLENGTH (oldfile
), 0);
1067 SCM_VALIDATE_ROSTRING(2,newfile
);
1068 if (SCM_SUBSTRP (newfile
))
1069 newfile
= scm_makfromstr (SCM_ROCHARS (newfile
), SCM_ROLENGTH (newfile
), 0);
1070 if (stat (SCM_ROCHARS (oldfile
), &oldstat
) == -1)
1072 oldfd
= open (SCM_ROCHARS (oldfile
), O_RDONLY
);
1076 /* use POSIX flags instead of 07777?. */
1077 newfd
= open (SCM_ROCHARS (newfile
), O_WRONLY
| O_CREAT
| O_TRUNC
,
1078 oldstat
.st_mode
& 07777);
1082 while ((n
= read (oldfd
, buf
, sizeof buf
)) > 0)
1083 if (write (newfd
, buf
, n
) != n
)
1090 if (close (newfd
) == -1)
1092 return SCM_UNSPECIFIED
;
1097 /* Filename manipulation */
1101 GUILE_PROC (scm_dirname
, "dirname", 1, 0, 0,
1104 #define FUNC_NAME s_scm_dirname
1108 SCM_VALIDATE_ROSTRING(1,filename
);
1109 s
= SCM_ROCHARS (filename
);
1110 len
= SCM_LENGTH (filename
);
1112 while (i
>= 0 && s
[i
] == '/') --i
;
1113 while (i
>= 0 && s
[i
] != '/') --i
;
1114 while (i
>= 0 && s
[i
] == '/') --i
;
1117 if (len
> 0 && s
[0] == '/')
1118 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1120 return scm_dot_string
;
1123 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (i
+ 1));
1127 GUILE_PROC (scm_basename
, "basename", 1, 1, 0,
1128 (SCM filename
, SCM suffix
),
1130 #define FUNC_NAME s_scm_basename
1134 SCM_VALIDATE_ROSTRING(1,filename
);
1135 SCM_ASSERT (SCM_UNBNDP (suffix
)
1136 || (SCM_NIMP (suffix
) && SCM_ROSTRINGP (suffix
)),
1140 f
= SCM_ROCHARS (filename
);
1141 if (SCM_UNBNDP (suffix
))
1145 s
= SCM_ROCHARS (suffix
);
1146 j
= SCM_LENGTH (suffix
) - 1;
1148 len
= SCM_LENGTH (filename
);
1150 while (i
>= 0 && f
[i
] == '/') --i
;
1152 while (i
>= 0 && j
>= 0 && f
[i
] == s
[j
]) --i
, --j
;
1155 while (i
>= 0 && f
[i
] != '/') --i
;
1158 if (len
> 0 && f
[0] == '/')
1159 return scm_make_shared_substring (filename
, SCM_INUM0
, SCM_MAKINUM (1));
1161 return scm_dot_string
;
1164 return scm_make_shared_substring (filename
,
1165 SCM_MAKINUM (i
+ 1),
1166 SCM_MAKINUM (end
+ 1));
1177 scm_tc16_dir
= scm_make_smob_type_mfpe ("directory", 0,
1178 NULL
, scm_dir_free
,scm_dir_print
, NULL
);
1180 scm_dot_string
= scm_permanent_object (scm_makfrom0str ("."));
1183 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY
));
1186 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY
));
1189 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR
));
1192 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT
));
1195 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL
));
1198 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY
));
1201 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC
));
1204 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND
));
1207 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK
));
1210 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY
));
1213 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC
));
1217 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD
));
1220 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD
));
1223 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD
));
1226 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL
));
1229 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL
));
1232 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN
));
1235 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN
));
1238 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC
));
1241 #include "filesys.x"