1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
28 #include "libguile/_scm.h"
29 #include "libguile/strings.h"
30 #include "libguile/validate.h"
31 #include "libguile/gc.h"
32 #include "libguile/posix.h"
33 #include "libguile/dynwind.h"
35 #include "libguile/fports.h"
46 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
51 #include <sys/types.h>
53 #include "libguile/iselect.h"
55 /* Some defines for Windows (native port, not Cygwin). */
57 # include <sys/stat.h>
58 # include <winsock2.h>
59 #endif /* __MINGW32__ */
61 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
62 already, but have this code here in case that wasn't so in past versions,
63 or perhaps to help other minimal DOS environments.
65 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
66 might be possibilities if we've got other systems without ftruncate. */
68 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
69 # define ftruncate(fd, size) chsize (fd, size)
71 #define HAVE_FTRUNCATE 1
74 #if SIZEOF_OFF_T == SIZEOF_INT
75 #define OFF_T_MAX INT_MAX
76 #define OFF_T_MIN INT_MIN
77 #elif SIZEOF_OFF_T == SIZEOF_LONG
78 #define OFF_T_MAX LONG_MAX
79 #define OFF_T_MIN LONG_MIN
80 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
81 #define OFF_T_MAX LONG_LONG_MAX
82 #define OFF_T_MIN LONG_LONG_MIN
84 #error Oops, unknown OFF_T size
87 scm_t_bits scm_tc16_fport;
90 /* default buffer size, used if the O/S won't supply a value. */
91 static const size_t default_buffer_size = 1024;
93 /* create FPORT buffer with specified sizes (or -1 to use default size or
96 scm_fport_buffer_add (SCM port, long read_size, int write_size)
97 #define FUNC_NAME "scm_fport_buffer_add"
99 scm_t_port *pt = SCM_PTAB_ENTRY (port);
101 if (read_size == -1 || write_size == -1)
104 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
106 scm_t_fport *fp = SCM_FSTREAM (port);
108 default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
111 default_size = default_buffer_size;
114 read_size = default_size;
115 if (write_size == -1)
116 write_size = default_size;
119 if (SCM_INPUT_PORT_P (port) && read_size > 0)
121 pt->read_buf = scm_gc_malloc (read_size, "port buffer");
122 pt->read_pos = pt->read_end = pt->read_buf;
123 pt->read_buf_size = read_size;
127 pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
128 pt->read_buf_size = 1;
131 if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
133 pt->write_buf = scm_gc_malloc (write_size, "port buffer");
134 pt->write_pos = pt->write_buf;
135 pt->write_buf_size = write_size;
139 pt->write_buf = pt->write_pos = &pt->shortbuf;
140 pt->write_buf_size = 1;
143 pt->write_end = pt->write_buf + pt->write_buf_size;
144 if (read_size > 0 || write_size > 0)
145 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
147 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
151 SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
152 (SCM port, SCM mode, SCM size),
153 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
160 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
161 "If @var{size} is omitted, a default size will be used.\n"
163 #define FUNC_NAME s_scm_setvbuf
169 port = SCM_COERCE_OUTPORT (port);
171 SCM_VALIDATE_OPFPORT (1,port);
172 cmode = scm_to_int (mode);
173 if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
174 scm_out_of_range (FUNC_NAME, mode);
178 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
183 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
186 if (SCM_UNBNDP (size))
195 csize = scm_to_int (size);
196 if (csize < 0 || (cmode == _IONBF && csize > 0))
197 scm_out_of_range (FUNC_NAME, size);
200 pt = SCM_PTAB_ENTRY (port);
202 /* silently discards buffered and put-back chars. */
203 if (pt->read_buf == pt->putback_buf)
205 pt->read_buf = pt->saved_read_buf;
206 pt->read_pos = pt->saved_read_pos;
207 pt->read_end = pt->saved_read_end;
208 pt->read_buf_size = pt->saved_read_buf_size;
210 if (pt->read_buf != &pt->shortbuf)
211 scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
212 if (pt->write_buf != &pt->shortbuf)
213 scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
215 scm_fport_buffer_add (port, csize, csize);
216 return SCM_UNSPECIFIED;
220 /* Move ports with the specified file descriptor to new descriptors,
221 * resetting the revealed count to 0.
225 scm_evict_ports (int fd)
229 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
231 for (i = 0; i < scm_i_port_table_size; i++)
233 SCM port = scm_i_port_table[i]->port;
235 if (SCM_FPORTP (port))
237 scm_t_fport *fp = SCM_FSTREAM (port);
243 scm_syserror ("scm_evict_ports");
244 scm_set_port_revealed_x (port, scm_from_int (0));
249 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
253 SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
255 "Determine whether @var{obj} is a port that is related to a file.")
256 #define FUNC_NAME s_scm_file_port_p
258 return scm_from_bool (SCM_FPORTP (obj));
264 * Return a new port open on a given file.
266 * The mode string must match the pattern: [rwa+]** which
267 * is interpreted in the usual unix way.
269 * Return the new port.
271 SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
272 (SCM filename, SCM mode),
273 "Open the file whose name is @var{filename}, and return a port\n"
274 "representing that file. The attributes of the port are\n"
275 "determined by the @var{mode} string. The way in which this is\n"
276 "interpreted is similar to C stdio. The first character must be\n"
277 "one of the following:\n"
280 "Open an existing file for input.\n"
282 "Open a file for output, creating it if it doesn't already exist\n"
283 "or removing its contents if it does.\n"
285 "Open a file for output, creating it if it doesn't already\n"
286 "exist. All writes to the port will go to the end of the file.\n"
287 "The \"append mode\" can be turned off while the port is in use\n"
288 "@pxref{Ports and File Descriptors, fcntl}\n"
290 "The following additional characters can be appended:\n"
293 "Open the underlying file in binary mode, if supported by the operating system. "
295 "Open the port for both input and output. E.g., @code{r+}: open\n"
296 "an existing file for both input and output.\n"
298 "Create an \"unbuffered\" port. In this case input and output\n"
299 "operations are passed directly to the underlying port\n"
300 "implementation without additional buffering. This is likely to\n"
301 "slow down I/O operations. The buffering mode can be changed\n"
302 "while a port is in use @pxref{Ports and File Descriptors,\n"
305 "Add line-buffering to the port. The port output buffer will be\n"
306 "automatically flushed whenever a newline character is written.\n"
308 "In theory we could create read/write ports which were buffered\n"
309 "in one direction only. However this isn't included in the\n"
310 "current interfaces. If a file cannot be opened with the access\n"
311 "requested, @code{open-file} throws an exception.")
312 #define FUNC_NAME s_scm_open_file
321 scm_dynwind_begin (0);
323 file = scm_to_locale_string (filename);
324 scm_dynwind_free (file);
326 md = scm_to_locale_string (mode);
327 scm_dynwind_free (md);
335 flags |= O_WRONLY | O_CREAT | O_TRUNC;
338 flags |= O_WRONLY | O_CREAT | O_APPEND;
341 scm_out_of_range (FUNC_NAME, mode);
349 flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
352 #if defined (O_BINARY)
356 case '0': /* unbuffered: handled later. */
357 case 'l': /* line buffered: handled during output. */
360 scm_out_of_range (FUNC_NAME, mode);
364 SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
369 SCM_SYSERROR_MSG ("~A: ~S",
370 scm_cons (scm_strerror (scm_from_int (en)),
371 scm_cons (filename, SCM_EOL)), en);
373 port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
384 * Try getting the appropiate file flags for a given file descriptor
385 * under Windows. This incorporates some fancy operations because Windows
386 * differentiates between file, pipe and socket descriptors.
389 # define O_ACCMODE 0x0003
392 static int getflags (int fdes)
396 int error, optlen = sizeof (int);
398 /* Is this a socket ? */
399 if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
401 /* Maybe a regular file ? */
402 else if (fstat (fdes, &buf) < 0)
406 /* Or an anonymous pipe handle ? */
407 if (buf.st_mode & _S_IFIFO)
408 flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
409 NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
411 else if (fdes == fileno (stdin) && isatty (fdes))
413 /* stdout / stderr ? */
414 else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
422 #endif /* __MINGW32__ */
424 /* Building Guile ports from a file descriptor. */
426 /* Build a Scheme port from an open file descriptor `fdes'.
427 MODE indicates whether FILE is open for reading or writing; it uses
428 the same notation as open-file's second argument.
429 NAME is a string to be used as the port's filename.
432 scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
433 #define FUNC_NAME "scm_fdes_to_port"
439 /* test that fdes is valid. */
441 flags = getflags (fdes);
443 flags = fcntl (fdes, F_GETFL, 0);
449 && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
450 || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
452 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
455 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
457 port = scm_new_port_table_entry (scm_tc16_fport);
458 SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
459 pt = SCM_PTAB_ENTRY(port);
462 = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
465 pt->rw_random = SCM_FDES_RANDOM_P (fdes);
466 SCM_SETSTREAM (port, fp);
467 if (mode_bits & SCM_BUF0)
468 scm_fport_buffer_add (port, 0, 0);
470 scm_fport_buffer_add (port, -1, -1);
472 SCM_SET_FILENAME (port, name);
473 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
479 scm_fdes_to_port (int fdes, char *mode, SCM name)
481 return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
484 /* Return a lower bound on the number of bytes available for input. */
486 fport_input_waiting (SCM port)
489 int fdes = SCM_FSTREAM (port)->fdes;
490 struct timeval timeout;
491 SELECT_TYPE read_set;
492 SELECT_TYPE write_set;
493 SELECT_TYPE except_set;
496 FD_ZERO (&write_set);
497 FD_ZERO (&except_set);
499 FD_SET (fdes, &read_set);
504 if (select (SELECT_SET_SIZE,
505 &read_set, &write_set, &except_set, &timeout)
507 scm_syserror ("fport_input_waiting");
508 return FD_ISSET (fdes, &read_set) ? 1 : 0;
510 #elif HAVE_IOCTL && defined (FIONREAD)
511 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
512 (for use with winsock ioctlsocket()) but not ioctl(). */
513 int fdes = SCM_FSTREAM (port)->fdes;
515 ioctl(fdes, FIONREAD, &remir);
519 scm_misc_error ("fport_input_waiting",
520 "Not fully implemented on this platform",
527 fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
529 scm_puts ("#<", port);
530 scm_print_port_mode (exp, port);
531 if (SCM_OPFPORTP (exp))
534 SCM name = SCM_FILENAME (exp);
535 if (scm_is_string (name) || scm_is_symbol (name))
536 scm_display (name, port);
538 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
539 scm_putc (' ', port);
540 fdes = (SCM_FSTREAM (exp))->fdes;
544 scm_display (scm_ttyname (exp), port);
546 #endif /* HAVE_TTYNAME */
547 scm_intprint (fdes, 10, port);
551 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
552 scm_putc (' ', port);
553 scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
555 scm_putc ('>', port);
560 /* thread-local block for input on fport's fdes. */
562 fport_wait_for_input (SCM port)
564 int fdes = SCM_FSTREAM (port)->fdes;
566 if (!fport_input_waiting (port))
570 int flags = fcntl (fdes, F_GETFL);
573 scm_syserror ("scm_fdes_wait_for_input");
574 if (!(flags & O_NONBLOCK))
578 FD_SET (fdes, &readfds);
579 n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
581 while (n == -1 && errno == EINTR);
584 #endif /* !__MINGW32__ */
586 static void fport_flush (SCM port);
588 /* fill a port's read-buffer with a single read. returns the first
589 char or EOF if end of file. */
591 fport_fill_input (SCM port)
594 scm_t_port *pt = SCM_PTAB_ENTRY (port);
595 scm_t_fport *fp = SCM_FSTREAM (port);
598 fport_wait_for_input (port);
599 #endif /* !__MINGW32__ */
600 SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
602 scm_syserror ("fport_fill_input");
607 pt->read_pos = pt->read_buf;
608 pt->read_end = pt->read_buf + count;
609 return *pt->read_buf;
613 static off_t_or_off64_t
614 fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
616 scm_t_port *pt = SCM_PTAB_ENTRY (port);
617 scm_t_fport *fp = SCM_FSTREAM (port);
619 off_t_or_off64_t result;
621 if (pt->rw_active == SCM_PORT_WRITE)
623 if (offset != 0 || whence != SEEK_CUR)
626 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
630 /* read current position without disturbing the buffer. */
631 rv = lseek_or_lseek64 (fp->fdes, offset, whence);
632 result = rv + (pt->write_pos - pt->write_buf);
635 else if (pt->rw_active == SCM_PORT_READ)
637 if (offset != 0 || whence != SEEK_CUR)
639 /* could expand to avoid a second seek. */
640 scm_end_input (port);
641 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
645 /* read current position without disturbing the buffer
646 (particularly the unread-char buffer). */
647 rv = lseek_or_lseek64 (fp->fdes, offset, whence);
648 result = rv - (pt->read_end - pt->read_pos);
650 if (pt->read_buf == pt->putback_buf)
651 result -= pt->saved_read_end - pt->saved_read_pos;
654 else /* SCM_PORT_NEITHER */
656 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
660 scm_syserror ("fport_seek");
665 /* If we've got largefile and off_t isn't already off64_t then
666 fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
669 Otherwise if no largefile, or off_t is the same as off64_t (which is the
670 case on NetBSD apparently), then fport_seek_or_seek64 is right to be
671 fport_seek already. */
673 #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
675 fport_seek (SCM port, off_t offset, int whence)
677 off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
678 if (rv > OFF_T_MAX || rv < OFF_T_MIN)
681 scm_syserror ("fport_seek");
687 #define fport_seek fport_seek_or_seek64
690 /* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
692 scm_i_fport_seek (SCM port, SCM offset, int how)
694 return scm_from_off_t_or_off64_t
695 (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
699 fport_truncate (SCM port, off_t length)
701 scm_t_fport *fp = SCM_FSTREAM (port);
703 if (ftruncate (fp->fdes, length) == -1)
704 scm_syserror ("ftruncate");
708 scm_i_fport_truncate (SCM port, SCM length)
710 scm_t_fport *fp = SCM_FSTREAM (port);
711 return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
714 /* helper for fport_write: try to write data, using multiple system
715 calls if required. */
716 #define FUNC_NAME "write_all"
717 static void write_all (SCM port, const void *data, size_t remaining)
719 int fdes = SCM_FSTREAM (port)->fdes;
721 while (remaining > 0)
725 SCM_SYSCALL (done = write (fdes, data, remaining));
730 data = ((const char *) data) + done;
736 fport_write (SCM port, const void *data, size_t size)
738 /* this procedure tries to minimize the number of writes/flushes. */
739 scm_t_port *pt = SCM_PTAB_ENTRY (port);
741 if (pt->write_buf == &pt->shortbuf
742 || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
744 /* "unbuffered" port, or
745 port with empty buffer and data won't fit in buffer. */
746 write_all (port, data, size);
751 off_t space = pt->write_end - pt->write_pos;
755 /* data fits in buffer. */
756 memcpy (pt->write_pos, data, size);
757 pt->write_pos += size;
758 if (pt->write_pos == pt->write_end)
761 /* we can skip the line-buffering check if nothing's buffered. */
767 memcpy (pt->write_pos, data, space);
768 pt->write_pos = pt->write_end;
771 const void *ptr = ((const char *) data) + space;
772 size_t remaining = size - space;
774 if (size >= pt->write_buf_size)
776 write_all (port, ptr, remaining);
781 memcpy (pt->write_pos, ptr, remaining);
782 pt->write_pos += remaining;
787 /* handle line buffering. */
788 if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
793 /* becomes 1 when process is exiting: normal exception handling won't
794 work by this time. */
795 extern int scm_i_terminating;
798 fport_flush (SCM port)
800 scm_t_port *pt = SCM_PTAB_ENTRY (port);
801 scm_t_fport *fp = SCM_FSTREAM (port);
802 unsigned char *ptr = pt->write_buf;
803 long init_size = pt->write_pos - pt->write_buf;
804 long remaining = init_size;
806 while (remaining > 0)
810 SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
813 /* error. assume nothing was written this call, but
814 fix up the buffer for any previous successful writes. */
815 long done = init_size - remaining;
821 for (i = 0; i < remaining; i++)
823 *(pt->write_buf + i) = *(pt->write_buf + done + i);
825 pt->write_pos = pt->write_buf + remaining;
827 if (scm_i_terminating)
829 const char *msg = "Error: could not flush file-descriptor ";
833 written = write (2, msg, strlen (msg));
834 sprintf (buf, "%d\n", fp->fdes);
835 written = write (2, buf, strlen (buf));
839 else if (scm_gc_running_p)
841 /* silently ignore the error. scm_error would abort if we
846 scm_syserror ("fport_flush");
851 pt->write_pos = pt->write_buf;
852 pt->rw_active = SCM_PORT_NEITHER;
855 /* clear the read buffer and adjust the file position for unread bytes. */
857 fport_end_input (SCM port, int offset)
859 scm_t_fport *fp = SCM_FSTREAM (port);
860 scm_t_port *pt = SCM_PTAB_ENTRY (port);
862 offset += pt->read_end - pt->read_pos;
866 pt->read_pos = pt->read_end;
867 /* will throw error if unread-char used at beginning of file
868 then attempting to write. seems correct. */
869 if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
870 scm_syserror ("fport_end_input");
872 pt->rw_active = SCM_PORT_NEITHER;
876 fport_close (SCM port)
878 scm_t_fport *fp = SCM_FSTREAM (port);
879 scm_t_port *pt = SCM_PTAB_ENTRY (port);
883 SCM_SYSCALL (rv = close (fp->fdes));
884 if (rv == -1 && errno != EBADF)
886 if (scm_gc_running_p)
887 /* silently ignore the error. scm_error would abort if we
891 scm_syserror ("fport_close");
893 if (pt->read_buf == pt->putback_buf)
894 pt->read_buf = pt->saved_read_buf;
895 if (pt->read_buf != &pt->shortbuf)
896 scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
897 if (pt->write_buf != &pt->shortbuf)
898 scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
899 scm_gc_free (fp, sizeof (*fp), "file port");
904 fport_free (SCM port)
913 scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
915 scm_set_port_free (tc, fport_free);
916 scm_set_port_print (tc, fport_print);
917 scm_set_port_flush (tc, fport_flush);
918 scm_set_port_end_input (tc, fport_end_input);
919 scm_set_port_close (tc, fport_close);
920 scm_set_port_seek (tc, fport_seek);
921 scm_set_port_truncate (tc, fport_truncate);
922 scm_set_port_input_waiting (tc, fport_input_waiting);
930 scm_tc16_fport = scm_make_fptob ();
932 scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
933 scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
934 scm_c_define ("_IONBF", scm_from_int (_IONBF));
936 #include "libguile/fports.x"