sendfile: Check return value of `lseek'.
[bpt/guile.git] / libguile / filesys.c
CommitLineData
f0007cad 1/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
9b6316ea 2 * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
f0007cad 3 *
73be1d9e 4 * This library is free software; you can redistribute it and/or
53befeb7
NJ
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
0f2d19dd 8 *
53befeb7
NJ
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
0f2d19dd 13 *
73be1d9e
MV
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
53befeb7
NJ
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
73be1d9e 18 */
1bbd0b84 19
1bbd0b84 20
0f2d19dd 21\f
073167ef
LC
22/* This file contains POSIX file system access procedures. Procedures
23 essential to the compiler and run-time (`stat', `canonicalize-path',
24 etc.) are compiled even with `--disable-posix'. */
25
464ee095
KR
26
27/* See stime.c for comments on why _POSIX_C_SOURCE is not always defined. */
2b829bbb 28#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
464ee095
KR
29#ifdef __hpux
30#define _POSIX_C_SOURCE 199506L /* for readdir_r */
edea856c 31#endif
6d484a0b 32
dbb605f5 33#ifdef HAVE_CONFIG_H
83079454
RB
34# include <config.h>
35#endif
36
f7439099 37#include <alloca.h>
2b829bbb 38
8912421c 39#include <stdlib.h>
3d8d56df 40#include <stdio.h>
e6e2e95a
MD
41#include <errno.h>
42
a0599745
MD
43#include "libguile/_scm.h"
44#include "libguile/smob.h"
45#include "libguile/feature.h"
46#include "libguile/fports.h"
2b829bbb 47#include "libguile/private-gc.h" /* for SCM_MAX */
a0599745
MD
48#include "libguile/strings.h"
49#include "libguile/vectors.h"
1299a0f1 50#include "libguile/dynwind.h"
0f2d19dd 51
a0599745
MD
52#include "libguile/validate.h"
53#include "libguile/filesys.h"
def804a3 54
0f2d19dd 55\f
def804a3
JB
56#ifdef HAVE_IO_H
57#include <io.h>
58#endif
59
e0c73a1c
MV
60#ifdef HAVE_DIRECT_H
61#include <direct.h>
62#endif
63
0f2d19dd
JB
64#ifdef TIME_WITH_SYS_TIME
65# include <sys/time.h>
66# include <time.h>
67#else
68# if HAVE_SYS_TIME_H
69# include <sys/time.h>
70# else
71# include <time.h>
72# endif
73#endif
74
75#ifdef HAVE_UNISTD_H
76#include <unistd.h>
77#endif
78
3594582b 79#ifdef LIBC_H_WITH_UNISTD_H
1f9e2226
JB
80#include <libc.h>
81#endif
82
0f2d19dd 83#include <sys/select.h>
0f2d19dd 84
1f9e2226
JB
85#ifdef HAVE_STRING_H
86#include <string.h>
87#endif
88
8cc71382 89#include <sys/types.h>
0f2d19dd
JB
90#include <sys/stat.h>
91#include <fcntl.h>
92
82893676 93#ifdef HAVE_PWD_H
0f2d19dd 94#include <pwd.h>
82893676 95#endif
0f2d19dd 96
f0007cad 97#include <dirent.h>
0f2d19dd 98
f0007cad 99#define NAMLEN(dirent) strlen ((dirent)->d_name)
0f2d19dd 100
fbac7c61
LC
101#ifdef HAVE_SYS_SENDFILE_H
102# include <sys/sendfile.h>
103#endif
104
105/* Glibc's `sendfile' function. */
106#define sendfile_or_sendfile64 \
107 CHOOSE_LARGEFILE (sendfile, sendfile64)
108
109#include <full-read.h>
110#include <full-write.h>
111
112
82893676
MG
113/* Some more definitions for the native Windows port. */
114#ifdef __MINGW32__
82893676 115# define fsync(fd) _commit (fd)
82893676 116#endif /* __MINGW32__ */
2b829bbb 117
2b829bbb 118
0f2d19dd
JB
119\f
120
1299a0f1
MV
121/* Two helper macros for an often used pattern */
122
123#define STRING_SYSCALL(str,cstr,code) \
124 do { \
125 int eno; \
126 char *cstr = scm_to_locale_string (str); \
127 SCM_SYSCALL (code); \
128 eno = errno; free (cstr); errno = eno; \
129 } while (0)
130
131#define STRING2_SYSCALL(str1,cstr1,str2,cstr2,code) \
132 do { \
133 int eno; \
134 char *cstr1, *cstr2; \
661ae7ab 135 scm_dynwind_begin (0); \
1299a0f1 136 cstr1 = scm_to_locale_string (str1); \
661ae7ab 137 scm_dynwind_free (cstr1); \
1299a0f1 138 cstr2 = scm_to_locale_string (str2); \
661ae7ab 139 scm_dynwind_free (cstr2); \
1299a0f1 140 SCM_SYSCALL (code); \
661ae7ab 141 eno = errno; scm_dynwind_end (); errno = eno; \
1299a0f1 142 } while (0)
0f2d19dd
JB
143
144\f
145
073167ef
LC
146#ifdef HAVE_POSIX
147
0f2d19dd
JB
148/* {Permissions}
149 */
150
82893676 151#ifdef HAVE_CHOWN
a1ec6916 152SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
1bbd0b84 153 (SCM object, SCM owner, SCM group),
d831b039
GH
154 "Change the ownership and group of the file referred to by @var{object} to\n"
155 "the integer values @var{owner} and @var{group}. @var{object} can be\n"
156 "a string containing a file name or, if the platform\n"
157 "supports fchown, a port or integer file descriptor\n"
158 "which is open on the file. The return value\n"
d3818c29 159 "is unspecified.\n\n"
d831b039 160 "If @var{object} is a symbolic link, either the\n"
d3818c29
MD
161 "ownership of the link or the ownership of the referenced file will be\n"
162 "changed depending on the operating system (lchown is\n"
163 "unsupported at present). If @var{owner} or @var{group} is specified\n"
164 "as @code{-1}, then that ID is not changed.")
1bbd0b84 165#define FUNC_NAME s_scm_chown
0f2d19dd 166{
6afcd3b2 167 int rv;
02b754d3 168
78446828
MV
169 object = SCM_COERCE_OUTPORT (object);
170
d831b039 171#ifdef HAVE_FCHOWN
a55c2b68 172 if (scm_is_integer (object) || (SCM_OPFPORTP (object)))
6afcd3b2 173 {
a55c2b68
MV
174 int fdes = (SCM_OPFPORTP (object)?
175 SCM_FPORT_FDES (object) : scm_to_int (object));
d831b039 176
a55c2b68 177 SCM_SYSCALL (rv = fchown (fdes, scm_to_int (owner), scm_to_int (group)));
6afcd3b2
GH
178 }
179 else
d831b039 180#endif
6afcd3b2 181 {
1299a0f1
MV
182 STRING_SYSCALL (object, c_object,
183 rv = chown (c_object,
184 scm_to_int (owner), scm_to_int (group)));
6afcd3b2
GH
185 }
186 if (rv == -1)
1bbd0b84 187 SCM_SYSERROR;
02b754d3 188 return SCM_UNSPECIFIED;
0f2d19dd 189}
1bbd0b84 190#undef FUNC_NAME
82893676 191#endif /* HAVE_CHOWN */
0f2d19dd 192
0f2d19dd 193\f
0f2d19dd 194
a1ec6916 195SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
1bbd0b84 196 (SCM path, SCM flags, SCM mode),
1e6808ea
MG
197 "Similar to @code{open} but return a file descriptor instead of\n"
198 "a port.")
1bbd0b84 199#define FUNC_NAME s_scm_open_fdes
0f2d19dd
JB
200{
201 int fd;
3d8d56df 202 int iflags;
6afcd3b2 203 int imode;
0f2d19dd 204
1be6b49c
ML
205 iflags = SCM_NUM2INT (2, flags);
206 imode = SCM_NUM2INT_DEF (3, mode, 0666);
23f2b9a3 207 STRING_SYSCALL (path, c_path, fd = open_or_open64 (c_path, iflags, imode));
3d8d56df 208 if (fd == -1)
1bbd0b84 209 SCM_SYSERROR;
e11e83f3 210 return scm_from_int (fd);
6afcd3b2 211}
1bbd0b84 212#undef FUNC_NAME
6afcd3b2 213
a1ec6916 214SCM_DEFINE (scm_open, "open", 2, 1, 0,
1bbd0b84 215 (SCM path, SCM flags, SCM mode),
d3818c29
MD
216 "Open the file named by @var{path} for reading and/or writing.\n"
217 "@var{flags} is an integer specifying how the file should be opened.\n"
218 "@var{mode} is an integer specifying the permission bits of the file, if\n"
219 "it needs to be created, before the umask is applied. The default is 666\n"
220 "(Unix itself has no default).\n\n"
221 "@var{flags} can be constructed by combining variables using @code{logior}.\n"
222 "Basic flags are:\n\n"
223 "@defvar O_RDONLY\n"
224 "Open the file read-only.\n"
225 "@end defvar\n"
226 "@defvar O_WRONLY\n"
9401323e 227 "Open the file write-only.\n"
d3818c29
MD
228 "@end defvar\n"
229 "@defvar O_RDWR\n"
230 "Open the file read/write.\n"
231 "@end defvar\n"
232 "@defvar O_APPEND\n"
233 "Append to the file instead of truncating.\n"
234 "@end defvar\n"
235 "@defvar O_CREAT\n"
236 "Create the file if it does not already exist.\n"
237 "@end defvar\n\n"
238 "See the Unix documentation of the @code{open} system call\n"
239 "for additional flags.")
1bbd0b84 240#define FUNC_NAME s_scm_open
6afcd3b2
GH
241{
242 SCM newpt;
243 char *port_mode;
244 int fd;
6afcd3b2
GH
245 int iflags;
246
e11e83f3 247 fd = scm_to_int (scm_open_fdes (path, flags, mode));
1be6b49c 248 iflags = SCM_NUM2INT (2, flags);
126a3224
LC
249
250 if ((iflags & O_RDWR) == O_RDWR)
77a76b64 251 {
126a3224 252 /* Opened read-write. */
77a76b64
JB
253 if (iflags & O_APPEND)
254 port_mode = "a+";
255 else if (iflags & O_CREAT)
256 port_mode = "w+";
257 else
258 port_mode = "r+";
259 }
126a3224
LC
260 else
261 {
262 /* Opened read-only or write-only. */
263 if (iflags & O_APPEND)
264 port_mode = "a";
265 else if (iflags & O_WRONLY)
266 port_mode = "w";
267 else
268 port_mode = "r";
269 }
270
77a76b64 271 newpt = scm_fdes_to_port (fd, port_mode, path);
3d8d56df 272 return newpt;
0f2d19dd 273}
1bbd0b84 274#undef FUNC_NAME
0f2d19dd 275
a1ec6916 276SCM_DEFINE (scm_close, "close", 1, 0, 0,
1bbd0b84 277 (SCM fd_or_port),
8f85c0c6 278 "Similar to close-port (@pxref{Closing, close-port}),\n"
d3818c29
MD
279 "but also works on file descriptors. A side\n"
280 "effect of closing a file descriptor is that any ports using that file\n"
281 "descriptor are moved to a different file descriptor and have\n"
282 "their revealed counts set to zero.")
1bbd0b84 283#define FUNC_NAME s_scm_close
eadd48de
GH
284{
285 int rv;
286 int fd;
287
78446828
MV
288 fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
289
0c95b57d 290 if (SCM_PORTP (fd_or_port))
eadd48de 291 return scm_close_port (fd_or_port);
a55c2b68 292 fd = scm_to_int (fd_or_port);
eadd48de 293 scm_evict_ports (fd); /* see scsh manual. */
a9488d12 294 SCM_SYSCALL (rv = close (fd));
eadd48de
GH
295 /* following scsh, closing an already closed file descriptor is
296 not an error. */
297 if (rv < 0 && errno != EBADF)
1bbd0b84 298 SCM_SYSERROR;
7888309b 299 return scm_from_bool (rv >= 0);
eadd48de 300}
1bbd0b84 301#undef FUNC_NAME
eadd48de 302
c2ca4493
GH
303SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0,
304 (SCM fd),
305 "A simple wrapper for the @code{close} system call.\n"
306 "Close file descriptor @var{fd}, which must be an integer.\n"
307 "Unlike close (@pxref{Ports and File Descriptors, close}),\n"
308 "the file descriptor will be closed even if a port is using it.\n"
309 "The return value is unspecified.")
310#define FUNC_NAME s_scm_close_fdes
311{
312 int c_fd;
313 int rv;
314
a55c2b68 315 c_fd = scm_to_int (fd);
c2ca4493
GH
316 SCM_SYSCALL (rv = close (c_fd));
317 if (rv < 0)
318 SCM_SYSERROR;
319 return SCM_UNSPECIFIED;
320}
321#undef FUNC_NAME
322
073167ef
LC
323#endif /* HAVE_POSIX */
324
0f2d19dd
JB
325\f
326/* {Files}
327 */
1cc91f1b 328
ae5253c5
GH
329SCM_SYMBOL (scm_sym_regular, "regular");
330SCM_SYMBOL (scm_sym_directory, "directory");
23f2b9a3 331#ifdef S_ISLNK
ae5253c5 332SCM_SYMBOL (scm_sym_symlink, "symlink");
f326ecf3 333#endif
ae5253c5
GH
334SCM_SYMBOL (scm_sym_block_special, "block-special");
335SCM_SYMBOL (scm_sym_char_special, "char-special");
336SCM_SYMBOL (scm_sym_fifo, "fifo");
337SCM_SYMBOL (scm_sym_sock, "socket");
338SCM_SYMBOL (scm_sym_unknown, "unknown");
339
0f2d19dd 340static SCM
2b829bbb 341scm_stat2scm (struct stat_or_stat64 *stat_temp)
0f2d19dd 342{
06bfe276 343 SCM ans = scm_c_make_vector (18, SCM_UNSPECIFIED);
ae5253c5 344
4057a3e0 345 SCM_SIMPLE_VECTOR_SET(ans, 0, scm_from_ulong (stat_temp->st_dev));
2b829bbb 346 SCM_SIMPLE_VECTOR_SET(ans, 1, scm_from_ino_t_or_ino64_t (stat_temp->st_ino));
4057a3e0
MV
347 SCM_SIMPLE_VECTOR_SET(ans, 2, scm_from_ulong (stat_temp->st_mode));
348 SCM_SIMPLE_VECTOR_SET(ans, 3, scm_from_ulong (stat_temp->st_nlink));
349 SCM_SIMPLE_VECTOR_SET(ans, 4, scm_from_ulong (stat_temp->st_uid));
350 SCM_SIMPLE_VECTOR_SET(ans, 5, scm_from_ulong (stat_temp->st_gid));
1fd85bc5 351#ifdef HAVE_STRUCT_STAT_ST_RDEV
4057a3e0 352 SCM_SIMPLE_VECTOR_SET(ans, 6, scm_from_ulong (stat_temp->st_rdev));
0f2d19dd 353#else
4057a3e0 354 SCM_SIMPLE_VECTOR_SET(ans, 6, SCM_BOOL_F);
0f2d19dd 355#endif
2b829bbb 356 SCM_SIMPLE_VECTOR_SET(ans, 7, scm_from_off_t_or_off64_t (stat_temp->st_size));
4057a3e0
MV
357 SCM_SIMPLE_VECTOR_SET(ans, 8, scm_from_ulong (stat_temp->st_atime));
358 SCM_SIMPLE_VECTOR_SET(ans, 9, scm_from_ulong (stat_temp->st_mtime));
359 SCM_SIMPLE_VECTOR_SET(ans, 10, scm_from_ulong (stat_temp->st_ctime));
1fd85bc5 360#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
4057a3e0 361 SCM_SIMPLE_VECTOR_SET(ans, 11, scm_from_ulong (stat_temp->st_blksize));
0f2d19dd 362#else
4057a3e0 363 SCM_SIMPLE_VECTOR_SET(ans, 11, scm_from_ulong (4096L));
0f2d19dd 364#endif
1fd85bc5 365#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
2b829bbb 366 SCM_SIMPLE_VECTOR_SET(ans, 12, scm_from_blkcnt_t_or_blkcnt64_t (stat_temp->st_blocks));
0f2d19dd 367#else
4057a3e0 368 SCM_SIMPLE_VECTOR_SET(ans, 12, SCM_BOOL_F);
0f2d19dd 369#endif
ae5253c5
GH
370 {
371 int mode = stat_temp->st_mode;
372
373 if (S_ISREG (mode))
4057a3e0 374 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_regular);
ae5253c5 375 else if (S_ISDIR (mode))
4057a3e0 376 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_directory);
23f2b9a3
KR
377#ifdef S_ISLNK
378 /* systems without symlinks probably don't have S_ISLNK */
ae5253c5 379 else if (S_ISLNK (mode))
4057a3e0 380 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_symlink);
f326ecf3 381#endif
ae5253c5 382 else if (S_ISBLK (mode))
4057a3e0 383 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_block_special);
ae5253c5 384 else if (S_ISCHR (mode))
4057a3e0 385 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_char_special);
ae5253c5 386 else if (S_ISFIFO (mode))
4057a3e0 387 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_fifo);
e655d034 388#ifdef S_ISSOCK
ae5253c5 389 else if (S_ISSOCK (mode))
4057a3e0 390 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_sock);
e655d034 391#endif
ae5253c5 392 else
4057a3e0 393 SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_unknown);
ae5253c5 394
4057a3e0 395 SCM_SIMPLE_VECTOR_SET(ans, 14, scm_from_int ((~S_IFMT) & mode));
ae5253c5
GH
396
397 /* the layout of the bits in ve[14] is intended to be portable.
398 If there are systems that don't follow the usual convention,
399 the following could be used:
400
401 tmp = 0;
402 if (S_ISUID & mode) tmp += 1;
403 tmp <<= 1;
404 if (S_IRGRP & mode) tmp += 1;
405 tmp <<= 1;
406 if (S_ISVTX & mode) tmp += 1;
407 tmp <<= 1;
408 if (S_IRUSR & mode) tmp += 1;
409 tmp <<= 1;
410 if (S_IWUSR & mode) tmp += 1;
411 tmp <<= 1;
412 if (S_IXUSR & mode) tmp += 1;
413 tmp <<= 1;
414 if (S_IWGRP & mode) tmp += 1;
415 tmp <<= 1;
416 if (S_IXGRP & mode) tmp += 1;
417 tmp <<= 1;
418 if (S_IROTH & mode) tmp += 1;
419 tmp <<= 1;
420 if (S_IWOTH & mode) tmp += 1;
421 tmp <<= 1;
422 if (S_IXOTH & mode) tmp += 1;
423
4057a3e0 424 SCM_SIMPLE_VECTOR_SET(ans, 14, scm_from_int (tmp));
ae5253c5
GH
425
426 */
427 }
06bfe276
AW
428#ifdef HAVE_STRUCT_STAT_ST_ATIM
429 SCM_SIMPLE_VECTOR_SET(ans, 15, scm_from_long (stat_temp->st_atim.tv_nsec));
430#else
431 SCM_SIMPLE_VECTOR_SET(ans, 15, SCM_I_MAKINUM (0));
432#endif
433#ifdef HAVE_STRUCT_STAT_ST_MTIM
434 SCM_SIMPLE_VECTOR_SET(ans, 16, scm_from_long (stat_temp->st_mtim.tv_nsec));
435#else
436 SCM_SIMPLE_VECTOR_SET(ans, 16, SCM_I_MAKINUM (0));
437#endif
438#ifdef HAVE_STRUCT_STAT_ST_CTIM
439 SCM_SIMPLE_VECTOR_SET(ans, 17, scm_from_ulong (stat_temp->st_ctim.tv_sec));
440#else
441 SCM_SIMPLE_VECTOR_SET(ans, 17, SCM_I_MAKINUM (0));
442#endif
0f2d19dd
JB
443
444 return ans;
445}
446
7a17979e
AW
447static int
448is_file_name_separator (SCM c)
449{
69b6da07 450 if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
7a17979e
AW
451 return 1;
452#ifdef __MINGW32__
69b6da07 453 if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
7a17979e
AW
454 return 1;
455#endif
456 return 0;
457}
458
fcb6f5ff
AW
459SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
460 (SCM object, SCM exception_on_error),
1e6808ea 461 "Return an object containing various information about the file\n"
b7e64f8b 462 "determined by @var{object}. @var{object} can be a string containing\n"
1e6808ea
MG
463 "a file name or a port or integer file descriptor which is open\n"
464 "on a file (in which case @code{fstat} is used as the underlying\n"
465 "system call).\n"
466 "\n"
fcb6f5ff
AW
467 "If the optional @var{exception_on_error} argument is true, which\n"
468 "is the default, an exception will be raised if the underlying\n"
469 "system call returns an error, for example if the file is not\n"
470 "found or is not readable. Otherwise, an error will cause\n"
471 "@code{stat} to return @code{#f}."
472 "\n"
473 "The object returned by a successful call to @code{stat} can be\n"
474 "passed as a single parameter to the following procedures, all of\n"
475 "which return integers:\n"
1e6808ea 476 "\n"
d3818c29
MD
477 "@table @code\n"
478 "@item stat:dev\n"
479 "The device containing the file.\n"
480 "@item stat:ino\n"
1e6808ea
MG
481 "The file serial number, which distinguishes this file from all\n"
482 "other files on the same device.\n"
d3818c29 483 "@item stat:mode\n"
1e6808ea
MG
484 "The mode of the file. This includes file type information and\n"
485 "the file permission bits. See @code{stat:type} and\n"
486 "@code{stat:perms} below.\n"
d3818c29
MD
487 "@item stat:nlink\n"
488 "The number of hard links to the file.\n"
489 "@item stat:uid\n"
490 "The user ID of the file's owner.\n"
491 "@item stat:gid\n"
492 "The group ID of the file.\n"
493 "@item stat:rdev\n"
494 "Device ID; this entry is defined only for character or block\n"
495 "special files.\n"
496 "@item stat:size\n"
497 "The size of a regular file in bytes.\n"
498 "@item stat:atime\n"
499 "The last access time for the file.\n"
500 "@item stat:mtime\n"
501 "The last modification time for the file.\n"
502 "@item stat:ctime\n"
503 "The last modification time for the attributes of the file.\n"
504 "@item stat:blksize\n"
1e6808ea
MG
505 "The optimal block size for reading or writing the file, in\n"
506 "bytes.\n"
d3818c29 507 "@item stat:blocks\n"
1e6808ea
MG
508 "The amount of disk space that the file occupies measured in\n"
509 "units of 512 byte blocks.\n"
510 "@end table\n"
511 "\n"
d3818c29 512 "In addition, the following procedures return the information\n"
1e6808ea
MG
513 "from stat:mode in a more convenient form:\n"
514 "\n"
d3818c29
MD
515 "@table @code\n"
516 "@item stat:type\n"
517 "A symbol representing the type of file. Possible values are\n"
1e6808ea
MG
518 "regular, directory, symlink, block-special, char-special, fifo,\n"
519 "socket and unknown\n"
d3818c29
MD
520 "@item stat:perms\n"
521 "An integer representing the access permission bits.\n"
522 "@end table")
1bbd0b84 523#define FUNC_NAME s_scm_stat
0f2d19dd 524{
6afcd3b2
GH
525 int rv;
526 int fdes;
2b829bbb 527 struct stat_or_stat64 stat_temp;
0f2d19dd 528
e11e83f3 529 if (scm_is_integer (object))
36284627 530 {
2b829bbb 531 SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp));
36284627 532 }
7f9994d9 533 else if (scm_is_string (object))
36284627 534 {
7f9994d9 535 char *file = scm_to_locale_string (object);
2b829bbb 536 SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp));
e0c73a1c 537 free (file);
36284627 538 }
1ea47048 539 else
0f2d19dd 540 {
36284627
DH
541 object = SCM_COERCE_OUTPORT (object);
542 SCM_VALIDATE_OPFPORT (1, object);
543 fdes = SCM_FPORT_FDES (object);
2b829bbb 544 SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
6afcd3b2 545 }
36284627 546
6afcd3b2 547 if (rv == -1)
3d8d56df 548 {
fcb6f5ff
AW
549 if (SCM_UNBNDP (exception_on_error) || scm_is_true (exception_on_error))
550 {
551 int en = errno;
552 SCM_SYSERROR_MSG ("~A: ~S",
553 scm_list_2 (scm_strerror (scm_from_int (en)),
554 object),
555 en);
556 }
557 else
558 return SCM_BOOL_F;
3d8d56df 559 }
02b754d3 560 return scm_stat2scm (&stat_temp);
0f2d19dd 561}
1bbd0b84 562#undef FUNC_NAME
0f2d19dd 563
d0476fa2
LC
564#ifdef HAVE_LSTAT
565SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
566 (SCM str),
567 "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
568 "it will return information about a symbolic link itself, not the\n"
b7e64f8b 569 "file it points to. @var{str} must be a string.")
d0476fa2
LC
570#define FUNC_NAME s_scm_lstat
571{
572 int rv;
573 struct stat_or_stat64 stat_temp;
574
575 STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
576 if (rv != 0)
577 {
578 int en = errno;
579
580 SCM_SYSERROR_MSG ("~A: ~S",
581 scm_list_2 (scm_strerror (scm_from_int (en)), str),
582 en);
583 }
584 return scm_stat2scm (&stat_temp);
585}
586#undef FUNC_NAME
587#endif /* HAVE_LSTAT */
588
0f2d19dd 589\f
073167ef
LC
590#ifdef HAVE_POSIX
591
0f2d19dd
JB
592/* {Modifying Directories}
593 */
594
82893676 595#ifdef HAVE_LINK
a1ec6916 596SCM_DEFINE (scm_link, "link", 2, 0, 0,
1bbd0b84 597 (SCM oldpath, SCM newpath),
6d36532c
GH
598 "Creates a new name @var{newpath} in the file system for the\n"
599 "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n"
600 "link, the link may or may not be followed depending on the\n"
601 "system.")
1bbd0b84 602#define FUNC_NAME s_scm_link
0f2d19dd
JB
603{
604 int val;
02b754d3 605
1299a0f1
MV
606 STRING2_SYSCALL (oldpath, c_oldpath,
607 newpath, c_newpath,
608 val = link (c_oldpath, c_newpath));
02b754d3 609 if (val != 0)
1bbd0b84 610 SCM_SYSERROR;
02b754d3 611 return SCM_UNSPECIFIED;
0f2d19dd 612}
1bbd0b84 613#undef FUNC_NAME
82893676 614#endif /* HAVE_LINK */
0f2d19dd 615
0f2d19dd 616\f
0f2d19dd
JB
617/* {Navigating Directories}
618 */
619
620
a1ec6916 621SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
1bbd0b84 622 (SCM str),
b7e64f8b 623 "Change the current working directory to @var{str}.\n"
d3818c29 624 "The return value is unspecified.")
1bbd0b84 625#define FUNC_NAME s_scm_chdir
0f2d19dd
JB
626{
627 int ans;
02b754d3 628
1299a0f1 629 STRING_SYSCALL (str, c_str, ans = chdir (c_str));
02b754d3 630 if (ans != 0)
1bbd0b84 631 SCM_SYSERROR;
02b754d3 632 return SCM_UNSPECIFIED;
0f2d19dd 633}
1bbd0b84 634#undef FUNC_NAME
0f2d19dd 635
0f2d19dd
JB
636\f
637
28d77376
GH
638/* check that element is a port or file descriptor. if it's a port
639 and its buffer is ready for use, add it to the ports_ready list.
640 otherwise add its file descriptor to *set. the type of list can be
641 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
642 SCM_ARG3 for excepts. */
cafc12ff 643static int
ba59471e 644set_element (fd_set *set, SCM *ports_ready, SCM element, int pos)
a48a89bc 645{
cafc12ff 646 int fd;
d831b039 647
e11e83f3 648 if (scm_is_integer (element))
28d77376 649 {
e11e83f3 650 fd = scm_to_int (element);
28d77376
GH
651 }
652 else
653 {
654 int use_buf = 0;
655
656 element = SCM_COERCE_OUTPORT (element);
657 SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select");
658 if (pos == SCM_ARG1)
659 {
660 /* check whether port has buffered input. */
92c2555f 661 scm_t_port *pt = SCM_PTAB_ENTRY (element);
28d77376
GH
662
663 if (pt->read_pos < pt->read_end)
664 use_buf = 1;
665 }
666 else if (pos == SCM_ARG2)
667 {
668 /* check whether port's output buffer has room. */
92c2555f 669 scm_t_port *pt = SCM_PTAB_ENTRY (element);
28d77376
GH
670
671 /* > 1 since writing the last byte in the buffer causes flush. */
672 if (pt->write_end - pt->write_pos > 1)
673 use_buf = 1;
674 }
675 fd = use_buf ? -1 : SCM_FPORT_FDES (element);
676 }
677 if (fd == -1)
678 *ports_ready = scm_cons (element, *ports_ready);
679 else
680 FD_SET (fd, set);
cafc12ff 681 return fd;
a48a89bc 682}
1cc91f1b 683
28d77376
GH
684/* check list_or_vec, a list or vector of ports or file descriptors,
685 adding each member to either the ports_ready list (if it's a port
686 with a usable buffer) or to *set. the kind of list_or_vec can be
687 determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
688 SCM_ARG3 for excepts. */
cafc12ff 689static int
ba59471e 690fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
0f2d19dd 691{
28d77376
GH
692 int max_fd = 0;
693
4057a3e0 694 if (scm_is_simple_vector (list_or_vec))
0f2d19dd 695 {
4057a3e0 696 int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
a48a89bc 697
28d77376 698 while (--i >= 0)
a48a89bc 699 {
4057a3e0
MV
700 int fd = set_element (set, ports_ready,
701 SCM_SIMPLE_VECTOR_REF (list_or_vec, i), pos);
28d77376 702
cafc12ff
MD
703 if (fd > max_fd)
704 max_fd = fd;
a48a89bc
GH
705 }
706 }
707 else
708 {
c96d76b8 709 while (!SCM_NULL_OR_NIL_P (list_or_vec))
a48a89bc 710 {
28d77376
GH
711 int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos);
712
cafc12ff
MD
713 if (fd > max_fd)
714 max_fd = fd;
28d77376 715 list_or_vec = SCM_CDR (list_or_vec);
a48a89bc 716 }
0f2d19dd 717 }
cafc12ff
MD
718
719 return max_fd;
0f2d19dd
JB
720}
721
28d77376
GH
722/* if element (a file descriptor or port) appears in *set, cons it to
723 list. return list. */
a48a89bc 724static SCM
ba59471e 725get_element (fd_set *set, SCM element, SCM list)
a48a89bc 726{
28d77376
GH
727 int fd;
728
e11e83f3 729 if (scm_is_integer (element))
a48a89bc 730 {
e11e83f3 731 fd = scm_to_int (element);
a48a89bc 732 }
28d77376 733 else
a48a89bc 734 {
28d77376 735 fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element));
a48a89bc 736 }
28d77376
GH
737 if (FD_ISSET (fd, set))
738 list = scm_cons (element, list);
a48a89bc
GH
739 return list;
740}
1cc91f1b 741
28d77376
GH
742/* construct component of scm_select return value.
743 set: pointer to set of file descriptors found by select to be ready
744 ports_ready: ports ready due to buffering
745 list_or_vec: original list/vector handed to scm_select.
746 the return value is a list/vector of ready ports/file descriptors.
747 works by finding the objects in list which correspond to members of
748 *set and appending them to ports_ready. result is converted to a
749 vector if list_or_vec is a vector. */
0f2d19dd 750static SCM
ba59471e 751retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
0f2d19dd 752{
28d77376 753 SCM answer_list = ports_ready;
a48a89bc 754
4057a3e0 755 if (scm_is_simple_vector (list_or_vec))
0f2d19dd 756 {
4057a3e0 757 int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
a48a89bc 758
28d77376 759 while (--i >= 0)
0f2d19dd 760 {
4057a3e0
MV
761 answer_list = get_element (set,
762 SCM_SIMPLE_VECTOR_REF (list_or_vec, i),
763 answer_list);
0f2d19dd 764 }
a48a89bc
GH
765 return scm_vector (answer_list);
766 }
767 else
768 {
28d77376 769 /* list_or_vec must be a list. */
c96d76b8 770 while (!SCM_NULL_OR_NIL_P (list_or_vec))
0f2d19dd 771 {
28d77376
GH
772 answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list);
773 list_or_vec = SCM_CDR (list_or_vec);
0f2d19dd 774 }
a48a89bc 775 return answer_list;
0f2d19dd 776 }
0f2d19dd
JB
777}
778
1bbd0b84 779/* Static helper functions above refer to s_scm_select directly as s_select */
a1ec6916 780SCM_DEFINE (scm_select, "select", 3, 2, 0,
1bbd0b84 781 (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
28d77376 782 "This procedure has a variety of uses: waiting for the ability\n"
bb2c02f2 783 "to provide input, accept output, or the existence of\n"
28d77376
GH
784 "exceptional conditions on a collection of ports or file\n"
785 "descriptors, or waiting for a timeout to occur.\n"
786 "It also returns if interrupted by a signal.\n\n"
787 "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
788 "vectors, with each member a port or a file descriptor.\n"
789 "The value returned is a list of three corresponding\n"
790 "lists or vectors containing only the members which meet the\n"
791 "specified requirement. The ability of port buffers to\n"
792 "provide input or accept output is taken into account.\n"
793 "Ordering of the input lists or vectors is not preserved.\n\n"
794 "The optional arguments @var{secs} and @var{usecs} specify the\n"
795 "timeout. Either @var{secs} can be specified alone, as\n"
796 "either an integer or a real number, or both @var{secs} and\n"
797 "@var{usecs} can be specified as integers, in which case\n"
798 "@var{usecs} is an additional timeout expressed in\n"
799 "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
800 "select will wait for as long as it takes for one of the other\n"
801 "conditions to be satisfied.\n\n"
802 "The scsh version of @code{select} differs as follows:\n"
803 "Only vectors are accepted for the first three arguments.\n"
804 "The @var{usecs} argument is not supported.\n"
805 "Multiple values are returned instead of a list.\n"
806 "Duplicates in the input vectors appear only once in output.\n"
9401323e 807 "An additional @code{select!} interface is provided.")
1bbd0b84 808#define FUNC_NAME s_scm_select
0f2d19dd 809{
0f2d19dd 810 struct timeval timeout;
28d77376 811 struct timeval * time_ptr;
ba59471e
AW
812 fd_set read_set;
813 fd_set write_set;
814 fd_set except_set;
28d77376
GH
815 int read_count;
816 int write_count;
817 int except_count;
818 /* these lists accumulate ports which are ready due to buffering.
819 their file descriptors don't need to be added to the select sets. */
820 SCM read_ports_ready = SCM_EOL;
821 SCM write_ports_ready = SCM_EOL;
822 int max_fd;
823
4057a3e0 824 if (scm_is_simple_vector (reads))
28d77376 825 {
4057a3e0 826 read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
28d77376
GH
827 }
828 else
829 {
830 read_count = scm_ilength (reads);
831 SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
832 }
4057a3e0 833 if (scm_is_simple_vector (writes))
28d77376 834 {
4057a3e0 835 write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
28d77376
GH
836 }
837 else
838 {
839 write_count = scm_ilength (writes);
840 SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
841 }
4057a3e0 842 if (scm_is_simple_vector (excepts))
28d77376 843 {
4057a3e0 844 except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
28d77376
GH
845 }
846 else
847 {
848 except_count = scm_ilength (excepts);
849 SCM_ASSERT (except_count >= 0, excepts, SCM_ARG3, FUNC_NAME);
850 }
0f2d19dd
JB
851
852 FD_ZERO (&read_set);
853 FD_ZERO (&write_set);
854 FD_ZERO (&except_set);
855
28d77376
GH
856 max_fd = fill_select_type (&read_set, &read_ports_ready, reads, SCM_ARG1);
857
858 {
859 int write_max = fill_select_type (&write_set, &write_ports_ready,
860 writes, SCM_ARG2);
861 int except_max = fill_select_type (&except_set, NULL,
862 excepts, SCM_ARG3);
863
864 if (write_max > max_fd)
865 max_fd = write_max;
866 if (except_max > max_fd)
867 max_fd = except_max;
868 }
0f2d19dd 869
ae1b098b
GH
870 /* if there's a port with a ready buffer, don't block, just
871 check for ready file descriptors. */
d2e53ed6 872 if (!scm_is_null (read_ports_ready) || !scm_is_null (write_ports_ready))
ae1b098b
GH
873 {
874 timeout.tv_sec = 0;
875 timeout.tv_usec = 0;
876 time_ptr = &timeout;
877 }
7888309b 878 else if (SCM_UNBNDP (secs) || scm_is_false (secs))
28d77376 879 time_ptr = 0;
0f2d19dd
JB
880 else
881 {
a55c2b68 882 if (scm_is_unsigned_integer (secs, 0, ULONG_MAX))
a48a89bc 883 {
a55c2b68 884 timeout.tv_sec = scm_to_ulong (secs);
a48a89bc
GH
885 if (SCM_UNBNDP (usecs))
886 timeout.tv_usec = 0;
887 else
a55c2b68 888 timeout.tv_usec = scm_to_long (usecs);
a48a89bc 889 }
0f2d19dd 890 else
a48a89bc 891 {
d9a67fc4 892 double fl = scm_to_double (secs);
a48a89bc
GH
893
894 if (!SCM_UNBNDP (usecs))
c1bfcf60 895 SCM_WRONG_TYPE_ARG (4, secs);
a48a89bc 896 if (fl > LONG_MAX)
c1bfcf60 897 SCM_OUT_OF_RANGE (4, secs);
a48a89bc
GH
898 timeout.tv_sec = (long) fl;
899 timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
900 }
28d77376 901 time_ptr = &timeout;
0f2d19dd
JB
902 }
903
28d77376 904 {
ba59471e
AW
905 int rv = select (max_fd + 1,
906 &read_set, &write_set, &except_set,
907 time_ptr);
28d77376
GH
908 if (rv < 0)
909 SCM_SYSERROR;
910 }
1afff620
KN
911 return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads),
912 retrieve_select_type (&write_set, write_ports_ready, writes),
913 retrieve_select_type (&except_set, SCM_EOL, excepts));
0f2d19dd 914}
1bbd0b84 915#undef FUNC_NAME
0f2d19dd
JB
916
917\f
4c1feaa5 918
82893676 919#ifdef HAVE_FCNTL
af45e3b0 920SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
1bbd0b84 921 (SCM object, SCM cmd, SCM value),
b7e64f8b 922 "Apply @var{cmd} to the specified file descriptor or the underlying\n"
d3818c29
MD
923 "file descriptor of the specified port. @var{value} is an optional\n"
924 "integer argument.\n\n"
b7e64f8b 925 "Values for @var{cmd} are:\n\n"
d3818c29
MD
926 "@table @code\n"
927 "@item F_DUPFD\n"
928 "Duplicate a file descriptor\n"
929 "@item F_GETFD\n"
930 "Get flags associated with the file descriptor.\n"
931 "@item F_SETFD\n"
932 "Set flags associated with the file descriptor to @var{value}.\n"
933 "@item F_GETFL\n"
934 "Get flags associated with the open file.\n"
935 "@item F_SETFL\n"
936 "Set flags associated with the open file to @var{value}\n"
937 "@item F_GETOWN\n"
938 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
939 "@item F_SETOWN\n"
940 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
941 "@item FD_CLOEXEC\n"
55892d87
NJ
942 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
943 "@code{F_SETFL}.\n"
a3c8b9fc 944 "@end table")
1bbd0b84 945#define FUNC_NAME s_scm_fcntl
4c1feaa5
JB
946{
947 int rv;
6afcd3b2
GH
948 int fdes;
949 int ivalue;
4c1feaa5 950
78446828
MV
951 object = SCM_COERCE_OUTPORT (object);
952
0c95b57d 953 if (SCM_OPFPORTP (object))
77a76b64 954 fdes = SCM_FPORT_FDES (object);
6afcd3b2 955 else
a55c2b68 956 fdes = scm_to_int (object);
af45e3b0 957
a55c2b68 958 if (SCM_UNBNDP (value))
6afcd3b2 959 ivalue = 0;
a55c2b68
MV
960 else
961 ivalue = scm_to_int (value);
af45e3b0 962
a55c2b68 963 SCM_SYSCALL (rv = fcntl (fdes, scm_to_int (cmd), ivalue));
77a76b64 964 if (rv == -1)
1bbd0b84 965 SCM_SYSERROR;
a55c2b68 966 return scm_from_int (rv);
4c1feaa5 967}
1bbd0b84 968#undef FUNC_NAME
82893676 969#endif /* HAVE_FCNTL */
6afcd3b2 970
a1ec6916 971SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
1bbd0b84 972 (SCM object),
b7e64f8b
BT
973 "Copies any unwritten data for the specified output file\n"
974 "descriptor to disk. If @var{object} is a port, its buffer is\n"
975 "flushed before the underlying file descriptor is fsync'd.\n"
d3818c29 976 "The return value is unspecified.")
1bbd0b84 977#define FUNC_NAME s_scm_fsync
6afcd3b2
GH
978{
979 int fdes;
980
78446828
MV
981 object = SCM_COERCE_OUTPORT (object);
982
0c95b57d 983 if (SCM_OPFPORTP (object))
6afcd3b2 984 {
affc96b5 985 scm_flush (object);
77a76b64 986 fdes = SCM_FPORT_FDES (object);
6afcd3b2
GH
987 }
988 else
a55c2b68
MV
989 fdes = scm_to_int (object);
990
6afcd3b2 991 if (fsync (fdes) == -1)
1bbd0b84 992 SCM_SYSERROR;
6afcd3b2
GH
993 return SCM_UNSPECIFIED;
994}
1bbd0b84 995#undef FUNC_NAME
0f2d19dd 996
f25f761d 997#ifdef HAVE_SYMLINK
a1ec6916 998SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
1bbd0b84 999 (SCM oldpath, SCM newpath),
b7e64f8b
BT
1000 "Create a symbolic link named @var{oldpath} with the value\n"
1001 "(i.e., pointing to) @var{newpath}. The return value is\n"
1002 "unspecified.")
1bbd0b84 1003#define FUNC_NAME s_scm_symlink
0f2d19dd 1004{
0f2d19dd 1005 int val;
02b754d3 1006
1299a0f1
MV
1007 STRING2_SYSCALL (oldpath, c_oldpath,
1008 newpath, c_newpath,
1009 val = symlink (c_oldpath, c_newpath));
02b754d3 1010 if (val != 0)
1bbd0b84 1011 SCM_SYSERROR;
02b754d3 1012 return SCM_UNSPECIFIED;
0f2d19dd 1013}
1bbd0b84 1014#undef FUNC_NAME
f25f761d 1015#endif /* HAVE_SYMLINK */
0f2d19dd 1016
f25f761d 1017#ifdef HAVE_READLINK
a1ec6916 1018SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
1bbd0b84 1019 (SCM path),
1e6808ea
MG
1020 "Return the value of the symbolic link named by @var{path} (a\n"
1021 "string), i.e., the file that the link points to.")
1bbd0b84 1022#define FUNC_NAME s_scm_readlink
0f2d19dd 1023{
6a738a25
JB
1024 int rv;
1025 int size = 100;
0f2d19dd
JB
1026 char *buf;
1027 SCM result;
1299a0f1
MV
1028 char *c_path;
1029
661ae7ab 1030 scm_dynwind_begin (0);
1299a0f1
MV
1031
1032 c_path = scm_to_locale_string (path);
661ae7ab 1033 scm_dynwind_free (c_path);
1299a0f1 1034
4c9419ac 1035 buf = scm_malloc (size);
1299a0f1
MV
1036
1037 while ((rv = readlink (c_path, buf, size)) == size)
0f2d19dd 1038 {
4c9419ac 1039 free (buf);
0f2d19dd 1040 size *= 2;
4c9419ac 1041 buf = scm_malloc (size);
0f2d19dd 1042 }
02b754d3 1043 if (rv == -1)
11e1db06
KR
1044 {
1045 int save_errno = errno;
1046 free (buf);
1047 errno = save_errno;
1048 SCM_SYSERROR;
1049 }
1299a0f1
MV
1050 result = scm_take_locale_stringn (buf, rv);
1051
661ae7ab 1052 scm_dynwind_end ();
0f2d19dd 1053 return result;
0f2d19dd 1054}
1bbd0b84 1055#undef FUNC_NAME
f25f761d 1056#endif /* HAVE_READLINK */
0f2d19dd 1057
a1ec6916 1058SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
1bbd0b84 1059 (SCM oldfile, SCM newfile),
b7e64f8b 1060 "Copy the file specified by @var{oldfile} to @var{newfile}.\n"
d3818c29 1061 "The return value is unspecified.")
1bbd0b84 1062#define FUNC_NAME s_scm_copy_file
0f2d19dd 1063{
1299a0f1 1064 char *c_oldfile, *c_newfile;
0f2d19dd 1065 int oldfd, newfd;
37eb673b 1066 int n, rv;
77a76b64 1067 char buf[BUFSIZ];
2b829bbb 1068 struct stat_or_stat64 oldstat;
0f2d19dd 1069
661ae7ab 1070 scm_dynwind_begin (0);
1299a0f1
MV
1071
1072 c_oldfile = scm_to_locale_string (oldfile);
661ae7ab 1073 scm_dynwind_free (c_oldfile);
1299a0f1 1074 c_newfile = scm_to_locale_string (newfile);
661ae7ab 1075 scm_dynwind_free (c_newfile);
37eb673b 1076
5a4a4454 1077 oldfd = open_or_open64 (c_oldfile, O_RDONLY | O_BINARY);
0f2d19dd 1078 if (oldfd == -1)
1bbd0b84 1079 SCM_SYSERROR;
02b754d3 1080
2b829bbb 1081 SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat));
37eb673b
KR
1082 if (rv == -1)
1083 goto err_close_oldfd;
1084
02b754d3 1085 /* use POSIX flags instead of 07777?. */
2b829bbb
KR
1086 newfd = open_or_open64 (c_newfile, O_WRONLY | O_CREAT | O_TRUNC,
1087 oldstat.st_mode & 07777);
0f2d19dd 1088 if (newfd == -1)
01046395 1089 {
37eb673b 1090 err_close_oldfd:
01046395
KR
1091 close (oldfd);
1092 SCM_SYSERROR;
1093 }
02b754d3 1094
0f2d19dd
JB
1095 while ((n = read (oldfd, buf, sizeof buf)) > 0)
1096 if (write (newfd, buf, n) != n)
1097 {
1098 close (oldfd);
1099 close (newfd);
1bbd0b84 1100 SCM_SYSERROR;
0f2d19dd
JB
1101 }
1102 close (oldfd);
1103 if (close (newfd) == -1)
1bbd0b84 1104 SCM_SYSERROR;
1299a0f1 1105
661ae7ab 1106 scm_dynwind_end ();
02b754d3 1107 return SCM_UNSPECIFIED;
0f2d19dd 1108}
1bbd0b84 1109#undef FUNC_NAME
0f2d19dd 1110
fbac7c61
LC
1111SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
1112 (SCM out, SCM in, SCM count, SCM offset),
1113 "Send @var{count} bytes from @var{in} to @var{out}, both of which "
1114 "are either open file ports or file descriptors. When "
1115 "@var{offset} is omitted, start reading from @var{in}'s current "
1116 "position; otherwise, start reading at @var{offset}.")
1117#define FUNC_NAME s_scm_sendfile
1118{
1119#define VALIDATE_FD_OR_PORT(cvar, svar, pos) \
1120 if (scm_is_integer (svar)) \
1121 cvar = scm_to_int (svar); \
1122 else \
1123 { \
1124 SCM_VALIDATE_OPFPORT (pos, svar); \
1125 scm_flush (svar); \
1126 cvar = SCM_FPORT_FDES (svar); \
1127 }
1128
1129 size_t c_count;
1130 scm_t_off c_offset;
1131 ssize_t result;
1132 int in_fd, out_fd;
1133
1134 VALIDATE_FD_OR_PORT (out_fd, out, 1);
1135 VALIDATE_FD_OR_PORT (in_fd, in, 2);
1136 c_count = scm_to_size_t (count);
1137 c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset);
1138
1139#ifdef HAVE_SENDFILE
1140 result = sendfile_or_sendfile64 (out_fd, in_fd,
1141 SCM_UNBNDP (offset) ? NULL : &c_offset,
1142 c_count);
1143
1144 /* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd
1145 must refer to a socket. Since Linux 2.6.33 it can be any file."
1146 Fall back to read(2) and write(2) when such an error occurs. */
1147 if (result < 0 && errno != EINVAL && errno != ENOSYS)
1148 SCM_SYSERROR;
1149 else if (result < 0)
1150#endif
1151 {
1152 char buf[8192];
1153 size_t result, left;
1154
1155 if (!SCM_UNBNDP (offset))
1156 {
1157 if (SCM_PORTP (in))
1158 scm_seek (in, offset, scm_from_int (SEEK_SET));
1159 else
f28885f4
LC
1160 {
1161 if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0)
1162 SCM_SYSERROR;
1163 }
fbac7c61
LC
1164 }
1165
1166 for (result = 0, left = c_count; result < c_count; )
1167 {
1168 size_t asked, obtained;
1169
1170 asked = SCM_MIN (sizeof buf, left);
1171 obtained = full_read (in_fd, buf, asked);
1172 if (obtained < asked)
1173 SCM_SYSERROR;
1174
1175 left -= obtained;
1176
1177 obtained = full_write (out_fd, buf, asked);
1178 if (obtained < asked)
1179 SCM_SYSERROR;
1180
1181 result += obtained;
1182 }
1183
1184 return scm_from_size_t (result);
1185 }
1186
1187 return scm_from_ssize_t (result);
1188
1189#undef VALIDATE_FD_OR_PORT
1190}
1191#undef FUNC_NAME
1192
073167ef
LC
1193#endif /* HAVE_POSIX */
1194
1195\f
1196/* Essential procedures used in (system base compile). */
1197
1198#ifdef HAVE_GETCWD
1199SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
1200 (),
1201 "Return the name of the current working directory.")
1202#define FUNC_NAME s_scm_getcwd
1203{
1204 char *rv;
1205 size_t size = 100;
1206 char *wd;
1207 SCM result;
1208
1209 wd = scm_malloc (size);
1210 while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
1211 {
1212 free (wd);
1213 size *= 2;
1214 wd = scm_malloc (size);
1215 }
1216 if (rv == 0)
1217 {
1218 int save_errno = errno;
1219 free (wd);
1220 errno = save_errno;
1221 SCM_SYSERROR;
1222 }
1223 result = scm_from_locale_stringn (wd, strlen (wd));
1224 free (wd);
1225 return result;
1226}
1227#undef FUNC_NAME
1228#endif /* HAVE_GETCWD */
1229
1230#ifdef HAVE_MKDIR
1231SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
1232 (SCM path, SCM mode),
1233 "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
1234 "then the permissions of the directory file are set using the current\n"
1235 "umask. Otherwise they are set to the decimal value specified with\n"
1236 "@var{mode}. The return value is unspecified.")
1237#define FUNC_NAME s_scm_mkdir
1238{
1239 int rv;
1240 mode_t mask;
1241
1242 if (SCM_UNBNDP (mode))
1243 {
1244 mask = umask (0);
1245 umask (mask);
1246 STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
1247 }
1248 else
1249 {
1250 STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
1251 }
1252 if (rv != 0)
1253 SCM_SYSERROR;
1254 return SCM_UNSPECIFIED;
1255}
1256#undef FUNC_NAME
1257#endif /* HAVE_MKDIR */
1258
1259#ifdef HAVE_RMDIR
1260SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
1261 (SCM path),
1262 "Remove the existing directory named by @var{path}. The directory must\n"
1263 "be empty for this to succeed. The return value is unspecified.")
1264#define FUNC_NAME s_scm_rmdir
1265{
1266 int val;
1267
1268 STRING_SYSCALL (path, c_path, val = rmdir (c_path));
1269 if (val != 0)
1270 SCM_SYSERROR;
1271 return SCM_UNSPECIFIED;
1272}
1273#undef FUNC_NAME
1274#endif
1275
1276#ifdef HAVE_RENAME
1277#define my_rename rename
1278#else
1279static int
1280my_rename (const char *oldname, const char *newname)
1281{
1282 int rv;
1283
1284 SCM_SYSCALL (rv = link (oldname, newname));
1285 if (rv == 0)
1286 {
1287 SCM_SYSCALL (rv = unlink (oldname));
1288 if (rv != 0)
1289 /* unlink failed. remove new name */
1290 SCM_SYSCALL (unlink (newname));
1291 }
1292 return rv;
1293}
1294#endif
1295
1296SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
1297 (SCM oldname, SCM newname),
1298 "Renames the file specified by @var{oldname} to @var{newname}.\n"
1299 "The return value is unspecified.")
1300#define FUNC_NAME s_scm_rename
1301{
1302 int rv;
1303
1304 STRING2_SYSCALL (oldname, c_oldname,
1305 newname, c_newname,
1306 rv = my_rename (c_oldname, c_newname));
1307 if (rv != 0)
1308 SCM_SYSERROR;
1309 return SCM_UNSPECIFIED;
1310}
1311#undef FUNC_NAME
1312
1313
1314SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
1315 (SCM str),
b7e64f8b 1316 "Deletes (or \"unlinks\") the file specified by @var{str}.")
073167ef
LC
1317#define FUNC_NAME s_scm_delete_file
1318{
1319 int ans;
1320 STRING_SYSCALL (str, c_str, ans = unlink (c_str));
1321 if (ans != 0)
1322 SCM_SYSERROR;
1323 return SCM_UNSPECIFIED;
1324}
1325#undef FUNC_NAME
1326
1327SCM_DEFINE (scm_access, "access?", 2, 0, 0,
1328 (SCM path, SCM how),
1329 "Test accessibility of a file under the real UID and GID of the\n"
1330 "calling process. The return is @code{#t} if @var{path} exists\n"
1331 "and the permissions requested by @var{how} are all allowed, or\n"
1332 "@code{#f} if not.\n"
1333 "\n"
1334 "@var{how} is an integer which is one of the following values,\n"
1335 "or a bitwise-OR (@code{logior}) of multiple values.\n"
1336 "\n"
1337 "@defvar R_OK\n"
1338 "Test for read permission.\n"
1339 "@end defvar\n"
1340 "@defvar W_OK\n"
1341 "Test for write permission.\n"
1342 "@end defvar\n"
1343 "@defvar X_OK\n"
1344 "Test for execute permission.\n"
1345 "@end defvar\n"
1346 "@defvar F_OK\n"
1347 "Test for existence of the file. This is implied by each of the\n"
1348 "other tests, so there's no need to combine it with them.\n"
1349 "@end defvar\n"
1350 "\n"
1351 "It's important to note that @code{access?} does not simply\n"
1352 "indicate what will happen on attempting to read or write a\n"
1353 "file. In normal circumstances it does, but in a set-UID or\n"
1354 "set-GID program it doesn't because @code{access?} tests the\n"
1355 "real ID, whereas an open or execute attempt uses the effective\n"
1356 "ID.\n"
1357 "\n"
1358 "A program which will never run set-UID/GID can ignore the\n"
1359 "difference between real and effective IDs, but for maximum\n"
1360 "generality, especially in library functions, it's best not to\n"
1361 "use @code{access?} to predict the result of an open or execute,\n"
1362 "instead simply attempt that and catch any exception.\n"
1363 "\n"
1364 "The main use for @code{access?} is to let a set-UID/GID program\n"
1365 "determine what the invoking user would have been allowed to do,\n"
1366 "without the greater (or perhaps lesser) privileges afforded by\n"
1367 "the effective ID. For more on this, see ``Testing File\n"
1368 "Access'' in The GNU C Library Reference Manual.")
1369#define FUNC_NAME s_scm_access
1370{
1371 int rv;
1372 char *c_path;
1373
1374 c_path = scm_to_locale_string (path);
1375 rv = access (c_path, scm_to_int (how));
1376 free (c_path);
1377
1378 return scm_from_bool (!rv);
1379}
1380#undef FUNC_NAME
1381
1382SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
1383 (SCM object, SCM mode),
b7e64f8b
BT
1384 "Changes the permissions of the file referred to by\n"
1385 "@var{object}. @var{object} can be a string containing a file\n"
1386 "name or a port or integer file descriptor which is open on a\n"
1387 "file (in which case @code{fchmod} is used as the underlying\n"
1388 "system call). @var{mode} specifies the new permissions as a\n"
1389 "decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
073167ef
LC
1390 "The return value is unspecified.")
1391#define FUNC_NAME s_scm_chmod
1392{
1393 int rv;
073167ef
LC
1394
1395 object = SCM_COERCE_OUTPORT (object);
1396
5558cdaa 1397#if HAVE_FCHMOD
073167ef
LC
1398 if (scm_is_integer (object) || SCM_OPFPORTP (object))
1399 {
5558cdaa 1400 int fdes;
073167ef
LC
1401 if (scm_is_integer (object))
1402 fdes = scm_to_int (object);
1403 else
1404 fdes = SCM_FPORT_FDES (object);
1405 SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
1406 }
1407 else
5558cdaa 1408#endif
073167ef
LC
1409 {
1410 STRING_SYSCALL (object, c_object,
1411 rv = chmod (c_object, scm_to_int (mode)));
1412 }
1413 if (rv == -1)
1414 SCM_SYSERROR;
1415 return SCM_UNSPECIFIED;
1416}
1417#undef FUNC_NAME
1418
1419SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
1420 (SCM mode),
1421 "If @var{mode} is omitted, returns a decimal number representing the current\n"
1422 "file creation mask. Otherwise the file creation mask is set to\n"
1423 "@var{mode} and the previous value is returned.\n\n"
1424 "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
1425#define FUNC_NAME s_scm_umask
1426{
1427 mode_t mask;
1428 if (SCM_UNBNDP (mode))
1429 {
1430 mask = umask (0);
1431 umask (mask);
1432 }
1433 else
1434 {
1435 mask = umask (scm_to_uint (mode));
1436 }
1437 return scm_from_uint (mask);
1438}
1439#undef FUNC_NAME
1440
1441#ifndef HAVE_MKSTEMP
1442extern int mkstemp (char *);
1443#endif
1444
1445SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
1446 (SCM tmpl),
1447 "Create a new unique file in the file system and return a new\n"
1448 "buffered port open for reading and writing to the file.\n"
1449 "\n"
1450 "@var{tmpl} is a string specifying where the file should be\n"
1451 "created: it must end with @samp{XXXXXX} and those @samp{X}s\n"
1452 "will be changed in the string to return the name of the file.\n"
1453 "(@code{port-filename} on the port also gives the name.)\n"
1454 "\n"
1455 "POSIX doesn't specify the permissions mode of the file, on GNU\n"
1456 "and most systems it's @code{#o600}. An application can use\n"
1457 "@code{chmod} to relax that if desired. For example\n"
1458 "@code{#o666} less @code{umask}, which is usual for ordinary\n"
1459 "file creation,\n"
1460 "\n"
1461 "@example\n"
1462 "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n"
1463 " (chmod port (logand #o666 (lognot (umask))))\n"
1464 " ...)\n"
1465 "@end example")
1466#define FUNC_NAME s_scm_mkstemp
1467{
1468 char *c_tmpl;
1469 int rv;
1470
1471 scm_dynwind_begin (0);
1472
1473 c_tmpl = scm_to_locale_string (tmpl);
1474 scm_dynwind_free (c_tmpl);
1475
1476 SCM_SYSCALL (rv = mkstemp (c_tmpl));
1477 if (rv == -1)
1478 SCM_SYSERROR;
1479
1480 scm_substring_move_x (scm_from_locale_string (c_tmpl),
1481 SCM_INUM0, scm_string_length (tmpl),
1482 tmpl, SCM_INUM0);
1483
1484 scm_dynwind_end ();
1485 return scm_fdes_to_port (rv, "w+", tmpl);
1486}
1487#undef FUNC_NAME
1488
0f2d19dd 1489\f
6a738a25
JB
1490/* Filename manipulation */
1491
1492SCM scm_dot_string;
1493
9b6316ea
AW
1494#ifdef __MINGW32__
1495SCM_SYMBOL (sym_file_name_convention, "windows");
1496#else
1497SCM_SYMBOL (sym_file_name_convention, "posix");
1498#endif
1499
1500SCM_INTERNAL SCM scm_system_file_name_convention (void);
1501
1502SCM_DEFINE (scm_system_file_name_convention,
1503 "system-file-name-convention", 0, 0, 0, (void),
1504 "Return either @code{posix} or @code{windows}, depending on\n"
1505 "what kind of system this Guile is running on.")
1506#define FUNC_NAME s_scm_system_file_name_convention
1507{
1508 return sym_file_name_convention;
1509}
1510#undef FUNC_NAME
1511
a1ec6916 1512SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
1bbd0b84 1513 (SCM filename),
fa6a543f
MG
1514 "Return the directory name component of the file name\n"
1515 "@var{filename}. If @var{filename} does not contain a directory\n"
1516 "component, @code{.} is returned.")
1bbd0b84 1517#define FUNC_NAME s_scm_dirname
6a738a25 1518{
9fd38a3d
DH
1519 long int i;
1520 unsigned long int len;
1521
34d19ef6 1522 SCM_VALIDATE_STRING (1, filename);
9fd38a3d 1523
cc95e00a 1524 len = scm_i_string_length (filename);
9fd38a3d 1525
6a738a25 1526 i = len - 1;
7a17979e
AW
1527
1528 while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
832bbc95 1529 --i;
7a17979e 1530 while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
832bbc95 1531 --i;
7a17979e 1532 while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
832bbc95 1533 --i;
7a17979e 1534
6a738a25
JB
1535 if (i < 0)
1536 {
7a17979e 1537 if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
cc95e00a 1538 return scm_c_substring (filename, 0, 1);
6a738a25
JB
1539 else
1540 return scm_dot_string;
1541 }
1542 else
cc95e00a 1543 return scm_c_substring (filename, 0, i + 1);
6a738a25 1544}
1bbd0b84 1545#undef FUNC_NAME
6a738a25 1546
a1ec6916 1547SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
1bbd0b84 1548 (SCM filename, SCM suffix),
fa6a543f
MG
1549 "Return the base name of the file name @var{filename}. The\n"
1550 "base name is the file name without any directory components.\n"
bb2c02f2 1551 "If @var{suffix} is provided, and is equal to the end of\n"
b7e64f8b 1552 "@var{filename}, it is removed also.")
1bbd0b84 1553#define FUNC_NAME s_scm_basename
6a738a25 1554{
6a738a25 1555 int i, j, len, end;
9fd38a3d 1556
34d19ef6 1557 SCM_VALIDATE_STRING (1, filename);
cc95e00a 1558 len = scm_i_string_length (filename);
9fd38a3d 1559
6a738a25
JB
1560 if (SCM_UNBNDP (suffix))
1561 j = -1;
1562 else
1563 {
9fd38a3d 1564 SCM_VALIDATE_STRING (2, suffix);
cc95e00a 1565 j = scm_i_string_length (suffix) - 1;
6a738a25 1566 }
6a738a25 1567 i = len - 1;
7a17979e 1568 while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
832bbc95 1569 --i;
6a738a25 1570 end = i;
832bbc95
MG
1571 while (i >= 0 && j >= 0
1572 && (scm_i_string_ref (filename, i)
1573 == scm_i_string_ref (suffix, j)))
1574 {
1575 --i;
1576 --j;
1577 }
6a738a25
JB
1578 if (j == -1)
1579 end = i;
7a17979e 1580 while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
832bbc95 1581 --i;
6a738a25
JB
1582 if (i == end)
1583 {
7a17979e 1584 if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
832bbc95 1585 return scm_c_substring (filename, 0, 1);
6a738a25
JB
1586 else
1587 return scm_dot_string;
1588 }
1589 else
cc95e00a 1590 return scm_c_substring (filename, i+1, end+1);
6a738a25 1591}
1bbd0b84 1592#undef FUNC_NAME
6a738a25 1593
25b82b34
AW
1594SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0,
1595 (SCM path),
1596 "Return the canonical path of @var{path}. A canonical path has\n"
1597 "no @code{.} or @code{..} components, nor any repeated path\n"
1598 "separators (@code{/}) nor symlinks.\n\n"
1599 "Raises an error if any component of @var{path} does not exist.")
1600#define FUNC_NAME s_scm_canonicalize_path
427c73b9
AW
1601{
1602 char *str, *canon;
25b82b34
AW
1603
1604 SCM_VALIDATE_STRING (1, path);
1605
1606 str = scm_to_locale_string (path);
1607 canon = canonicalize_file_name (str);
1608 free (str);
1609
1610 if (canon)
1611 return scm_take_locale_string (canon);
1612 else
1613 SCM_SYSERROR;
1614}
1615#undef FUNC_NAME
6a738a25 1616
22457d57
AW
1617SCM
1618scm_i_relativize_path (SCM path, SCM in_path)
1619{
1620 char *str, *canon;
1621 SCM scanon;
1622
1623 str = scm_to_locale_string (path);
1624 canon = canonicalize_file_name (str);
1625 free (str);
1626
1627 if (!canon)
1628 return SCM_BOOL_F;
1629
1630 scanon = scm_take_locale_string (canon);
1631
1632 for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
2ae7b7b6
LC
1633 {
1634 SCM dir = scm_car (in_path);
1635 size_t len = scm_c_string_length (dir);
1636
1637 /* When DIR is empty, it means "current working directory". We
1638 could set DIR to (getcwd) in that case, but then the
1639 canonicalization would depend on the current directory, which
1640 is not what we want in the context of `compile-file', for
1641 instance. */
1642 if (len > 0
1643 && scm_is_true (scm_string_prefix_p (dir, scanon,
1644 SCM_UNDEFINED, SCM_UNDEFINED,
1645 SCM_UNDEFINED, SCM_UNDEFINED)))
1646 {
1647 /* DIR either has a trailing delimiter or doesn't. SCANON
1648 will be delimited by single delimiters. When DIR does not
1649 have a trailing delimiter, add one to the length to strip
1650 off the delimiter within SCANON. */
7a17979e 1651 if (!is_file_name_separator (scm_c_string_ref (dir, len - 1)))
2ae7b7b6 1652 len++;
22457d57 1653
2ae7b7b6
LC
1654 if (scm_c_string_length (scanon) > len)
1655 return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
1656 else
1657 return SCM_BOOL_F;
1658 }
1659 }
22457d57
AW
1660
1661 return SCM_BOOL_F;
1662}
1663
d0476fa2
LC
1664\f
1665/* Examining directories. These procedures are used by `check-guile'
1666 and thus compiled unconditionally. */
1667
1668scm_t_bits scm_tc16_dir;
1669
1670
1671SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
1672 (SCM obj),
b7e64f8b 1673 "Return a boolean indicating whether @var{obj} is a directory\n"
d0476fa2
LC
1674 "stream as returned by @code{opendir}.")
1675#define FUNC_NAME s_scm_directory_stream_p
1676{
1677 return scm_from_bool (SCM_DIRP (obj));
1678}
1679#undef FUNC_NAME
1680
1681
1682SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
1683 (SCM dirname),
b7e64f8b 1684 "Open the directory specified by @var{dirname} and return a directory\n"
d0476fa2
LC
1685 "stream.")
1686#define FUNC_NAME s_scm_opendir
1687{
1688 DIR *ds;
1689 STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
1690 if (ds == NULL)
1691 SCM_SYSERROR;
1692 SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
1693}
1694#undef FUNC_NAME
1695
1696
1697/* FIXME: The glibc manual has a portability note that readdir_r may not
1698 null-terminate its return string. The circumstances outlined for this
1699 are not clear, nor is it clear what should be done about it. Lets use
1700 NAMLEN and worry about what else should be done if/when someone can
1701 figure it out. */
1702
1703SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
1704 (SCM port),
1705 "Return (as a string) the next directory entry from the directory stream\n"
b7e64f8b 1706 "@var{port}. If there is no remaining entry to be read then the\n"
d0476fa2
LC
1707 "end of file object is returned.")
1708#define FUNC_NAME s_scm_readdir
1709{
1710 struct dirent_or_dirent64 *rdent;
1711
1712 SCM_VALIDATE_DIR (1, port);
1713 if (!SCM_DIR_OPEN_P (port))
1714 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
1715
1716#if HAVE_READDIR_R
1717 /* As noted in the glibc manual, on various systems (such as Solaris) the
1718 d_name[] field is only 1 char and you're expected to size the dirent
1719 buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
1720 effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
1721 bigger.
1722
1723 On solaris 10 there's no NAME_MAX constant, it's necessary to use
1724 pathconf(). We prefer NAME_MAX though, since it should be a constant
1725 and will therefore save a system call. We also prefer it since dirfd()
1726 is not available everywhere.
1727
1728 An alternative to dirfd() would be to open() the directory and then use
1729 fdopendir(), if the latter is available. That'd let us hold the fd
1730 somewhere in the smob, or just the dirent size calculated once. */
1731 {
1732 struct dirent_or_dirent64 de; /* just for sizeof */
1733 DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
1734#ifdef NAME_MAX
1735 char buf [SCM_MAX (sizeof (de),
1736 sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
1737#else
1738 char *buf;
1739 long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
1740 if (name_max == -1)
1741 SCM_SYSERROR;
1742 buf = alloca (SCM_MAX (sizeof (de),
1743 sizeof (de) - sizeof (de.d_name) + name_max + 1));
1744#endif
1745
1746 errno = 0;
1747 SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
1748 if (errno != 0)
1749 SCM_SYSERROR;
1750 if (! rdent)
1751 return SCM_EOF_VAL;
1752
1753 return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
1754 : SCM_EOF_VAL);
1755 }
1756#else
1757 {
1758 SCM ret;
1759 scm_dynwind_begin (0);
1760 scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
1761
1762 errno = 0;
1763 SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
1764 if (errno != 0)
1765 SCM_SYSERROR;
1766
1767 ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
1768 : SCM_EOF_VAL);
1769
1770 scm_dynwind_end ();
1771 return ret;
1772 }
1773#endif
1774}
1775#undef FUNC_NAME
1776
1777
1778SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
1779 (SCM port),
b7e64f8b 1780 "Reset the directory port @var{port} so that the next call to\n"
d0476fa2
LC
1781 "@code{readdir} will return the first directory entry.")
1782#define FUNC_NAME s_scm_rewinddir
1783{
1784 SCM_VALIDATE_DIR (1, port);
1785 if (!SCM_DIR_OPEN_P (port))
1786 SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
1787
1788 rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
1789
1790 return SCM_UNSPECIFIED;
1791}
1792#undef FUNC_NAME
1793
1794
1795SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
1796 (SCM port),
b7e64f8b 1797 "Close the directory stream @var{port}.\n"
d0476fa2
LC
1798 "The return value is unspecified.")
1799#define FUNC_NAME s_scm_closedir
1800{
1801 SCM_VALIDATE_DIR (1, port);
1802
1803 if (SCM_DIR_OPEN_P (port))
1804 {
1805 int sts;
1806
1807 SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
1808 if (sts != 0)
1809 SCM_SYSERROR;
1810
1811 SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
1812 }
1813
1814 return SCM_UNSPECIFIED;
1815}
1816#undef FUNC_NAME
1817
1818
1fa54298 1819#ifdef HAVE_POSIX
d0476fa2
LC
1820static int
1821scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
1822{
1823 scm_puts ("#<", port);
1824 if (!SCM_DIR_OPEN_P (exp))
1825 scm_puts ("closed: ", port);
1826 scm_puts ("directory stream ", port);
1827 scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
1828 scm_putc ('>', port);
1829 return 1;
1830}
1831
1832
1833static size_t
1834scm_dir_free (SCM p)
1835{
1836 if (SCM_DIR_OPEN_P (p))
1837 closedir ((DIR *) SCM_SMOB_DATA_1 (p));
1838 return 0;
1839}
1fa54298 1840#endif
6a738a25
JB
1841
1842\f
1cc91f1b 1843
0f2d19dd
JB
1844void
1845scm_init_filesys ()
0f2d19dd 1846{
073167ef 1847#ifdef HAVE_POSIX
e841c3e0
KN
1848 scm_tc16_dir = scm_make_smob_type ("directory", 0);
1849 scm_set_smob_free (scm_tc16_dir, scm_dir_free);
1850 scm_set_smob_print (scm_tc16_dir, scm_dir_print);
0f2d19dd 1851
3d8d56df 1852#ifdef O_RDONLY
23d72566 1853 scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
3d8d56df
GH
1854#endif
1855#ifdef O_WRONLY
23d72566 1856 scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY));
3d8d56df
GH
1857#endif
1858#ifdef O_RDWR
23d72566 1859 scm_c_define ("O_RDWR", scm_from_int (O_RDWR));
3d8d56df
GH
1860#endif
1861#ifdef O_CREAT
23d72566 1862 scm_c_define ("O_CREAT", scm_from_int (O_CREAT));
3d8d56df
GH
1863#endif
1864#ifdef O_EXCL
23d72566 1865 scm_c_define ("O_EXCL", scm_from_int (O_EXCL));
3d8d56df
GH
1866#endif
1867#ifdef O_NOCTTY
23d72566 1868 scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY));
3d8d56df
GH
1869#endif
1870#ifdef O_TRUNC
23d72566 1871 scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC));
3d8d56df
GH
1872#endif
1873#ifdef O_APPEND
23d72566 1874 scm_c_define ("O_APPEND", scm_from_int (O_APPEND));
3d8d56df 1875#endif
6afcd3b2 1876#ifdef O_NONBLOCK
23d72566 1877 scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK));
3d8d56df
GH
1878#endif
1879#ifdef O_NDELAY
23d72566 1880 scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY));
3d8d56df
GH
1881#endif
1882#ifdef O_SYNC
23d72566 1883 scm_c_define ("O_SYNC", scm_from_int (O_SYNC));
3d8d56df 1884#endif
23f2b9a3 1885#ifdef O_LARGEFILE
23d72566 1886 scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
3565df45
LC
1887#endif
1888#ifdef O_NOTRANS
1889 scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS));
1890#endif
3d8d56df 1891
4c1feaa5 1892#ifdef F_DUPFD
23d72566 1893 scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
4c1feaa5
JB
1894#endif
1895#ifdef F_GETFD
23d72566 1896 scm_c_define ("F_GETFD", scm_from_int (F_GETFD));
4c1feaa5
JB
1897#endif
1898#ifdef F_SETFD
23d72566 1899 scm_c_define ("F_SETFD", scm_from_int (F_SETFD));
4c1feaa5
JB
1900#endif
1901#ifdef F_GETFL
23d72566 1902 scm_c_define ("F_GETFL", scm_from_int (F_GETFL));
4c1feaa5
JB
1903#endif
1904#ifdef F_SETFL
23d72566 1905 scm_c_define ("F_SETFL", scm_from_int (F_SETFL));
4c1feaa5
JB
1906#endif
1907#ifdef F_GETOWN
23d72566 1908 scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN));
4c1feaa5
JB
1909#endif
1910#ifdef F_SETOWN
23d72566 1911 scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN));
4c1feaa5
JB
1912#endif
1913#ifdef FD_CLOEXEC
23d72566 1914 scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
bd9e24b3 1915#endif
073167ef
LC
1916#endif /* HAVE_POSIX */
1917
1918 /* `access' symbols. */
1919 scm_c_define ("R_OK", scm_from_int (R_OK));
1920 scm_c_define ("W_OK", scm_from_int (W_OK));
1921 scm_c_define ("X_OK", scm_from_int (X_OK));
1922 scm_c_define ("F_OK", scm_from_int (F_OK));
1923
1924 scm_dot_string = scm_from_locale_string (".");
3d8d56df 1925
a0599745 1926#include "libguile/filesys.x"
0f2d19dd 1927}
89e00824
ML
1928
1929/*
1930 Local Variables:
1931 c-file-style: "gnu"
1932 End:
1933*/