-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
+ * 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
#include "libguile/feature.h"
#include "libguile/fports.h"
#include "libguile/private-gc.h" /* for SCM_MAX */
-#include "libguile/iselect.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
# endif
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#endif
#ifdef LIBC_H_WITH_UNISTD_H
#include <libc.h>
#endif
-#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
-#endif
#ifdef HAVE_STRING_H
#include <string.h>
#include <pwd.h>
#endif
+#include <dirent.h>
-#if defined (__MINGW32__) || defined (_MSC_VER) || defined (__BORLANDC__)
-# include "win32-dirent.h"
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-/* The following bits are per AC_HEADER_DIRENT doco in the autoconf manual */
-#elif HAVE_DIRENT_H
-# include <dirent.h>
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-#else
-# define dirent direct
-# define NAMLEN(dirent) (dirent)->d_namlen
-# if HAVE_SYS_NDIR_H
-# include <sys/ndir.h>
-# endif
-# if HAVE_SYS_DIR_H
-# include <sys/dir.h>
-# endif
-# if HAVE_NDIR_H
-# include <ndir.h>
-# endif
-#endif
+#define NAMLEN(dirent) strlen ((dirent)->d_name)
-/* Some more definitions for the native Windows port. */
-#ifdef __MINGW32__
-# define mkdir(path, mode) mkdir (path)
-# define fsync(fd) _commit (fd)
-# define fchmod(fd, mode) (-1)
-#endif /* __MINGW32__ */
-
-/* dirfd() returns the file descriptor underlying a "DIR*" directory stream.
- Found on MacOS X for instance. The following definition is for Solaris
- 10, it's probably not right elsewhere, but that's ok, it shouldn't be
- used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4
- figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field,
- or d_fd field). */
-#ifndef dirfd
-#define dirfd(dirstream) ((dirstream)->dd_fd)
+#ifdef HAVE_SYS_SENDFILE_H
+# include <sys/sendfile.h>
#endif
+/* Glibc's `sendfile' function. */
+#define sendfile_or_sendfile64 \
+ CHOOSE_LARGEFILE (sendfile, sendfile64)
+
+#include <full-read.h>
+#include <full-write.h>
+
+
\f
/* Two helper macros for an often used pattern */
fd = scm_to_int (scm_open_fdes (path, flags, mode));
iflags = SCM_NUM2INT (2, flags);
- if (iflags & O_RDWR)
+
+ if ((iflags & O_RDWR) == O_RDWR)
{
+ /* Opened read-write. */
if (iflags & O_APPEND)
port_mode = "a+";
else if (iflags & O_CREAT)
else
port_mode = "r+";
}
- else {
- if (iflags & O_APPEND)
- port_mode = "a";
- else if (iflags & O_WRONLY)
- port_mode = "w";
- else
- port_mode = "r";
- }
+ else
+ {
+ /* Opened read-only or write-only. */
+ if (iflags & O_APPEND)
+ port_mode = "a";
+ else if (iflags & O_WRONLY)
+ port_mode = "w";
+ else
+ port_mode = "r";
+ }
+
newpt = scm_fdes_to_port (fd, port_mode, path);
return newpt;
}
return ans;
}
-#ifdef __MINGW32__
-/*
- * Try getting the appropiate stat buffer for a given file descriptor
- * under Windows. It differentiates between file, pipe and socket
- * descriptors.
- */
-static int fstat_Win32 (int fdes, struct stat *buf)
+static int
+is_file_name_separator (SCM c)
{
- int error, optlen = sizeof (int);
-
- memset (buf, 0, sizeof (struct stat));
-
- /* Is this a socket ? */
- if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
- {
- buf->st_mode = _S_IFSOCK | _S_IREAD | _S_IWRITE | _S_IEXEC;
- buf->st_nlink = 1;
- buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
- return 0;
- }
- /* Maybe a regular file or pipe ? */
- return fstat (fdes, buf);
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
+ return 1;
+#ifdef __MINGW32__
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
+ return 1;
+#endif
+ return 0;
}
-#endif /* __MINGW32__ */
SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
(SCM object, SCM exception_on_error),
"Return an object containing various information about the file\n"
- "determined by @var{obj}. @var{obj} can be a string containing\n"
+ "determined by @var{object}. @var{object} can be a string containing\n"
"a file name or a port or integer file descriptor which is open\n"
"on a file (in which case @code{fstat} is used as the underlying\n"
"system call).\n"
if (scm_is_integer (object))
{
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp));
-#endif
}
else if (scm_is_string (object))
{
char *file = scm_to_locale_string (object);
-#ifdef __MINGW32__
- char *p;
- p = file + strlen (file) - 1;
- while (p > file && (*p == '/' || *p == '\\'))
- *p-- = '\0';
-#endif
SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp));
free (file);
}
object = SCM_COERCE_OUTPORT (object);
SCM_VALIDATE_OPFPORT (1, object);
fdes = SCM_FPORT_FDES (object);
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
-#endif
}
if (rv == -1)
}
#undef FUNC_NAME
+SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
+ (SCM str),
+ "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
+ "it will return information about a symbolic link itself, not the\n"
+ "file it points to. @var{str} must be a string.")
+#define FUNC_NAME s_scm_lstat
+{
+ int rv;
+ struct stat_or_stat64 stat_temp;
+
+ STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
+ if (rv != 0)
+ {
+ int en = errno;
+
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)), str),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+
\f
#ifdef HAVE_POSIX
/* {Modifying Directories}
*/
-#ifdef HAVE_LINK
SCM_DEFINE (scm_link, "link", 2, 0, 0,
(SCM oldpath, SCM newpath),
"Creates a new name @var{newpath} in the file system for the\n"
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif /* HAVE_LINK */
-
-\f
-
-/* {Examining Directories}
- */
-
-scm_t_bits scm_tc16_dir;
-
-
-SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
- (SCM obj),
- "Return a boolean indicating whether @var{object} is a directory\n"
- "stream as returned by @code{opendir}.")
-#define FUNC_NAME s_scm_directory_stream_p
-{
- return scm_from_bool (SCM_DIRP (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
- (SCM dirname),
- "Open the directory specified by @var{path} and return a directory\n"
- "stream.")
-#define FUNC_NAME s_scm_opendir
-{
- DIR *ds;
- STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
- if (ds == NULL)
- SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
-}
-#undef FUNC_NAME
-
-
-/* FIXME: The glibc manual has a portability note that readdir_r may not
- null-terminate its return string. The circumstances outlined for this
- are not clear, nor is it clear what should be done about it. Lets use
- NAMLEN and worry about what else should be done if/when someone can
- figure it out. */
-
-SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
- (SCM port),
- "Return (as a string) the next directory entry from the directory stream\n"
- "@var{stream}. If there is no remaining entry to be read then the\n"
- "end of file object is returned.")
-#define FUNC_NAME s_scm_readdir
-{
- struct dirent_or_dirent64 *rdent;
-
- SCM_VALIDATE_DIR (1, port);
- if (!SCM_DIR_OPEN_P (port))
- SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
-
-#if HAVE_READDIR_R
- /* As noted in the glibc manual, on various systems (such as Solaris) the
- d_name[] field is only 1 char and you're expected to size the dirent
- buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
- effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
- bigger.
-
- On solaris 10 there's no NAME_MAX constant, it's necessary to use
- pathconf(). We prefer NAME_MAX though, since it should be a constant
- and will therefore save a system call. We also prefer it since dirfd()
- is not available everywhere.
-
- An alternative to dirfd() would be to open() the directory and then use
- fdopendir(), if the latter is available. That'd let us hold the fd
- somewhere in the smob, or just the dirent size calculated once. */
- {
- struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
-#ifdef NAME_MAX
- char buf [SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
-#else
- char *buf;
- long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
- if (name_max == -1)
- SCM_SYSERROR;
- buf = alloca (SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + name_max + 1));
-#endif
-
- errno = 0;
- SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
- if (errno != 0)
- SCM_SYSERROR;
- if (! rdent)
- return SCM_EOF_VAL;
-
- return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
- : SCM_EOF_VAL);
- }
-#else
- {
- SCM ret;
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
-
- errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
- if (errno != 0)
- SCM_SYSERROR;
-
- ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
- : SCM_EOF_VAL);
-
- scm_dynwind_end ();
- return ret;
- }
-#endif
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
- (SCM port),
- "Reset the directory port @var{stream} so that the next call to\n"
- "@code{readdir} will return the first directory entry.")
-#define FUNC_NAME s_scm_rewinddir
-{
- SCM_VALIDATE_DIR (1, port);
- if (!SCM_DIR_OPEN_P (port))
- SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
-
- rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
- (SCM port),
- "Close the directory stream @var{stream}.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_closedir
-{
- SCM_VALIDATE_DIR (1, port);
-
- if (SCM_DIR_OPEN_P (port))
- {
- int sts;
-
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
- if (sts != 0)
- SCM_SYSERROR;
-
- SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
- }
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static int
-scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<", port);
- if (!SCM_DIR_OPEN_P (exp))
- scm_puts ("closed: ", port);
- scm_puts ("directory stream ", port);
- scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-
-static size_t
-scm_dir_free (SCM p)
-{
- if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_SMOB_DATA_1 (p));
- return 0;
-}
\f
/* {Navigating Directories}
SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
(SCM str),
- "Change the current working directory to @var{path}.\n"
+ "Change the current working directory to @var{str}.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_chdir
{
\f
-#ifdef HAVE_SELECT
-
/* check that element is a port or file descriptor. if it's a port
and its buffer is ready for use, add it to the ports_ready list.
otherwise add its file descriptor to *set. the type of list can be
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
-set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
+set_element (fd_set *set, SCM *ports_ready, SCM element, int pos)
{
int fd;
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
-fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
+fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
{
int max_fd = 0;
/* if element (a file descriptor or port) appears in *set, cons it to
list. return list. */
static SCM
-get_element (SELECT_TYPE *set, SCM element, SCM list)
+get_element (fd_set *set, SCM element, SCM list)
{
int fd;
*set and appending them to ports_ready. result is converted to a
vector if list_or_vec is a vector. */
static SCM
-retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
+retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
{
SCM answer_list = ports_ready;
{
struct timeval timeout;
struct timeval * time_ptr;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
+ fd_set read_set;
+ fd_set write_set;
+ fd_set except_set;
int read_count;
int write_count;
int except_count;
}
{
- int rv = scm_std_select (max_fd + 1,
- &read_set, &write_set, &except_set,
- time_ptr);
+ int rv = select (max_fd + 1,
+ &read_set, &write_set, &except_set,
+ time_ptr);
if (rv < 0)
SCM_SYSERROR;
}
retrieve_select_type (&except_set, SCM_EOL, excepts));
}
#undef FUNC_NAME
-#endif /* HAVE_SELECT */
\f
#ifdef HAVE_FCNTL
SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
(SCM object, SCM cmd, SCM value),
- "Apply @var{command} to the specified file descriptor or the underlying\n"
+ "Apply @var{cmd} to the specified file descriptor or the underlying\n"
"file descriptor of the specified port. @var{value} is an optional\n"
"integer argument.\n\n"
- "Values for @var{command} are:\n\n"
+ "Values for @var{cmd} are:\n\n"
"@table @code\n"
"@item F_DUPFD\n"
"Duplicate a file descriptor\n"
SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
(SCM object),
- "Copies any unwritten data for the specified output file descriptor to disk.\n"
- "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
- "file descriptor is fsync'd.\n"
+ "Copies any unwritten data for the specified output file\n"
+ "descriptor to disk. If @var{object} is a port, its buffer is\n"
+ "flushed before the underlying file descriptor is fsync'd.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_fsync
{
#ifdef HAVE_SYMLINK
SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
(SCM oldpath, SCM newpath),
- "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
- "@var{path-from}. The return value is unspecified.")
+ "Create a symbolic link named @var{oldpath} with the value\n"
+ "(i.e., pointing to) @var{newpath}. The return value is\n"
+ "unspecified.")
#define FUNC_NAME s_scm_symlink
{
int val;
#undef FUNC_NAME
#endif /* HAVE_SYMLINK */
-#ifdef HAVE_READLINK
SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
(SCM path),
"Return the value of the symbolic link named by @var{path} (a\n"
return result;
}
#undef FUNC_NAME
-#endif /* HAVE_READLINK */
-
-#ifdef HAVE_LSTAT
-SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
- (SCM str),
- "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
- "it will return information about a symbolic link itself, not the\n"
- "file it points to. @var{path} must be a string.")
-#define FUNC_NAME s_scm_lstat
-{
- int rv;
- struct stat_or_stat64 stat_temp;
-
- STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
- if (rv != 0)
- {
- int en = errno;
-
- SCM_SYSERROR_MSG ("~A: ~S",
- scm_list_2 (scm_strerror (scm_from_int (en)), str),
- en);
- }
- return scm_stat2scm (&stat_temp);
-}
-#undef FUNC_NAME
-#endif /* HAVE_LSTAT */
SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
(SCM oldfile, SCM newfile),
- "Copy the file specified by @var{path-from} to @var{path-to}.\n"
+ "Copy the file specified by @var{oldfile} to @var{newfile}.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_copy_file
{
c_newfile = scm_to_locale_string (newfile);
scm_dynwind_free (c_newfile);
- oldfd = open_or_open64 (c_oldfile, O_RDONLY);
+ oldfd = open_or_open64 (c_oldfile, O_RDONLY | O_BINARY);
if (oldfd == -1)
SCM_SYSERROR;
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (oldfd, &oldstat));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat));
-#endif
if (rv == -1)
goto err_close_oldfd;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
+ (SCM out, SCM in, SCM count, SCM offset),
+ "Send @var{count} bytes from @var{in} to @var{out}, both of which "
+ "must be either open file ports or file descriptors. When "
+ "@var{offset} is omitted, start reading from @var{in}'s current "
+ "position; otherwise, start reading at @var{offset}. Return "
+ "the number of bytes actually sent.")
+#define FUNC_NAME s_scm_sendfile
+{
+#define VALIDATE_FD_OR_PORT(cvar, svar, pos) \
+ if (scm_is_integer (svar)) \
+ cvar = scm_to_int (svar); \
+ else \
+ { \
+ SCM_VALIDATE_OPFPORT (pos, svar); \
+ scm_flush (svar); \
+ cvar = SCM_FPORT_FDES (svar); \
+ }
+
+ ssize_t result SCM_UNUSED;
+ size_t c_count, total = 0;
+ scm_t_off c_offset;
+ int in_fd, out_fd;
+
+ VALIDATE_FD_OR_PORT (out_fd, out, 1);
+ VALIDATE_FD_OR_PORT (in_fd, in, 2);
+ c_count = scm_to_size_t (count);
+ c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset);
+
+#if defined HAVE_SYS_SENDFILE_H && defined HAVE_SENDFILE
+ /* The Linux-style sendfile(2), which is different from the BSD-style. */
+
+ {
+ off_t *offset_ptr;
+
+ offset_ptr = SCM_UNBNDP (offset) ? NULL : &c_offset;
+
+ /* On Linux, when OUT_FD is a file, everything is transferred at once and
+ RESULT == C_COUNT. However, when OUT_FD is a pipe or other "slow"
+ device, fewer bytes may be transferred, hence the loop. RESULT == 0
+ means EOF on IN_FD, so leave the loop in that case. */
+ do
+ {
+ result = sendfile_or_sendfile64 (out_fd, in_fd, offset_ptr,
+ c_count - total);
+ if (result > 0)
+ /* At this point, either OFFSET_PTR is non-NULL and it has been
+ updated to the current offset in IN_FD, or it is NULL and IN_FD's
+ offset has been updated. */
+ total += result;
+ else if (result < 0 && (errno == EINTR || errno == EAGAIN))
+ /* Keep going. */
+ result = 1;
+ }
+ while (total < c_count && result > 0);
+ }
+
+ /* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd
+ must refer to a socket. Since Linux 2.6.33 it can be any file."
+ Fall back to read(2) and write(2) when such an error occurs. */
+ if (result < 0 && errno != EINVAL && errno != ENOSYS)
+ SCM_SYSERROR;
+ else if (result < 0)
+#endif
+ {
+ char buf[8192];
+ size_t left;
+ int reached_eof = 0;
+
+ if (!SCM_UNBNDP (offset))
+ {
+ if (SCM_PORTP (in))
+ scm_seek (in, scm_from_off_t (c_offset), scm_from_int (SEEK_SET));
+ else
+ {
+ if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0)
+ SCM_SYSERROR;
+ }
+ }
+
+ for (total = 0, left = c_count; total < c_count && !reached_eof; )
+ {
+ size_t asked, obtained, written;
+
+ asked = SCM_MIN (sizeof buf, left);
+ obtained = full_read (in_fd, buf, asked);
+ if (obtained < asked)
+ {
+ if (errno == 0)
+ reached_eof = 1;
+ else
+ SCM_SYSERROR;
+ }
+
+ left -= obtained;
+
+ written = full_write (out_fd, buf, obtained);
+ if (written < obtained)
+ SCM_SYSERROR;
+
+ total += written;
+ }
+
+ }
+
+ return scm_from_size_t (total);
+
+#undef VALIDATE_FD_OR_PORT
+}
+#undef FUNC_NAME
+
#endif /* HAVE_POSIX */
\f
#undef FUNC_NAME
#endif /* HAVE_GETCWD */
-#ifdef HAVE_MKDIR
SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
(SCM path, SCM mode),
"Create a new directory named by @var{path}. If @var{mode} is omitted\n"
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif /* HAVE_MKDIR */
-#ifdef HAVE_RMDIR
SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
(SCM path),
"Remove the existing directory named by @var{path}. The directory must\n"
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif
-
-#ifdef HAVE_RENAME
-#define my_rename rename
-#else
-static int
-my_rename (const char *oldname, const char *newname)
-{
- int rv;
-
- SCM_SYSCALL (rv = link (oldname, newname));
- if (rv == 0)
- {
- SCM_SYSCALL (rv = unlink (oldname));
- if (rv != 0)
- /* unlink failed. remove new name */
- SCM_SYSCALL (unlink (newname));
- }
- return rv;
-}
-#endif
SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
(SCM oldname, SCM newname),
STRING2_SYSCALL (oldname, c_oldname,
newname, c_newname,
- rv = my_rename (c_oldname, c_newname));
+ rv = rename (c_oldname, c_newname));
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
(SCM str),
- "Deletes (or \"unlinks\") the file specified by @var{path}.")
+ "Deletes (or \"unlinks\") the file specified by @var{str}.")
#define FUNC_NAME s_scm_delete_file
{
int ans;
SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
(SCM object, SCM mode),
- "Changes the permissions of the file referred to by @var{obj}.\n"
- "@var{obj} can be a string containing a file name or a port or integer file\n"
- "descriptor which is open on a file (in which case @code{fchmod} is used\n"
- "as the underlying system call).\n"
- "@var{mode} specifies\n"
- "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
+ "Changes the permissions of the file referred to by\n"
+ "@var{object}. @var{object} can be a string containing a file\n"
+ "name or a port or integer file descriptor which is open on a\n"
+ "file (in which case @code{fchmod} is used as the underlying\n"
+ "system call). @var{mode} specifies the new permissions as a\n"
+ "decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_chmod
{
int rv;
- int fdes;
object = SCM_COERCE_OUTPORT (object);
+#if HAVE_FCHMOD
if (scm_is_integer (object) || SCM_OPFPORTP (object))
{
+ int fdes;
if (scm_is_integer (object))
fdes = scm_to_int (object);
else
SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
}
else
+#endif
{
STRING_SYSCALL (object, c_object,
rv = chmod (c_object, scm_to_int (mode)));
}
#undef FUNC_NAME
-#ifndef HAVE_MKSTEMP
-extern int mkstemp (char *);
-#endif
-
SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
(SCM tmpl),
"Create a new unique file in the file system and return a new\n"
SCM scm_dot_string;
+#ifdef __MINGW32__
+SCM_SYMBOL (sym_file_name_convention, "windows");
+#else
+SCM_SYMBOL (sym_file_name_convention, "posix");
+#endif
+
+SCM_INTERNAL SCM scm_system_file_name_convention (void);
+
+SCM_DEFINE (scm_system_file_name_convention,
+ "system-file-name-convention", 0, 0, 0, (void),
+ "Return either @code{posix} or @code{windows}, depending on\n"
+ "what kind of system this Guile is running on.")
+#define FUNC_NAME s_scm_system_file_name_convention
+{
+ return sym_file_name_convention;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
(SCM filename),
"Return the directory name component of the file name\n"
len = scm_i_string_length (filename);
i = len - 1;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
- while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
- && scm_i_string_ref (filename, i) != '\\'))
- --i;
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
- while (i >= 0 && scm_i_string_ref (filename, i) != '/')
+ while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#endif /* ndef __MINGW32__ */
+
if (i < 0)
{
-#ifdef __MINGW32__
- if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
- || scm_i_string_ref (filename, 0) == '\\'))
-#else
- if (len > 0 && scm_i_string_ref (filename, 0) == '/')
-#endif /* ndef __MINGW32__ */
+ if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
"Return the base name of the file name @var{filename}. The\n"
"base name is the file name without any directory components.\n"
"If @var{suffix} is provided, and is equal to the end of\n"
- "@var{basename}, it is removed also.")
+ "@var{filename}, it is removed also.")
#define FUNC_NAME s_scm_basename
{
int i, j, len, end;
j = scm_i_string_length (suffix) - 1;
}
i = len - 1;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#endif /* ndef __MINGW32__ */
end = i;
while (i >= 0 && j >= 0
&& (scm_i_string_ref (filename, i)
}
if (j == -1)
end = i;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
- && scm_i_string_ref (filename, i) != '\\'))
+ while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) != '/')
- --i;
-#endif /* ndef __MINGW32__ */
if (i == end)
{
-#ifdef __MINGW32__
- if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
- || scm_i_string_ref (filename, 0) == '\\'))
-#else
- if (len > 0 && scm_i_string_ref (filename, 0) == '/')
-#endif /* ndef __MINGW32__ */
+ if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
scanon = scm_take_locale_string (canon);
for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
- if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
- scanon,
- SCM_UNDEFINED, SCM_UNDEFINED,
- SCM_UNDEFINED, SCM_UNDEFINED)))
- {
- size_t len = scm_c_string_length (scm_car (in_path));
+ {
+ SCM dir = scm_car (in_path);
+ size_t len = scm_c_string_length (dir);
+
+ /* When DIR is empty, it means "current working directory". We
+ could set DIR to (getcwd) in that case, but then the
+ canonicalization would depend on the current directory, which
+ is not what we want in the context of `compile-file', for
+ instance. */
+ if (len > 0
+ && scm_is_true (scm_string_prefix_p (dir, scanon,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ {
+ /* DIR either has a trailing delimiter or doesn't. SCANON
+ will be delimited by single delimiters. When DIR does not
+ have a trailing delimiter, add one to the length to strip
+ off the delimiter within SCANON. */
+ if (!is_file_name_separator (scm_c_string_ref (dir, len - 1)))
+ len++;
+
+ if (scm_c_string_length (scanon) > len)
+ return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
+ else
+ return SCM_BOOL_F;
+ }
+ }
- /* The path either has a trailing delimiter or doesn't. scanon will be
- delimited by single delimiters. In the case in which the path does
- not have a trailing delimiter, add one to the length to strip off the
- delimiter within scanon. */
- if (!len
-#ifdef __MINGW32__
- || (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
- && scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
+ return SCM_BOOL_F;
+}
+
+\f
+/* Examining directories. These procedures are used by `check-guile'
+ and thus compiled unconditionally. */
+
+scm_t_bits scm_tc16_dir;
+
+
+SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
+ (SCM obj),
+ "Return a boolean indicating whether @var{obj} is a directory\n"
+ "stream as returned by @code{opendir}.")
+#define FUNC_NAME s_scm_directory_stream_p
+{
+ return scm_from_bool (SCM_DIRP (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
+ (SCM dirname),
+ "Open the directory specified by @var{dirname} and return a directory\n"
+ "stream.")
+#define FUNC_NAME s_scm_opendir
+{
+ DIR *ds;
+ STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
+ if (ds == NULL)
+ SCM_SYSERROR;
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
+}
+#undef FUNC_NAME
+
+
+/* FIXME: The glibc manual has a portability note that readdir_r may not
+ null-terminate its return string. The circumstances outlined for this
+ are not clear, nor is it clear what should be done about it. Lets use
+ NAMLEN and worry about what else should be done if/when someone can
+ figure it out. */
+
+SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
+ (SCM port),
+ "Return (as a string) the next directory entry from the directory stream\n"
+ "@var{port}. If there is no remaining entry to be read then the\n"
+ "end of file object is returned.")
+#define FUNC_NAME s_scm_readdir
+{
+ struct dirent_or_dirent64 *rdent;
+
+ SCM_VALIDATE_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+#if HAVE_READDIR_R
+ /* As noted in the glibc manual, on various systems (such as Solaris) the
+ d_name[] field is only 1 char and you're expected to size the dirent
+ buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
+ effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
+ bigger.
+
+ On solaris 10 there's no NAME_MAX constant, it's necessary to use
+ pathconf(). We prefer NAME_MAX though, since it should be a constant
+ and will therefore save a system call. We also prefer it since dirfd()
+ is not available everywhere.
+
+ An alternative to dirfd() would be to open() the directory and then use
+ fdopendir(), if the latter is available. That'd let us hold the fd
+ somewhere in the smob, or just the dirent size calculated once. */
+ {
+ struct dirent_or_dirent64 de; /* just for sizeof */
+ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
+#ifdef NAME_MAX
+ char buf [SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
#else
- || scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+ char *buf;
+ long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
+ if (name_max == -1)
+ SCM_SYSERROR;
+ buf = alloca (SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + name_max + 1));
#endif
- )
- len++;
- if (scm_c_string_length (scanon) > len)
- return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
- else
- return SCM_BOOL_F;
- }
+ errno = 0;
+ SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
+ if (errno != 0)
+ SCM_SYSERROR;
+ if (! rdent)
+ return SCM_EOF_VAL;
- return SCM_BOOL_F;
+ return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+ }
+#else
+ {
+ SCM ret;
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ errno = 0;
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
+ if (errno != 0)
+ SCM_SYSERROR;
+
+ ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+
+ scm_dynwind_end ();
+ return ret;
+ }
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
+ (SCM port),
+ "Reset the directory port @var{port} so that the next call to\n"
+ "@code{readdir} will return the first directory entry.")
+#define FUNC_NAME s_scm_rewinddir
+{
+ SCM_VALIDATE_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+ rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
+ (SCM port),
+ "Close the directory stream @var{port}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_closedir
+{
+ SCM_VALIDATE_DIR (1, port);
+
+ if (SCM_DIR_OPEN_P (port))
+ {
+ int sts;
+
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
+ if (sts != 0)
+ SCM_SYSERROR;
+
+ SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_POSIX
+static int
+scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<", port);
+ if (!SCM_DIR_OPEN_P (exp))
+ scm_puts ("closed: ", port);
+ scm_puts ("directory stream ", port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
+ scm_putc ('>', port);
+ return 1;
}
+static size_t
+scm_dir_free (SCM p)
+{
+ if (SCM_DIR_OPEN_P (p))
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
+ return 0;
+}
+#endif
+
\f
void
#endif
#ifdef O_LARGEFILE
scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
-#endif
+#endif
+#ifdef O_NOTRANS
+ scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS));
+#endif
#ifdef F_DUPFD
scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
HCoop / bpt / guile.git / blobdiff