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 */
62 #ifdef HAVE_ST_BLKSIZE
70 /* create FPORT buffer with specified sizes (or -1 to use default size or
73 scm_fport_buffer_add (SCM port
, int read_size
, int write_size
)
75 struct scm_fport
*fp
= SCM_FSTREAM (port
);
76 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
77 char *s_scm_fport_buffer_add
= "scm_fport_buffer_add";
79 if (read_size
== -1 || write_size
== -1)
82 #ifdef HAVE_ST_BLKSIZE
85 if (fstat (fp
->fdes
, &st
) == -1)
86 scm_syserror (s_scm_fport_buffer_add
);
87 default_size
= st
.st_blksize
;
92 read_size
= default_size
;
94 write_size
= default_size
;
97 if (SCM_INPORTP (port
) && read_size
> 0)
99 pt
->read_buf
= malloc (read_size
);
100 if (pt
->read_buf
== NULL
)
101 scm_memory_error (s_scm_fport_buffer_add
);
102 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
103 pt
->read_buf_size
= read_size
;
107 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
108 pt
->read_buf_size
= 1;
111 if (SCM_OUTPORTP (port
) && write_size
> 0)
113 pt
->write_buf
= malloc (write_size
);
114 if (pt
->write_buf
== NULL
)
115 scm_memory_error (s_scm_fport_buffer_add
);
116 pt
->write_pos
= pt
->write_buf
;
117 pt
->write_buf_size
= write_size
;
121 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
122 pt
->write_buf_size
= 1;
125 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
126 if (read_size
> 0 || write_size
> 0)
127 SCM_SETCAR (port
, SCM_CARBITS (port
) & ~SCM_BUF0
);
129 SCM_SETCAR (port
, (SCM_CARBITS (port
) | SCM_BUF0
));
132 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
133 (SCM port
, SCM mode
, SCM size
),
134 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
141 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
142 "If @var{size} is omitted, a default size will be used.\n"
144 "@deffn primitive fcntl fd/port command [value]\n"
145 "Apply @var{command} to the specified file descriptor or the underlying\n"
146 "file descriptor of the specified port. @var{value} is an optional\n"
147 "integer argument.\n\n"
148 "Values for @var{command} are:\n\n"
151 "Duplicate a file descriptor\n"
153 "Get flags associated with the file descriptor.\n"
155 "Set flags associated with the file descriptor to @var{value}.\n"
157 "Get flags associated with the open file.\n"
159 "Set flags associated with the open file to @var{value}\n"
161 "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
163 "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
165 "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
169 #define FUNC_NAME s_scm_setvbuf
174 port
= SCM_COERCE_OUTPORT (port
);
176 SCM_VALIDATE_OPFPORT (1,port
);
177 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
178 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
179 scm_out_of_range (FUNC_NAME
, mode
);
183 SCM_SETCAR (port
, SCM_CARBITS (port
) | SCM_BUFLINE
);
188 SCM_SETCAR (port
, SCM_CARBITS (port
) ^ SCM_BUFLINE
);
191 if (SCM_UNBNDP (size
))
200 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
201 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
202 scm_out_of_range (FUNC_NAME
, size
);
205 pt
= SCM_PTAB_ENTRY (port
);
207 /* silently discards buffered chars. */
208 if (pt
->read_buf
!= &pt
->shortbuf
)
209 scm_must_free (pt
->read_buf
);
210 if (pt
->write_buf
!= &pt
->shortbuf
)
211 scm_must_free (pt
->write_buf
);
213 scm_fport_buffer_add (port
, csize
, csize
);
214 return SCM_UNSPECIFIED
;
218 /* Move ports with the specified file descriptor to new descriptors,
219 * reseting the revealed count to 0.
223 scm_evict_ports (int fd
)
227 for (i
= 0; i
< scm_port_table_size
; i
++)
229 SCM port
= scm_port_table
[i
]->port
;
231 if (SCM_FPORTP (port
))
233 struct scm_fport
*fp
= SCM_FSTREAM (port
);
239 scm_syserror ("scm_evict_ports");
240 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
247 * Return a new port open on a given file.
249 * The mode string must match the pattern: [rwa+]** which
250 * is interpreted in the usual unix way.
252 * Return the new port.
254 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
255 (SCM filename
, SCM modes
),
256 "Open the file whose name is @var{string}, and return a port\n"
257 "representing that file. The attributes of the port are\n"
258 "determined by the @var{mode} string. The way in \n"
259 "which this is interpreted is similar to C stdio:\n\n"
260 "The first character must be one of the following:\n\n"
263 "Open an existing file for input.\n"
265 "Open a file for output, creating it if it doesn't already exist\n"
266 "or removing its contents if it does.\n"
268 "Open a file for output, creating it if it doesn't already exist.\n"
269 "All writes to the port will go to the end of the file.\n"
270 "The \"append mode\" can be turned off while the port is in use\n"
271 "@pxref{Ports and File Descriptors, fcntl}\n"
273 "The following additional characters can be appended:\n\n"
276 "Open the port for both input and output. E.g., @code{r+}: open\n"
277 "an existing file for both input and output.\n"
279 "Create an \"unbuffered\" port. In this case input and output operations\n"
280 "are passed directly to the underlying port implementation without\n"
281 "additional buffering. This is likely to slow down I/O operations.\n"
282 "The buffering mode can be changed while a port is in use\n"
283 "@pxref{Ports and File Descriptors, setvbuf}\n"
285 "Add line-buffering to the port. The port output buffer will be\n"
286 "automatically flushed whenever a newline character is written.\n"
288 "In theory we could create read/write ports which were buffered in one\n"
289 "direction only. However this isn't included in the current interfaces.\n\n"
290 "If a file cannot be opened with the access requested,\n"
291 "@code{open-file} throws an exception.")
292 #define FUNC_NAME s_scm_open_file
301 SCM_VALIDATE_ROSTRING (1,filename
);
302 SCM_VALIDATE_ROSTRING (2,modes
);
303 if (SCM_SUBSTRP (filename
))
304 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
305 if (SCM_SUBSTRP (modes
))
306 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
308 file
= SCM_ROCHARS (filename
);
309 mode
= SCM_ROCHARS (modes
);
317 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
320 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
323 scm_out_of_range (FUNC_NAME
, modes
);
331 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
333 case '0': /* unbuffered: handled later. */
334 case 'b': /* 'binary' mode: ignored. */
335 case 'l': /* line buffered: handled during output. */
338 scm_out_of_range (FUNC_NAME
, modes
);
342 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
347 SCM_SYSERROR_MSG ("~A: ~S",
348 scm_cons (scm_makfrom0str (strerror (en
)),
349 scm_cons (filename
, SCM_EOL
)), en
);
351 port
= scm_fdes_to_port (fdes
, mode
, filename
);
357 /* Building Guile ports from a file descriptor. */
359 /* Build a Scheme port from an open file descriptor `fdes'.
360 MODE indicates whether FILE is open for reading or writing; it uses
361 the same notation as open-file's second argument.
362 Use NAME as the port's filename. */
365 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
367 long mode_bits
= scm_mode_bits (mode
);
373 pt
= scm_add_to_port_table (port
);
374 SCM_SETPTAB_ENTRY (port
, pt
);
375 SCM_SETCAR (port
, (scm_tc16_fport
| mode_bits
));
379 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
381 scm_memory_error ("scm_fdes_to_port");
383 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
384 SCM_SETSTREAM (port
, fp
);
385 if (mode_bits
& SCM_BUF0
)
386 scm_fport_buffer_add (port
, 0, 0);
388 scm_fport_buffer_add (port
, -1, -1);
390 SCM_PTAB_ENTRY (port
)->file_name
= name
;
396 /* Return a lower bound on the number of bytes available for input. */
398 fport_input_waiting (SCM port
)
400 int fdes
= SCM_FSTREAM (port
)->fdes
;
403 struct timeval timeout
;
404 SELECT_TYPE read_set
;
405 SELECT_TYPE write_set
;
406 SELECT_TYPE except_set
;
409 FD_ZERO (&write_set
);
410 FD_ZERO (&except_set
);
412 FD_SET (fdes
, &read_set
);
417 if (select (SELECT_SET_SIZE
,
418 &read_set
, &write_set
, &except_set
, &timeout
)
420 scm_syserror ("fport_input_waiting");
421 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
422 #elif defined (FIONREAD)
424 ioctl(fdes
, FIONREAD
, &remir
);
427 scm_misc_error ("fport_input_waiting",
428 "Not fully implemented on this platform",
435 prinfport (SCM exp
,SCM port
,scm_print_state
*pstate
)
437 scm_puts ("#<", port
);
438 scm_print_port_mode (exp
, port
);
439 if (SCM_OPFPORTP (exp
))
442 SCM name
= SCM_PTAB_ENTRY (exp
)->file_name
;
443 scm_puts (SCM_ROSTRINGP (name
)
445 : SCM_PTOBNAME (SCM_PTOBNUM (exp
)),
447 scm_putc (' ', port
);
448 fdes
= (SCM_FSTREAM (exp
))->fdes
;
451 scm_puts (ttyname (fdes
), port
);
453 scm_intprint (fdes
, 10, port
);
457 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
458 scm_putc (' ', port
);
459 scm_intprint (SCM_BITS (SCM_CDR (exp
)), 16, port
);
461 scm_putc ('>', port
);
466 /* thread-local block for input on fport's fdes. */
468 fport_wait_for_input (SCM port
)
470 int fdes
= SCM_FSTREAM (port
)->fdes
;
472 if (!fport_input_waiting (port
))
476 int flags
= fcntl (fdes
, F_GETFL
);
479 scm_syserror ("scm_fdes_wait_for_input");
480 if (!(flags
& O_NONBLOCK
))
484 FD_SET (fdes
, &readfds
);
485 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
487 while (n
== -1 && errno
== EINTR
);
492 static void fport_flush (SCM port
);
494 /* fill a port's read-buffer with a single read.
495 returns the first char and moves the read_pos pointer past it.
496 or returns EOF if end of file. */
498 fport_fill_input (SCM port
)
501 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
502 struct scm_fport
*fp
= SCM_FSTREAM (port
);
505 fport_wait_for_input (port
);
507 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
509 scm_syserror ("fport_fill_input");
514 pt
->read_pos
= pt
->read_buf
;
515 pt
->read_end
= pt
->read_buf
+ count
;
516 return *pt
->read_buf
;
521 fport_seek (SCM port
, off_t offset
, int whence
)
523 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
524 struct scm_fport
*fp
= SCM_FSTREAM (port
);
528 if (pt
->rw_active
== SCM_PORT_WRITE
)
530 if (offset
!= 0 || whence
!= SEEK_CUR
)
533 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
537 /* read current position without disturbing the buffer. */
538 rv
= lseek (fp
->fdes
, offset
, whence
);
539 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
542 else if (pt
->rw_active
== SCM_PORT_READ
)
544 if (offset
!= 0 || whence
!= SEEK_CUR
)
546 /* could expand to avoid a second seek. */
547 scm_end_input (port
);
548 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
552 /* read current position without disturbing the buffer
553 (particularly the unread-char buffer). */
554 rv
= lseek (fp
->fdes
, offset
, whence
);
555 result
= rv
- (pt
->read_end
- pt
->read_pos
);
557 if (pt
->read_buf
== pt
->putback_buf
)
558 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
561 else /* SCM_PORT_NEITHER */
563 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
567 scm_syserror ("fport_seek");
573 fport_truncate (SCM port
, off_t length
)
575 struct scm_fport
*fp
= SCM_FSTREAM (port
);
577 if (ftruncate (fp
->fdes
, length
) == -1)
578 scm_syserror ("ftruncate");
582 fport_write (SCM port
, const void *data
, size_t size
)
584 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
586 if (pt
->write_buf
== &pt
->shortbuf
)
588 /* "unbuffered" port. */
589 int fdes
= SCM_FSTREAM (port
)->fdes
;
591 if (write (fdes
, data
, size
) == -1)
592 scm_syserror ("fport_write");
596 const char *input
= (char *) data
;
597 size_t remaining
= size
;
599 while (remaining
> 0)
601 int space
= pt
->write_end
- pt
->write_pos
;
602 int write_len
= (remaining
> space
) ? space
: remaining
;
604 memcpy (pt
->write_pos
, input
, write_len
);
605 pt
->write_pos
+= write_len
;
606 remaining
-= write_len
;
608 if (write_len
== space
)
612 /* handle line buffering. */
613 if ((SCM_CARBITS (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
618 /* becomes 1 when process is exiting: normal exception handling won't
619 work by this time. */
620 extern int terminating
;
623 fport_flush (SCM port
)
625 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
626 struct scm_fport
*fp
= SCM_FSTREAM (port
);
627 char *ptr
= pt
->write_buf
;
628 int init_size
= pt
->write_pos
- pt
->write_buf
;
629 int remaining
= init_size
;
631 while (remaining
> 0)
635 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
638 /* error. assume nothing was written this call, but
639 fix up the buffer for any previous successful writes. */
640 int done
= init_size
- remaining
;
646 for (i
= 0; i
< remaining
; i
++)
648 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
650 pt
->write_pos
= pt
->write_buf
+ remaining
;
653 scm_syserror ("fport_flush");
656 const char *msg
= "Error: could not flush file-descriptor ";
659 write (2, msg
, strlen (msg
));
660 sprintf (buf
, "%d\n", fp
->fdes
);
661 write (2, buf
, strlen (buf
));
669 pt
->write_pos
= pt
->write_buf
;
670 pt
->rw_active
= SCM_PORT_NEITHER
;
673 /* clear the read buffer and adjust the file position for unread bytes. */
675 fport_end_input (SCM port
, int offset
)
677 struct scm_fport
*fp
= SCM_FSTREAM (port
);
678 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
680 offset
+= pt
->read_end
- pt
->read_pos
;
684 pt
->read_pos
= pt
->read_end
;
685 /* will throw error if unread-char used at beginning of file
686 then attempting to write. seems correct. */
687 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
688 scm_syserror ("fport_end_input");
690 pt
->rw_active
= SCM_PORT_NEITHER
;
694 fport_close (SCM port
)
696 struct scm_fport
*fp
= SCM_FSTREAM (port
);
697 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
701 SCM_SYSCALL (rv
= close (fp
->fdes
));
702 if (rv
== -1 && errno
!= EBADF
)
703 scm_syserror ("fport_close");
704 if (pt
->read_buf
== pt
->putback_buf
)
705 pt
->read_buf
= pt
->saved_read_buf
;
706 if (pt
->read_buf
!= &pt
->shortbuf
)
708 if (pt
->write_buf
!= &pt
->shortbuf
)
709 free (pt
->write_buf
);
715 fport_free (SCM port
)
721 void scm_make_fptob (void); /* Called from ports.c */
726 long tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
727 scm_set_port_free (tc
, fport_free
);
728 scm_set_port_print (tc
, prinfport
);
729 scm_set_port_flush (tc
, fport_flush
);
730 scm_set_port_end_input (tc
, fport_end_input
);
731 scm_set_port_close (tc
, fport_close
);
732 scm_set_port_seek (tc
, fport_seek
);
733 scm_set_port_truncate (tc
, fport_truncate
);
734 scm_set_port_input_waiting (tc
, fport_input_waiting
);
741 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
742 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
743 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));