1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
26 #include "libguile/_scm.h"
27 #include "libguile/strings.h"
28 #include "libguile/validate.h"
29 #include "libguile/gc.h"
30 #include "libguile/posix.h"
31 #include "libguile/dynwind.h"
33 #include "libguile/fports.h"
46 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
52 #include "libguile/iselect.h"
54 /* Some defines for Windows (native port, not Cygwin). */
56 # include <sys/stat.h>
57 # include <winsock2.h>
58 # define ftruncate(fd, size) chsize (fd, size)
59 #endif /* __MINGW32__ */
62 scm_t_bits scm_tc16_fport
;
65 /* default buffer size, used if the O/S won't supply a value. */
66 static const size_t default_buffer_size
= 1024;
68 /* create FPORT buffer with specified sizes (or -1 to use default size or
71 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
72 #define FUNC_NAME "scm_fport_buffer_add"
74 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
76 if (read_size
== -1 || write_size
== -1)
79 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
81 scm_t_fport
*fp
= SCM_FSTREAM (port
);
83 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
86 default_size
= default_buffer_size
;
89 read_size
= default_size
;
91 write_size
= default_size
;
94 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
96 pt
->read_buf
= scm_gc_malloc (read_size
, "port buffer");
97 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
98 pt
->read_buf_size
= read_size
;
102 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
103 pt
->read_buf_size
= 1;
106 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
108 pt
->write_buf
= scm_gc_malloc (write_size
, "port buffer");
109 pt
->write_pos
= pt
->write_buf
;
110 pt
->write_buf_size
= write_size
;
114 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
115 pt
->write_buf_size
= 1;
118 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
119 if (read_size
> 0 || write_size
> 0)
120 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
122 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
126 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
127 (SCM port
, SCM mode
, SCM size
),
128 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
135 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
136 "If @var{size} is omitted, a default size will be used.\n"
138 #define FUNC_NAME s_scm_setvbuf
144 port
= SCM_COERCE_OUTPORT (port
);
146 SCM_VALIDATE_OPFPORT (1,port
);
147 cmode
= scm_to_int (mode
);
148 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
149 scm_out_of_range (FUNC_NAME
, mode
);
153 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
158 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
161 if (SCM_UNBNDP (size
))
170 csize
= scm_to_int (size
);
171 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
172 scm_out_of_range (FUNC_NAME
, size
);
175 pt
= SCM_PTAB_ENTRY (port
);
177 /* silently discards buffered and put-back chars. */
178 if (pt
->read_buf
== pt
->putback_buf
)
180 pt
->read_buf
= pt
->saved_read_buf
;
181 pt
->read_pos
= pt
->saved_read_pos
;
182 pt
->read_end
= pt
->saved_read_end
;
183 pt
->read_buf_size
= pt
->saved_read_buf_size
;
185 if (pt
->read_buf
!= &pt
->shortbuf
)
186 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
187 if (pt
->write_buf
!= &pt
->shortbuf
)
188 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
190 scm_fport_buffer_add (port
, csize
, csize
);
191 return SCM_UNSPECIFIED
;
195 /* Move ports with the specified file descriptor to new descriptors,
196 * resetting the revealed count to 0.
200 scm_evict_ports (int fd
)
204 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
206 for (i
= 0; i
< scm_i_port_table_size
; i
++)
208 SCM port
= scm_i_port_table
[i
]->port
;
210 if (SCM_FPORTP (port
))
212 scm_t_fport
*fp
= SCM_FSTREAM (port
);
218 scm_syserror ("scm_evict_ports");
219 scm_set_port_revealed_x (port
, scm_from_int (0));
224 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
228 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
230 "Determine whether @var{obj} is a port that is related to a file.")
231 #define FUNC_NAME s_scm_file_port_p
233 return scm_from_bool (SCM_FPORTP (obj
));
239 * Return a new port open on a given file.
241 * The mode string must match the pattern: [rwa+]** which
242 * is interpreted in the usual unix way.
244 * Return the new port.
246 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
247 (SCM filename
, SCM mode
),
248 "Open the file whose name is @var{filename}, and return a port\n"
249 "representing that file. The attributes of the port are\n"
250 "determined by the @var{mode} string. The way in which this is\n"
251 "interpreted is similar to C stdio. The first character must be\n"
252 "one of the following:\n"
255 "Open an existing file for input.\n"
257 "Open a file for output, creating it if it doesn't already exist\n"
258 "or removing its contents if it does.\n"
260 "Open a file for output, creating it if it doesn't already\n"
261 "exist. All writes to the port will go to the end of the file.\n"
262 "The \"append mode\" can be turned off while the port is in use\n"
263 "@pxref{Ports and File Descriptors, fcntl}\n"
265 "The following additional characters can be appended:\n"
268 "Open the underlying file in binary mode, if supported by the operating system. "
270 "Open the port for both input and output. E.g., @code{r+}: open\n"
271 "an existing file for both input and output.\n"
273 "Create an \"unbuffered\" port. In this case input and output\n"
274 "operations are passed directly to the underlying port\n"
275 "implementation without additional buffering. This is likely to\n"
276 "slow down I/O operations. The buffering mode can be changed\n"
277 "while a port is in use @pxref{Ports and File Descriptors,\n"
280 "Add line-buffering to the port. The port output buffer will be\n"
281 "automatically flushed whenever a newline character is written.\n"
283 "In theory we could create read/write ports which were buffered\n"
284 "in one direction only. However this isn't included in the\n"
285 "current interfaces. If a file cannot be opened with the access\n"
286 "requested, @code{open-file} throws an exception.")
287 #define FUNC_NAME s_scm_open_file
296 scm_dynwind_begin (0);
298 file
= scm_to_locale_string (filename
);
299 scm_dynwind_free (file
);
301 md
= scm_to_locale_string (mode
);
302 scm_dynwind_free (md
);
310 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
313 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
316 scm_out_of_range (FUNC_NAME
, mode
);
324 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
327 #if defined (O_BINARY)
331 case '0': /* unbuffered: handled later. */
332 case 'l': /* line buffered: handled during output. */
335 scm_out_of_range (FUNC_NAME
, mode
);
339 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
344 SCM_SYSERROR_MSG ("~A: ~S",
345 scm_cons (scm_strerror (scm_from_int (en
)),
346 scm_cons (filename
, SCM_EOL
)), en
);
348 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
), filename
);
359 * Try getting the appropiate file flags for a given file descriptor
360 * under Windows. This incorporates some fancy operations because Windows
361 * differentiates between file, pipe and socket descriptors.
364 # define O_ACCMODE 0x0003
367 static int getflags (int fdes
)
371 int error
, optlen
= sizeof (int);
373 /* Is this a socket ? */
374 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
376 /* Maybe a regular file ? */
377 else if (fstat (fdes
, &buf
) < 0)
381 /* Or an anonymous pipe handle ? */
382 if (buf
.st_mode
& _S_IFIFO
)
383 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
384 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
386 else if (fdes
== fileno (stdin
) && isatty (fdes
))
388 /* stdout / stderr ? */
389 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
397 #endif /* __MINGW32__ */
399 /* Building Guile ports from a file descriptor. */
401 /* Build a Scheme port from an open file descriptor `fdes'.
402 MODE indicates whether FILE is open for reading or writing; it uses
403 the same notation as open-file's second argument.
404 NAME is a string to be used as the port's filename.
407 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
408 #define FUNC_NAME "scm_fdes_to_port"
414 /* test that fdes is valid. */
416 flags
= getflags (fdes
);
418 flags
= fcntl (fdes
, F_GETFL
, 0);
424 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
425 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
427 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
430 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
432 port
= scm_new_port_table_entry (scm_tc16_fport
);
433 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
434 pt
= SCM_PTAB_ENTRY(port
);
437 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
440 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
441 SCM_SETSTREAM (port
, fp
);
442 if (mode_bits
& SCM_BUF0
)
443 scm_fport_buffer_add (port
, 0, 0);
445 scm_fport_buffer_add (port
, -1, -1);
447 SCM_SET_FILENAME (port
, name
);
448 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
454 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
456 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
459 /* Return a lower bound on the number of bytes available for input. */
461 fport_input_waiting (SCM port
)
463 int fdes
= SCM_FSTREAM (port
)->fdes
;
466 struct timeval timeout
;
467 SELECT_TYPE read_set
;
468 SELECT_TYPE write_set
;
469 SELECT_TYPE except_set
;
472 FD_ZERO (&write_set
);
473 FD_ZERO (&except_set
);
475 FD_SET (fdes
, &read_set
);
480 if (select (SELECT_SET_SIZE
,
481 &read_set
, &write_set
, &except_set
, &timeout
)
483 scm_syserror ("fport_input_waiting");
484 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
485 #elif defined (FIONREAD)
487 ioctl(fdes
, FIONREAD
, &remir
);
490 scm_misc_error ("fport_input_waiting",
491 "Not fully implemented on this platform",
498 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
500 scm_puts ("#<", port
);
501 scm_print_port_mode (exp
, port
);
502 if (SCM_OPFPORTP (exp
))
505 SCM name
= SCM_FILENAME (exp
);
506 if (scm_is_string (name
) || scm_is_symbol (name
))
507 scm_display (name
, port
);
509 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
510 scm_putc (' ', port
);
511 fdes
= (SCM_FSTREAM (exp
))->fdes
;
515 scm_display (scm_ttyname (exp
), port
);
517 #endif /* HAVE_TTYNAME */
518 scm_intprint (fdes
, 10, port
);
522 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
523 scm_putc (' ', port
);
524 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
526 scm_putc ('>', port
);
531 /* thread-local block for input on fport's fdes. */
533 fport_wait_for_input (SCM port
)
535 int fdes
= SCM_FSTREAM (port
)->fdes
;
537 if (!fport_input_waiting (port
))
541 int flags
= fcntl (fdes
, F_GETFL
);
544 scm_syserror ("scm_fdes_wait_for_input");
545 if (!(flags
& O_NONBLOCK
))
549 FD_SET (fdes
, &readfds
);
550 n
= scm_std_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
552 while (n
== -1 && errno
== EINTR
);
555 #endif /* !__MINGW32__ */
557 static void fport_flush (SCM port
);
559 /* fill a port's read-buffer with a single read. returns the first
560 char or EOF if end of file. */
562 fport_fill_input (SCM port
)
565 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
566 scm_t_fport
*fp
= SCM_FSTREAM (port
);
569 fport_wait_for_input (port
);
570 #endif /* !__MINGW32__ */
571 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
573 scm_syserror ("fport_fill_input");
578 pt
->read_pos
= pt
->read_buf
;
579 pt
->read_end
= pt
->read_buf
+ count
;
580 return *pt
->read_buf
;
585 fport_seek (SCM port
, off_t offset
, int whence
)
587 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
588 scm_t_fport
*fp
= SCM_FSTREAM (port
);
592 if (pt
->rw_active
== SCM_PORT_WRITE
)
594 if (offset
!= 0 || whence
!= SEEK_CUR
)
597 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
601 /* read current position without disturbing the buffer. */
602 rv
= lseek (fp
->fdes
, offset
, whence
);
603 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
606 else if (pt
->rw_active
== SCM_PORT_READ
)
608 if (offset
!= 0 || whence
!= SEEK_CUR
)
610 /* could expand to avoid a second seek. */
611 scm_end_input (port
);
612 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
616 /* read current position without disturbing the buffer
617 (particularly the unread-char buffer). */
618 rv
= lseek (fp
->fdes
, offset
, whence
);
619 result
= rv
- (pt
->read_end
- pt
->read_pos
);
621 if (pt
->read_buf
== pt
->putback_buf
)
622 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
625 else /* SCM_PORT_NEITHER */
627 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
631 scm_syserror ("fport_seek");
637 fport_truncate (SCM port
, off_t length
)
639 scm_t_fport
*fp
= SCM_FSTREAM (port
);
641 if (ftruncate (fp
->fdes
, length
) == -1)
642 scm_syserror ("ftruncate");
645 /* helper for fport_write: try to write data, using multiple system
646 calls if required. */
647 #define FUNC_NAME "write_all"
648 static void write_all (SCM port
, const void *data
, size_t remaining
)
650 int fdes
= SCM_FSTREAM (port
)->fdes
;
652 while (remaining
> 0)
656 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
661 data
= ((const char *) data
) + done
;
667 fport_write (SCM port
, const void *data
, size_t size
)
669 /* this procedure tries to minimize the number of writes/flushes. */
670 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
672 if (pt
->write_buf
== &pt
->shortbuf
673 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
675 /* "unbuffered" port, or
676 port with empty buffer and data won't fit in buffer. */
677 write_all (port
, data
, size
);
682 off_t space
= pt
->write_end
- pt
->write_pos
;
686 /* data fits in buffer. */
687 memcpy (pt
->write_pos
, data
, size
);
688 pt
->write_pos
+= size
;
689 if (pt
->write_pos
== pt
->write_end
)
692 /* we can skip the line-buffering check if nothing's buffered. */
698 memcpy (pt
->write_pos
, data
, space
);
699 pt
->write_pos
= pt
->write_end
;
702 const void *ptr
= ((const char *) data
) + space
;
703 size_t remaining
= size
- space
;
705 if (size
>= pt
->write_buf_size
)
707 write_all (port
, ptr
, remaining
);
712 memcpy (pt
->write_pos
, ptr
, remaining
);
713 pt
->write_pos
+= remaining
;
718 /* handle line buffering. */
719 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
724 /* becomes 1 when process is exiting: normal exception handling won't
725 work by this time. */
726 extern int scm_i_terminating
;
729 fport_flush (SCM port
)
731 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
732 scm_t_fport
*fp
= SCM_FSTREAM (port
);
733 unsigned char *ptr
= pt
->write_buf
;
734 long init_size
= pt
->write_pos
- pt
->write_buf
;
735 long remaining
= init_size
;
737 while (remaining
> 0)
741 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
744 /* error. assume nothing was written this call, but
745 fix up the buffer for any previous successful writes. */
746 long done
= init_size
- remaining
;
752 for (i
= 0; i
< remaining
; i
++)
754 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
756 pt
->write_pos
= pt
->write_buf
+ remaining
;
758 if (scm_i_terminating
)
760 const char *msg
= "Error: could not flush file-descriptor ";
763 write (2, msg
, strlen (msg
));
764 sprintf (buf
, "%d\n", fp
->fdes
);
765 write (2, buf
, strlen (buf
));
769 else if (scm_gc_running_p
)
771 /* silently ignore the error. scm_error would abort if we
776 scm_syserror ("fport_flush");
781 pt
->write_pos
= pt
->write_buf
;
782 pt
->rw_active
= SCM_PORT_NEITHER
;
785 /* clear the read buffer and adjust the file position for unread bytes. */
787 fport_end_input (SCM port
, int offset
)
789 scm_t_fport
*fp
= SCM_FSTREAM (port
);
790 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
792 offset
+= pt
->read_end
- pt
->read_pos
;
796 pt
->read_pos
= pt
->read_end
;
797 /* will throw error if unread-char used at beginning of file
798 then attempting to write. seems correct. */
799 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
800 scm_syserror ("fport_end_input");
802 pt
->rw_active
= SCM_PORT_NEITHER
;
806 fport_close (SCM port
)
808 scm_t_fport
*fp
= SCM_FSTREAM (port
);
809 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
813 SCM_SYSCALL (rv
= close (fp
->fdes
));
814 if (rv
== -1 && errno
!= EBADF
)
816 if (scm_gc_running_p
)
817 /* silently ignore the error. scm_error would abort if we
821 scm_syserror ("fport_close");
823 if (pt
->read_buf
== pt
->putback_buf
)
824 pt
->read_buf
= pt
->saved_read_buf
;
825 if (pt
->read_buf
!= &pt
->shortbuf
)
826 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
827 if (pt
->write_buf
!= &pt
->shortbuf
)
828 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
829 scm_gc_free (fp
, sizeof (*fp
), "file port");
834 fport_free (SCM port
)
843 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
845 scm_set_port_free (tc
, fport_free
);
846 scm_set_port_print (tc
, fport_print
);
847 scm_set_port_flush (tc
, fport_flush
);
848 scm_set_port_end_input (tc
, fport_end_input
);
849 scm_set_port_close (tc
, fport_close
);
850 scm_set_port_seek (tc
, fport_seek
);
851 scm_set_port_truncate (tc
, fport_truncate
);
852 scm_set_port_input_waiting (tc
, fport_input_waiting
);
860 scm_tc16_fport
= scm_make_fptob ();
862 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
863 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
864 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
866 #include "libguile/fports.x"