X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/c8ab29ac8e32f3f68efe1652e27d4a4cb2d90f4e..f6f4feb0a2222efcb297e634603621126542e63f:/libguile/fports.c diff --git a/libguile/fports.c b/libguile/fports.c index 2dc23758f..13d1dd732 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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 @@ -28,15 +28,6 @@ #include #include -#include "libguile/_scm.h" -#include "libguile/strings.h" -#include "libguile/validate.h" -#include "libguile/gc.h" -#include "libguile/posix.h" -#include "libguile/dynwind.h" -#include "libguile/hashtab.h" - -#include "libguile/fports.h" #ifdef HAVE_STRING_H #include @@ -50,36 +41,23 @@ #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE #include #endif -#ifdef HAVE_POLL_H #include -#endif #include #include +#include +#include #include -#include "libguile/iselect.h" - -/* Some defines for Windows (native port, not Cygwin). */ -#ifdef __MINGW32__ -# include -# include -#endif /* __MINGW32__ */ - -#include - -/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize - already, but have this code here in case that wasn't so in past versions, - or perhaps to help other minimal DOS environments. - - gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which - might be possibilities if we've got other systems without ftruncate. */ +#include "libguile/_scm.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/gc.h" +#include "libguile/posix.h" +#include "libguile/dynwind.h" +#include "libguile/hashtab.h" -#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE -# define ftruncate(fd, size) chsize (fd, size) -# undef HAVE_FTRUNCATE -# define HAVE_FTRUNCATE 1 -#endif +#include "libguile/fports.h" #if SIZEOF_OFF_T == SIZEOF_INT #define OFF_T_MAX INT_MAX @@ -174,7 +152,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, { int cmode; long csize; - SCM drained; + size_t ndrained; + char *drained; scm_t_port *pt; port = SCM_COERCE_OUTPORT (port); @@ -211,9 +190,21 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, pt = SCM_PTAB_ENTRY (port); if (SCM_INPUT_PORT_P (port)) - drained = scm_drain_input (port); + { + /* Drain pending input from PORT. Don't use `scm_drain_input' since + it returns a string, whereas we want binary input here. */ + ndrained = pt->read_end - pt->read_pos; + if (pt->read_buf == pt->putback_buf) + ndrained += pt->saved_read_end - pt->saved_read_pos; + + if (ndrained > 0) + { + drained = scm_gc_malloc_pointerless (ndrained, "file port"); + scm_take_from_input_buffers (port, drained, ndrained); + } + } else - drained = scm_nullstr; + ndrained = 0; if (SCM_OUTPUT_PORT_P (port)) scm_flush_unlocked (port); @@ -232,8 +223,9 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, scm_fport_buffer_add (port, csize, csize); - if (scm_is_true (drained) && scm_c_string_length (drained)) - scm_unread_string (drained, port); + if (ndrained > 0) + /* Put DRAINED back to PORT. */ + scm_unget_bytes ((unsigned char *) drained, ndrained, port); return SCM_UNSPECIFIED; } @@ -323,71 +315,35 @@ fport_canonicalize_filename (SCM filename) } } +/* scm_open_file_with_encoding + Return a new port open on a given file. -/* scm_open_file - * Return a new port open on a given file. - * - * The mode string must match the pattern: [rwa+]** which - * is interpreted in the usual unix way. - * - * Return the new port. - */ -SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, - (SCM filename, SCM mode), - "Open the file whose name is @var{filename}, and return a port\n" - "representing that file. The attributes of the port are\n" - "determined by the @var{mode} string. The way in which this is\n" - "interpreted is similar to C stdio. The first character must be\n" - "one of the following:\n" - "@table @samp\n" - "@item r\n" - "Open an existing file for input.\n" - "@item w\n" - "Open a file for output, creating it if it doesn't already exist\n" - "or removing its contents if it does.\n" - "@item a\n" - "Open a file for output, creating it if it doesn't already\n" - "exist. All writes to the port will go to the end of the file.\n" - "The \"append mode\" can be turned off while the port is in use\n" - "@pxref{Ports and File Descriptors, fcntl}\n" - "@end table\n" - "The following additional characters can be appended:\n" - "@table @samp\n" - "@item b\n" - "Open the underlying file in binary mode, if supported by the system.\n" - "Also, open the file using the binary-compatible character encoding\n" - "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n" - "at the top of the input file, if any.\n" - "@item +\n" - "Open the port for both input and output. E.g., @code{r+}: open\n" - "an existing file for both input and output.\n" - "@item 0\n" - "Create an \"unbuffered\" port. In this case input and output\n" - "operations are passed directly to the underlying port\n" - "implementation without additional buffering. This is likely to\n" - "slow down I/O operations. The buffering mode can be changed\n" - "while a port is in use @pxref{Ports and File Descriptors,\n" - "setvbuf}\n" - "@item l\n" - "Add line-buffering to the port. The port output buffer will be\n" - "automatically flushed whenever a newline character is written.\n" - "@end table\n" - "When the file is opened, this procedure will scan for a coding\n" - "declaration@pxref{Character Encoding of Source Files}. If present\n" - "will use that encoding for interpreting the file. Otherwise, the\n" - "port's encoding will be used.\n" - "\n" - "In theory we could create read/write ports which were buffered\n" - "in one direction only. However this isn't included in the\n" - "current interfaces. If a file cannot be opened with the access\n" - "requested, @code{open-file} throws an exception.") -#define FUNC_NAME s_scm_open_file + The mode string must match the pattern: [rwa+]** which + is interpreted in the usual unix way. + + Unless binary mode is requested, the character encoding of the new + port is determined as follows: First, if GUESS_ENCODING is true, + 'file-encoding' is used to guess the encoding of the file. If + GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used + unless it is also false. As a last resort, the default port encoding + is used. It is an error to pass a non-false GUESS_ENCODING or + ENCODING if binary mode is requested. + + Return the new port. */ +SCM +scm_open_file_with_encoding (SCM filename, SCM mode, + SCM guess_encoding, SCM encoding) +#define FUNC_NAME "open-file" { SCM port; - int fdes, flags = 0, use_encoding = 1; + int fdes, flags = 0, binary = 0; unsigned int retries; char *file, *md, *ptr; + if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding)))) + scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding, + "encoding to be string or false"); + scm_dynwind_begin (0); file = scm_to_locale_string (filename); @@ -419,7 +375,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR; break; case 'b': - use_encoding = 0; + binary = 1; #if defined (O_BINARY) flags |= O_BINARY; #endif @@ -458,21 +414,44 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), fport_canonicalize_filename (filename)); - if (use_encoding) + if (binary) { - /* If this file has a coding declaration, use that as the port - encoding. */ - if (SCM_INPUT_PORT_P (port)) - { - char *enc = scm_i_scan_for_encoding (port); - if (enc != NULL) - scm_i_set_port_encoding_x (port, enc); - } + if (scm_is_true (encoding)) + scm_misc_error (FUNC_NAME, + "Encoding specified on a binary port", + scm_list_1 (encoding)); + if (scm_is_true (guess_encoding)) + scm_misc_error (FUNC_NAME, + "Request to guess encoding on a binary port", + SCM_EOL); + + /* Use the binary-friendly ISO-8859-1 encoding. */ + scm_i_set_port_encoding_x (port, NULL); } else - /* If this is a binary file, use the binary-friendly ISO-8859-1 - encoding. */ - scm_i_set_port_encoding_x (port, NULL); + { + char *enc = NULL; + + if (scm_is_true (guess_encoding)) + { + if (SCM_INPUT_PORT_P (port)) + enc = scm_i_scan_for_encoding (port); + else + scm_misc_error (FUNC_NAME, + "Request to guess encoding on an output-only port", + SCM_EOL); + } + + if (!enc && scm_is_true (encoding)) + { + char *buf = scm_to_latin1_string (encoding); + enc = scm_gc_strdup (buf, "encoding"); + free (buf); + } + + if (enc) + scm_i_set_port_encoding_x (port, enc); + } scm_dynwind_end (); @@ -480,49 +459,76 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, } #undef FUNC_NAME - -#ifdef __MINGW32__ -/* - * Try getting the appropiate file flags for a given file descriptor - * under Windows. This incorporates some fancy operations because Windows - * differentiates between file, pipe and socket descriptors. - */ -#ifndef O_ACCMODE -# define O_ACCMODE 0x0003 -#endif +SCM +scm_open_file (SCM filename, SCM mode) +{ + return scm_open_file_with_encoding (filename, mode, SCM_BOOL_F, SCM_BOOL_F); +} -static int getflags (int fdes) +/* We can't define these using SCM_KEYWORD, because keywords have not + yet been initialized when scm_init_fports is called. */ +static SCM k_guess_encoding = SCM_UNDEFINED; +static SCM k_encoding = SCM_UNDEFINED; + +SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1, + (SCM filename, SCM mode, SCM keyword_args), + "Open the file whose name is @var{filename}, and return a port\n" + "representing that file. The attributes of the port are\n" + "determined by the @var{mode} string. The way in which this is\n" + "interpreted is similar to C stdio. The first character must be\n" + "one of the following:\n" + "@table @samp\n" + "@item r\n" + "Open an existing file for input.\n" + "@item w\n" + "Open a file for output, creating it if it doesn't already exist\n" + "or removing its contents if it does.\n" + "@item a\n" + "Open a file for output, creating it if it doesn't already\n" + "exist. All writes to the port will go to the end of the file.\n" + "The \"append mode\" can be turned off while the port is in use\n" + "@pxref{Ports and File Descriptors, fcntl}\n" + "@end table\n" + "The following additional characters can be appended:\n" + "@table @samp\n" + "@item b\n" + "Open the underlying file in binary mode, if supported by the system.\n" + "Also, open the file using the binary-compatible character encoding\n" + "\"ISO-8859-1\", ignoring the default port encoding.\n" + "@item +\n" + "Open the port for both input and output. E.g., @code{r+}: open\n" + "an existing file for both input and output.\n" + "@item 0\n" + "Create an \"unbuffered\" port. In this case input and output\n" + "operations are passed directly to the underlying port\n" + "implementation without additional buffering. This is likely to\n" + "slow down I/O operations. The buffering mode can be changed\n" + "while a port is in use @pxref{Ports and File Descriptors,\n" + "setvbuf}\n" + "@item l\n" + "Add line-buffering to the port. The port output buffer will be\n" + "automatically flushed whenever a newline character is written.\n" + "@end table\n" + "In theory we could create read/write ports which were buffered\n" + "in one direction only. However this isn't included in the\n" + "current interfaces. If a file cannot be opened with the access\n" + "requested, @code{open-file} throws an exception.") +#define FUNC_NAME s_scm_i_open_file { - int flags = 0; - struct stat buf; - int error, optlen = sizeof (int); - - /* Is this a socket ? */ - if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0) - flags = O_RDWR; - /* Maybe a regular file ? */ - else if (fstat (fdes, &buf) < 0) - flags = -1; - else - { - /* Or an anonymous pipe handle ? */ - if (buf.st_mode & _S_IFIFO) - flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0, - NULL, NULL, NULL) ? O_RDONLY : O_WRONLY; - /* stdin ? */ - else if (fdes == fileno (stdin) && isatty (fdes)) - flags = O_RDONLY; - /* stdout / stderr ? */ - else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) && - isatty (fdes)) - flags = O_WRONLY; - else - flags = buf.st_mode; - } - return flags; + SCM encoding = SCM_BOOL_F; + SCM guess_encoding = SCM_BOOL_F; + + scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0, + k_guess_encoding, &guess_encoding, + k_encoding, &encoding, + SCM_UNDEFINED); + + return scm_open_file_with_encoding (filename, mode, + guess_encoding, encoding); } -#endif /* __MINGW32__ */ +#undef FUNC_NAME + /* Building Guile ports from a file descriptor. */ /* Build a Scheme port from an open file descriptor `fdes'. @@ -536,14 +542,10 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) { SCM port; scm_t_fport *fp; - int flags; - /* test that fdes is valid. */ -#ifdef __MINGW32__ - flags = getflags (fdes); -#else - flags = fcntl (fdes, F_GETFL, 0); -#endif + /* Test that fdes is valid. */ +#ifdef F_GETFL + int flags = fcntl (fdes, F_GETFL, 0); if (flags == -1) SCM_SYSERROR; flags &= O_ACCMODE; @@ -553,6 +555,13 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) { SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL); } +#else + /* If we don't have F_GETFL, as on mingw, at least we can test that + it is a valid file descriptor. */ + struct stat st; + if (fstat (fdes, &st) != 0) + SCM_SYSERROR; +#endif fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport), "file port"); @@ -585,52 +594,12 @@ fport_input_waiting (SCM port) { int fdes = SCM_FSTREAM (port)->fdes; - /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the - highest numerical value of file descriptors that can be monitored. - Thus, use poll(2) whenever that is possible. */ - -#ifdef HAVE_POLL struct pollfd pollfd = { fdes, POLLIN, 0 }; if (poll (&pollfd, 1, 0) < 0) scm_syserror ("fport_input_waiting"); return pollfd.revents & POLLIN ? 1 : 0; - -#elif defined(HAVE_SELECT) - struct timeval timeout; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - FD_SET (fdes, &read_set); - - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - if (select (SELECT_SET_SIZE, - &read_set, &write_set, &except_set, &timeout) - < 0) - scm_syserror ("fport_input_waiting"); - return FD_ISSET (fdes, &read_set) ? 1 : 0; - -#elif HAVE_IOCTL && defined (FIONREAD) - /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD - (for use with winsock ioctlsocket()) but not ioctl(). */ - int fdes = SCM_FSTREAM (port)->fdes; - int remir; - ioctl(fdes, FIONREAD, &remir); - return remir; - -#else - scm_misc_error ("fport_input_waiting", - "Not fully implemented on this platform", - SCM_EOL); -#endif } @@ -1007,6 +976,15 @@ scm_make_fptob () return tc; } +/* We can't initialize the keywords from 'scm_init_fports', because + keywords haven't yet been initialized at that point. */ +void +scm_init_fports_keywords () +{ + k_guess_encoding = scm_from_latin1_keyword ("guess-encoding"); + k_encoding = scm_from_latin1_keyword ("encoding"); +} + void scm_init_fports () {