1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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. */
47 #include "libguile/_scm.h"
48 #include "libguile/strings.h"
49 #include "libguile/validate.h"
50 #include "libguile/gc.h"
52 #include "libguile/fports.h"
65 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
71 #include "libguile/iselect.h"
72 /* Some defines for Windows. */
74 # include <sys/stat.h>
75 # include <winsock2.h>
76 # define ftruncate(fd, size) chsize (fd, size)
77 #endif /* __MINGW32__ */
80 scm_t_bits scm_tc16_fport
;
83 /* default buffer size, used if the O/S won't supply a value. */
84 static const size_t default_buffer_size
= 1024;
86 /* create FPORT buffer with specified sizes (or -1 to use default size or
89 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
90 #define FUNC_NAME "scm_fport_buffer_add"
92 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
94 if (read_size
== -1 || write_size
== -1)
97 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
99 scm_t_fport
*fp
= SCM_FSTREAM (port
);
101 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
104 default_size
= default_buffer_size
;
107 read_size
= default_size
;
108 if (write_size
== -1)
109 write_size
= default_size
;
112 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
114 pt
->read_buf
= scm_must_malloc (read_size
, FUNC_NAME
);
115 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
116 pt
->read_buf_size
= read_size
;
120 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
121 pt
->read_buf_size
= 1;
124 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
126 pt
->write_buf
= scm_must_malloc (write_size
, FUNC_NAME
);
127 pt
->write_pos
= pt
->write_buf
;
128 pt
->write_buf_size
= write_size
;
132 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
133 pt
->write_buf_size
= 1;
136 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
137 if (read_size
> 0 || write_size
> 0)
138 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
140 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
144 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
145 (SCM port
, SCM mode
, SCM size
),
146 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
153 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
154 "If @var{size} is omitted, a default size will be used.\n"
156 #define FUNC_NAME s_scm_setvbuf
162 port
= SCM_COERCE_OUTPORT (port
);
164 SCM_VALIDATE_OPFPORT (1,port
);
165 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
166 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
167 scm_out_of_range (FUNC_NAME
, mode
);
171 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
176 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
179 if (SCM_UNBNDP (size
))
188 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
189 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
190 scm_out_of_range (FUNC_NAME
, size
);
193 pt
= SCM_PTAB_ENTRY (port
);
195 /* silently discards buffered chars. */
196 if (pt
->read_buf
!= &pt
->shortbuf
)
197 scm_must_free (pt
->read_buf
);
198 if (pt
->write_buf
!= &pt
->shortbuf
)
199 scm_must_free (pt
->write_buf
);
201 scm_fport_buffer_add (port
, csize
, csize
);
202 return SCM_UNSPECIFIED
;
206 /* Move ports with the specified file descriptor to new descriptors,
207 * reseting the revealed count to 0.
211 scm_evict_ports (int fd
)
215 for (i
= 0; i
< scm_port_table_size
; i
++)
217 SCM port
= scm_port_table
[i
]->port
;
219 if (SCM_FPORTP (port
))
221 scm_t_fport
*fp
= SCM_FSTREAM (port
);
227 scm_syserror ("scm_evict_ports");
228 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
235 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
237 "Determine whether @var{obj} is a port that is related to a file.")
238 #define FUNC_NAME s_scm_file_port_p
240 return SCM_BOOL (SCM_FPORTP (obj
));
246 * Return a new port open on a given file.
248 * The mode string must match the pattern: [rwa+]** which
249 * is interpreted in the usual unix way.
251 * Return the new port.
253 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
254 (SCM filename
, SCM mode
),
255 "Open the file whose name is @var{filename}, and return a port\n"
256 "representing that file. The attributes of the port are\n"
257 "determined by the @var{mode} string. The way in which this is\n"
258 "interpreted is similar to C stdio. The first character must be\n"
259 "one of the following:\n"
262 "Open an existing file for input.\n"
264 "Open a file for output, creating it if it doesn't already exist\n"
265 "or removing its contents if it does.\n"
267 "Open a file for output, creating it if it doesn't already\n"
268 "exist. All writes to the port will go to the end of the file.\n"
269 "The \"append mode\" can be turned off while the port is in use\n"
270 "@pxref{Ports and File Descriptors, fcntl}\n"
272 "The following additional characters can be appended:\n"
275 "Open the port for both input and output. E.g., @code{r+}: open\n"
276 "an existing file for both input and output.\n"
278 "Create an \"unbuffered\" port. In this case input and output\n"
279 "operations are passed directly to the underlying port\n"
280 "implementation without additional buffering. This is likely to\n"
281 "slow down I/O operations. The buffering mode can be changed\n"
282 "while a port is in use @pxref{Ports and File Descriptors,\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\n"
289 "in one direction only. However this isn't included in the\n"
290 "current interfaces. If a file cannot be opened with the access\n"
291 "requested, @code{open-file} throws an exception.")
292 #define FUNC_NAME s_scm_open_file
301 SCM_VALIDATE_STRING (1, filename
);
302 SCM_VALIDATE_STRING (2, mode
);
304 file
= SCM_STRING_CHARS (filename
);
305 md
= SCM_STRING_CHARS (mode
);
313 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
316 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
319 scm_out_of_range (FUNC_NAME
, mode
);
327 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
330 #if defined (O_BINARY)
334 case '0': /* unbuffered: handled later. */
335 case 'l': /* line buffered: handled during output. */
338 scm_out_of_range (FUNC_NAME
, mode
);
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
, md
, filename
);
359 * Try getting the appropiate file flags for a given file descriptor
360 * under Windows. This incorporates some fancy operations because Windows
361 * differentiates between file, pipe and socket descriptors.
364 # define O_ACCMODE 0x0003
367 static int getflags (int fdes
)
371 int error
, optlen
= sizeof (int);
373 /* Is this a socket ? */
374 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
376 /* Maybe a regular file ? */
377 else if (fstat (fdes
, &buf
) < 0)
381 /* Or an anonymous pipe handle ? */
382 if (buf
.st_mode
& _S_IFIFO
)
385 else if (fdes
== fileno (stdin
) && isatty (fdes
))
387 /* stdout / stderr ? */
388 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
396 #endif /* __MINGW32__ */
398 /* Building Guile ports from a file descriptor. */
400 /* Build a Scheme port from an open file descriptor `fdes'.
401 MODE indicates whether FILE is open for reading or writing; it uses
402 the same notation as open-file's second argument.
403 NAME is a string to be used as the port's filename.
406 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
407 #define FUNC_NAME "scm_fdes_to_port"
409 long mode_bits
= scm_mode_bits (mode
);
414 /* test that fdes is valid. */
416 flags
= getflags (fdes
);
418 flags
= fcntl (fdes
, F_GETFL
, 0);
424 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
425 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
427 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
432 pt
= scm_add_to_port_table (port
);
433 SCM_SETPTAB_ENTRY (port
, pt
);
434 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
438 = (scm_t_fport
*) scm_must_malloc (sizeof (scm_t_fport
),
442 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
443 SCM_SETSTREAM (port
, fp
);
444 if (mode_bits
& SCM_BUF0
)
445 scm_fport_buffer_add (port
, 0, 0);
447 scm_fport_buffer_add (port
, -1, -1);
449 SCM_SET_FILENAME (port
, name
);
455 /* Return a lower bound on the number of bytes available for input. */
457 fport_input_waiting (SCM port
)
459 int fdes
= SCM_FSTREAM (port
)->fdes
;
462 struct timeval timeout
;
463 SELECT_TYPE read_set
;
464 SELECT_TYPE write_set
;
465 SELECT_TYPE except_set
;
468 FD_ZERO (&write_set
);
469 FD_ZERO (&except_set
);
471 FD_SET (fdes
, &read_set
);
476 if (select (SELECT_SET_SIZE
,
477 &read_set
, &write_set
, &except_set
, &timeout
)
479 scm_syserror ("fport_input_waiting");
480 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
481 #elif defined (FIONREAD)
483 ioctl(fdes
, FIONREAD
, &remir
);
486 scm_misc_error ("fport_input_waiting",
487 "Not fully implemented on this platform",
494 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
496 scm_puts ("#<", port
);
497 scm_print_port_mode (exp
, port
);
498 if (SCM_OPFPORTP (exp
))
501 SCM name
= SCM_FILENAME (exp
);
502 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
503 scm_display (name
, port
);
505 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
506 scm_putc (' ', port
);
507 fdes
= (SCM_FSTREAM (exp
))->fdes
;
511 scm_puts (ttyname (fdes
), port
);
513 #endif /* HAVE_TTYNAME */
514 scm_intprint (fdes
, 10, port
);
518 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
519 scm_putc (' ', port
);
520 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
522 scm_putc ('>', port
);
527 /* thread-local block for input on fport's fdes. */
529 fport_wait_for_input (SCM port
)
531 int fdes
= SCM_FSTREAM (port
)->fdes
;
533 if (!fport_input_waiting (port
))
537 int flags
= fcntl (fdes
, F_GETFL
);
540 scm_syserror ("scm_fdes_wait_for_input");
541 if (!(flags
& O_NONBLOCK
))
545 FD_SET (fdes
, &readfds
);
546 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
548 while (n
== -1 && errno
== EINTR
);
553 static void fport_flush (SCM port
);
555 /* fill a port's read-buffer with a single read. returns the first
556 char or EOF if end of file. */
558 fport_fill_input (SCM port
)
561 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
562 scm_t_fport
*fp
= SCM_FSTREAM (port
);
565 fport_wait_for_input (port
);
567 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
569 scm_syserror ("fport_fill_input");
574 pt
->read_pos
= pt
->read_buf
;
575 pt
->read_end
= pt
->read_buf
+ count
;
576 return *pt
->read_buf
;
581 fport_seek (SCM port
, off_t offset
, int whence
)
583 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
584 scm_t_fport
*fp
= SCM_FSTREAM (port
);
588 if (pt
->rw_active
== SCM_PORT_WRITE
)
590 if (offset
!= 0 || whence
!= SEEK_CUR
)
593 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
597 /* read current position without disturbing the buffer. */
598 rv
= lseek (fp
->fdes
, offset
, whence
);
599 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
602 else if (pt
->rw_active
== SCM_PORT_READ
)
604 if (offset
!= 0 || whence
!= SEEK_CUR
)
606 /* could expand to avoid a second seek. */
607 scm_end_input (port
);
608 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
612 /* read current position without disturbing the buffer
613 (particularly the unread-char buffer). */
614 rv
= lseek (fp
->fdes
, offset
, whence
);
615 result
= rv
- (pt
->read_end
- pt
->read_pos
);
617 if (pt
->read_buf
== pt
->putback_buf
)
618 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
621 else /* SCM_PORT_NEITHER */
623 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
627 scm_syserror ("fport_seek");
633 fport_truncate (SCM port
, off_t length
)
635 scm_t_fport
*fp
= SCM_FSTREAM (port
);
637 if (ftruncate (fp
->fdes
, length
) == -1)
638 scm_syserror ("ftruncate");
641 /* helper for fport_write: try to write data, using multiple system
642 calls if required. */
643 #define FUNC_NAME "write_all"
644 static void write_all (SCM port
, const void *data
, size_t remaining
)
646 int fdes
= SCM_FSTREAM (port
)->fdes
;
648 while (remaining
> 0)
652 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
657 data
= ((const char *) data
) + done
;
663 fport_write (SCM port
, const void *data
, size_t size
)
665 /* this procedure tries to minimize the number of writes/flushes. */
666 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
668 if (pt
->write_buf
== &pt
->shortbuf
669 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
671 /* "unbuffered" port, or
672 port with empty buffer and data won't fit in buffer. */
673 write_all (port
, data
, size
);
678 off_t space
= pt
->write_end
- pt
->write_pos
;
682 /* data fits in buffer. */
683 memcpy (pt
->write_pos
, data
, size
);
684 pt
->write_pos
+= size
;
685 if (pt
->write_pos
== pt
->write_end
)
688 /* we can skip the line-buffering check if nothing's buffered. */
694 memcpy (pt
->write_pos
, data
, space
);
695 pt
->write_pos
= pt
->write_end
;
698 const void *ptr
= ((const char *) data
) + space
;
699 size_t remaining
= size
- space
;
701 if (size
>= pt
->write_buf_size
)
703 write_all (port
, ptr
, remaining
);
708 memcpy (pt
->write_pos
, ptr
, remaining
);
709 pt
->write_pos
+= remaining
;
714 /* handle line buffering. */
715 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
720 /* becomes 1 when process is exiting: normal exception handling won't
721 work by this time. */
722 extern int terminating
;
725 fport_flush (SCM port
)
727 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
728 scm_t_fport
*fp
= SCM_FSTREAM (port
);
729 unsigned char *ptr
= pt
->write_buf
;
730 long init_size
= pt
->write_pos
- pt
->write_buf
;
731 long remaining
= init_size
;
733 while (remaining
> 0)
737 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
740 /* error. assume nothing was written this call, but
741 fix up the buffer for any previous successful writes. */
742 long done
= init_size
- remaining
;
748 for (i
= 0; i
< remaining
; i
++)
750 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
752 pt
->write_pos
= pt
->write_buf
+ remaining
;
756 const char *msg
= "Error: could not flush file-descriptor ";
759 write (2, msg
, strlen (msg
));
760 sprintf (buf
, "%d\n", fp
->fdes
);
761 write (2, buf
, strlen (buf
));
765 else if (scm_gc_running_p
)
767 /* silently ignore the error. scm_error would abort if we
772 scm_syserror ("fport_flush");
777 pt
->write_pos
= pt
->write_buf
;
778 pt
->rw_active
= SCM_PORT_NEITHER
;
781 /* clear the read buffer and adjust the file position for unread bytes. */
783 fport_end_input (SCM port
, int offset
)
785 scm_t_fport
*fp
= SCM_FSTREAM (port
);
786 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
788 offset
+= pt
->read_end
- pt
->read_pos
;
792 pt
->read_pos
= pt
->read_end
;
793 /* will throw error if unread-char used at beginning of file
794 then attempting to write. seems correct. */
795 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
796 scm_syserror ("fport_end_input");
798 pt
->rw_active
= SCM_PORT_NEITHER
;
802 fport_close (SCM port
)
804 scm_t_fport
*fp
= SCM_FSTREAM (port
);
805 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
809 SCM_SYSCALL (rv
= close (fp
->fdes
));
810 if (rv
== -1 && errno
!= EBADF
)
812 if (scm_gc_running_p
)
813 /* silently ignore the error. scm_error would abort if we
817 scm_syserror ("fport_close");
819 if (pt
->read_buf
== pt
->putback_buf
)
820 pt
->read_buf
= pt
->saved_read_buf
;
821 if (pt
->read_buf
!= &pt
->shortbuf
)
822 scm_must_free (pt
->read_buf
);
823 if (pt
->write_buf
!= &pt
->shortbuf
)
824 scm_must_free (pt
->write_buf
);
825 scm_must_free ((char *) fp
);
830 fport_free (SCM port
)
839 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
841 scm_set_port_free (tc
, fport_free
);
842 scm_set_port_print (tc
, fport_print
);
843 scm_set_port_flush (tc
, fport_flush
);
844 scm_set_port_end_input (tc
, fport_end_input
);
845 scm_set_port_close (tc
, fport_close
);
846 scm_set_port_seek (tc
, fport_seek
);
847 scm_set_port_truncate (tc
, fport_truncate
);
848 scm_set_port_input_waiting (tc
, fport_input_waiting
);
856 scm_tc16_fport
= scm_make_fptob ();
858 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
859 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
860 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
862 #ifndef SCM_MAGIC_SNARFER
863 #include "libguile/fports.x"