1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19
20 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
21
22 #ifdef HAVE_CONFIG_H
23 # include <config.h>
24 #endif
25
26 #include <stdio.h>
27 #include <fcntl.h>
28 #include "libguile/_scm.h"
29 #include "libguile/strings.h"
30 #include "libguile/validate.h"
31 #include "libguile/gc.h"
32 #include "libguile/posix.h"
33 #include "libguile/dynwind.h"
34
35 #include "libguile/fports.h"
36
37 #ifdef HAVE_STRING_H
38 #include <string.h>
39 #endif
40 #ifdef HAVE_UNISTD_H
41 #include <unistd.h>
42 #endif
43 #ifdef HAVE_IO_H
44 #include <io.h>
45 #endif
46 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
47 #include <sys/stat.h>
48 #endif
49
50 #include <errno.h>
51 #include <sys/types.h>
52
53 #include "libguile/iselect.h"
54
55 /* Some defines for Windows (native port, not Cygwin). */
56 #ifdef __MINGW32__
57 # include <sys/stat.h>
58 # include <winsock2.h>
59 #endif /* __MINGW32__ */
60
61 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
62 already, but have this code here in case that wasn't so in past versions,
63 or perhaps to help other minimal DOS environments.
64
65 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
66 might be possibilities if we've got other systems without ftruncate. */
67
68 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
69 # define ftruncate(fd, size) chsize (fd, size)
70 #undef HAVE_FTRUNCATE
71 #define HAVE_FTRUNCATE 1
72 #endif
73
74 #if SIZEOF_OFF_T == SIZEOF_INT
75 #define OFF_T_MAX INT_MAX
76 #define OFF_T_MIN INT_MIN
77 #elif SIZEOF_OFF_T == SIZEOF_LONG
78 #define OFF_T_MAX LONG_MAX
79 #define OFF_T_MIN LONG_MIN
80 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
81 #define OFF_T_MAX LONG_LONG_MAX
82 #define OFF_T_MIN LONG_LONG_MIN
83 #else
84 #error Oops, unknown OFF_T size
85 #endif
86
87 scm_t_bits scm_tc16_fport;
88
89
90 /* default buffer size, used if the O/S won't supply a value. */
91 static const size_t default_buffer_size = 1024;
92
93 /* create FPORT buffer with specified sizes (or -1 to use default size or
94 0 for no buffer. */
95 static void
scm_fport_buffer_add(SCM port,long read_size,int write_size)96 scm_fport_buffer_add (SCM port, long read_size, int write_size)
97 #define FUNC_NAME "scm_fport_buffer_add"
98 {
99 scm_t_port *pt = SCM_PTAB_ENTRY (port);
100
101 if (read_size == -1 || write_size == -1)
102 {
103 size_t default_size;
104 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
105 struct stat st;
106 scm_t_fport *fp = SCM_FSTREAM (port);
107
108 default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
109 : st.st_blksize;
110 #else
111 default_size = default_buffer_size;
112 #endif
113 if (read_size == -1)
114 read_size = default_size;
115 if (write_size == -1)
116 write_size = default_size;
117 }
118
119 if (SCM_INPUT_PORT_P (port) && read_size > 0)
120 {
121 pt->read_buf = scm_gc_malloc (read_size, "port buffer");
122 pt->read_pos = pt->read_end = pt->read_buf;
123 pt->read_buf_size = read_size;
124 }
125 else
126 {
127 pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
128 pt->read_buf_size = 1;
129 }
130
131 if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
132 {
133 pt->write_buf = scm_gc_malloc (write_size, "port buffer");
134 pt->write_pos = pt->write_buf;
135 pt->write_buf_size = write_size;
136 }
137 else
138 {
139 pt->write_buf = pt->write_pos = &pt->shortbuf;
140 pt->write_buf_size = 1;
141 }
142
143 pt->write_end = pt->write_buf + pt->write_buf_size;
144 if (read_size > 0 || write_size > 0)
145 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
146 else
147 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
148 }
149 #undef FUNC_NAME
150
151 SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
152 (SCM port, SCM mode, SCM size),
153 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
154 "@table @code\n"
155 "@item _IONBF\n"
156 "non-buffered\n"
157 "@item _IOLBF\n"
158 "line buffered\n"
159 "@item _IOFBF\n"
160 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
161 "If @var{size} is omitted, a default size will be used.\n"
162 "@end table")
163 #define FUNC_NAME s_scm_setvbuf
164 {
165 int cmode;
166 long csize;
167 scm_t_port *pt;
168
169 port = SCM_COERCE_OUTPORT (port);
170
171 SCM_VALIDATE_OPFPORT (1,port);
172 cmode = scm_to_int (mode);
173 if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
174 scm_out_of_range (FUNC_NAME, mode);
175
176 if (cmode == _IOLBF)
177 {
178 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
179 cmode = _IOFBF;
180 }
181 else
182 {
183 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
184 }
185
186 if (SCM_UNBNDP (size))
187 {
188 if (cmode == _IOFBF)
189 csize = -1;
190 else
191 csize = 0;
192 }
193 else
194 {
195 csize = scm_to_int (size);
196 if (csize < 0 || (cmode == _IONBF && csize > 0))
197 scm_out_of_range (FUNC_NAME, size);
198 }
199
200 pt = SCM_PTAB_ENTRY (port);
201
202 /* silently discards buffered and put-back chars. */
203 if (pt->read_buf == pt->putback_buf)
204 {
205 pt->read_buf = pt->saved_read_buf;
206 pt->read_pos = pt->saved_read_pos;
207 pt->read_end = pt->saved_read_end;
208 pt->read_buf_size = pt->saved_read_buf_size;
209 }
210 if (pt->read_buf != &pt->shortbuf)
211 scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
212 if (pt->write_buf != &pt->shortbuf)
213 scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
214
215 scm_fport_buffer_add (port, csize, csize);
216 return SCM_UNSPECIFIED;
217 }
218 #undef FUNC_NAME
219
220 /* Move ports with the specified file descriptor to new descriptors,
221 * resetting the revealed count to 0.
222 */
223
224 void
scm_evict_ports(int fd)225 scm_evict_ports (int fd)
226 {
227 long i;
228
229 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
230
231 for (i = 0; i < scm_i_port_table_size; i++)
232 {
233 SCM port = scm_i_port_table[i]->port;
234
235 if (SCM_FPORTP (port))
236 {
237 scm_t_fport *fp = SCM_FSTREAM (port);
238
239 if (fp->fdes == fd)
240 {
241 fp->fdes = dup (fd);
242 if (fp->fdes == -1)
243 scm_syserror ("scm_evict_ports");
244 scm_set_port_revealed_x (port, scm_from_int (0));
245 }
246 }
247 }
248
249 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
250 }
251
252
253 SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
254 (SCM obj),
255 "Determine whether @var{obj} is a port that is related to a file.")
256 #define FUNC_NAME s_scm_file_port_p
257 {
258 return scm_from_bool (SCM_FPORTP (obj));
259 }
260 #undef FUNC_NAME
261
262
263 /* scm_open_file
264 * Return a new port open on a given file.
265 *
266 * The mode string must match the pattern: [rwa+]** which
267 * is interpreted in the usual unix way.
268 *
269 * Return the new port.
270 */
271 SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
272 (SCM filename, SCM mode),
273 "Open the file whose name is @var{filename}, and return a port\n"
274 "representing that file. The attributes of the port are\n"
275 "determined by the @var{mode} string. The way in which this is\n"
276 "interpreted is similar to C stdio. The first character must be\n"
277 "one of the following:\n"
278 "@table @samp\n"
279 "@item r\n"
280 "Open an existing file for input.\n"
281 "@item w\n"
282 "Open a file for output, creating it if it doesn't already exist\n"
283 "or removing its contents if it does.\n"
284 "@item a\n"
285 "Open a file for output, creating it if it doesn't already\n"
286 "exist. All writes to the port will go to the end of the file.\n"
287 "The \"append mode\" can be turned off while the port is in use\n"
288 "@pxref{Ports and File Descriptors, fcntl}\n"
289 "@end table\n"
290 "The following additional characters can be appended:\n"
291 "@table @samp\n"
292 "@item b\n"
293 "Open the underlying file in binary mode, if supported by the operating system. "
294 "@item +\n"
295 "Open the port for both input and output. E.g., @code{r+}: open\n"
296 "an existing file for both input and output.\n"
297 "@item 0\n"
298 "Create an \"unbuffered\" port. In this case input and output\n"
299 "operations are passed directly to the underlying port\n"
300 "implementation without additional buffering. This is likely to\n"
301 "slow down I/O operations. The buffering mode can be changed\n"
302 "while a port is in use @pxref{Ports and File Descriptors,\n"
303 "setvbuf}\n"
304 "@item l\n"
305 "Add line-buffering to the port. The port output buffer will be\n"
306 "automatically flushed whenever a newline character is written.\n"
307 "@end table\n"
308 "In theory we could create read/write ports which were buffered\n"
309 "in one direction only. However this isn't included in the\n"
310 "current interfaces. If a file cannot be opened with the access\n"
311 "requested, @code{open-file} throws an exception.")
312 #define FUNC_NAME s_scm_open_file
313 {
314 SCM port;
315 int fdes;
316 int flags = 0;
317 char *file;
318 char *md;
319 char *ptr;
320
321 scm_dynwind_begin (0);
322
323 file = scm_to_locale_string (filename);
324 scm_dynwind_free (file);
325
326 md = scm_to_locale_string (mode);
327 scm_dynwind_free (md);
328
329 switch (*md)
330 {
331 case 'r':
332 flags |= O_RDONLY;
333 break;
334 case 'w':
335 flags |= O_WRONLY | O_CREAT | O_TRUNC;
336 break;
337 case 'a':
338 flags |= O_WRONLY | O_CREAT | O_APPEND;
339 break;
340 default:
341 scm_out_of_range (FUNC_NAME, mode);
342 }
343 ptr = md + 1;
344 while (*ptr != '\0')
345 {
346 switch (*ptr)
347 {
348 case '+':
349 flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
350 break;
351 case 'b':
352 #if defined (O_BINARY)
353 flags |= O_BINARY;
354 #endif
355 break;
356 case '0': /* unbuffered: handled later. */
357 case 'l': /* line buffered: handled during output. */
358 break;
359 default:
360 scm_out_of_range (FUNC_NAME, mode);
361 }
362 ptr++;
363 }
364 SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
365 if (fdes == -1)
366 {
367 int en = errno;
368
369 SCM_SYSERROR_MSG ("~A: ~S",
370 scm_cons (scm_strerror (scm_from_int (en)),
371 scm_cons (filename, SCM_EOL)), en);
372 }
373 port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
374
375 scm_dynwind_end ();
376
377 return port;
378 }
379 #undef FUNC_NAME
380
381
382 #ifdef __MINGW32__
383 /*
384 * Try getting the appropiate file flags for a given file descriptor
385 * under Windows. This incorporates some fancy operations because Windows
386 * differentiates between file, pipe and socket descriptors.
387 */
388 #ifndef O_ACCMODE
389 # define O_ACCMODE 0x0003
390 #endif
391
getflags(int fdes)392 static int getflags (int fdes)
393 {
394 int flags = 0;
395 struct stat buf;
396 int error, optlen = sizeof (int);
397
398 /* Is this a socket ? */
399 if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
400 flags = O_RDWR;
401 /* Maybe a regular file ? */
402 else if (fstat (fdes, &buf) < 0)
403 flags = -1;
404 else
405 {
406 /* Or an anonymous pipe handle ? */
407 if (buf.st_mode & _S_IFIFO)
408 flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
409 NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
410 /* stdin ? */
411 else if (fdes == fileno (stdin) && isatty (fdes))
412 flags = O_RDONLY;
413 /* stdout / stderr ? */
414 else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
415 isatty (fdes))
416 flags = O_WRONLY;
417 else
418 flags = buf.st_mode;
419 }
420 return flags;
421 }
422 #endif /* __MINGW32__ */
423
424 /* Building Guile ports from a file descriptor. */
425
426 /* Build a Scheme port from an open file descriptor `fdes'.
427 MODE indicates whether FILE is open for reading or writing; it uses
428 the same notation as open-file's second argument.
429 NAME is a string to be used as the port's filename.
430 */
431 SCM
scm_i_fdes_to_port(int fdes,long mode_bits,SCM name)432 scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
433 #define FUNC_NAME "scm_fdes_to_port"
434 {
435 SCM port;
436 scm_t_port *pt;
437 int flags;
438
439 /* test that fdes is valid. */
440 #ifdef __MINGW32__
441 flags = getflags (fdes);
442 #else
443 flags = fcntl (fdes, F_GETFL, 0);
444 #endif
445 if (flags == -1)
446 SCM_SYSERROR;
447 flags &= O_ACCMODE;
448 if (flags != O_RDWR
449 && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
450 || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
451 {
452 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
453 }
454
455 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
456
457 port = scm_new_port_table_entry (scm_tc16_fport);
458 SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
459 pt = SCM_PTAB_ENTRY(port);
460 {
461 scm_t_fport *fp
462 = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
463
464 fp->fdes = fdes;
465 pt->rw_random = SCM_FDES_RANDOM_P (fdes);
466 SCM_SETSTREAM (port, fp);
467 if (mode_bits & SCM_BUF0)
468 scm_fport_buffer_add (port, 0, 0);
469 else
470 scm_fport_buffer_add (port, -1, -1);
471 }
472 SCM_SET_FILENAME (port, name);
473 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
474 return port;
475 }
476 #undef FUNC_NAME
477
478 SCM
scm_fdes_to_port(int fdes,char * mode,SCM name)479 scm_fdes_to_port (int fdes, char *mode, SCM name)
480 {
481 return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
482 }
483
484 /* Return a lower bound on the number of bytes available for input. */
485 static int
fport_input_waiting(SCM port)486 fport_input_waiting (SCM port)
487 {
488 #ifdef HAVE_SELECT
489 int fdes = SCM_FSTREAM (port)->fdes;
490 struct timeval timeout;
491 SELECT_TYPE read_set;
492 SELECT_TYPE write_set;
493 SELECT_TYPE except_set;
494
495 FD_ZERO (&read_set);
496 FD_ZERO (&write_set);
497 FD_ZERO (&except_set);
498
499 FD_SET (fdes, &read_set);
500
501 timeout.tv_sec = 0;
502 timeout.tv_usec = 0;
503
504 if (select (SELECT_SET_SIZE,
505 &read_set, &write_set, &except_set, &timeout)
506 < 0)
507 scm_syserror ("fport_input_waiting");
508 return FD_ISSET (fdes, &read_set) ? 1 : 0;
509
510 #elif HAVE_IOCTL && defined (FIONREAD)
511 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
512 (for use with winsock ioctlsocket()) but not ioctl(). */
513 int fdes = SCM_FSTREAM (port)->fdes;
514 int remir;
515 ioctl(fdes, FIONREAD, &remir);
516 return remir;
517
518 #else
519 scm_misc_error ("fport_input_waiting",
520 "Not fully implemented on this platform",
521 SCM_EOL);
522 #endif
523 }
524
525
526 static int
fport_print(SCM exp,SCM port,scm_print_state * pstate SCM_UNUSED)527 fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
528 {
529 scm_puts ("#<", port);
530 scm_print_port_mode (exp, port);
531 if (SCM_OPFPORTP (exp))
532 {
533 int fdes;
534 SCM name = SCM_FILENAME (exp);
535 if (scm_is_string (name) || scm_is_symbol (name))
536 scm_display (name, port);
537 else
538 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
539 scm_putc (' ', port);
540 fdes = (SCM_FSTREAM (exp))->fdes;
541
542 #ifdef HAVE_TTYNAME
543 if (isatty (fdes))
544 scm_display (scm_ttyname (exp), port);
545 else
546 #endif /* HAVE_TTYNAME */
547 scm_intprint (fdes, 10, port);
548 }
549 else
550 {
551 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
552 scm_putc (' ', port);
553 scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
554 }
555 scm_putc ('>', port);
556 return 1;
557 }
558
559 #ifndef __MINGW32__
560 /* thread-local block for input on fport's fdes. */
561 static void
fport_wait_for_input(SCM port)562 fport_wait_for_input (SCM port)
563 {
564 int fdes = SCM_FSTREAM (port)->fdes;
565
566 if (!fport_input_waiting (port))
567 {
568 int n;
569 SELECT_TYPE readfds;
570 int flags = fcntl (fdes, F_GETFL);
571
572 if (flags == -1)
573 scm_syserror ("scm_fdes_wait_for_input");
574 if (!(flags & O_NONBLOCK))
575 do
576 {
577 FD_ZERO (&readfds);
578 FD_SET (fdes, &readfds);
579 n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
580 }
581 while (n == -1 && errno == EINTR);
582 }
583 }
584 #endif /* !__MINGW32__ */
585
586 static void fport_flush (SCM port);
587
588 /* fill a port's read-buffer with a single read. returns the first
589 char or EOF if end of file. */
590 static int
fport_fill_input(SCM port)591 fport_fill_input (SCM port)
592 {
593 long count;
594 scm_t_port *pt = SCM_PTAB_ENTRY (port);
595 scm_t_fport *fp = SCM_FSTREAM (port);
596
597 #ifndef __MINGW32__
598 fport_wait_for_input (port);
599 #endif /* !__MINGW32__ */
600 SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
601 if (count == -1)
602 scm_syserror ("fport_fill_input");
603 if (count == 0)
604 return EOF;
605 else
606 {
607 pt->read_pos = pt->read_buf;
608 pt->read_end = pt->read_buf + count;
609 return *pt->read_buf;
610 }
611 }
612
613 static off_t_or_off64_t
fport_seek_or_seek64(SCM port,off_t_or_off64_t offset,int whence)614 fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
615 {
616 scm_t_port *pt = SCM_PTAB_ENTRY (port);
617 scm_t_fport *fp = SCM_FSTREAM (port);
618 off_t_or_off64_t rv;
619 off_t_or_off64_t result;
620
621 if (pt->rw_active == SCM_PORT_WRITE)
622 {
623 if (offset != 0 || whence != SEEK_CUR)
624 {
625 fport_flush (port);
626 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
627 }
628 else
629 {
630 /* read current position without disturbing the buffer. */
631 rv = lseek_or_lseek64 (fp->fdes, offset, whence);
632 result = rv + (pt->write_pos - pt->write_buf);
633 }
634 }
635 else if (pt->rw_active == SCM_PORT_READ)
636 {
637 if (offset != 0 || whence != SEEK_CUR)
638 {
639 /* could expand to avoid a second seek. */
640 scm_end_input (port);
641 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
642 }
643 else
644 {
645 /* read current position without disturbing the buffer
646 (particularly the unread-char buffer). */
647 rv = lseek_or_lseek64 (fp->fdes, offset, whence);
648 result = rv - (pt->read_end - pt->read_pos);
649
650 if (pt->read_buf == pt->putback_buf)
651 result -= pt->saved_read_end - pt->saved_read_pos;
652 }
653 }
654 else /* SCM_PORT_NEITHER */
655 {
656 result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
657 }
658
659 if (rv == -1)
660 scm_syserror ("fport_seek");
661
662 return result;
663 }
664
665 /* If we've got largefile and off_t isn't already off64_t then
666 fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
667 the port descriptor.
668
669 Otherwise if no largefile, or off_t is the same as off64_t (which is the
670 case on NetBSD apparently), then fport_seek_or_seek64 is right to be
671 fport_seek already. */
672
673 #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
674 static off_t
fport_seek(SCM port,off_t offset,int whence)675 fport_seek (SCM port, off_t offset, int whence)
676 {
677 off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
678 if (rv > OFF_T_MAX || rv < OFF_T_MIN)
679 {
680 errno = EOVERFLOW;
681 scm_syserror ("fport_seek");
682 }
683 return (off_t) rv;
684
685 }
686 #else
687 #define fport_seek fport_seek_or_seek64
688 #endif
689
690 /* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
691 SCM
scm_i_fport_seek(SCM port,SCM offset,int how)692 scm_i_fport_seek (SCM port, SCM offset, int how)
693 {
694 return scm_from_off_t_or_off64_t
695 (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
696 }
697
698 static void
fport_truncate(SCM port,off_t length)699 fport_truncate (SCM port, off_t length)
700 {
701 scm_t_fport *fp = SCM_FSTREAM (port);
702
703 if (ftruncate (fp->fdes, length) == -1)
704 scm_syserror ("ftruncate");
705 }
706
707 int
scm_i_fport_truncate(SCM port,SCM length)708 scm_i_fport_truncate (SCM port, SCM length)
709 {
710 scm_t_fport *fp = SCM_FSTREAM (port);
711 return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
712 }
713
714 /* helper for fport_write: try to write data, using multiple system
715 calls if required. */
716 #define FUNC_NAME "write_all"
write_all(SCM port,const void * data,size_t remaining)717 static void write_all (SCM port, const void *data, size_t remaining)
718 {
719 int fdes = SCM_FSTREAM (port)->fdes;
720
721 while (remaining > 0)
722 {
723 size_t done;
724
725 SCM_SYSCALL (done = write (fdes, data, remaining));
726
727 if (done == -1)
728 SCM_SYSERROR;
729 remaining -= done;
730 data = ((const char *) data) + done;
731 }
732 }
733 #undef FUNC_NAME
734
735 static void
fport_write(SCM port,const void * data,size_t size)736 fport_write (SCM port, const void *data, size_t size)
737 {
738 /* this procedure tries to minimize the number of writes/flushes. */
739 scm_t_port *pt = SCM_PTAB_ENTRY (port);
740
741 if (pt->write_buf == &pt->shortbuf
742 || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
743 {
744 /* "unbuffered" port, or
745 port with empty buffer and data won't fit in buffer. */
746 write_all (port, data, size);
747 return;
748 }
749
750 {
751 off_t space = pt->write_end - pt->write_pos;
752
753 if (size <= space)
754 {
755 /* data fits in buffer. */
756 memcpy (pt->write_pos, data, size);
757 pt->write_pos += size;
758 if (pt->write_pos == pt->write_end)
759 {
760 fport_flush (port);
761 /* we can skip the line-buffering check if nothing's buffered. */
762 return;
763 }
764 }
765 else
766 {
767 memcpy (pt->write_pos, data, space);
768 pt->write_pos = pt->write_end;
769 fport_flush (port);
770 {
771 const void *ptr = ((const char *) data) + space;
772 size_t remaining = size - space;
773
774 if (size >= pt->write_buf_size)
775 {
776 write_all (port, ptr, remaining);
777 return;
778 }
779 else
780 {
781 memcpy (pt->write_pos, ptr, remaining);
782 pt->write_pos += remaining;
783 }
784 }
785 }
786
787 /* handle line buffering. */
788 if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
789 fport_flush (port);
790 }
791 }
792
793 /* becomes 1 when process is exiting: normal exception handling won't
794 work by this time. */
795 extern int scm_i_terminating;
796
797 static void
fport_flush(SCM port)798 fport_flush (SCM port)
799 {
800 scm_t_port *pt = SCM_PTAB_ENTRY (port);
801 scm_t_fport *fp = SCM_FSTREAM (port);
802 unsigned char *ptr = pt->write_buf;
803 long init_size = pt->write_pos - pt->write_buf;
804 long remaining = init_size;
805
806 while (remaining > 0)
807 {
808 long count;
809
810 SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
811 if (count < 0)
812 {
813 /* error. assume nothing was written this call, but
814 fix up the buffer for any previous successful writes. */
815 long done = init_size - remaining;
816
817 if (done > 0)
818 {
819 int i;
820
821 for (i = 0; i < remaining; i++)
822 {
823 *(pt->write_buf + i) = *(pt->write_buf + done + i);
824 }
825 pt->write_pos = pt->write_buf + remaining;
826 }
827 if (scm_i_terminating)
828 {
829 const char *msg = "Error: could not flush file-descriptor ";
830 char buf[11];
831 size_t written;
832
833 written = write (2, msg, strlen (msg));
834 sprintf (buf, "%d\n", fp->fdes);
835 written = write (2, buf, strlen (buf));
836
837 count = remaining;
838 }
839 else if (scm_gc_running_p)
840 {
841 /* silently ignore the error. scm_error would abort if we
842 called it now. */
843 count = remaining;
844 }
845 else
846 scm_syserror ("fport_flush");
847 }
848 ptr += count;
849 remaining -= count;
850 }
851 pt->write_pos = pt->write_buf;
852 pt->rw_active = SCM_PORT_NEITHER;
853 }
854
855 /* clear the read buffer and adjust the file position for unread bytes. */
856 static void
fport_end_input(SCM port,int offset)857 fport_end_input (SCM port, int offset)
858 {
859 scm_t_fport *fp = SCM_FSTREAM (port);
860 scm_t_port *pt = SCM_PTAB_ENTRY (port);
861
862 offset += pt->read_end - pt->read_pos;
863
864 if (offset > 0)
865 {
866 pt->read_pos = pt->read_end;
867 /* will throw error if unread-char used at beginning of file
868 then attempting to write. seems correct. */
869 if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
870 scm_syserror ("fport_end_input");
871 }
872 pt->rw_active = SCM_PORT_NEITHER;
873 }
874
875 static int
fport_close(SCM port)876 fport_close (SCM port)
877 {
878 scm_t_fport *fp = SCM_FSTREAM (port);
879 scm_t_port *pt = SCM_PTAB_ENTRY (port);
880 int rv;
881
882 fport_flush (port);
883 SCM_SYSCALL (rv = close (fp->fdes));
884 if (rv == -1 && errno != EBADF)
885 {
886 if (scm_gc_running_p)
887 /* silently ignore the error. scm_error would abort if we
888 called it now. */
889 ;
890 else
891 scm_syserror ("fport_close");
892 }
893 if (pt->read_buf == pt->putback_buf)
894 pt->read_buf = pt->saved_read_buf;
895 if (pt->read_buf != &pt->shortbuf)
896 scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
897 if (pt->write_buf != &pt->shortbuf)
898 scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
899 scm_gc_free (fp, sizeof (*fp), "file port");
900 return rv;
901 }
902
903 static size_t
fport_free(SCM port)904 fport_free (SCM port)
905 {
906 fport_close (port);
907 return 0;
908 }
909
910 static scm_t_bits
scm_make_fptob()911 scm_make_fptob ()
912 {
913 scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
914
915 scm_set_port_free (tc, fport_free);
916 scm_set_port_print (tc, fport_print);
917 scm_set_port_flush (tc, fport_flush);
918 scm_set_port_end_input (tc, fport_end_input);
919 scm_set_port_close (tc, fport_close);
920 scm_set_port_seek (tc, fport_seek);
921 scm_set_port_truncate (tc, fport_truncate);
922 scm_set_port_input_waiting (tc, fport_input_waiting);
923
924 return tc;
925 }
926
927 void
scm_init_fports()928 scm_init_fports ()
929 {
930 scm_tc16_fport = scm_make_fptob ();
931
932 scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
933 scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
934 scm_c_define ("_IONBF", scm_from_int (_IONBF));
935
936 #include "libguile/fports.x"
937 }
938
939 /*
940 Local Variables:
941 c-file-style: "gnu"
942 End:
943 */
944