1 /* Copyright (C) 1995,1996,1997,1998,1999, 2000 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
)
84 struct scm_fport
*fp
= SCM_FSTREAM (port
);
85 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
86 char *s_scm_fport_buffer_add
= "scm_fport_buffer_add";
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
= malloc (read_size
);
108 if (pt
->read_buf
== NULL
)
109 scm_memory_error (s_scm_fport_buffer_add
);
110 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
111 pt
->read_buf_size
= read_size
;
115 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
116 pt
->read_buf_size
= 1;
119 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
121 pt
->write_buf
= malloc (write_size
);
122 if (pt
->write_buf
== NULL
)
123 scm_memory_error (s_scm_fport_buffer_add
);
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
);
140 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
141 (SCM port
, SCM mode
, SCM size
),
142 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
149 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
150 "If @var{size} is omitted, a default size will be used.\n"
152 #define FUNC_NAME s_scm_setvbuf
157 port
= SCM_COERCE_OUTPORT (port
);
159 SCM_VALIDATE_OPFPORT (1,port
);
160 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
161 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
162 scm_out_of_range (FUNC_NAME
, mode
);
166 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
171 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
174 if (SCM_UNBNDP (size
))
183 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
184 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
185 scm_out_of_range (FUNC_NAME
, size
);
188 pt
= SCM_PTAB_ENTRY (port
);
190 /* silently discards buffered chars. */
191 if (pt
->read_buf
!= &pt
->shortbuf
)
193 if (pt
->write_buf
!= &pt
->shortbuf
)
194 free (pt
->write_buf
);
196 scm_fport_buffer_add (port
, csize
, csize
);
197 return SCM_UNSPECIFIED
;
201 /* Move ports with the specified file descriptor to new descriptors,
202 * reseting the revealed count to 0.
206 scm_evict_ports (int fd
)
210 for (i
= 0; i
< scm_port_table_size
; i
++)
212 SCM port
= scm_port_table
[i
]->port
;
214 if (SCM_FPORTP (port
))
216 struct scm_fport
*fp
= SCM_FSTREAM (port
);
222 scm_syserror ("scm_evict_ports");
223 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
230 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
232 "Determine whether OBJ is a port that is related to a file.")
233 #define FUNC_NAME s_scm_file_port_p
235 return SCM_BOOL (SCM_FPORTP (obj
));
241 * Return a new port open on a given file.
243 * The mode string must match the pattern: [rwa+]** which
244 * is interpreted in the usual unix way.
246 * Return the new port.
248 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
249 (SCM filename
, SCM modes
),
250 "Open the file whose name is @var{string}, and return a port\n"
251 "representing that file. The attributes of the port are\n"
252 "determined by the @var{mode} string. The way in \n"
253 "which this is interpreted is similar to C stdio:\n\n"
254 "The first character must be one of the following:\n\n"
257 "Open an existing file for input.\n"
259 "Open a file for output, creating it if it doesn't already exist\n"
260 "or removing its contents if it does.\n"
262 "Open a file for output, creating it if it doesn't already exist.\n"
263 "All writes to the port will go to the end of the file.\n"
264 "The \"append mode\" can be turned off while the port is in use\n"
265 "@pxref{Ports and File Descriptors, fcntl}\n"
267 "The following additional characters can be appended:\n\n"
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 operations\n"
274 "are passed directly to the underlying port implementation without\n"
275 "additional buffering. This is likely to slow down I/O operations.\n"
276 "The buffering mode can be changed while a port is in use\n"
277 "@pxref{Ports and File Descriptors, setvbuf}\n"
279 "Add line-buffering to the port. The port output buffer will be\n"
280 "automatically flushed whenever a newline character is written.\n"
282 "In theory we could create read/write ports which were buffered in one\n"
283 "direction only. However this isn't included in the current interfaces.\n\n"
284 "If a file cannot be opened with the access requested,\n"
285 "@code{open-file} throws an exception.")
286 #define FUNC_NAME s_scm_open_file
295 SCM_VALIDATE_STRING (1, filename
);
296 SCM_VALIDATE_STRING (2, modes
);
297 SCM_STRING_COERCE_0TERMINATION_X (filename
);
298 SCM_STRING_COERCE_0TERMINATION_X (modes
);
300 file
= SCM_STRING_CHARS (filename
);
301 mode
= SCM_STRING_CHARS (modes
);
309 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
312 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
315 scm_out_of_range (FUNC_NAME
, modes
);
323 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
326 #if defined (O_BINARY)
330 case '0': /* unbuffered: handled later. */
331 case 'l': /* line buffered: handled during output. */
334 scm_out_of_range (FUNC_NAME
, modes
);
338 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
343 SCM_SYSERROR_MSG ("~A: ~S",
344 scm_cons (scm_makfrom0str (strerror (en
)),
345 scm_cons (filename
, SCM_EOL
)), en
);
347 port
= scm_fdes_to_port (fdes
, mode
, filename
);
353 /* Building Guile ports from a file descriptor. */
355 /* Build a Scheme port from an open file descriptor `fdes'.
356 MODE indicates whether FILE is open for reading or writing; it uses
357 the same notation as open-file's second argument.
358 NAME is a string to be used as the port's filename.
361 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
362 #define FUNC_NAME "scm_fdes_to_port"
364 long mode_bits
= scm_mode_bits (mode
);
369 /* test that fdes is valid. */
370 flags
= fcntl (fdes
, F_GETFL
, 0);
375 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
376 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
378 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
383 pt
= scm_add_to_port_table (port
);
384 SCM_SETPTAB_ENTRY (port
, pt
);
385 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
389 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
393 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
394 SCM_SETSTREAM (port
, fp
);
395 if (mode_bits
& SCM_BUF0
)
396 scm_fport_buffer_add (port
, 0, 0);
398 scm_fport_buffer_add (port
, -1, -1);
400 SCM_SET_FILENAME (port
, name
);
406 /* Return a lower bound on the number of bytes available for input. */
408 fport_input_waiting (SCM port
)
410 int fdes
= SCM_FSTREAM (port
)->fdes
;
413 struct timeval timeout
;
414 SELECT_TYPE read_set
;
415 SELECT_TYPE write_set
;
416 SELECT_TYPE except_set
;
419 FD_ZERO (&write_set
);
420 FD_ZERO (&except_set
);
422 FD_SET (fdes
, &read_set
);
427 if (select (SELECT_SET_SIZE
,
428 &read_set
, &write_set
, &except_set
, &timeout
)
430 scm_syserror ("fport_input_waiting");
431 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
432 #elif defined (FIONREAD)
434 ioctl(fdes
, FIONREAD
, &remir
);
437 scm_misc_error ("fport_input_waiting",
438 "Not fully implemented on this platform",
445 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
447 scm_puts ("#<", port
);
448 scm_print_port_mode (exp
, port
);
449 if (SCM_OPFPORTP (exp
))
452 SCM name
= SCM_FILENAME (exp
);
453 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
454 scm_display (name
, port
);
456 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
457 scm_putc (' ', port
);
458 fdes
= (SCM_FSTREAM (exp
))->fdes
;
461 scm_puts (ttyname (fdes
), port
);
463 scm_intprint (fdes
, 10, port
);
467 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
468 scm_putc (' ', port
);
469 scm_intprint (SCM_UNPACK (SCM_CDR (exp
)), 16, port
);
471 scm_putc ('>', port
);
476 /* thread-local block for input on fport's fdes. */
478 fport_wait_for_input (SCM port
)
480 int fdes
= SCM_FSTREAM (port
)->fdes
;
482 if (!fport_input_waiting (port
))
486 int flags
= fcntl (fdes
, F_GETFL
);
489 scm_syserror ("scm_fdes_wait_for_input");
490 if (!(flags
& O_NONBLOCK
))
494 FD_SET (fdes
, &readfds
);
495 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
497 while (n
== -1 && errno
== EINTR
);
502 static void fport_flush (SCM port
);
504 /* fill a port's read-buffer with a single read. returns the first
505 char or EOF if end of file. */
507 fport_fill_input (SCM port
)
510 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
511 struct scm_fport
*fp
= SCM_FSTREAM (port
);
514 fport_wait_for_input (port
);
516 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
518 scm_syserror ("fport_fill_input");
523 pt
->read_pos
= pt
->read_buf
;
524 pt
->read_end
= pt
->read_buf
+ count
;
525 return *pt
->read_buf
;
530 fport_seek (SCM port
, off_t offset
, int whence
)
532 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
533 struct scm_fport
*fp
= SCM_FSTREAM (port
);
537 if (pt
->rw_active
== SCM_PORT_WRITE
)
539 if (offset
!= 0 || whence
!= SEEK_CUR
)
542 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
546 /* read current position without disturbing the buffer. */
547 rv
= lseek (fp
->fdes
, offset
, whence
);
548 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
551 else if (pt
->rw_active
== SCM_PORT_READ
)
553 if (offset
!= 0 || whence
!= SEEK_CUR
)
555 /* could expand to avoid a second seek. */
556 scm_end_input (port
);
557 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
561 /* read current position without disturbing the buffer
562 (particularly the unread-char buffer). */
563 rv
= lseek (fp
->fdes
, offset
, whence
);
564 result
= rv
- (pt
->read_end
- pt
->read_pos
);
566 if (pt
->read_buf
== pt
->putback_buf
)
567 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
570 else /* SCM_PORT_NEITHER */
572 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
576 scm_syserror ("fport_seek");
582 fport_truncate (SCM port
, off_t length
)
584 struct scm_fport
*fp
= SCM_FSTREAM (port
);
586 if (ftruncate (fp
->fdes
, length
) == -1)
587 scm_syserror ("ftruncate");
590 /* helper for fport_write: try to write data, using multiple system
591 calls if required. */
592 #define FUNC_NAME "write_all"
593 static void write_all (SCM port
, const void *data
, size_t remaining
)
595 int fdes
= SCM_FSTREAM (port
)->fdes
;
597 while (remaining
> 0)
601 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
606 data
= ((const char *) data
) + done
;
612 fport_write (SCM port
, const void *data
, size_t size
)
614 /* this procedure tries to minimize the number of writes/flushes. */
615 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
617 if (pt
->write_buf
== &pt
->shortbuf
618 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
620 /* "unbuffered" port, or
621 port with empty buffer and data won't fit in buffer. */
622 write_all (port
, data
, size
);
627 off_t space
= pt
->write_end
- pt
->write_pos
;
631 /* data fits in buffer. */
632 memcpy (pt
->write_pos
, data
, size
);
633 pt
->write_pos
+= size
;
634 if (pt
->write_pos
== pt
->write_end
)
637 /* we can skip the line-buffering check if nothing's buffered. */
643 memcpy (pt
->write_pos
, data
, space
);
644 pt
->write_pos
= pt
->write_end
;
647 const void *ptr
= ((const char *) data
) + space
;
648 size_t remaining
= size
- space
;
650 if (size
>= pt
->write_buf_size
)
652 write_all (port
, ptr
, remaining
);
657 memcpy (pt
->write_pos
, ptr
, remaining
);
658 pt
->write_pos
+= remaining
;
663 /* handle line buffering. */
664 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
669 /* becomes 1 when process is exiting: normal exception handling won't
670 work by this time. */
671 extern int terminating
;
674 fport_flush (SCM port
)
676 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
677 struct scm_fport
*fp
= SCM_FSTREAM (port
);
678 unsigned char *ptr
= pt
->write_buf
;
679 int init_size
= pt
->write_pos
- pt
->write_buf
;
680 int remaining
= init_size
;
682 while (remaining
> 0)
686 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
689 /* error. assume nothing was written this call, but
690 fix up the buffer for any previous successful writes. */
691 int done
= init_size
- remaining
;
697 for (i
= 0; i
< remaining
; i
++)
699 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
701 pt
->write_pos
= pt
->write_buf
+ remaining
;
705 const char *msg
= "Error: could not flush file-descriptor ";
708 write (2, msg
, strlen (msg
));
709 sprintf (buf
, "%d\n", fp
->fdes
);
710 write (2, buf
, strlen (buf
));
714 else if (scm_gc_running_p
)
716 /* silently ignore the error. scm_error would abort if we
721 scm_syserror ("fport_flush");
726 pt
->write_pos
= pt
->write_buf
;
727 pt
->rw_active
= SCM_PORT_NEITHER
;
730 /* clear the read buffer and adjust the file position for unread bytes. */
732 fport_end_input (SCM port
, int offset
)
734 struct scm_fport
*fp
= SCM_FSTREAM (port
);
735 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
737 offset
+= pt
->read_end
- pt
->read_pos
;
741 pt
->read_pos
= pt
->read_end
;
742 /* will throw error if unread-char used at beginning of file
743 then attempting to write. seems correct. */
744 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
745 scm_syserror ("fport_end_input");
747 pt
->rw_active
= SCM_PORT_NEITHER
;
751 fport_close (SCM port
)
753 struct scm_fport
*fp
= SCM_FSTREAM (port
);
754 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
758 SCM_SYSCALL (rv
= close (fp
->fdes
));
759 if (rv
== -1 && errno
!= EBADF
)
761 if (scm_gc_running_p
)
762 /* silently ignore the error. scm_error would abort if we
766 scm_syserror ("fport_close");
768 if (pt
->read_buf
== pt
->putback_buf
)
769 pt
->read_buf
= pt
->saved_read_buf
;
770 if (pt
->read_buf
!= &pt
->shortbuf
)
772 if (pt
->write_buf
!= &pt
->shortbuf
)
773 free (pt
->write_buf
);
779 fport_free (SCM port
)
788 scm_bits_t tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
790 scm_set_port_free (tc
, fport_free
);
791 scm_set_port_print (tc
, fport_print
);
792 scm_set_port_flush (tc
, fport_flush
);
793 scm_set_port_end_input (tc
, fport_end_input
);
794 scm_set_port_close (tc
, fport_close
);
795 scm_set_port_seek (tc
, fport_seek
);
796 scm_set_port_truncate (tc
, fport_truncate
);
797 scm_set_port_input_waiting (tc
, fport_input_waiting
);
805 scm_tc16_fport
= scm_make_fptob ();
807 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
808 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
809 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));
811 #ifndef SCM_MAGIC_SNARFER
812 #include "libguile/fports.x"