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