1 /* Copyright (C) 1995,1996,1997 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. */
58 /* {Ports - file ports}
62 /* should be called with SCM_DEFER_INTS active */
68 /* NOSETBUF was provided by scm to allow unbuffered ports to be
69 avoided on systems where ungetc didn't work correctly. See
70 comment in unif.c, which seems to be the only place where it
71 could still be a problem. */
73 /* SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); */
74 SCM_SYSCALL (setvbuf ((FILE *)SCM_STREAM (port
), 0, _IONBF
, 0););
76 return SCM_UNSPECIFIED
;
79 SCM_PROC (s_setvbuf
, "setvbuf", 2, 1, 0, scm_setvbuf
);
81 scm_setvbuf (SCM port
, SCM mode
, SCM size
)
86 port
= SCM_COERCE_OUTPORT (port
);
88 SCM_ASSERT (SCM_NIMP (port
) && SCM_FPORTP (port
), port
, SCM_ARG1
, s_setvbuf
);
89 SCM_ASSERT (SCM_INUMP (mode
), mode
, SCM_ARG2
, s_setvbuf
);
90 if (SCM_UNBNDP (size
))
94 SCM_ASSERT (SCM_INUMP (size
), size
, SCM_ARG3
, s_setvbuf
);
95 csize
= SCM_INUM (size
);
97 cmode
= SCM_INUM (mode
);
98 if (csize
== 0 && cmode
== _IOFBF
)
101 SCM_SYSCALL (rv
= setvbuf ((FILE *)SCM_STREAM (port
), 0, cmode
, csize
));
103 scm_syserror (s_setvbuf
);
105 SCM_SETCAR (port
, SCM_CAR (port
) | SCM_BUF0
);
107 SCM_SETCAR (port
, (SCM_CAR (port
) & ~SCM_BUF0
));
109 return SCM_UNSPECIFIED
;
113 #define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
117 scm_setfileno (fs
, fd
)
121 #ifdef SET_FILE_FD_FIELD
122 SET_FILE_FD_FIELD(fs
, fd
);
124 scm_misc_error ("scm_setfileno", "Not fully implemented on this platform",
129 /* Move ports with the specified file descriptor to new descriptors,
130 * reseting the revealed count to 0.
131 * Should be called with SCM_DEFER_INTS active.
140 for (i
= 0; i
< scm_port_table_size
; i
++)
142 if (SCM_FPORTP (scm_port_table
[i
]->port
)
143 && fileno ((FILE *)SCM_STREAM (scm_port_table
[i
]->port
)) == fd
)
145 scm_setfileno ((FILE *)SCM_STREAM (scm_port_table
[i
]->port
), dup (fd
));
146 scm_set_port_revealed_x (scm_port_table
[i
]->port
, SCM_MAKINUM (0));
152 * Return a new port open on a given file.
154 * The mode string must match the pattern: [rwa+]** which
155 * is interpreted in the usual unix way.
157 * Return the new port.
159 SCM_PROC(s_open_file
, "open-file", 2, 0, 0, scm_open_file
);
162 scm_open_file (filename
, modes
)
171 SCM_ASSERT (SCM_NIMP (filename
) && SCM_ROSTRINGP (filename
), filename
, SCM_ARG1
, s_open_file
);
172 SCM_ASSERT (SCM_NIMP (modes
) && SCM_ROSTRINGP (modes
), modes
, SCM_ARG2
, s_open_file
);
173 if (SCM_SUBSTRP (filename
))
174 filename
= scm_makfromstr (SCM_ROCHARS (filename
), SCM_ROLENGTH (filename
), 0);
175 if (SCM_SUBSTRP (modes
))
176 modes
= scm_makfromstr (SCM_ROCHARS (modes
), SCM_ROLENGTH (modes
), 0);
178 file
= SCM_ROCHARS (filename
);
179 mode
= SCM_ROCHARS (modes
);
183 SCM_SYSCALL (f
= fopen (file
, mode
));
188 scm_syserror_msg (s_open_file
, "%s: %S",
189 scm_listify (scm_makfrom0str (strerror (errno
)),
196 struct scm_port_table
* pt
;
198 pt
= scm_add_to_port_table (port
);
199 SCM_SETPTAB_ENTRY (port
, pt
);
200 SCM_SETCAR (port
, scm_tc16_fport
| scm_mode_bits (mode
));
201 SCM_SETSTREAM (port
, (SCM
) f
);
202 if (SCM_BUF0
& SCM_CAR (port
))
204 SCM_PTAB_ENTRY (port
)->file_name
= filename
;
211 /* Build a Scheme port from an open stdio port, FILE.
212 MODE indicates whether FILE is open for reading or writing; it uses
213 the same notation as open-file's second argument.
214 If NAME is non-zero, use it as the port's filename.
216 scm_stdio_to_port sets the revealed count for FILE's file
217 descriptor to 1, so that FILE won't be closed when the port object
220 scm_stdio_to_port (file
, mode
, name
)
225 long mode_bits
= scm_mode_bits (mode
);
227 struct scm_port_table
* pt
;
232 pt
= scm_add_to_port_table (port
);
233 SCM_SETPTAB_ENTRY (port
, pt
);
234 SCM_SETCAR (port
, (scm_tc16_fport
| mode_bits
));
235 SCM_SETSTREAM (port
, (SCM
) file
);
236 if (SCM_BUF0
& SCM_CAR (port
))
238 SCM_PTAB_ENTRY (port
)->file_name
= scm_makfrom0str (name
);
241 scm_set_port_revealed_x (port
, SCM_MAKINUM (1));
247 static int prinfport
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
250 prinfport (exp
, port
, pstate
)
253 scm_print_state
*pstate
;
257 if (SCM_CLOSEDP (exp
))
263 name
= SCM_PTAB_ENTRY (exp
)->file_name
;
264 if (SCM_NIMP (name
) && SCM_ROSTRINGP (name
))
265 c
= SCM_ROCHARS (name
);
270 scm_prinport (exp
, port
, c
);
276 static int scm_fgetc
SCM_P ((FILE * s
));
289 * The fgets method must take a port as its argument, rather than
290 * the underlying file handle. The reason is that we also provide
291 * a generic fgets method for ports which can't use fgets(3) (e.g.
292 * string ports). This generic method calls the port's own
293 * fgetc method. In order for it to know how to get that method,
294 * we must pass the original Scheme port object.
297 static char * scm_fgets
SCM_P ((SCM port
, int *len
));
300 scm_fgets (port
, len
)
307 char *p
; /* pointer to current buffer position */
308 int limit
= 80; /* current size of buffer */
310 f
= (FILE *) SCM_STREAM (port
);
314 buf
= (char *) malloc (limit
* sizeof(char));
317 /* If a char has been pushed onto the port with scm_ungetc,
319 if (SCM_CRDYP (port
))
321 buf
[*len
] = SCM_CGETUN (port
);
323 if (buf
[(*len
)++] == '\n')
332 int chunk_size
= limit
- *len
;
333 long int numread
, pos
;
337 /* We must use ftell to figure out how many characters were read.
338 If there are null characters near the end of file, and no
339 terminating newline, there is no other way to tell the difference
340 between an embedded null and the string-terminating null. */
343 if (fgets (p
, chunk_size
, f
) == NULL
) {
349 numread
= ftell (f
) - pos
;
352 if (numread
< chunk_size
- 1 || buf
[limit
-2] == '\n')
355 buf
= (char *) realloc (buf
, sizeof(char) * limit
* 2);
362 static scm_sizet pwrite
SCM_P ((char *ptr
, scm_sizet size
, nitems
, FILE *port
));
365 pwrite (ptr
, size
, nitems
, port
)
367 scm_sizet size
, nitems
;
370 scm_sizet len
= size
* nitems
;
377 #define ffwrite pwrite
379 #define ffwrite fwrite
383 /* This otherwise pointless code helps some poor
384 * crippled C compilers cope with life.
387 static int local_fclose
SCM_P ((FILE *fp
));
396 static int local_fflush
SCM_P ((FILE *fp
));
405 static int local_fputc
SCM_P ((int c
, FILE *fp
));
412 return fputc (c
, fp
);
415 static int local_fputs
SCM_P ((char *s
, FILE *fp
));
422 return fputs (s
, fp
);
425 static scm_sizet local_ffwrite
SCM_P ((void *ptr
, int size
, int nitems
, FILE *fp
));
428 local_ffwrite (ptr
, size
, nitems
, fp
)
434 return ffwrite (ptr
, size
, nitems
, fp
);
438 print_pipe_port (SCM exp
, SCM port
, scm_print_state
*pstate
)
440 scm_prinport (exp
, port
, "pipe");
446 /* On SunOS, there's no declaration for pclose in the headers, so
447 putting it directly in the initializer for scm_pipob doesn't really
448 fly. We could add an extern declaration for it, but then it'll
449 mismatch on some systems that do have a declaration. So we just
450 wrap it up this way. */
459 scm_ptobfuns scm_fptob
=
462 (int (*) SCM_P ((SCM
))) local_fclose
,
465 (int (*) SCM_P ((int, SCM
))) local_fputc
,
466 (int (*) SCM_P ((char *, SCM
))) local_fputs
,
467 (scm_sizet (*) SCM_P ((char *, scm_sizet
, scm_sizet
, SCM
))) local_ffwrite
,
468 (int (*) SCM_P ((SCM
))) local_fflush
,
469 (int (*) SCM_P ((SCM
))) scm_fgetc
,
470 (char * (*) SCM_P ((SCM
, int *))) scm_fgets
,
471 (int (*) SCM_P ((SCM
))) local_fclose
475 scm_ptobfuns scm_pipob
=
478 (int (*) SCM_P ((SCM
))) local_pclose
,
481 (int (*) SCM_P ((int, SCM
))) local_fputc
,
482 (int (*) SCM_P ((char *, SCM
))) local_fputs
,
483 (scm_sizet (*) SCM_P ((char *, scm_sizet
, scm_sizet
, SCM
))) local_ffwrite
,
484 (int (*) SCM_P ((SCM
))) local_fflush
,
485 (int (*) SCM_P ((SCM
))) scm_fgetc
,
486 (char * (*) SCM_P ((SCM
, int *))) scm_generic_fgets
,
487 (int (*) SCM_P ((SCM
))) local_pclose
494 scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF
));
495 scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF
));
496 scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF
));