1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
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)
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.
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
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
49 #include "libguile/_scm.h"
50 #include "libguile/ports.h"
51 #include "libguile/read.h"
52 #include "libguile/fports.h"
53 #include "libguile/unif.h"
54 #include "libguile/chars.h"
55 #include "libguile/feature.h"
56 #include "libguile/root.h"
57 #include "libguile/strings.h"
59 #include "libguile/validate.h"
60 #include "libguile/ioext.h"
72 SCM_DEFINE (scm_read_string_x_partial
, "read-string!/partial", 1, 3, 0,
73 (SCM str
, SCM port_or_fdes
, SCM start
, SCM end
),
74 "Read characters from an fport or file descriptor into a\n"
75 "string @var{str}. This procedure is scsh-compatible\n"
76 "and can efficiently read large strings. It will:\n\n"
79 "attempt to fill the entire string, unless the @var{start}\n"
80 "and/or @var{end} arguments are supplied. i.e., @var{start}\n"
81 "defaults to 0 and @var{end} defaults to\n"
82 "@code{(string-length str)}\n"
84 "use the current input port if @var{port_or_fdes} is not\n"
87 "read any characters that are currently available,\n"
88 "without waiting for the rest (short reads are possible).\n\n"
90 "wait for as long as it needs to for the first character to\n"
91 "become available, unless the port is in non-blocking mode\n"
93 "return @code{#f} if end-of-file is encountered before reading\n"
94 "any characters, otherwise return the number of characters\n"
97 "return 0 if the port is in non-blocking mode and no characters\n"
98 "are immediately available.\n"
100 "return 0 if the request is for 0 bytes, with no\n"
101 "end-of-file check\n"
103 #define FUNC_NAME s_scm_read_string_x_partial
114 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, dest
, 3, start
, offset
,
117 read_len
= last
- offset
;
120 if (SCM_INUMP (port_or_fdes
))
121 fdes
= SCM_INUM (port_or_fdes
);
124 SCM port
= SCM_UNBNDP (port_or_fdes
) ? scm_cur_inp
: port_or_fdes
;
126 SCM_VALIDATE_OPFPORT (2, port
);
127 SCM_VALIDATE_INPUT_PORT (2, port
);
129 /* if there's anything in the port buffers, use it, but then
130 don't touch the file descriptor. otherwise the
131 "return immediately if something is available" rule may
133 chars_read
= scm_take_from_input_buffers (port
, dest
, read_len
);
134 fdes
= SCM_FPORT_FDES (port
);
137 if (chars_read
== 0 && read_len
> 0) /* don't confuse read_len == 0 with
140 SCM_SYSCALL (chars_read
= read (fdes
, dest
, read_len
));
141 if (chars_read
== -1)
143 #if defined (EWOULDBLOCK) || defined (EAGAIN)
145 #if defined (EWOULDBLOCK)
156 else if (chars_read
== 0)
159 return scm_long2num (chars_read
);
163 SCM_DEFINE (scm_read_delimited_x
, "%read-delimited!", 3, 3, 0,
164 (SCM delims
, SCM str
, SCM gobble
, SCM port
, SCM start
, SCM end
),
165 "Read characters from @var{port} into @var{str} until one of the\n"
166 "characters in the @var{delims} string is encountered. If @var{gobble}\n"
167 "is true, discard the delimiter character; otherwise, leave it\n"
168 "in the input stream for the next read.\n"
169 "If @var{port} is not specified, use the value of\n"
170 "@code{(current-input-port)}. If @var{start} or @var{end} are specified,\n"
171 "store data only into the substring of @var{str} bounded by @var{start}\n"
172 "and @var{end} (which default to the beginning and end of the string,\n"
174 "Return a pair consisting of the delimiter that terminated the string and\n"
175 "the number of characters read. If reading stopped at the end of file,\n"
176 "the delimiter returned is the @var{eof-object}; if the string was filled\n"
177 "without encountering a delimiter, this value is @var{#f}.")
178 #define FUNC_NAME s_scm_read_delimited_x
188 SCM_VALIDATE_STRING_COPY (1, delims
, cdelims
);
189 num_delims
= SCM_STRING_LENGTH (delims
);
190 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str
, buf
, 5, start
, cstart
,
192 if (SCM_UNBNDP (port
))
195 SCM_VALIDATE_OPINPORT (4,port
);
197 for (j
= cstart
; j
< cend
; j
++)
202 for (k
= 0; k
< num_delims
; k
++)
206 if (SCM_FALSEP (gobble
))
207 scm_ungetc (c
, port
);
209 return scm_cons (SCM_MAKE_CHAR (c
),
210 scm_long2num (j
- cstart
));
214 return scm_cons (SCM_EOF_VAL
,
215 scm_long2num (j
- cstart
));
219 return scm_cons (SCM_BOOL_F
, scm_long2num (j
- cstart
));
223 static unsigned char *
224 scm_do_read_line (SCM port
, int *len_p
)
226 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
229 /* I thought reading lines was simple. Mercy me. */
231 /* The common case: the buffer contains a complete line.
232 This needs to be fast. */
233 if ((end
= memchr (pt
->read_pos
, '\n', (pt
->read_end
- pt
->read_pos
)))
236 int buf_len
= (end
+ 1) - pt
->read_pos
;
237 /* Allocate a buffer of the perfect size. */
238 unsigned char *buf
= scm_must_malloc (buf_len
+ 1, "%read-line");
240 memcpy (buf
, pt
->read_pos
, buf_len
);
241 pt
->read_pos
+= buf_len
;
249 /* The buffer contains no newlines. */
251 /* When live, len is always the number of characters in the
252 current buffer that are part of the current line. */
253 int len
= (pt
->read_end
- pt
->read_pos
);
254 int buf_size
= (len
< 50) ? 60 : len
* 2;
255 /* Invariant: buf always has buf_size + 1 characters allocated;
256 the `+ 1' is for the final '\0'. */
257 unsigned char *buf
= scm_must_malloc (buf_size
+ 1, "%read-line");
262 if (buf_len
+ len
> buf_size
)
264 int new_size
= (buf_len
+ len
) * 2;
265 buf
= scm_must_realloc (buf
, buf_size
+ 1, new_size
+ 1,
270 /* Copy what we've got out of the port, into our buffer. */
271 memcpy (buf
+ buf_len
, pt
->read_pos
, len
);
275 /* If we had seen a newline, we're done now. */
279 /* Get more characters. */
280 if (scm_fill_input (port
) == EOF
)
282 /* If we're missing a final newline in the file, return
283 what we did get, sans newline. */
291 /* Search the buffer for newlines. */
292 if ((end
= memchr (pt
->read_pos
, '\n',
293 (len
= (pt
->read_end
- pt
->read_pos
))))
295 len
= (end
- pt
->read_pos
) + 1;
298 /* I wonder how expensive this realloc is. */
299 buf
= scm_must_realloc (buf
, buf_size
+ 1, buf_len
+ 1, "%read-line");
309 * truncates any terminating newline from its input, and returns
310 * a cons of the string read and its terminating character. Doing
311 * so makes it easy to implement the hairy `read-line' options
312 * efficiently in Scheme.
315 SCM_DEFINE (scm_read_line
, "%read-line", 0, 1, 0,
317 "Read a newline-terminated line from @var{port}, allocating storage as\n"
318 "necessary. The newline terminator (if any) is removed from the string,\n"
319 "and a pair consisting of the line and its delimiter is returned. The\n"
320 "delimiter may be either a newline or the @var{eof-object}; if\n"
321 "@code{%read-line} is called at the end of file, it returns the pair\n"
322 "@code{(#<eof> . #<eof>)}.")
323 #define FUNC_NAME s_scm_read_line
330 if (SCM_UNBNDP (port
))
332 SCM_VALIDATE_OPINPORT (1,port
);
334 pt
= SCM_PTAB_ENTRY (port
);
335 if (pt
->rw_active
== SCM_PORT_WRITE
)
336 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
338 s
= (char *) scm_do_read_line (port
, &slen
);
341 term
= line
= SCM_EOF_VAL
;
344 if (s
[slen
-1] == '\n')
346 term
= SCM_MAKE_CHAR ('\n');
348 line
= scm_take_str (s
, slen
-1);
349 scm_done_malloc (-1);
354 /* Fix: we should check for eof on the port before assuming this. */
356 line
= scm_take_str (s
, slen
);
357 SCM_COL (port
) += slen
;
362 pt
->rw_active
= SCM_PORT_READ
;
364 return scm_cons (line
, term
);
368 SCM_DEFINE (scm_write_line
, "write-line", 1, 1, 0,
370 "Display @var{obj} and a newline character to @var{port}. If @var{port}\n"
371 "is not specified, @code{(current-output-port)} is used. This function\n"
372 "is equivalent to:\n\n"
374 "(display obj [port])\n"
377 #define FUNC_NAME s_scm_write_line
379 scm_display (obj
, port
);
380 return scm_newline (port
);
384 SCM_DEFINE (scm_ftell
, "ftell", 1, 0, 0,
386 "Returns an integer representing the current position of @var{fd/port},\n"
387 "measured from the beginning. Equivalent to:\n"
389 "(seek port 0 SEEK_CUR)\n"
391 #define FUNC_NAME s_scm_ftell
393 return scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
398 #if (SCM_DEBUG_DEPRECATED == 0)
400 SCM_DEFINE (scm_fseek
, "fseek", 3, 0, 0,
401 (SCM object
, SCM offset
, SCM whence
),
402 "Obsolete. Almost the same as seek, above, but the return value is\n"
404 #define FUNC_NAME s_scm_fseek
406 scm_seek (object
, offset
, whence
);
407 return SCM_UNSPECIFIED
;
411 #endif /* SCM_DEBUG_DEPRECATED == 0 */
414 SCM_DEFINE (scm_redirect_port
, "redirect-port", 2, 0, 0,
416 "This procedure takes two ports and duplicates the underlying file\n"
417 "descriptor from @var{old-port} into @var{new-port}. The\n"
418 "current file descriptor in @var{new-port} will be closed.\n"
419 "After the redirection the two ports will share a file position\n"
420 "and file status flags.\n\n"
421 "The return value is unspecified.\n\n"
422 "Unexpected behaviour can result if both ports are subsequently used\n"
423 "and the original and/or duplicate ports are buffered.\n\n"
424 "This procedure does not have any side effects on other ports or\n"
426 #define FUNC_NAME s_scm_redirect_port
428 int ans
, oldfd
, newfd
;
429 struct scm_fport
*fp
;
431 old
= SCM_COERCE_OUTPORT (old
);
432 new = SCM_COERCE_OUTPORT (new);
434 SCM_VALIDATE_OPFPORT (1,old
);
435 SCM_VALIDATE_OPFPORT (2,new);
436 oldfd
= SCM_FPORT_FDES (old
);
437 fp
= SCM_FSTREAM (new);
441 scm_port
*pt
= SCM_PTAB_ENTRY (new);
442 scm_port
*old_pt
= SCM_PTAB_ENTRY (old
);
443 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (new)];
445 /* must flush to old fdes. */
446 if (pt
->rw_active
== SCM_PORT_WRITE
)
448 else if (pt
->rw_active
== SCM_PORT_READ
)
450 ans
= dup2 (oldfd
, newfd
);
453 pt
->rw_random
= old_pt
->rw_random
;
454 /* continue using existing buffers, even if inappropriate. */
456 return SCM_UNSPECIFIED
;
460 SCM_DEFINE (scm_dup_to_fdes
, "dup->fdes", 1, 1, 0,
461 (SCM fd_or_port
, SCM fd
),
462 "Returns an integer file descriptor.")
463 #define FUNC_NAME s_scm_dup_to_fdes
465 int oldfd
, newfd
, rv
;
467 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
469 if (SCM_INUMP (fd_or_port
))
470 oldfd
= SCM_INUM (fd_or_port
);
473 SCM_VALIDATE_OPFPORT (1,fd_or_port
);
474 oldfd
= SCM_FPORT_FDES (fd_or_port
);
482 fd
= SCM_MAKINUM (newfd
);
486 SCM_VALIDATE_INUM_COPY (2, fd
, newfd
);
489 scm_evict_ports (newfd
); /* see scsh manual. */
490 rv
= dup2 (oldfd
, newfd
);
500 SCM_DEFINE (scm_dup2
, "dup2", 2, 0, 0,
501 (SCM oldfd
, SCM newfd
),
502 "A simple wrapper for the @code{dup2} system call.\n"
503 "Copies the file descriptor @var{oldfd} to descriptor\n"
504 "number @var{newfd}, replacing the previous meaning\n"
505 "of @var{newfd}. Both @var{oldfd} and @var{newfd} must\n"
507 "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
508 "is made to move away ports which are using @var{newfd}.\n"
509 "The return value is unspecified.")
510 #define FUNC_NAME s_scm_dup2
516 SCM_VALIDATE_INUM_COPY (1, oldfd
, c_oldfd
);
517 SCM_VALIDATE_INUM_COPY (2, newfd
, c_newfd
);
518 rv
= dup2 (c_oldfd
, c_newfd
);
521 return SCM_UNSPECIFIED
;
525 SCM_DEFINE (scm_fileno
, "fileno", 1, 0, 0,
527 "Returns the integer file descriptor underlying @var{port}.\n"
528 "Does not change its revealed count.")
529 #define FUNC_NAME s_scm_fileno
531 port
= SCM_COERCE_OUTPORT (port
);
532 SCM_VALIDATE_OPFPORT (1,port
);
533 return SCM_MAKINUM (SCM_FPORT_FDES (port
));
537 /* GJB:FIXME:: why does this not throw
538 an error if the arg is not a port?
539 This proc as is would be better names isattyport?
540 if it is not going to assume that the arg is a port */
541 SCM_DEFINE (scm_isatty_p
, "isatty?", 1, 0, 0,
543 "Returns @code{#t} if @var{port} is using a serial\n"
544 "non-file device, otherwise @code{#f}.")
545 #define FUNC_NAME s_scm_isatty_p
549 port
= SCM_COERCE_OUTPORT (port
);
551 if (!SCM_OPFPORTP (port
))
554 rv
= isatty (SCM_FPORT_FDES (port
));
561 SCM_DEFINE (scm_fdopen
, "fdopen", 2, 0, 0,
562 (SCM fdes
, SCM modes
),
563 "Returns a new port based on the file descriptor @var{fdes}.\n"
564 "Modes are given by the string @var{modes}. The revealed count of the port\n"
565 "is initialized to zero. The modes string is the same as that accepted\n"
566 "by @ref{File Ports, open-file}.")
567 #define FUNC_NAME s_scm_fdopen
569 SCM_VALIDATE_INUM (1,fdes
);
570 SCM_VALIDATE_STRING (2, modes
);
571 SCM_STRING_COERCE_0TERMINATION_X (modes
);
573 return scm_fdes_to_port (SCM_INUM (fdes
), SCM_STRING_CHARS (modes
), SCM_BOOL_F
);
579 /* Move a port's underlying file descriptor to a given value.
580 * Returns #f if fdes is already the given value.
582 * MOVE->FDES is implemented in Scheme and calls this primitive.
584 SCM_DEFINE (scm_primitive_move_to_fdes
, "primitive-move->fdes", 2, 0, 0,
586 "Moves the underlying file descriptor for @var{port} to the integer\n"
587 "value @var{fdes} without changing the revealed count of @var{port}.\n"
588 "Any other ports already using this descriptor will be automatically\n"
589 "shifted to new descriptors and their revealed counts reset to zero.\n"
590 "The return value is @code{#f} if the file descriptor already had the\n"
591 "required value or @code{#t} if it was moved.")
592 #define FUNC_NAME s_scm_primitive_move_to_fdes
594 struct scm_fport
*stream
;
599 port
= SCM_COERCE_OUTPORT (port
);
601 SCM_VALIDATE_OPFPORT (1,port
);
602 SCM_VALIDATE_INUM (2,fd
);
603 stream
= SCM_FSTREAM (port
);
604 old_fd
= stream
->fdes
;
605 new_fd
= SCM_INUM (fd
);
606 if (old_fd
== new_fd
)
610 scm_evict_ports (new_fd
);
611 rv
= dup2 (old_fd
, new_fd
);
614 stream
->fdes
= new_fd
;
615 SCM_SYSCALL (close (old_fd
));
620 /* Return a list of ports using a given file descriptor. */
621 SCM_DEFINE (scm_fdes_to_ports
, "fdes->ports", 1, 0, 0,
623 "Returns a list of existing ports which have @var{fdes} as an\n"
624 "underlying file descriptor, without changing their revealed counts.")
625 #define FUNC_NAME s_scm_fdes_to_ports
627 SCM result
= SCM_EOL
;
631 SCM_VALIDATE_INUM_COPY (1,fd
,int_fd
);
633 for (i
= 0; i
< scm_port_table_size
; i
++)
635 if (SCM_OPFPORTP (scm_port_table
[i
]->port
)
636 && ((struct scm_fport
*) scm_port_table
[i
]->stream
)->fdes
== int_fd
)
637 result
= scm_cons (scm_port_table
[i
]->port
, result
);
647 scm_add_feature ("i/o-extensions");
649 #ifndef SCM_MAGIC_SNARFER
650 #include "libguile/ioext.x"