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
181 port
= SCM_COERCE_OUTPORT (port
);
183 SCM_VALIDATE_OPFPORT (1,port
);
184 cmode
= scm_to_int (mode
);
185 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
186 scm_out_of_range (FUNC_NAME
, mode
);
190 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
195 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
198 if (SCM_UNBNDP (size
))
207 csize
= scm_to_int (size
);
208 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
209 scm_out_of_range (FUNC_NAME
, size
);
212 pt
= SCM_PTAB_ENTRY (port
);
214 if (SCM_INPUT_PORT_P (port
))
216 /* Drain pending input from PORT. Don't use `scm_drain_input' since
217 it returns a string, whereas we want binary input here. */
218 ndrained
= pt
->read_end
- pt
->read_pos
;
219 if (pt
->read_buf
== pt
->putback_buf
)
220 ndrained
+= pt
->saved_read_end
- pt
->saved_read_pos
;
224 drained
= scm_gc_malloc_pointerless (ndrained
, "file port");
225 scm_take_from_input_buffers (port
, drained
, ndrained
);
231 if (SCM_OUTPUT_PORT_P (port
))
232 scm_flush_unlocked (port
);
234 if (pt
->read_buf
== pt
->putback_buf
)
236 pt
->read_buf
= pt
->saved_read_buf
;
237 pt
->read_pos
= pt
->saved_read_pos
;
238 pt
->read_end
= pt
->saved_read_end
;
239 pt
->read_buf_size
= pt
->saved_read_buf_size
;
241 if (pt
->read_buf
!= &pt
->shortbuf
)
242 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
243 if (pt
->write_buf
!= &pt
->shortbuf
)
244 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
246 scm_fport_buffer_add (port
, csize
, csize
);
249 /* Put DRAINED back to PORT. */
250 while (ndrained
-- > 0)
251 scm_unget_byte (drained
[ndrained
], port
);
253 return SCM_UNSPECIFIED
;
257 /* Move ports with the specified file descriptor to new descriptors,
258 * resetting the revealed count to 0.
261 scm_i_evict_port (void *closure
, SCM port
)
263 int fd
= * (int*) closure
;
265 if (SCM_FPORTP (port
))
270 /* XXX: In some cases, we can encounter a port with no associated ptab
272 p
= SCM_PTAB_ENTRY (port
);
273 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
275 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
279 scm_syserror ("scm_evict_ports");
280 scm_set_port_revealed_x (port
, scm_from_int (0));
286 scm_evict_ports (int fd
)
288 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
292 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
294 "Determine whether @var{obj} is a port that is related to a file.")
295 #define FUNC_NAME s_scm_file_port_p
297 return scm_from_bool (SCM_FPORTP (obj
));
302 static SCM sys_file_port_name_canonicalization
;
303 SCM_SYMBOL (sym_relative
, "relative");
304 SCM_SYMBOL (sym_absolute
, "absolute");
307 fport_canonicalize_filename (SCM filename
)
309 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
311 if (!scm_is_string (filename
))
315 else if (scm_is_eq (mode
, sym_relative
))
319 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
321 rel
= scm_i_relativize_path (filename
, path
);
323 return scm_is_true (rel
) ? rel
: filename
;
325 else if (scm_is_eq (mode
, sym_absolute
))
329 str
= scm_to_locale_string (filename
);
330 canon
= canonicalize_file_name (str
);
333 return canon
? scm_take_locale_string (canon
) : filename
;
343 * Return a new port open on a given file.
345 * The mode string must match the pattern: [rwa+]** which
346 * is interpreted in the usual unix way.
348 * Return the new port.
350 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
351 (SCM filename
, SCM mode
),
352 "Open the file whose name is @var{filename}, and return a port\n"
353 "representing that file. The attributes of the port are\n"
354 "determined by the @var{mode} string. The way in which this is\n"
355 "interpreted is similar to C stdio. The first character must be\n"
356 "one of the following:\n"
359 "Open an existing file for input.\n"
361 "Open a file for output, creating it if it doesn't already exist\n"
362 "or removing its contents if it does.\n"
364 "Open a file for output, creating it if it doesn't already\n"
365 "exist. All writes to the port will go to the end of the file.\n"
366 "The \"append mode\" can be turned off while the port is in use\n"
367 "@pxref{Ports and File Descriptors, fcntl}\n"
369 "The following additional characters can be appended:\n"
372 "Open the underlying file in binary mode, if supported by the system.\n"
373 "Also, open the file using the binary-compatible character encoding\n"
374 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
375 "at the top of the input file, if any.\n"
377 "Open the port for both input and output. E.g., @code{r+}: open\n"
378 "an existing file for both input and output.\n"
380 "Create an \"unbuffered\" port. In this case input and output\n"
381 "operations are passed directly to the underlying port\n"
382 "implementation without additional buffering. This is likely to\n"
383 "slow down I/O operations. The buffering mode can be changed\n"
384 "while a port is in use @pxref{Ports and File Descriptors,\n"
387 "Add line-buffering to the port. The port output buffer will be\n"
388 "automatically flushed whenever a newline character is written.\n"
390 "When the file is opened, this procedure will scan for a coding\n"
391 "declaration@pxref{Character Encoding of Source Files}. If present\n"
392 "will use that encoding for interpreting the file. Otherwise, the\n"
393 "port's encoding will be used.\n"
395 "In theory we could create read/write ports which were buffered\n"
396 "in one direction only. However this isn't included in the\n"
397 "current interfaces. If a file cannot be opened with the access\n"
398 "requested, @code{open-file} throws an exception.")
399 #define FUNC_NAME s_scm_open_file
402 int fdes
, flags
= 0, use_encoding
= 1;
403 unsigned int retries
;
404 char *file
, *md
, *ptr
;
406 scm_dynwind_begin (0);
408 file
= scm_to_locale_string (filename
);
409 scm_dynwind_free (file
);
411 md
= scm_to_locale_string (mode
);
412 scm_dynwind_free (md
);
420 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
423 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
426 scm_out_of_range (FUNC_NAME
, mode
);
434 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
438 #if defined (O_BINARY)
442 case '0': /* unbuffered: handled later. */
443 case 'l': /* line buffered: handled during output. */
446 scm_out_of_range (FUNC_NAME
, mode
);
451 for (retries
= 0, fdes
= -1;
452 fdes
< 0 && retries
< 2;
455 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
460 if (en
== EMFILE
&& retries
== 0)
461 /* Run the GC in case it collects open file ports that are no
462 longer referenced. */
463 scm_i_gc (FUNC_NAME
);
465 SCM_SYSERROR_MSG ("~A: ~S",
466 scm_cons (scm_strerror (scm_from_int (en
)),
467 scm_cons (filename
, SCM_EOL
)), en
);
471 /* Create a port from this file descriptor. The port's encoding is initially
472 %default-port-encoding. */
473 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
474 fport_canonicalize_filename (filename
));
478 /* If this file has a coding declaration, use that as the port
480 if (SCM_INPUT_PORT_P (port
))
482 char *enc
= scm_i_scan_for_encoding (port
);
484 scm_i_set_port_encoding_x (port
, enc
);
488 /* If this is a binary file, use the binary-friendly ISO-8859-1
490 scm_i_set_port_encoding_x (port
, NULL
);
501 * Try getting the appropiate file flags for a given file descriptor
502 * under Windows. This incorporates some fancy operations because Windows
503 * differentiates between file, pipe and socket descriptors.
506 # define O_ACCMODE 0x0003
509 static int getflags (int fdes
)
513 int error
, optlen
= sizeof (int);
515 /* Is this a socket ? */
516 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
518 /* Maybe a regular file ? */
519 else if (fstat (fdes
, &buf
) < 0)
523 /* Or an anonymous pipe handle ? */
524 if (buf
.st_mode
& _S_IFIFO
)
525 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
526 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
528 else if (fdes
== fileno (stdin
) && isatty (fdes
))
530 /* stdout / stderr ? */
531 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
539 #endif /* __MINGW32__ */
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"
556 /* test that fdes is valid. */
558 flags
= getflags (fdes
);
560 flags
= fcntl (fdes
, F_GETFL
, 0);
566 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
567 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
569 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
572 fp
= (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
576 port
= scm_c_make_port (scm_tc16_fport
, mode_bits
, (scm_t_bits
)fp
);
578 SCM_PTAB_ENTRY (port
)->rw_random
= SCM_FDES_RANDOM_P (fdes
);
580 if (mode_bits
& SCM_BUF0
)
581 scm_fport_buffer_add (port
, 0, 0);
583 scm_fport_buffer_add (port
, -1, -1);
585 SCM_SET_FILENAME (port
, name
);
592 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
594 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
597 /* Return a lower bound on the number of bytes available for input. */
599 fport_input_waiting (SCM port
)
601 int fdes
= SCM_FSTREAM (port
)->fdes
;
603 /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
604 highest numerical value of file descriptors that can be monitored.
605 Thus, use poll(2) whenever that is possible. */
608 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
610 if (poll (&pollfd
, 1, 0) < 0)
611 scm_syserror ("fport_input_waiting");
613 return pollfd
.revents
& POLLIN
? 1 : 0;
615 #elif defined(HAVE_SELECT)
616 struct timeval timeout
;
617 SELECT_TYPE read_set
;
618 SELECT_TYPE write_set
;
619 SELECT_TYPE except_set
;
622 FD_ZERO (&write_set
);
623 FD_ZERO (&except_set
);
625 FD_SET (fdes
, &read_set
);
630 if (select (SELECT_SET_SIZE
,
631 &read_set
, &write_set
, &except_set
, &timeout
)
633 scm_syserror ("fport_input_waiting");
634 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
636 #elif HAVE_IOCTL && defined (FIONREAD)
637 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
638 (for use with winsock ioctlsocket()) but not ioctl(). */
639 int fdes
= SCM_FSTREAM (port
)->fdes
;
641 ioctl(fdes
, FIONREAD
, &remir
);
645 scm_misc_error ("fport_input_waiting",
646 "Not fully implemented on this platform",
654 /* Revealed counts --- an oddity inherited from SCSH. */
656 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
658 static SCM revealed_ports
= SCM_EOL
;
659 static scm_i_pthread_mutex_t revealed_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
661 /* Find a port in the table and return its revealed count.
662 Also used by the garbage collector.
665 scm_revealed_count (SCM port
)
669 scm_i_pthread_mutex_lock (&revealed_lock
);
670 ret
= SCM_REVEALED (port
);
671 scm_i_pthread_mutex_unlock (&revealed_lock
);
676 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
678 "Return the revealed count for @var{port}.")
679 #define FUNC_NAME s_scm_port_revealed
681 port
= SCM_COERCE_OUTPORT (port
);
682 SCM_VALIDATE_OPFPORT (1, port
);
683 return scm_from_int (scm_revealed_count (port
));
687 /* Set the revealed count for a port. */
688 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
689 (SCM port
, SCM rcount
),
690 "Sets the revealed count for a port to a given value.\n"
691 "The return value is unspecified.")
692 #define FUNC_NAME s_scm_set_port_revealed_x
696 port
= SCM_COERCE_OUTPORT (port
);
697 SCM_VALIDATE_OPFPORT (1, port
);
699 r
= scm_to_int (rcount
);
701 scm_i_pthread_mutex_lock (&revealed_lock
);
703 prev
= SCM_REVEALED (port
);
704 SCM_REVEALED (port
) = r
;
707 revealed_ports
= scm_cons (port
, revealed_ports
);
709 revealed_ports
= scm_delq_x (port
, revealed_ports
);
711 scm_i_pthread_mutex_unlock (&revealed_lock
);
713 return SCM_UNSPECIFIED
;
717 /* Set the revealed count for a port. */
718 SCM_DEFINE (scm_adjust_port_revealed_x
, "adjust-port-revealed!", 2, 0, 0,
719 (SCM port
, SCM addend
),
720 "Add @var{addend} to the revealed count of @var{port}.\n"
721 "The return value is unspecified.")
722 #define FUNC_NAME s_scm_adjust_port_revealed_x
726 port
= SCM_COERCE_OUTPORT (port
);
727 SCM_VALIDATE_OPFPORT (1, port
);
729 a
= scm_to_int (addend
);
731 return SCM_UNSPECIFIED
;
733 scm_i_pthread_mutex_lock (&revealed_lock
);
735 SCM_REVEALED (port
) += a
;
736 if (SCM_REVEALED (port
) == a
)
737 revealed_ports
= scm_cons (port
, revealed_ports
);
738 else if (!SCM_REVEALED (port
))
739 revealed_ports
= scm_delq_x (port
, revealed_ports
);
741 scm_i_pthread_mutex_unlock (&revealed_lock
);
743 return SCM_UNSPECIFIED
;
750 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
752 scm_puts_unlocked ("#<", port
);
753 scm_print_port_mode (exp
, port
);
754 if (SCM_OPFPORTP (exp
))
757 SCM name
= SCM_FILENAME (exp
);
758 if (scm_is_string (name
) || scm_is_symbol (name
))
759 scm_display (name
, port
);
761 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
762 scm_putc_unlocked (' ', port
);
763 fdes
= (SCM_FSTREAM (exp
))->fdes
;
765 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
767 scm_display (scm_ttyname (exp
), port
);
769 #endif /* HAVE_TTYNAME */
770 scm_intprint (fdes
, 10, port
);
774 scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
775 scm_putc_unlocked (' ', port
);
776 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
778 scm_putc_unlocked ('>', port
);
782 static void fport_flush (SCM port
);
784 /* fill a port's read-buffer with a single read. returns the first
785 char or EOF if end of file. */
787 fport_fill_input (SCM port
)
790 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
791 scm_t_fport
*fp
= SCM_FSTREAM (port
);
793 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
795 scm_syserror ("fport_fill_input");
797 return (scm_t_wchar
) EOF
;
800 pt
->read_pos
= pt
->read_buf
;
801 pt
->read_end
= pt
->read_buf
+ count
;
802 return *pt
->read_buf
;
807 fport_seek (SCM port
, scm_t_off offset
, int whence
)
809 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
810 scm_t_fport
*fp
= SCM_FSTREAM (port
);
812 off_t_or_off64_t result
;
814 if (pt
->rw_active
== SCM_PORT_WRITE
)
816 if (offset
!= 0 || whence
!= SEEK_CUR
)
819 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
823 /* read current position without disturbing the buffer. */
824 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
825 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
828 else if (pt
->rw_active
== SCM_PORT_READ
)
830 if (offset
!= 0 || whence
!= SEEK_CUR
)
832 /* could expand to avoid a second seek. */
833 scm_end_input_unlocked (port
);
834 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
838 /* read current position without disturbing the buffer
839 (particularly the unread-char buffer). */
840 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
841 result
= rv
- (pt
->read_end
- pt
->read_pos
);
843 if (pt
->read_buf
== pt
->putback_buf
)
844 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
847 else /* SCM_PORT_NEITHER */
849 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
853 scm_syserror ("fport_seek");
859 fport_truncate (SCM port
, scm_t_off length
)
861 scm_t_fport
*fp
= SCM_FSTREAM (port
);
863 if (ftruncate (fp
->fdes
, length
) == -1)
864 scm_syserror ("ftruncate");
868 fport_write (SCM port
, const void *data
, size_t size
)
869 #define FUNC_NAME "fport_write"
871 /* this procedure tries to minimize the number of writes/flushes. */
872 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
874 if (pt
->write_buf
== &pt
->shortbuf
875 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
877 /* Unbuffered port, or port with empty buffer and data won't fit in
879 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
886 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
890 /* data fits in buffer. */
891 memcpy (pt
->write_pos
, data
, size
);
892 pt
->write_pos
+= size
;
893 if (pt
->write_pos
== pt
->write_end
)
896 /* we can skip the line-buffering check if nothing's buffered. */
902 memcpy (pt
->write_pos
, data
, space
);
903 pt
->write_pos
= pt
->write_end
;
906 const void *ptr
= ((const char *) data
) + space
;
907 size_t remaining
= size
- space
;
909 if (size
>= pt
->write_buf_size
)
911 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
918 memcpy (pt
->write_pos
, ptr
, remaining
);
919 pt
->write_pos
+= remaining
;
924 /* handle line buffering. */
925 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
932 fport_flush (SCM port
)
935 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
936 scm_t_fport
*fp
= SCM_FSTREAM (port
);
937 size_t count
= pt
->write_pos
- pt
->write_buf
;
939 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
941 scm_syserror ("scm_flush");
943 pt
->write_pos
= pt
->write_buf
;
944 pt
->rw_active
= SCM_PORT_NEITHER
;
947 /* clear the read buffer and adjust the file position for unread bytes. */
949 fport_end_input (SCM port
, int offset
)
951 scm_t_fport
*fp
= SCM_FSTREAM (port
);
952 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
954 offset
+= pt
->read_end
- pt
->read_pos
;
958 pt
->read_pos
= pt
->read_end
;
959 /* will throw error if unread-char used at beginning of file
960 then attempting to write. seems correct. */
961 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
962 scm_syserror ("fport_end_input");
964 pt
->rw_active
= SCM_PORT_NEITHER
;
968 close_the_fd (void *data
)
970 scm_t_fport
*fp
= data
;
973 /* There's already one exception. That's probably enough! */
978 fport_close (SCM port
)
980 scm_t_fport
*fp
= SCM_FSTREAM (port
);
983 scm_dynwind_begin (0);
984 scm_dynwind_unwind_handler (close_the_fd
, fp
, 0);
988 scm_port_non_buffer (SCM_PTAB_ENTRY (port
));
990 rv
= close (fp
->fdes
);
992 /* It's not useful to retry after EINTR, as the file descriptor is
993 in an undefined state. See http://lwn.net/Articles/365294/.
994 Instead just throw an error if close fails, trusting that the fd
996 scm_syserror ("fport_close");
1002 fport_free (SCM port
)
1011 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
1013 scm_set_port_free (tc
, fport_free
);
1014 scm_set_port_print (tc
, fport_print
);
1015 scm_set_port_flush (tc
, fport_flush
);
1016 scm_set_port_end_input (tc
, fport_end_input
);
1017 scm_set_port_close (tc
, fport_close
);
1018 scm_set_port_seek (tc
, fport_seek
);
1019 scm_set_port_truncate (tc
, fport_truncate
);
1020 scm_set_port_input_waiting (tc
, fport_input_waiting
);
1028 scm_tc16_fport
= scm_make_fptob ();
1030 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
1031 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
1032 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
1034 sys_file_port_name_canonicalization
= scm_make_fluid ();
1035 scm_c_define ("%file-port-name-canonicalization",
1036 sys_file_port_name_canonicalization
);
1038 #include "libguile/fports.x"