* Makefile.am (DEFS): Added. automake adds -I options to DEFS,
[bpt/guile.git] / libguile / filesys.c
CommitLineData
bd9e24b3 1/* Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
0f2d19dd
JB
2 *
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)
6 * any later version.
7 *
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.
12 *
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
82892bed
JB
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
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.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
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.
37 *
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.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84
GB
41
42/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
0f2d19dd 45\f
3d8d56df 46#include <stdio.h>
a0599745
MD
47#include "libguile/_scm.h"
48#include "libguile/smob.h"
49#include "libguile/feature.h"
50#include "libguile/fports.h"
51#include "libguile/iselect.h"
52#include "libguile/strings.h"
53#include "libguile/vectors.h"
0f2d19dd 54
a0599745
MD
55#include "libguile/validate.h"
56#include "libguile/filesys.h"
def804a3 57
0f2d19dd 58\f
def804a3
JB
59#ifdef HAVE_IO_H
60#include <io.h>
61#endif
62
0f2d19dd
JB
63#ifdef TIME_WITH_SYS_TIME
64# include <sys/time.h>
65# include <time.h>
66#else
67# if HAVE_SYS_TIME_H
68# include <sys/time.h>
69# else
70# include <time.h>
71# endif
72#endif
73
74#ifdef HAVE_UNISTD_H
75#include <unistd.h>
76#endif
77
3594582b 78#ifdef LIBC_H_WITH_UNISTD_H
1f9e2226
JB
79#include <libc.h>
80#endif
81
0f2d19dd
JB
82#ifdef HAVE_SYS_SELECT_H
83#include <sys/select.h>
84#endif
85
1f9e2226
JB
86#ifdef HAVE_STRING_H
87#include <string.h>
88#endif
89
8cc71382 90#include <sys/types.h>
0f2d19dd
JB
91#include <sys/stat.h>
92#include <fcntl.h>
93
94#include <pwd.h>
95
96
0f2d19dd
JB
97#if HAVE_DIRENT_H
98# include <dirent.h>
99# define NAMLEN(dirent) strlen((dirent)->d_name)
100#else
101# define dirent direct
102# define NAMLEN(dirent) (dirent)->d_namlen
103# if HAVE_SYS_NDIR_H
104# include <sys/ndir.h>
105# endif
106# if HAVE_SYS_DIR_H
107# include <sys/dir.h>
108# endif
109# if HAVE_NDIR_H
110# include <ndir.h>
111# endif
112#endif
113
d7b8a21a
JB
114/* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
115#if defined (S_IFSOCK) && ! defined (S_ISSOCK)
116#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
117#endif
0f2d19dd
JB
118\f
119
0f2d19dd
JB
120
121\f
122
123/* {Permissions}
124 */
125
a1ec6916 126SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
1bbd0b84 127 (SCM object, SCM owner, SCM group),
d831b039
GH
128 "Change the ownership and group of the file referred to by @var{object} to\n"
129 "the integer values @var{owner} and @var{group}. @var{object} can be\n"
130 "a string containing a file name or, if the platform\n"
131 "supports fchown, a port or integer file descriptor\n"
132 "which is open on the file. The return value\n"
d3818c29 133 "is unspecified.\n\n"
d831b039 134 "If @var{object} is a symbolic link, either the\n"
d3818c29
MD
135 "ownership of the link or the ownership of the referenced file will be\n"
136 "changed depending on the operating system (lchown is\n"
137 "unsupported at present). If @var{owner} or @var{group} is specified\n"
138 "as @code{-1}, then that ID is not changed.")
1bbd0b84 139#define FUNC_NAME s_scm_chown
0f2d19dd 140{
6afcd3b2 141 int rv;
02b754d3 142
78446828
MV
143 object = SCM_COERCE_OUTPORT (object);
144
3b3b36dd
GB
145 SCM_VALIDATE_INUM (2,owner);
146 SCM_VALIDATE_INUM (3,group);
d831b039 147#ifdef HAVE_FCHOWN
0c95b57d 148 if (SCM_INUMP (object) || (SCM_OPFPORTP (object)))
6afcd3b2 149 {
d831b039
GH
150 int fdes = SCM_INUMP (object) ? SCM_INUM (object)
151 : SCM_FPORT_FDES (object);
152
6afcd3b2
GH
153 SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group)));
154 }
155 else
d831b039 156#endif
6afcd3b2 157 {
c1bfcf60 158 SCM_VALIDATE_ROSTRING(1,object);
6afcd3b2
GH
159 SCM_COERCE_SUBSTR (object);
160 SCM_SYSCALL (rv = chown (SCM_ROCHARS (object),
161 SCM_INUM (owner), SCM_INUM (group)));
162 }
163 if (rv == -1)
1bbd0b84 164 SCM_SYSERROR;
02b754d3 165 return SCM_UNSPECIFIED;
0f2d19dd 166}
1bbd0b84 167#undef FUNC_NAME
0f2d19dd
JB
168
169
a1ec6916 170SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
1bbd0b84 171 (SCM object, SCM mode),
d3818c29
MD
172 "Changes the permissions of the file referred to by @var{obj}.\n"
173 "@var{obj} can be a string containing a file name or a port or integer file\n"
174 "descriptor which is open on a file (in which case @code{fchmod} is used\n"
175 "as the underlying system call).\n"
176 "@var{mode} specifies\n"
177 "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
178 "The return value is unspecified.")
1bbd0b84 179#define FUNC_NAME s_scm_chmod
0f2d19dd
JB
180{
181 int rv;
6afcd3b2
GH
182 int fdes;
183
78446828
MV
184 object = SCM_COERCE_OUTPORT (object);
185
3b3b36dd 186 SCM_VALIDATE_INUM (2,mode);
0c95b57d 187 if (SCM_INUMP (object) || SCM_OPFPORTP (object))
89958ad0 188 {
6afcd3b2
GH
189 if (SCM_INUMP (object))
190 fdes = SCM_INUM (object);
191 else
77a76b64 192 fdes = SCM_FPORT_FDES (object);
6afcd3b2 193 SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode)));
89958ad0 194 }
0f2d19dd
JB
195 else
196 {
3b3b36dd 197 SCM_VALIDATE_ROSTRING (1,object);
6afcd3b2
GH
198 SCM_COERCE_SUBSTR (object);
199 SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode)));
0f2d19dd 200 }
6afcd3b2 201 if (rv == -1)
1bbd0b84 202 SCM_SYSERROR;
02b754d3 203 return SCM_UNSPECIFIED;
0f2d19dd 204}
1bbd0b84 205#undef FUNC_NAME
0f2d19dd 206
a1ec6916 207SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
1bbd0b84 208 (SCM mode),
d3818c29
MD
209 "If @var{mode} is omitted, retuns a decimal number representing the current\n"
210 "file creation mask. Otherwise the file creation mask is set to\n"
211 "@var{mode} and the previous value is returned.\n\n"
212 "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
1bbd0b84 213#define FUNC_NAME s_scm_umask
0f2d19dd
JB
214{
215 mode_t mask;
216 if (SCM_UNBNDP (mode))
217 {
218 mask = umask (0);
219 umask (mask);
220 }
221 else
222 {
3b3b36dd 223 SCM_VALIDATE_INUM (1,mode);
0f2d19dd
JB
224 mask = umask (SCM_INUM (mode));
225 }
226 return SCM_MAKINUM (mask);
227}
1bbd0b84 228#undef FUNC_NAME
0f2d19dd
JB
229
230\f
0f2d19dd 231
a1ec6916 232SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
1bbd0b84 233 (SCM path, SCM flags, SCM mode),
d3818c29
MD
234 "Similar to @code{open} but returns a file descriptor instead of a\n"
235 "port.")
1bbd0b84 236#define FUNC_NAME s_scm_open_fdes
0f2d19dd
JB
237{
238 int fd;
3d8d56df 239 int iflags;
6afcd3b2 240 int imode;
0f2d19dd 241
3b3b36dd 242 SCM_VALIDATE_ROSTRING (1,path);
6afcd3b2 243 SCM_COERCE_SUBSTR (path);
c1bfcf60
GB
244 iflags = SCM_NUM2LONG(2,flags);
245 imode = SCM_NUM2LONG_DEF(3,mode,0666);
6afcd3b2 246 SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode));
3d8d56df 247 if (fd == -1)
1bbd0b84 248 SCM_SYSERROR;
6afcd3b2
GH
249 return SCM_MAKINUM (fd);
250}
1bbd0b84 251#undef FUNC_NAME
6afcd3b2 252
a1ec6916 253SCM_DEFINE (scm_open, "open", 2, 1, 0,
1bbd0b84 254 (SCM path, SCM flags, SCM mode),
d3818c29
MD
255 "Open the file named by @var{path} for reading and/or writing.\n"
256 "@var{flags} is an integer specifying how the file should be opened.\n"
257 "@var{mode} is an integer specifying the permission bits of the file, if\n"
258 "it needs to be created, before the umask is applied. The default is 666\n"
259 "(Unix itself has no default).\n\n"
260 "@var{flags} can be constructed by combining variables using @code{logior}.\n"
261 "Basic flags are:\n\n"
262 "@defvar O_RDONLY\n"
263 "Open the file read-only.\n"
264 "@end defvar\n"
265 "@defvar O_WRONLY\n"
266 "Open the file write-only. \n"
267 "@end defvar\n"
268 "@defvar O_RDWR\n"
269 "Open the file read/write.\n"
270 "@end defvar\n"
271 "@defvar O_APPEND\n"
272 "Append to the file instead of truncating.\n"
273 "@end defvar\n"
274 "@defvar O_CREAT\n"
275 "Create the file if it does not already exist.\n"
276 "@end defvar\n\n"
277 "See the Unix documentation of the @code{open} system call\n"
278 "for additional flags.")
1bbd0b84 279#define FUNC_NAME s_scm_open
6afcd3b2
GH
280{
281 SCM newpt;
282 char *port_mode;
283 int fd;
6afcd3b2
GH
284 int iflags;
285
286 fd = SCM_INUM (scm_open_fdes (path, flags, mode));
c1bfcf60 287 iflags = SCM_NUM2LONG (2,flags);
3d8d56df 288 if (iflags & O_RDWR)
77a76b64
JB
289 {
290 if (iflags & O_APPEND)
291 port_mode = "a+";
292 else if (iflags & O_CREAT)
293 port_mode = "w+";
294 else
295 port_mode = "r+";
296 }
3d8d56df 297 else {
77a76b64
JB
298 if (iflags & O_APPEND)
299 port_mode = "a";
300 else if (iflags & O_WRONLY)
3d8d56df
GH
301 port_mode = "w";
302 else
303 port_mode = "r";
304 }
77a76b64 305 newpt = scm_fdes_to_port (fd, port_mode, path);
3d8d56df 306 return newpt;
0f2d19dd 307}
1bbd0b84 308#undef FUNC_NAME
0f2d19dd 309
a1ec6916 310SCM_DEFINE (scm_close, "close", 1, 0, 0,
1bbd0b84 311 (SCM fd_or_port),
d3818c29
MD
312 "Similar to close-port (@pxref{Generic Port Operations, close-port}),\n"
313 "but also works on file descriptors. A side\n"
314 "effect of closing a file descriptor is that any ports using that file\n"
315 "descriptor are moved to a different file descriptor and have\n"
316 "their revealed counts set to zero.")
1bbd0b84 317#define FUNC_NAME s_scm_close
eadd48de
GH
318{
319 int rv;
320 int fd;
321
78446828
MV
322 fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
323
0c95b57d 324 if (SCM_PORTP (fd_or_port))
eadd48de 325 return scm_close_port (fd_or_port);
3b3b36dd 326 SCM_VALIDATE_INUM (1,fd_or_port);
eadd48de 327 fd = SCM_INUM (fd_or_port);
eadd48de 328 scm_evict_ports (fd); /* see scsh manual. */
a9488d12 329 SCM_SYSCALL (rv = close (fd));
eadd48de
GH
330 /* following scsh, closing an already closed file descriptor is
331 not an error. */
332 if (rv < 0 && errno != EBADF)
1bbd0b84
GB
333 SCM_SYSERROR;
334 return SCM_NEGATE_BOOL(rv < 0);
eadd48de 335}
1bbd0b84 336#undef FUNC_NAME
eadd48de 337
0f2d19dd
JB
338\f
339/* {Files}
340 */
1cc91f1b 341
ae5253c5
GH
342SCM_SYMBOL (scm_sym_regular, "regular");
343SCM_SYMBOL (scm_sym_directory, "directory");
f326ecf3 344#ifdef HAVE_S_ISLNK
ae5253c5 345SCM_SYMBOL (scm_sym_symlink, "symlink");
f326ecf3 346#endif
ae5253c5
GH
347SCM_SYMBOL (scm_sym_block_special, "block-special");
348SCM_SYMBOL (scm_sym_char_special, "char-special");
349SCM_SYMBOL (scm_sym_fifo, "fifo");
350SCM_SYMBOL (scm_sym_sock, "socket");
351SCM_SYMBOL (scm_sym_unknown, "unknown");
352
0f2d19dd 353static SCM
1bbd0b84 354scm_stat2scm (struct stat *stat_temp)
0f2d19dd 355{
a8741caa 356 SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED);
0f2d19dd 357 SCM *ve = SCM_VELTS (ans);
ae5253c5 358
0f2d19dd
JB
359 ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
360 ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
361 ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
362 ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink);
363 ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid);
364 ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid);
365#ifdef HAVE_ST_RDEV
366 ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev);
367#else
368 ve[6] = SCM_BOOL_F;
369#endif
370 ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size);
371 ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime);
372 ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime);
373 ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime);
374#ifdef HAVE_ST_BLKSIZE
375 ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize);
376#else
377 ve[11] = scm_ulong2num (4096L);
378#endif
379#ifdef HAVE_ST_BLOCKS
380 ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks);
381#else
382 ve[12] = SCM_BOOL_F;
383#endif
ae5253c5
GH
384 {
385 int mode = stat_temp->st_mode;
386
387 if (S_ISREG (mode))
388 ve[13] = scm_sym_regular;
389 else if (S_ISDIR (mode))
390 ve[13] = scm_sym_directory;
f326ecf3 391#ifdef HAVE_S_ISLNK
ae5253c5
GH
392 else if (S_ISLNK (mode))
393 ve[13] = scm_sym_symlink;
f326ecf3 394#endif
ae5253c5
GH
395 else if (S_ISBLK (mode))
396 ve[13] = scm_sym_block_special;
397 else if (S_ISCHR (mode))
398 ve[13] = scm_sym_char_special;
399 else if (S_ISFIFO (mode))
400 ve[13] = scm_sym_fifo;
401 else if (S_ISSOCK (mode))
402 ve[13] = scm_sym_sock;
403 else
404 ve[13] = scm_sym_unknown;
405
406 ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
407
408 /* the layout of the bits in ve[14] is intended to be portable.
409 If there are systems that don't follow the usual convention,
410 the following could be used:
411
412 tmp = 0;
413 if (S_ISUID & mode) tmp += 1;
414 tmp <<= 1;
415 if (S_IRGRP & mode) tmp += 1;
416 tmp <<= 1;
417 if (S_ISVTX & mode) tmp += 1;
418 tmp <<= 1;
419 if (S_IRUSR & mode) tmp += 1;
420 tmp <<= 1;
421 if (S_IWUSR & mode) tmp += 1;
422 tmp <<= 1;
423 if (S_IXUSR & mode) tmp += 1;
424 tmp <<= 1;
425 if (S_IWGRP & mode) tmp += 1;
426 tmp <<= 1;
427 if (S_IXGRP & mode) tmp += 1;
428 tmp <<= 1;
429 if (S_IROTH & mode) tmp += 1;
430 tmp <<= 1;
431 if (S_IWOTH & mode) tmp += 1;
432 tmp <<= 1;
433 if (S_IXOTH & mode) tmp += 1;
434
435 ve[14] = SCM_MAKINUM (tmp);
436
437 */
438 }
0f2d19dd
JB
439
440 return ans;
441}
442
a1ec6916 443SCM_DEFINE (scm_stat, "stat", 1, 0, 0,
1bbd0b84 444 (SCM object),
d3818c29
MD
445 "Returns an object containing various information\n"
446 "about the file determined by @var{obj}.\n"
447 "@var{obj} can be a string containing a file name or a port or integer file\n"
448 "descriptor which is open on a file (in which case @code{fstat} is used\n"
449 "as the underlying system call).\n\n"
450 "The object returned by @code{stat} can be passed as a single parameter\n"
451 "to the following procedures, all of which return integers:\n\n"
452 "@table @code\n"
453 "@item stat:dev\n"
454 "The device containing the file.\n"
455 "@item stat:ino\n"
456 "The file serial number, which distinguishes this file from all other\n"
457 "files on the same device.\n"
458 "@item stat:mode\n"
459 "The mode of the file. This includes file type information\n"
460 "and the file permission bits. See @code{stat:type} and @code{stat:perms}\n"
461 "below.\n"
462 "@item stat:nlink\n"
463 "The number of hard links to the file.\n"
464 "@item stat:uid\n"
465 "The user ID of the file's owner.\n"
466 "@item stat:gid\n"
467 "The group ID of the file.\n"
468 "@item stat:rdev\n"
469 "Device ID; this entry is defined only for character or block\n"
470 "special files.\n"
471 "@item stat:size\n"
472 "The size of a regular file in bytes.\n"
473 "@item stat:atime\n"
474 "The last access time for the file.\n"
475 "@item stat:mtime\n"
476 "The last modification time for the file.\n"
477 "@item stat:ctime\n"
478 "The last modification time for the attributes of the file.\n"
479 "@item stat:blksize\n"
480 "The optimal block size for reading or writing the file, in bytes.\n"
481 "@item stat:blocks\n"
482 "The amount of disk space that the file occupies measured in units of\n"
483 "512 byte blocks.\n"
484 "@end table\n\n"
485 "In addition, the following procedures return the information\n"
486 "from stat:mode in a more convenient form:\n\n"
487 "@table @code\n"
488 "@item stat:type\n"
489 "A symbol representing the type of file. Possible values are\n"
490 "regular, directory, symlink, block-special, char-special,\n"
491 "fifo, socket and unknown\n"
492 "@item stat:perms\n"
493 "An integer representing the access permission bits.\n"
494 "@end table")
1bbd0b84 495#define FUNC_NAME s_scm_stat
0f2d19dd 496{
6afcd3b2
GH
497 int rv;
498 int fdes;
0f2d19dd
JB
499 struct stat stat_temp;
500
1ea47048
MD
501 if (SCM_INUMP (object))
502 SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
503 else
0f2d19dd 504 {
6b5a304f 505 SCM_VALIDATE_NIM (1,object);
1ea47048
MD
506 if (SCM_ROSTRINGP (object))
507 {
508 SCM_COERCE_SUBSTR (object);
509 SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
510 }
c0ebd8c5 511 else
0f2d19dd 512 {
1ea47048 513 object = SCM_COERCE_OUTPORT (object);
c1bfcf60 514 SCM_VALIDATE_OPFPORT(1,object);
77a76b64 515 fdes = SCM_FPORT_FDES (object);
1ea47048 516 SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
0f2d19dd 517 }
6afcd3b2
GH
518 }
519 if (rv == -1)
3d8d56df
GH
520 {
521 int en = errno;
522
5d2d2ffc 523 SCM_SYSERROR_MSG ("~A: ~S",
3d8d56df 524 scm_listify (scm_makfrom0str (strerror (errno)),
6afcd3b2 525 object,
5d2d2ffc 526 SCM_UNDEFINED), en);
3d8d56df 527 }
02b754d3 528 return scm_stat2scm (&stat_temp);
0f2d19dd 529}
1bbd0b84 530#undef FUNC_NAME
0f2d19dd 531
0f2d19dd
JB
532\f
533/* {Modifying Directories}
534 */
535
a1ec6916 536SCM_DEFINE (scm_link, "link", 2, 0, 0,
1bbd0b84 537 (SCM oldpath, SCM newpath),
d3818c29
MD
538 "Creates a new name @var{path-to} in the file system for the file\n"
539 "named by @var{path-from}. If @var{path-from} is a symbolic link, the\n"
540 "link may or may not be followed depending on the system.")
1bbd0b84 541#define FUNC_NAME s_scm_link
0f2d19dd
JB
542{
543 int val;
02b754d3 544
3b3b36dd 545 SCM_VALIDATE_ROSTRING (1,oldpath);
0f2d19dd 546 if (SCM_SUBSTRP (oldpath))
6afcd3b2
GH
547 oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
548 SCM_ROLENGTH (oldpath), 0);
3b3b36dd 549 SCM_VALIDATE_ROSTRING (2,newpath);
0f2d19dd 550 if (SCM_SUBSTRP (newpath))
6afcd3b2
GH
551 newpath = scm_makfromstr (SCM_ROCHARS (newpath),
552 SCM_ROLENGTH (newpath), 0);
0f2d19dd 553 SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
02b754d3 554 if (val != 0)
1bbd0b84 555 SCM_SYSERROR;
02b754d3 556 return SCM_UNSPECIFIED;
0f2d19dd 557}
1bbd0b84 558#undef FUNC_NAME
0f2d19dd
JB
559
560
561
a1ec6916 562SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
1bbd0b84 563 (SCM oldname, SCM newname),
d3818c29
MD
564 "Renames the file specified by @var{path-from} to @var{path-to}.\n"
565 "The return value is unspecified.")
1bbd0b84 566#define FUNC_NAME s_scm_rename
0f2d19dd
JB
567{
568 int rv;
3b3b36dd
GB
569 SCM_VALIDATE_ROSTRING (1,oldname);
570 SCM_VALIDATE_ROSTRING (2,newname);
89958ad0
JB
571 SCM_COERCE_SUBSTR (oldname);
572 SCM_COERCE_SUBSTR (newname);
0f2d19dd 573#ifdef HAVE_RENAME
89958ad0 574 SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
0f2d19dd 575#else
89958ad0 576 SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
02b754d3 577 if (rv == 0)
0f2d19dd 578 {
89958ad0 579 SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
02b754d3 580 if (rv != 0)
0f2d19dd 581 /* unlink failed. remove new name */
89958ad0 582 SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
0f2d19dd 583 }
6afcd3b2 584#endif
02b754d3 585 if (rv != 0)
1bbd0b84 586 SCM_SYSERROR;
02b754d3 587 return SCM_UNSPECIFIED;
0f2d19dd 588}
1bbd0b84 589#undef FUNC_NAME
0f2d19dd
JB
590
591
3b3b36dd 592SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
1bbd0b84 593 (SCM str),
d3818c29 594 "Deletes (or \"unlinks\") the file specified by @var{path}.")
1bbd0b84 595#define FUNC_NAME s_scm_delete_file
2f3ed1ba
JB
596{
597 int ans;
3b3b36dd 598 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
599 SCM_COERCE_SUBSTR (str);
600 SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
2f3ed1ba 601 if (ans != 0)
1bbd0b84 602 SCM_SYSERROR;
2f3ed1ba
JB
603 return SCM_UNSPECIFIED;
604}
1bbd0b84 605#undef FUNC_NAME
2f3ed1ba 606
f25f761d 607#ifdef HAVE_MKDIR
a1ec6916 608SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
1bbd0b84 609 (SCM path, SCM mode),
d3818c29
MD
610 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
611 "then the permissions of the directory file are set using the current\n"
612 "umask. Otherwise they are set to the decimal value specified with\n"
613 "@var{mode}. The return value is unspecified.")
1bbd0b84 614#define FUNC_NAME s_scm_mkdir
0f2d19dd 615{
0f2d19dd
JB
616 int rv;
617 mode_t mask;
3b3b36dd 618 SCM_VALIDATE_ROSTRING (1,path);
89958ad0 619 SCM_COERCE_SUBSTR (path);
0f2d19dd
JB
620 if (SCM_UNBNDP (mode))
621 {
622 mask = umask (0);
623 umask (mask);
89958ad0 624 SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
0f2d19dd
JB
625 }
626 else
627 {
3b3b36dd 628 SCM_VALIDATE_INUM (2,mode);
89958ad0 629 SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
0f2d19dd 630 }
02b754d3 631 if (rv != 0)
1bbd0b84 632 SCM_SYSERROR;
02b754d3 633 return SCM_UNSPECIFIED;
0f2d19dd 634}
1bbd0b84 635#undef FUNC_NAME
f25f761d 636#endif /* HAVE_MKDIR */
0f2d19dd 637
f25f761d 638#ifdef HAVE_RMDIR
a1ec6916 639SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
1bbd0b84 640 (SCM path),
d3818c29
MD
641 "Remove the existing directory named by @var{path}. The directory must\n"
642 "be empty for this to succeed. The return value is unspecified.")
1bbd0b84 643#define FUNC_NAME s_scm_rmdir
0f2d19dd 644{
0f2d19dd 645 int val;
02b754d3 646
3b3b36dd 647 SCM_VALIDATE_ROSTRING (1,path);
89958ad0
JB
648 SCM_COERCE_SUBSTR (path);
649 SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
02b754d3 650 if (val != 0)
1bbd0b84 651 SCM_SYSERROR;
02b754d3 652 return SCM_UNSPECIFIED;
0f2d19dd 653}
1bbd0b84 654#undef FUNC_NAME
f25f761d 655#endif
0f2d19dd
JB
656
657\f
658/* {Examining Directories}
659 */
660
661long scm_tc16_dir;
662
a1ec6916 663SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
1bbd0b84 664 (SCM obj),
d3818c29
MD
665 "Returns a boolean indicating whether @var{object} is a directory stream\n"
666 "as returned by @code{opendir}.")
1bbd0b84 667#define FUNC_NAME s_scm_directory_stream_p
77242ff9 668{
0c95b57d 669 return SCM_BOOL(SCM_DIRP (obj));
77242ff9 670}
1bbd0b84 671#undef FUNC_NAME
77242ff9 672
a1ec6916 673SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
1bbd0b84 674 (SCM dirname),
d3818c29
MD
675 "Open the directory specified by @var{path} and return a directory\n"
676 "stream.")
1bbd0b84 677#define FUNC_NAME s_scm_opendir
0f2d19dd
JB
678{
679 DIR *ds;
3b3b36dd 680 SCM_VALIDATE_ROSTRING (1,dirname);
89958ad0 681 SCM_COERCE_SUBSTR (dirname);
89958ad0 682 SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
02b754d3 683 if (ds == NULL)
1bbd0b84 684 SCM_SYSERROR;
23a62151 685 SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
0f2d19dd 686}
1bbd0b84 687#undef FUNC_NAME
0f2d19dd
JB
688
689
a1ec6916 690SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
1bbd0b84 691 (SCM port),
d3818c29
MD
692 "Return (as a string) the next directory entry from the directory stream\n"
693 "@var{stream}. If there is no remaining entry to be read then the\n"
694 "end of file object is returned.")
1bbd0b84 695#define FUNC_NAME s_scm_readdir
0f2d19dd
JB
696{
697 struct dirent *rdent;
3b3b36dd 698 SCM_VALIDATE_OPDIR (1,port);
0f2d19dd 699 errno = 0;
4260a7fc 700 SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port)));
02b754d3 701 if (errno != 0)
1bbd0b84 702 SCM_SYSERROR;
02b754d3
GH
703 return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
704 : SCM_EOF_VAL);
0f2d19dd 705}
1bbd0b84 706#undef FUNC_NAME
0f2d19dd
JB
707
708
709
a1ec6916 710SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
1bbd0b84 711 (SCM port),
d3818c29
MD
712 "Reset the directory port @var{stream} so that the next call to\n"
713 "@code{readdir} will return the first directory entry.")
1bbd0b84 714#define FUNC_NAME s_scm_rewinddir
0f2d19dd 715{
3b3b36dd 716 SCM_VALIDATE_OPDIR (1,port);
4260a7fc 717 rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
0f2d19dd
JB
718 return SCM_UNSPECIFIED;
719}
1bbd0b84 720#undef FUNC_NAME
0f2d19dd
JB
721
722
723
a1ec6916 724SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
1bbd0b84 725 (SCM port),
d3818c29
MD
726 "Close the directory stream @var{stream}.\n"
727 "The return value is unspecified.")
1bbd0b84 728#define FUNC_NAME s_scm_closedir
0f2d19dd
JB
729{
730 int sts;
02b754d3 731
3b3b36dd 732 SCM_VALIDATE_DIR (1,port);
0f2d19dd
JB
733 if (SCM_CLOSEDP (port))
734 {
02b754d3 735 return SCM_UNSPECIFIED;
0f2d19dd 736 }
4260a7fc 737 SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
02b754d3 738 if (sts != 0)
1bbd0b84 739 SCM_SYSERROR;
4260a7fc 740 SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
02b754d3 741 return SCM_UNSPECIFIED;
0f2d19dd 742}
1bbd0b84 743#undef FUNC_NAME
0f2d19dd
JB
744
745
746
1cc91f1b 747
0f2d19dd 748static int
f8b16091 749scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
0f2d19dd 750{
f8b16091
MD
751 scm_puts ("#<", port);
752 if (SCM_CLOSEDP (exp))
753 scm_puts ("closed: ", port);
0d03da62 754 scm_puts ("directory stream ", port);
4260a7fc 755 scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
f8b16091 756 scm_putc ('>', port);
0f2d19dd
JB
757 return 1;
758}
759
1cc91f1b 760
0f2d19dd 761static scm_sizet
1bbd0b84 762scm_dir_free (SCM p)
0f2d19dd
JB
763{
764 if (SCM_OPENP (p))
4260a7fc 765 closedir ((DIR *) SCM_CELL_WORD_1 (p));
0f2d19dd
JB
766 return 0;
767}
768
0f2d19dd
JB
769\f
770/* {Navigating Directories}
771 */
772
773
a1ec6916 774SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
1bbd0b84 775 (SCM str),
d3818c29
MD
776 "Change the current working directory to @var{path}.\n"
777 "The return value is unspecified.")
1bbd0b84 778#define FUNC_NAME s_scm_chdir
0f2d19dd
JB
779{
780 int ans;
02b754d3 781
3b3b36dd 782 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
783 SCM_COERCE_SUBSTR (str);
784 SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
02b754d3 785 if (ans != 0)
1bbd0b84 786 SCM_SYSERROR;
02b754d3 787 return SCM_UNSPECIFIED;
0f2d19dd 788}
1bbd0b84 789#undef FUNC_NAME
0f2d19dd 790
f25f761d 791#ifdef HAVE_GETCWD
a1ec6916 792SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
1bbd0b84 793 (),
d3818c29 794 "Returns the name of the current working directory.")
1bbd0b84 795#define FUNC_NAME s_scm_getcwd
0f2d19dd 796{
0f2d19dd 797 char *rv;
0f2d19dd
JB
798 scm_sizet size = 100;
799 char *wd;
800 SCM result;
801
1bbd0b84 802 wd = scm_must_malloc (size, FUNC_NAME);
0f2d19dd
JB
803 while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
804 {
805 scm_must_free (wd);
806 size *= 2;
1bbd0b84 807 wd = scm_must_malloc (size, FUNC_NAME);
0f2d19dd 808 }
02b754d3 809 if (rv == 0)
1bbd0b84 810 SCM_SYSERROR;
02b754d3 811 result = scm_makfromstr (wd, strlen (wd), 0);
0f2d19dd 812 scm_must_free (wd);
0f2d19dd 813 return result;
0f2d19dd 814}
1bbd0b84 815#undef FUNC_NAME
f25f761d 816#endif /* HAVE_GETCWD */
0f2d19dd
JB
817
818\f
819
28d77376
GH
820#ifdef HAVE_SELECT
821
822/* check that element is a port or file descriptor. if it's a port
823 and its buffer is ready for use, add it to the ports_ready list.
824 otherwise add its file descriptor to *set. the type of list can be
825 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
826 SCM_ARG3 for excepts. */
cafc12ff 827static int
28d77376 828set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
a48a89bc 829{
cafc12ff 830 int fd;
d831b039 831
28d77376
GH
832 if (SCM_INUMP (element))
833 {
834 fd = SCM_INUM (element);
835 }
836 else
837 {
838 int use_buf = 0;
839
840 element = SCM_COERCE_OUTPORT (element);
841 SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select");
842 if (pos == SCM_ARG1)
843 {
844 /* check whether port has buffered input. */
845 scm_port *pt = SCM_PTAB_ENTRY (element);
846
847 if (pt->read_pos < pt->read_end)
848 use_buf = 1;
849 }
850 else if (pos == SCM_ARG2)
851 {
852 /* check whether port's output buffer has room. */
853 scm_port *pt = SCM_PTAB_ENTRY (element);
854
855 /* > 1 since writing the last byte in the buffer causes flush. */
856 if (pt->write_end - pt->write_pos > 1)
857 use_buf = 1;
858 }
859 fd = use_buf ? -1 : SCM_FPORT_FDES (element);
860 }
861 if (fd == -1)
862 *ports_ready = scm_cons (element, *ports_ready);
863 else
864 FD_SET (fd, set);
cafc12ff 865 return fd;
a48a89bc 866}
1cc91f1b 867
28d77376
GH
868/* check list_or_vec, a list or vector of ports or file descriptors,
869 adding each member to either the ports_ready list (if it's a port
870 with a usable buffer) or to *set. the kind of list_or_vec can be
871 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
872 SCM_ARG3 for excepts. */
cafc12ff 873static int
28d77376 874fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
0f2d19dd 875{
28d77376
GH
876 int max_fd = 0;
877
878 if (SCM_VECTORP (list_or_vec))
0f2d19dd 879 {
28d77376
GH
880 int i = SCM_LENGTH (list_or_vec);
881 SCM *ve = SCM_VELTS (list_or_vec);
a48a89bc 882
28d77376 883 while (--i >= 0)
a48a89bc 884 {
28d77376
GH
885 int fd = set_element (set, ports_ready, ve[i], pos);
886
cafc12ff
MD
887 if (fd > max_fd)
888 max_fd = fd;
a48a89bc
GH
889 }
890 }
891 else
892 {
4260a7fc 893 while (!SCM_NULLP (list_or_vec))
a48a89bc 894 {
28d77376
GH
895 int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos);
896
cafc12ff
MD
897 if (fd > max_fd)
898 max_fd = fd;
28d77376 899 list_or_vec = SCM_CDR (list_or_vec);
a48a89bc 900 }
0f2d19dd 901 }
cafc12ff
MD
902
903 return max_fd;
0f2d19dd
JB
904}
905
28d77376
GH
906/* if element (a file descriptor or port) appears in *set, cons it to
907 list. return list. */
a48a89bc
GH
908static SCM
909get_element (SELECT_TYPE *set, SCM element, SCM list)
910{
28d77376
GH
911 int fd;
912
913 if (SCM_INUMP (element))
a48a89bc 914 {
28d77376 915 fd = SCM_INUM (element);
a48a89bc 916 }
28d77376 917 else
a48a89bc 918 {
28d77376 919 fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element));
a48a89bc 920 }
28d77376
GH
921 if (FD_ISSET (fd, set))
922 list = scm_cons (element, list);
a48a89bc
GH
923 return list;
924}
1cc91f1b 925
28d77376
GH
926/* construct component of scm_select return value.
927 set: pointer to set of file descriptors found by select to be ready
928 ports_ready: ports ready due to buffering
929 list_or_vec: original list/vector handed to scm_select.
930 the return value is a list/vector of ready ports/file descriptors.
931 works by finding the objects in list which correspond to members of
932 *set and appending them to ports_ready. result is converted to a
933 vector if list_or_vec is a vector. */
0f2d19dd 934static SCM
28d77376 935retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
0f2d19dd 936{
28d77376 937 SCM answer_list = ports_ready;
a48a89bc 938
28d77376 939 if (SCM_VECTORP (list_or_vec))
0f2d19dd 940 {
28d77376
GH
941 int i = SCM_LENGTH (list_or_vec);
942 SCM *ve = SCM_VELTS (list_or_vec);
a48a89bc 943
28d77376 944 while (--i >= 0)
0f2d19dd 945 {
28d77376 946 answer_list = get_element (set, ve[i], answer_list);
0f2d19dd 947 }
a48a89bc
GH
948 return scm_vector (answer_list);
949 }
950 else
951 {
28d77376 952 /* list_or_vec must be a list. */
4260a7fc 953 while (!SCM_NULLP (list_or_vec))
0f2d19dd 954 {
28d77376
GH
955 answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list);
956 list_or_vec = SCM_CDR (list_or_vec);
0f2d19dd 957 }
a48a89bc 958 return answer_list;
0f2d19dd 959 }
0f2d19dd
JB
960}
961
1bbd0b84 962/* Static helper functions above refer to s_scm_select directly as s_select */
a1ec6916 963SCM_DEFINE (scm_select, "select", 3, 2, 0,
1bbd0b84 964 (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
28d77376
GH
965 "This procedure has a variety of uses: waiting for the ability\n"
966 "to provide input, accept output, or the existance of\n"
967 "exceptional conditions on a collection of ports or file\n"
968 "descriptors, or waiting for a timeout to occur.\n"
969 "It also returns if interrupted by a signal.\n\n"
970 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
971 "vectors, with each member a port or a file descriptor.\n"
972 "The value returned is a list of three corresponding\n"
973 "lists or vectors containing only the members which meet the\n"
974 "specified requirement. The ability of port buffers to\n"
975 "provide input or accept output is taken into account.\n"
976 "Ordering of the input lists or vectors is not preserved.\n\n"
977 "The optional arguments @var{secs} and @var{usecs} specify the\n"
978 "timeout. Either @var{secs} can be specified alone, as\n"
979 "either an integer or a real number, or both @var{secs} and\n"
980 "@var{usecs} can be specified as integers, in which case\n"
981 "@var{usecs} is an additional timeout expressed in\n"
982 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
983 "select will wait for as long as it takes for one of the other\n"
984 "conditions to be satisfied.\n\n"
985 "The scsh version of @code{select} differs as follows:\n"
986 "Only vectors are accepted for the first three arguments.\n"
987 "The @var{usecs} argument is not supported.\n"
988 "Multiple values are returned instead of a list.\n"
989 "Duplicates in the input vectors appear only once in output.\n"
990 "An additional @code{select!} interface is provided.\n"
991 )
1bbd0b84 992#define FUNC_NAME s_scm_select
0f2d19dd 993{
0f2d19dd 994 struct timeval timeout;
28d77376 995 struct timeval * time_ptr;
0f2d19dd
JB
996 SELECT_TYPE read_set;
997 SELECT_TYPE write_set;
998 SELECT_TYPE except_set;
28d77376
GH
999 int read_count;
1000 int write_count;
1001 int except_count;
1002 /* these lists accumulate ports which are ready due to buffering.
1003 their file descriptors don't need to be added to the select sets. */
1004 SCM read_ports_ready = SCM_EOL;
1005 SCM write_ports_ready = SCM_EOL;
1006 int max_fd;
1007
1008 if (SCM_VECTORP (reads))
1009 {
1010 read_count = SCM_LENGTH (reads);
1011 }
1012 else
1013 {
1014 read_count = scm_ilength (reads);
1015 SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
1016 }
1017 if (SCM_VECTORP (writes))
1018 {
1019 write_count = SCM_LENGTH (writes);
1020 }
1021 else
1022 {
1023 write_count = scm_ilength (writes);
1024 SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
1025 }
1026 if (SCM_VECTORP (excepts))
1027 {
1028 except_count = SCM_LENGTH (excepts);
1029 }
1030 else
1031 {
1032 except_count = scm_ilength (excepts);
1033 SCM_ASSERT (except_count >= 0, excepts, SCM_ARG3, FUNC_NAME);
1034 }
0f2d19dd
JB
1035
1036 FD_ZERO (&read_set);
1037 FD_ZERO (&write_set);
1038 FD_ZERO (&except_set);
1039
28d77376
GH
1040 max_fd = fill_select_type (&read_set, &read_ports_ready, reads, SCM_ARG1);
1041
1042 {
1043 int write_max = fill_select_type (&write_set, &write_ports_ready,
1044 writes, SCM_ARG2);
1045 int except_max = fill_select_type (&except_set, NULL,
1046 excepts, SCM_ARG3);
1047
1048 if (write_max > max_fd)
1049 max_fd = write_max;
1050 if (except_max > max_fd)
1051 max_fd = except_max;
1052 }
0f2d19dd 1053
ae1b098b
GH
1054 /* if there's a port with a ready buffer, don't block, just
1055 check for ready file descriptors. */
4260a7fc 1056 if (!SCM_NULLP (read_ports_ready) || !SCM_NULLP (write_ports_ready))
ae1b098b
GH
1057 {
1058 timeout.tv_sec = 0;
1059 timeout.tv_usec = 0;
1060 time_ptr = &timeout;
1061 }
1062 else if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
28d77376 1063 time_ptr = 0;
0f2d19dd
JB
1064 else
1065 {
ae1b098b 1066 if (SCM_INUMP (secs))
a48a89bc
GH
1067 {
1068 timeout.tv_sec = SCM_INUM (secs);
1069 if (SCM_UNBNDP (usecs))
1070 timeout.tv_usec = 0;
1071 else
1072 {
3b3b36dd 1073 SCM_VALIDATE_INUM (5,usecs);
a48a89bc
GH
1074 timeout.tv_usec = SCM_INUM (usecs);
1075 }
1076 }
0f2d19dd 1077 else
a48a89bc 1078 {
1bbd0b84 1079 double fl = scm_num2dbl (secs, FUNC_NAME);
a48a89bc
GH
1080
1081 if (!SCM_UNBNDP (usecs))
c1bfcf60 1082 SCM_WRONG_TYPE_ARG (4, secs);
a48a89bc 1083 if (fl > LONG_MAX)
c1bfcf60 1084 SCM_OUT_OF_RANGE (4, secs);
a48a89bc
GH
1085 timeout.tv_sec = (long) fl;
1086 timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
1087 }
28d77376 1088 time_ptr = &timeout;
0f2d19dd
JB
1089 }
1090
28d77376 1091 {
44e8413c 1092#ifdef GUILE_ISELECT
28d77376
GH
1093 int rv = scm_internal_select (max_fd + 1,
1094 &read_set, &write_set, &except_set,
1095 time_ptr);
44e8413c 1096#else
28d77376
GH
1097 int rv = select (max_fd + 1,
1098 &read_set, &write_set, &except_set, time_ptr);
44e8413c 1099#endif
28d77376
GH
1100 if (rv < 0)
1101 SCM_SYSERROR;
1102 }
1103 return scm_listify (retrieve_select_type (&read_set, read_ports_ready,
1104 reads),
1105 retrieve_select_type (&write_set, write_ports_ready,
1106 writes),
1107 retrieve_select_type (&except_set, SCM_EOL, excepts),
02b754d3 1108 SCM_UNDEFINED);
0f2d19dd 1109}
1bbd0b84 1110#undef FUNC_NAME
f25f761d 1111#endif /* HAVE_SELECT */
0f2d19dd
JB
1112
1113\f
4c1feaa5 1114
a1ec6916 1115SCM_DEFINE (scm_fcntl, "fcntl", 2, 0, 1,
1bbd0b84 1116 (SCM object, SCM cmd, SCM value),
d3818c29
MD
1117 "Apply @var{command} to the specified file descriptor or the underlying\n"
1118 "file descriptor of the specified port. @var{value} is an optional\n"
1119 "integer argument.\n\n"
1120 "Values for @var{command} are:\n\n"
1121 "@table @code\n"
1122 "@item F_DUPFD\n"
1123 "Duplicate a file descriptor\n"
1124 "@item F_GETFD\n"
1125 "Get flags associated with the file descriptor.\n"
1126 "@item F_SETFD\n"
1127 "Set flags associated with the file descriptor to @var{value}.\n"
1128 "@item F_GETFL\n"
1129 "Get flags associated with the open file.\n"
1130 "@item F_SETFL\n"
1131 "Set flags associated with the open file to @var{value}\n"
1132 "@item F_GETOWN\n"
1133 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1134 "@item F_SETOWN\n"
1135 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1136 "@item FD_CLOEXEC\n"
a3c8b9fc
MD
1137 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or"
1138 "@code{F_SETFL}."
1139 "@end table")
1bbd0b84 1140#define FUNC_NAME s_scm_fcntl
4c1feaa5
JB
1141{
1142 int rv;
6afcd3b2
GH
1143 int fdes;
1144 int ivalue;
4c1feaa5 1145
78446828
MV
1146 object = SCM_COERCE_OUTPORT (object);
1147
3b3b36dd 1148 SCM_VALIDATE_INUM (2,cmd);
0c95b57d 1149 if (SCM_OPFPORTP (object))
77a76b64 1150 fdes = SCM_FPORT_FDES (object);
6afcd3b2
GH
1151 else
1152 {
3b3b36dd 1153 SCM_VALIDATE_INUM (1,object);
6afcd3b2
GH
1154 fdes = SCM_INUM (object);
1155 }
1156 if (SCM_NULLP (value))
1157 ivalue = 0;
1158 else
1159 {
1bbd0b84 1160 SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, FUNC_NAME);
6afcd3b2
GH
1161 ivalue = SCM_INUM (SCM_CAR (value));
1162 }
77a76b64
JB
1163 SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
1164 if (rv == -1)
1bbd0b84 1165 SCM_SYSERROR;
4c1feaa5
JB
1166 return SCM_MAKINUM (rv);
1167}
1bbd0b84 1168#undef FUNC_NAME
6afcd3b2 1169
a1ec6916 1170SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
1bbd0b84 1171 (SCM object),
d3818c29
MD
1172 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1173 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1174 "file descriptor is fsync'd.\n"
1175 "The return value is unspecified.")
1bbd0b84 1176#define FUNC_NAME s_scm_fsync
6afcd3b2
GH
1177{
1178 int fdes;
1179
78446828
MV
1180 object = SCM_COERCE_OUTPORT (object);
1181
0c95b57d 1182 if (SCM_OPFPORTP (object))
6afcd3b2 1183 {
affc96b5 1184 scm_flush (object);
77a76b64 1185 fdes = SCM_FPORT_FDES (object);
6afcd3b2
GH
1186 }
1187 else
1188 {
3b3b36dd 1189 SCM_VALIDATE_INUM (1,object);
6afcd3b2
GH
1190 fdes = SCM_INUM (object);
1191 }
1192 if (fsync (fdes) == -1)
1bbd0b84 1193 SCM_SYSERROR;
6afcd3b2
GH
1194 return SCM_UNSPECIFIED;
1195}
1bbd0b84 1196#undef FUNC_NAME
0f2d19dd 1197
f25f761d 1198#ifdef HAVE_SYMLINK
a1ec6916 1199SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
1bbd0b84 1200 (SCM oldpath, SCM newpath),
d3818c29
MD
1201 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1202 "@var{path-from}. The return value is unspecified.")
1bbd0b84 1203#define FUNC_NAME s_scm_symlink
0f2d19dd 1204{
0f2d19dd 1205 int val;
02b754d3 1206
3b3b36dd
GB
1207 SCM_VALIDATE_ROSTRING (1,oldpath);
1208 SCM_VALIDATE_ROSTRING (2,newpath);
89958ad0
JB
1209 SCM_COERCE_SUBSTR (oldpath);
1210 SCM_COERCE_SUBSTR (newpath);
1211 SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
02b754d3 1212 if (val != 0)
1bbd0b84 1213 SCM_SYSERROR;
02b754d3 1214 return SCM_UNSPECIFIED;
0f2d19dd 1215}
1bbd0b84 1216#undef FUNC_NAME
f25f761d 1217#endif /* HAVE_SYMLINK */
0f2d19dd 1218
f25f761d 1219#ifdef HAVE_READLINK
a1ec6916 1220SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
1bbd0b84 1221 (SCM path),
d3818c29
MD
1222 "Returns the value of the symbolic link named by\n"
1223 "@var{path} (a string), i.e., the\n"
1224 "file that the link points to.")
1bbd0b84 1225#define FUNC_NAME s_scm_readlink
0f2d19dd 1226{
6a738a25
JB
1227 int rv;
1228 int size = 100;
0f2d19dd
JB
1229 char *buf;
1230 SCM result;
3b3b36dd 1231 SCM_VALIDATE_ROSTRING (1,path);
89958ad0 1232 SCM_COERCE_SUBSTR (path);
1bbd0b84 1233 buf = scm_must_malloc (size, FUNC_NAME);
6a738a25 1234 while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
0f2d19dd
JB
1235 {
1236 scm_must_free (buf);
1237 size *= 2;
1bbd0b84 1238 buf = scm_must_malloc (size, FUNC_NAME);
0f2d19dd 1239 }
02b754d3 1240 if (rv == -1)
1bbd0b84 1241 SCM_SYSERROR;
02b754d3 1242 result = scm_makfromstr (buf, rv, 0);
0f2d19dd 1243 scm_must_free (buf);
0f2d19dd 1244 return result;
0f2d19dd 1245}
1bbd0b84 1246#undef FUNC_NAME
f25f761d 1247#endif /* HAVE_READLINK */
0f2d19dd 1248
f25f761d 1249#ifdef HAVE_LSTAT
a1ec6916 1250SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
1bbd0b84 1251 (SCM str),
d3818c29
MD
1252 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1253 "it will return information about a symbolic link itself, not the \n"
1254 "file it points to. @var{path} must be a string.")
1bbd0b84 1255#define FUNC_NAME s_scm_lstat
0f2d19dd 1256{
02b754d3 1257 int rv;
0f2d19dd 1258 struct stat stat_temp;
02b754d3 1259
3b3b36dd 1260 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
1261 SCM_COERCE_SUBSTR (str);
1262 SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
02b754d3 1263 if (rv != 0)
3d8d56df
GH
1264 {
1265 int en = errno;
1266
5d2d2ffc 1267 SCM_SYSERROR_MSG ("~A: ~S",
3d8d56df
GH
1268 scm_listify (scm_makfrom0str (strerror (errno)),
1269 str,
5d2d2ffc 1270 SCM_UNDEFINED), en);
3d8d56df 1271 }
02b754d3 1272 return scm_stat2scm(&stat_temp);
0f2d19dd 1273}
1bbd0b84 1274#undef FUNC_NAME
f25f761d 1275#endif /* HAVE_LSTAT */
0f2d19dd 1276
a1ec6916 1277SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
1bbd0b84 1278 (SCM oldfile, SCM newfile),
d3818c29
MD
1279 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1280 "The return value is unspecified.")
1bbd0b84 1281#define FUNC_NAME s_scm_copy_file
0f2d19dd
JB
1282{
1283 int oldfd, newfd;
1284 int n;
77a76b64 1285 char buf[BUFSIZ];
0f2d19dd
JB
1286 struct stat oldstat;
1287
3b3b36dd 1288 SCM_VALIDATE_ROSTRING (1,oldfile);
0f2d19dd
JB
1289 if (SCM_SUBSTRP (oldfile))
1290 oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
3b3b36dd 1291 SCM_VALIDATE_ROSTRING (2,newfile);
0f2d19dd
JB
1292 if (SCM_SUBSTRP (newfile))
1293 newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1294 if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1bbd0b84 1295 SCM_SYSERROR;
0f2d19dd
JB
1296 oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1297 if (oldfd == -1)
1bbd0b84 1298 SCM_SYSERROR;
02b754d3
GH
1299
1300 /* use POSIX flags instead of 07777?. */
0f2d19dd
JB
1301 newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1302 oldstat.st_mode & 07777);
1303 if (newfd == -1)
1bbd0b84 1304 SCM_SYSERROR;
02b754d3 1305
0f2d19dd
JB
1306 while ((n = read (oldfd, buf, sizeof buf)) > 0)
1307 if (write (newfd, buf, n) != n)
1308 {
1309 close (oldfd);
1310 close (newfd);
1bbd0b84 1311 SCM_SYSERROR;
0f2d19dd
JB
1312 }
1313 close (oldfd);
1314 if (close (newfd) == -1)
1bbd0b84 1315 SCM_SYSERROR;
02b754d3 1316 return SCM_UNSPECIFIED;
0f2d19dd 1317}
1bbd0b84 1318#undef FUNC_NAME
0f2d19dd
JB
1319
1320\f
6a738a25
JB
1321/* Filename manipulation */
1322
1323SCM scm_dot_string;
1324
a1ec6916 1325SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
1bbd0b84 1326 (SCM filename),
d3818c29 1327 "")
1bbd0b84 1328#define FUNC_NAME s_scm_dirname
6a738a25
JB
1329{
1330 char *s;
1331 int i, len;
3b3b36dd 1332 SCM_VALIDATE_ROSTRING (1,filename);
6a738a25
JB
1333 s = SCM_ROCHARS (filename);
1334 len = SCM_LENGTH (filename);
1335 i = len - 1;
1336 while (i >= 0 && s[i] == '/') --i;
1337 while (i >= 0 && s[i] != '/') --i;
1338 while (i >= 0 && s[i] == '/') --i;
1339 if (i < 0)
1340 {
1341 if (len > 0 && s[0] == '/')
1342 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1343 else
1344 return scm_dot_string;
1345 }
1346 else
1347 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1348}
1bbd0b84 1349#undef FUNC_NAME
6a738a25 1350
a1ec6916 1351SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
1bbd0b84 1352 (SCM filename, SCM suffix),
d3818c29 1353 "")
1bbd0b84 1354#define FUNC_NAME s_scm_basename
6a738a25
JB
1355{
1356 char *f, *s = 0;
1357 int i, j, len, end;
3b3b36dd 1358 SCM_VALIDATE_ROSTRING (1,filename);
6a738a25 1359 SCM_ASSERT (SCM_UNBNDP (suffix)
0c95b57d 1360 || (SCM_ROSTRINGP (suffix)),
6a738a25
JB
1361 suffix,
1362 SCM_ARG2,
1bbd0b84 1363 FUNC_NAME);
6a738a25
JB
1364 f = SCM_ROCHARS (filename);
1365 if (SCM_UNBNDP (suffix))
1366 j = -1;
1367 else
1368 {
1369 s = SCM_ROCHARS (suffix);
1370 j = SCM_LENGTH (suffix) - 1;
1371 }
1372 len = SCM_LENGTH (filename);
1373 i = len - 1;
1374 while (i >= 0 && f[i] == '/') --i;
1375 end = i;
1376 while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1377 if (j == -1)
1378 end = i;
1379 while (i >= 0 && f[i] != '/') --i;
1380 if (i == end)
1381 {
1382 if (len > 0 && f[0] == '/')
1383 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1384 else
1385 return scm_dot_string;
1386 }
1387 else
1388 return scm_make_shared_substring (filename,
1389 SCM_MAKINUM (i + 1),
1390 SCM_MAKINUM (end + 1));
1391}
1bbd0b84 1392#undef FUNC_NAME
6a738a25
JB
1393
1394
1395
1396\f
1cc91f1b 1397
0f2d19dd
JB
1398void
1399scm_init_filesys ()
0f2d19dd 1400{
23a62151
MD
1401 scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
1402 NULL, scm_dir_free,scm_dir_print, NULL);
0f2d19dd 1403
a163dda9
MD
1404 scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1405
3d8d56df
GH
1406#ifdef O_RDONLY
1407scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1408#endif
1409#ifdef O_WRONLY
1410scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1411#endif
1412#ifdef O_RDWR
1413scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1414#endif
1415#ifdef O_CREAT
1416scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1417#endif
1418#ifdef O_EXCL
1419scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1420#endif
1421#ifdef O_NOCTTY
1422scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1423#endif
1424#ifdef O_TRUNC
1425scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1426#endif
1427#ifdef O_APPEND
1428scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1429#endif
6afcd3b2 1430#ifdef O_NONBLOCK
3d8d56df
GH
1431scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1432#endif
1433#ifdef O_NDELAY
1434scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1435#endif
1436#ifdef O_SYNC
1437scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1438#endif
1439
4c1feaa5
JB
1440#ifdef F_DUPFD
1441scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1442#endif
1443#ifdef F_GETFD
1444scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1445#endif
1446#ifdef F_SETFD
1447scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1448#endif
1449#ifdef F_GETFL
1450scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1451#endif
1452#ifdef F_SETFL
1453scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1454#endif
1455#ifdef F_GETOWN
1456scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1457#endif
1458#ifdef F_SETOWN
1459scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1460#endif
1461#ifdef FD_CLOEXEC
1462scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
bd9e24b3 1463#endif
3d8d56df 1464
a0599745 1465#include "libguile/filesys.x"
0f2d19dd 1466}
89e00824
ML
1467
1468/*
1469 Local Variables:
1470 c-file-style: "gnu"
1471 End:
1472*/