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