1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
26 #include "libguile/_scm.h"
27 #include "libguile/strings.h"
28 #include "libguile/validate.h"
29 #include "libguile/gc.h"
31 #include "libguile/fports.h"
44 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
50 #include "libguile/iselect.h"
52 /* Some defines for Windows (native port, not Cygwin). */
54 # include <sys/stat.h>
55 # include <winsock2.h>
56 # define ftruncate(fd, size) chsize (fd, size)
57 #endif /* __MINGW32__ */
60 scm_t_bits scm_tc16_fport
;
63 /* default buffer size, used if the O/S won't supply a value. */
64 static const size_t default_buffer_size
= 1024;
66 /* create FPORT buffer with specified sizes (or -1 to use default size or
69 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
70 #define FUNC_NAME "scm_fport_buffer_add"
72 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
74 if (read_size
== -1 || write_size
== -1)
77 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
79 scm_t_fport
*fp
= SCM_FSTREAM (port
);
81 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
84 default_size
= default_buffer_size
;
87 read_size
= default_size
;
89 write_size
= default_size
;
92 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
94 pt
->read_buf
= scm_gc_malloc (read_size
, "port buffer");
95 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
96 pt
->read_buf_size
= read_size
;
100 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
101 pt
->read_buf_size
= 1;
104 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
106 pt
->write_buf
= scm_gc_malloc (write_size
, "port buffer");
107 pt
->write_pos
= pt
->write_buf
;
108 pt
->write_buf_size
= write_size
;
112 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
113 pt
->write_buf_size
= 1;
116 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
117 if (read_size
> 0 || write_size
> 0)
118 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
120 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
124 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
125 (SCM port
, SCM mode
, SCM size
),
126 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
133 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
134 "If @var{size} is omitted, a default size will be used.\n"
136 #define FUNC_NAME s_scm_setvbuf
142 port
= SCM_COERCE_OUTPORT (port
);
144 SCM_VALIDATE_OPFPORT (1,port
);
145 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
146 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
147 scm_out_of_range (FUNC_NAME
, mode
);
151 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
156 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
159 if (SCM_UNBNDP (size
))
168 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
169 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
170 scm_out_of_range (FUNC_NAME
, size
);
173 pt
= SCM_PTAB_ENTRY (port
);
175 /* silently discards buffered and put-back chars. */
176 if (pt
->read_buf
== pt
->putback_buf
)
178 pt
->read_buf
= pt
->saved_read_buf
;
179 pt
->read_pos
= pt
->saved_read_pos
;
180 pt
->read_end
= pt
->saved_read_end
;
181 pt
->read_buf_size
= pt
->saved_read_buf_size
;
183 if (pt
->read_buf
!= &pt
->shortbuf
)
184 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
185 if (pt
->write_buf
!= &pt
->shortbuf
)
186 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
188 scm_fport_buffer_add (port
, csize
, csize
);
189 return SCM_UNSPECIFIED
;
193 /* Move ports with the specified file descriptor to new descriptors,
194 * resetting the revealed count to 0.
198 scm_evict_ports (int fd
)
202 for (i
= 0; i
< scm_i_port_table_size
; i
++)
204 SCM port
= scm_i_port_table
[i
]->port
;
206 if (SCM_FPORTP (port
))
208 scm_t_fport
*fp
= SCM_FSTREAM (port
);
214 scm_syserror ("scm_evict_ports");
215 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
222 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
224 "Determine whether @var{obj} is a port that is related to a file.")
225 #define FUNC_NAME s_scm_file_port_p
227 return SCM_BOOL (SCM_FPORTP (obj
));
233 * Return a new port open on a given file.
235 * The mode string must match the pattern: [rwa+]** which
236 * is interpreted in the usual unix way.
238 * Return the new port.
240 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
241 (SCM filename
, SCM mode
),
242 "Open the file whose name is @var{filename}, and return a port\n"
243 "representing that file. The attributes of the port are\n"
244 "determined by the @var{mode} string. The way in which this is\n"
245 "interpreted is similar to C stdio. The first character must be\n"
246 "one of the following:\n"
249 "Open an existing file for input.\n"
251 "Open a file for output, creating it if it doesn't already exist\n"
252 "or removing its contents if it does.\n"
254 "Open a file for output, creating it if it doesn't already\n"
255 "exist. All writes to the port will go to the end of the file.\n"
256 "The \"append mode\" can be turned off while the port is in use\n"
257 "@pxref{Ports and File Descriptors, fcntl}\n"
259 "The following additional characters can be appended:\n"
262 "Open the port for both input and output. E.g., @code{r+}: open\n"
263 "an existing file for both input and output.\n"
265 "Create an \"unbuffered\" port. In this case input and output\n"
266 "operations are passed directly to the underlying port\n"
267 "implementation without additional buffering. This is likely to\n"
268 "slow down I/O operations. The buffering mode can be changed\n"
269 "while a port is in use @pxref{Ports and File Descriptors,\n"
272 "Add line-buffering to the port. The port output buffer will be\n"
273 "automatically flushed whenever a newline character is written.\n"
275 "In theory we could create read/write ports which were buffered\n"
276 "in one direction only. However this isn't included in the\n"
277 "current interfaces. If a file cannot be opened with the access\n"
278 "requested, @code{open-file} throws an exception.")
279 #define FUNC_NAME s_scm_open_file
288 SCM_VALIDATE_STRING (1, filename
);
289 SCM_VALIDATE_STRING (2, mode
);
291 file
= SCM_STRING_CHARS (filename
);
292 md
= SCM_STRING_CHARS (mode
);
300 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
303 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
306 scm_out_of_range (FUNC_NAME
, mode
);
314 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
317 #if defined (O_BINARY)
321 case '0': /* unbuffered: handled later. */
322 case 'l': /* line buffered: handled during output. */
325 scm_out_of_range (FUNC_NAME
, mode
);
329 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
334 SCM_SYSERROR_MSG ("~A: ~S",
335 scm_cons (scm_makfrom0str (strerror (en
)),
336 scm_cons (filename
, SCM_EOL
)), en
);
338 port
= scm_fdes_to_port (fdes
, md
, filename
);
346 * Try getting the appropiate file flags for a given file descriptor
347 * under Windows. This incorporates some fancy operations because Windows
348 * differentiates between file, pipe and socket descriptors.
351 # define O_ACCMODE 0x0003
354 static int getflags (int fdes
)
358 int error
, optlen
= sizeof (int);
360 /* Is this a socket ? */
361 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
363 /* Maybe a regular file ? */
364 else if (fstat (fdes
, &buf
) < 0)
368 /* Or an anonymous pipe handle ? */
369 if (buf
.st_mode
& _S_IFIFO
)
370 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
371 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
373 else if (fdes
== fileno (stdin
) && isatty (fdes
))
375 /* stdout / stderr ? */
376 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
384 #endif /* __MINGW32__ */
386 /* Building Guile ports from a file descriptor. */
388 /* Build a Scheme port from an open file descriptor `fdes'.
389 MODE indicates whether FILE is open for reading or writing; it uses
390 the same notation as open-file's second argument.
391 NAME is a string to be used as the port's filename.
394 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
395 #define FUNC_NAME "scm_fdes_to_port"
397 long mode_bits
= scm_mode_bits (mode
);
402 /* test that fdes is valid. */
404 flags
= getflags (fdes
);
406 flags
= fcntl (fdes
, F_GETFL
, 0);
412 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
413 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
415 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
420 port
= scm_new_port_table_entry (scm_tc16_fport
);
421 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
422 pt
= SCM_PTAB_ENTRY(port
);
425 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
428 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
429 SCM_SETSTREAM (port
, fp
);
430 if (mode_bits
& SCM_BUF0
)
431 scm_fport_buffer_add (port
, 0, 0);
433 scm_fport_buffer_add (port
, -1, -1);
435 SCM_SET_FILENAME (port
, name
);
441 /* Return a lower bound on the number of bytes available for input. */
443 fport_input_waiting (SCM port
)
445 int fdes
= SCM_FSTREAM (port
)->fdes
;
448 struct timeval timeout
;
449 SELECT_TYPE read_set
;
450 SELECT_TYPE write_set
;
451 SELECT_TYPE except_set
;
454 FD_ZERO (&write_set
);
455 FD_ZERO (&except_set
);
457 FD_SET (fdes
, &read_set
);
462 if (select (SELECT_SET_SIZE
,
463 &read_set
, &write_set
, &except_set
, &timeout
)
465 scm_syserror ("fport_input_waiting");
466 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
467 #elif defined (FIONREAD)
469 ioctl(fdes
, FIONREAD
, &remir
);
472 scm_misc_error ("fport_input_waiting",
473 "Not fully implemented on this platform",
480 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
482 scm_puts ("#<", port
);
483 scm_print_port_mode (exp
, port
);
484 if (SCM_OPFPORTP (exp
))
487 SCM name
= SCM_FILENAME (exp
);
488 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
489 scm_display (name
, port
);
491 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
492 scm_putc (' ', port
);
493 fdes
= (SCM_FSTREAM (exp
))->fdes
;
497 scm_puts (ttyname (fdes
), port
);
499 #endif /* HAVE_TTYNAME */
500 scm_intprint (fdes
, 10, port
);
504 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
505 scm_putc (' ', port
);
506 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
508 scm_putc ('>', port
);
512 /* thread-local block for input on fport's fdes. */
514 fport_wait_for_input (SCM port
)
516 int fdes
= SCM_FSTREAM (port
)->fdes
;
518 if (!fport_input_waiting (port
))
522 int flags
= fcntl (fdes
, F_GETFL
);
525 scm_syserror ("scm_fdes_wait_for_input");
526 if (!(flags
& O_NONBLOCK
))
530 FD_SET (fdes
, &readfds
);
531 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
533 while (n
== -1 && errno
== EINTR
);
537 static void fport_flush (SCM port
);
539 /* fill a port's read-buffer with a single read. returns the first
540 char or EOF if end of file. */
542 fport_fill_input (SCM port
)
545 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
546 scm_t_fport
*fp
= SCM_FSTREAM (port
);
548 fport_wait_for_input (port
);
549 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
551 scm_syserror ("fport_fill_input");
556 pt
->read_pos
= pt
->read_buf
;
557 pt
->read_end
= pt
->read_buf
+ count
;
558 return *pt
->read_buf
;
563 fport_seek (SCM port
, off_t offset
, int whence
)
565 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
566 scm_t_fport
*fp
= SCM_FSTREAM (port
);
570 if (pt
->rw_active
== SCM_PORT_WRITE
)
572 if (offset
!= 0 || whence
!= SEEK_CUR
)
575 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
579 /* read current position without disturbing the buffer. */
580 rv
= lseek (fp
->fdes
, offset
, whence
);
581 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
584 else if (pt
->rw_active
== SCM_PORT_READ
)
586 if (offset
!= 0 || whence
!= SEEK_CUR
)
588 /* could expand to avoid a second seek. */
589 scm_end_input (port
);
590 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
594 /* read current position without disturbing the buffer
595 (particularly the unread-char buffer). */
596 rv
= lseek (fp
->fdes
, offset
, whence
);
597 result
= rv
- (pt
->read_end
- pt
->read_pos
);
599 if (pt
->read_buf
== pt
->putback_buf
)
600 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
603 else /* SCM_PORT_NEITHER */
605 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
609 scm_syserror ("fport_seek");
615 fport_truncate (SCM port
, off_t length
)
617 scm_t_fport
*fp
= SCM_FSTREAM (port
);
619 if (ftruncate (fp
->fdes
, length
) == -1)
620 scm_syserror ("ftruncate");
623 /* helper for fport_write: try to write data, using multiple system
624 calls if required. */
625 #define FUNC_NAME "write_all"
626 static void write_all (SCM port
, const void *data
, size_t remaining
)
628 int fdes
= SCM_FSTREAM (port
)->fdes
;
630 while (remaining
> 0)
634 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
639 data
= ((const char *) data
) + done
;
645 fport_write (SCM port
, const void *data
, size_t size
)
647 /* this procedure tries to minimize the number of writes/flushes. */
648 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
650 if (pt
->write_buf
== &pt
->shortbuf
651 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
653 /* "unbuffered" port, or
654 port with empty buffer and data won't fit in buffer. */
655 write_all (port
, data
, size
);
660 off_t space
= pt
->write_end
- pt
->write_pos
;
664 /* data fits in buffer. */
665 memcpy (pt
->write_pos
, data
, size
);
666 pt
->write_pos
+= size
;
667 if (pt
->write_pos
== pt
->write_end
)
670 /* we can skip the line-buffering check if nothing's buffered. */
676 memcpy (pt
->write_pos
, data
, space
);
677 pt
->write_pos
= pt
->write_end
;
680 const void *ptr
= ((const char *) data
) + space
;
681 size_t remaining
= size
- space
;
683 if (size
>= pt
->write_buf_size
)
685 write_all (port
, ptr
, remaining
);
690 memcpy (pt
->write_pos
, ptr
, remaining
);
691 pt
->write_pos
+= remaining
;
696 /* handle line buffering. */
697 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
702 /* becomes 1 when process is exiting: normal exception handling won't
703 work by this time. */
704 extern int scm_i_terminating
;
707 fport_flush (SCM port
)
709 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
710 scm_t_fport
*fp
= SCM_FSTREAM (port
);
711 unsigned char *ptr
= pt
->write_buf
;
712 long init_size
= pt
->write_pos
- pt
->write_buf
;
713 long remaining
= init_size
;
715 while (remaining
> 0)
719 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
722 /* error. assume nothing was written this call, but
723 fix up the buffer for any previous successful writes. */
724 long done
= init_size
- remaining
;
730 for (i
= 0; i
< remaining
; i
++)
732 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
734 pt
->write_pos
= pt
->write_buf
+ remaining
;
736 if (scm_i_terminating
)
738 const char *msg
= "Error: could not flush file-descriptor ";
741 write (2, msg
, strlen (msg
));
742 sprintf (buf
, "%d\n", fp
->fdes
);
743 write (2, buf
, strlen (buf
));
747 else if (scm_gc_running_p
)
749 /* silently ignore the error. scm_error would abort if we
754 scm_syserror ("fport_flush");
759 pt
->write_pos
= pt
->write_buf
;
760 pt
->rw_active
= SCM_PORT_NEITHER
;
763 /* clear the read buffer and adjust the file position for unread bytes. */
765 fport_end_input (SCM port
, int offset
)
767 scm_t_fport
*fp
= SCM_FSTREAM (port
);
768 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
770 offset
+= pt
->read_end
- pt
->read_pos
;
774 pt
->read_pos
= pt
->read_end
;
775 /* will throw error if unread-char used at beginning of file
776 then attempting to write. seems correct. */
777 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
778 scm_syserror ("fport_end_input");
780 pt
->rw_active
= SCM_PORT_NEITHER
;
784 fport_close (SCM port
)
786 scm_t_fport
*fp
= SCM_FSTREAM (port
);
787 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
791 SCM_SYSCALL (rv
= close (fp
->fdes
));
792 if (rv
== -1 && errno
!= EBADF
)
794 if (scm_gc_running_p
)
795 /* silently ignore the error. scm_error would abort if we
799 scm_syserror ("fport_close");
801 if (pt
->read_buf
== pt
->putback_buf
)
802 pt
->read_buf
= pt
->saved_read_buf
;
803 if (pt
->read_buf
!= &pt
->shortbuf
)
804 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
805 if (pt
->write_buf
!= &pt
->shortbuf
)
806 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
807 scm_gc_free (fp
, sizeof (*fp
), "file port");
812 fport_free (SCM port
)
821 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
823 scm_set_port_free (tc
, fport_free
);
824 scm_set_port_print (tc
, fport_print
);
825 scm_set_port_flush (tc
, fport_flush
);
826 scm_set_port_end_input (tc
, fport_end_input
);
827 scm_set_port_close (tc
, fport_close
);
828 scm_set_port_seek (tc
, fport_seek
);
829 scm_set_port_truncate (tc
, fport_truncate
);
830 scm_set_port_input_waiting (tc
, fport_input_waiting
);
838 scm_tc16_fport
= scm_make_fptob ();
840 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
841 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
842 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
844 #include "libguile/fports.x"