1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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. */
50 #include "libguile/_scm.h"
51 #include "libguile/strings.h"
52 #include "libguile/validate.h"
53 #include "libguile/gc.h"
55 #include "libguile/fports.h"
68 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
74 #include "libguile/iselect.h"
76 /* Some defines for Windows (native port, not Cygwin). */
78 # include <sys/stat.h>
79 # include <winsock2.h>
80 # define ftruncate(fd, size) chsize (fd, size)
81 #endif /* __MINGW32__ */
84 scm_t_bits scm_tc16_fport
;
87 /* default buffer size, used if the O/S won't supply a value. */
88 static const size_t default_buffer_size
= 1024;
90 /* create FPORT buffer with specified sizes (or -1 to use default size or
93 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
94 #define FUNC_NAME "scm_fport_buffer_add"
96 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
98 if (read_size
== -1 || write_size
== -1)
101 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
103 scm_t_fport
*fp
= SCM_FSTREAM (port
);
105 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
108 default_size
= default_buffer_size
;
111 read_size
= default_size
;
112 if (write_size
== -1)
113 write_size
= default_size
;
116 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
118 pt
->read_buf
= scm_gc_malloc (read_size
, "port buffer");
119 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
120 pt
->read_buf_size
= read_size
;
124 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
125 pt
->read_buf_size
= 1;
128 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
130 pt
->write_buf
= scm_gc_malloc (write_size
, "port buffer");
131 pt
->write_pos
= pt
->write_buf
;
132 pt
->write_buf_size
= write_size
;
136 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
137 pt
->write_buf_size
= 1;
140 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
141 if (read_size
> 0 || write_size
> 0)
142 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
144 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
148 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
149 (SCM port
, SCM mode
, SCM size
),
150 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
157 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
158 "If @var{size} is omitted, a default size will be used.\n"
160 #define FUNC_NAME s_scm_setvbuf
166 port
= SCM_COERCE_OUTPORT (port
);
168 SCM_VALIDATE_OPFPORT (1,port
);
169 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
170 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
171 scm_out_of_range (FUNC_NAME
, mode
);
175 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
180 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
183 if (SCM_UNBNDP (size
))
192 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
193 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
194 scm_out_of_range (FUNC_NAME
, size
);
197 pt
= SCM_PTAB_ENTRY (port
);
199 /* silently discards buffered and put-back chars. */
200 if (pt
->read_buf
== pt
->putback_buf
)
202 pt
->read_buf
= pt
->saved_read_buf
;
203 pt
->read_pos
= pt
->saved_read_pos
;
204 pt
->read_end
= pt
->saved_read_end
;
205 pt
->read_buf_size
= pt
->saved_read_buf_size
;
207 if (pt
->read_buf
!= &pt
->shortbuf
)
208 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
209 if (pt
->write_buf
!= &pt
->shortbuf
)
210 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
212 scm_fport_buffer_add (port
, csize
, csize
);
213 return SCM_UNSPECIFIED
;
217 /* Move ports with the specified file descriptor to new descriptors,
218 * resetting the revealed count to 0.
222 scm_evict_ports (int fd
)
226 for (i
= 0; i
< scm_i_port_table_size
; i
++)
228 SCM port
= scm_i_port_table
[i
]->port
;
230 if (SCM_FPORTP (port
))
232 scm_t_fport
*fp
= SCM_FSTREAM (port
);
238 scm_syserror ("scm_evict_ports");
239 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
246 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
248 "Determine whether @var{obj} is a port that is related to a file.")
249 #define FUNC_NAME s_scm_file_port_p
251 return SCM_BOOL (SCM_FPORTP (obj
));
257 * Return a new port open on a given file.
259 * The mode string must match the pattern: [rwa+]** which
260 * is interpreted in the usual unix way.
262 * Return the new port.
264 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
265 (SCM filename
, SCM mode
),
266 "Open the file whose name is @var{filename}, and return a port\n"
267 "representing that file. The attributes of the port are\n"
268 "determined by the @var{mode} string. The way in which this is\n"
269 "interpreted is similar to C stdio. The first character must be\n"
270 "one of the following:\n"
273 "Open an existing file for input.\n"
275 "Open a file for output, creating it if it doesn't already exist\n"
276 "or removing its contents if it does.\n"
278 "Open a file for output, creating it if it doesn't already\n"
279 "exist. All writes to the port will go to the end of the file.\n"
280 "The \"append mode\" can be turned off while the port is in use\n"
281 "@pxref{Ports and File Descriptors, fcntl}\n"
283 "The following additional characters can be appended:\n"
286 "Open the port for both input and output. E.g., @code{r+}: open\n"
287 "an existing file for both input and output.\n"
289 "Create an \"unbuffered\" port. In this case input and output\n"
290 "operations are passed directly to the underlying port\n"
291 "implementation without additional buffering. This is likely to\n"
292 "slow down I/O operations. The buffering mode can be changed\n"
293 "while a port is in use @pxref{Ports and File Descriptors,\n"
296 "Add line-buffering to the port. The port output buffer will be\n"
297 "automatically flushed whenever a newline character is written.\n"
299 "In theory we could create read/write ports which were buffered\n"
300 "in one direction only. However this isn't included in the\n"
301 "current interfaces. If a file cannot be opened with the access\n"
302 "requested, @code{open-file} throws an exception.")
303 #define FUNC_NAME s_scm_open_file
312 SCM_VALIDATE_STRING (1, filename
);
313 SCM_VALIDATE_STRING (2, mode
);
315 file
= SCM_STRING_CHARS (filename
);
316 md
= SCM_STRING_CHARS (mode
);
324 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
327 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
330 scm_out_of_range (FUNC_NAME
, mode
);
338 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
341 #if defined (O_BINARY)
345 case '0': /* unbuffered: handled later. */
346 case 'l': /* line buffered: handled during output. */
349 scm_out_of_range (FUNC_NAME
, mode
);
353 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
358 SCM_SYSERROR_MSG ("~A: ~S",
359 scm_cons (scm_makfrom0str (strerror (en
)),
360 scm_cons (filename
, SCM_EOL
)), en
);
362 port
= scm_fdes_to_port (fdes
, md
, filename
);
370 * Try getting the appropiate file flags for a given file descriptor
371 * under Windows. This incorporates some fancy operations because Windows
372 * differentiates between file, pipe and socket descriptors.
375 # define O_ACCMODE 0x0003
378 static int getflags (int fdes
)
382 int error
, optlen
= sizeof (int);
384 /* Is this a socket ? */
385 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
387 /* Maybe a regular file ? */
388 else if (fstat (fdes
, &buf
) < 0)
392 /* Or an anonymous pipe handle ? */
393 if (buf
.st_mode
& _S_IFIFO
)
394 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
395 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
397 else if (fdes
== fileno (stdin
) && isatty (fdes
))
399 /* stdout / stderr ? */
400 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
408 #endif /* __MINGW32__ */
410 /* Building Guile ports from a file descriptor. */
412 /* Build a Scheme port from an open file descriptor `fdes'.
413 MODE indicates whether FILE is open for reading or writing; it uses
414 the same notation as open-file's second argument.
415 NAME is a string to be used as the port's filename.
418 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
419 #define FUNC_NAME "scm_fdes_to_port"
421 long mode_bits
= scm_mode_bits (mode
);
426 /* test that fdes is valid. */
428 flags
= getflags (fdes
);
430 flags
= fcntl (fdes
, F_GETFL
, 0);
436 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
437 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
439 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
444 port
= scm_new_port_table_entry (scm_tc16_fport
);
445 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
446 pt
= SCM_PTAB_ENTRY(port
);
449 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
452 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
453 SCM_SETSTREAM (port
, fp
);
454 if (mode_bits
& SCM_BUF0
)
455 scm_fport_buffer_add (port
, 0, 0);
457 scm_fport_buffer_add (port
, -1, -1);
459 SCM_SET_FILENAME (port
, name
);
465 /* Return a lower bound on the number of bytes available for input. */
467 fport_input_waiting (SCM port
)
469 int fdes
= SCM_FSTREAM (port
)->fdes
;
472 struct timeval timeout
;
473 SELECT_TYPE read_set
;
474 SELECT_TYPE write_set
;
475 SELECT_TYPE except_set
;
478 FD_ZERO (&write_set
);
479 FD_ZERO (&except_set
);
481 FD_SET (fdes
, &read_set
);
486 if (select (SELECT_SET_SIZE
,
487 &read_set
, &write_set
, &except_set
, &timeout
)
489 scm_syserror ("fport_input_waiting");
490 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
491 #elif defined (FIONREAD)
493 ioctl(fdes
, FIONREAD
, &remir
);
496 scm_misc_error ("fport_input_waiting",
497 "Not fully implemented on this platform",
504 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
506 scm_puts ("#<", port
);
507 scm_print_port_mode (exp
, port
);
508 if (SCM_OPFPORTP (exp
))
511 SCM name
= SCM_FILENAME (exp
);
512 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
513 scm_display (name
, port
);
515 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
516 scm_putc (' ', port
);
517 fdes
= (SCM_FSTREAM (exp
))->fdes
;
521 scm_puts (ttyname (fdes
), port
);
523 #endif /* HAVE_TTYNAME */
524 scm_intprint (fdes
, 10, port
);
528 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
529 scm_putc (' ', port
);
530 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
532 scm_putc ('>', port
);
536 /* thread-local block for input on fport's fdes. */
538 fport_wait_for_input (SCM port
)
540 int fdes
= SCM_FSTREAM (port
)->fdes
;
542 if (!fport_input_waiting (port
))
546 int flags
= fcntl (fdes
, F_GETFL
);
549 scm_syserror ("scm_fdes_wait_for_input");
550 if (!(flags
& O_NONBLOCK
))
554 FD_SET (fdes
, &readfds
);
555 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
557 while (n
== -1 && errno
== EINTR
);
561 static void fport_flush (SCM port
);
563 /* fill a port's read-buffer with a single read. returns the first
564 char or EOF if end of file. */
566 fport_fill_input (SCM port
)
569 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
570 scm_t_fport
*fp
= SCM_FSTREAM (port
);
572 fport_wait_for_input (port
);
573 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
575 scm_syserror ("fport_fill_input");
580 pt
->read_pos
= pt
->read_buf
;
581 pt
->read_end
= pt
->read_buf
+ count
;
582 return *pt
->read_buf
;
587 fport_seek (SCM port
, off_t offset
, int whence
)
589 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
590 scm_t_fport
*fp
= SCM_FSTREAM (port
);
594 if (pt
->rw_active
== SCM_PORT_WRITE
)
596 if (offset
!= 0 || whence
!= SEEK_CUR
)
599 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
603 /* read current position without disturbing the buffer. */
604 rv
= lseek (fp
->fdes
, offset
, whence
);
605 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
608 else if (pt
->rw_active
== SCM_PORT_READ
)
610 if (offset
!= 0 || whence
!= SEEK_CUR
)
612 /* could expand to avoid a second seek. */
613 scm_end_input (port
);
614 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
618 /* read current position without disturbing the buffer
619 (particularly the unread-char buffer). */
620 rv
= lseek (fp
->fdes
, offset
, whence
);
621 result
= rv
- (pt
->read_end
- pt
->read_pos
);
623 if (pt
->read_buf
== pt
->putback_buf
)
624 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
627 else /* SCM_PORT_NEITHER */
629 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
633 scm_syserror ("fport_seek");
639 fport_truncate (SCM port
, off_t length
)
641 scm_t_fport
*fp
= SCM_FSTREAM (port
);
643 if (ftruncate (fp
->fdes
, length
) == -1)
644 scm_syserror ("ftruncate");
647 /* helper for fport_write: try to write data, using multiple system
648 calls if required. */
649 #define FUNC_NAME "write_all"
650 static void write_all (SCM port
, const void *data
, size_t remaining
)
652 int fdes
= SCM_FSTREAM (port
)->fdes
;
654 while (remaining
> 0)
658 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
663 data
= ((const char *) data
) + done
;
669 fport_write (SCM port
, const void *data
, size_t size
)
671 /* this procedure tries to minimize the number of writes/flushes. */
672 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
674 if (pt
->write_buf
== &pt
->shortbuf
675 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
677 /* "unbuffered" port, or
678 port with empty buffer and data won't fit in buffer. */
679 write_all (port
, data
, size
);
684 off_t space
= pt
->write_end
- pt
->write_pos
;
688 /* data fits in buffer. */
689 memcpy (pt
->write_pos
, data
, size
);
690 pt
->write_pos
+= size
;
691 if (pt
->write_pos
== pt
->write_end
)
694 /* we can skip the line-buffering check if nothing's buffered. */
700 memcpy (pt
->write_pos
, data
, space
);
701 pt
->write_pos
= pt
->write_end
;
704 const void *ptr
= ((const char *) data
) + space
;
705 size_t remaining
= size
- space
;
707 if (size
>= pt
->write_buf_size
)
709 write_all (port
, ptr
, remaining
);
714 memcpy (pt
->write_pos
, ptr
, remaining
);
715 pt
->write_pos
+= remaining
;
720 /* handle line buffering. */
721 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
726 /* becomes 1 when process is exiting: normal exception handling won't
727 work by this time. */
728 extern int scm_i_terminating
;
731 fport_flush (SCM port
)
733 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
734 scm_t_fport
*fp
= SCM_FSTREAM (port
);
735 unsigned char *ptr
= pt
->write_buf
;
736 long init_size
= pt
->write_pos
- pt
->write_buf
;
737 long remaining
= init_size
;
739 while (remaining
> 0)
743 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
746 /* error. assume nothing was written this call, but
747 fix up the buffer for any previous successful writes. */
748 long done
= init_size
- remaining
;
754 for (i
= 0; i
< remaining
; i
++)
756 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
758 pt
->write_pos
= pt
->write_buf
+ remaining
;
760 if (scm_i_terminating
)
762 const char *msg
= "Error: could not flush file-descriptor ";
765 write (2, msg
, strlen (msg
));
766 sprintf (buf
, "%d\n", fp
->fdes
);
767 write (2, buf
, strlen (buf
));
771 else if (scm_gc_running_p
)
773 /* silently ignore the error. scm_error would abort if we
778 scm_syserror ("fport_flush");
783 pt
->write_pos
= pt
->write_buf
;
784 pt
->rw_active
= SCM_PORT_NEITHER
;
787 /* clear the read buffer and adjust the file position for unread bytes. */
789 fport_end_input (SCM port
, int offset
)
791 scm_t_fport
*fp
= SCM_FSTREAM (port
);
792 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
794 offset
+= pt
->read_end
- pt
->read_pos
;
798 pt
->read_pos
= pt
->read_end
;
799 /* will throw error if unread-char used at beginning of file
800 then attempting to write. seems correct. */
801 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
802 scm_syserror ("fport_end_input");
804 pt
->rw_active
= SCM_PORT_NEITHER
;
808 fport_close (SCM port
)
810 scm_t_fport
*fp
= SCM_FSTREAM (port
);
811 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
815 SCM_SYSCALL (rv
= close (fp
->fdes
));
816 if (rv
== -1 && errno
!= EBADF
)
818 if (scm_gc_running_p
)
819 /* silently ignore the error. scm_error would abort if we
823 scm_syserror ("fport_close");
825 if (pt
->read_buf
== pt
->putback_buf
)
826 pt
->read_buf
= pt
->saved_read_buf
;
827 if (pt
->read_buf
!= &pt
->shortbuf
)
828 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
829 if (pt
->write_buf
!= &pt
->shortbuf
)
830 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
831 scm_gc_free (fp
, sizeof (*fp
), "file port");
836 fport_free (SCM port
)
845 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
847 scm_set_port_free (tc
, fport_free
);
848 scm_set_port_print (tc
, fport_print
);
849 scm_set_port_flush (tc
, fport_flush
);
850 scm_set_port_end_input (tc
, fport_end_input
);
851 scm_set_port_close (tc
, fport_close
);
852 scm_set_port_seek (tc
, fport_seek
);
853 scm_set_port_truncate (tc
, fport_truncate
);
854 scm_set_port_input_waiting (tc
, fport_input_waiting
);
862 scm_tc16_fport
= scm_make_fptob ();
864 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
865 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
866 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
868 #include "libguile/fports.x"