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"
30 #include "libguile/dynwind.h"
32 #include "libguile/fports.h"
45 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
51 #include "libguile/iselect.h"
53 /* Some defines for Windows (native port, not Cygwin). */
55 # include <sys/stat.h>
56 # include <winsock2.h>
57 # define ftruncate(fd, size) chsize (fd, size)
58 #endif /* __MINGW32__ */
61 scm_t_bits scm_tc16_fport
;
64 /* default buffer size, used if the O/S won't supply a value. */
65 static const size_t default_buffer_size
= 1024;
67 /* create FPORT buffer with specified sizes (or -1 to use default size or
70 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
71 #define FUNC_NAME "scm_fport_buffer_add"
73 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
75 if (read_size
== -1 || write_size
== -1)
78 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
80 scm_t_fport
*fp
= SCM_FSTREAM (port
);
82 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
85 default_size
= default_buffer_size
;
88 read_size
= default_size
;
90 write_size
= default_size
;
93 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
95 pt
->read_buf
= scm_gc_malloc (read_size
, "port buffer");
96 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
97 pt
->read_buf_size
= read_size
;
101 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
102 pt
->read_buf_size
= 1;
105 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
107 pt
->write_buf
= scm_gc_malloc (write_size
, "port buffer");
108 pt
->write_pos
= pt
->write_buf
;
109 pt
->write_buf_size
= write_size
;
113 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
114 pt
->write_buf_size
= 1;
117 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
118 if (read_size
> 0 || write_size
> 0)
119 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
121 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
125 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
126 (SCM port
, SCM mode
, SCM size
),
127 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
134 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
135 "If @var{size} is omitted, a default size will be used.\n"
137 #define FUNC_NAME s_scm_setvbuf
143 port
= SCM_COERCE_OUTPORT (port
);
145 SCM_VALIDATE_OPFPORT (1,port
);
146 cmode
= scm_to_int (mode
);
147 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
148 scm_out_of_range (FUNC_NAME
, mode
);
152 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
157 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) ^ SCM_BUFLINE
);
160 if (SCM_UNBNDP (size
))
169 csize
= scm_to_int (size
);
170 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
171 scm_out_of_range (FUNC_NAME
, size
);
174 pt
= SCM_PTAB_ENTRY (port
);
176 /* silently discards buffered and put-back chars. */
177 if (pt
->read_buf
== pt
->putback_buf
)
179 pt
->read_buf
= pt
->saved_read_buf
;
180 pt
->read_pos
= pt
->saved_read_pos
;
181 pt
->read_end
= pt
->saved_read_end
;
182 pt
->read_buf_size
= pt
->saved_read_buf_size
;
184 if (pt
->read_buf
!= &pt
->shortbuf
)
185 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
186 if (pt
->write_buf
!= &pt
->shortbuf
)
187 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
189 scm_fport_buffer_add (port
, csize
, csize
);
190 return SCM_UNSPECIFIED
;
194 /* Move ports with the specified file descriptor to new descriptors,
195 * resetting the revealed count to 0.
199 scm_evict_ports (int fd
)
203 scm_mutex_lock (&scm_i_port_table_mutex
);
205 for (i
= 0; i
< scm_i_port_table_size
; i
++)
207 SCM port
= scm_i_port_table
[i
]->port
;
209 if (SCM_FPORTP (port
))
211 scm_t_fport
*fp
= SCM_FSTREAM (port
);
217 scm_syserror ("scm_evict_ports");
218 scm_set_port_revealed_x (port
, scm_from_int (0));
223 scm_mutex_unlock (&scm_i_port_table_mutex
);
227 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
229 "Determine whether @var{obj} is a port that is related to a file.")
230 #define FUNC_NAME s_scm_file_port_p
232 return scm_from_bool (SCM_FPORTP (obj
));
238 * Return a new port open on a given file.
240 * The mode string must match the pattern: [rwa+]** which
241 * is interpreted in the usual unix way.
243 * Return the new port.
245 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
246 (SCM filename
, SCM mode
),
247 "Open the file whose name is @var{filename}, and return a port\n"
248 "representing that file. The attributes of the port are\n"
249 "determined by the @var{mode} string. The way in which this is\n"
250 "interpreted is similar to C stdio. The first character must be\n"
251 "one of the following:\n"
254 "Open an existing file for input.\n"
256 "Open a file for output, creating it if it doesn't already exist\n"
257 "or removing its contents if it does.\n"
259 "Open a file for output, creating it if it doesn't already\n"
260 "exist. All writes to the port will go to the end of the file.\n"
261 "The \"append mode\" can be turned off while the port is in use\n"
262 "@pxref{Ports and File Descriptors, fcntl}\n"
264 "The following additional characters can be appended:\n"
267 "Open the port for both input and output. E.g., @code{r+}: open\n"
268 "an existing file for both input and output.\n"
270 "Create an \"unbuffered\" port. In this case input and output\n"
271 "operations are passed directly to the underlying port\n"
272 "implementation without additional buffering. This is likely to\n"
273 "slow down I/O operations. The buffering mode can be changed\n"
274 "while a port is in use @pxref{Ports and File Descriptors,\n"
277 "Add line-buffering to the port. The port output buffer will be\n"
278 "automatically flushed whenever a newline character is written.\n"
280 "In theory we could create read/write ports which were buffered\n"
281 "in one direction only. However this isn't included in the\n"
282 "current interfaces. If a file cannot be opened with the access\n"
283 "requested, @code{open-file} throws an exception.")
284 #define FUNC_NAME s_scm_open_file
295 file
= scm_to_locale_string (filename
);
296 scm_frame_free (file
);
298 md
= scm_to_locale_string (mode
);
307 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
310 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
313 scm_out_of_range (FUNC_NAME
, mode
);
321 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
324 #if defined (O_BINARY)
328 case '0': /* unbuffered: handled later. */
329 case 'l': /* line buffered: handled during output. */
332 scm_out_of_range (FUNC_NAME
, mode
);
336 SCM_SYSCALL (fdes
= open (file
, flags
, 0666));
341 SCM_SYSERROR_MSG ("~A: ~S",
342 scm_cons (scm_strerror (scm_from_int (en
)),
343 scm_cons (filename
, SCM_EOL
)), en
);
345 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
), 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
& _S_IFIFO
)
380 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
381 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
383 else if (fdes
== fileno (stdin
) && isatty (fdes
))
385 /* stdout / stderr ? */
386 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
394 #endif /* __MINGW32__ */
396 /* Building Guile ports from a file descriptor. */
398 /* Build a Scheme port from an open file descriptor `fdes'.
399 MODE indicates whether FILE is open for reading or writing; it uses
400 the same notation as open-file's second argument.
401 NAME is a string to be used as the port's filename.
404 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
405 #define FUNC_NAME "scm_fdes_to_port"
411 /* test that fdes is valid. */
413 flags
= getflags (fdes
);
415 flags
= fcntl (fdes
, F_GETFL
, 0);
421 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
422 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
424 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
427 scm_mutex_lock (&scm_i_port_table_mutex
);
429 port
= scm_new_port_table_entry (scm_tc16_fport
);
430 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
431 pt
= SCM_PTAB_ENTRY(port
);
434 = (scm_t_fport
*) scm_gc_malloc (sizeof (scm_t_fport
), "file port");
437 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
438 SCM_SETSTREAM (port
, fp
);
439 if (mode_bits
& SCM_BUF0
)
440 scm_fport_buffer_add (port
, 0, 0);
442 scm_fport_buffer_add (port
, -1, -1);
444 SCM_SET_FILENAME (port
, name
);
445 scm_mutex_unlock (&scm_i_port_table_mutex
);
451 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
453 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
456 /* Return a lower bound on the number of bytes available for input. */
458 fport_input_waiting (SCM port
)
460 int fdes
= SCM_FSTREAM (port
)->fdes
;
463 struct timeval timeout
;
464 SELECT_TYPE read_set
;
465 SELECT_TYPE write_set
;
466 SELECT_TYPE except_set
;
469 FD_ZERO (&write_set
);
470 FD_ZERO (&except_set
);
472 FD_SET (fdes
, &read_set
);
477 if (select (SELECT_SET_SIZE
,
478 &read_set
, &write_set
, &except_set
, &timeout
)
480 scm_syserror ("fport_input_waiting");
481 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
482 #elif defined (FIONREAD)
484 ioctl(fdes
, FIONREAD
, &remir
);
487 scm_misc_error ("fport_input_waiting",
488 "Not fully implemented on this platform",
495 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
497 scm_puts ("#<", port
);
498 scm_print_port_mode (exp
, port
);
499 if (SCM_OPFPORTP (exp
))
502 SCM name
= SCM_FILENAME (exp
);
503 if (scm_is_string (name
) || SCM_SYMBOLP (name
))
504 scm_display (name
, port
);
506 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
507 scm_putc (' ', port
);
508 fdes
= (SCM_FSTREAM (exp
))->fdes
;
512 scm_puts (ttyname (fdes
), port
);
514 #endif /* HAVE_TTYNAME */
515 scm_intprint (fdes
, 10, port
);
519 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
520 scm_putc (' ', port
);
521 scm_intprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
523 scm_putc ('>', port
);
528 /* thread-local block for input on fport's fdes. */
530 fport_wait_for_input (SCM port
)
532 int fdes
= SCM_FSTREAM (port
)->fdes
;
534 if (!fport_input_waiting (port
))
538 int flags
= fcntl (fdes
, F_GETFL
);
541 scm_syserror ("scm_fdes_wait_for_input");
542 if (!(flags
& O_NONBLOCK
))
546 FD_SET (fdes
, &readfds
);
547 n
= scm_internal_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
549 while (n
== -1 && errno
== EINTR
);
552 #endif /* !__MINGW32__ */
554 static void fport_flush (SCM port
);
556 /* fill a port's read-buffer with a single read. returns the first
557 char or EOF if end of file. */
559 fport_fill_input (SCM port
)
562 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
563 scm_t_fport
*fp
= SCM_FSTREAM (port
);
566 fport_wait_for_input (port
);
567 #endif /* !__MINGW32__ */
568 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
570 scm_syserror ("fport_fill_input");
575 pt
->read_pos
= pt
->read_buf
;
576 pt
->read_end
= pt
->read_buf
+ count
;
577 return *pt
->read_buf
;
582 fport_seek (SCM port
, off_t offset
, int whence
)
584 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
585 scm_t_fport
*fp
= SCM_FSTREAM (port
);
589 if (pt
->rw_active
== SCM_PORT_WRITE
)
591 if (offset
!= 0 || whence
!= SEEK_CUR
)
594 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
598 /* read current position without disturbing the buffer. */
599 rv
= lseek (fp
->fdes
, offset
, whence
);
600 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
603 else if (pt
->rw_active
== SCM_PORT_READ
)
605 if (offset
!= 0 || whence
!= SEEK_CUR
)
607 /* could expand to avoid a second seek. */
608 scm_end_input (port
);
609 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
613 /* read current position without disturbing the buffer
614 (particularly the unread-char buffer). */
615 rv
= lseek (fp
->fdes
, offset
, whence
);
616 result
= rv
- (pt
->read_end
- pt
->read_pos
);
618 if (pt
->read_buf
== pt
->putback_buf
)
619 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
622 else /* SCM_PORT_NEITHER */
624 result
= rv
= lseek (fp
->fdes
, offset
, whence
);
628 scm_syserror ("fport_seek");
634 fport_truncate (SCM port
, off_t length
)
636 scm_t_fport
*fp
= SCM_FSTREAM (port
);
638 if (ftruncate (fp
->fdes
, length
) == -1)
639 scm_syserror ("ftruncate");
642 /* helper for fport_write: try to write data, using multiple system
643 calls if required. */
644 #define FUNC_NAME "write_all"
645 static void write_all (SCM port
, const void *data
, size_t remaining
)
647 int fdes
= SCM_FSTREAM (port
)->fdes
;
649 while (remaining
> 0)
653 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
658 data
= ((const char *) data
) + done
;
664 fport_write (SCM port
, const void *data
, size_t size
)
666 /* this procedure tries to minimize the number of writes/flushes. */
667 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
669 if (pt
->write_buf
== &pt
->shortbuf
670 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
672 /* "unbuffered" port, or
673 port with empty buffer and data won't fit in buffer. */
674 write_all (port
, data
, size
);
679 off_t space
= pt
->write_end
- pt
->write_pos
;
683 /* data fits in buffer. */
684 memcpy (pt
->write_pos
, data
, size
);
685 pt
->write_pos
+= size
;
686 if (pt
->write_pos
== pt
->write_end
)
689 /* we can skip the line-buffering check if nothing's buffered. */
695 memcpy (pt
->write_pos
, data
, space
);
696 pt
->write_pos
= pt
->write_end
;
699 const void *ptr
= ((const char *) data
) + space
;
700 size_t remaining
= size
- space
;
702 if (size
>= pt
->write_buf_size
)
704 write_all (port
, ptr
, remaining
);
709 memcpy (pt
->write_pos
, ptr
, remaining
);
710 pt
->write_pos
+= remaining
;
715 /* handle line buffering. */
716 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
721 /* becomes 1 when process is exiting: normal exception handling won't
722 work by this time. */
723 extern int scm_i_terminating
;
726 fport_flush (SCM port
)
728 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
729 scm_t_fport
*fp
= SCM_FSTREAM (port
);
730 unsigned char *ptr
= pt
->write_buf
;
731 long init_size
= pt
->write_pos
- pt
->write_buf
;
732 long remaining
= init_size
;
734 while (remaining
> 0)
738 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
741 /* error. assume nothing was written this call, but
742 fix up the buffer for any previous successful writes. */
743 long done
= init_size
- remaining
;
749 for (i
= 0; i
< remaining
; i
++)
751 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
753 pt
->write_pos
= pt
->write_buf
+ remaining
;
755 if (scm_i_terminating
)
757 const char *msg
= "Error: could not flush file-descriptor ";
760 write (2, msg
, strlen (msg
));
761 sprintf (buf
, "%d\n", fp
->fdes
);
762 write (2, buf
, strlen (buf
));
766 else if (scm_gc_running_p
)
768 /* silently ignore the error. scm_error would abort if we
773 scm_syserror ("fport_flush");
778 pt
->write_pos
= pt
->write_buf
;
779 pt
->rw_active
= SCM_PORT_NEITHER
;
782 /* clear the read buffer and adjust the file position for unread bytes. */
784 fport_end_input (SCM port
, int offset
)
786 scm_t_fport
*fp
= SCM_FSTREAM (port
);
787 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
789 offset
+= pt
->read_end
- pt
->read_pos
;
793 pt
->read_pos
= pt
->read_end
;
794 /* will throw error if unread-char used at beginning of file
795 then attempting to write. seems correct. */
796 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
797 scm_syserror ("fport_end_input");
799 pt
->rw_active
= SCM_PORT_NEITHER
;
803 fport_close (SCM port
)
805 scm_t_fport
*fp
= SCM_FSTREAM (port
);
806 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
810 SCM_SYSCALL (rv
= close (fp
->fdes
));
811 if (rv
== -1 && errno
!= EBADF
)
813 if (scm_gc_running_p
)
814 /* silently ignore the error. scm_error would abort if we
818 scm_syserror ("fport_close");
820 if (pt
->read_buf
== pt
->putback_buf
)
821 pt
->read_buf
= pt
->saved_read_buf
;
822 if (pt
->read_buf
!= &pt
->shortbuf
)
823 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
824 if (pt
->write_buf
!= &pt
->shortbuf
)
825 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
826 scm_gc_free (fp
, sizeof (*fp
), "file port");
831 fport_free (SCM port
)
840 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
842 scm_set_port_free (tc
, fport_free
);
843 scm_set_port_print (tc
, fport_print
);
844 scm_set_port_flush (tc
, fport_flush
);
845 scm_set_port_end_input (tc
, fport_end_input
);
846 scm_set_port_close (tc
, fport_close
);
847 scm_set_port_seek (tc
, fport_seek
);
848 scm_set_port_truncate (tc
, fport_truncate
);
849 scm_set_port_input_waiting (tc
, fport_input_waiting
);
857 scm_tc16_fport
= scm_make_fptob ();
859 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
860 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
861 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
863 #include "libguile/fports.x"