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_gc_malloc (read_size
, "port buffer");
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_gc_malloc (write_size
, "port buffer");
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 and put-back chars. */
196 if (pt
->read_buf
== pt
->putback_buf
)
198 pt
->read_buf
= pt
->saved_read_buf
;
199 pt
->read_pos
= pt
->saved_read_pos
;
200 pt
->read_end
= pt
->saved_read_end
;
201 pt
->read_buf_size
= pt
->saved_read_buf_size
;
203 if (pt
->read_buf
!= &pt
->shortbuf
)
204 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
205 if (pt
->write_buf
!= &pt
->shortbuf
)
206 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
208 scm_fport_buffer_add (port
, csize
, csize
);
209 return SCM_UNSPECIFIED
;
213 /* Move ports with the specified file descriptor to new descriptors,
214 * reseting the revealed count to 0.
218 scm_evict_ports (int fd
)
222 for (i
= 0; i
< scm_port_table_size
; i
++)
224 SCM port
= scm_port_table
[i
]->port
;
226 if (SCM_FPORTP (port
))
228 scm_t_fport
*fp
= SCM_FSTREAM (port
);
234 scm_syserror ("scm_evict_ports");
235 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
242 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
244 "Determine whether @var{obj} is a port that is related to a file.")
245 #define FUNC_NAME s_scm_file_port_p
247 return SCM_BOOL (SCM_FPORTP (obj
));
253 * Return a new port open on a given file.
255 * The mode string must match the pattern: [rwa+]** which
256 * is interpreted in the usual unix way.
258 * Return the new port.
260 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
261 (SCM filename
, SCM mode
),
262 "Open the file whose name is @var{filename}, and return a port\n"
263 "representing that file. The attributes of the port are\n"
264 "determined by the @var{mode} string. The way in which this is\n"
265 "interpreted is similar to C stdio. The first character must be\n"
266 "one of the following:\n"
269 "Open an existing file for input.\n"
271 "Open a file for output, creating it if it doesn't already exist\n"
272 "or removing its contents if it does.\n"
274 "Open a file for output, creating it if it doesn't already\n"
275 "exist. All writes to the port will go to the end of the file.\n"
276 "The \"append mode\" can be turned off while the port is in use\n"
277 "@pxref{Ports and File Descriptors, fcntl}\n"
279 "The following additional characters can be appended:\n"
282 "Open the port for both input and output. E.g., @code{r+}: open\n"
283 "an existing file for both input and output.\n"
285 "Create an \"unbuffered\" port. In this case input and output\n"
286 "operations are passed directly to the underlying port\n"
287 "implementation without additional buffering. This is likely to\n"
288 "slow down I/O operations. The buffering mode can be changed\n"
289 "while a port is in use @pxref{Ports and File Descriptors,\n"
292 "Add line-buffering to the port. The port output buffer will be\n"
293 "automatically flushed whenever a newline character is written.\n"
295 "In theory we could create read/write ports which were buffered\n"
296 "in one direction only. However this isn't included in the\n"
297 "current interfaces. If a file cannot be opened with the access\n"
298 "requested, @code{open-file} throws an exception.")
299 #define FUNC_NAME s_scm_open_file
308 SCM_VALIDATE_STRING (1, filename
);
309 SCM_VALIDATE_STRING (2, mode
);
311 file
= SCM_STRING_CHARS (filename
);
312 md
= SCM_STRING_CHARS (mode
);
320 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
323 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
326 scm_out_of_range (FUNC_NAME
, mode
);
334 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
337 #if defined (O_BINARY)
341 case '0': /* unbuffered: handled later. */
342 case 'l': /* line buffered: handled during output. */
345 scm_out_of_range (FUNC_NAME
, mode
);
349 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
354 SCM_SYSERROR_MSG ("~A: ~S",
355 scm_cons (scm_makfrom0str (strerror (en
)),
356 scm_cons (filename
, SCM_EOL
)), en
);
358 port
= scm_fdes_to_port (fdes
, md
, filename
);
366 * Try getting the appropiate file flags for a given file descriptor
367 * under Windows. This incorporates some fancy operations because Windows
368 * differentiates between file, pipe and socket descriptors.
371 # define O_ACCMODE 0x0003
374 static int getflags (int fdes
)
378 int error
, optlen
= sizeof (int);
380 /* Is this a socket ? */
381 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
383 /* Maybe a regular file ? */
384 else if (fstat (fdes
, &buf
) < 0)
388 /* Or an anonymous pipe handle ? */
389 if (buf
.st_mode
& _S_IFIFO
)
390 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
391 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
393 else if (fdes
== fileno (stdin
) && isatty (fdes
))
395 /* stdout / stderr ? */
396 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
404 #endif /* __MINGW32__ */
406 /* Building Guile ports from a file descriptor. */
408 /* Build a Scheme port from an open file descriptor `fdes'.
409 MODE indicates whether FILE is open for reading or writing; it uses
410 the same notation as open-file's second argument.
411 NAME is a string to be used as the port's filename.
414 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
415 #define FUNC_NAME "scm_fdes_to_port"
417 long mode_bits
= scm_mode_bits (mode
);
422 /* test that fdes is valid. */
424 flags
= getflags (fdes
);
426 flags
= fcntl (fdes
, F_GETFL
, 0);
432 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
433 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
435 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
438 port
= scm_alloc_cell (scm_tc16_fport
, 0);
440 pt
= scm_add_to_port_table (port
);
441 SCM_SETPTAB_ENTRY (port
, pt
);
442 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
446 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
449 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
450 SCM_SETSTREAM (port
, fp
);
451 if (mode_bits
& SCM_BUF0
)
452 scm_fport_buffer_add (port
, 0, 0);
454 scm_fport_buffer_add (port
, -1, -1);
456 SCM_SET_FILENAME (port
, name
);
462 /* Return a lower bound on the number of bytes available for input. */
464 fport_input_waiting (SCM port
)
466 int fdes
= SCM_FSTREAM (port
)->fdes
;
469 struct timeval timeout
;
470 SELECT_TYPE read_set
;
471 SELECT_TYPE write_set
;
472 SELECT_TYPE except_set
;
475 FD_ZERO (&write_set
);
476 FD_ZERO (&except_set
);
478 FD_SET (fdes
, &read_set
);
483 if (select (SELECT_SET_SIZE
,
484 &read_set
, &write_set
, &except_set
, &timeout
)
486 scm_syserror ("fport_input_waiting");
487 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
488 #elif defined (FIONREAD)
490 ioctl(fdes
, FIONREAD
, &remir
);
493 scm_misc_error ("fport_input_waiting",
494 "Not fully implemented on this platform",
501 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
503 scm_puts ("#<", port
);
504 scm_print_port_mode (exp
, port
);
505 if (SCM_OPFPORTP (exp
))
508 SCM name
= SCM_FILENAME (exp
);
509 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
510 scm_display (name
, port
);
512 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
513 scm_putc (' ', port
);
514 fdes
= (SCM_FSTREAM (exp
))->fdes
;
518 scm_puts (ttyname (fdes
), port
);
520 #endif /* HAVE_TTYNAME */
521 scm_intprint (fdes
, 10, port
);
525 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
526 scm_putc (' ', port
);
527 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
529 scm_putc ('>', port
);
534 /* thread-local block for input on fport's fdes. */
536 fport_wait_for_input (SCM port
)
538 int fdes
= SCM_FSTREAM (port
)->fdes
;
540 if (!fport_input_waiting (port
))
544 int flags
= fcntl (fdes
, F_GETFL
);
547 scm_syserror ("scm_fdes_wait_for_input");
548 if (!(flags
& O_NONBLOCK
))
552 FD_SET (fdes
, &readfds
);
553 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
555 while (n
== -1 && errno
== EINTR
);
560 static void fport_flush (SCM port
);
562 /* fill a port's read-buffer with a single read. returns the first
563 char or EOF if end of file. */
565 fport_fill_input (SCM port
)
568 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
569 scm_t_fport
*fp
= SCM_FSTREAM (port
);
572 fport_wait_for_input (port
);
574 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
576 scm_syserror ("fport_fill_input");
581 pt
->read_pos
= pt
->read_buf
;
582 pt
->read_end
= pt
->read_buf
+ count
;
583 return *pt
->read_buf
;
588 fport_seek (SCM port
, off_t offset
, int whence
)
590 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
591 scm_t_fport
*fp
= SCM_FSTREAM (port
);
595 if (pt
->rw_active
== SCM_PORT_WRITE
)
597 if (offset
!= 0 || whence
!= SEEK_CUR
)
600 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
604 /* read current position without disturbing the buffer. */
605 rv
= lseek (fp
->fdes
, offset
, whence
);
606 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
609 else if (pt
->rw_active
== SCM_PORT_READ
)
611 if (offset
!= 0 || whence
!= SEEK_CUR
)
613 /* could expand to avoid a second seek. */
614 scm_end_input (port
);
615 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
619 /* read current position without disturbing the buffer
620 (particularly the unread-char buffer). */
621 rv
= lseek (fp
->fdes
, offset
, whence
);
622 result
= rv
- (pt
->read_end
- pt
->read_pos
);
624 if (pt
->read_buf
== pt
->putback_buf
)
625 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
628 else /* SCM_PORT_NEITHER */
630 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
634 scm_syserror ("fport_seek");
640 fport_truncate (SCM port
, off_t length
)
642 scm_t_fport
*fp
= SCM_FSTREAM (port
);
644 if (ftruncate (fp
->fdes
, length
) == -1)
645 scm_syserror ("ftruncate");
648 /* helper for fport_write: try to write data, using multiple system
649 calls if required. */
650 #define FUNC_NAME "write_all"
651 static void write_all (SCM port
, const void *data
, size_t remaining
)
653 int fdes
= SCM_FSTREAM (port
)->fdes
;
655 while (remaining
> 0)
659 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
664 data
= ((const char *) data
) + done
;
670 fport_write (SCM port
, const void *data
, size_t size
)
672 /* this procedure tries to minimize the number of writes/flushes. */
673 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
675 if (pt
->write_buf
== &pt
->shortbuf
676 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
678 /* "unbuffered" port, or
679 port with empty buffer and data won't fit in buffer. */
680 write_all (port
, data
, size
);
685 off_t space
= pt
->write_end
- pt
->write_pos
;
689 /* data fits in buffer. */
690 memcpy (pt
->write_pos
, data
, size
);
691 pt
->write_pos
+= size
;
692 if (pt
->write_pos
== pt
->write_end
)
695 /* we can skip the line-buffering check if nothing's buffered. */
701 memcpy (pt
->write_pos
, data
, space
);
702 pt
->write_pos
= pt
->write_end
;
705 const void *ptr
= ((const char *) data
) + space
;
706 size_t remaining
= size
- space
;
708 if (size
>= pt
->write_buf_size
)
710 write_all (port
, ptr
, remaining
);
715 memcpy (pt
->write_pos
, ptr
, remaining
);
716 pt
->write_pos
+= remaining
;
721 /* handle line buffering. */
722 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
727 /* becomes 1 when process is exiting: normal exception handling won't
728 work by this time. */
729 extern int terminating
;
732 fport_flush (SCM port
)
734 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
735 scm_t_fport
*fp
= SCM_FSTREAM (port
);
736 unsigned char *ptr
= pt
->write_buf
;
737 long init_size
= pt
->write_pos
- pt
->write_buf
;
738 long remaining
= init_size
;
740 while (remaining
> 0)
744 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
747 /* error. assume nothing was written this call, but
748 fix up the buffer for any previous successful writes. */
749 long done
= init_size
- remaining
;
755 for (i
= 0; i
< remaining
; i
++)
757 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
759 pt
->write_pos
= pt
->write_buf
+ remaining
;
763 const char *msg
= "Error: could not flush file-descriptor ";
766 write (2, msg
, strlen (msg
));
767 sprintf (buf
, "%d\n", fp
->fdes
);
768 write (2, buf
, strlen (buf
));
772 else if (scm_gc_running_p
)
774 /* silently ignore the error. scm_error would abort if we
779 scm_syserror ("fport_flush");
784 pt
->write_pos
= pt
->write_buf
;
785 pt
->rw_active
= SCM_PORT_NEITHER
;
788 /* clear the read buffer and adjust the file position for unread bytes. */
790 fport_end_input (SCM port
, int offset
)
792 scm_t_fport
*fp
= SCM_FSTREAM (port
);
793 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
795 offset
+= pt
->read_end
- pt
->read_pos
;
799 pt
->read_pos
= pt
->read_end
;
800 /* will throw error if unread-char used at beginning of file
801 then attempting to write. seems correct. */
802 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
803 scm_syserror ("fport_end_input");
805 pt
->rw_active
= SCM_PORT_NEITHER
;
809 fport_close (SCM port
)
811 scm_t_fport
*fp
= SCM_FSTREAM (port
);
812 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
816 SCM_SYSCALL (rv
= close (fp
->fdes
));
817 if (rv
== -1 && errno
!= EBADF
)
819 if (scm_gc_running_p
)
820 /* silently ignore the error. scm_error would abort if we
824 scm_syserror ("fport_close");
826 if (pt
->read_buf
== pt
->putback_buf
)
827 pt
->read_buf
= pt
->saved_read_buf
;
828 if (pt
->read_buf
!= &pt
->shortbuf
)
829 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
830 if (pt
->write_buf
!= &pt
->shortbuf
)
831 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
832 scm_gc_free (fp
, sizeof (*fp
), "file port");
837 fport_free (SCM port
)
846 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
848 scm_set_port_free (tc
, fport_free
);
849 scm_set_port_print (tc
, fport_print
);
850 scm_set_port_flush (tc
, fport_flush
);
851 scm_set_port_end_input (tc
, fport_end_input
);
852 scm_set_port_close (tc
, fport_close
);
853 scm_set_port_seek (tc
, fport_seek
);
854 scm_set_port_truncate (tc
, fport_truncate
);
855 scm_set_port_input_waiting (tc
, fport_input_waiting
);
863 scm_tc16_fport
= scm_make_fptob ();
865 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
866 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
867 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
869 #ifndef SCM_MAGIC_SNARFER
870 #include "libguile/fports.x"