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"
52 #include "libguile/validate.h"
53 #include "libguile/fports.h"
63 #ifdef HAVE_ST_BLKSIZE
69 #include "libguile/iselect.h"
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_INPUT_PORT_P (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_OUTPUT_PORT_P (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_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
132 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (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"
147 #define FUNC_NAME s_scm_setvbuf
152 port
= SCM_COERCE_OUTPORT (port
);
154 SCM_VALIDATE_OPFPORT (1,port
);
155 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
156 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
157 scm_out_of_range (FUNC_NAME
, mode
);
161 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
166 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
169 if (SCM_UNBNDP (size
))
178 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
179 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
180 scm_out_of_range (FUNC_NAME
, size
);
183 pt
= SCM_PTAB_ENTRY (port
);
185 /* silently discards buffered chars. */
186 if (pt
->read_buf
!= &pt
->shortbuf
)
188 if (pt
->write_buf
!= &pt
->shortbuf
)
189 free (pt
->write_buf
);
191 scm_fport_buffer_add (port
, csize
, csize
);
192 return SCM_UNSPECIFIED
;
196 /* Move ports with the specified file descriptor to new descriptors,
197 * reseting the revealed count to 0.
201 scm_evict_ports (int fd
)
205 for (i
= 0; i
< scm_port_table_size
; i
++)
207 SCM port
= scm_port_table
[i
]->port
;
209 if (SCM_FPORTP (port
))
211 struct scm_fport
*fp
= SCM_FSTREAM (port
);
217 scm_syserror ("scm_evict_ports");
218 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
225 * Return a new port open on a given file.
227 * The mode string must match the pattern: [rwa+]** which
228 * is interpreted in the usual unix way.
230 * Return the new port.
232 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
233 (SCM filename
, SCM modes
),
234 "Open the file whose name is @var{string}, and return a port\n"
235 "representing that file. The attributes of the port are\n"
236 "determined by the @var{mode} string. The way in \n"
237 "which this is interpreted is similar to C stdio:\n\n"
238 "The first character must be one of the following:\n\n"
241 "Open an existing file for input.\n"
243 "Open a file for output, creating it if it doesn't already exist\n"
244 "or removing its contents if it does.\n"
246 "Open a file for output, creating it if it doesn't already exist.\n"
247 "All writes to the port will go to the end of the file.\n"
248 "The \"append mode\" can be turned off while the port is in use\n"
249 "@pxref{Ports and File Descriptors, fcntl}\n"
251 "The following additional characters can be appended:\n\n"
254 "Open the port for both input and output. E.g., @code{r+}: open\n"
255 "an existing file for both input and output.\n"
257 "Create an \"unbuffered\" port. In this case input and output operations\n"
258 "are passed directly to the underlying port implementation without\n"
259 "additional buffering. This is likely to slow down I/O operations.\n"
260 "The buffering mode can be changed while a port is in use\n"
261 "@pxref{Ports and File Descriptors, setvbuf}\n"
263 "Add line-buffering to the port. The port output buffer will be\n"
264 "automatically flushed whenever a newline character is written.\n"
266 "In theory we could create read/write ports which were buffered in one\n"
267 "direction only. However this isn't included in the current interfaces.\n\n"
268 "If a file cannot be opened with the access requested,\n"
269 "@code{open-file} throws an exception.")
270 #define FUNC_NAME s_scm_open_file
279 SCM_VALIDATE_ROSTRING (1,filename
);
280 SCM_VALIDATE_ROSTRING (2,modes
);
281 if (SCM_SUBSTRP (filename
))
282 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
283 if (SCM_SUBSTRP (modes
))
284 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
286 file
= SCM_ROCHARS (filename
);
287 mode
= SCM_ROCHARS (modes
);
295 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
298 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
301 scm_out_of_range (FUNC_NAME
, modes
);
309 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
311 case '0': /* unbuffered: handled later. */
312 case 'b': /* 'binary' mode: ignored. */
313 case 'l': /* line buffered: handled during output. */
316 scm_out_of_range (FUNC_NAME
, modes
);
320 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
325 SCM_SYSERROR_MSG ("~A: ~S",
326 scm_cons (scm_makfrom0str (strerror (en
)),
327 scm_cons (filename
, SCM_EOL
)), en
);
329 port
= scm_fdes_to_port (fdes
, mode
, filename
);
335 /* Building Guile ports from a file descriptor. */
337 /* Build a Scheme port from an open file descriptor `fdes'.
338 MODE indicates whether FILE is open for reading or writing; it uses
339 the same notation as open-file's second argument.
340 NAME is a string to be used as the port's filename.
343 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
344 #define FUNC_NAME "scm_fdes_to_port"
346 long mode_bits
= scm_mode_bits (mode
);
351 /* test that fdes is valid. */
352 flags
= fcntl (fdes
, F_GETFL
, 0);
357 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
358 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
360 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
365 pt
= scm_add_to_port_table (port
);
366 SCM_SETPTAB_ENTRY (port
, pt
);
367 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
371 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
375 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
376 SCM_SETSTREAM (port
, fp
);
377 if (mode_bits
& SCM_BUF0
)
378 scm_fport_buffer_add (port
, 0, 0);
380 scm_fport_buffer_add (port
, -1, -1);
382 SCM_PTAB_ENTRY (port
)->file_name
= name
;
388 /* Return a lower bound on the number of bytes available for input. */
390 fport_input_waiting (SCM port
)
392 int fdes
= SCM_FSTREAM (port
)->fdes
;
395 struct timeval timeout
;
396 SELECT_TYPE read_set
;
397 SELECT_TYPE write_set
;
398 SELECT_TYPE except_set
;
401 FD_ZERO (&write_set
);
402 FD_ZERO (&except_set
);
404 FD_SET (fdes
, &read_set
);
409 if (select (SELECT_SET_SIZE
,
410 &read_set
, &write_set
, &except_set
, &timeout
)
412 scm_syserror ("fport_input_waiting");
413 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
414 #elif defined (FIONREAD)
416 ioctl(fdes
, FIONREAD
, &remir
);
419 scm_misc_error ("fport_input_waiting",
420 "Not fully implemented on this platform",
427 prinfport (SCM exp
,SCM port
,scm_print_state
*pstate
)
429 scm_puts ("#<", port
);
430 scm_print_port_mode (exp
, port
);
431 if (SCM_OPFPORTP (exp
))
434 SCM name
= SCM_PTAB_ENTRY (exp
)->file_name
;
435 scm_puts (SCM_ROSTRINGP (name
)
437 : SCM_PTOBNAME (SCM_PTOBNUM (exp
)),
439 scm_putc (' ', port
);
440 fdes
= (SCM_FSTREAM (exp
))->fdes
;
443 scm_puts (ttyname (fdes
), port
);
445 scm_intprint (fdes
, 10, port
);
449 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
450 scm_putc (' ', port
);
451 scm_intprint (SCM_UNPACK (SCM_CDR (exp
)), 16, port
);
453 scm_putc ('>', port
);
458 /* thread-local block for input on fport's fdes. */
460 fport_wait_for_input (SCM port
)
462 int fdes
= SCM_FSTREAM (port
)->fdes
;
464 if (!fport_input_waiting (port
))
468 int flags
= fcntl (fdes
, F_GETFL
);
471 scm_syserror ("scm_fdes_wait_for_input");
472 if (!(flags
& O_NONBLOCK
))
476 FD_SET (fdes
, &readfds
);
477 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
479 while (n
== -1 && errno
== EINTR
);
484 static void fport_flush (SCM port
);
486 /* fill a port's read-buffer with a single read.
487 returns the first char and moves the read_pos pointer past it.
488 or returns EOF if end of file. */
490 fport_fill_input (SCM port
)
493 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
494 struct scm_fport
*fp
= SCM_FSTREAM (port
);
497 fport_wait_for_input (port
);
499 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
501 scm_syserror ("fport_fill_input");
506 pt
->read_pos
= pt
->read_buf
;
507 pt
->read_end
= pt
->read_buf
+ count
;
508 return *pt
->read_buf
;
513 fport_seek (SCM port
, off_t offset
, int whence
)
515 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
516 struct scm_fport
*fp
= SCM_FSTREAM (port
);
520 if (pt
->rw_active
== SCM_PORT_WRITE
)
522 if (offset
!= 0 || whence
!= SEEK_CUR
)
525 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
529 /* read current position without disturbing the buffer. */
530 rv
= lseek (fp
->fdes
, offset
, whence
);
531 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
534 else if (pt
->rw_active
== SCM_PORT_READ
)
536 if (offset
!= 0 || whence
!= SEEK_CUR
)
538 /* could expand to avoid a second seek. */
539 scm_end_input (port
);
540 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
544 /* read current position without disturbing the buffer
545 (particularly the unread-char buffer). */
546 rv
= lseek (fp
->fdes
, offset
, whence
);
547 result
= rv
- (pt
->read_end
- pt
->read_pos
);
549 if (pt
->read_buf
== pt
->putback_buf
)
550 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
553 else /* SCM_PORT_NEITHER */
555 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
559 scm_syserror ("fport_seek");
565 fport_truncate (SCM port
, off_t length
)
567 struct scm_fport
*fp
= SCM_FSTREAM (port
);
569 if (ftruncate (fp
->fdes
, length
) == -1)
570 scm_syserror ("ftruncate");
574 fport_write (SCM port
, const void *data
, size_t size
)
576 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
578 if (pt
->write_buf
== &pt
->shortbuf
)
580 /* "unbuffered" port. */
581 int fdes
= SCM_FSTREAM (port
)->fdes
;
583 if (write (fdes
, data
, size
) == -1)
584 scm_syserror ("fport_write");
588 const char *input
= (char *) data
;
589 size_t remaining
= size
;
591 while (remaining
> 0)
593 int space
= pt
->write_end
- pt
->write_pos
;
594 int write_len
= (remaining
> space
) ? space
: remaining
;
596 memcpy (pt
->write_pos
, input
, write_len
);
597 pt
->write_pos
+= write_len
;
598 remaining
-= write_len
;
600 if (write_len
== space
)
604 /* handle line buffering. */
605 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
610 /* becomes 1 when process is exiting: normal exception handling won't
611 work by this time. */
612 extern int terminating
;
615 fport_flush (SCM port
)
617 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
618 struct scm_fport
*fp
= SCM_FSTREAM (port
);
619 unsigned char *ptr
= pt
->write_buf
;
620 int init_size
= pt
->write_pos
- pt
->write_buf
;
621 int remaining
= init_size
;
623 while (remaining
> 0)
627 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
630 /* error. assume nothing was written this call, but
631 fix up the buffer for any previous successful writes. */
632 int done
= init_size
- remaining
;
638 for (i
= 0; i
< remaining
; i
++)
640 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
642 pt
->write_pos
= pt
->write_buf
+ remaining
;
645 scm_syserror ("fport_flush");
648 const char *msg
= "Error: could not flush file-descriptor ";
651 write (2, msg
, strlen (msg
));
652 sprintf (buf
, "%d\n", fp
->fdes
);
653 write (2, buf
, strlen (buf
));
661 pt
->write_pos
= pt
->write_buf
;
662 pt
->rw_active
= SCM_PORT_NEITHER
;
665 /* clear the read buffer and adjust the file position for unread bytes. */
667 fport_end_input (SCM port
, int offset
)
669 struct scm_fport
*fp
= SCM_FSTREAM (port
);
670 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
672 offset
+= pt
->read_end
- pt
->read_pos
;
676 pt
->read_pos
= pt
->read_end
;
677 /* will throw error if unread-char used at beginning of file
678 then attempting to write. seems correct. */
679 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
680 scm_syserror ("fport_end_input");
682 pt
->rw_active
= SCM_PORT_NEITHER
;
686 fport_close (SCM port
)
688 struct scm_fport
*fp
= SCM_FSTREAM (port
);
689 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
693 SCM_SYSCALL (rv
= close (fp
->fdes
));
694 if (rv
== -1 && errno
!= EBADF
)
695 scm_syserror ("fport_close");
696 if (pt
->read_buf
== pt
->putback_buf
)
697 pt
->read_buf
= pt
->saved_read_buf
;
698 if (pt
->read_buf
!= &pt
->shortbuf
)
700 if (pt
->write_buf
!= &pt
->shortbuf
)
701 free (pt
->write_buf
);
707 fport_free (SCM port
)
713 void scm_make_fptob (void); /* Called from ports.c */
718 long tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
719 scm_set_port_free (tc
, fport_free
);
720 scm_set_port_print (tc
, prinfport
);
721 scm_set_port_flush (tc
, fport_flush
);
722 scm_set_port_end_input (tc
, fport_end_input
);
723 scm_set_port_close (tc
, fport_close
);
724 scm_set_port_seek (tc
, fport_seek
);
725 scm_set_port_truncate (tc
, fport_truncate
);
726 scm_set_port_input_waiting (tc
, fport_input_waiting
);
732 #include "libguile/fports.x"
733 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
734 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
735 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));