Corrected "Brat" to "Brad". Sorry.
[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;
e655d034 401#ifdef S_ISSOCK
ae5253c5
GH
402 else if (S_ISSOCK (mode))
403 ve[13] = scm_sym_sock;
e655d034 404#endif
ae5253c5
GH
405 else
406 ve[13] = scm_sym_unknown;
407
408 ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
409
410 /* the layout of the bits in ve[14] is intended to be portable.
411 If there are systems that don't follow the usual convention,
412 the following could be used:
413
414 tmp = 0;
415 if (S_ISUID & mode) tmp += 1;
416 tmp <<= 1;
417 if (S_IRGRP & mode) tmp += 1;
418 tmp <<= 1;
419 if (S_ISVTX & mode) tmp += 1;
420 tmp <<= 1;
421 if (S_IRUSR & mode) tmp += 1;
422 tmp <<= 1;
423 if (S_IWUSR & mode) tmp += 1;
424 tmp <<= 1;
425 if (S_IXUSR & mode) tmp += 1;
426 tmp <<= 1;
427 if (S_IWGRP & mode) tmp += 1;
428 tmp <<= 1;
429 if (S_IXGRP & mode) tmp += 1;
430 tmp <<= 1;
431 if (S_IROTH & mode) tmp += 1;
432 tmp <<= 1;
433 if (S_IWOTH & mode) tmp += 1;
434 tmp <<= 1;
435 if (S_IXOTH & mode) tmp += 1;
436
437 ve[14] = SCM_MAKINUM (tmp);
438
439 */
440 }
0f2d19dd
JB
441
442 return ans;
443}
444
a1ec6916 445SCM_DEFINE (scm_stat, "stat", 1, 0, 0,
1bbd0b84 446 (SCM object),
d3818c29
MD
447 "Returns an object containing various information\n"
448 "about the file determined by @var{obj}.\n"
449 "@var{obj} can be a string containing a file name or a port or integer file\n"
450 "descriptor which is open on a file (in which case @code{fstat} is used\n"
451 "as the underlying system call).\n\n"
452 "The object returned by @code{stat} can be passed as a single parameter\n"
453 "to the following procedures, all of which return integers:\n\n"
454 "@table @code\n"
455 "@item stat:dev\n"
456 "The device containing the file.\n"
457 "@item stat:ino\n"
458 "The file serial number, which distinguishes this file from all other\n"
459 "files on the same device.\n"
460 "@item stat:mode\n"
461 "The mode of the file. This includes file type information\n"
462 "and the file permission bits. See @code{stat:type} and @code{stat:perms}\n"
463 "below.\n"
464 "@item stat:nlink\n"
465 "The number of hard links to the file.\n"
466 "@item stat:uid\n"
467 "The user ID of the file's owner.\n"
468 "@item stat:gid\n"
469 "The group ID of the file.\n"
470 "@item stat:rdev\n"
471 "Device ID; this entry is defined only for character or block\n"
472 "special files.\n"
473 "@item stat:size\n"
474 "The size of a regular file in bytes.\n"
475 "@item stat:atime\n"
476 "The last access time for the file.\n"
477 "@item stat:mtime\n"
478 "The last modification time for the file.\n"
479 "@item stat:ctime\n"
480 "The last modification time for the attributes of the file.\n"
481 "@item stat:blksize\n"
482 "The optimal block size for reading or writing the file, in bytes.\n"
483 "@item stat:blocks\n"
484 "The amount of disk space that the file occupies measured in units of\n"
485 "512 byte blocks.\n"
486 "@end table\n\n"
487 "In addition, the following procedures return the information\n"
488 "from stat:mode in a more convenient form:\n\n"
489 "@table @code\n"
490 "@item stat:type\n"
491 "A symbol representing the type of file. Possible values are\n"
492 "regular, directory, symlink, block-special, char-special,\n"
493 "fifo, socket and unknown\n"
494 "@item stat:perms\n"
495 "An integer representing the access permission bits.\n"
496 "@end table")
1bbd0b84 497#define FUNC_NAME s_scm_stat
0f2d19dd 498{
6afcd3b2
GH
499 int rv;
500 int fdes;
0f2d19dd
JB
501 struct stat stat_temp;
502
1ea47048
MD
503 if (SCM_INUMP (object))
504 SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
505 else
0f2d19dd 506 {
6b5a304f 507 SCM_VALIDATE_NIM (1,object);
1ea47048
MD
508 if (SCM_ROSTRINGP (object))
509 {
510 SCM_COERCE_SUBSTR (object);
511 SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
512 }
c0ebd8c5 513 else
0f2d19dd 514 {
1ea47048 515 object = SCM_COERCE_OUTPORT (object);
c1bfcf60 516 SCM_VALIDATE_OPFPORT(1,object);
77a76b64 517 fdes = SCM_FPORT_FDES (object);
1ea47048 518 SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
0f2d19dd 519 }
6afcd3b2
GH
520 }
521 if (rv == -1)
3d8d56df
GH
522 {
523 int en = errno;
524
5d2d2ffc 525 SCM_SYSERROR_MSG ("~A: ~S",
3d8d56df 526 scm_listify (scm_makfrom0str (strerror (errno)),
6afcd3b2 527 object,
5d2d2ffc 528 SCM_UNDEFINED), en);
3d8d56df 529 }
02b754d3 530 return scm_stat2scm (&stat_temp);
0f2d19dd 531}
1bbd0b84 532#undef FUNC_NAME
0f2d19dd 533
0f2d19dd
JB
534\f
535/* {Modifying Directories}
536 */
537
a1ec6916 538SCM_DEFINE (scm_link, "link", 2, 0, 0,
1bbd0b84 539 (SCM oldpath, SCM newpath),
d3818c29
MD
540 "Creates a new name @var{path-to} in the file system for the file\n"
541 "named by @var{path-from}. If @var{path-from} is a symbolic link, the\n"
542 "link may or may not be followed depending on the system.")
1bbd0b84 543#define FUNC_NAME s_scm_link
0f2d19dd
JB
544{
545 int val;
02b754d3 546
3b3b36dd 547 SCM_VALIDATE_ROSTRING (1,oldpath);
0f2d19dd 548 if (SCM_SUBSTRP (oldpath))
6afcd3b2
GH
549 oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
550 SCM_ROLENGTH (oldpath), 0);
3b3b36dd 551 SCM_VALIDATE_ROSTRING (2,newpath);
0f2d19dd 552 if (SCM_SUBSTRP (newpath))
6afcd3b2
GH
553 newpath = scm_makfromstr (SCM_ROCHARS (newpath),
554 SCM_ROLENGTH (newpath), 0);
0f2d19dd 555 SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
02b754d3 556 if (val != 0)
1bbd0b84 557 SCM_SYSERROR;
02b754d3 558 return SCM_UNSPECIFIED;
0f2d19dd 559}
1bbd0b84 560#undef FUNC_NAME
0f2d19dd
JB
561
562
563
a1ec6916 564SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
1bbd0b84 565 (SCM oldname, SCM newname),
d3818c29
MD
566 "Renames the file specified by @var{path-from} to @var{path-to}.\n"
567 "The return value is unspecified.")
1bbd0b84 568#define FUNC_NAME s_scm_rename
0f2d19dd
JB
569{
570 int rv;
3b3b36dd
GB
571 SCM_VALIDATE_ROSTRING (1,oldname);
572 SCM_VALIDATE_ROSTRING (2,newname);
89958ad0
JB
573 SCM_COERCE_SUBSTR (oldname);
574 SCM_COERCE_SUBSTR (newname);
0f2d19dd 575#ifdef HAVE_RENAME
89958ad0 576 SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
0f2d19dd 577#else
89958ad0 578 SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
02b754d3 579 if (rv == 0)
0f2d19dd 580 {
89958ad0 581 SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
02b754d3 582 if (rv != 0)
0f2d19dd 583 /* unlink failed. remove new name */
89958ad0 584 SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
0f2d19dd 585 }
6afcd3b2 586#endif
02b754d3 587 if (rv != 0)
1bbd0b84 588 SCM_SYSERROR;
02b754d3 589 return SCM_UNSPECIFIED;
0f2d19dd 590}
1bbd0b84 591#undef FUNC_NAME
0f2d19dd
JB
592
593
3b3b36dd 594SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
1bbd0b84 595 (SCM str),
d3818c29 596 "Deletes (or \"unlinks\") the file specified by @var{path}.")
1bbd0b84 597#define FUNC_NAME s_scm_delete_file
2f3ed1ba
JB
598{
599 int ans;
3b3b36dd 600 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
601 SCM_COERCE_SUBSTR (str);
602 SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
2f3ed1ba 603 if (ans != 0)
1bbd0b84 604 SCM_SYSERROR;
2f3ed1ba
JB
605 return SCM_UNSPECIFIED;
606}
1bbd0b84 607#undef FUNC_NAME
2f3ed1ba 608
f25f761d 609#ifdef HAVE_MKDIR
a1ec6916 610SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
1bbd0b84 611 (SCM path, SCM mode),
d3818c29
MD
612 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
613 "then the permissions of the directory file are set using the current\n"
614 "umask. Otherwise they are set to the decimal value specified with\n"
615 "@var{mode}. The return value is unspecified.")
1bbd0b84 616#define FUNC_NAME s_scm_mkdir
0f2d19dd 617{
0f2d19dd
JB
618 int rv;
619 mode_t mask;
3b3b36dd 620 SCM_VALIDATE_ROSTRING (1,path);
89958ad0 621 SCM_COERCE_SUBSTR (path);
0f2d19dd
JB
622 if (SCM_UNBNDP (mode))
623 {
624 mask = umask (0);
625 umask (mask);
89958ad0 626 SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
0f2d19dd
JB
627 }
628 else
629 {
3b3b36dd 630 SCM_VALIDATE_INUM (2,mode);
89958ad0 631 SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
0f2d19dd 632 }
02b754d3 633 if (rv != 0)
1bbd0b84 634 SCM_SYSERROR;
02b754d3 635 return SCM_UNSPECIFIED;
0f2d19dd 636}
1bbd0b84 637#undef FUNC_NAME
f25f761d 638#endif /* HAVE_MKDIR */
0f2d19dd 639
f25f761d 640#ifdef HAVE_RMDIR
a1ec6916 641SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
1bbd0b84 642 (SCM path),
d3818c29
MD
643 "Remove the existing directory named by @var{path}. The directory must\n"
644 "be empty for this to succeed. The return value is unspecified.")
1bbd0b84 645#define FUNC_NAME s_scm_rmdir
0f2d19dd 646{
0f2d19dd 647 int val;
02b754d3 648
3b3b36dd 649 SCM_VALIDATE_ROSTRING (1,path);
89958ad0
JB
650 SCM_COERCE_SUBSTR (path);
651 SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
02b754d3 652 if (val != 0)
1bbd0b84 653 SCM_SYSERROR;
02b754d3 654 return SCM_UNSPECIFIED;
0f2d19dd 655}
1bbd0b84 656#undef FUNC_NAME
f25f761d 657#endif
0f2d19dd
JB
658
659\f
660/* {Examining Directories}
661 */
662
663long scm_tc16_dir;
664
a1ec6916 665SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
1bbd0b84 666 (SCM obj),
d3818c29
MD
667 "Returns a boolean indicating whether @var{object} is a directory stream\n"
668 "as returned by @code{opendir}.")
1bbd0b84 669#define FUNC_NAME s_scm_directory_stream_p
77242ff9 670{
0c95b57d 671 return SCM_BOOL(SCM_DIRP (obj));
77242ff9 672}
1bbd0b84 673#undef FUNC_NAME
77242ff9 674
a1ec6916 675SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
1bbd0b84 676 (SCM dirname),
d3818c29
MD
677 "Open the directory specified by @var{path} and return a directory\n"
678 "stream.")
1bbd0b84 679#define FUNC_NAME s_scm_opendir
0f2d19dd
JB
680{
681 DIR *ds;
3b3b36dd 682 SCM_VALIDATE_ROSTRING (1,dirname);
89958ad0 683 SCM_COERCE_SUBSTR (dirname);
89958ad0 684 SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
02b754d3 685 if (ds == NULL)
1bbd0b84 686 SCM_SYSERROR;
23a62151 687 SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
0f2d19dd 688}
1bbd0b84 689#undef FUNC_NAME
0f2d19dd
JB
690
691
a1ec6916 692SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
1bbd0b84 693 (SCM port),
d3818c29
MD
694 "Return (as a string) the next directory entry from the directory stream\n"
695 "@var{stream}. If there is no remaining entry to be read then the\n"
696 "end of file object is returned.")
1bbd0b84 697#define FUNC_NAME s_scm_readdir
0f2d19dd
JB
698{
699 struct dirent *rdent;
3b3b36dd 700 SCM_VALIDATE_OPDIR (1,port);
0f2d19dd 701 errno = 0;
4260a7fc 702 SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port)));
02b754d3 703 if (errno != 0)
1bbd0b84 704 SCM_SYSERROR;
02b754d3
GH
705 return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
706 : SCM_EOF_VAL);
0f2d19dd 707}
1bbd0b84 708#undef FUNC_NAME
0f2d19dd
JB
709
710
711
a1ec6916 712SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
1bbd0b84 713 (SCM port),
d3818c29
MD
714 "Reset the directory port @var{stream} so that the next call to\n"
715 "@code{readdir} will return the first directory entry.")
1bbd0b84 716#define FUNC_NAME s_scm_rewinddir
0f2d19dd 717{
3b3b36dd 718 SCM_VALIDATE_OPDIR (1,port);
4260a7fc 719 rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
0f2d19dd
JB
720 return SCM_UNSPECIFIED;
721}
1bbd0b84 722#undef FUNC_NAME
0f2d19dd
JB
723
724
725
a1ec6916 726SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
1bbd0b84 727 (SCM port),
d3818c29
MD
728 "Close the directory stream @var{stream}.\n"
729 "The return value is unspecified.")
1bbd0b84 730#define FUNC_NAME s_scm_closedir
0f2d19dd
JB
731{
732 int sts;
02b754d3 733
3b3b36dd 734 SCM_VALIDATE_DIR (1,port);
0f2d19dd
JB
735 if (SCM_CLOSEDP (port))
736 {
02b754d3 737 return SCM_UNSPECIFIED;
0f2d19dd 738 }
4260a7fc 739 SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
02b754d3 740 if (sts != 0)
1bbd0b84 741 SCM_SYSERROR;
4260a7fc 742 SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
02b754d3 743 return SCM_UNSPECIFIED;
0f2d19dd 744}
1bbd0b84 745#undef FUNC_NAME
0f2d19dd
JB
746
747
748
1cc91f1b 749
0f2d19dd 750static int
f8b16091 751scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
0f2d19dd 752{
f8b16091
MD
753 scm_puts ("#<", port);
754 if (SCM_CLOSEDP (exp))
755 scm_puts ("closed: ", port);
0d03da62 756 scm_puts ("directory stream ", port);
4260a7fc 757 scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
f8b16091 758 scm_putc ('>', port);
0f2d19dd
JB
759 return 1;
760}
761
1cc91f1b 762
0f2d19dd 763static scm_sizet
1bbd0b84 764scm_dir_free (SCM p)
0f2d19dd
JB
765{
766 if (SCM_OPENP (p))
4260a7fc 767 closedir ((DIR *) SCM_CELL_WORD_1 (p));
0f2d19dd
JB
768 return 0;
769}
770
0f2d19dd
JB
771\f
772/* {Navigating Directories}
773 */
774
775
a1ec6916 776SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
1bbd0b84 777 (SCM str),
d3818c29
MD
778 "Change the current working directory to @var{path}.\n"
779 "The return value is unspecified.")
1bbd0b84 780#define FUNC_NAME s_scm_chdir
0f2d19dd
JB
781{
782 int ans;
02b754d3 783
3b3b36dd 784 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
785 SCM_COERCE_SUBSTR (str);
786 SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
02b754d3 787 if (ans != 0)
1bbd0b84 788 SCM_SYSERROR;
02b754d3 789 return SCM_UNSPECIFIED;
0f2d19dd 790}
1bbd0b84 791#undef FUNC_NAME
0f2d19dd 792
f25f761d 793#ifdef HAVE_GETCWD
a1ec6916 794SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
1bbd0b84 795 (),
d3818c29 796 "Returns the name of the current working directory.")
1bbd0b84 797#define FUNC_NAME s_scm_getcwd
0f2d19dd 798{
0f2d19dd 799 char *rv;
0f2d19dd
JB
800 scm_sizet size = 100;
801 char *wd;
802 SCM result;
803
1bbd0b84 804 wd = scm_must_malloc (size, FUNC_NAME);
0f2d19dd
JB
805 while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
806 {
807 scm_must_free (wd);
808 size *= 2;
1bbd0b84 809 wd = scm_must_malloc (size, FUNC_NAME);
0f2d19dd 810 }
02b754d3 811 if (rv == 0)
1bbd0b84 812 SCM_SYSERROR;
02b754d3 813 result = scm_makfromstr (wd, strlen (wd), 0);
0f2d19dd 814 scm_must_free (wd);
0f2d19dd 815 return result;
0f2d19dd 816}
1bbd0b84 817#undef FUNC_NAME
f25f761d 818#endif /* HAVE_GETCWD */
0f2d19dd
JB
819
820\f
821
28d77376
GH
822#ifdef HAVE_SELECT
823
824/* check that element is a port or file descriptor. if it's a port
825 and its buffer is ready for use, add it to the ports_ready list.
826 otherwise add its file descriptor to *set. the type of list can be
827 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
828 SCM_ARG3 for excepts. */
cafc12ff 829static int
28d77376 830set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
a48a89bc 831{
cafc12ff 832 int fd;
d831b039 833
28d77376
GH
834 if (SCM_INUMP (element))
835 {
836 fd = SCM_INUM (element);
837 }
838 else
839 {
840 int use_buf = 0;
841
842 element = SCM_COERCE_OUTPORT (element);
843 SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select");
844 if (pos == SCM_ARG1)
845 {
846 /* check whether port has buffered input. */
847 scm_port *pt = SCM_PTAB_ENTRY (element);
848
849 if (pt->read_pos < pt->read_end)
850 use_buf = 1;
851 }
852 else if (pos == SCM_ARG2)
853 {
854 /* check whether port's output buffer has room. */
855 scm_port *pt = SCM_PTAB_ENTRY (element);
856
857 /* > 1 since writing the last byte in the buffer causes flush. */
858 if (pt->write_end - pt->write_pos > 1)
859 use_buf = 1;
860 }
861 fd = use_buf ? -1 : SCM_FPORT_FDES (element);
862 }
863 if (fd == -1)
864 *ports_ready = scm_cons (element, *ports_ready);
865 else
866 FD_SET (fd, set);
cafc12ff 867 return fd;
a48a89bc 868}
1cc91f1b 869
28d77376
GH
870/* check list_or_vec, a list or vector of ports or file descriptors,
871 adding each member to either the ports_ready list (if it's a port
872 with a usable buffer) or to *set. the kind of list_or_vec can be
873 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
874 SCM_ARG3 for excepts. */
cafc12ff 875static int
28d77376 876fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
0f2d19dd 877{
28d77376
GH
878 int max_fd = 0;
879
880 if (SCM_VECTORP (list_or_vec))
0f2d19dd 881 {
9fd38a3d 882 int i = SCM_VECTOR_LENGTH (list_or_vec);
28d77376 883 SCM *ve = SCM_VELTS (list_or_vec);
a48a89bc 884
28d77376 885 while (--i >= 0)
a48a89bc 886 {
28d77376
GH
887 int fd = set_element (set, ports_ready, ve[i], pos);
888
cafc12ff
MD
889 if (fd > max_fd)
890 max_fd = fd;
a48a89bc
GH
891 }
892 }
893 else
894 {
4260a7fc 895 while (!SCM_NULLP (list_or_vec))
a48a89bc 896 {
28d77376
GH
897 int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos);
898
cafc12ff
MD
899 if (fd > max_fd)
900 max_fd = fd;
28d77376 901 list_or_vec = SCM_CDR (list_or_vec);
a48a89bc 902 }
0f2d19dd 903 }
cafc12ff
MD
904
905 return max_fd;
0f2d19dd
JB
906}
907
28d77376
GH
908/* if element (a file descriptor or port) appears in *set, cons it to
909 list. return list. */
a48a89bc
GH
910static SCM
911get_element (SELECT_TYPE *set, SCM element, SCM list)
912{
28d77376
GH
913 int fd;
914
915 if (SCM_INUMP (element))
a48a89bc 916 {
28d77376 917 fd = SCM_INUM (element);
a48a89bc 918 }
28d77376 919 else
a48a89bc 920 {
28d77376 921 fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element));
a48a89bc 922 }
28d77376
GH
923 if (FD_ISSET (fd, set))
924 list = scm_cons (element, list);
a48a89bc
GH
925 return list;
926}
1cc91f1b 927
28d77376
GH
928/* construct component of scm_select return value.
929 set: pointer to set of file descriptors found by select to be ready
930 ports_ready: ports ready due to buffering
931 list_or_vec: original list/vector handed to scm_select.
932 the return value is a list/vector of ready ports/file descriptors.
933 works by finding the objects in list which correspond to members of
934 *set and appending them to ports_ready. result is converted to a
935 vector if list_or_vec is a vector. */
0f2d19dd 936static SCM
28d77376 937retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
0f2d19dd 938{
28d77376 939 SCM answer_list = ports_ready;
a48a89bc 940
28d77376 941 if (SCM_VECTORP (list_or_vec))
0f2d19dd 942 {
9fd38a3d 943 int i = SCM_VECTOR_LENGTH (list_or_vec);
28d77376 944 SCM *ve = SCM_VELTS (list_or_vec);
a48a89bc 945
28d77376 946 while (--i >= 0)
0f2d19dd 947 {
28d77376 948 answer_list = get_element (set, ve[i], answer_list);
0f2d19dd 949 }
a48a89bc
GH
950 return scm_vector (answer_list);
951 }
952 else
953 {
28d77376 954 /* list_or_vec must be a list. */
4260a7fc 955 while (!SCM_NULLP (list_or_vec))
0f2d19dd 956 {
28d77376
GH
957 answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list);
958 list_or_vec = SCM_CDR (list_or_vec);
0f2d19dd 959 }
a48a89bc 960 return answer_list;
0f2d19dd 961 }
0f2d19dd
JB
962}
963
1bbd0b84 964/* Static helper functions above refer to s_scm_select directly as s_select */
a1ec6916 965SCM_DEFINE (scm_select, "select", 3, 2, 0,
1bbd0b84 966 (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
28d77376
GH
967 "This procedure has a variety of uses: waiting for the ability\n"
968 "to provide input, accept output, or the existance of\n"
969 "exceptional conditions on a collection of ports or file\n"
970 "descriptors, or waiting for a timeout to occur.\n"
971 "It also returns if interrupted by a signal.\n\n"
972 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
973 "vectors, with each member a port or a file descriptor.\n"
974 "The value returned is a list of three corresponding\n"
975 "lists or vectors containing only the members which meet the\n"
976 "specified requirement. The ability of port buffers to\n"
977 "provide input or accept output is taken into account.\n"
978 "Ordering of the input lists or vectors is not preserved.\n\n"
979 "The optional arguments @var{secs} and @var{usecs} specify the\n"
980 "timeout. Either @var{secs} can be specified alone, as\n"
981 "either an integer or a real number, or both @var{secs} and\n"
982 "@var{usecs} can be specified as integers, in which case\n"
983 "@var{usecs} is an additional timeout expressed in\n"
984 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
985 "select will wait for as long as it takes for one of the other\n"
986 "conditions to be satisfied.\n\n"
987 "The scsh version of @code{select} differs as follows:\n"
988 "Only vectors are accepted for the first three arguments.\n"
989 "The @var{usecs} argument is not supported.\n"
990 "Multiple values are returned instead of a list.\n"
991 "Duplicates in the input vectors appear only once in output.\n"
992 "An additional @code{select!} interface is provided.\n"
993 )
1bbd0b84 994#define FUNC_NAME s_scm_select
0f2d19dd 995{
0f2d19dd 996 struct timeval timeout;
28d77376 997 struct timeval * time_ptr;
0f2d19dd
JB
998 SELECT_TYPE read_set;
999 SELECT_TYPE write_set;
1000 SELECT_TYPE except_set;
28d77376
GH
1001 int read_count;
1002 int write_count;
1003 int except_count;
1004 /* these lists accumulate ports which are ready due to buffering.
1005 their file descriptors don't need to be added to the select sets. */
1006 SCM read_ports_ready = SCM_EOL;
1007 SCM write_ports_ready = SCM_EOL;
1008 int max_fd;
1009
1010 if (SCM_VECTORP (reads))
1011 {
9fd38a3d 1012 read_count = SCM_VECTOR_LENGTH (reads);
28d77376
GH
1013 }
1014 else
1015 {
1016 read_count = scm_ilength (reads);
1017 SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
1018 }
1019 if (SCM_VECTORP (writes))
1020 {
9fd38a3d 1021 write_count = SCM_VECTOR_LENGTH (writes);
28d77376
GH
1022 }
1023 else
1024 {
1025 write_count = scm_ilength (writes);
1026 SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
1027 }
1028 if (SCM_VECTORP (excepts))
1029 {
9fd38a3d 1030 except_count = SCM_VECTOR_LENGTH (excepts);
28d77376
GH
1031 }
1032 else
1033 {
1034 except_count = scm_ilength (excepts);
1035 SCM_ASSERT (except_count >= 0, excepts, SCM_ARG3, FUNC_NAME);
1036 }
0f2d19dd
JB
1037
1038 FD_ZERO (&read_set);
1039 FD_ZERO (&write_set);
1040 FD_ZERO (&except_set);
1041
28d77376
GH
1042 max_fd = fill_select_type (&read_set, &read_ports_ready, reads, SCM_ARG1);
1043
1044 {
1045 int write_max = fill_select_type (&write_set, &write_ports_ready,
1046 writes, SCM_ARG2);
1047 int except_max = fill_select_type (&except_set, NULL,
1048 excepts, SCM_ARG3);
1049
1050 if (write_max > max_fd)
1051 max_fd = write_max;
1052 if (except_max > max_fd)
1053 max_fd = except_max;
1054 }
0f2d19dd 1055
ae1b098b
GH
1056 /* if there's a port with a ready buffer, don't block, just
1057 check for ready file descriptors. */
4260a7fc 1058 if (!SCM_NULLP (read_ports_ready) || !SCM_NULLP (write_ports_ready))
ae1b098b
GH
1059 {
1060 timeout.tv_sec = 0;
1061 timeout.tv_usec = 0;
1062 time_ptr = &timeout;
1063 }
1064 else if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
28d77376 1065 time_ptr = 0;
0f2d19dd
JB
1066 else
1067 {
ae1b098b 1068 if (SCM_INUMP (secs))
a48a89bc
GH
1069 {
1070 timeout.tv_sec = SCM_INUM (secs);
1071 if (SCM_UNBNDP (usecs))
1072 timeout.tv_usec = 0;
1073 else
1074 {
3b3b36dd 1075 SCM_VALIDATE_INUM (5,usecs);
a48a89bc
GH
1076 timeout.tv_usec = SCM_INUM (usecs);
1077 }
1078 }
0f2d19dd 1079 else
a48a89bc 1080 {
1bbd0b84 1081 double fl = scm_num2dbl (secs, FUNC_NAME);
a48a89bc
GH
1082
1083 if (!SCM_UNBNDP (usecs))
c1bfcf60 1084 SCM_WRONG_TYPE_ARG (4, secs);
a48a89bc 1085 if (fl > LONG_MAX)
c1bfcf60 1086 SCM_OUT_OF_RANGE (4, secs);
a48a89bc
GH
1087 timeout.tv_sec = (long) fl;
1088 timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
1089 }
28d77376 1090 time_ptr = &timeout;
0f2d19dd
JB
1091 }
1092
28d77376 1093 {
44e8413c 1094#ifdef GUILE_ISELECT
28d77376
GH
1095 int rv = scm_internal_select (max_fd + 1,
1096 &read_set, &write_set, &except_set,
1097 time_ptr);
44e8413c 1098#else
28d77376
GH
1099 int rv = select (max_fd + 1,
1100 &read_set, &write_set, &except_set, time_ptr);
44e8413c 1101#endif
28d77376
GH
1102 if (rv < 0)
1103 SCM_SYSERROR;
1104 }
1105 return scm_listify (retrieve_select_type (&read_set, read_ports_ready,
1106 reads),
1107 retrieve_select_type (&write_set, write_ports_ready,
1108 writes),
1109 retrieve_select_type (&except_set, SCM_EOL, excepts),
02b754d3 1110 SCM_UNDEFINED);
0f2d19dd 1111}
1bbd0b84 1112#undef FUNC_NAME
f25f761d 1113#endif /* HAVE_SELECT */
0f2d19dd
JB
1114
1115\f
4c1feaa5 1116
af45e3b0 1117SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
1bbd0b84 1118 (SCM object, SCM cmd, SCM value),
d3818c29
MD
1119 "Apply @var{command} to the specified file descriptor or the underlying\n"
1120 "file descriptor of the specified port. @var{value} is an optional\n"
1121 "integer argument.\n\n"
1122 "Values for @var{command} are:\n\n"
1123 "@table @code\n"
1124 "@item F_DUPFD\n"
1125 "Duplicate a file descriptor\n"
1126 "@item F_GETFD\n"
1127 "Get flags associated with the file descriptor.\n"
1128 "@item F_SETFD\n"
1129 "Set flags associated with the file descriptor to @var{value}.\n"
1130 "@item F_GETFL\n"
1131 "Get flags associated with the open file.\n"
1132 "@item F_SETFL\n"
1133 "Set flags associated with the open file to @var{value}\n"
1134 "@item F_GETOWN\n"
1135 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
1136 "@item F_SETOWN\n"
1137 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
1138 "@item FD_CLOEXEC\n"
55892d87
NJ
1139 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
1140 "@code{F_SETFL}.\n"
a3c8b9fc 1141 "@end table")
1bbd0b84 1142#define FUNC_NAME s_scm_fcntl
4c1feaa5
JB
1143{
1144 int rv;
6afcd3b2
GH
1145 int fdes;
1146 int ivalue;
4c1feaa5 1147
78446828
MV
1148 object = SCM_COERCE_OUTPORT (object);
1149
3b3b36dd 1150 SCM_VALIDATE_INUM (2,cmd);
0c95b57d 1151 if (SCM_OPFPORTP (object))
77a76b64 1152 fdes = SCM_FPORT_FDES (object);
6afcd3b2
GH
1153 else
1154 {
3b3b36dd 1155 SCM_VALIDATE_INUM (1,object);
6afcd3b2
GH
1156 fdes = SCM_INUM (object);
1157 }
af45e3b0
DH
1158
1159 if (SCM_UNBNDP (value)) {
6afcd3b2 1160 ivalue = 0;
af45e3b0
DH
1161 } else {
1162 SCM_VALIDATE_INUM_COPY (SCM_ARG3, value, ivalue);
1163 }
1164
77a76b64
JB
1165 SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
1166 if (rv == -1)
1bbd0b84 1167 SCM_SYSERROR;
4c1feaa5
JB
1168 return SCM_MAKINUM (rv);
1169}
1bbd0b84 1170#undef FUNC_NAME
6afcd3b2 1171
a1ec6916 1172SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
1bbd0b84 1173 (SCM object),
d3818c29
MD
1174 "Copies any unwritten data for the specified output file descriptor to disk.\n"
1175 "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
1176 "file descriptor is fsync'd.\n"
1177 "The return value is unspecified.")
1bbd0b84 1178#define FUNC_NAME s_scm_fsync
6afcd3b2
GH
1179{
1180 int fdes;
1181
78446828
MV
1182 object = SCM_COERCE_OUTPORT (object);
1183
0c95b57d 1184 if (SCM_OPFPORTP (object))
6afcd3b2 1185 {
affc96b5 1186 scm_flush (object);
77a76b64 1187 fdes = SCM_FPORT_FDES (object);
6afcd3b2
GH
1188 }
1189 else
1190 {
3b3b36dd 1191 SCM_VALIDATE_INUM (1,object);
6afcd3b2
GH
1192 fdes = SCM_INUM (object);
1193 }
1194 if (fsync (fdes) == -1)
1bbd0b84 1195 SCM_SYSERROR;
6afcd3b2
GH
1196 return SCM_UNSPECIFIED;
1197}
1bbd0b84 1198#undef FUNC_NAME
0f2d19dd 1199
f25f761d 1200#ifdef HAVE_SYMLINK
a1ec6916 1201SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
1bbd0b84 1202 (SCM oldpath, SCM newpath),
d3818c29
MD
1203 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
1204 "@var{path-from}. The return value is unspecified.")
1bbd0b84 1205#define FUNC_NAME s_scm_symlink
0f2d19dd 1206{
0f2d19dd 1207 int val;
02b754d3 1208
3b3b36dd
GB
1209 SCM_VALIDATE_ROSTRING (1,oldpath);
1210 SCM_VALIDATE_ROSTRING (2,newpath);
89958ad0
JB
1211 SCM_COERCE_SUBSTR (oldpath);
1212 SCM_COERCE_SUBSTR (newpath);
1213 SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
02b754d3 1214 if (val != 0)
1bbd0b84 1215 SCM_SYSERROR;
02b754d3 1216 return SCM_UNSPECIFIED;
0f2d19dd 1217}
1bbd0b84 1218#undef FUNC_NAME
f25f761d 1219#endif /* HAVE_SYMLINK */
0f2d19dd 1220
f25f761d 1221#ifdef HAVE_READLINK
a1ec6916 1222SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
1bbd0b84 1223 (SCM path),
d3818c29
MD
1224 "Returns the value of the symbolic link named by\n"
1225 "@var{path} (a string), i.e., the\n"
1226 "file that the link points to.")
1bbd0b84 1227#define FUNC_NAME s_scm_readlink
0f2d19dd 1228{
6a738a25
JB
1229 int rv;
1230 int size = 100;
0f2d19dd
JB
1231 char *buf;
1232 SCM result;
3b3b36dd 1233 SCM_VALIDATE_ROSTRING (1,path);
89958ad0 1234 SCM_COERCE_SUBSTR (path);
1bbd0b84 1235 buf = scm_must_malloc (size, FUNC_NAME);
6a738a25 1236 while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
0f2d19dd
JB
1237 {
1238 scm_must_free (buf);
1239 size *= 2;
1bbd0b84 1240 buf = scm_must_malloc (size, FUNC_NAME);
0f2d19dd 1241 }
02b754d3 1242 if (rv == -1)
1bbd0b84 1243 SCM_SYSERROR;
02b754d3 1244 result = scm_makfromstr (buf, rv, 0);
0f2d19dd 1245 scm_must_free (buf);
0f2d19dd 1246 return result;
0f2d19dd 1247}
1bbd0b84 1248#undef FUNC_NAME
f25f761d 1249#endif /* HAVE_READLINK */
0f2d19dd 1250
f25f761d 1251#ifdef HAVE_LSTAT
a1ec6916 1252SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
1bbd0b84 1253 (SCM str),
d3818c29
MD
1254 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
1255 "it will return information about a symbolic link itself, not the \n"
1256 "file it points to. @var{path} must be a string.")
1bbd0b84 1257#define FUNC_NAME s_scm_lstat
0f2d19dd 1258{
02b754d3 1259 int rv;
0f2d19dd 1260 struct stat stat_temp;
02b754d3 1261
3b3b36dd 1262 SCM_VALIDATE_ROSTRING (1,str);
89958ad0
JB
1263 SCM_COERCE_SUBSTR (str);
1264 SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
02b754d3 1265 if (rv != 0)
3d8d56df
GH
1266 {
1267 int en = errno;
1268
5d2d2ffc 1269 SCM_SYSERROR_MSG ("~A: ~S",
3d8d56df
GH
1270 scm_listify (scm_makfrom0str (strerror (errno)),
1271 str,
5d2d2ffc 1272 SCM_UNDEFINED), en);
3d8d56df 1273 }
02b754d3 1274 return scm_stat2scm(&stat_temp);
0f2d19dd 1275}
1bbd0b84 1276#undef FUNC_NAME
f25f761d 1277#endif /* HAVE_LSTAT */
0f2d19dd 1278
a1ec6916 1279SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
1bbd0b84 1280 (SCM oldfile, SCM newfile),
d3818c29
MD
1281 "Copy the file specified by @var{path-from} to @var{path-to}.\n"
1282 "The return value is unspecified.")
1bbd0b84 1283#define FUNC_NAME s_scm_copy_file
0f2d19dd
JB
1284{
1285 int oldfd, newfd;
1286 int n;
77a76b64 1287 char buf[BUFSIZ];
0f2d19dd
JB
1288 struct stat oldstat;
1289
3b3b36dd 1290 SCM_VALIDATE_ROSTRING (1,oldfile);
0f2d19dd
JB
1291 if (SCM_SUBSTRP (oldfile))
1292 oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
3b3b36dd 1293 SCM_VALIDATE_ROSTRING (2,newfile);
0f2d19dd
JB
1294 if (SCM_SUBSTRP (newfile))
1295 newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1296 if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1bbd0b84 1297 SCM_SYSERROR;
0f2d19dd
JB
1298 oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1299 if (oldfd == -1)
1bbd0b84 1300 SCM_SYSERROR;
02b754d3
GH
1301
1302 /* use POSIX flags instead of 07777?. */
0f2d19dd
JB
1303 newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1304 oldstat.st_mode & 07777);
1305 if (newfd == -1)
1bbd0b84 1306 SCM_SYSERROR;
02b754d3 1307
0f2d19dd
JB
1308 while ((n = read (oldfd, buf, sizeof buf)) > 0)
1309 if (write (newfd, buf, n) != n)
1310 {
1311 close (oldfd);
1312 close (newfd);
1bbd0b84 1313 SCM_SYSERROR;
0f2d19dd
JB
1314 }
1315 close (oldfd);
1316 if (close (newfd) == -1)
1bbd0b84 1317 SCM_SYSERROR;
02b754d3 1318 return SCM_UNSPECIFIED;
0f2d19dd 1319}
1bbd0b84 1320#undef FUNC_NAME
0f2d19dd
JB
1321
1322\f
6a738a25
JB
1323/* Filename manipulation */
1324
1325SCM scm_dot_string;
1326
a1ec6916 1327SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
1bbd0b84 1328 (SCM filename),
d3818c29 1329 "")
1bbd0b84 1330#define FUNC_NAME s_scm_dirname
6a738a25
JB
1331{
1332 char *s;
9fd38a3d
DH
1333 long int i;
1334 unsigned long int len;
1335
1336 SCM_VALIDATE_STRING (1,filename);
1337
6a738a25 1338 s = SCM_ROCHARS (filename);
9fd38a3d
DH
1339 len = SCM_STRING_LENGTH (filename);
1340
6a738a25
JB
1341 i = len - 1;
1342 while (i >= 0 && s[i] == '/') --i;
1343 while (i >= 0 && s[i] != '/') --i;
1344 while (i >= 0 && s[i] == '/') --i;
1345 if (i < 0)
1346 {
1347 if (len > 0 && s[0] == '/')
1348 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1349 else
1350 return scm_dot_string;
1351 }
1352 else
1353 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1354}
1bbd0b84 1355#undef FUNC_NAME
6a738a25 1356
a1ec6916 1357SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
1bbd0b84 1358 (SCM filename, SCM suffix),
d3818c29 1359 "")
1bbd0b84 1360#define FUNC_NAME s_scm_basename
6a738a25
JB
1361{
1362 char *f, *s = 0;
1363 int i, j, len, end;
9fd38a3d
DH
1364
1365 SCM_VALIDATE_STRING (1,filename);
6a738a25 1366 f = SCM_ROCHARS (filename);
9fd38a3d
DH
1367 len = SCM_STRING_LENGTH (filename);
1368
6a738a25
JB
1369 if (SCM_UNBNDP (suffix))
1370 j = -1;
1371 else
1372 {
9fd38a3d 1373 SCM_VALIDATE_STRING (2, suffix);
6a738a25 1374 s = SCM_ROCHARS (suffix);
9fd38a3d 1375 j = SCM_STRING_LENGTH (suffix) - 1;
6a738a25 1376 }
6a738a25
JB
1377 i = len - 1;
1378 while (i >= 0 && f[i] == '/') --i;
1379 end = i;
1380 while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1381 if (j == -1)
1382 end = i;
1383 while (i >= 0 && f[i] != '/') --i;
1384 if (i == end)
1385 {
1386 if (len > 0 && f[0] == '/')
1387 return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1388 else
1389 return scm_dot_string;
1390 }
1391 else
1392 return scm_make_shared_substring (filename,
1393 SCM_MAKINUM (i + 1),
1394 SCM_MAKINUM (end + 1));
1395}
1bbd0b84 1396#undef FUNC_NAME
6a738a25
JB
1397
1398
1399
1400\f
1cc91f1b 1401
0f2d19dd
JB
1402void
1403scm_init_filesys ()
0f2d19dd 1404{
23a62151
MD
1405 scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
1406 NULL, scm_dir_free,scm_dir_print, NULL);
0f2d19dd 1407
a163dda9
MD
1408 scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1409
3d8d56df
GH
1410#ifdef O_RDONLY
1411scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1412#endif
1413#ifdef O_WRONLY
1414scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1415#endif
1416#ifdef O_RDWR
1417scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1418#endif
1419#ifdef O_CREAT
1420scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1421#endif
1422#ifdef O_EXCL
1423scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1424#endif
1425#ifdef O_NOCTTY
1426scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1427#endif
1428#ifdef O_TRUNC
1429scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1430#endif
1431#ifdef O_APPEND
1432scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1433#endif
6afcd3b2 1434#ifdef O_NONBLOCK
3d8d56df
GH
1435scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1436#endif
1437#ifdef O_NDELAY
1438scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1439#endif
1440#ifdef O_SYNC
1441scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1442#endif
1443
4c1feaa5
JB
1444#ifdef F_DUPFD
1445scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1446#endif
1447#ifdef F_GETFD
1448scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1449#endif
1450#ifdef F_SETFD
1451scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1452#endif
1453#ifdef F_GETFL
1454scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1455#endif
1456#ifdef F_SETFL
1457scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1458#endif
1459#ifdef F_GETOWN
1460scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1461#endif
1462#ifdef F_SETOWN
1463scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1464#endif
1465#ifdef FD_CLOEXEC
1466scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
bd9e24b3 1467#endif
3d8d56df 1468
a0599745 1469#include "libguile/filesys.x"
0f2d19dd 1470}
89e00824
ML
1471
1472/*
1473 Local Variables:
1474 c-file-style: "gnu"
1475 End:
1476*/