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.
194 for (i
= 0; i
< scm_port_table_size
; i
++)
196 SCM port
= scm_port_table
[i
]->port
;
198 if (SCM_FPORTP (port
))
200 struct scm_fport
*fp
= SCM_FSTREAM (port
);
206 scm_syserror ("scm_evict_ports");
207 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
214 * Return a new port open on a given file.
216 * The mode string must match the pattern: [rwa+]** which
217 * is interpreted in the usual unix way.
219 * Return the new port.
221 GUILE_PROC(scm_open_file
, "open-file", 2, 0, 0,
222 (SCM filename
, SCM modes
),
224 #define FUNC_NAME s_scm_open_file
233 SCM_VALIDATE_ROSTRING(1,filename
);
234 SCM_VALIDATE_ROSTRING(2,modes
);
235 if (SCM_SUBSTRP (filename
))
236 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
237 if (SCM_SUBSTRP (modes
))
238 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
240 file
= SCM_ROCHARS (filename
);
241 mode
= SCM_ROCHARS (modes
);
249 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
252 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
255 scm_out_of_range (FUNC_NAME
, modes
);
263 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
265 case '0': /* unbuffered: handled later. */
266 case 'b': /* 'binary' mode: ignored. */
267 case 'l': /* line buffered: handled during output. */
270 scm_out_of_range (FUNC_NAME
, modes
);
274 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
279 scm_syserror_msg (FUNC_NAME
, "%s: %S",
280 scm_cons (scm_makfrom0str (strerror (en
)),
281 scm_cons (filename
, SCM_EOL
)),
284 port
= scm_fdes_to_port (fdes
, mode
, filename
);
290 /* Building Guile ports from a file descriptor. */
292 /* Build a Scheme port from an open file descriptor `fdes'.
293 MODE indicates whether FILE is open for reading or writing; it uses
294 the same notation as open-file's second argument.
295 Use NAME as the port's filename. */
298 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
300 long mode_bits
= scm_mode_bits (mode
);
306 pt
= scm_add_to_port_table (port
);
307 SCM_SETPTAB_ENTRY (port
, pt
);
308 SCM_SETCAR (port
, (scm_tc16_fport
| mode_bits
));
312 = (struct scm_fport
*) malloc (sizeof (struct scm_fport
));
314 scm_memory_error ("scm_fdes_to_port");
316 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
317 SCM_SETSTREAM (port
, fp
);
318 if (mode_bits
& SCM_BUF0
)
319 scm_fport_buffer_add (port
, 0, 0);
321 scm_fport_buffer_add (port
, -1, -1);
323 SCM_PTAB_ENTRY (port
)->file_name
= name
;
329 /* Return a lower bound on the number of bytes available for input. */
331 fport_input_waiting (SCM port
)
333 int fdes
= SCM_FSTREAM (port
)->fdes
;
336 struct timeval timeout
;
337 SELECT_TYPE read_set
;
338 SELECT_TYPE write_set
;
339 SELECT_TYPE except_set
;
342 FD_ZERO (&write_set
);
343 FD_ZERO (&except_set
);
345 FD_SET (fdes
, &read_set
);
350 if (select (SELECT_SET_SIZE
,
351 &read_set
, &write_set
, &except_set
, &timeout
)
353 scm_syserror ("fport_input_waiting");
354 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
355 #elif defined (FIONREAD)
357 ioctl(fdes
, FIONREAD
, &remir
);
360 scm_misc_error ("fport_input_waiting",
361 "Not fully implemented on this platform",
368 prinfport (SCM exp
,SCM port
,scm_print_state
*pstate
)
370 scm_puts ("#<", port
);
371 scm_print_port_mode (exp
, port
);
372 if (SCM_OPFPORTP (exp
))
375 SCM name
= SCM_PTAB_ENTRY (exp
)->file_name
;
376 scm_puts (SCM_NIMP (name
) && SCM_ROSTRINGP (name
)
378 : SCM_PTOBNAME (SCM_PTOBNUM (exp
)),
380 scm_putc (' ', port
);
381 fdes
= (SCM_FSTREAM (exp
))->fdes
;
384 scm_puts (ttyname (fdes
), port
);
386 scm_intprint (fdes
, 10, port
);
390 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
391 scm_putc (' ', port
);
392 scm_intprint (SCM_CDR (exp
), 16, port
);
394 scm_putc ('>', port
);
399 /* thread-local block for input on fport's fdes. */
401 fport_wait_for_input (SCM port
)
403 int fdes
= SCM_FSTREAM (port
)->fdes
;
405 if (!fport_input_waiting (port
))
409 int flags
= fcntl (fdes
, F_GETFL
);
412 scm_syserror ("scm_fdes_wait_for_input");
413 if (!(flags
& O_NONBLOCK
))
417 FD_SET (fdes
, &readfds
);
418 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
420 while (n
== -1 && errno
== EINTR
);
425 static void fport_flush (SCM port
);
427 /* fill a port's read-buffer with a single read.
428 returns the first char and moves the read_pos pointer past it.
429 or returns EOF if end of file. */
431 fport_fill_input (SCM port
)
434 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
435 struct scm_fport
*fp
= SCM_FSTREAM (port
);
438 fport_wait_for_input (port
);
440 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
442 scm_syserror ("fport_fill_input");
447 pt
->read_pos
= pt
->read_buf
;
448 pt
->read_end
= pt
->read_buf
+ count
;
449 return *pt
->read_buf
;
454 fport_seek (SCM port
, off_t offset
, int whence
)
456 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
457 struct scm_fport
*fp
= SCM_FSTREAM (port
);
461 if (pt
->rw_active
== SCM_PORT_WRITE
)
463 if (offset
!= 0 || whence
!= SEEK_CUR
)
466 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
470 /* read current position without disturbing the buffer. */
471 rv
= lseek (fp
->fdes
, offset
, whence
);
472 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
475 else if (pt
->rw_active
== SCM_PORT_READ
)
477 if (offset
!= 0 || whence
!= SEEK_CUR
)
479 /* could expand to avoid a second seek. */
480 scm_end_input (port
);
481 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
485 /* read current position without disturbing the buffer
486 (particularly the unread-char buffer). */
487 rv
= lseek (fp
->fdes
, offset
, whence
);
488 result
= rv
- (pt
->read_end
- pt
->read_pos
);
490 if (pt
->read_buf
== pt
->putback_buf
)
491 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
494 else /* SCM_PORT_NEITHER */
496 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
500 scm_syserror ("fport_seek");
506 fport_truncate (SCM port
, off_t length
)
508 struct scm_fport
*fp
= SCM_FSTREAM (port
);
510 if (ftruncate (fp
->fdes
, length
) == -1)
511 scm_syserror ("ftruncate");
515 fport_write (SCM port
, void *data
, size_t size
)
517 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
519 if (pt
->write_buf
== &pt
->shortbuf
)
521 /* "unbuffered" port. */
522 int fdes
= SCM_FSTREAM (port
)->fdes
;
524 if (write (fdes
, data
, size
) == -1)
525 scm_syserror ("fport_write");
529 const char *input
= (char *) data
;
530 size_t remaining
= size
;
532 while (remaining
> 0)
534 int space
= pt
->write_end
- pt
->write_pos
;
535 int write_len
= (remaining
> space
) ? space
: remaining
;
537 memcpy (pt
->write_pos
, input
, write_len
);
538 pt
->write_pos
+= write_len
;
539 remaining
-= write_len
;
541 if (write_len
== space
)
545 /* handle line buffering. */
546 if ((SCM_CAR (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
551 /* becomes 1 when process is exiting: normal exception handling won't
552 work by this time. */
553 extern int terminating
;
556 fport_flush (SCM port
)
558 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
559 struct scm_fport
*fp
= SCM_FSTREAM (port
);
560 char *ptr
= pt
->write_buf
;
561 int init_size
= pt
->write_pos
- pt
->write_buf
;
562 int remaining
= init_size
;
564 while (remaining
> 0)
568 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
571 /* error. assume nothing was written this call, but
572 fix up the buffer for any previous successful writes. */
573 int done
= init_size
- remaining
;
579 for (i
= 0; i
< remaining
; i
++)
581 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
583 pt
->write_pos
= pt
->write_buf
+ remaining
;
586 scm_syserror ("fport_flush");
589 const char *msg
= "Error: could not flush file-descriptor ";
592 write (2, msg
, strlen (msg
));
593 sprintf (buf
, "%d\n", fp
->fdes
);
594 write (2, buf
, strlen (buf
));
602 pt
->write_pos
= pt
->write_buf
;
603 pt
->rw_active
= SCM_PORT_NEITHER
;
606 /* clear the read buffer and adjust the file position for unread bytes. */
608 fport_end_input (SCM port
, int offset
)
610 struct scm_fport
*fp
= SCM_FSTREAM (port
);
611 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
613 offset
+= pt
->read_end
- pt
->read_pos
;
617 pt
->read_pos
= pt
->read_end
;
618 /* will throw error if unread-char used at beginning of file
619 then attempting to write. seems correct. */
620 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
621 scm_syserror ("fport_end_input");
623 pt
->rw_active
= SCM_PORT_NEITHER
;
627 fport_close (SCM port
)
629 struct scm_fport
*fp
= SCM_FSTREAM (port
);
630 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
634 SCM_SYSCALL (rv
= close (fp
->fdes
));
635 if (rv
== -1 && errno
!= EBADF
)
636 scm_syserror ("fport_close");
637 if (pt
->read_buf
== pt
->putback_buf
)
638 pt
->read_buf
= pt
->saved_read_buf
;
639 if (pt
->read_buf
!= &pt
->shortbuf
)
641 if (pt
->write_buf
!= &pt
->shortbuf
)
642 free (pt
->write_buf
);
648 fport_free (SCM port
)
654 void scm_make_fptob (void); /* Called from ports.c */
659 long tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
660 scm_set_port_free (tc
, fport_free
);
661 scm_set_port_print (tc
, prinfport
);
662 scm_set_port_flush (tc
, fport_flush
);
663 scm_set_port_end_input (tc
, fport_end_input
);
664 scm_set_port_close (tc
, fport_close
);
665 scm_set_port_seek (tc
, fport_seek
);
666 scm_set_port_truncate (tc
, fport_truncate
);
667 scm_set_port_input_waiting (tc
, fport_input_waiting
);
674 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
675 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
676 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));