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 */
51 #include "scm_validate.h"
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_CAR (port
) & ~SCM_BUF0
);
129 SCM_SETCAR (port
, (SCM_CAR (port
) | SCM_BUF0
));
132 GUILE_PROC (scm_setvbuf
, "setvbuf", 2, 1, 0,
133 (SCM port
, SCM mode
, SCM size
),
135 #define FUNC_NAME s_scm_setvbuf
140 port
= SCM_COERCE_OUTPORT (port
);
142 SCM_VALIDATE_OPFPORT(1,port
);
143 SCM_VALIDATE_INT_COPY(2,mode
,cmode
);
144 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
145 scm_out_of_range (FUNC_NAME
, mode
);
149 SCM_SETCAR (port
, SCM_CAR (port
) | SCM_BUFLINE
);
154 SCM_SETCAR (port
, SCM_CAR (port
) ^ SCM_BUFLINE
);
157 if (SCM_UNBNDP (size
))
166 SCM_VALIDATE_INT_COPY(3,size
,csize
);
167 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
168 scm_out_of_range (FUNC_NAME
, size
);
171 pt
= SCM_PTAB_ENTRY (port
);
173 /* silently discards buffered chars. */
174 if (pt
->read_buf
!= &pt
->shortbuf
)
175 scm_must_free (pt
->read_buf
);
176 if (pt
->write_buf
!= &pt
->shortbuf
)
177 scm_must_free (pt
->write_buf
);
179 scm_fport_buffer_add (port
, csize
, csize
);
180 return SCM_UNSPECIFIED
;
184 /* Move ports with the specified file descriptor to new descriptors,
185 * reseting the revealed count to 0.
189 scm_evict_ports (int fd
)
193 for (i
= 0; i
< scm_port_table_size
; i
++)
195 SCM port
= scm_port_table
[i
]->port
;
197 if (SCM_FPORTP (port
))
199 struct scm_fport
*fp
= SCM_FSTREAM (port
);
205 scm_syserror ("scm_evict_ports");
206 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
213 * Return a new port open on a given file.
215 * The mode string must match the pattern: [rwa+]** which
216 * is interpreted in the usual unix way.
218 * Return the new port.
220 GUILE_PROC(scm_open_file
, "open-file", 2, 0, 0,
221 (SCM filename
, SCM modes
),
223 #define FUNC_NAME s_scm_open_file
232 SCM_VALIDATE_ROSTRING(1,filename
);
233 SCM_VALIDATE_ROSTRING(2,modes
);
234 if (SCM_SUBSTRP (filename
))
235 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
236 if (SCM_SUBSTRP (modes
))
237 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
239 file
= SCM_ROCHARS (filename
);
240 mode
= SCM_ROCHARS (modes
);
248 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
251 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
254 scm_out_of_range (FUNC_NAME
, modes
);
262 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
264 case '0': /* unbuffered: handled later. */
265 case 'b': /* 'binary' mode: ignored. */
266 case 'l': /* line buffered: handled during output. */
269 scm_out_of_range (FUNC_NAME
, modes
);
273 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
278 scm_syserror_msg (FUNC_NAME
, "%s: %S",
279 scm_cons (scm_makfrom0str (strerror (en
)),
280 scm_cons (filename
, SCM_EOL
)),
283 port
= scm_fdes_to_port (fdes
, mode
, filename
);
289 /* Building Guile ports from a file descriptor. */
291 /* Build a Scheme port from an open file descriptor `fdes'.
292 MODE indicates whether FILE is open for reading or writing; it uses
293 the same notation as open-file's second argument.
294 Use NAME as the port's filename. */
297 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
299 long mode_bits
= scm_mode_bits (mode
);
305 pt
= scm_add_to_port_table (port
);
306 SCM_SETPTAB_ENTRY (port
, pt
);
307 SCM_SETCAR (port
, (scm_tc16_fport
| mode_bits
));
311 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
313 scm_memory_error ("scm_fdes_to_port");
315 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
316 SCM_SETSTREAM (port
, fp
);
317 if (mode_bits
& SCM_BUF0
)
318 scm_fport_buffer_add (port
, 0, 0);
320 scm_fport_buffer_add (port
, -1, -1);
322 SCM_PTAB_ENTRY (port
)->file_name
= name
;
328 /* Return a lower bound on the number of bytes available for input. */
330 fport_input_waiting (SCM port
)
332 int fdes
= SCM_FSTREAM (port
)->fdes
;
335 struct timeval timeout
;
336 SELECT_TYPE read_set
;
337 SELECT_TYPE write_set
;
338 SELECT_TYPE except_set
;
341 FD_ZERO (&write_set
);
342 FD_ZERO (&except_set
);
344 FD_SET (fdes
, &read_set
);
349 if (select (SELECT_SET_SIZE
,
350 &read_set
, &write_set
, &except_set
, &timeout
)
352 scm_syserror ("fport_input_waiting");
353 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
354 #elif defined (FIONREAD)
356 ioctl(fdes
, FIONREAD
, &remir
);
359 scm_misc_error ("fport_input_waiting",
360 "Not fully implemented on this platform",
367 prinfport (SCM exp
,SCM port
,scm_print_state
*pstate
)
369 scm_puts ("#<", port
);
370 scm_print_port_mode (exp
, port
);
371 if (SCM_OPFPORTP (exp
))
374 SCM name
= SCM_PTAB_ENTRY (exp
)->file_name
;
375 scm_puts (SCM_NIMP (name
) && SCM_ROSTRINGP (name
)
377 : SCM_PTOBNAME (SCM_PTOBNUM (exp
)),
379 scm_putc (' ', port
);
380 fdes
= (SCM_FSTREAM (exp
))->fdes
;
383 scm_puts (ttyname (fdes
), port
);
385 scm_intprint (fdes
, 10, port
);
389 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
390 scm_putc (' ', port
);
391 scm_intprint (SCM_CDR (exp
), 16, port
);
393 scm_putc ('>', port
);
398 /* thread-local block for input on fport's fdes. */
400 fport_wait_for_input (SCM port
)
402 int fdes
= SCM_FSTREAM (port
)->fdes
;
404 if (!fport_input_waiting (port
))
408 int flags
= fcntl (fdes
, F_GETFL
);
411 scm_syserror ("scm_fdes_wait_for_input");
412 if (!(flags
& O_NONBLOCK
))
416 FD_SET (fdes
, &readfds
);
417 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
419 while (n
== -1 && errno
== EINTR
);
424 static void fport_flush (SCM port
);
426 /* fill a port's read-buffer with a single read.
427 returns the first char and moves the read_pos pointer past it.
428 or returns EOF if end of file. */
430 fport_fill_input (SCM port
)
433 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
434 struct scm_fport
*fp
= SCM_FSTREAM (port
);
437 fport_wait_for_input (port
);
439 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
441 scm_syserror ("fport_fill_input");
446 pt
->read_pos
= pt
->read_buf
;
447 pt
->read_end
= pt
->read_buf
+ count
;
448 return *pt
->read_buf
;
453 fport_seek (SCM port
, off_t offset
, int whence
)
455 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
456 struct scm_fport
*fp
= SCM_FSTREAM (port
);
460 if (pt
->rw_active
== SCM_PORT_WRITE
)
462 if (offset
!= 0 || whence
!= SEEK_CUR
)
465 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
469 /* read current position without disturbing the buffer. */
470 rv
= lseek (fp
->fdes
, offset
, whence
);
471 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
474 else if (pt
->rw_active
== SCM_PORT_READ
)
476 if (offset
!= 0 || whence
!= SEEK_CUR
)
478 /* could expand to avoid a second seek. */
479 scm_end_input (port
);
480 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
484 /* read current position without disturbing the buffer
485 (particularly the unread-char buffer). */
486 rv
= lseek (fp
->fdes
, offset
, whence
);
487 result
= rv
- (pt
->read_end
- pt
->read_pos
);
489 if (pt
->read_buf
== pt
->putback_buf
)
490 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
493 else /* SCM_PORT_NEITHER */
495 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
499 scm_syserror ("fport_seek");
505 fport_truncate (SCM port
, off_t length
)
507 struct scm_fport
*fp
= SCM_FSTREAM (port
);
509 if (ftruncate (fp
->fdes
, length
) == -1)
510 scm_syserror ("ftruncate");
514 fport_write (SCM port
, void *data
, size_t size
)
516 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
518 if (pt
->write_buf
== &pt
->shortbuf
)
520 /* "unbuffered" port. */
521 int fdes
= SCM_FSTREAM (port
)->fdes
;
523 if (write (fdes
, data
, size
) == -1)
524 scm_syserror ("fport_write");
528 const char *input
= (char *) data
;
529 size_t remaining
= size
;
531 while (remaining
> 0)
533 int space
= pt
->write_end
- pt
->write_pos
;
534 int write_len
= (remaining
> space
) ? space
: remaining
;
536 memcpy (pt
->write_pos
, input
, write_len
);
537 pt
->write_pos
+= write_len
;
538 remaining
-= write_len
;
540 if (write_len
== space
)
544 /* handle line buffering. */
545 if ((SCM_CAR (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
550 /* becomes 1 when process is exiting: normal exception handling won't
551 work by this time. */
552 extern int terminating
;
555 fport_flush (SCM port
)
557 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
558 struct scm_fport
*fp
= SCM_FSTREAM (port
);
559 char *ptr
= pt
->write_buf
;
560 int init_size
= pt
->write_pos
- pt
->write_buf
;
561 int remaining
= init_size
;
563 while (remaining
> 0)
567 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
570 /* error. assume nothing was written this call, but
571 fix up the buffer for any previous successful writes. */
572 int done
= init_size
- remaining
;
578 for (i
= 0; i
< remaining
; i
++)
580 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
582 pt
->write_pos
= pt
->write_buf
+ remaining
;
585 scm_syserror ("fport_flush");
588 const char *msg
= "Error: could not flush file-descriptor ";
591 write (2, msg
, strlen (msg
));
592 sprintf (buf
, "%d\n", fp
->fdes
);
593 write (2, buf
, strlen (buf
));
601 pt
->write_pos
= pt
->write_buf
;
602 pt
->rw_active
= SCM_PORT_NEITHER
;
605 /* clear the read buffer and adjust the file position for unread bytes. */
607 fport_end_input (SCM port
, int offset
)
609 struct scm_fport
*fp
= SCM_FSTREAM (port
);
610 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
612 offset
+= pt
->read_end
- pt
->read_pos
;
616 pt
->read_pos
= pt
->read_end
;
617 /* will throw error if unread-char used at beginning of file
618 then attempting to write. seems correct. */
619 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
620 scm_syserror ("fport_end_input");
622 pt
->rw_active
= SCM_PORT_NEITHER
;
626 fport_close (SCM port
)
628 struct scm_fport
*fp
= SCM_FSTREAM (port
);
629 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
633 SCM_SYSCALL (rv
= close (fp
->fdes
));
634 if (rv
== -1 && errno
!= EBADF
)
635 scm_syserror ("fport_close");
636 if (pt
->read_buf
== pt
->putback_buf
)
637 pt
->read_buf
= pt
->saved_read_buf
;
638 if (pt
->read_buf
!= &pt
->shortbuf
)
640 if (pt
->write_buf
!= &pt
->shortbuf
)
641 free (pt
->write_buf
);
647 fport_free (SCM port
)
653 void scm_make_fptob (void); /* Called from ports.c */
658 long tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
659 scm_set_port_free (tc
, fport_free
);
660 scm_set_port_print (tc
, prinfport
);
661 scm_set_port_flush (tc
, fport_flush
);
662 scm_set_port_end_input (tc
, fport_end_input
);
663 scm_set_port_close (tc
, fport_close
);
664 scm_set_port_seek (tc
, fport_seek
);
665 scm_set_port_truncate (tc
, fport_truncate
);
666 scm_set_port_input_waiting (tc
, fport_input_waiting
);
673 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
674 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
675 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));