1 /* Copyright (C) 1995,1996,1997,1998,1999 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 */
63 #ifdef HAVE_ST_BLKSIZE
71 /* default buffer size, used if the O/S won't supply a value. */
72 static const int default_buffer_size
= 1024;
74 /* create FPORT buffer with specified sizes (or -1 to use default size or
77 scm_fport_buffer_add (SCM port
, int read_size
, int write_size
)
79 struct scm_fport
*fp
= SCM_FSTREAM (port
);
80 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
81 char *s_scm_fport_buffer_add
= "scm_fport_buffer_add";
83 if (read_size
== -1 || write_size
== -1)
86 #ifdef HAVE_ST_BLKSIZE
89 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
92 default_size
= default_buffer_size
;
95 read_size
= default_size
;
97 write_size
= default_size
;
100 if (SCM_INPORTP (port
) && read_size
> 0)
102 pt
->read_buf
= malloc (read_size
);
103 if (pt
->read_buf
== NULL
)
104 scm_memory_error (s_scm_fport_buffer_add
);
105 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
106 pt
->read_buf_size
= read_size
;
110 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
111 pt
->read_buf_size
= 1;
114 if (SCM_OUTPORTP (port
) && write_size
> 0)
116 pt
->write_buf
= malloc (write_size
);
117 if (pt
->write_buf
== NULL
)
118 scm_memory_error (s_scm_fport_buffer_add
);
119 pt
->write_pos
= pt
->write_buf
;
120 pt
->write_buf_size
= write_size
;
124 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
125 pt
->write_buf_size
= 1;
128 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
129 if (read_size
> 0 || write_size
> 0)
130 SCM_SETCAR (port
, SCM_UNPACK_CAR (port
) & ~SCM_BUF0
);
132 SCM_SETCAR (port
, (SCM_UNPACK_CAR (port
) | SCM_BUF0
));
135 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
136 (SCM port
, SCM mode
, SCM size
),
137 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
144 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
145 "If @var{size} is omitted, a default size will be used.\n"
148 #define FUNC_NAME s_scm_setvbuf
153 port
= SCM_COERCE_OUTPORT (port
);
155 SCM_VALIDATE_OPFPORT (1,port
);
156 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
157 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
158 scm_out_of_range (FUNC_NAME
, mode
);
162 SCM_SETCAR (port
, SCM_UNPACK_CAR (port
) | SCM_BUFLINE
);
167 SCM_SETCAR (port
, SCM_UNPACK_CAR (port
) ^ SCM_BUFLINE
);
170 if (SCM_UNBNDP (size
))
179 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
180 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
181 scm_out_of_range (FUNC_NAME
, size
);
184 pt
= SCM_PTAB_ENTRY (port
);
186 /* silently discards buffered chars. */
187 if (pt
->read_buf
!= &pt
->shortbuf
)
188 scm_must_free (pt
->read_buf
);
189 if (pt
->write_buf
!= &pt
->shortbuf
)
190 scm_must_free (pt
->write_buf
);
192 scm_fport_buffer_add (port
, csize
, csize
);
193 return SCM_UNSPECIFIED
;
197 /* Move ports with the specified file descriptor to new descriptors,
198 * reseting the revealed count to 0.
202 scm_evict_ports (int fd
)
206 for (i
= 0; i
< scm_port_table_size
; i
++)
208 SCM port
= scm_port_table
[i
]->port
;
210 if (SCM_FPORTP (port
))
212 struct scm_fport
*fp
= SCM_FSTREAM (port
);
218 scm_syserror ("scm_evict_ports");
219 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
226 * Return a new port open on a given file.
228 * The mode string must match the pattern: [rwa+]** which
229 * is interpreted in the usual unix way.
231 * Return the new port.
233 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
234 (SCM filename
, SCM modes
),
235 "Open the file whose name is @var{string}, and return a port\n"
236 "representing that file. The attributes of the port are\n"
237 "determined by the @var{mode} string. The way in \n"
238 "which this is interpreted is similar to C stdio:\n\n"
239 "The first character must be one of the following:\n\n"
242 "Open an existing file for input.\n"
244 "Open a file for output, creating it if it doesn't already exist\n"
245 "or removing its contents if it does.\n"
247 "Open a file for output, creating it if it doesn't already exist.\n"
248 "All writes to the port will go to the end of the file.\n"
249 "The \"append mode\" can be turned off while the port is in use\n"
250 "@pxref{Ports and File Descriptors, fcntl}\n"
252 "The following additional characters can be appended:\n\n"
255 "Open the port for both input and output. E.g., @code{r+}: open\n"
256 "an existing file for both input and output.\n"
258 "Create an \"unbuffered\" port. In this case input and output operations\n"
259 "are passed directly to the underlying port implementation without\n"
260 "additional buffering. This is likely to slow down I/O operations.\n"
261 "The buffering mode can be changed while a port is in use\n"
262 "@pxref{Ports and File Descriptors, setvbuf}\n"
264 "Add line-buffering to the port. The port output buffer will be\n"
265 "automatically flushed whenever a newline character is written.\n"
267 "In theory we could create read/write ports which were buffered in one\n"
268 "direction only. However this isn't included in the current interfaces.\n\n"
269 "If a file cannot be opened with the access requested,\n"
270 "@code{open-file} throws an exception.")
271 #define FUNC_NAME s_scm_open_file
280 SCM_VALIDATE_ROSTRING (1,filename
);
281 SCM_VALIDATE_ROSTRING (2,modes
);
282 if (SCM_SUBSTRP (filename
))
283 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
284 if (SCM_SUBSTRP (modes
))
285 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
287 file
= SCM_ROCHARS (filename
);
288 mode
= SCM_ROCHARS (modes
);
296 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
299 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
302 scm_out_of_range (FUNC_NAME
, modes
);
310 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
312 case '0': /* unbuffered: handled later. */
313 case 'b': /* 'binary' mode: ignored. */
314 case 'l': /* line buffered: handled during output. */
317 scm_out_of_range (FUNC_NAME
, modes
);
321 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
326 SCM_SYSERROR_MSG ("~A: ~S",
327 scm_cons (scm_makfrom0str (strerror (en
)),
328 scm_cons (filename
, SCM_EOL
)), en
);
330 port
= scm_fdes_to_port (fdes
, mode
, filename
);
336 /* Building Guile ports from a file descriptor. */
338 /* Build a Scheme port from an open file descriptor `fdes'.
339 MODE indicates whether FILE is open for reading or writing; it uses
340 the same notation as open-file's second argument.
341 NAME is a string to be used as the port's filename.
344 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
345 #define FUNC_NAME "scm_fdes_to_port"
347 long mode_bits
= scm_mode_bits (mode
);
352 /* test that fdes is valid. */
353 flags
= fcntl (fdes
, F_GETFL
, 0);
358 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
359 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
361 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
366 pt
= scm_add_to_port_table (port
);
367 SCM_SETPTAB_ENTRY (port
, pt
);
368 SCM_SETCAR (port
, (scm_tc16_fport
| mode_bits
));
372 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
376 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
377 SCM_SETSTREAM (port
, fp
);
378 if (mode_bits
& SCM_BUF0
)
379 scm_fport_buffer_add (port
, 0, 0);
381 scm_fport_buffer_add (port
, -1, -1);
383 SCM_PTAB_ENTRY (port
)->file_name
= name
;
389 /* Return a lower bound on the number of bytes available for input. */
391 fport_input_waiting (SCM port
)
393 int fdes
= SCM_FSTREAM (port
)->fdes
;
396 struct timeval timeout
;
397 SELECT_TYPE read_set
;
398 SELECT_TYPE write_set
;
399 SELECT_TYPE except_set
;
402 FD_ZERO (&write_set
);
403 FD_ZERO (&except_set
);
405 FD_SET (fdes
, &read_set
);
410 if (select (SELECT_SET_SIZE
,
411 &read_set
, &write_set
, &except_set
, &timeout
)
413 scm_syserror ("fport_input_waiting");
414 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
415 #elif defined (FIONREAD)
417 ioctl(fdes
, FIONREAD
, &remir
);
420 scm_misc_error ("fport_input_waiting",
421 "Not fully implemented on this platform",
428 prinfport (SCM exp
,SCM port
,scm_print_state
*pstate
)
430 scm_puts ("#<", port
);
431 scm_print_port_mode (exp
, port
);
432 if (SCM_OPFPORTP (exp
))
435 SCM name
= SCM_PTAB_ENTRY (exp
)->file_name
;
436 scm_puts (SCM_ROSTRINGP (name
)
438 : SCM_PTOBNAME (SCM_PTOBNUM (exp
)),
440 scm_putc (' ', port
);
441 fdes
= (SCM_FSTREAM (exp
))->fdes
;
444 scm_puts (ttyname (fdes
), port
);
446 scm_intprint (fdes
, 10, port
);
450 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
451 scm_putc (' ', port
);
452 scm_intprint (SCM_UNPACK (SCM_CDR (exp
)), 16, port
);
454 scm_putc ('>', port
);
459 /* thread-local block for input on fport's fdes. */
461 fport_wait_for_input (SCM port
)
463 int fdes
= SCM_FSTREAM (port
)->fdes
;
465 if (!fport_input_waiting (port
))
469 int flags
= fcntl (fdes
, F_GETFL
);
472 scm_syserror ("scm_fdes_wait_for_input");
473 if (!(flags
& O_NONBLOCK
))
477 FD_SET (fdes
, &readfds
);
478 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
480 while (n
== -1 && errno
== EINTR
);
485 static void fport_flush (SCM port
);
487 /* fill a port's read-buffer with a single read.
488 returns the first char and moves the read_pos pointer past it.
489 or returns EOF if end of file. */
491 fport_fill_input (SCM port
)
494 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
495 struct scm_fport
*fp
= SCM_FSTREAM (port
);
498 fport_wait_for_input (port
);
500 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
502 scm_syserror ("fport_fill_input");
507 pt
->read_pos
= pt
->read_buf
;
508 pt
->read_end
= pt
->read_buf
+ count
;
509 return *pt
->read_buf
;
514 fport_seek (SCM port
, off_t offset
, int whence
)
516 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
517 struct scm_fport
*fp
= SCM_FSTREAM (port
);
521 if (pt
->rw_active
== SCM_PORT_WRITE
)
523 if (offset
!= 0 || whence
!= SEEK_CUR
)
526 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
530 /* read current position without disturbing the buffer. */
531 rv
= lseek (fp
->fdes
, offset
, whence
);
532 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
535 else if (pt
->rw_active
== SCM_PORT_READ
)
537 if (offset
!= 0 || whence
!= SEEK_CUR
)
539 /* could expand to avoid a second seek. */
540 scm_end_input (port
);
541 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
545 /* read current position without disturbing the buffer
546 (particularly the unread-char buffer). */
547 rv
= lseek (fp
->fdes
, offset
, whence
);
548 result
= rv
- (pt
->read_end
- pt
->read_pos
);
550 if (pt
->read_buf
== pt
->putback_buf
)
551 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
554 else /* SCM_PORT_NEITHER */
556 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
560 scm_syserror ("fport_seek");
566 fport_truncate (SCM port
, off_t length
)
568 struct scm_fport
*fp
= SCM_FSTREAM (port
);
570 if (ftruncate (fp
->fdes
, length
) == -1)
571 scm_syserror ("ftruncate");
575 fport_write (SCM port
, const void *data
, size_t size
)
577 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
579 if (pt
->write_buf
== &pt
->shortbuf
)
581 /* "unbuffered" port. */
582 int fdes
= SCM_FSTREAM (port
)->fdes
;
584 if (write (fdes
, data
, size
) == -1)
585 scm_syserror ("fport_write");
589 const char *input
= (char *) data
;
590 size_t remaining
= size
;
592 while (remaining
> 0)
594 int space
= pt
->write_end
- pt
->write_pos
;
595 int write_len
= (remaining
> space
) ? space
: remaining
;
597 memcpy (pt
->write_pos
, input
, write_len
);
598 pt
->write_pos
+= write_len
;
599 remaining
-= write_len
;
601 if (write_len
== space
)
605 /* handle line buffering. */
606 if ((SCM_UNPACK_CAR (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
611 /* becomes 1 when process is exiting: normal exception handling won't
612 work by this time. */
613 extern int terminating
;
616 fport_flush (SCM port
)
618 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
619 struct scm_fport
*fp
= SCM_FSTREAM (port
);
620 char *ptr
= pt
->write_buf
;
621 int init_size
= pt
->write_pos
- pt
->write_buf
;
622 int remaining
= init_size
;
624 while (remaining
> 0)
628 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
631 /* error. assume nothing was written this call, but
632 fix up the buffer for any previous successful writes. */
633 int done
= init_size
- remaining
;
639 for (i
= 0; i
< remaining
; i
++)
641 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
643 pt
->write_pos
= pt
->write_buf
+ remaining
;
646 scm_syserror ("fport_flush");
649 const char *msg
= "Error: could not flush file-descriptor ";
652 write (2, msg
, strlen (msg
));
653 sprintf (buf
, "%d\n", fp
->fdes
);
654 write (2, buf
, strlen (buf
));
662 pt
->write_pos
= pt
->write_buf
;
663 pt
->rw_active
= SCM_PORT_NEITHER
;
666 /* clear the read buffer and adjust the file position for unread bytes. */
668 fport_end_input (SCM port
, int offset
)
670 struct scm_fport
*fp
= SCM_FSTREAM (port
);
671 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
673 offset
+= pt
->read_end
- pt
->read_pos
;
677 pt
->read_pos
= pt
->read_end
;
678 /* will throw error if unread-char used at beginning of file
679 then attempting to write. seems correct. */
680 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
681 scm_syserror ("fport_end_input");
683 pt
->rw_active
= SCM_PORT_NEITHER
;
687 fport_close (SCM port
)
689 struct scm_fport
*fp
= SCM_FSTREAM (port
);
690 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
694 SCM_SYSCALL (rv
= close (fp
->fdes
));
695 if (rv
== -1 && errno
!= EBADF
)
696 scm_syserror ("fport_close");
697 if (pt
->read_buf
== pt
->putback_buf
)
698 pt
->read_buf
= pt
->saved_read_buf
;
699 if (pt
->read_buf
!= &pt
->shortbuf
)
701 if (pt
->write_buf
!= &pt
->shortbuf
)
702 free (pt
->write_buf
);
708 fport_free (SCM port
)
714 void scm_make_fptob (void); /* Called from ports.c */
719 long tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
720 scm_set_port_free (tc
, fport_free
);
721 scm_set_port_print (tc
, prinfport
);
722 scm_set_port_flush (tc
, fport_flush
);
723 scm_set_port_end_input (tc
, fport_end_input
);
724 scm_set_port_close (tc
, fport_close
);
725 scm_set_port_seek (tc
, fport_seek
);
726 scm_set_port_truncate (tc
, fport_truncate
);
727 scm_set_port_input_waiting (tc
, fport_input_waiting
);
734 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
735 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
736 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));