-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010, 2011 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
\f
+/* This file contains POSIX file system access procedures. Procedures
+ essential to the compiler and run-time (`stat', `canonicalize-path',
+ etc.) are compiled even with `--disable-posix'. */
+
/* See stime.c for comments on why _POSIX_C_SOURCE is not always defined. */
#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
#endif
#include <alloca.h>
-#include <canonicalize.h>
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
#include "libguile/iselect.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/lang.h"
#include "libguile/dynwind.h"
#include "libguile/validate.h"
# endif
#endif
-/* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
-#if defined (S_IFSOCK) && ! defined (S_ISSOCK)
-#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
-#endif
-
-/* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows
- compiler like BorlandC or MSVC has none of these macros defined. */
-#ifdef __MINGW32__
-
-# ifdef _S_IFIFO
-# undef _S_IFIFO
-# endif
-# ifdef _S_IFCHR
-# undef _S_IFCHR
-# endif
-# ifdef _S_IFBLK
-# undef _S_IFBLK
-# endif
-# ifdef _S_IFDIR
-# undef _S_IFDIR
-# endif
-# ifdef _S_IFREG
-# undef _S_IFREG
-# endif
-# ifdef _S_IFSOCK
-# undef _S_IFSOCK
-# endif
-
-# define _S_IFIFO 0x1000 /* FIFO */
-# define _S_IFCHR 0x2000 /* Character */
-# define _S_IFBLK 0x3000 /* Block */
-# define _S_IFDIR 0x4000 /* Directory */
-# define _S_IFREG 0x8000 /* Regular */
-# define _S_IFSOCK 0xC000 /* Socket */
-
-# ifdef S_ISBLK
-# undef S_ISBLK
-# endif
-# ifdef S_ISFIFO
-# undef S_ISFIFO
-# endif
-# ifdef S_ISCHR
-# undef S_ISCHR
-# endif
-# ifdef S_ISDIR
-# undef S_ISDIR
-# endif
-# ifdef S_ISREG
-# undef S_ISREG
-# endif
-# ifdef S_ISSOCK
-# undef S_ISSOCK
-# endif
-
-# define S_ISBLK(mode) (((mode) & _S_IFMT) == _S_IFBLK)
-# define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO)
-# define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR)
-# define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR)
-# define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG)
-# define S_ISSOCK(mode) (((mode) & _S_IFMT) == _S_IFSOCK)
-
-#endif /* __MINGW32__ */
-
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
# define mkdir(path, mode) mkdir (path)
\f
+#ifdef HAVE_POSIX
+
/* {Permissions}
*/
#undef FUNC_NAME
#endif /* HAVE_CHOWN */
-
-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"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_chmod
-{
- int rv;
- int fdes;
-
- object = SCM_COERCE_OUTPORT (object);
-
- if (scm_is_integer (object) || SCM_OPFPORTP (object))
- {
- if (scm_is_integer (object))
- fdes = scm_to_int (object);
- else
- fdes = SCM_FPORT_FDES (object);
- SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
- }
- else
- {
- STRING_SYSCALL (object, c_object,
- rv = chmod (c_object, scm_to_int (mode)));
- }
- if (rv == -1)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
- (SCM mode),
- "If @var{mode} is omitted, returns a decimal number representing the current\n"
- "file creation mask. Otherwise the file creation mask is set to\n"
- "@var{mode} and the previous value is returned.\n\n"
- "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
-#define FUNC_NAME s_scm_umask
-{
- mode_t mask;
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- }
- else
- {
- mask = umask (scm_to_uint (mode));
- }
- return scm_from_uint (mask);
-}
-#undef FUNC_NAME
-
\f
SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
}
#undef FUNC_NAME
+#endif /* HAVE_POSIX */
+
\f
/* {Files}
*/
static SCM
scm_stat2scm (struct stat_or_stat64 *stat_temp)
{
- SCM ans = scm_c_make_vector (15, SCM_UNSPECIFIED);
+ SCM ans = scm_c_make_vector (18, SCM_UNSPECIFIED);
SCM_SIMPLE_VECTOR_SET(ans, 0, scm_from_ulong (stat_temp->st_dev));
SCM_SIMPLE_VECTOR_SET(ans, 1, scm_from_ino_t_or_ino64_t (stat_temp->st_ino));
*/
}
+#ifdef HAVE_STRUCT_STAT_ST_ATIM
+ SCM_SIMPLE_VECTOR_SET(ans, 15, scm_from_long (stat_temp->st_atim.tv_nsec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 15, SCM_I_MAKINUM (0));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_MTIM
+ SCM_SIMPLE_VECTOR_SET(ans, 16, scm_from_long (stat_temp->st_mtim.tv_nsec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 16, SCM_I_MAKINUM (0));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_CTIM
+ SCM_SIMPLE_VECTOR_SET(ans, 17, scm_from_ulong (stat_temp->st_ctim.tv_sec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 17, SCM_I_MAKINUM (0));
+#endif
return ans;
}
#undef FUNC_NAME
\f
+#ifdef HAVE_POSIX
+
/* {Modifying Directories}
*/
#undef FUNC_NAME
#endif /* HAVE_LINK */
-#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),
- "Renames the file specified by @var{oldname} to @var{newname}.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_rename
-{
- int rv;
-
- STRING2_SYSCALL (oldname, c_oldname,
- newname, c_newname,
- rv = my_rename (c_oldname, c_newname));
- if (rv != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
- (SCM str),
- "Deletes (or \"unlinks\") the file specified by @var{path}.")
-#define FUNC_NAME s_scm_delete_file
-{
- int ans;
- STRING_SYSCALL (str, c_str, ans = unlink (c_str));
- if (ans != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#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"
- "then the permissions of the directory file are set using the current\n"
- "umask. Otherwise they are set to the decimal value specified with\n"
- "@var{mode}. The return value is unspecified.")
-#define FUNC_NAME s_scm_mkdir
-{
- int rv;
- mode_t mask;
-
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
- }
- else
- {
- STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
- }
- if (rv != 0)
- SCM_SYSERROR;
- 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"
- "be empty for this to succeed. The return value is unspecified.")
-#define FUNC_NAME s_scm_rmdir
-{
- int val;
-
- STRING_SYSCALL (path, c_path, val = rmdir (c_path));
- if (val != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-#endif
-
\f
/* {Examining Directories}
STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
if (ds == NULL)
SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds);
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
}
#undef FUNC_NAME
somewhere in the smob, or just the dirent size calculated once. */
{
struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_CELL_WORD_1 (port);
- size_t namlen;
+ 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)];
if (! rdent)
return SCM_EOF_VAL;
- namlen = NAMLEN (rdent);
-
return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
: SCM_EOF_VAL);
}
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
if (errno != 0)
SCM_SYSERROR;
if (!SCM_DIR_OPEN_P (port))
SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
- rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
+ rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
return SCM_UNSPECIFIED;
}
{
int sts;
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
if (sts != 0)
SCM_SYSERROR;
- SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
+ SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
}
return SCM_UNSPECIFIED;
if (!SCM_DIR_OPEN_P (exp))
scm_puts ("closed: ", port);
scm_puts ("directory stream ", port);
- scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
scm_putc ('>', port);
return 1;
}
scm_dir_free (SCM p)
{
if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_CELL_WORD_1 (p));
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
return 0;
}
}
#undef FUNC_NAME
-#ifdef HAVE_GETCWD
-SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
- (),
- "Return the name of the current working directory.")
-#define FUNC_NAME s_scm_getcwd
-{
- char *rv;
- size_t size = 100;
- char *wd;
- SCM result;
-
- wd = scm_malloc (size);
- while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
- {
- free (wd);
- size *= 2;
- wd = scm_malloc (size);
- }
- if (rv == 0)
- {
- int save_errno = errno;
- free (wd);
- errno = save_errno;
- SCM_SYSERROR;
- }
- result = scm_from_locale_stringn (wd, strlen (wd));
- free (wd);
- return result;
-}
-#undef FUNC_NAME
-#endif /* HAVE_GETCWD */
-
\f
#ifdef HAVE_SELECT
}
#undef FUNC_NAME
+#endif /* HAVE_POSIX */
+
+\f
+/* Essential procedures used in (system base compile). */
+
+#ifdef HAVE_GETCWD
+SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
+ (),
+ "Return the name of the current working directory.")
+#define FUNC_NAME s_scm_getcwd
+{
+ char *rv;
+ size_t size = 100;
+ char *wd;
+ SCM result;
+
+ wd = scm_malloc (size);
+ while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
+ {
+ free (wd);
+ size *= 2;
+ wd = scm_malloc (size);
+ }
+ if (rv == 0)
+ {
+ int save_errno = errno;
+ free (wd);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ result = scm_from_locale_stringn (wd, strlen (wd));
+ free (wd);
+ return result;
+}
+#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"
+ "then the permissions of the directory file are set using the current\n"
+ "umask. Otherwise they are set to the decimal value specified with\n"
+ "@var{mode}. The return value is unspecified.")
+#define FUNC_NAME s_scm_mkdir
+{
+ int rv;
+ mode_t mask;
+
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
+ }
+ else
+ {
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
+ }
+ if (rv != 0)
+ SCM_SYSERROR;
+ 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"
+ "be empty for this to succeed. The return value is unspecified.")
+#define FUNC_NAME s_scm_rmdir
+{
+ int val;
+
+ STRING_SYSCALL (path, c_path, val = rmdir (c_path));
+ if (val != 0)
+ SCM_SYSERROR;
+ 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),
+ "Renames the file specified by @var{oldname} to @var{newname}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_rename
+{
+ int rv;
+
+ STRING2_SYSCALL (oldname, c_oldname,
+ newname, c_newname,
+ rv = my_rename (c_oldname, c_newname));
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
+ (SCM str),
+ "Deletes (or \"unlinks\") the file specified by @var{path}.")
+#define FUNC_NAME s_scm_delete_file
+{
+ int ans;
+ STRING_SYSCALL (str, c_str, ans = unlink (c_str));
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_access, "access?", 2, 0, 0,
+ (SCM path, SCM how),
+ "Test accessibility of a file under the real UID and GID of the\n"
+ "calling process. The return is @code{#t} if @var{path} exists\n"
+ "and the permissions requested by @var{how} are all allowed, or\n"
+ "@code{#f} if not.\n"
+ "\n"
+ "@var{how} is an integer which is one of the following values,\n"
+ "or a bitwise-OR (@code{logior}) of multiple values.\n"
+ "\n"
+ "@defvar R_OK\n"
+ "Test for read permission.\n"
+ "@end defvar\n"
+ "@defvar W_OK\n"
+ "Test for write permission.\n"
+ "@end defvar\n"
+ "@defvar X_OK\n"
+ "Test for execute permission.\n"
+ "@end defvar\n"
+ "@defvar F_OK\n"
+ "Test for existence of the file. This is implied by each of the\n"
+ "other tests, so there's no need to combine it with them.\n"
+ "@end defvar\n"
+ "\n"
+ "It's important to note that @code{access?} does not simply\n"
+ "indicate what will happen on attempting to read or write a\n"
+ "file. In normal circumstances it does, but in a set-UID or\n"
+ "set-GID program it doesn't because @code{access?} tests the\n"
+ "real ID, whereas an open or execute attempt uses the effective\n"
+ "ID.\n"
+ "\n"
+ "A program which will never run set-UID/GID can ignore the\n"
+ "difference between real and effective IDs, but for maximum\n"
+ "generality, especially in library functions, it's best not to\n"
+ "use @code{access?} to predict the result of an open or execute,\n"
+ "instead simply attempt that and catch any exception.\n"
+ "\n"
+ "The main use for @code{access?} is to let a set-UID/GID program\n"
+ "determine what the invoking user would have been allowed to do,\n"
+ "without the greater (or perhaps lesser) privileges afforded by\n"
+ "the effective ID. For more on this, see ``Testing File\n"
+ "Access'' in The GNU C Library Reference Manual.")
+#define FUNC_NAME s_scm_access
+{
+ int rv;
+ char *c_path;
+
+ c_path = scm_to_locale_string (path);
+ rv = access (c_path, scm_to_int (how));
+ free (c_path);
+
+ return scm_from_bool (!rv);
+}
+#undef FUNC_NAME
+
+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"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_chmod
+{
+ int rv;
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (scm_is_integer (object) || SCM_OPFPORTP (object))
+ {
+ if (scm_is_integer (object))
+ fdes = scm_to_int (object);
+ else
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
+ }
+ else
+ {
+ STRING_SYSCALL (object, c_object,
+ rv = chmod (c_object, scm_to_int (mode)));
+ }
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
+ (SCM mode),
+ "If @var{mode} is omitted, returns a decimal number representing the current\n"
+ "file creation mask. Otherwise the file creation mask is set to\n"
+ "@var{mode} and the previous value is returned.\n\n"
+ "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
+#define FUNC_NAME s_scm_umask
+{
+ mode_t mask;
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ }
+ else
+ {
+ mask = umask (scm_to_uint (mode));
+ }
+ return scm_from_uint (mask);
+}
+#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"
+ "buffered port open for reading and writing to the file.\n"
+ "\n"
+ "@var{tmpl} is a string specifying where the file should be\n"
+ "created: it must end with @samp{XXXXXX} and those @samp{X}s\n"
+ "will be changed in the string to return the name of the file.\n"
+ "(@code{port-filename} on the port also gives the name.)\n"
+ "\n"
+ "POSIX doesn't specify the permissions mode of the file, on GNU\n"
+ "and most systems it's @code{#o600}. An application can use\n"
+ "@code{chmod} to relax that if desired. For example\n"
+ "@code{#o666} less @code{umask}, which is usual for ordinary\n"
+ "file creation,\n"
+ "\n"
+ "@example\n"
+ "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n"
+ " (chmod port (logand #o666 (lognot (umask))))\n"
+ " ...)\n"
+ "@end example")
+#define FUNC_NAME s_scm_mkstemp
+{
+ char *c_tmpl;
+ int rv;
+
+ scm_dynwind_begin (0);
+
+ c_tmpl = scm_to_locale_string (tmpl);
+ scm_dynwind_free (c_tmpl);
+
+ SCM_SYSCALL (rv = mkstemp (c_tmpl));
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ scm_substring_move_x (scm_from_locale_string (c_tmpl),
+ SCM_INUM0, scm_string_length (tmpl),
+ tmpl, SCM_INUM0);
+
+ scm_dynwind_end ();
+ return scm_fdes_to_port (rv, "w+", tmpl);
+}
+#undef FUNC_NAME
+
\f
/* Filename manipulation */
"separators (@code{/}) nor symlinks.\n\n"
"Raises an error if any component of @var{path} does not exist.")
#define FUNC_NAME s_scm_canonicalize_path
-{ char *str, *canon;
+{
+ char *str, *canon;
SCM_VALIDATE_STRING (1, path);
}
#undef FUNC_NAME
+SCM
+scm_i_relativize_path (SCM path, SCM in_path)
+{
+ char *str, *canon;
+ SCM scanon;
+
+ str = scm_to_locale_string (path);
+ canon = canonicalize_file_name (str);
+ free (str);
+
+ if (!canon)
+ return SCM_BOOL_F;
+
+ 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));
+
+ /* 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) != '\\')
+#else
+ || scm_i_string_ref (scm_car (in_path), len - 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;
+ }
+
+ return SCM_BOOL_F;
+}
+
\f
void
scm_init_filesys ()
{
+#ifdef HAVE_POSIX
scm_tc16_dir = scm_make_smob_type ("directory", 0);
scm_set_smob_free (scm_tc16_dir, scm_dir_free);
scm_set_smob_print (scm_tc16_dir, scm_dir_print);
- scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
-
#ifdef O_RDONLY
scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
#endif
#ifdef FD_CLOEXEC
scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
#endif
+#endif /* HAVE_POSIX */
+
+ /* `access' symbols. */
+ scm_c_define ("R_OK", scm_from_int (R_OK));
+ scm_c_define ("W_OK", scm_from_int (W_OK));
+ scm_c_define ("X_OK", scm_from_int (X_OK));
+ scm_c_define ("F_OK", scm_from_int (F_OK));
+
+ scm_dot_string = scm_from_locale_string (".");
#include "libguile/filesys.x"
}
HCoop / bpt / guile.git / blobdiff