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