1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
49 #include "libguile/_scm.h"
50 #include "libguile/strings.h"
51 #include "libguile/validate.h"
52 #include "libguile/gc.h"
54 #include "libguile/fports.h"
64 #ifdef HAVE_ST_BLKSIZE
70 #include "libguile/iselect.h"
73 scm_bits_t scm_tc16_fport
;
76 /* default buffer size, used if the O/S won't supply a value. */
77 static const int default_buffer_size
= 1024;
79 /* create FPORT buffer with specified sizes (or -1 to use default size or
82 scm_fport_buffer_add (SCM port
, int read_size
, int write_size
)
83 #define FUNC_NAME "scm_fport_buffer_add"
85 struct scm_fport
*fp
= SCM_FSTREAM (port
);
86 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
88 if (read_size
== -1 || write_size
== -1)
91 #ifdef HAVE_ST_BLKSIZE
94 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
97 default_size
= default_buffer_size
;
100 read_size
= default_size
;
101 if (write_size
== -1)
102 write_size
= default_size
;
105 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
107 pt
->read_buf
= scm_must_malloc (read_size
, FUNC_NAME
);
108 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
109 pt
->read_buf_size
= read_size
;
113 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
114 pt
->read_buf_size
= 1;
117 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
119 pt
->write_buf
= scm_must_malloc (write_size
, FUNC_NAME
);
120 pt
->write_pos
= pt
->write_buf
;
121 pt
->write_buf_size
= write_size
;
125 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
126 pt
->write_buf_size
= 1;
129 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
130 if (read_size
> 0 || write_size
> 0)
131 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
133 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
137 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
138 (SCM port
, SCM mode
, SCM size
),
139 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
146 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
147 "If @var{size} is omitted, a default size will be used.\n"
149 #define FUNC_NAME s_scm_setvbuf
154 port
= SCM_COERCE_OUTPORT (port
);
156 SCM_VALIDATE_OPFPORT (1,port
);
157 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
158 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
159 scm_out_of_range (FUNC_NAME
, mode
);
163 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
168 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
171 if (SCM_UNBNDP (size
))
180 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
181 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
182 scm_out_of_range (FUNC_NAME
, size
);
185 pt
= SCM_PTAB_ENTRY (port
);
187 /* silently discards buffered chars. */
188 if (pt
->read_buf
!= &pt
->shortbuf
)
189 scm_must_free (pt
->read_buf
);
190 if (pt
->write_buf
!= &pt
->shortbuf
)
191 scm_must_free (pt
->write_buf
);
193 scm_fport_buffer_add (port
, csize
, csize
);
194 return SCM_UNSPECIFIED
;
198 /* Move ports with the specified file descriptor to new descriptors,
199 * reseting the revealed count to 0.
203 scm_evict_ports (int fd
)
207 for (i
= 0; i
< scm_port_table_size
; i
++)
209 SCM port
= scm_port_table
[i
]->port
;
211 if (SCM_FPORTP (port
))
213 struct scm_fport
*fp
= SCM_FSTREAM (port
);
219 scm_syserror ("scm_evict_ports");
220 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
227 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
229 "Determine whether @var{obj} is a port that is related to a file.")
230 #define FUNC_NAME s_scm_file_port_p
232 return SCM_BOOL (SCM_FPORTP (obj
));
238 * Return a new port open on a given file.
240 * The mode string must match the pattern: [rwa+]** which
241 * is interpreted in the usual unix way.
243 * Return the new port.
245 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
246 (SCM filename
, SCM mode
),
247 "Open the file whose name is @var{filename}, and return a port\n"
248 "representing that file. The attributes of the port are\n"
249 "determined by the @var{mode} string. The way in which this is\n"
250 "interpreted is similar to C stdio. The first character must be\n"
251 "one of the following:\n"
254 "Open an existing file for input.\n"
256 "Open a file for output, creating it if it doesn't already exist\n"
257 "or removing its contents if it does.\n"
259 "Open a file for output, creating it if it doesn't already\n"
260 "exist. All writes to the port will go to the end of the file.\n"
261 "The \"append mode\" can be turned off while the port is in use\n"
262 "@pxref{Ports and File Descriptors, fcntl}\n"
264 "The following additional characters can be appended:\n"
267 "Open the port for both input and output. E.g., @code{r+}: open\n"
268 "an existing file for both input and output.\n"
270 "Create an \"unbuffered\" port. In this case input and output\n"
271 "operations are passed directly to the underlying port\n"
272 "implementation without additional buffering. This is likely to\n"
273 "slow down I/O operations. The buffering mode can be changed\n"
274 "while a port is in use @pxref{Ports and File Descriptors,\n"
277 "Add line-buffering to the port. The port output buffer will be\n"
278 "automatically flushed whenever a newline character is written.\n"
280 "In theory we could create read/write ports which were buffered\n"
281 "in one direction only. However this isn't included in the\n"
282 "current interfaces. If a file cannot be opened with the access\n"
283 "requested, @code{open-file} throws an exception.")
284 #define FUNC_NAME s_scm_open_file
293 SCM_VALIDATE_STRING (1, filename
);
294 SCM_VALIDATE_STRING (2, mode
);
295 SCM_STRING_COERCE_0TERMINATION_X (filename
);
296 SCM_STRING_COERCE_0TERMINATION_X (mode
);
298 file
= SCM_STRING_CHARS (filename
);
299 md
= SCM_STRING_CHARS (mode
);
307 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
310 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
313 scm_out_of_range (FUNC_NAME
, mode
);
321 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
324 #if defined (O_BINARY)
328 case '0': /* unbuffered: handled later. */
329 case 'l': /* line buffered: handled during output. */
332 scm_out_of_range (FUNC_NAME
, mode
);
336 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
341 SCM_SYSERROR_MSG ("~A: ~S",
342 scm_cons (scm_makfrom0str (strerror (en
)),
343 scm_cons (filename
, SCM_EOL
)), en
);
345 port
= scm_fdes_to_port (fdes
, md
, filename
);
351 /* Building Guile ports from a file descriptor. */
353 /* Build a Scheme port from an open file descriptor `fdes'.
354 MODE indicates whether FILE is open for reading or writing; it uses
355 the same notation as open-file's second argument.
356 NAME is a string to be used as the port's filename.
359 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
360 #define FUNC_NAME "scm_fdes_to_port"
362 long mode_bits
= scm_mode_bits (mode
);
367 /* test that fdes is valid. */
368 flags
= fcntl (fdes
, F_GETFL
, 0);
373 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
374 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
376 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
381 pt
= scm_add_to_port_table (port
);
382 SCM_SETPTAB_ENTRY (port
, pt
);
383 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
387 = (struct scm_fport
*) scm_must_malloc (sizeof (struct scm_fport
),
391 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
392 SCM_SETSTREAM (port
, fp
);
393 if (mode_bits
& SCM_BUF0
)
394 scm_fport_buffer_add (port
, 0, 0);
396 scm_fport_buffer_add (port
, -1, -1);
398 SCM_SET_FILENAME (port
, name
);
404 /* Return a lower bound on the number of bytes available for input. */
406 fport_input_waiting (SCM port
)
408 int fdes
= SCM_FSTREAM (port
)->fdes
;
411 struct timeval timeout
;
412 SELECT_TYPE read_set
;
413 SELECT_TYPE write_set
;
414 SELECT_TYPE except_set
;
417 FD_ZERO (&write_set
);
418 FD_ZERO (&except_set
);
420 FD_SET (fdes
, &read_set
);
425 if (select (SELECT_SET_SIZE
,
426 &read_set
, &write_set
, &except_set
, &timeout
)
428 scm_syserror ("fport_input_waiting");
429 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
430 #elif defined (FIONREAD)
432 ioctl(fdes
, FIONREAD
, &remir
);
435 scm_misc_error ("fport_input_waiting",
436 "Not fully implemented on this platform",
443 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
445 scm_puts ("#<", port
);
446 scm_print_port_mode (exp
, port
);
447 if (SCM_OPFPORTP (exp
))
450 SCM name
= SCM_FILENAME (exp
);
451 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
452 scm_display (name
, port
);
454 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
455 scm_putc (' ', port
);
456 fdes
= (SCM_FSTREAM (exp
))->fdes
;
459 scm_puts (ttyname (fdes
), port
);
461 scm_intprint (fdes
, 10, port
);
465 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
466 scm_putc (' ', port
);
467 scm_intprint (SCM_UNPACK (SCM_CDR (exp
)), 16, port
);
469 scm_putc ('>', port
);
474 /* thread-local block for input on fport's fdes. */
476 fport_wait_for_input (SCM port
)
478 int fdes
= SCM_FSTREAM (port
)->fdes
;
480 if (!fport_input_waiting (port
))
484 int flags
= fcntl (fdes
, F_GETFL
);
487 scm_syserror ("scm_fdes_wait_for_input");
488 if (!(flags
& O_NONBLOCK
))
492 FD_SET (fdes
, &readfds
);
493 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
495 while (n
== -1 && errno
== EINTR
);
500 static void fport_flush (SCM port
);
502 /* fill a port's read-buffer with a single read. returns the first
503 char or EOF if end of file. */
505 fport_fill_input (SCM port
)
508 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
509 struct scm_fport
*fp
= SCM_FSTREAM (port
);
512 fport_wait_for_input (port
);
514 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
516 scm_syserror ("fport_fill_input");
521 pt
->read_pos
= pt
->read_buf
;
522 pt
->read_end
= pt
->read_buf
+ count
;
523 return *pt
->read_buf
;
528 fport_seek (SCM port
, off_t offset
, int whence
)
530 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
531 struct scm_fport
*fp
= SCM_FSTREAM (port
);
535 if (pt
->rw_active
== SCM_PORT_WRITE
)
537 if (offset
!= 0 || whence
!= SEEK_CUR
)
540 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
544 /* read current position without disturbing the buffer. */
545 rv
= lseek (fp
->fdes
, offset
, whence
);
546 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
549 else if (pt
->rw_active
== SCM_PORT_READ
)
551 if (offset
!= 0 || whence
!= SEEK_CUR
)
553 /* could expand to avoid a second seek. */
554 scm_end_input (port
);
555 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
559 /* read current position without disturbing the buffer
560 (particularly the unread-char buffer). */
561 rv
= lseek (fp
->fdes
, offset
, whence
);
562 result
= rv
- (pt
->read_end
- pt
->read_pos
);
564 if (pt
->read_buf
== pt
->putback_buf
)
565 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
568 else /* SCM_PORT_NEITHER */
570 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
574 scm_syserror ("fport_seek");
580 fport_truncate (SCM port
, off_t length
)
582 struct scm_fport
*fp
= SCM_FSTREAM (port
);
584 if (ftruncate (fp
->fdes
, length
) == -1)
585 scm_syserror ("ftruncate");
588 /* helper for fport_write: try to write data, using multiple system
589 calls if required. */
590 #define FUNC_NAME "write_all"
591 static void write_all (SCM port
, const void *data
, size_t remaining
)
593 int fdes
= SCM_FSTREAM (port
)->fdes
;
595 while (remaining
> 0)
599 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
604 data
= ((const char *) data
) + done
;
610 fport_write (SCM port
, const void *data
, size_t size
)
612 /* this procedure tries to minimize the number of writes/flushes. */
613 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
615 if (pt
->write_buf
== &pt
->shortbuf
616 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
618 /* "unbuffered" port, or
619 port with empty buffer and data won't fit in buffer. */
620 write_all (port
, data
, size
);
625 off_t space
= pt
->write_end
- pt
->write_pos
;
629 /* data fits in buffer. */
630 memcpy (pt
->write_pos
, data
, size
);
631 pt
->write_pos
+= size
;
632 if (pt
->write_pos
== pt
->write_end
)
635 /* we can skip the line-buffering check if nothing's buffered. */
641 memcpy (pt
->write_pos
, data
, space
);
642 pt
->write_pos
= pt
->write_end
;
645 const void *ptr
= ((const char *) data
) + space
;
646 size_t remaining
= size
- space
;
648 if (size
>= pt
->write_buf_size
)
650 write_all (port
, ptr
, remaining
);
655 memcpy (pt
->write_pos
, ptr
, remaining
);
656 pt
->write_pos
+= remaining
;
661 /* handle line buffering. */
662 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
667 /* becomes 1 when process is exiting: normal exception handling won't
668 work by this time. */
669 extern int terminating
;
672 fport_flush (SCM port
)
674 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
675 struct scm_fport
*fp
= SCM_FSTREAM (port
);
676 unsigned char *ptr
= pt
->write_buf
;
677 int init_size
= pt
->write_pos
- pt
->write_buf
;
678 int remaining
= init_size
;
680 while (remaining
> 0)
684 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
687 /* error. assume nothing was written this call, but
688 fix up the buffer for any previous successful writes. */
689 int done
= init_size
- remaining
;
695 for (i
= 0; i
< remaining
; i
++)
697 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
699 pt
->write_pos
= pt
->write_buf
+ remaining
;
703 const char *msg
= "Error: could not flush file-descriptor ";
706 write (2, msg
, strlen (msg
));
707 sprintf (buf
, "%d\n", fp
->fdes
);
708 write (2, buf
, strlen (buf
));
712 else if (scm_gc_running_p
)
714 /* silently ignore the error. scm_error would abort if we
719 scm_syserror ("fport_flush");
724 pt
->write_pos
= pt
->write_buf
;
725 pt
->rw_active
= SCM_PORT_NEITHER
;
728 /* clear the read buffer and adjust the file position for unread bytes. */
730 fport_end_input (SCM port
, int offset
)
732 struct scm_fport
*fp
= SCM_FSTREAM (port
);
733 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
735 offset
+= pt
->read_end
- pt
->read_pos
;
739 pt
->read_pos
= pt
->read_end
;
740 /* will throw error if unread-char used at beginning of file
741 then attempting to write. seems correct. */
742 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
743 scm_syserror ("fport_end_input");
745 pt
->rw_active
= SCM_PORT_NEITHER
;
749 fport_close (SCM port
)
751 struct scm_fport
*fp
= SCM_FSTREAM (port
);
752 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
756 SCM_SYSCALL (rv
= close (fp
->fdes
));
757 if (rv
== -1 && errno
!= EBADF
)
759 if (scm_gc_running_p
)
760 /* silently ignore the error. scm_error would abort if we
764 scm_syserror ("fport_close");
766 if (pt
->read_buf
== pt
->putback_buf
)
767 pt
->read_buf
= pt
->saved_read_buf
;
768 if (pt
->read_buf
!= &pt
->shortbuf
)
769 scm_must_free (pt
->read_buf
);
770 if (pt
->write_buf
!= &pt
->shortbuf
)
771 scm_must_free (pt
->write_buf
);
772 scm_must_free ((char *) fp
);
777 fport_free (SCM port
)
786 scm_bits_t tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
788 scm_set_port_free (tc
, fport_free
);
789 scm_set_port_print (tc
, fport_print
);
790 scm_set_port_flush (tc
, fport_flush
);
791 scm_set_port_end_input (tc
, fport_end_input
);
792 scm_set_port_close (tc
, fport_close
);
793 scm_set_port_seek (tc
, fport_seek
);
794 scm_set_port_truncate (tc
, fport_truncate
);
795 scm_set_port_input_waiting (tc
, fport_input_waiting
);
803 scm_tc16_fport
= scm_make_fptob ();
805 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
806 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
807 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
809 #ifndef SCM_MAGIC_SNARFER
810 #include "libguile/fports.x"