1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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 */
31 #include "libguile/_scm.h"
32 #include "libguile/strings.h"
33 #include "libguile/validate.h"
34 #include "libguile/gc.h"
35 #include "libguile/posix.h"
36 #include "libguile/dynwind.h"
37 #include "libguile/hashtab.h"
39 #include "libguile/fports.h"
50 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
57 #include <sys/types.h>
59 #include <full-write.h>
61 #include "libguile/iselect.h"
63 /* Some defines for Windows (native port, not Cygwin). */
65 # include <sys/stat.h>
66 # include <winsock2.h>
67 #endif /* __MINGW32__ */
69 #include <full-write.h>
71 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
72 already, but have this code here in case that wasn't so in past versions,
73 or perhaps to help other minimal DOS environments.
75 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
76 might be possibilities if we've got other systems without ftruncate. */
78 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
79 # define ftruncate(fd, size) chsize (fd, size)
80 # undef HAVE_FTRUNCATE
81 # define HAVE_FTRUNCATE 1
84 #if SIZEOF_OFF_T == SIZEOF_INT
85 #define OFF_T_MAX INT_MAX
86 #define OFF_T_MIN INT_MIN
87 #elif SIZEOF_OFF_T == SIZEOF_LONG
88 #define OFF_T_MAX LONG_MAX
89 #define OFF_T_MIN LONG_MIN
90 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
91 #define OFF_T_MAX LONG_LONG_MAX
92 #define OFF_T_MIN LONG_LONG_MIN
94 #error Oops, unknown OFF_T size
97 scm_t_bits scm_tc16_fport
;
100 /* default buffer size, used if the O/S won't supply a value. */
101 static const size_t default_buffer_size
= 1024;
103 /* create FPORT buffer with specified sizes (or -1 to use default size or
106 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
107 #define FUNC_NAME "scm_fport_buffer_add"
109 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
111 if (read_size
== -1 || write_size
== -1)
114 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
116 scm_t_fport
*fp
= SCM_FSTREAM (port
);
118 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
121 default_size
= default_buffer_size
;
124 read_size
= default_size
;
125 if (write_size
== -1)
126 write_size
= default_size
;
129 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
131 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
132 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
133 pt
->read_buf_size
= read_size
;
137 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
138 pt
->read_buf_size
= 1;
141 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
143 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
144 pt
->write_pos
= pt
->write_buf
;
145 pt
->write_buf_size
= write_size
;
149 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
150 pt
->write_buf_size
= 1;
153 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
154 if (read_size
> 0 || write_size
> 0)
155 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
157 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
161 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
162 (SCM port
, SCM mode
, SCM size
),
163 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
170 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
171 "If @var{size} is omitted, a default size will be used.\n"
173 #define FUNC_NAME s_scm_setvbuf
180 port
= SCM_COERCE_OUTPORT (port
);
182 SCM_VALIDATE_OPFPORT (1,port
);
183 cmode
= scm_to_int (mode
);
184 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
185 scm_out_of_range (FUNC_NAME
, mode
);
189 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
194 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
197 if (SCM_UNBNDP (size
))
206 csize
= scm_to_int (size
);
207 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
208 scm_out_of_range (FUNC_NAME
, size
);
211 pt
= SCM_PTAB_ENTRY (port
);
213 if (SCM_INPUT_PORT_P (port
))
214 drained
= scm_drain_input (port
);
216 drained
= scm_nullstr
;
218 if (SCM_OUTPUT_PORT_P (port
))
219 scm_flush_unlocked (port
);
221 if (pt
->read_buf
== pt
->putback_buf
)
223 pt
->read_buf
= pt
->saved_read_buf
;
224 pt
->read_pos
= pt
->saved_read_pos
;
225 pt
->read_end
= pt
->saved_read_end
;
226 pt
->read_buf_size
= pt
->saved_read_buf_size
;
228 if (pt
->read_buf
!= &pt
->shortbuf
)
229 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
230 if (pt
->write_buf
!= &pt
->shortbuf
)
231 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
233 scm_fport_buffer_add (port
, csize
, csize
);
235 if (scm_is_true (drained
) && scm_c_string_length (drained
))
236 scm_unread_string (drained
, port
);
238 return SCM_UNSPECIFIED
;
242 /* Move ports with the specified file descriptor to new descriptors,
243 * resetting the revealed count to 0.
246 scm_i_evict_port (void *closure
, SCM port
)
248 int fd
= * (int*) closure
;
250 if (SCM_FPORTP (port
))
255 /* XXX: In some cases, we can encounter a port with no associated ptab
257 p
= SCM_PTAB_ENTRY (port
);
258 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
260 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
264 scm_syserror ("scm_evict_ports");
265 scm_set_port_revealed_x (port
, scm_from_int (0));
271 scm_evict_ports (int fd
)
273 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
277 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
279 "Determine whether @var{obj} is a port that is related to a file.")
280 #define FUNC_NAME s_scm_file_port_p
282 return scm_from_bool (SCM_FPORTP (obj
));
287 static SCM sys_file_port_name_canonicalization
;
288 SCM_SYMBOL (sym_relative
, "relative");
289 SCM_SYMBOL (sym_absolute
, "absolute");
292 fport_canonicalize_filename (SCM filename
)
294 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
296 if (!scm_is_string (filename
))
300 else if (scm_is_eq (mode
, sym_relative
))
304 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
306 rel
= scm_i_relativize_path (filename
, path
);
308 return scm_is_true (rel
) ? rel
: filename
;
310 else if (scm_is_eq (mode
, sym_absolute
))
314 str
= scm_to_locale_string (filename
);
315 canon
= canonicalize_file_name (str
);
318 return canon
? scm_take_locale_string (canon
) : filename
;
328 * Return a new port open on a given file.
330 * The mode string must match the pattern: [rwa+]** which
331 * is interpreted in the usual unix way.
333 * Return the new port.
335 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
336 (SCM filename
, SCM mode
),
337 "Open the file whose name is @var{filename}, and return a port\n"
338 "representing that file. The attributes of the port are\n"
339 "determined by the @var{mode} string. The way in which this is\n"
340 "interpreted is similar to C stdio. The first character must be\n"
341 "one of the following:\n"
344 "Open an existing file for input.\n"
346 "Open a file for output, creating it if it doesn't already exist\n"
347 "or removing its contents if it does.\n"
349 "Open a file for output, creating it if it doesn't already\n"
350 "exist. All writes to the port will go to the end of the file.\n"
351 "The \"append mode\" can be turned off while the port is in use\n"
352 "@pxref{Ports and File Descriptors, fcntl}\n"
354 "The following additional characters can be appended:\n"
357 "Open the underlying file in binary mode, if supported by the system.\n"
358 "Also, open the file using the binary-compatible character encoding\n"
359 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
360 "at the top of the input file, if any.\n"
362 "Open the port for both input and output. E.g., @code{r+}: open\n"
363 "an existing file for both input and output.\n"
365 "Create an \"unbuffered\" port. In this case input and output\n"
366 "operations are passed directly to the underlying port\n"
367 "implementation without additional buffering. This is likely to\n"
368 "slow down I/O operations. The buffering mode can be changed\n"
369 "while a port is in use @pxref{Ports and File Descriptors,\n"
372 "Add line-buffering to the port. The port output buffer will be\n"
373 "automatically flushed whenever a newline character is written.\n"
375 "When the file is opened, this procedure will scan for a coding\n"
376 "declaration@pxref{Character Encoding of Source Files}. If present\n"
377 "will use that encoding for interpreting the file. Otherwise, the\n"
378 "port's encoding will be used.\n"
380 "In theory we could create read/write ports which were buffered\n"
381 "in one direction only. However this isn't included in the\n"
382 "current interfaces. If a file cannot be opened with the access\n"
383 "requested, @code{open-file} throws an exception.")
384 #define FUNC_NAME s_scm_open_file
387 int fdes
, flags
= 0, use_encoding
= 1;
388 unsigned int retries
;
389 char *file
, *md
, *ptr
;
391 scm_dynwind_begin (0);
393 file
= scm_to_locale_string (filename
);
394 scm_dynwind_free (file
);
396 md
= scm_to_locale_string (mode
);
397 scm_dynwind_free (md
);
405 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
408 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
411 scm_out_of_range (FUNC_NAME
, mode
);
419 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
423 #if defined (O_BINARY)
427 case '0': /* unbuffered: handled later. */
428 case 'l': /* line buffered: handled during output. */
431 scm_out_of_range (FUNC_NAME
, mode
);
436 for (retries
= 0, fdes
= -1;
437 fdes
< 0 && retries
< 2;
440 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
445 if (en
== EMFILE
&& retries
== 0)
446 /* Run the GC in case it collects open file ports that are no
447 longer referenced. */
448 scm_i_gc (FUNC_NAME
);
450 SCM_SYSERROR_MSG ("~A: ~S",
451 scm_cons (scm_strerror (scm_from_int (en
)),
452 scm_cons (filename
, SCM_EOL
)), en
);
456 /* Create a port from this file descriptor. The port's encoding is initially
457 %default-port-encoding. */
458 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
459 fport_canonicalize_filename (filename
));
463 /* If this file has a coding declaration, use that as the port
465 if (SCM_INPUT_PORT_P (port
))
467 char *enc
= scm_i_scan_for_encoding (port
);
469 scm_i_set_port_encoding_x (port
, enc
);
473 /* If this is a binary file, use the binary-friendly ISO-8859-1
475 scm_i_set_port_encoding_x (port
, NULL
);
486 * Try getting the appropiate file flags for a given file descriptor
487 * under Windows. This incorporates some fancy operations because Windows
488 * differentiates between file, pipe and socket descriptors.
491 # define O_ACCMODE 0x0003
494 static int getflags (int fdes
)
498 int error
, optlen
= sizeof (int);
500 /* Is this a socket ? */
501 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
503 /* Maybe a regular file ? */
504 else if (fstat (fdes
, &buf
) < 0)
508 /* Or an anonymous pipe handle ? */
509 if (buf
.st_mode
& _S_IFIFO
)
510 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
511 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
513 else if (fdes
== fileno (stdin
) && isatty (fdes
))
515 /* stdout / stderr ? */
516 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
524 #endif /* __MINGW32__ */
526 /* Building Guile ports from a file descriptor. */
528 /* Build a Scheme port from an open file descriptor `fdes'.
529 MODE indicates whether FILE is open for reading or writing; it uses
530 the same notation as open-file's second argument.
531 NAME is a string to be used as the port's filename.
534 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
535 #define FUNC_NAME "scm_fdes_to_port"
541 /* test that fdes is valid. */
543 flags
= getflags (fdes
);
545 flags
= fcntl (fdes
, F_GETFL
, 0);
551 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
552 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
554 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
557 fp
= (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
561 port
= scm_c_make_port (scm_tc16_fport
, mode_bits
, (scm_t_bits
)fp
);
563 SCM_PTAB_ENTRY (port
)->rw_random
= SCM_FDES_RANDOM_P (fdes
);
565 if (mode_bits
& SCM_BUF0
)
566 scm_fport_buffer_add (port
, 0, 0);
568 scm_fport_buffer_add (port
, -1, -1);
570 SCM_SET_FILENAME (port
, name
);
577 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
579 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
582 /* Return a lower bound on the number of bytes available for input. */
584 fport_input_waiting (SCM port
)
586 int fdes
= SCM_FSTREAM (port
)->fdes
;
588 /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
589 highest numerical value of file descriptors that can be monitored.
590 Thus, use poll(2) whenever that is possible. */
593 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
595 if (poll (&pollfd
, 1, 0) < 0)
596 scm_syserror ("fport_input_waiting");
598 return pollfd
.revents
& POLLIN
? 1 : 0;
600 #elif defined(HAVE_SELECT)
601 struct timeval timeout
;
602 SELECT_TYPE read_set
;
603 SELECT_TYPE write_set
;
604 SELECT_TYPE except_set
;
607 FD_ZERO (&write_set
);
608 FD_ZERO (&except_set
);
610 FD_SET (fdes
, &read_set
);
615 if (select (SELECT_SET_SIZE
,
616 &read_set
, &write_set
, &except_set
, &timeout
)
618 scm_syserror ("fport_input_waiting");
619 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
621 #elif HAVE_IOCTL && defined (FIONREAD)
622 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
623 (for use with winsock ioctlsocket()) but not ioctl(). */
624 int fdes
= SCM_FSTREAM (port
)->fdes
;
626 ioctl(fdes
, FIONREAD
, &remir
);
630 scm_misc_error ("fport_input_waiting",
631 "Not fully implemented on this platform",
639 /* Revealed counts --- an oddity inherited from SCSH. */
641 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
643 static SCM revealed_ports
= SCM_EOL
;
644 static scm_i_pthread_mutex_t revealed_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
646 /* Find a port in the table and return its revealed count.
647 Also used by the garbage collector.
650 scm_revealed_count (SCM port
)
654 scm_i_pthread_mutex_lock (&revealed_lock
);
655 ret
= SCM_REVEALED (port
);
656 scm_i_pthread_mutex_unlock (&revealed_lock
);
661 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
663 "Return the revealed count for @var{port}.")
664 #define FUNC_NAME s_scm_port_revealed
666 port
= SCM_COERCE_OUTPORT (port
);
667 SCM_VALIDATE_OPFPORT (1, port
);
668 return scm_from_int (scm_revealed_count (port
));
672 /* Set the revealed count for a port. */
673 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
674 (SCM port
, SCM rcount
),
675 "Sets the revealed count for a port to a given value.\n"
676 "The return value is unspecified.")
677 #define FUNC_NAME s_scm_set_port_revealed_x
681 port
= SCM_COERCE_OUTPORT (port
);
682 SCM_VALIDATE_OPFPORT (1, port
);
684 r
= scm_to_int (rcount
);
686 scm_i_pthread_mutex_lock (&revealed_lock
);
688 prev
= SCM_REVEALED (port
);
689 SCM_REVEALED (port
) = r
;
692 revealed_ports
= scm_cons (port
, revealed_ports
);
694 revealed_ports
= scm_delq_x (port
, revealed_ports
);
696 scm_i_pthread_mutex_unlock (&revealed_lock
);
698 return SCM_UNSPECIFIED
;
702 /* Set the revealed count for a port. */
703 SCM_DEFINE (scm_adjust_port_revealed_x
, "adjust-port-revealed!", 2, 0, 0,
704 (SCM port
, SCM addend
),
705 "Add @var{addend} to the revealed count of @var{port}.\n"
706 "The return value is unspecified.")
707 #define FUNC_NAME s_scm_adjust_port_revealed_x
711 port
= SCM_COERCE_OUTPORT (port
);
712 SCM_VALIDATE_OPFPORT (1, port
);
714 a
= scm_to_int (addend
);
716 return SCM_UNSPECIFIED
;
718 scm_i_pthread_mutex_lock (&revealed_lock
);
720 SCM_REVEALED (port
) += a
;
721 if (SCM_REVEALED (port
) == a
)
722 revealed_ports
= scm_cons (port
, revealed_ports
);
723 else if (!SCM_REVEALED (port
))
724 revealed_ports
= scm_delq_x (port
, revealed_ports
);
726 scm_i_pthread_mutex_unlock (&revealed_lock
);
728 return SCM_UNSPECIFIED
;
735 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
737 scm_puts_unlocked ("#<", port
);
738 scm_print_port_mode (exp
, port
);
739 if (SCM_OPFPORTP (exp
))
742 SCM name
= SCM_FILENAME (exp
);
743 if (scm_is_string (name
) || scm_is_symbol (name
))
744 scm_display (name
, port
);
746 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
747 scm_putc_unlocked (' ', port
);
748 fdes
= (SCM_FSTREAM (exp
))->fdes
;
750 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
752 scm_display (scm_ttyname (exp
), port
);
754 #endif /* HAVE_TTYNAME */
755 scm_intprint (fdes
, 10, port
);
759 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
760 scm_putc_unlocked (' ', port
);
761 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
763 scm_putc_unlocked ('>', port
);
767 static void fport_flush (SCM port
);
769 /* fill a port's read-buffer with a single read. returns the first
770 char or EOF if end of file. */
772 fport_fill_input (SCM port
)
775 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
776 scm_t_fport
*fp
= SCM_FSTREAM (port
);
778 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
780 scm_syserror ("fport_fill_input");
782 return (scm_t_wchar
) EOF
;
785 pt
->read_pos
= pt
->read_buf
;
786 pt
->read_end
= pt
->read_buf
+ count
;
787 return *pt
->read_buf
;
792 fport_seek (SCM port
, scm_t_off offset
, int whence
)
794 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
795 scm_t_fport
*fp
= SCM_FSTREAM (port
);
797 off_t_or_off64_t result
;
799 if (pt
->rw_active
== SCM_PORT_WRITE
)
801 if (offset
!= 0 || whence
!= SEEK_CUR
)
804 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
808 /* read current position without disturbing the buffer. */
809 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
810 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
813 else if (pt
->rw_active
== SCM_PORT_READ
)
815 if (offset
!= 0 || whence
!= SEEK_CUR
)
817 /* could expand to avoid a second seek. */
818 scm_end_input_unlocked (port
);
819 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
823 /* read current position without disturbing the buffer
824 (particularly the unread-char buffer). */
825 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
826 result
= rv
- (pt
->read_end
- pt
->read_pos
);
828 if (pt
->read_buf
== pt
->putback_buf
)
829 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
832 else /* SCM_PORT_NEITHER */
834 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
838 scm_syserror ("fport_seek");
844 fport_truncate (SCM port
, scm_t_off length
)
846 scm_t_fport
*fp
= SCM_FSTREAM (port
);
848 if (ftruncate (fp
->fdes
, length
) == -1)
849 scm_syserror ("ftruncate");
853 fport_write (SCM port
, const void *data
, size_t size
)
854 #define FUNC_NAME "fport_write"
856 /* this procedure tries to minimize the number of writes/flushes. */
857 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
859 if (pt
->write_buf
== &pt
->shortbuf
860 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
862 /* Unbuffered port, or port with empty buffer and data won't fit in
864 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
871 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
875 /* data fits in buffer. */
876 memcpy (pt
->write_pos
, data
, size
);
877 pt
->write_pos
+= size
;
878 if (pt
->write_pos
== pt
->write_end
)
881 /* we can skip the line-buffering check if nothing's buffered. */
887 memcpy (pt
->write_pos
, data
, space
);
888 pt
->write_pos
= pt
->write_end
;
891 const void *ptr
= ((const char *) data
) + space
;
892 size_t remaining
= size
- space
;
894 if (size
>= pt
->write_buf_size
)
896 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
903 memcpy (pt
->write_pos
, ptr
, remaining
);
904 pt
->write_pos
+= remaining
;
909 /* handle line buffering. */
910 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
917 fport_flush (SCM port
)
920 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
921 scm_t_fport
*fp
= SCM_FSTREAM (port
);
922 size_t count
= pt
->write_pos
- pt
->write_buf
;
924 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
926 scm_syserror ("scm_flush");
928 pt
->write_pos
= pt
->write_buf
;
929 pt
->rw_active
= SCM_PORT_NEITHER
;
932 /* clear the read buffer and adjust the file position for unread bytes. */
934 fport_end_input (SCM port
, int offset
)
936 scm_t_fport
*fp
= SCM_FSTREAM (port
);
937 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
939 offset
+= pt
->read_end
- pt
->read_pos
;
943 pt
->read_pos
= pt
->read_end
;
944 /* will throw error if unread-char used at beginning of file
945 then attempting to write. seems correct. */
946 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
947 scm_syserror ("fport_end_input");
949 pt
->rw_active
= SCM_PORT_NEITHER
;
953 close_the_fd (void *data
)
955 scm_t_fport
*fp
= data
;
958 /* There's already one exception. That's probably enough! */
963 fport_close (SCM port
)
965 scm_t_fport
*fp
= SCM_FSTREAM (port
);
968 scm_dynwind_begin (0);
969 scm_dynwind_unwind_handler (close_the_fd
, fp
, 0);
973 scm_port_non_buffer (SCM_PTAB_ENTRY (port
));
975 rv
= close (fp
->fdes
);
977 /* It's not useful to retry after EINTR, as the file descriptor is
978 in an undefined state. See http://lwn.net/Articles/365294/.
979 Instead just throw an error if close fails, trusting that the fd
981 scm_syserror ("fport_close");
987 fport_free (SCM port
)
996 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
998 scm_set_port_free (tc
, fport_free
);
999 scm_set_port_print (tc
, fport_print
);
1000 scm_set_port_flush (tc
, fport_flush
);
1001 scm_set_port_end_input (tc
, fport_end_input
);
1002 scm_set_port_close (tc
, fport_close
);
1003 scm_set_port_seek (tc
, fport_seek
);
1004 scm_set_port_truncate (tc
, fport_truncate
);
1005 scm_set_port_input_waiting (tc
, fport_input_waiting
);
1013 scm_tc16_fport
= scm_make_fptob ();
1015 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
1016 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
1017 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
1019 sys_file_port_name_canonicalization
= scm_make_fluid ();
1020 scm_c_define ("%file-port-name-canonicalization",
1021 sys_file_port_name_canonicalization
);
1023 #include "libguile/fports.x"