1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
3 * 2014 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 */
42 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
47 #include <sys/types.h>
49 #include <sys/select.h>
51 #include <full-write.h>
53 #include "libguile/_scm.h"
54 #include "libguile/strings.h"
55 #include "libguile/validate.h"
56 #include "libguile/gc.h"
57 #include "libguile/posix.h"
58 #include "libguile/dynwind.h"
59 #include "libguile/hashtab.h"
61 #include "libguile/fports.h"
62 #include "libguile/ports-internal.h"
64 #if SIZEOF_OFF_T == SIZEOF_INT
65 #define OFF_T_MAX INT_MAX
66 #define OFF_T_MIN INT_MIN
67 #elif SIZEOF_OFF_T == SIZEOF_LONG
68 #define OFF_T_MAX LONG_MAX
69 #define OFF_T_MIN LONG_MIN
70 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
71 #define OFF_T_MAX LONG_LONG_MAX
72 #define OFF_T_MIN LONG_LONG_MIN
74 #error Oops, unknown OFF_T size
77 scm_t_bits scm_tc16_fport
;
80 /* default buffer size, used if the O/S won't supply a value. */
81 static const size_t default_buffer_size
= 1024;
83 /* Create FPORT buffers with specified sizes (or -1 to use default size
84 or 0 for no buffer.) */
86 scm_fport_buffer_add (SCM port
, long read_size
, long write_size
)
87 #define FUNC_NAME "scm_fport_buffer_add"
89 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
91 if (read_size
== -1 || write_size
== -1)
94 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
96 scm_t_fport
*fp
= SCM_FSTREAM (port
);
98 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
101 default_size
= default_buffer_size
;
104 read_size
= default_size
;
105 if (write_size
== -1)
106 write_size
= default_size
;
109 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
111 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
112 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
113 pt
->read_buf_size
= read_size
;
117 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
118 pt
->read_buf_size
= 1;
121 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
123 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
124 pt
->write_pos
= pt
->write_buf
;
125 pt
->write_buf_size
= write_size
;
129 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
130 pt
->write_buf_size
= 1;
133 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
134 if (read_size
> 0 || write_size
> 0)
135 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
137 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
141 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
142 (SCM port
, SCM mode
, SCM size
),
143 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
150 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
151 "If @var{size} is omitted, a default size will be used.\n"
153 "Only certain types of ports are supported, most importantly\n"
155 #define FUNC_NAME s_scm_setvbuf
162 scm_t_ptob_descriptor
*ptob
;
164 port
= SCM_COERCE_OUTPORT (port
);
166 SCM_VALIDATE_OPENPORT (1, port
);
167 ptob
= SCM_PORT_DESCRIPTOR (port
);
169 if (ptob
->setvbuf
== NULL
)
170 scm_wrong_type_arg_msg (FUNC_NAME
, 1, port
,
171 "port that supports 'setvbuf'");
173 cmode
= scm_to_int (mode
);
174 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
175 scm_out_of_range (FUNC_NAME
, mode
);
179 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
183 SCM_SET_CELL_WORD_0 (port
,
184 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 if (SCM_INPUT_PORT_P (port
))
204 /* Drain pending input from PORT. Don't use `scm_drain_input' since
205 it returns a string, whereas we want binary input here. */
206 ndrained
= pt
->read_end
- pt
->read_pos
;
207 if (pt
->read_buf
== pt
->putback_buf
)
208 ndrained
+= pt
->saved_read_end
- pt
->saved_read_pos
;
212 drained
= scm_gc_malloc_pointerless (ndrained
, "file port");
213 scm_take_from_input_buffers (port
, drained
, ndrained
);
219 if (SCM_OUTPUT_PORT_P (port
))
220 scm_flush_unlocked (port
);
222 if (pt
->read_buf
== pt
->putback_buf
)
224 pt
->read_buf
= pt
->saved_read_buf
;
225 pt
->read_pos
= pt
->saved_read_pos
;
226 pt
->read_end
= pt
->saved_read_end
;
227 pt
->read_buf_size
= pt
->saved_read_buf_size
;
230 ptob
->setvbuf (port
, csize
, csize
);
233 /* Put DRAINED back to PORT. */
234 scm_unget_bytes ((unsigned char *) drained
, ndrained
, port
);
236 return SCM_UNSPECIFIED
;
240 /* Move ports with the specified file descriptor to new descriptors,
241 * resetting the revealed count to 0.
244 scm_i_evict_port (void *closure
, SCM port
)
246 int fd
= * (int*) closure
;
248 if (SCM_FPORTP (port
))
253 /* XXX: In some cases, we can encounter a port with no associated ptab
255 p
= SCM_PTAB_ENTRY (port
);
256 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
258 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
262 scm_syserror ("scm_evict_ports");
263 scm_set_port_revealed_x (port
, scm_from_int (0));
269 scm_evict_ports (int fd
)
271 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
275 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
277 "Determine whether @var{obj} is a port that is related to a file.")
278 #define FUNC_NAME s_scm_file_port_p
280 return scm_from_bool (SCM_FPORTP (obj
));
285 static SCM sys_file_port_name_canonicalization
;
286 SCM_SYMBOL (sym_relative
, "relative");
287 SCM_SYMBOL (sym_absolute
, "absolute");
290 fport_canonicalize_filename (SCM filename
)
292 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
294 if (!scm_is_string (filename
))
298 else if (scm_is_eq (mode
, sym_relative
))
302 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
304 rel
= scm_i_relativize_path (filename
, path
);
306 return scm_is_true (rel
) ? rel
: filename
;
308 else if (scm_is_eq (mode
, sym_absolute
))
312 str
= scm_to_locale_string (filename
);
313 canon
= canonicalize_file_name (str
);
316 return canon
? scm_take_locale_string (canon
) : filename
;
324 /* scm_open_file_with_encoding
325 Return a new port open on a given file.
327 The mode string must match the pattern: [rwa+]** which
328 is interpreted in the usual unix way.
330 Unless binary mode is requested, the character encoding of the new
331 port is determined as follows: First, if GUESS_ENCODING is true,
332 'file-encoding' is used to guess the encoding of the file. If
333 GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used
334 unless it is also false. As a last resort, the default port encoding
335 is used. It is an error to pass a non-false GUESS_ENCODING or
336 ENCODING if binary mode is requested.
338 Return the new port. */
340 scm_open_file_with_encoding (SCM filename
, SCM mode
,
341 SCM guess_encoding
, SCM encoding
)
342 #define FUNC_NAME "open-file"
345 int fdes
, flags
= 0, binary
= 0;
346 unsigned int retries
;
347 char *file
, *md
, *ptr
;
349 if (SCM_UNLIKELY (!(scm_is_false (encoding
) || scm_is_string (encoding
))))
350 scm_wrong_type_arg_msg (FUNC_NAME
, 0, encoding
,
351 "encoding to be string or false");
353 scm_dynwind_begin (0);
355 file
= scm_to_locale_string (filename
);
356 scm_dynwind_free (file
);
358 md
= scm_to_locale_string (mode
);
359 scm_dynwind_free (md
);
367 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
370 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
373 scm_out_of_range (FUNC_NAME
, mode
);
381 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
385 #if defined (O_BINARY)
389 case '0': /* unbuffered: handled later. */
390 case 'l': /* line buffered: handled during output. */
393 scm_out_of_range (FUNC_NAME
, mode
);
398 for (retries
= 0, fdes
= -1;
399 fdes
< 0 && retries
< 2;
402 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
407 if (en
== EMFILE
&& retries
== 0)
408 /* Run the GC in case it collects open file ports that are no
409 longer referenced. */
410 scm_i_gc (FUNC_NAME
);
412 SCM_SYSERROR_MSG ("~A: ~S",
413 scm_cons (scm_strerror (scm_from_int (en
)),
414 scm_cons (filename
, SCM_EOL
)), en
);
418 /* Create a port from this file descriptor. The port's encoding is initially
419 %default-port-encoding. */
420 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
421 fport_canonicalize_filename (filename
));
425 if (scm_is_true (encoding
))
426 scm_misc_error (FUNC_NAME
,
427 "Encoding specified on a binary port",
428 scm_list_1 (encoding
));
429 if (scm_is_true (guess_encoding
))
430 scm_misc_error (FUNC_NAME
,
431 "Request to guess encoding on a binary port",
434 /* Use the binary-friendly ISO-8859-1 encoding. */
435 scm_i_set_port_encoding_x (port
, NULL
);
441 if (scm_is_true (guess_encoding
))
443 if (SCM_INPUT_PORT_P (port
))
444 enc
= scm_i_scan_for_encoding (port
);
446 scm_misc_error (FUNC_NAME
,
447 "Request to guess encoding on an output-only port",
451 if (!enc
&& scm_is_true (encoding
))
453 char *buf
= scm_to_latin1_string (encoding
);
454 enc
= scm_gc_strdup (buf
, "encoding");
459 scm_i_set_port_encoding_x (port
, enc
);
469 scm_open_file (SCM filename
, SCM mode
)
471 return scm_open_file_with_encoding (filename
, mode
, SCM_BOOL_F
, SCM_BOOL_F
);
474 /* We can't define these using SCM_KEYWORD, because keywords have not
475 yet been initialized when scm_init_fports is called. */
476 static SCM k_guess_encoding
= SCM_UNDEFINED
;
477 static SCM k_encoding
= SCM_UNDEFINED
;
479 SCM_INTERNAL SCM
scm_i_open_file (SCM
, SCM
, SCM
);
481 SCM_DEFINE (scm_i_open_file
, "open-file", 2, 0, 1,
482 (SCM filename
, SCM mode
, SCM keyword_args
),
483 "Open the file whose name is @var{filename}, and return a port\n"
484 "representing that file. The attributes of the port are\n"
485 "determined by the @var{mode} string. The way in which this is\n"
486 "interpreted is similar to C stdio. The first character must be\n"
487 "one of the following:\n"
490 "Open an existing file for input.\n"
492 "Open a file for output, creating it if it doesn't already exist\n"
493 "or removing its contents if it does.\n"
495 "Open a file for output, creating it if it doesn't already\n"
496 "exist. All writes to the port will go to the end of the file.\n"
497 "The \"append mode\" can be turned off while the port is in use\n"
498 "@pxref{Ports and File Descriptors, fcntl}\n"
500 "The following additional characters can be appended:\n"
503 "Open the underlying file in binary mode, if supported by the system.\n"
504 "Also, open the file using the binary-compatible character encoding\n"
505 "\"ISO-8859-1\", ignoring the default port encoding.\n"
507 "Open the port for both input and output. E.g., @code{r+}: open\n"
508 "an existing file for both input and output.\n"
510 "Create an \"unbuffered\" port. In this case input and output\n"
511 "operations are passed directly to the underlying port\n"
512 "implementation without additional buffering. This is likely to\n"
513 "slow down I/O operations. The buffering mode can be changed\n"
514 "while a port is in use @pxref{Ports and File Descriptors,\n"
517 "Add line-buffering to the port. The port output buffer will be\n"
518 "automatically flushed whenever a newline character is written.\n"
520 "In theory we could create read/write ports which were buffered\n"
521 "in one direction only. However this isn't included in the\n"
522 "current interfaces. If a file cannot be opened with the access\n"
523 "requested, @code{open-file} throws an exception.")
524 #define FUNC_NAME s_scm_i_open_file
526 SCM encoding
= SCM_BOOL_F
;
527 SCM guess_encoding
= SCM_BOOL_F
;
529 scm_c_bind_keyword_arguments (FUNC_NAME
, keyword_args
, 0,
530 k_guess_encoding
, &guess_encoding
,
531 k_encoding
, &encoding
,
534 return scm_open_file_with_encoding (filename
, mode
,
535 guess_encoding
, encoding
);
540 /* Building Guile ports from a file descriptor. */
542 /* Build a Scheme port from an open file descriptor `fdes'.
543 MODE indicates whether FILE is open for reading or writing; it uses
544 the same notation as open-file's second argument.
545 NAME is a string to be used as the port's filename.
548 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
549 #define FUNC_NAME "scm_fdes_to_port"
554 /* Test that fdes is valid. */
556 int flags
= fcntl (fdes
, F_GETFL
, 0);
561 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
562 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
564 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
567 /* If we don't have F_GETFL, as on mingw, at least we can test that
568 it is a valid file descriptor. */
570 if (fstat (fdes
, &st
) != 0)
574 fp
= (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
578 port
= scm_c_make_port (scm_tc16_fport
, mode_bits
, (scm_t_bits
)fp
);
580 SCM_PTAB_ENTRY (port
)->rw_random
= SCM_FDES_RANDOM_P (fdes
);
582 if (mode_bits
& SCM_BUF0
)
583 scm_fport_buffer_add (port
, 0, 0);
585 scm_fport_buffer_add (port
, -1, -1);
587 SCM_SET_FILENAME (port
, name
);
594 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
596 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
599 /* Return a lower bound on the number of bytes available for input. */
601 fport_input_waiting (SCM port
)
603 int fdes
= SCM_FSTREAM (port
)->fdes
;
605 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
607 if (poll (&pollfd
, 1, 0) < 0)
608 scm_syserror ("fport_input_waiting");
610 return pollfd
.revents
& POLLIN
? 1 : 0;
616 /* Revealed counts --- an oddity inherited from SCSH. */
618 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
620 static SCM revealed_ports
= SCM_EOL
;
621 static scm_i_pthread_mutex_t revealed_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
623 /* Find a port in the table and return its revealed count.
624 Also used by the garbage collector.
627 scm_revealed_count (SCM port
)
631 scm_i_pthread_mutex_lock (&revealed_lock
);
632 ret
= SCM_REVEALED (port
);
633 scm_i_pthread_mutex_unlock (&revealed_lock
);
638 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
640 "Return the revealed count for @var{port}.")
641 #define FUNC_NAME s_scm_port_revealed
643 port
= SCM_COERCE_OUTPORT (port
);
644 SCM_VALIDATE_OPFPORT (1, port
);
645 return scm_from_int (scm_revealed_count (port
));
649 /* Set the revealed count for a port. */
650 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
651 (SCM port
, SCM rcount
),
652 "Sets the revealed count for a port to a given value.\n"
653 "The return value is unspecified.")
654 #define FUNC_NAME s_scm_set_port_revealed_x
658 port
= SCM_COERCE_OUTPORT (port
);
659 SCM_VALIDATE_OPFPORT (1, port
);
661 r
= scm_to_int (rcount
);
663 scm_i_pthread_mutex_lock (&revealed_lock
);
665 prev
= SCM_REVEALED (port
);
666 SCM_REVEALED (port
) = r
;
669 revealed_ports
= scm_cons (port
, revealed_ports
);
671 revealed_ports
= scm_delq_x (port
, revealed_ports
);
673 scm_i_pthread_mutex_unlock (&revealed_lock
);
675 return SCM_UNSPECIFIED
;
679 /* Set the revealed count for a port. */
680 SCM_DEFINE (scm_adjust_port_revealed_x
, "adjust-port-revealed!", 2, 0, 0,
681 (SCM port
, SCM addend
),
682 "Add @var{addend} to the revealed count of @var{port}.\n"
683 "The return value is unspecified.")
684 #define FUNC_NAME s_scm_adjust_port_revealed_x
688 port
= SCM_COERCE_OUTPORT (port
);
689 SCM_VALIDATE_OPFPORT (1, port
);
691 a
= scm_to_int (addend
);
693 return SCM_UNSPECIFIED
;
695 scm_i_pthread_mutex_lock (&revealed_lock
);
697 SCM_REVEALED (port
) += a
;
698 if (SCM_REVEALED (port
) == a
)
699 revealed_ports
= scm_cons (port
, revealed_ports
);
700 else if (!SCM_REVEALED (port
))
701 revealed_ports
= scm_delq_x (port
, revealed_ports
);
703 scm_i_pthread_mutex_unlock (&revealed_lock
);
705 return SCM_UNSPECIFIED
;
712 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
714 scm_puts_unlocked ("#<", port
);
715 scm_print_port_mode (exp
, port
);
716 if (SCM_OPFPORTP (exp
))
719 SCM name
= SCM_FILENAME (exp
);
720 if (scm_is_string (name
) || scm_is_symbol (name
))
721 scm_display (name
, port
);
723 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
724 scm_putc_unlocked (' ', port
);
725 fdes
= (SCM_FSTREAM (exp
))->fdes
;
727 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
729 scm_display (scm_ttyname (exp
), port
);
731 #endif /* HAVE_TTYNAME */
732 scm_intprint (fdes
, 10, port
);
736 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
737 scm_putc_unlocked (' ', port
);
738 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
740 scm_putc_unlocked ('>', port
);
744 static void fport_flush (SCM port
);
746 /* fill a port's read-buffer with a single read. returns the first
747 char or EOF if end of file. */
749 fport_fill_input (SCM port
)
752 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
753 scm_t_fport
*fp
= SCM_FSTREAM (port
);
755 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
757 scm_syserror ("fport_fill_input");
759 return (scm_t_wchar
) EOF
;
762 pt
->read_pos
= pt
->read_buf
;
763 pt
->read_end
= pt
->read_buf
+ count
;
764 return *pt
->read_buf
;
769 fport_seek (SCM port
, scm_t_off offset
, int whence
)
771 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
772 scm_t_fport
*fp
= SCM_FSTREAM (port
);
774 off_t_or_off64_t result
;
776 if (pt
->rw_active
== SCM_PORT_WRITE
)
778 if (offset
!= 0 || whence
!= SEEK_CUR
)
781 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
785 /* read current position without disturbing the buffer. */
786 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
787 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
790 else if (pt
->rw_active
== SCM_PORT_READ
)
792 if (offset
!= 0 || whence
!= SEEK_CUR
)
794 /* could expand to avoid a second seek. */
795 scm_end_input_unlocked (port
);
796 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
800 /* read current position without disturbing the buffer
801 (particularly the unread-char buffer). */
802 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
803 result
= rv
- (pt
->read_end
- pt
->read_pos
);
805 if (pt
->read_buf
== pt
->putback_buf
)
806 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
809 else /* SCM_PORT_NEITHER */
811 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
815 scm_syserror ("fport_seek");
821 fport_truncate (SCM port
, scm_t_off length
)
823 scm_t_fport
*fp
= SCM_FSTREAM (port
);
825 if (ftruncate (fp
->fdes
, length
) == -1)
826 scm_syserror ("ftruncate");
830 fport_write (SCM port
, const void *data
, size_t size
)
831 #define FUNC_NAME "fport_write"
833 /* this procedure tries to minimize the number of writes/flushes. */
834 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
836 if (pt
->write_buf
== &pt
->shortbuf
837 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
839 /* Unbuffered port, or port with empty buffer and data won't fit in
841 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
848 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
852 /* data fits in buffer. */
853 memcpy (pt
->write_pos
, data
, size
);
854 pt
->write_pos
+= size
;
855 if (pt
->write_pos
== pt
->write_end
)
858 /* we can skip the line-buffering check if nothing's buffered. */
864 memcpy (pt
->write_pos
, data
, space
);
865 pt
->write_pos
= pt
->write_end
;
868 const void *ptr
= ((const char *) data
) + space
;
869 size_t remaining
= size
- space
;
871 if (size
>= pt
->write_buf_size
)
873 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
880 memcpy (pt
->write_pos
, ptr
, remaining
);
881 pt
->write_pos
+= remaining
;
886 /* handle line buffering. */
887 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
894 fport_flush (SCM port
)
897 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
898 scm_t_fport
*fp
= SCM_FSTREAM (port
);
899 size_t count
= pt
->write_pos
- pt
->write_buf
;
901 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
903 scm_syserror ("scm_flush");
905 pt
->write_pos
= pt
->write_buf
;
906 pt
->rw_active
= SCM_PORT_NEITHER
;
909 /* clear the read buffer and adjust the file position for unread bytes. */
911 fport_end_input (SCM port
, int offset
)
913 scm_t_fport
*fp
= SCM_FSTREAM (port
);
914 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
916 offset
+= pt
->read_end
- pt
->read_pos
;
920 pt
->read_pos
= pt
->read_end
;
921 /* will throw error if unread-char used at beginning of file
922 then attempting to write. seems correct. */
923 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
924 scm_syserror ("fport_end_input");
926 pt
->rw_active
= SCM_PORT_NEITHER
;
930 close_the_fd (void *data
)
932 scm_t_fport
*fp
= data
;
935 /* There's already one exception. That's probably enough! */
940 fport_close (SCM port
)
942 scm_t_fport
*fp
= SCM_FSTREAM (port
);
945 scm_dynwind_begin (0);
946 scm_dynwind_unwind_handler (close_the_fd
, fp
, 0);
950 scm_port_non_buffer (SCM_PTAB_ENTRY (port
));
952 rv
= close (fp
->fdes
);
954 /* It's not useful to retry after EINTR, as the file descriptor is
955 in an undefined state. See http://lwn.net/Articles/365294/.
956 Instead just throw an error if close fails, trusting that the fd
958 scm_syserror ("fport_close");
964 fport_free (SCM port
)
973 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
975 scm_set_port_free (tc
, fport_free
);
976 scm_set_port_print (tc
, fport_print
);
977 scm_set_port_flush (tc
, fport_flush
);
978 scm_set_port_end_input (tc
, fport_end_input
);
979 scm_set_port_close (tc
, fport_close
);
980 scm_set_port_seek (tc
, fport_seek
);
981 scm_set_port_truncate (tc
, fport_truncate
);
982 scm_set_port_input_waiting (tc
, fport_input_waiting
);
983 scm_set_port_setvbuf (tc
, scm_fport_buffer_add
);
988 /* We can't initialize the keywords from 'scm_init_fports', because
989 keywords haven't yet been initialized at that point. */
991 scm_init_fports_keywords ()
993 k_guess_encoding
= scm_from_latin1_keyword ("guess-encoding");
994 k_encoding
= scm_from_latin1_keyword ("encoding");
1000 scm_tc16_fport
= scm_make_fptob ();
1002 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
1003 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
1004 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
1006 sys_file_port_name_canonicalization
= scm_make_fluid ();
1007 scm_c_define ("%file-port-name-canonicalization",
1008 sys_file_port_name_canonicalization
);
1010 #include "libguile/fports.x"