1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
3 * 2014, 2015 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
23 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
24 #define _GNU_SOURCE /* ask for LONG_LONG_MAX/LONG_LONG_MIN */
40 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
45 #include <sys/types.h>
47 #include <sys/select.h>
49 #include <full-write.h>
51 #include "libguile/_scm.h"
52 #include "libguile/strings.h"
53 #include "libguile/validate.h"
54 #include "libguile/gc.h"
55 #include "libguile/posix.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/hashtab.h"
59 #include "libguile/fports.h"
60 #include "libguile/ports-internal.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 buffers with specified sizes (or -1 to use default size
82 or 0 for no buffer.) */
84 scm_fport_buffer_add (SCM port
, long read_size
, long 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 "Only certain types of ports are supported, most importantly\n"
153 #define FUNC_NAME s_scm_setvbuf
158 char *drained
= NULL
;
160 scm_t_ptob_descriptor
*ptob
;
162 port
= SCM_COERCE_OUTPORT (port
);
164 SCM_VALIDATE_OPENPORT (1, port
);
165 ptob
= SCM_PORT_DESCRIPTOR (port
);
167 if (ptob
->setvbuf
== NULL
)
168 scm_wrong_type_arg_msg (FUNC_NAME
, 1, port
,
169 "port that supports 'setvbuf'");
171 cmode
= scm_to_int (mode
);
172 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
173 scm_out_of_range (FUNC_NAME
, mode
);
177 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
181 SCM_SET_CELL_WORD_0 (port
,
182 SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
) SCM_BUFLINE
);
184 if (SCM_UNBNDP (size
))
193 csize
= scm_to_int (size
);
194 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
195 scm_out_of_range (FUNC_NAME
, size
);
198 pt
= SCM_PTAB_ENTRY (port
);
200 if (SCM_INPUT_PORT_P (port
))
202 /* Drain pending input from PORT. Don't use `scm_drain_input' since
203 it returns a string, whereas we want binary input here. */
204 ndrained
= pt
->read_end
- pt
->read_pos
;
205 if (pt
->read_buf
== pt
->putback_buf
)
206 ndrained
+= pt
->saved_read_end
- pt
->saved_read_pos
;
210 drained
= scm_gc_malloc_pointerless (ndrained
, "file port");
211 scm_take_from_input_buffers (port
, drained
, ndrained
);
217 if (SCM_OUTPUT_PORT_P (port
))
218 scm_flush_unlocked (port
);
220 if (pt
->read_buf
== pt
->putback_buf
)
222 pt
->read_buf
= pt
->saved_read_buf
;
223 pt
->read_pos
= pt
->saved_read_pos
;
224 pt
->read_end
= pt
->saved_read_end
;
225 pt
->read_buf_size
= pt
->saved_read_buf_size
;
228 ptob
->setvbuf (port
, csize
, csize
);
231 /* Put DRAINED back to PORT. */
232 scm_unget_bytes ((unsigned char *) drained
, ndrained
, port
);
234 return SCM_UNSPECIFIED
;
238 /* Move ports with the specified file descriptor to new descriptors,
239 * resetting the revealed count to 0.
242 scm_i_evict_port (void *closure
, SCM port
)
244 int fd
= * (int*) closure
;
246 if (SCM_FPORTP (port
))
251 /* XXX: In some cases, we can encounter a port with no associated ptab
253 p
= SCM_PTAB_ENTRY (port
);
254 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
256 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
260 scm_syserror ("scm_evict_ports");
261 scm_set_port_revealed_x (port
, scm_from_int (0));
267 scm_evict_ports (int fd
)
269 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
273 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
275 "Determine whether @var{obj} is a port that is related to a file.")
276 #define FUNC_NAME s_scm_file_port_p
278 return scm_from_bool (SCM_FPORTP (obj
));
283 static SCM sys_file_port_name_canonicalization
;
284 SCM_SYMBOL (sym_relative
, "relative");
285 SCM_SYMBOL (sym_absolute
, "absolute");
288 fport_canonicalize_filename (SCM filename
)
290 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
292 if (!scm_is_string (filename
))
296 else if (scm_is_eq (mode
, sym_relative
))
300 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
302 rel
= scm_i_relativize_path (filename
, path
);
304 return scm_is_true (rel
) ? rel
: filename
;
306 else if (scm_is_eq (mode
, sym_absolute
))
310 str
= scm_to_locale_string (filename
);
311 canon
= canonicalize_file_name (str
);
314 return canon
? scm_take_locale_string (canon
) : filename
;
322 /* scm_open_file_with_encoding
323 Return a new port open on a given file.
325 The mode string must match the pattern: [rwa+]** which
326 is interpreted in the usual unix way.
328 Unless binary mode is requested, the character encoding of the new
329 port is determined as follows: First, if GUESS_ENCODING is true,
330 'file-encoding' is used to guess the encoding of the file. If
331 GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used
332 unless it is also false. As a last resort, the default port encoding
333 is used. It is an error to pass a non-false GUESS_ENCODING or
334 ENCODING if binary mode is requested.
336 Return the new port. */
338 scm_open_file_with_encoding (SCM filename
, SCM mode
,
339 SCM guess_encoding
, SCM encoding
)
340 #define FUNC_NAME "open-file"
343 int fdes
, flags
= 0, binary
= 0;
344 unsigned int retries
;
346 const char *md
, *ptr
;
348 if (SCM_UNLIKELY (!(scm_is_false (encoding
) || scm_is_string (encoding
))))
349 scm_wrong_type_arg_msg (FUNC_NAME
, 0, encoding
,
350 "encoding to be string or false");
352 scm_dynwind_begin (0);
354 file
= scm_to_locale_string (filename
);
355 scm_dynwind_free (file
);
357 if (SCM_UNLIKELY (!scm_i_try_narrow_string (mode
)))
358 scm_out_of_range (FUNC_NAME
, mode
);
360 md
= scm_i_string_chars (mode
);
368 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
371 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
374 scm_out_of_range (FUNC_NAME
, mode
);
382 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
386 #if defined (O_BINARY)
390 case '0': /* unbuffered: handled later. */
391 case 'l': /* line buffered: handled during output. */
394 scm_out_of_range (FUNC_NAME
, mode
);
399 for (retries
= 0, fdes
= -1;
400 fdes
< 0 && retries
< 2;
403 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
408 if (en
== EMFILE
&& retries
== 0)
409 /* Run the GC in case it collects open file ports that are no
410 longer referenced. */
411 scm_i_gc (FUNC_NAME
);
413 SCM_SYSERROR_MSG ("~A: ~S",
414 scm_cons (scm_strerror (scm_from_int (en
)),
415 scm_cons (filename
, SCM_EOL
)), en
);
419 /* Create a port from this file descriptor. The port's encoding is initially
420 %default-port-encoding. */
421 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
422 fport_canonicalize_filename (filename
));
426 if (scm_is_true (encoding
))
427 scm_misc_error (FUNC_NAME
,
428 "Encoding specified on a binary port",
429 scm_list_1 (encoding
));
430 if (scm_is_true (guess_encoding
))
431 scm_misc_error (FUNC_NAME
,
432 "Request to guess encoding on a binary port",
435 /* Use the binary-friendly ISO-8859-1 encoding. */
436 scm_i_set_port_encoding_x (port
, NULL
);
442 if (scm_is_true (guess_encoding
))
444 if (SCM_INPUT_PORT_P (port
))
445 enc
= scm_i_scan_for_encoding (port
);
447 scm_misc_error (FUNC_NAME
,
448 "Request to guess encoding on an output-only port",
452 if (!enc
&& scm_is_true (encoding
))
454 char *buf
= scm_to_latin1_string (encoding
);
455 enc
= scm_gc_strdup (buf
, "encoding");
460 scm_i_set_port_encoding_x (port
, enc
);
470 scm_open_file (SCM filename
, SCM mode
)
472 return scm_open_file_with_encoding (filename
, mode
, SCM_BOOL_F
, SCM_BOOL_F
);
475 /* We can't define these using SCM_KEYWORD, because keywords have not
476 yet been initialized when scm_init_fports is called. */
477 static SCM k_guess_encoding
= SCM_UNDEFINED
;
478 static SCM k_encoding
= SCM_UNDEFINED
;
480 SCM_INTERNAL SCM
scm_i_open_file (SCM
, SCM
, SCM
);
482 SCM_DEFINE (scm_i_open_file
, "open-file", 2, 0, 1,
483 (SCM filename
, SCM mode
, SCM keyword_args
),
484 "Open the file whose name is @var{filename}, and return a port\n"
485 "representing that file. The attributes of the port are\n"
486 "determined by the @var{mode} string. The way in which this is\n"
487 "interpreted is similar to C stdio. The first character must be\n"
488 "one of the following:\n"
491 "Open an existing file for input.\n"
493 "Open a file for output, creating it if it doesn't already exist\n"
494 "or removing its contents if it does.\n"
496 "Open a file for output, creating it if it doesn't already\n"
497 "exist. All writes to the port will go to the end of the file.\n"
498 "The \"append mode\" can be turned off while the port is in use\n"
499 "@pxref{Ports and File Descriptors, fcntl}\n"
501 "The following additional characters can be appended:\n"
504 "Open the underlying file in binary mode, if supported by the system.\n"
505 "Also, open the file using the binary-compatible character encoding\n"
506 "\"ISO-8859-1\", ignoring the default port encoding.\n"
508 "Open the port for both input and output. E.g., @code{r+}: open\n"
509 "an existing file for both input and output.\n"
511 "Create an \"unbuffered\" port. In this case input and output\n"
512 "operations are passed directly to the underlying port\n"
513 "implementation without additional buffering. This is likely to\n"
514 "slow down I/O operations. The buffering mode can be changed\n"
515 "while a port is in use @pxref{Ports and File Descriptors,\n"
518 "Add line-buffering to the port. The port output buffer will be\n"
519 "automatically flushed whenever a newline character is written.\n"
521 "In theory we could create read/write ports which were buffered\n"
522 "in one direction only. However this isn't included in the\n"
523 "current interfaces. If a file cannot be opened with the access\n"
524 "requested, @code{open-file} throws an exception.")
525 #define FUNC_NAME s_scm_i_open_file
527 SCM encoding
= SCM_BOOL_F
;
528 SCM guess_encoding
= SCM_BOOL_F
;
530 scm_c_bind_keyword_arguments (FUNC_NAME
, keyword_args
, 0,
531 k_guess_encoding
, &guess_encoding
,
532 k_encoding
, &encoding
,
535 return scm_open_file_with_encoding (filename
, mode
,
536 guess_encoding
, encoding
);
541 /* Building Guile ports from a file descriptor. */
543 /* Build a Scheme port from an open file descriptor `fdes'.
544 MODE indicates whether FILE is open for reading or writing; it uses
545 the same notation as open-file's second argument.
546 NAME is a string to be used as the port's filename.
549 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
550 #define FUNC_NAME "scm_fdes_to_port"
555 /* Test that fdes is valid. */
557 int flags
= fcntl (fdes
, F_GETFL
, 0);
562 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
563 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
565 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
568 /* If we don't have F_GETFL, as on mingw, at least we can test that
569 it is a valid file descriptor. */
571 if (fstat (fdes
, &st
) != 0)
575 fp
= (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
579 port
= scm_c_make_port (scm_tc16_fport
, mode_bits
, (scm_t_bits
)fp
);
581 SCM_PTAB_ENTRY (port
)->rw_random
= SCM_FDES_RANDOM_P (fdes
);
583 if (mode_bits
& SCM_BUF0
)
584 scm_fport_buffer_add (port
, 0, 0);
586 scm_fport_buffer_add (port
, -1, -1);
588 SCM_SET_FILENAME (port
, name
);
595 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
597 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
600 /* Return a lower bound on the number of bytes available for input. */
602 fport_input_waiting (SCM port
)
604 int fdes
= SCM_FSTREAM (port
)->fdes
;
606 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
608 if (poll (&pollfd
, 1, 0) < 0)
609 scm_syserror ("fport_input_waiting");
611 return pollfd
.revents
& POLLIN
? 1 : 0;
617 /* Revealed counts --- an oddity inherited from SCSH. */
619 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
621 static SCM revealed_ports
= SCM_EOL
;
622 static scm_i_pthread_mutex_t revealed_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
624 /* Find a port in the table and return its revealed count.
625 Also used by the garbage collector.
628 scm_revealed_count (SCM port
)
632 scm_i_pthread_mutex_lock (&revealed_lock
);
633 ret
= SCM_REVEALED (port
);
634 scm_i_pthread_mutex_unlock (&revealed_lock
);
639 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
641 "Return the revealed count for @var{port}.")
642 #define FUNC_NAME s_scm_port_revealed
644 port
= SCM_COERCE_OUTPORT (port
);
645 SCM_VALIDATE_OPFPORT (1, port
);
646 return scm_from_int (scm_revealed_count (port
));
650 /* Set the revealed count for a port. */
651 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
652 (SCM port
, SCM rcount
),
653 "Sets the revealed count for a port to a given value.\n"
654 "The return value is unspecified.")
655 #define FUNC_NAME s_scm_set_port_revealed_x
659 port
= SCM_COERCE_OUTPORT (port
);
660 SCM_VALIDATE_OPFPORT (1, port
);
662 r
= scm_to_int (rcount
);
664 scm_i_pthread_mutex_lock (&revealed_lock
);
666 prev
= SCM_REVEALED (port
);
667 SCM_REVEALED (port
) = r
;
670 revealed_ports
= scm_cons (port
, revealed_ports
);
672 revealed_ports
= scm_delq_x (port
, revealed_ports
);
674 scm_i_pthread_mutex_unlock (&revealed_lock
);
676 return SCM_UNSPECIFIED
;
680 /* Set the revealed count for a port. */
681 SCM_DEFINE (scm_adjust_port_revealed_x
, "adjust-port-revealed!", 2, 0, 0,
682 (SCM port
, SCM addend
),
683 "Add @var{addend} to the revealed count of @var{port}.\n"
684 "The return value is unspecified.")
685 #define FUNC_NAME s_scm_adjust_port_revealed_x
689 port
= SCM_COERCE_OUTPORT (port
);
690 SCM_VALIDATE_OPFPORT (1, port
);
692 a
= scm_to_int (addend
);
694 return SCM_UNSPECIFIED
;
696 scm_i_pthread_mutex_lock (&revealed_lock
);
698 SCM_REVEALED (port
) += a
;
699 if (SCM_REVEALED (port
) == a
)
700 revealed_ports
= scm_cons (port
, revealed_ports
);
701 else if (!SCM_REVEALED (port
))
702 revealed_ports
= scm_delq_x (port
, revealed_ports
);
704 scm_i_pthread_mutex_unlock (&revealed_lock
);
706 return SCM_UNSPECIFIED
;
713 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
715 scm_puts_unlocked ("#<", port
);
716 scm_print_port_mode (exp
, port
);
717 if (SCM_OPFPORTP (exp
))
720 SCM name
= SCM_FILENAME (exp
);
721 if (scm_is_string (name
) || scm_is_symbol (name
))
722 scm_display (name
, port
);
724 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
725 scm_putc_unlocked (' ', port
);
726 fdes
= (SCM_FSTREAM (exp
))->fdes
;
728 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
730 scm_display (scm_ttyname (exp
), port
);
732 #endif /* HAVE_TTYNAME */
733 scm_intprint (fdes
, 10, port
);
737 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
738 scm_putc_unlocked (' ', port
);
739 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
741 scm_putc_unlocked ('>', port
);
745 static void fport_flush (SCM port
);
747 /* fill a port's read-buffer with a single read. returns the first
748 char or EOF if end of file. */
750 fport_fill_input (SCM port
)
753 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
754 scm_t_fport
*fp
= SCM_FSTREAM (port
);
756 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
758 scm_syserror ("fport_fill_input");
760 return (scm_t_wchar
) EOF
;
763 pt
->read_pos
= pt
->read_buf
;
764 pt
->read_end
= pt
->read_buf
+ count
;
765 return *pt
->read_buf
;
770 fport_seek (SCM port
, scm_t_off offset
, int whence
)
772 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
773 scm_t_fport
*fp
= SCM_FSTREAM (port
);
775 off_t_or_off64_t result
;
777 if (pt
->rw_active
== SCM_PORT_WRITE
)
779 if (offset
!= 0 || whence
!= SEEK_CUR
)
782 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
786 /* read current position without disturbing the buffer. */
787 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
788 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
791 else if (pt
->rw_active
== SCM_PORT_READ
)
793 if (offset
!= 0 || whence
!= SEEK_CUR
)
795 /* could expand to avoid a second seek. */
796 scm_end_input_unlocked (port
);
797 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
801 /* read current position without disturbing the buffer
802 (particularly the unread-char buffer). */
803 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
804 result
= rv
- (pt
->read_end
- pt
->read_pos
);
806 if (pt
->read_buf
== pt
->putback_buf
)
807 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
810 else /* SCM_PORT_NEITHER */
812 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
816 scm_syserror ("fport_seek");
822 fport_truncate (SCM port
, scm_t_off length
)
824 scm_t_fport
*fp
= SCM_FSTREAM (port
);
826 if (ftruncate (fp
->fdes
, length
) == -1)
827 scm_syserror ("ftruncate");
831 fport_write (SCM port
, const void *data
, size_t size
)
832 #define FUNC_NAME "fport_write"
834 /* this procedure tries to minimize the number of writes/flushes. */
835 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
837 if (pt
->write_buf
== &pt
->shortbuf
838 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
840 /* Unbuffered port, or port with empty buffer and data won't fit in
842 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
849 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
853 /* data fits in buffer. */
854 memcpy (pt
->write_pos
, data
, size
);
855 pt
->write_pos
+= size
;
856 if (pt
->write_pos
== pt
->write_end
)
859 /* we can skip the line-buffering check if nothing's buffered. */
865 memcpy (pt
->write_pos
, data
, space
);
866 pt
->write_pos
= pt
->write_end
;
869 const void *ptr
= ((const char *) data
) + space
;
870 size_t remaining
= size
- space
;
872 if (size
>= pt
->write_buf_size
)
874 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
881 memcpy (pt
->write_pos
, ptr
, remaining
);
882 pt
->write_pos
+= remaining
;
887 /* handle line buffering. */
888 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
895 fport_flush (SCM port
)
898 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
899 scm_t_fport
*fp
= SCM_FSTREAM (port
);
900 size_t count
= pt
->write_pos
- pt
->write_buf
;
902 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
904 scm_syserror ("scm_flush");
906 pt
->write_pos
= pt
->write_buf
;
907 pt
->rw_active
= SCM_PORT_NEITHER
;
910 /* clear the read buffer and adjust the file position for unread bytes. */
912 fport_end_input (SCM port
, int offset
)
914 scm_t_fport
*fp
= SCM_FSTREAM (port
);
915 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
917 offset
+= pt
->read_end
- pt
->read_pos
;
921 pt
->read_pos
= pt
->read_end
;
922 /* will throw error if unread-char used at beginning of file
923 then attempting to write. seems correct. */
924 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
925 scm_syserror ("fport_end_input");
927 pt
->rw_active
= SCM_PORT_NEITHER
;
931 close_the_fd (void *data
)
933 scm_t_fport
*fp
= data
;
936 /* There's already one exception. That's probably enough! */
941 fport_close (SCM port
)
943 scm_t_fport
*fp
= SCM_FSTREAM (port
);
946 scm_dynwind_begin (0);
947 scm_dynwind_unwind_handler (close_the_fd
, fp
, 0);
951 scm_port_non_buffer (SCM_PTAB_ENTRY (port
));
953 rv
= close (fp
->fdes
);
955 /* It's not useful to retry after EINTR, as the file descriptor is
956 in an undefined state. See http://lwn.net/Articles/365294/.
957 Instead just throw an error if close fails, trusting that the fd
959 scm_syserror ("fport_close");
965 fport_free (SCM port
)
974 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
976 scm_set_port_free (tc
, fport_free
);
977 scm_set_port_print (tc
, fport_print
);
978 scm_set_port_flush (tc
, fport_flush
);
979 scm_set_port_end_input (tc
, fport_end_input
);
980 scm_set_port_close (tc
, fport_close
);
981 scm_set_port_seek (tc
, fport_seek
);
982 scm_set_port_truncate (tc
, fport_truncate
);
983 scm_set_port_input_waiting (tc
, fport_input_waiting
);
984 scm_set_port_setvbuf (tc
, scm_fport_buffer_add
);
989 /* We can't initialize the keywords from 'scm_init_fports', because
990 keywords haven't yet been initialized at that point. */
992 scm_init_fports_keywords ()
994 k_guess_encoding
= scm_from_latin1_keyword ("guess-encoding");
995 k_encoding
= scm_from_latin1_keyword ("encoding");
1001 scm_tc16_fport
= scm_make_fptob ();
1003 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
1004 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
1005 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
1007 sys_file_port_name_canonicalization
= scm_make_fluid ();
1008 scm_c_define ("%file-port-name-canonicalization",
1009 sys_file_port_name_canonicalization
);
1011 #include "libguile/fports.x"