1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
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.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
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
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
23 #define _GNU_SOURCE /* ask for LONG_LONG_MAX/LONG_LONG_MIN */
41 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
46 #include <sys/types.h>
48 #include <sys/select.h>
50 #include <full-write.h>
52 #include "libguile/_scm.h"
53 #include "libguile/strings.h"
54 #include "libguile/validate.h"
55 #include "libguile/gc.h"
56 #include "libguile/posix.h"
57 #include "libguile/dynwind.h"
58 #include "libguile/hashtab.h"
60 #include "libguile/fports.h"
62 #if SIZEOF_OFF_T == SIZEOF_INT
63 #define OFF_T_MAX INT_MAX
64 #define OFF_T_MIN INT_MIN
65 #elif SIZEOF_OFF_T == SIZEOF_LONG
66 #define OFF_T_MAX LONG_MAX
67 #define OFF_T_MIN LONG_MIN
68 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
69 #define OFF_T_MAX LONG_LONG_MAX
70 #define OFF_T_MIN LONG_LONG_MIN
72 #error Oops, unknown OFF_T size
75 scm_t_bits scm_tc16_fport
;
78 /* default buffer size, used if the O/S won't supply a value. */
79 static const size_t default_buffer_size
= 1024;
81 /* create FPORT buffer with specified sizes (or -1 to use default size or
84 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
85 #define FUNC_NAME "scm_fport_buffer_add"
87 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
89 if (read_size
== -1 || write_size
== -1)
92 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
94 scm_t_fport
*fp
= SCM_FSTREAM (port
);
96 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
99 default_size
= default_buffer_size
;
102 read_size
= default_size
;
103 if (write_size
== -1)
104 write_size
= default_size
;
107 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
109 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
110 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
111 pt
->read_buf_size
= read_size
;
115 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
116 pt
->read_buf_size
= 1;
119 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
121 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
122 pt
->write_pos
= pt
->write_buf
;
123 pt
->write_buf_size
= write_size
;
127 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
128 pt
->write_buf_size
= 1;
131 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
132 if (read_size
> 0 || write_size
> 0)
133 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
135 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
139 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
140 (SCM port
, SCM mode
, SCM size
),
141 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
148 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
149 "If @var{size} is omitted, a default size will be used.\n"
151 #define FUNC_NAME s_scm_setvbuf
159 port
= SCM_COERCE_OUTPORT (port
);
161 SCM_VALIDATE_OPFPORT (1,port
);
162 cmode
= scm_to_int (mode
);
163 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
164 scm_out_of_range (FUNC_NAME
, mode
);
168 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
173 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
176 if (SCM_UNBNDP (size
))
185 csize
= scm_to_int (size
);
186 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
187 scm_out_of_range (FUNC_NAME
, size
);
190 pt
= SCM_PTAB_ENTRY (port
);
192 if (SCM_INPUT_PORT_P (port
))
194 /* Drain pending input from PORT. Don't use `scm_drain_input' since
195 it returns a string, whereas we want binary input here. */
196 ndrained
= pt
->read_end
- pt
->read_pos
;
197 if (pt
->read_buf
== pt
->putback_buf
)
198 ndrained
+= pt
->saved_read_end
- pt
->saved_read_pos
;
202 drained
= scm_gc_malloc_pointerless (ndrained
, "file port");
203 scm_take_from_input_buffers (port
, drained
, ndrained
);
209 if (SCM_OUTPUT_PORT_P (port
))
212 if (pt
->read_buf
== pt
->putback_buf
)
214 pt
->read_buf
= pt
->saved_read_buf
;
215 pt
->read_pos
= pt
->saved_read_pos
;
216 pt
->read_end
= pt
->saved_read_end
;
217 pt
->read_buf_size
= pt
->saved_read_buf_size
;
219 if (pt
->read_buf
!= &pt
->shortbuf
)
220 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
221 if (pt
->write_buf
!= &pt
->shortbuf
)
222 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
224 scm_fport_buffer_add (port
, csize
, csize
);
227 /* Put DRAINED back to PORT. */
228 while (ndrained
-- > 0)
229 scm_unget_byte (drained
[ndrained
], port
);
231 return SCM_UNSPECIFIED
;
235 /* Move ports with the specified file descriptor to new descriptors,
236 * resetting the revealed count to 0.
239 scm_i_evict_port (void *closure
, SCM port
)
241 int fd
= * (int*) closure
;
243 if (SCM_FPORTP (port
))
248 /* XXX: In some cases, we can encounter a port with no associated ptab
250 p
= SCM_PTAB_ENTRY (port
);
251 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
253 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
257 scm_syserror ("scm_evict_ports");
258 scm_set_port_revealed_x (port
, scm_from_int (0));
264 scm_evict_ports (int fd
)
266 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
270 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
272 "Determine whether @var{obj} is a port that is related to a file.")
273 #define FUNC_NAME s_scm_file_port_p
275 return scm_from_bool (SCM_FPORTP (obj
));
280 static SCM sys_file_port_name_canonicalization
;
281 SCM_SYMBOL (sym_relative
, "relative");
282 SCM_SYMBOL (sym_absolute
, "absolute");
285 fport_canonicalize_filename (SCM filename
)
287 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
289 if (!scm_is_string (filename
))
293 else if (scm_is_eq (mode
, sym_relative
))
297 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
299 rel
= scm_i_relativize_path (filename
, path
);
301 return scm_is_true (rel
) ? rel
: filename
;
303 else if (scm_is_eq (mode
, sym_absolute
))
307 str
= scm_to_locale_string (filename
);
308 canon
= canonicalize_file_name (str
);
311 return canon
? scm_take_locale_string (canon
) : filename
;
321 * Return a new port open on a given file.
323 * The mode string must match the pattern: [rwa+]** which
324 * is interpreted in the usual unix way.
326 * Return the new port.
328 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
329 (SCM filename
, SCM mode
),
330 "Open the file whose name is @var{filename}, and return a port\n"
331 "representing that file. The attributes of the port are\n"
332 "determined by the @var{mode} string. The way in which this is\n"
333 "interpreted is similar to C stdio. The first character must be\n"
334 "one of the following:\n"
337 "Open an existing file for input.\n"
339 "Open a file for output, creating it if it doesn't already exist\n"
340 "or removing its contents if it does.\n"
342 "Open a file for output, creating it if it doesn't already\n"
343 "exist. All writes to the port will go to the end of the file.\n"
344 "The \"append mode\" can be turned off while the port is in use\n"
345 "@pxref{Ports and File Descriptors, fcntl}\n"
347 "The following additional characters can be appended:\n"
350 "Open the underlying file in binary mode, if supported by the system.\n"
351 "Also, open the file using the binary-compatible character encoding\n"
352 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
353 "at the top of the input file, if any.\n"
355 "Open the port for both input and output. E.g., @code{r+}: open\n"
356 "an existing file for both input and output.\n"
358 "Create an \"unbuffered\" port. In this case input and output\n"
359 "operations are passed directly to the underlying port\n"
360 "implementation without additional buffering. This is likely to\n"
361 "slow down I/O operations. The buffering mode can be changed\n"
362 "while a port is in use @pxref{Ports and File Descriptors,\n"
365 "Add line-buffering to the port. The port output buffer will be\n"
366 "automatically flushed whenever a newline character is written.\n"
368 "When the file is opened, this procedure will scan for a coding\n"
369 "declaration@pxref{Character Encoding of Source Files}. If present\n"
370 "will use that encoding for interpreting the file. Otherwise, the\n"
371 "port's encoding will be used.\n"
373 "In theory we could create read/write ports which were buffered\n"
374 "in one direction only. However this isn't included in the\n"
375 "current interfaces. If a file cannot be opened with the access\n"
376 "requested, @code{open-file} throws an exception.")
377 #define FUNC_NAME s_scm_open_file
380 int fdes
, flags
= 0, use_encoding
= 1;
381 unsigned int retries
;
382 char *file
, *md
, *ptr
;
384 scm_dynwind_begin (0);
386 file
= scm_to_locale_string (filename
);
387 scm_dynwind_free (file
);
389 md
= scm_to_locale_string (mode
);
390 scm_dynwind_free (md
);
398 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
401 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
404 scm_out_of_range (FUNC_NAME
, mode
);
412 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
416 #if defined (O_BINARY)
420 case '0': /* unbuffered: handled later. */
421 case 'l': /* line buffered: handled during output. */
424 scm_out_of_range (FUNC_NAME
, mode
);
429 for (retries
= 0, fdes
= -1;
430 fdes
< 0 && retries
< 2;
433 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
438 if (en
== EMFILE
&& retries
== 0)
439 /* Run the GC in case it collects open file ports that are no
440 longer referenced. */
441 scm_i_gc (FUNC_NAME
);
443 SCM_SYSERROR_MSG ("~A: ~S",
444 scm_cons (scm_strerror (scm_from_int (en
)),
445 scm_cons (filename
, SCM_EOL
)), en
);
449 /* Create a port from this file descriptor. The port's encoding is initially
450 %default-port-encoding. */
451 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
452 fport_canonicalize_filename (filename
));
456 /* If this file has a coding declaration, use that as the port
458 if (SCM_INPUT_PORT_P (port
))
460 char *enc
= scm_i_scan_for_encoding (port
);
462 scm_i_set_port_encoding_x (port
, enc
);
466 /* If this is a binary file, use the binary-friendly ISO-8859-1
468 scm_i_set_port_encoding_x (port
, NULL
);
477 /* Building Guile ports from a file descriptor. */
479 /* Build a Scheme port from an open file descriptor `fdes'.
480 MODE indicates whether FILE is open for reading or writing; it uses
481 the same notation as open-file's second argument.
482 NAME is a string to be used as the port's filename.
485 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
486 #define FUNC_NAME "scm_fdes_to_port"
491 /* Test that fdes is valid. */
493 int flags
= fcntl (fdes
, F_GETFL
, 0);
498 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
499 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
501 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
504 /* If we don't have F_GETFL, as on mingw, at least we can test that
505 it is a valid file descriptor. */
507 if (fstat (fdes
, &st
) != 0)
511 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
513 port
= scm_new_port_table_entry (scm_tc16_fport
);
514 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
515 pt
= SCM_PTAB_ENTRY(port
);
518 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
522 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
523 SCM_SETSTREAM (port
, fp
);
524 if (mode_bits
& SCM_BUF0
)
525 scm_fport_buffer_add (port
, 0, 0);
527 scm_fport_buffer_add (port
, -1, -1);
529 SCM_SET_FILENAME (port
, name
);
530 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
536 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
538 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
541 /* Return a lower bound on the number of bytes available for input. */
543 fport_input_waiting (SCM port
)
545 int fdes
= SCM_FSTREAM (port
)->fdes
;
547 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
549 if (poll (&pollfd
, 1, 0) < 0)
550 scm_syserror ("fport_input_waiting");
552 return pollfd
.revents
& POLLIN
? 1 : 0;
557 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
559 scm_puts ("#<", port
);
560 scm_print_port_mode (exp
, port
);
561 if (SCM_OPFPORTP (exp
))
564 SCM name
= SCM_FILENAME (exp
);
565 if (scm_is_string (name
) || scm_is_symbol (name
))
566 scm_display (name
, port
);
568 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
569 scm_putc (' ', port
);
570 fdes
= (SCM_FSTREAM (exp
))->fdes
;
572 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
574 scm_display (scm_ttyname (exp
), port
);
576 #endif /* HAVE_TTYNAME */
577 scm_intprint (fdes
, 10, port
);
581 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
582 scm_putc (' ', port
);
583 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
585 scm_putc ('>', port
);
589 static void fport_flush (SCM port
);
591 /* fill a port's read-buffer with a single read. returns the first
592 char or EOF if end of file. */
594 fport_fill_input (SCM port
)
597 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
598 scm_t_fport
*fp
= SCM_FSTREAM (port
);
600 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
602 scm_syserror ("fport_fill_input");
604 return (scm_t_wchar
) EOF
;
607 pt
->read_pos
= pt
->read_buf
;
608 pt
->read_end
= pt
->read_buf
+ count
;
609 return *pt
->read_buf
;
614 fport_seek (SCM port
, scm_t_off 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");
666 fport_truncate (SCM port
, scm_t_off length
)
668 scm_t_fport
*fp
= SCM_FSTREAM (port
);
670 if (ftruncate (fp
->fdes
, length
) == -1)
671 scm_syserror ("ftruncate");
675 fport_write (SCM port
, const void *data
, size_t size
)
676 #define FUNC_NAME "fport_write"
678 /* this procedure tries to minimize the number of writes/flushes. */
679 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
681 if (pt
->write_buf
== &pt
->shortbuf
682 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
684 /* Unbuffered port, or port with empty buffer and data won't fit in
686 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
693 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
697 /* data fits in buffer. */
698 memcpy (pt
->write_pos
, data
, size
);
699 pt
->write_pos
+= size
;
700 if (pt
->write_pos
== pt
->write_end
)
703 /* we can skip the line-buffering check if nothing's buffered. */
709 memcpy (pt
->write_pos
, data
, space
);
710 pt
->write_pos
= pt
->write_end
;
713 const void *ptr
= ((const char *) data
) + space
;
714 size_t remaining
= size
- space
;
716 if (size
>= pt
->write_buf_size
)
718 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
725 memcpy (pt
->write_pos
, ptr
, remaining
);
726 pt
->write_pos
+= remaining
;
731 /* handle line buffering. */
732 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
739 fport_flush (SCM port
)
742 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
743 scm_t_fport
*fp
= SCM_FSTREAM (port
);
744 size_t count
= pt
->write_pos
- pt
->write_buf
;
746 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
748 scm_syserror ("scm_flush");
750 pt
->write_pos
= pt
->write_buf
;
751 pt
->rw_active
= SCM_PORT_NEITHER
;
754 /* clear the read buffer and adjust the file position for unread bytes. */
756 fport_end_input (SCM port
, int offset
)
758 scm_t_fport
*fp
= SCM_FSTREAM (port
);
759 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
761 offset
+= pt
->read_end
- pt
->read_pos
;
765 pt
->read_pos
= pt
->read_end
;
766 /* will throw error if unread-char used at beginning of file
767 then attempting to write. seems correct. */
768 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
769 scm_syserror ("fport_end_input");
771 pt
->rw_active
= SCM_PORT_NEITHER
;
775 fport_close (SCM port
)
777 scm_t_fport
*fp
= SCM_FSTREAM (port
);
778 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
782 SCM_SYSCALL (rv
= close (fp
->fdes
));
783 if (rv
== -1 && errno
!= EBADF
)
785 if (scm_gc_running_p
)
786 /* silently ignore the error. scm_error would abort if we
790 scm_syserror ("fport_close");
792 if (pt
->read_buf
== pt
->putback_buf
)
793 pt
->read_buf
= pt
->saved_read_buf
;
794 if (pt
->read_buf
!= &pt
->shortbuf
)
795 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
796 if (pt
->write_buf
!= &pt
->shortbuf
)
797 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
798 scm_gc_free (fp
, sizeof (*fp
), "file port");
803 fport_free (SCM port
)
812 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
814 scm_set_port_free (tc
, fport_free
);
815 scm_set_port_print (tc
, fport_print
);
816 scm_set_port_flush (tc
, fport_flush
);
817 scm_set_port_end_input (tc
, fport_end_input
);
818 scm_set_port_close (tc
, fport_close
);
819 scm_set_port_seek (tc
, fport_seek
);
820 scm_set_port_truncate (tc
, fport_truncate
);
821 scm_set_port_input_waiting (tc
, fport_input_waiting
);
829 scm_tc16_fport
= scm_make_fptob ();
831 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
832 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
833 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
835 sys_file_port_name_canonicalization
= scm_make_fluid ();
836 scm_c_define ("%file-port-name-canonicalization",
837 sys_file_port_name_canonicalization
);
839 #include "libguile/fports.x"