* Added a file-port? primitive.
[bpt/guile.git] / libguile / fports.c
CommitLineData
f2c9fcb0 1/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc.
0f2d19dd
JB
2 *
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)
6 * any later version.
7 *
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.
12 *
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
82892bed
JB
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
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.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
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.
37 *
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.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84
GB
41
42/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
0f2d19dd
JB
45\f
46
47#include <stdio.h>
cb63cf9e 48#include <fcntl.h>
a0599745
MD
49#include "libguile/_scm.h"
50#include "libguile/strings.h"
a0599745 51#include "libguile/validate.h"
6b72ac1d
GH
52#include "libguile/gc.h"
53
a0599745 54#include "libguile/fports.h"
95b88819
GH
55
56#ifdef HAVE_STRING_H
57#include <string.h>
58#endif
0f2d19dd
JB
59#ifdef HAVE_UNISTD_H
60#include <unistd.h>
61#else
0f2d19dd
JB
62scm_sizet fwrite ();
63#endif
cb63cf9e
JB
64#ifdef HAVE_ST_BLKSIZE
65#include <sys/stat.h>
66#endif
0f2d19dd 67
cb63cf9e 68#include <errno.h>
e145dd02 69
a0599745 70#include "libguile/iselect.h"
cb63cf9e 71
a98bddfd
DH
72
73scm_bits_t scm_tc16_fport;
74
75
19b27fa2
GH
76/* default buffer size, used if the O/S won't supply a value. */
77static const int default_buffer_size = 1024;
78
cb63cf9e
JB
79/* create FPORT buffer with specified sizes (or -1 to use default size or
80 0 for no buffer. */
81static void
82scm_fport_buffer_add (SCM port, int read_size, int write_size)
e145dd02 83{
cb63cf9e 84 struct scm_fport *fp = SCM_FSTREAM (port);
b24b5e13 85 scm_port *pt = SCM_PTAB_ENTRY (port);
cb63cf9e 86 char *s_scm_fport_buffer_add = "scm_fport_buffer_add";
e145dd02 87
cb63cf9e
JB
88 if (read_size == -1 || write_size == -1)
89 {
90 int default_size;
91#ifdef HAVE_ST_BLKSIZE
92 struct stat st;
93
19b27fa2
GH
94 default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
95 : st.st_blksize;
cb63cf9e 96#else
19b27fa2 97 default_size = default_buffer_size;
cb63cf9e
JB
98#endif
99 if (read_size == -1)
100 read_size = default_size;
101 if (write_size == -1)
102 write_size = default_size;
103 }
0f2d19dd 104
f5f2dcff 105 if (SCM_INPUT_PORT_P (port) && read_size > 0)
cb63cf9e 106 {
840ae05d
JB
107 pt->read_buf = malloc (read_size);
108 if (pt->read_buf == NULL)
109 scm_memory_error (s_scm_fport_buffer_add);
cb63cf9e
JB
110 pt->read_pos = pt->read_end = pt->read_buf;
111 pt->read_buf_size = read_size;
112 }
113 else
114 {
840ae05d 115 pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
cb63cf9e
JB
116 pt->read_buf_size = 1;
117 }
1717856b 118
f5f2dcff 119 if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
cb63cf9e 120 {
840ae05d
JB
121 pt->write_buf = malloc (write_size);
122 if (pt->write_buf == NULL)
123 scm_memory_error (s_scm_fport_buffer_add);
cb63cf9e
JB
124 pt->write_pos = pt->write_buf;
125 pt->write_buf_size = write_size;
126 }
127 else
128 {
129 pt->write_buf = pt->write_pos = &pt->shortbuf;
130 pt->write_buf_size = 1;
131 }
132
133 pt->write_end = pt->write_buf + pt->write_buf_size;
134 if (read_size > 0 || write_size > 0)
54778cd3 135 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
cb63cf9e 136 else
54778cd3 137 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
7a6f1ffa
GH
138}
139
a1ec6916 140SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
1bbd0b84 141 (SCM port, SCM mode, SCM size),
fc0d72d4
MD
142 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
143 "@table @code\n"
144 "@item _IONBF\n"
145 "non-buffered\n"
146 "@item _IOLBF\n"
147 "line buffered\n"
148 "@item _IOFBF\n"
149 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
150 "If @var{size} is omitted, a default size will be used.\n"
2c1ae20e 151 "@end table")
1bbd0b84 152#define FUNC_NAME s_scm_setvbuf
7a6f1ffa 153{
7a6f1ffa 154 int cmode, csize;
840ae05d 155 scm_port *pt;
7a6f1ffa 156
78446828
MV
157 port = SCM_COERCE_OUTPORT (port);
158
3b3b36dd
GB
159 SCM_VALIDATE_OPFPORT (1,port);
160 SCM_VALIDATE_INUM_COPY (2,mode,cmode);
d3639214 161 if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
1bbd0b84 162 scm_out_of_range (FUNC_NAME, mode);
d3639214
GH
163
164 if (cmode == _IOLBF)
165 {
54778cd3 166 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
d3639214
GH
167 cmode = _IOFBF;
168 }
169 else
170 {
54778cd3 171 SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) ^ SCM_BUFLINE);
d3639214
GH
172 }
173
7a6f1ffa 174 if (SCM_UNBNDP (size))
cb63cf9e
JB
175 {
176 if (cmode == _IOFBF)
177 csize = -1;
178 else
179 csize = 0;
180 }
7a6f1ffa
GH
181 else
182 {
3b3b36dd 183 SCM_VALIDATE_INUM_COPY (3,size,csize);
cb63cf9e 184 if (csize < 0 || (cmode == _IONBF && csize > 0))
1bbd0b84 185 scm_out_of_range (FUNC_NAME, size);
7a6f1ffa 186 }
d3639214 187
cb63cf9e 188 pt = SCM_PTAB_ENTRY (port);
7a6f1ffa 189
cb63cf9e
JB
190 /* silently discards buffered chars. */
191 if (pt->read_buf != &pt->shortbuf)
f30c9c8f 192 free (pt->read_buf);
cb63cf9e 193 if (pt->write_buf != &pt->shortbuf)
f30c9c8f 194 free (pt->write_buf);
7a6f1ffa 195
cb63cf9e
JB
196 scm_fport_buffer_add (port, csize, csize);
197 return SCM_UNSPECIFIED;
0f2d19dd 198}
1bbd0b84 199#undef FUNC_NAME
0f2d19dd 200
eadd48de
GH
201/* Move ports with the specified file descriptor to new descriptors,
202 * reseting the revealed count to 0.
0f2d19dd 203 */
1717856b 204
eadd48de 205void
6e8d25a6 206scm_evict_ports (int fd)
0f2d19dd 207{
eadd48de 208 int i;
0f2d19dd 209
eadd48de
GH
210 for (i = 0; i < scm_port_table_size; i++)
211 {
cb63cf9e
JB
212 SCM port = scm_port_table[i]->port;
213
214 if (SCM_FPORTP (port))
eadd48de 215 {
cb63cf9e
JB
216 struct scm_fport *fp = SCM_FSTREAM (port);
217
218 if (fp->fdes == fd)
219 {
220 fp->fdes = dup (fd);
221 if (fp->fdes == -1)
222 scm_syserror ("scm_evict_ports");
223 scm_set_port_revealed_x (port, SCM_MAKINUM (0));
224 }
eadd48de
GH
225 }
226 }
227}
0f2d19dd 228
efa40607
DH
229
230SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
231 (SCM obj),
232 "Determine whether OBJ is a port that is related to a file.")
233#define FUNC_NAME s_scm_file_port_p
234{
235 return SCM_BOOL (SCM_FPORTP (obj));
236}
237#undef FUNC_NAME
238
239
0f2d19dd
JB
240/* scm_open_file
241 * Return a new port open on a given file.
242 *
243 * The mode string must match the pattern: [rwa+]** which
244 * is interpreted in the usual unix way.
245 *
246 * Return the new port.
247 */
3b3b36dd 248SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
1bbd0b84 249 (SCM filename, SCM modes),
fc0d72d4
MD
250 "Open the file whose name is @var{string}, and return a port\n"
251 "representing that file. The attributes of the port are\n"
252 "determined by the @var{mode} string. The way in \n"
253 "which this is interpreted is similar to C stdio:\n\n"
254 "The first character must be one of the following:\n\n"
255 "@table @samp\n"
256 "@item r\n"
257 "Open an existing file for input.\n"
258 "@item w\n"
259 "Open a file for output, creating it if it doesn't already exist\n"
260 "or removing its contents if it does.\n"
261 "@item a\n"
262 "Open a file for output, creating it if it doesn't already exist.\n"
263 "All writes to the port will go to the end of the file.\n"
264 "The \"append mode\" can be turned off while the port is in use\n"
265 "@pxref{Ports and File Descriptors, fcntl}\n"
266 "@end table\n\n"
267 "The following additional characters can be appended:\n\n"
268 "@table @samp\n"
269 "@item +\n"
270 "Open the port for both input and output. E.g., @code{r+}: open\n"
271 "an existing file for both input and output.\n"
272 "@item 0\n"
273 "Create an \"unbuffered\" port. In this case input and output operations\n"
274 "are passed directly to the underlying port implementation without\n"
275 "additional buffering. This is likely to slow down I/O operations.\n"
276 "The buffering mode can be changed while a port is in use\n"
277 "@pxref{Ports and File Descriptors, setvbuf}\n"
278 "@item l\n"
279 "Add line-buffering to the port. The port output buffer will be\n"
280 "automatically flushed whenever a newline character is written.\n"
281 "@end table\n\n"
282 "In theory we could create read/write ports which were buffered in one\n"
283 "direction only. However this isn't included in the current interfaces.\n\n"
284 "If a file cannot be opened with the access requested,\n"
285 "@code{open-file} throws an exception.")
1bbd0b84 286#define FUNC_NAME s_scm_open_file
0f2d19dd 287{
19639113 288 SCM port;
cb63cf9e
JB
289 int fdes;
290 int flags = 0;
19639113
GH
291 char *file;
292 char *mode;
cb63cf9e 293 char *ptr;
19639113 294
a6d9e5ab
DH
295 SCM_VALIDATE_STRING (1, filename);
296 SCM_VALIDATE_STRING (2, modes);
297 SCM_STRING_COERCE_0TERMINATION_X (filename);
298 SCM_STRING_COERCE_0TERMINATION_X (modes);
19639113 299
a6d9e5ab
DH
300 file = SCM_STRING_CHARS (filename);
301 mode = SCM_STRING_CHARS (modes);
19639113 302
cb63cf9e 303 switch (*mode)
0f2d19dd 304 {
cb63cf9e
JB
305 case 'r':
306 flags |= O_RDONLY;
307 break;
308 case 'w':
309 flags |= O_WRONLY | O_CREAT | O_TRUNC;
310 break;
311 case 'a':
312 flags |= O_WRONLY | O_CREAT | O_APPEND;
313 break;
314 default:
1bbd0b84 315 scm_out_of_range (FUNC_NAME, modes);
0f2d19dd 316 }
cb63cf9e
JB
317 ptr = mode + 1;
318 while (*ptr != '\0')
e145dd02 319 {
cb63cf9e
JB
320 switch (*ptr)
321 {
322 case '+':
323 flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
324 break;
9f561420
GH
325 case 'b':
326#if defined (O_BINARY)
327 flags |= O_BINARY;
328#endif
329 break;
cb63cf9e 330 case '0': /* unbuffered: handled later. */
d3639214 331 case 'l': /* line buffered: handled during output. */
cb63cf9e
JB
332 break;
333 default:
1bbd0b84 334 scm_out_of_range (FUNC_NAME, modes);
cb63cf9e
JB
335 }
336 ptr++;
e145dd02 337 }
cb63cf9e
JB
338 SCM_SYSCALL (fdes = open (file, flags, 0666));
339 if (fdes == -1)
e145dd02 340 {
cb63cf9e
JB
341 int en = errno;
342
5d2d2ffc 343 SCM_SYSERROR_MSG ("~A: ~S",
cb63cf9e 344 scm_cons (scm_makfrom0str (strerror (en)),
5d2d2ffc 345 scm_cons (filename, SCM_EOL)), en);
0f2d19dd 346 }
cb63cf9e 347 port = scm_fdes_to_port (fdes, mode, filename);
0f2d19dd
JB
348 return port;
349}
1bbd0b84 350#undef FUNC_NAME
0f2d19dd 351
e145dd02 352\f
cb63cf9e 353/* Building Guile ports from a file descriptor. */
e145dd02 354
cb63cf9e 355/* Build a Scheme port from an open file descriptor `fdes'.
a089567e
JB
356 MODE indicates whether FILE is open for reading or writing; it uses
357 the same notation as open-file's second argument.
19b27fa2
GH
358 NAME is a string to be used as the port's filename.
359*/
a089567e 360SCM
cb63cf9e 361scm_fdes_to_port (int fdes, char *mode, SCM name)
19b27fa2 362#define FUNC_NAME "scm_fdes_to_port"
a089567e
JB
363{
364 long mode_bits = scm_mode_bits (mode);
365 SCM port;
840ae05d 366 scm_port *pt;
19b27fa2
GH
367 int flags;
368
369 /* test that fdes is valid. */
370 flags = fcntl (fdes, F_GETFL, 0);
371 if (flags == -1)
372 SCM_SYSERROR;
373 flags &= O_ACCMODE;
374 if (flags != O_RDWR
375 && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
376 || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
377 {
378 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
379 }
a089567e
JB
380
381 SCM_NEWCELL (port);
382 SCM_DEFER_INTS;
cb63cf9e
JB
383 pt = scm_add_to_port_table (port);
384 SCM_SETPTAB_ENTRY (port, pt);
54778cd3 385 SCM_SET_CELL_TYPE (port, (scm_tc16_fport | mode_bits));
cb63cf9e 386
a089567e 387 {
cb63cf9e 388 struct scm_fport *fp
840ae05d
JB
389 = (struct scm_fport *) malloc (sizeof (struct scm_fport));
390 if (fp == NULL)
19b27fa2 391 SCM_MEMORY_ERROR;
cb63cf9e 392 fp->fdes = fdes;
0de97b83 393 pt->rw_random = SCM_FDES_RANDOM_P (fdes);
cb63cf9e
JB
394 SCM_SETSTREAM (port, fp);
395 if (mode_bits & SCM_BUF0)
396 scm_fport_buffer_add (port, 0, 0);
397 else
398 scm_fport_buffer_add (port, -1, -1);
a089567e 399 }
b24b5e13 400 SCM_SET_FILENAME (port, name);
a089567e 401 SCM_ALLOW_INTS;
e145dd02
JB
402 return port;
403}
19b27fa2 404#undef FUNC_NAME
e145dd02 405
affc96b5 406/* Return a lower bound on the number of bytes available for input. */
cb63cf9e 407static int
affc96b5 408fport_input_waiting (SCM port)
e145dd02 409{
cb63cf9e
JB
410 int fdes = SCM_FSTREAM (port)->fdes;
411
412#ifdef HAVE_SELECT
413 struct timeval timeout;
414 SELECT_TYPE read_set;
415 SELECT_TYPE write_set;
416 SELECT_TYPE except_set;
417
418 FD_ZERO (&read_set);
419 FD_ZERO (&write_set);
420 FD_ZERO (&except_set);
421
422 FD_SET (fdes, &read_set);
423
424 timeout.tv_sec = 0;
425 timeout.tv_usec = 0;
426
427 if (select (SELECT_SET_SIZE,
428 &read_set, &write_set, &except_set, &timeout)
429 < 0)
affc96b5
GH
430 scm_syserror ("fport_input_waiting");
431 return FD_ISSET (fdes, &read_set) ? 1 : 0;
cb63cf9e
JB
432#elif defined (FIONREAD)
433 int remir;
434 ioctl(fdes, FIONREAD, &remir);
435 return remir;
436#else
affc96b5 437 scm_misc_error ("fport_input_waiting",
cb63cf9e
JB
438 "Not fully implemented on this platform",
439 SCM_EOL);
440#endif
a089567e
JB
441}
442
cb63cf9e 443\f
0f2d19dd 444static int
e841c3e0 445fport_print (SCM exp, SCM port, scm_print_state *pstate)
0f2d19dd 446{
b3ec3c64
MD
447 scm_puts ("#<", port);
448 scm_print_port_mode (exp, port);
449 if (SCM_OPFPORTP (exp))
0f2d19dd 450 {
b3ec3c64 451 int fdes;
b24b5e13
DH
452 SCM name = SCM_FILENAME (exp);
453 if (SCM_STRINGP (name) || SCM_SYMBOLP (name))
454 scm_display (name, port);
455 else
456 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
b3ec3c64
MD
457 scm_putc (' ', port);
458 fdes = (SCM_FSTREAM (exp))->fdes;
459
460 if (isatty (fdes))
461 scm_puts (ttyname (fdes), port);
462 else
463 scm_intprint (fdes, 10, port);
0f2d19dd
JB
464 }
465 else
466 {
b3ec3c64
MD
467 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
468 scm_putc (' ', port);
f1267706 469 scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
0f2d19dd 470 }
b3ec3c64
MD
471 scm_putc ('>', port);
472 return 1;
0f2d19dd
JB
473}
474
cb63cf9e
JB
475#ifdef GUILE_ISELECT
476/* thread-local block for input on fport's fdes. */
477static void
478fport_wait_for_input (SCM port)
3cb988bd 479{
cb63cf9e 480 int fdes = SCM_FSTREAM (port)->fdes;
3cb988bd 481
affc96b5 482 if (!fport_input_waiting (port))
8122b543 483 {
cb63cf9e
JB
484 int n;
485 SELECT_TYPE readfds;
486 int flags = fcntl (fdes, F_GETFL);
487
488 if (flags == -1)
489 scm_syserror ("scm_fdes_wait_for_input");
490 if (!(flags & O_NONBLOCK))
491 do
492 {
493 FD_ZERO (&readfds);
494 FD_SET (fdes, &readfds);
495 n = scm_internal_select (fdes + 1, &readfds, NULL, NULL, NULL);
496 }
497 while (n == -1 && errno == EINTR);
8122b543 498 }
3cb988bd 499}
0f2d19dd
JB
500#endif
501
affc96b5 502static void fport_flush (SCM port);
0f2d19dd 503
c2da2648
GH
504/* fill a port's read-buffer with a single read. returns the first
505 char or EOF if end of file. */
0f2d19dd 506static int
affc96b5 507fport_fill_input (SCM port)
0f2d19dd 508{
cb63cf9e 509 int count;
840ae05d 510 scm_port *pt = SCM_PTAB_ENTRY (port);
cb63cf9e
JB
511 struct scm_fport *fp = SCM_FSTREAM (port);
512
cb63cf9e
JB
513#ifdef GUILE_ISELECT
514 fport_wait_for_input (port);
515#endif
516 SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
517 if (count == -1)
affc96b5 518 scm_syserror ("fport_fill_input");
cb63cf9e
JB
519 if (count == 0)
520 return EOF;
521 else
522 {
5c070ca7 523 pt->read_pos = pt->read_buf;
cb63cf9e 524 pt->read_end = pt->read_buf + count;
5c070ca7 525 return *pt->read_buf;
cb63cf9e 526 }
0f2d19dd
JB
527}
528
cb63cf9e 529static off_t
affc96b5 530fport_seek (SCM port, off_t offset, int whence)
0f2d19dd 531{
7dcb364d 532 scm_port *pt = SCM_PTAB_ENTRY (port);
cb63cf9e 533 struct scm_fport *fp = SCM_FSTREAM (port);
7dcb364d
GH
534 off_t rv;
535 off_t result;
536
537 if (pt->rw_active == SCM_PORT_WRITE)
538 {
539 if (offset != 0 || whence != SEEK_CUR)
540 {
541 fport_flush (port);
542 result = rv = lseek (fp->fdes, offset, whence);
543 }
544 else
545 {
546 /* read current position without disturbing the buffer. */
547 rv = lseek (fp->fdes, offset, whence);
548 result = rv + (pt->write_pos - pt->write_buf);
549 }
550 }
551 else if (pt->rw_active == SCM_PORT_READ)
552 {
553 if (offset != 0 || whence != SEEK_CUR)
554 {
555 /* could expand to avoid a second seek. */
556 scm_end_input (port);
557 result = rv = lseek (fp->fdes, offset, whence);
558 }
559 else
560 {
561 /* read current position without disturbing the buffer
562 (particularly the unread-char buffer). */
563 rv = lseek (fp->fdes, offset, whence);
564 result = rv - (pt->read_end - pt->read_pos);
565
566 if (pt->read_buf == pt->putback_buf)
567 result -= pt->saved_read_end - pt->saved_read_pos;
568 }
569 }
570 else /* SCM_PORT_NEITHER */
571 {
572 result = rv = lseek (fp->fdes, offset, whence);
573 }
cb8dfa3f 574
7dcb364d 575 if (rv == -1)
affc96b5 576 scm_syserror ("fport_seek");
7dcb364d 577
cb8dfa3f 578 return result;
0f2d19dd
JB
579}
580
840ae05d 581static void
affc96b5 582fport_truncate (SCM port, off_t length)
840ae05d
JB
583{
584 struct scm_fport *fp = SCM_FSTREAM (port);
585
586 if (ftruncate (fp->fdes, length) == -1)
587 scm_syserror ("ftruncate");
588}
589
0c6d2191
GH
590/* helper for fport_write: try to write data, using multiple system
591 calls if required. */
592#define FUNC_NAME "write_all"
593static void write_all (SCM port, const void *data, size_t remaining)
594{
595 int fdes = SCM_FSTREAM (port)->fdes;
596
597 while (remaining > 0)
598 {
599 ssize_t done;
600
601 SCM_SYSCALL (done = write (fdes, data, remaining));
602
603 if (done == -1)
604 SCM_SYSERROR;
605 remaining -= done;
606 data = ((const char *) data) + done;
607 }
608}
609#undef FUNC_NAME
610
31703ab8 611static void
8aa011a1 612fport_write (SCM port, const void *data, size_t size)
31703ab8 613{
0c6d2191 614 /* this procedure tries to minimize the number of writes/flushes. */
31703ab8
GH
615 scm_port *pt = SCM_PTAB_ENTRY (port);
616
0c6d2191
GH
617 if (pt->write_buf == &pt->shortbuf
618 || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
31703ab8 619 {
0c6d2191
GH
620 /* "unbuffered" port, or
621 port with empty buffer and data won't fit in buffer. */
622 write_all (port, data, size);
623 return;
31703ab8 624 }
d3639214 625
0c6d2191
GH
626 {
627 off_t space = pt->write_end - pt->write_pos;
628
629 if (size <= space)
630 {
631 /* data fits in buffer. */
632 memcpy (pt->write_pos, data, size);
633 pt->write_pos += size;
634 if (pt->write_pos == pt->write_end)
635 {
affc96b5 636 fport_flush (port);
0c6d2191
GH
637 /* we can skip the line-buffering check if nothing's buffered. */
638 return;
639 }
640 }
641 else
642 {
643 memcpy (pt->write_pos, data, space);
644 pt->write_pos = pt->write_end;
645 fport_flush (port);
646 {
647 const void *ptr = ((const char *) data) + space;
648 size_t remaining = size - space;
649
650 if (size >= pt->write_buf_size)
651 {
652 write_all (port, ptr, remaining);
653 return;
654 }
655 else
656 {
657 memcpy (pt->write_pos, ptr, remaining);
658 pt->write_pos += remaining;
659 }
31703ab8 660 }
0c6d2191 661 }
31703ab8 662
0c6d2191
GH
663 /* handle line buffering. */
664 if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
665 fport_flush (port);
666 }
31703ab8
GH
667}
668
669/* becomes 1 when process is exiting: normal exception handling won't
670 work by this time. */
cb63cf9e 671extern int terminating;
0f2d19dd 672
cb63cf9e 673static void
affc96b5 674fport_flush (SCM port)
0f2d19dd 675{
840ae05d 676 scm_port *pt = SCM_PTAB_ENTRY (port);
cb63cf9e 677 struct scm_fport *fp = SCM_FSTREAM (port);
6f760c1d 678 unsigned char *ptr = pt->write_buf;
cb63cf9e
JB
679 int init_size = pt->write_pos - pt->write_buf;
680 int remaining = init_size;
0f2d19dd 681
cb63cf9e
JB
682 while (remaining > 0)
683 {
684 int count;
685
686 SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
687 if (count < 0)
688 {
689 /* error. assume nothing was written this call, but
690 fix up the buffer for any previous successful writes. */
691 int done = init_size - remaining;
692
693 if (done > 0)
694 {
695 int i;
696
697 for (i = 0; i < remaining; i++)
698 {
699 *(pt->write_buf + i) = *(pt->write_buf + done + i);
700 }
701 pt->write_pos = pt->write_buf + remaining;
702 }
6b72ac1d 703 if (terminating)
cb63cf9e
JB
704 {
705 const char *msg = "Error: could not flush file-descriptor ";
706 char buf[11];
707
708 write (2, msg, strlen (msg));
709 sprintf (buf, "%d\n", fp->fdes);
710 write (2, buf, strlen (buf));
711
712 count = remaining;
713 }
6b72ac1d
GH
714 else if (scm_gc_running_p)
715 {
716 /* silently ignore the error. scm_error would abort if we
717 called it now. */
718 count = remaining;
719 }
720 else
721 scm_syserror ("fport_flush");
cb63cf9e
JB
722 }
723 ptr += count;
724 remaining -= count;
725 }
726 pt->write_pos = pt->write_buf;
61e452ba 727 pt->rw_active = SCM_PORT_NEITHER;
840ae05d
JB
728}
729
283a1a0e 730/* clear the read buffer and adjust the file position for unread bytes. */
840ae05d 731static void
affc96b5 732fport_end_input (SCM port, int offset)
840ae05d
JB
733{
734 struct scm_fport *fp = SCM_FSTREAM (port);
735 scm_port *pt = SCM_PTAB_ENTRY (port);
283a1a0e
GH
736
737 offset += pt->read_end - pt->read_pos;
840ae05d 738
840ae05d
JB
739 if (offset > 0)
740 {
741 pt->read_pos = pt->read_end;
742 /* will throw error if unread-char used at beginning of file
743 then attempting to write. seems correct. */
744 if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
affc96b5 745 scm_syserror ("fport_end_input");
840ae05d 746 }
61e452ba 747 pt->rw_active = SCM_PORT_NEITHER;
8f29fbd0
JB
748}
749
6a2c4c81 750static int
affc96b5 751fport_close (SCM port)
6a2c4c81 752{
cb63cf9e 753 struct scm_fport *fp = SCM_FSTREAM (port);
840ae05d 754 scm_port *pt = SCM_PTAB_ENTRY (port);
cb63cf9e 755 int rv;
840ae05d 756
affc96b5 757 fport_flush (port);
cb63cf9e
JB
758 SCM_SYSCALL (rv = close (fp->fdes));
759 if (rv == -1 && errno != EBADF)
6b72ac1d
GH
760 {
761 if (scm_gc_running_p)
762 /* silently ignore the error. scm_error would abort if we
763 called it now. */
764 ;
765 else
766 scm_syserror ("fport_close");
767 }
6c951427
GH
768 if (pt->read_buf == pt->putback_buf)
769 pt->read_buf = pt->saved_read_buf;
cb63cf9e 770 if (pt->read_buf != &pt->shortbuf)
840ae05d 771 free (pt->read_buf);
cb63cf9e 772 if (pt->write_buf != &pt->shortbuf)
840ae05d
JB
773 free (pt->write_buf);
774 free ((char *) fp);
cb63cf9e 775 return rv;
6a2c4c81
JB
776}
777
b3ec3c64 778static scm_sizet
affc96b5 779fport_free (SCM port)
b3ec3c64 780{
affc96b5 781 fport_close (port);
b3ec3c64
MD
782 return 0;
783}
784
a98bddfd 785static scm_bits_t
b3ec3c64
MD
786scm_make_fptob ()
787{
a98bddfd
DH
788 scm_bits_t tc = scm_make_port_type ("file", fport_fill_input, fport_write);
789
affc96b5 790 scm_set_port_free (tc, fport_free);
e841c3e0 791 scm_set_port_print (tc, fport_print);
affc96b5
GH
792 scm_set_port_flush (tc, fport_flush);
793 scm_set_port_end_input (tc, fport_end_input);
794 scm_set_port_close (tc, fport_close);
795 scm_set_port_seek (tc, fport_seek);
796 scm_set_port_truncate (tc, fport_truncate);
797 scm_set_port_input_waiting (tc, fport_input_waiting);
a98bddfd
DH
798
799 return tc;
b3ec3c64 800}
0f2d19dd 801
0f2d19dd
JB
802void
803scm_init_fports ()
0f2d19dd 804{
a98bddfd
DH
805 scm_tc16_fport = scm_make_fptob ();
806
7a6f1ffa
GH
807 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
808 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
809 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
a98bddfd
DH
810
811#ifndef SCM_MAGIC_SNARFER
812#include "libguile/fports.x"
813#endif
0f2d19dd 814}
89e00824
ML
815
816/*
817 Local Variables:
818 c-file-style: "gnu"
819 End:
820*/