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"
62 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
68 #include "libguile/iselect.h"
69 /* Some defines for Windows. */
71 # include <sys/stat.h>
72 # include <winsock2.h>
73 # define ftruncate(fd, size) chsize (fd, size)
74 #endif /* __MINGW32__ */
77 scm_t_bits scm_tc16_fport
;
80 /* default buffer size, used if the O/S won't supply a value. */
81 static const size_t default_buffer_size
= 1024;
83 /* create FPORT buffer with specified sizes (or -1 to use default size or
86 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
87 #define FUNC_NAME "scm_fport_buffer_add"
89 scm_t_fport
*fp
= SCM_FSTREAM (port
);
90 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
92 if (read_size
== -1 || write_size
== -1)
95 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
98 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
101 default_size
= default_buffer_size
;
104 read_size
= default_size
;
105 if (write_size
== -1)
106 write_size
= default_size
;
109 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
111 pt
->read_buf
= scm_must_malloc (read_size
, FUNC_NAME
);
112 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
113 pt
->read_buf_size
= read_size
;
117 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
118 pt
->read_buf_size
= 1;
121 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
123 pt
->write_buf
= scm_must_malloc (write_size
, FUNC_NAME
);
124 pt
->write_pos
= pt
->write_buf
;
125 pt
->write_buf_size
= write_size
;
129 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
130 pt
->write_buf_size
= 1;
133 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
134 if (read_size
> 0 || write_size
> 0)
135 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
137 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
141 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
142 (SCM port
, SCM mode
, SCM size
),
143 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
150 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
151 "If @var{size} is omitted, a default size will be used.\n"
153 #define FUNC_NAME s_scm_setvbuf
159 port
= SCM_COERCE_OUTPORT (port
);
161 SCM_VALIDATE_OPFPORT (1,port
);
162 SCM_VALIDATE_INUM_COPY (2,mode
,cmode
);
163 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
164 scm_out_of_range (FUNC_NAME
, mode
);
168 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
173 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
176 if (SCM_UNBNDP (size
))
185 SCM_VALIDATE_INUM_COPY (3,size
,csize
);
186 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
187 scm_out_of_range (FUNC_NAME
, size
);
190 pt
= SCM_PTAB_ENTRY (port
);
192 /* silently discards buffered chars. */
193 if (pt
->read_buf
!= &pt
->shortbuf
)
194 scm_must_free (pt
->read_buf
);
195 if (pt
->write_buf
!= &pt
->shortbuf
)
196 scm_must_free (pt
->write_buf
);
198 scm_fport_buffer_add (port
, csize
, csize
);
199 return SCM_UNSPECIFIED
;
203 /* Move ports with the specified file descriptor to new descriptors,
204 * reseting the revealed count to 0.
208 scm_evict_ports (int fd
)
212 for (i
= 0; i
< scm_port_table_size
; i
++)
214 SCM port
= scm_port_table
[i
]->port
;
216 if (SCM_FPORTP (port
))
218 scm_t_fport
*fp
= SCM_FSTREAM (port
);
224 scm_syserror ("scm_evict_ports");
225 scm_set_port_revealed_x (port
, SCM_MAKINUM (0));
232 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
234 "Determine whether @var{obj} is a port that is related to a file.")
235 #define FUNC_NAME s_scm_file_port_p
237 return SCM_BOOL (SCM_FPORTP (obj
));
243 * Return a new port open on a given file.
245 * The mode string must match the pattern: [rwa+]** which
246 * is interpreted in the usual unix way.
248 * Return the new port.
250 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
251 (SCM filename
, SCM mode
),
252 "Open the file whose name is @var{filename}, and return a port\n"
253 "representing that file. The attributes of the port are\n"
254 "determined by the @var{mode} string. The way in which this is\n"
255 "interpreted is similar to C stdio. The first character must be\n"
256 "one of the following:\n"
259 "Open an existing file for input.\n"
261 "Open a file for output, creating it if it doesn't already exist\n"
262 "or removing its contents if it does.\n"
264 "Open a file for output, creating it if it doesn't already\n"
265 "exist. All writes to the port will go to the end of the file.\n"
266 "The \"append mode\" can be turned off while the port is in use\n"
267 "@pxref{Ports and File Descriptors, fcntl}\n"
269 "The following additional characters can be appended:\n"
272 "Open the port for both input and output. E.g., @code{r+}: open\n"
273 "an existing file for both input and output.\n"
275 "Create an \"unbuffered\" port. In this case input and output\n"
276 "operations are passed directly to the underlying port\n"
277 "implementation without additional buffering. This is likely to\n"
278 "slow down I/O operations. The buffering mode can be changed\n"
279 "while a port is in use @pxref{Ports and File Descriptors,\n"
282 "Add line-buffering to the port. The port output buffer will be\n"
283 "automatically flushed whenever a newline character is written.\n"
285 "In theory we could create read/write ports which were buffered\n"
286 "in one direction only. However this isn't included in the\n"
287 "current interfaces. If a file cannot be opened with the access\n"
288 "requested, @code{open-file} throws an exception.")
289 #define FUNC_NAME s_scm_open_file
298 SCM_VALIDATE_STRING (1, filename
);
299 SCM_VALIDATE_STRING (2, mode
);
301 file
= SCM_STRING_CHARS (filename
);
302 md
= SCM_STRING_CHARS (mode
);
310 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
313 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
316 scm_out_of_range (FUNC_NAME
, mode
);
324 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
327 #if defined (O_BINARY)
331 case '0': /* unbuffered: handled later. */
332 case 'l': /* line buffered: handled during output. */
335 scm_out_of_range (FUNC_NAME
, mode
);
339 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
344 SCM_SYSERROR_MSG ("~A: ~S",
345 scm_cons (scm_makfrom0str (strerror (en
)),
346 scm_cons (filename
, SCM_EOL
)), en
);
348 port
= scm_fdes_to_port (fdes
, md
, filename
);
356 * Try getting the appropiate file flags for a given file descriptor
357 * under Windows. This incorporates some fancy operations because Windows
358 * differentiates between file, pipe and socket descriptors.
361 # define O_ACCMODE 0x0003
364 static int getflags (int fdes
)
368 int error
, optlen
= sizeof (int);
370 /* Is this a socket ? */
371 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
373 /* Maybe a regular file ? */
374 else if (fstat (fdes
, &buf
) < 0)
378 /* Or an anonymous pipe handle ? */
379 if (buf
.st_mode
& 0x1000 /* _O_SHORT_LIVED */)
382 else if (fdes
== 0 && isatty (fdes
))
384 /* stdout / stderr ? */
385 else if ((fdes
== 1 || fdes
== 2) && isatty (fdes
))
392 #endif /* __MINGW32__ */
394 /* Building Guile ports from a file descriptor. */
396 /* Build a Scheme port from an open file descriptor `fdes'.
397 MODE indicates whether FILE is open for reading or writing; it uses
398 the same notation as open-file's second argument.
399 NAME is a string to be used as the port's filename.
402 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
403 #define FUNC_NAME "scm_fdes_to_port"
405 long mode_bits
= scm_mode_bits (mode
);
410 /* test that fdes is valid. */
412 flags
= getflags (fdes
);
414 flags
= fcntl (fdes
, F_GETFL
, 0);
420 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
421 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
423 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
428 pt
= scm_add_to_port_table (port
);
429 SCM_SETPTAB_ENTRY (port
, pt
);
430 SCM_SET_CELL_TYPE (port
, (scm_tc16_fport
| mode_bits
));
434 = (scm_t_fport
*) scm_must_malloc (sizeof (scm_t_fport
),
438 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
439 SCM_SETSTREAM (port
, fp
);
440 if (mode_bits
& SCM_BUF0
)
441 scm_fport_buffer_add (port
, 0, 0);
443 scm_fport_buffer_add (port
, -1, -1);
445 SCM_SET_FILENAME (port
, name
);
451 /* Return a lower bound on the number of bytes available for input. */
453 fport_input_waiting (SCM port
)
455 int fdes
= SCM_FSTREAM (port
)->fdes
;
458 struct timeval timeout
;
459 SELECT_TYPE read_set
;
460 SELECT_TYPE write_set
;
461 SELECT_TYPE except_set
;
464 FD_ZERO (&write_set
);
465 FD_ZERO (&except_set
);
467 FD_SET (fdes
, &read_set
);
472 if (select (SELECT_SET_SIZE
,
473 &read_set
, &write_set
, &except_set
, &timeout
)
475 scm_syserror ("fport_input_waiting");
476 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
477 #elif defined (FIONREAD)
479 ioctl(fdes
, FIONREAD
, &remir
);
482 scm_misc_error ("fport_input_waiting",
483 "Not fully implemented on this platform",
490 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
492 scm_puts ("#<", port
);
493 scm_print_port_mode (exp
, port
);
494 if (SCM_OPFPORTP (exp
))
497 SCM name
= SCM_FILENAME (exp
);
498 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
499 scm_display (name
, port
);
501 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
502 scm_putc (' ', port
);
503 fdes
= (SCM_FSTREAM (exp
))->fdes
;
507 scm_puts (ttyname (fdes
), port
);
509 #endif /* HAVE_TTYNAME */
510 scm_intprint (fdes
, 10, port
);
514 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
515 scm_putc (' ', port
);
516 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
518 scm_putc ('>', port
);
523 /* thread-local block for input on fport's fdes. */
525 fport_wait_for_input (SCM port
)
527 int fdes
= SCM_FSTREAM (port
)->fdes
;
529 if (!fport_input_waiting (port
))
533 int flags
= fcntl (fdes
, F_GETFL
);
536 scm_syserror ("scm_fdes_wait_for_input");
537 if (!(flags
& O_NONBLOCK
))
541 FD_SET (fdes
, &readfds
);
542 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
544 while (n
== -1 && errno
== EINTR
);
549 static void fport_flush (SCM port
);
551 /* fill a port's read-buffer with a single read. returns the first
552 char or EOF if end of file. */
554 fport_fill_input (SCM port
)
557 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
558 scm_t_fport
*fp
= SCM_FSTREAM (port
);
561 fport_wait_for_input (port
);
563 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
565 scm_syserror ("fport_fill_input");
570 pt
->read_pos
= pt
->read_buf
;
571 pt
->read_end
= pt
->read_buf
+ count
;
572 return *pt
->read_buf
;
577 fport_seek (SCM port
, off_t offset
, int whence
)
579 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
580 scm_t_fport
*fp
= SCM_FSTREAM (port
);
584 if (pt
->rw_active
== SCM_PORT_WRITE
)
586 if (offset
!= 0 || whence
!= SEEK_CUR
)
589 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
593 /* read current position without disturbing the buffer. */
594 rv
= lseek (fp
->fdes
, offset
, whence
);
595 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
598 else if (pt
->rw_active
== SCM_PORT_READ
)
600 if (offset
!= 0 || whence
!= SEEK_CUR
)
602 /* could expand to avoid a second seek. */
603 scm_end_input (port
);
604 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
608 /* read current position without disturbing the buffer
609 (particularly the unread-char buffer). */
610 rv
= lseek (fp
->fdes
, offset
, whence
);
611 result
= rv
- (pt
->read_end
- pt
->read_pos
);
613 if (pt
->read_buf
== pt
->putback_buf
)
614 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
617 else /* SCM_PORT_NEITHER */
619 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
623 scm_syserror ("fport_seek");
629 fport_truncate (SCM port
, off_t length
)
631 scm_t_fport
*fp
= SCM_FSTREAM (port
);
633 if (ftruncate (fp
->fdes
, length
) == -1)
634 scm_syserror ("ftruncate");
637 /* helper for fport_write: try to write data, using multiple system
638 calls if required. */
639 #define FUNC_NAME "write_all"
640 static void write_all (SCM port
, const void *data
, size_t remaining
)
642 int fdes
= SCM_FSTREAM (port
)->fdes
;
644 while (remaining
> 0)
648 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
653 data
= ((const char *) data
) + done
;
659 fport_write (SCM port
, const void *data
, size_t size
)
661 /* this procedure tries to minimize the number of writes/flushes. */
662 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
664 if (pt
->write_buf
== &pt
->shortbuf
665 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
667 /* "unbuffered" port, or
668 port with empty buffer and data won't fit in buffer. */
669 write_all (port
, data
, size
);
674 off_t space
= pt
->write_end
- pt
->write_pos
;
678 /* data fits in buffer. */
679 memcpy (pt
->write_pos
, data
, size
);
680 pt
->write_pos
+= size
;
681 if (pt
->write_pos
== pt
->write_end
)
684 /* we can skip the line-buffering check if nothing's buffered. */
690 memcpy (pt
->write_pos
, data
, space
);
691 pt
->write_pos
= pt
->write_end
;
694 const void *ptr
= ((const char *) data
) + space
;
695 size_t remaining
= size
- space
;
697 if (size
>= pt
->write_buf_size
)
699 write_all (port
, ptr
, remaining
);
704 memcpy (pt
->write_pos
, ptr
, remaining
);
705 pt
->write_pos
+= remaining
;
710 /* handle line buffering. */
711 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
716 /* becomes 1 when process is exiting: normal exception handling won't
717 work by this time. */
718 extern int terminating
;
721 fport_flush (SCM port
)
723 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
724 scm_t_fport
*fp
= SCM_FSTREAM (port
);
725 unsigned char *ptr
= pt
->write_buf
;
726 long init_size
= pt
->write_pos
- pt
->write_buf
;
727 long remaining
= init_size
;
729 while (remaining
> 0)
733 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
736 /* error. assume nothing was written this call, but
737 fix up the buffer for any previous successful writes. */
738 long done
= init_size
- remaining
;
744 for (i
= 0; i
< remaining
; i
++)
746 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
748 pt
->write_pos
= pt
->write_buf
+ remaining
;
752 const char *msg
= "Error: could not flush file-descriptor ";
755 write (2, msg
, strlen (msg
));
756 sprintf (buf
, "%d\n", fp
->fdes
);
757 write (2, buf
, strlen (buf
));
761 else if (scm_gc_running_p
)
763 /* silently ignore the error. scm_error would abort if we
768 scm_syserror ("fport_flush");
773 pt
->write_pos
= pt
->write_buf
;
774 pt
->rw_active
= SCM_PORT_NEITHER
;
777 /* clear the read buffer and adjust the file position for unread bytes. */
779 fport_end_input (SCM port
, int offset
)
781 scm_t_fport
*fp
= SCM_FSTREAM (port
);
782 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
784 offset
+= pt
->read_end
- pt
->read_pos
;
788 pt
->read_pos
= pt
->read_end
;
789 /* will throw error if unread-char used at beginning of file
790 then attempting to write. seems correct. */
791 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
792 scm_syserror ("fport_end_input");
794 pt
->rw_active
= SCM_PORT_NEITHER
;
798 fport_close (SCM port
)
800 scm_t_fport
*fp
= SCM_FSTREAM (port
);
801 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
805 SCM_SYSCALL (rv
= close (fp
->fdes
));
806 if (rv
== -1 && errno
!= EBADF
)
808 if (scm_gc_running_p
)
809 /* silently ignore the error. scm_error would abort if we
813 scm_syserror ("fport_close");
815 if (pt
->read_buf
== pt
->putback_buf
)
816 pt
->read_buf
= pt
->saved_read_buf
;
817 if (pt
->read_buf
!= &pt
->shortbuf
)
818 scm_must_free (pt
->read_buf
);
819 if (pt
->write_buf
!= &pt
->shortbuf
)
820 scm_must_free (pt
->write_buf
);
821 scm_must_free ((char *) fp
);
826 fport_free (SCM port
)
835 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
837 scm_set_port_free (tc
, fport_free
);
838 scm_set_port_print (tc
, fport_print
);
839 scm_set_port_flush (tc
, fport_flush
);
840 scm_set_port_end_input (tc
, fport_end_input
);
841 scm_set_port_close (tc
, fport_close
);
842 scm_set_port_seek (tc
, fport_seek
);
843 scm_set_port_truncate (tc
, fport_truncate
);
844 scm_set_port_input_waiting (tc
, fport_input_waiting
);
852 scm_tc16_fport
= scm_make_fptob ();
854 scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF
));
855 scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF
));
856 scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF
));
858 #ifndef SCM_MAGIC_SNARFER
859 #include "libguile/fports.x"