1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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 cmode
= scm_to_int (mode
);
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 csize
= scm_to_int (size
);
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 scm_mutex_lock (&scm_i_port_table_mutex
);
204 for (i
= 0; i
< scm_i_port_table_size
; i
++)
206 SCM port
= scm_i_port_table
[i
]->port
;
208 if (SCM_FPORTP (port
))
210 scm_t_fport
*fp
= SCM_FSTREAM (port
);
216 scm_syserror ("scm_evict_ports");
217 scm_set_port_revealed_x (port
, scm_from_int (0));
222 scm_mutex_unlock (&scm_i_port_table_mutex
);
226 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
228 "Determine whether @var{obj} is a port that is related to a file.")
229 #define FUNC_NAME s_scm_file_port_p
231 return scm_from_bool (SCM_FPORTP (obj
));
237 * Return a new port open on a given file.
239 * The mode string must match the pattern: [rwa+]** which
240 * is interpreted in the usual unix way.
242 * Return the new port.
244 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
245 (SCM filename
, SCM mode
),
246 "Open the file whose name is @var{filename}, and return a port\n"
247 "representing that file. The attributes of the port are\n"
248 "determined by the @var{mode} string. The way in which this is\n"
249 "interpreted is similar to C stdio. The first character must be\n"
250 "one of the following:\n"
253 "Open an existing file for input.\n"
255 "Open a file for output, creating it if it doesn't already exist\n"
256 "or removing its contents if it does.\n"
258 "Open a file for output, creating it if it doesn't already\n"
259 "exist. All writes to the port will go to the end of the file.\n"
260 "The \"append mode\" can be turned off while the port is in use\n"
261 "@pxref{Ports and File Descriptors, fcntl}\n"
263 "The following additional characters can be appended:\n"
266 "Open the port for both input and output. E.g., @code{r+}: open\n"
267 "an existing file for both input and output.\n"
269 "Create an \"unbuffered\" port. In this case input and output\n"
270 "operations are passed directly to the underlying port\n"
271 "implementation without additional buffering. This is likely to\n"
272 "slow down I/O operations. The buffering mode can be changed\n"
273 "while a port is in use @pxref{Ports and File Descriptors,\n"
276 "Add line-buffering to the port. The port output buffer will be\n"
277 "automatically flushed whenever a newline character is written.\n"
279 "In theory we could create read/write ports which were buffered\n"
280 "in one direction only. However this isn't included in the\n"
281 "current interfaces. If a file cannot be opened with the access\n"
282 "requested, @code{open-file} throws an exception.")
283 #define FUNC_NAME s_scm_open_file
292 SCM_VALIDATE_STRING (1, filename
);
293 SCM_VALIDATE_STRING (2, mode
);
295 file
= SCM_STRING_CHARS (filename
);
296 md
= SCM_STRING_CHARS (mode
);
304 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
307 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
310 scm_out_of_range (FUNC_NAME
, mode
);
318 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
321 #if defined (O_BINARY)
325 case '0': /* unbuffered: handled later. */
326 case 'l': /* line buffered: handled during output. */
329 scm_out_of_range (FUNC_NAME
, mode
);
333 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
338 SCM_SYSERROR_MSG ("~A: ~S",
339 scm_cons (scm_strerror (scm_from_int (en
)),
340 scm_cons (filename
, SCM_EOL
)), en
);
342 port
= scm_fdes_to_port (fdes
, md
, filename
);
350 * Try getting the appropiate file flags for a given file descriptor
351 * under Windows. This incorporates some fancy operations because Windows
352 * differentiates between file, pipe and socket descriptors.
355 # define O_ACCMODE 0x0003
358 static int getflags (int fdes
)
362 int error
, optlen
= sizeof (int);
364 /* Is this a socket ? */
365 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
367 /* Maybe a regular file ? */
368 else if (fstat (fdes
, &buf
) < 0)
372 /* Or an anonymous pipe handle ? */
373 if (buf
.st_mode
& _S_IFIFO
)
374 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
375 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
377 else if (fdes
== fileno (stdin
) && isatty (fdes
))
379 /* stdout / stderr ? */
380 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
388 #endif /* __MINGW32__ */
390 /* Building Guile ports from a file descriptor. */
392 /* Build a Scheme port from an open file descriptor `fdes'.
393 MODE indicates whether FILE is open for reading or writing; it uses
394 the same notation as open-file's second argument.
395 NAME is a string to be used as the port's filename.
398 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
399 #define FUNC_NAME "scm_fdes_to_port"
401 long mode_bits
= scm_mode_bits (mode
);
406 /* test that fdes is valid. */
408 flags
= getflags (fdes
);
410 flags
= fcntl (fdes
, F_GETFL
, 0);
416 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
417 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
419 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
422 scm_mutex_lock (&scm_i_port_table_mutex
);
424 port
= scm_new_port_table_entry (scm_tc16_fport
);
425 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
426 pt
= SCM_PTAB_ENTRY(port
);
429 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
432 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
433 SCM_SETSTREAM (port
, fp
);
434 if (mode_bits
& SCM_BUF0
)
435 scm_fport_buffer_add (port
, 0, 0);
437 scm_fport_buffer_add (port
, -1, -1);
439 SCM_SET_FILENAME (port
, name
);
440 scm_mutex_unlock (&scm_i_port_table_mutex
);
445 /* Return a lower bound on the number of bytes available for input. */
447 fport_input_waiting (SCM port
)
449 int fdes
= SCM_FSTREAM (port
)->fdes
;
452 struct timeval timeout
;
453 SELECT_TYPE read_set
;
454 SELECT_TYPE write_set
;
455 SELECT_TYPE except_set
;
458 FD_ZERO (&write_set
);
459 FD_ZERO (&except_set
);
461 FD_SET (fdes
, &read_set
);
466 if (select (SELECT_SET_SIZE
,
467 &read_set
, &write_set
, &except_set
, &timeout
)
469 scm_syserror ("fport_input_waiting");
470 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
471 #elif defined (FIONREAD)
473 ioctl(fdes
, FIONREAD
, &remir
);
476 scm_misc_error ("fport_input_waiting",
477 "Not fully implemented on this platform",
484 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
486 scm_puts ("#<", port
);
487 scm_print_port_mode (exp
, port
);
488 if (SCM_OPFPORTP (exp
))
491 SCM name
= SCM_FILENAME (exp
);
492 if (SCM_STRINGP (name
) || SCM_SYMBOLP (name
))
493 scm_display (name
, port
);
495 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
496 scm_putc (' ', port
);
497 fdes
= (SCM_FSTREAM (exp
))->fdes
;
501 scm_puts (ttyname (fdes
), port
);
503 #endif /* HAVE_TTYNAME */
504 scm_intprint (fdes
, 10, port
);
508 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
509 scm_putc (' ', port
);
510 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
512 scm_putc ('>', port
);
517 /* thread-local block for input on fport's fdes. */
519 fport_wait_for_input (SCM port
)
521 int fdes
= SCM_FSTREAM (port
)->fdes
;
523 if (!fport_input_waiting (port
))
527 int flags
= fcntl (fdes
, F_GETFL
);
530 scm_syserror ("scm_fdes_wait_for_input");
531 if (!(flags
& O_NONBLOCK
))
535 FD_SET (fdes
, &readfds
);
536 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
538 while (n
== -1 && errno
== EINTR
);
541 #endif /* !__MINGW32__ */
543 static void fport_flush (SCM port
);
545 /* fill a port's read-buffer with a single read. returns the first
546 char or EOF if end of file. */
548 fport_fill_input (SCM port
)
551 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
552 scm_t_fport
*fp
= SCM_FSTREAM (port
);
555 fport_wait_for_input (port
);
556 #endif /* !__MINGW32__ */
557 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
559 scm_syserror ("fport_fill_input");
564 pt
->read_pos
= pt
->read_buf
;
565 pt
->read_end
= pt
->read_buf
+ count
;
566 return *pt
->read_buf
;
571 fport_seek (SCM port
, off_t offset
, int whence
)
573 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
574 scm_t_fport
*fp
= SCM_FSTREAM (port
);
578 if (pt
->rw_active
== SCM_PORT_WRITE
)
580 if (offset
!= 0 || whence
!= SEEK_CUR
)
583 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
587 /* read current position without disturbing the buffer. */
588 rv
= lseek (fp
->fdes
, offset
, whence
);
589 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
592 else if (pt
->rw_active
== SCM_PORT_READ
)
594 if (offset
!= 0 || whence
!= SEEK_CUR
)
596 /* could expand to avoid a second seek. */
597 scm_end_input (port
);
598 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
602 /* read current position without disturbing the buffer
603 (particularly the unread-char buffer). */
604 rv
= lseek (fp
->fdes
, offset
, whence
);
605 result
= rv
- (pt
->read_end
- pt
->read_pos
);
607 if (pt
->read_buf
== pt
->putback_buf
)
608 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
611 else /* SCM_PORT_NEITHER */
613 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
617 scm_syserror ("fport_seek");
623 fport_truncate (SCM port
, off_t length
)
625 scm_t_fport
*fp
= SCM_FSTREAM (port
);
627 if (ftruncate (fp
->fdes
, length
) == -1)
628 scm_syserror ("ftruncate");
631 /* helper for fport_write: try to write data, using multiple system
632 calls if required. */
633 #define FUNC_NAME "write_all"
634 static void write_all (SCM port
, const void *data
, size_t remaining
)
636 int fdes
= SCM_FSTREAM (port
)->fdes
;
638 while (remaining
> 0)
642 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
647 data
= ((const char *) data
) + done
;
653 fport_write (SCM port
, const void *data
, size_t size
)
655 /* this procedure tries to minimize the number of writes/flushes. */
656 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
658 if (pt
->write_buf
== &pt
->shortbuf
659 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
661 /* "unbuffered" port, or
662 port with empty buffer and data won't fit in buffer. */
663 write_all (port
, data
, size
);
668 off_t space
= pt
->write_end
- pt
->write_pos
;
672 /* data fits in buffer. */
673 memcpy (pt
->write_pos
, data
, size
);
674 pt
->write_pos
+= size
;
675 if (pt
->write_pos
== pt
->write_end
)
678 /* we can skip the line-buffering check if nothing's buffered. */
684 memcpy (pt
->write_pos
, data
, space
);
685 pt
->write_pos
= pt
->write_end
;
688 const void *ptr
= ((const char *) data
) + space
;
689 size_t remaining
= size
- space
;
691 if (size
>= pt
->write_buf_size
)
693 write_all (port
, ptr
, remaining
);
698 memcpy (pt
->write_pos
, ptr
, remaining
);
699 pt
->write_pos
+= remaining
;
704 /* handle line buffering. */
705 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
710 /* becomes 1 when process is exiting: normal exception handling won't
711 work by this time. */
712 extern int scm_i_terminating
;
715 fport_flush (SCM port
)
717 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
718 scm_t_fport
*fp
= SCM_FSTREAM (port
);
719 unsigned char *ptr
= pt
->write_buf
;
720 long init_size
= pt
->write_pos
- pt
->write_buf
;
721 long remaining
= init_size
;
723 while (remaining
> 0)
727 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
730 /* error. assume nothing was written this call, but
731 fix up the buffer for any previous successful writes. */
732 long done
= init_size
- remaining
;
738 for (i
= 0; i
< remaining
; i
++)
740 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
742 pt
->write_pos
= pt
->write_buf
+ remaining
;
744 if (scm_i_terminating
)
746 const char *msg
= "Error: could not flush file-descriptor ";
749 write (2, msg
, strlen (msg
));
750 sprintf (buf
, "%d\n", fp
->fdes
);
751 write (2, buf
, strlen (buf
));
755 else if (scm_gc_running_p
)
757 /* silently ignore the error. scm_error would abort if we
762 scm_syserror ("fport_flush");
767 pt
->write_pos
= pt
->write_buf
;
768 pt
->rw_active
= SCM_PORT_NEITHER
;
771 /* clear the read buffer and adjust the file position for unread bytes. */
773 fport_end_input (SCM port
, int offset
)
775 scm_t_fport
*fp
= SCM_FSTREAM (port
);
776 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
778 offset
+= pt
->read_end
- pt
->read_pos
;
782 pt
->read_pos
= pt
->read_end
;
783 /* will throw error if unread-char used at beginning of file
784 then attempting to write. seems correct. */
785 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
786 scm_syserror ("fport_end_input");
788 pt
->rw_active
= SCM_PORT_NEITHER
;
792 fport_close (SCM port
)
794 scm_t_fport
*fp
= SCM_FSTREAM (port
);
795 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
799 SCM_SYSCALL (rv
= close (fp
->fdes
));
800 if (rv
== -1 && errno
!= EBADF
)
802 if (scm_gc_running_p
)
803 /* silently ignore the error. scm_error would abort if we
807 scm_syserror ("fport_close");
809 if (pt
->read_buf
== pt
->putback_buf
)
810 pt
->read_buf
= pt
->saved_read_buf
;
811 if (pt
->read_buf
!= &pt
->shortbuf
)
812 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
813 if (pt
->write_buf
!= &pt
->shortbuf
)
814 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
815 scm_gc_free (fp
, sizeof (*fp
), "file port");
820 fport_free (SCM port
)
829 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
831 scm_set_port_free (tc
, fport_free
);
832 scm_set_port_print (tc
, fport_print
);
833 scm_set_port_flush (tc
, fport_flush
);
834 scm_set_port_end_input (tc
, fport_end_input
);
835 scm_set_port_close (tc
, fport_close
);
836 scm_set_port_seek (tc
, fport_seek
);
837 scm_set_port_truncate (tc
, fport_truncate
);
838 scm_set_port_input_waiting (tc
, fport_input_waiting
);
846 scm_tc16_fport
= scm_make_fptob ();
848 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
849 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
850 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
852 #include "libguile/fports.x"