1 /*-
2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)io.c 2.2 1/29/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 #if !defined(WEXITSTATUS)
37 #define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
38 #endif
39 #if !defined(WIFEXITED)
40 #define WIFEXITED(stat_val) (((stat_val) & 0xff) == 0)
41 #endif
42
43 /* === IO === */
44
45 static FTH io_tag;
46
47 /* --- General IO Macros --- */
48
49 #define IO_NOT_CLOSED_P(Obj) (FTH_IO_P(Obj) && !FTH_IO_CLOSED_P(Obj))
50 #define IO_INPUT_P(Obj) (IO_NOT_CLOSED_P(Obj) && FTH_IO_INPUT_P(Obj))
51 #define IO_OUTPUT_P(Obj) (IO_NOT_CLOSED_P(Obj) && FTH_IO_OUTPUT_P(Obj))
52
53 #define IO_FILE_ERROR(Func) FTH_ANY_ERROR_THROW(FTH_FILE_IO_ERROR, Func)
54 #define IO_FILE_ERROR_ARG(Func, Desc) \
55 FTH_ANY_ERROR_ARG_THROW(FTH_FILE_IO_ERROR, Func, Desc)
56
57 #define IO_SOCKET_ERROR(Func) FTH_ANY_ERROR_THROW(FTH_SOCKET_ERROR, Func)
58 #define IO_SOCKET_ERROR_ARG(Func, Desc) \
59 FTH_ANY_ERROR_ARG_THROW(FTH_SOCKET_ERROR, Func, Desc)
60
61 /* --- STRING IO --- */
62
63 #define FTH_IO_STRING_LENGTH(Obj) fth_string_length((FTH)(Obj))
64 #define FTH_IO_STRING_INDEX_REF(Obj) FTH_INSTANCE_REF(Obj)->cycle
65 #define FTH_IO_STRING_INDEX_SET(Obj, Idx) FTH_INSTANCE_REF(Obj)->cycle = (Idx)
66
67 #define IO_STRING_REF(line) \
68 ((fth_string_length(line) > 0) ? fth_string_ref(line) : "")
69
70 #define IO_ASSERT_ARGS(Cond, Arg, Str) \
71 FTH_ASSERT_ARGS(Cond, Arg, FTH_ARG1, Str)
72 #define IO_ASSERT_IO(Io) \
73 IO_ASSERT_ARGS(FTH_IO_P(Io), Io, "an io")
74 #define IO_ASSERT_IO_INPUT(Io) \
75 IO_ASSERT_ARGS(IO_INPUT_P(Io), Io, "an open input io")
76 #define IO_ASSERT_IO_OUTPUT(Io) \
77 IO_ASSERT_ARGS(IO_OUTPUT_P(Io), Io, "an open output io")
78 #define IO_ASSERT_IO_NOT_CLOSED(Io) \
79 IO_ASSERT_ARGS(IO_NOT_CLOSED_P(Io), Io, "an open io")
80
81 #define IO_ASSERT_STRING(Str, Arg) \
82 FTH_ASSERT_ARGS(fth_string_length(Str) > 0, (Str), (Arg), "a string")
83
84 /* --- SOCKET IO --- */
85
86 typedef struct {
87 int fd; /* file descriptor */
88 FTH host; /* host name */
89 } FIO_Socket;
90
91 #define SOCKET_REF(Obj) ((FIO_Socket *)(Obj))
92 #define FTH_IO_SOCKET_FD(Obj) SOCKET_REF(Obj)->fd
93 #define FTH_IO_SOCKET_HOST(Obj) SOCKET_REF(Obj)->host
94
95 static char *fam_to_mode(int);
96 static void ficl_accept(ficlVm *);
97 static void ficl_bind(ficlVm *);
98 static void ficl_connect(ficlVm *);
99 static void ficl_exit_status(ficlVm *);
100 static void ficl_io_close(ficlVm *);
101 static void ficl_io_closed_p(ficlVm *);
102 static void ficl_io_eof_p(ficlVm *);
103 static void ficl_io_equal_p(ficlVm *);
104 static void ficl_io_fdopen(ficlVm *);
105 static void ficl_io_filename(ficlVm *);
106 static void ficl_io_fileno(ficlVm *);
107 static void ficl_io_flush(ficlVm *);
108 static void ficl_io_getc(ficlVm *);
109 static void ficl_io_input_p(ficlVm *);
110 static void ficl_io_mode(ficlVm *);
111 static void ficl_io_nopen(ficlVm *);
112 static void ficl_io_open(ficlVm *);
113 static void ficl_io_open_file(ficlVm *);
114 static void ficl_io_open_input_file(ficlVm *);
115 static void ficl_io_open_output_file(ficlVm *);
116 static void ficl_io_open_read(ficlVm *);
117 static void ficl_io_open_write(ficlVm *);
118 static void ficl_io_output_p(ficlVm *);
119 static void ficl_io_p(ficlVm *);
120 static void ficl_io_popen(ficlVm *);
121 static void ficl_io_popen_read(ficlVm *);
122 static void ficl_io_popen_write(ficlVm *);
123 static void ficl_io_pos_ref(ficlVm *);
124 static void ficl_io_pos_set(ficlVm *);
125 static void ficl_io_putc(ficlVm *);
126 static void ficl_io_reopen(ficlVm *);
127 static void ficl_io_rewind(ficlVm *);
128 static void ficl_io_seek(ficlVm *);
129 static void ficl_io_sopen(ficlVm *);
130 static void ficl_io_sopen_read(ficlVm *);
131 static void ficl_io_sopen_write(ficlVm *);
132 static void ficl_io_stderr(ficlVm *);
133 static void ficl_io_stdin(ficlVm *);
134 static void ficl_io_stdout(ficlVm *);
135 static void ficl_io_write(ficlVm *);
136 static void ficl_io_write_format(ficlVm *);
137 static void ficl_listen(ficlVm *);
138 static void ficl_print_io(ficlVm *);
139 static void ficl_readlines(ficlVm *);
140 static void ficl_recv(ficlVm *);
141 static void ficl_recvfrom(ficlVm *);
142 static void ficl_send(ficlVm *);
143 static void ficl_sendto(ficlVm *);
144 static void ficl_set_io_stderr(ficlVm *);
145 static void ficl_set_io_stdin(ficlVm *);
146 static void ficl_set_io_stdout(ficlVm *);
147 static void ficl_set_version_control(ficlVm *);
148 static void ficl_shutdown(ficlVm *);
149 static void ficl_socket(ficlVm *);
150 static void ficl_version_control(ficlVm *);
151 static void ficl_writelines(ficlVm *);
152 static void file_close(void *);
153 static int file_eof_p(void *);
154 static void file_flush(void *);
155 static int file_number(char *);
156 static int file_read_char(void *);
157 static char *file_read_line(void *);
158 static void file_rewind(void *);
159 static ficl2Integer file_seek(void *, ficl2Integer, int);
160 static ficl2Integer file_tell(void *);
161 static void file_version_rename(char *);
162 static void file_write_char(void *, int);
163 static void file_write_line(void *, const char *);
164 static void generic_close(void *);
165 static int generic_eof_p(void *);
166 static void generic_flush(void *);
167 static int generic_read_char(void *);
168 static char *generic_read_line(void *);
169 static void generic_rewind(void *);
170 static ficl2Integer generic_seek(void *, ficl2Integer, int);
171 static ficl2Integer generic_tell(void *);
172 static void generic_write_char(void *, int);
173 static void generic_write_line(void *, const char *);
174 static FTH io_equal_p(FTH, FTH);
175 static void io_free(FTH);
176 static void io_if_exists(char *, FTH, int);
177 static FTH io_inspect(FTH);
178 static FTH io_length(FTH);
179 static void io_mark(FTH);
180 static FTH io_ref(FTH, FTH);
181 static FTH io_to_array(FTH);
182 static FTH io_to_string(FTH);
183 static FTH make_file_io(FILE *, const char *, int);
184 static FTH make_socket_io(const char *, int, int, int);
185 static void pipe_close(void *);
186 static int seek_constant_p(int);
187 static int socket_accept(int, int);
188 static int socket_bind(const char *, int, int, int);
189 static void socket_close(void *);
190 static int socket_connect(const char *, int, int, int);
191 static int socket_eof_p(void *);
192 static int socket_open(int, int);
193 static int socket_read_char(void *);
194 static char *socket_read_line(void *);
195 static void socket_rewind(void *);
196 static ficl2Integer socket_seek(void *, ficl2Integer, int);
197 static ficl2Integer socket_tell(void *);
198 static void socket_unlink(const char *);
199 static void socket_write_char(void *, int);
200 static void socket_write_line(void *, const char *);
201 static int string_eof_p(void *);
202 static int string_read_char(void *);
203 static char *string_read_line(void *);
204 static void string_rewind_and_close(void *);
205 static ficl2Integer string_seek(void *, ficl2Integer, int);
206 static ficl2Integer string_tell(void *);
207 static void string_write_char(void *, int);
208 static void string_write_line(void *, const char *);
209
210 #define h_list_of_io_functions "\
211 *** IO and FILE PRIMITIVES ***\n\
212 *stderr* ( -- io )\n\
213 *stdin* ( -- io )\n\
214 *stdout* ( -- io )\n\
215 .io ( io -- )\n\
216 exit-status alias for io-exit-status\n\
217 io->string ( io -- str )\n\
218 io-close ( io -- )\n\
219 io-closed? ( io -- f )\n\
220 io-eof? ( io -- f )\n\
221 io-exit-status ( -- n )\n\
222 io-fdopen ( fd :key args -- io )\n\
223 io-filename ( io -- fname )\n\
224 io-fileno ( io -- fd )\n\
225 io-flush ( io -- )\n\
226 io-getc ( io -- c )\n\
227 io-input? ( obj -- f )\n\
228 io-mode ( io -- mode )\n\
229 io-open ( name :key args -- io )\n\
230 io-open-file ( :key args -- io )\n\
231 io-open-input-file ( :key args -- io )\n\
232 io-open-output-file ( :key args -- io )\n\
233 io-open-read ( name -- io )\n\
234 io-open-write ( name :key args -- io )\n\
235 io-output? ( obj -- f )\n\
236 io-popen ( cmd :key args -- io )\n\
237 io-popen-read ( cmd -- io )\n\
238 io-popen-write ( cmd -- io )\n\
239 io-pos-ref ( io -- pos )\n\
240 io-pos-set! ( io pos -- )\n\
241 io-putc ( io c -- )\n\
242 io-read ( io -- line )\n\
243 io-readlines ( io -- array-of-lines )\n\
244 io-reopen ( io1 name :key args -- io2 )\n\
245 io-rewind ( io -- )\n\
246 io-seek ( io offset :key whence -- pos )\n\
247 io-sopen ( str :key args -- io )\n\
248 io-sopen-read ( str -- io )\n\
249 io-sopen-write ( str -- io )\n\
250 io-tell alias for io-pos-ref\n\
251 io-write ( io line -- )\n\
252 io-write-format ( io fmt args -- )\n\
253 io-writelines ( io array-of-lines -- )\n\
254 io= ( obj1 obj2 -- f )\n\
255 io? ( obj -- f )\n\
256 make-file-input-port alias for io-open-read\n\
257 make-file-output-port alias for io-open-write\n\
258 make-file-port alias for io-open\n\
259 make-pipe-input-port alias for io-popen-read\n\
260 make-pipe-output-port alias for io-popen-write\n\
261 make-pipe-port alias for io-popen\n\
262 make-string-input-port alias for io-sopen-read\n\
263 make-string-output-port alias for io-sopen-write\n\
264 make-string-port alias for io-sopen\n\
265 readlines ( name -- array-of-lines )\n\
266 set-*stderr* ( io1 -- io2 )\n\
267 set-*stdin* ( io1 -- io2 )\n\
268 set-*stdout* ( io1 -- io2 )\n\
269 set-version-control ( val -- )\n\
270 version-control ( -- val )\n\
271 writelines ( name array-of-lines -- )\n\
272 *** constants:\n\
273 SEEK_SET, SEEK_CUR, SEEK_END\n\
274 AF_*, SOCK_*, SHUT_*"
275
276 #if HAVE_SOCKET
277 #define h_list_of_io_socket_functions "\
278 *** IO SOCKET PRIMITIVES ***\n\
279 io-nopen ( host :key args -- io )\n\
280 make-socket-port alias for io-nopen\n\
281 net-accept ( fd host domain -- io )\n\
282 net-bind ( fd host port domain -- )\n\
283 net-connect ( fd host port domain -- io )\n\
284 net-listen ( fd -- )\n\
285 net-recv ( fd flags -- msg )\n\
286 net-recvfrom ( fd flags host port domain -- msg )\n\
287 net-send ( fd msg flags -- )\n\
288 net-sendto ( fd msg flags host port domain -- )\n\
289 net-shutdown ( fd how -- )\n\
290 net-socket ( domain type -- fd )"
291 #endif /* HAVE_SOCKET */
292
293 static FTH
io_inspect(FTH self)294 io_inspect(FTH self)
295 {
296 FTH fs;
297
298 fs = fth_make_string(FTH_INSTANCE_NAME(self));
299
300 if (fth_io_pos_ref(self) >= 0)
301 fth_string_sformat(fs, "[%lld]", fth_io_pos_ref(self));
302
303 if (FTH_STRING_P(FTH_IO_FILENAME(self)))
304 fth_string_sformat(fs, ": \"%S\",", FTH_IO_FILENAME(self));
305
306 fth_string_sformat(fs, " %S", FTH_IO_NAME(self));
307
308 if (FTH_IO_INPUT_P(self)) {
309 fth_string_sformat(fs, "-input");
310 if (FTH_IO_OUTPUT_P(self))
311 fth_string_sformat(fs, "/output");
312 } else if (FTH_IO_OUTPUT_P(self))
313 fth_string_sformat(fs, "-output");
314
315 if (FTH_IO_CLOSED_P(self))
316 fth_string_sformat(fs, " closed");
317
318 return (fs);
319 }
320
321 static FTH
io_to_string(FTH self)322 io_to_string(FTH self)
323 {
324 return (fth_make_string_format("#<%S>", io_inspect(self)));
325 }
326
327 static FTH string_empty;
328 static FTH string_cr;
329 static FTH string_space;
330
331 static FTH
io_to_array(FTH self)332 io_to_array(FTH self)
333 {
334 FTH ary;
335
336 if (FTH_ARRAY_P(FTH_IO_BUFFER(self)))
337 return (FTH_IO_BUFFER(self));
338
339 if (FTH_IO_TYPE(self) == FTH_IO_STRING)
340 ary = fth_string_split_2((FTH) FTH_IO_DATA(self), string_cr);
341 else
342 ary = fth_io_readlines(self);
343
344 FTH_IO_BUFFER(self) = ary;
345 return (FTH_IO_BUFFER(self));
346 }
347
348 /* io 2 object-ref => 3rd line of io object */
349 static FTH
io_ref(FTH self,FTH idx)350 io_ref(FTH self, FTH idx)
351 {
352 return (fth_array_ref(fth_object_to_array(self), FTH_INT_REF(idx)));
353 }
354
355 static FTH
io_equal_p(FTH self,FTH obj)356 io_equal_p(FTH self, FTH obj)
357 {
358 int f;
359
360 f = fth_string_equal_p(FTH_IO_FILENAME(self), FTH_IO_FILENAME(obj)) &&
361 FTH_IO_FAM(self) == FTH_IO_FAM(obj) &&
362 fth_io_pos_ref(self) == fth_io_pos_ref(obj);
363 return (BOOL_TO_FTH(f));
364 }
365
366 static FTH
io_length(FTH self)367 io_length(FTH self)
368 {
369 return (fth_make_long_long(fth_io_length(self)));
370 }
371
372 static void
io_mark(FTH self)373 io_mark(FTH self)
374 {
375 fth_gc_mark(FTH_IO_NAME(self));
376 fth_gc_mark(FTH_IO_FILENAME(self));
377 fth_gc_mark(FTH_IO_BUFFER(self));
378 }
379
380 static void
io_free(FTH self)381 io_free(FTH self)
382 {
383 if (!FTH_IO_CLOSED_P(self))
384 FTH_IO_CLOSE(self);
385
386 switch (FTH_IO_TYPE(self)) {
387 case FTH_IO_SOCKET:
388 case FTH_IO_PORT:
389 FTH_FREE(FTH_IO_DATA(self));
390 break;
391 case FTH_IO_FILE: /* FILE *fp */
392 case FTH_IO_PIPE: /* FILE *fp */
393 case FTH_IO_STRING: /* FTH_STRING */
394 default:
395 break;
396 }
397
398 FTH_FREE(FTH_IO_OBJECT(self));
399 }
400
401 static char *
fam_to_mode(int fam)402 fam_to_mode(int fam)
403 {
404 #define WARN_STR "\
405 %s accepts only r/o (r), w/o (w), r/w (w+), a/o (a), and r/a (a+)"
406 static char mode[3];
407 int i;
408
409 i = 0;
410
411 switch (fam) {
412 case FICL_FAM_READ:
413 mode[i++] = 'r';
414 break;
415 case FICL_FAM_WRITE:
416 mode[i++] = 'w';
417 break;
418 case FICL_FAM_READ | FICL_FAM_WRITE:
419 mode[i++] = 'w';
420 mode[i++] = '+';
421 break;
422 case FICL_FAM_APPEND: /* append, write */
423 mode[i++] = 'a';
424 break;
425 case FICL_FAM_READ | FICL_FAM_APPEND: /* append, read-write */
426 mode[i++] = 'a';
427 mode[i++] = '+';
428 break;
429 default:
430 mode[i++] = 'r';
431 fth_warning(WARN_STR, RUNNING_WORD());
432 break;
433 }
434
435 mode[i] = '\0';
436 return (mode);
437 }
438
439 /* --- Generic --- */
440
441 /* ARGSUSED */
442 static int
generic_read_char(void * ptr)443 generic_read_char(void *ptr)
444 {
445 (void) ptr;
446 return (EOF);
447 }
448
449 /* ARGSUSED */
450 static void
generic_write_char(void * ptr,int c)451 generic_write_char(void *ptr, int c)
452 {
453 (void) ptr;
454 (void) c;
455 }
456
457 /* ARGSUSED */
458 static char *
generic_read_line(void * ptr)459 generic_read_line(void *ptr)
460 {
461 (void) ptr;
462 return (NULL);
463 }
464
465 /* ARGSUSED */
466 static void
generic_write_line(void * ptr,const char * line)467 generic_write_line(void *ptr, const char *line)
468 {
469 (void) ptr;
470 (void) line;
471 }
472
473 /* ARGSUSED */
474 static int
generic_eof_p(void * ptr)475 generic_eof_p(void *ptr)
476 {
477 (void) ptr;
478 return (0);
479 }
480
481 /* ARGSUSED */
482 static ficl2Integer
generic_tell(void * ptr)483 generic_tell(void *ptr)
484 {
485 (void) ptr;
486 return (0);
487 }
488
489 /* ARGSUSED */
490 static ficl2Integer
generic_seek(void * ptr,ficl2Integer pos,int whence)491 generic_seek(void *ptr, ficl2Integer pos, int whence)
492 {
493 (void) ptr;
494 (void) pos;
495 (void) whence;
496 return (0);
497 }
498
499 /* ARGSUSED */
500 static void
generic_flush(void * ptr)501 generic_flush(void *ptr)
502 {
503 (void) ptr;
504 }
505
506 /* ARGSUSED */
507 static void
generic_rewind(void * ptr)508 generic_rewind(void *ptr)
509 {
510 (void) ptr;
511 }
512
513 /* ARGSUSED */
514 static void
generic_close(void * ptr)515 generic_close(void *ptr)
516 {
517 (void) ptr;
518 }
519
520 FTH
make_io_base(int fam)521 make_io_base(int fam)
522 {
523 FIO *io;
524
525 io = FTH_CALLOC(1, sizeof(FIO));
526 io->type = FTH_IO_UNDEF;
527 io->name = FTH_FALSE;
528 io->filename = FTH_FALSE;
529 io->buffer = FTH_FALSE;
530 io->fam = fam;
531 io->data = NULL;
532 io->length = 0;
533 io->input_p = (fam & FICL_FAM_READ);
534 io->output_p = (fam & (FICL_FAM_WRITE | FICL_FAM_APPEND));
535 io->closed_p = 0;
536 io->read_char = generic_read_char;
537 io->write_char = generic_write_char;
538 io->read_line = generic_read_line;
539 io->write_line = generic_write_line;
540 io->eof_p = generic_eof_p;
541 io->tell = generic_tell;
542 io->seek = generic_seek;
543 io->flush = generic_flush;
544 io->rewind = generic_rewind;
545 io->close = generic_close;
546 return (fth_make_instance(io_tag, io));
547 }
548
549 /* === FILE-IO === */
550
551 static int
file_read_char(void * ptr)552 file_read_char(void *ptr)
553 {
554 FILE *fp;
555 int c;
556
557 fp = (FILE *) ptr;
558 c = fgetc(fp);
559
560 if (c == EOF) {
561 if (feof(fp))
562 return (EOF);
563
564 if (ferror(fp)) {
565 clearerr(fp);
566 IO_FILE_ERROR(fgetc);
567 }
568 }
569 return (c);
570 }
571
572 static void
file_write_char(void * ptr,int c)573 file_write_char(void *ptr, int c)
574 {
575 FILE *fp;
576
577 fp = (FILE *) ptr;
578
579 if (fputc(c, fp) == EOF)
580 if (ferror(fp)) {
581 clearerr(fp);
582 IO_FILE_ERROR(fputc);
583 }
584 }
585
586 static char io_scratch[BUFSIZ];
587
588 static char *
file_read_line(void * ptr)589 file_read_line(void *ptr)
590 {
591 FILE *fp;
592 char *p;
593
594 fp = (FILE *) ptr;
595 p = fgets(io_scratch, (int) sizeof(io_scratch), fp);
596
597 if (p != NULL)
598 return (p);
599 else {
600 if (feof(fp))
601 return (NULL);
602
603 if (ferror(fp)) {
604 clearerr(fp);
605 IO_FILE_ERROR(fgets);
606 }
607 }
608 /* NOTREACHED */
609 return (NULL);
610 }
611
612 static void
file_write_line(void * ptr,const char * line)613 file_write_line(void *ptr, const char *line)
614 {
615 FILE *fp;
616
617 fp = (FILE *) ptr;
618
619 if (fputs(line, fp) == EOF)
620 if (ferror(fp)) {
621 clearerr(fp);
622 IO_FILE_ERROR(fputs);
623 }
624 }
625
626 static int
file_eof_p(void * ptr)627 file_eof_p(void *ptr)
628 {
629 return (feof((FILE *) ptr));
630 }
631
632 static ficl2Integer
file_tell(void * ptr)633 file_tell(void *ptr)
634 {
635 FILE *fp;
636
637 fp = (FILE *) ptr;
638 fflush(fp);
639 return ((ficl2Integer) lseek(fileno(fp), (off_t) 0, SEEK_CUR));
640 }
641
642 static ficl2Integer
file_seek(void * ptr,ficl2Integer pos,int whence)643 file_seek(void *ptr, ficl2Integer pos, int whence)
644 {
645 FILE *fp;
646
647 fp = (FILE *) ptr;
648 fflush(fp);
649 return ((ficl2Integer) lseek(fileno(fp), (off_t) pos, whence));
650 }
651
652 static void
file_flush(void * ptr)653 file_flush(void *ptr)
654 {
655 fflush((FILE *) ptr);
656 }
657
658 static void
file_rewind(void * ptr)659 file_rewind(void *ptr)
660 {
661 FILE *fp;
662
663 fp = (FILE *) ptr;
664 fflush(fp);
665 rewind(fp);
666 }
667
668 static void
file_close(void * ptr)669 file_close(void *ptr)
670 {
671 fclose((FILE *) ptr);
672 }
673
674 static FTH
make_file_io(FILE * fp,const char * name,int fam)675 make_file_io(FILE *fp, const char *name, int fam)
676 {
677 char *mode;
678 FTH io;
679
680 mode = fam_to_mode(fam);
681
682 if (fp == NULL) {
683 fp = fopen(name, mode);
684
685 if (fp == NULL) {
686 IO_FILE_ERROR_ARG(fopen, name);
687 /* NOTREACHED */
688 return (FTH_FALSE);
689 }
690 }
691 io = make_io_base(fam);
692 FTH_IO_TYPE(io) = FTH_IO_FILE;
693 FTH_IO_NAME(io) = fth_make_string("file");
694 FTH_IO_FILENAME(io) = fth_make_string(name);
695 FTH_IO_DATA(io) = (void *) fp;
696 FTH_IO_OBJECT(io)->read_char = file_read_char;
697 FTH_IO_OBJECT(io)->write_char = file_write_char;
698 FTH_IO_OBJECT(io)->read_line = file_read_line;
699 FTH_IO_OBJECT(io)->write_line = file_write_line;
700 FTH_IO_OBJECT(io)->eof_p = file_eof_p;
701 FTH_IO_OBJECT(io)->tell = file_tell;
702 FTH_IO_OBJECT(io)->seek = file_seek;
703 FTH_IO_OBJECT(io)->flush = file_flush;
704 FTH_IO_OBJECT(io)->rewind = file_rewind;
705 FTH_IO_OBJECT(io)->close = file_close;
706 return (io);
707 }
708
709 /* === PIPE-IO === */
710
711 static void
pipe_close(void * ptr)712 pipe_close(void *ptr)
713 {
714 fth_set_exit_status(pclose((FILE *) ptr));
715 }
716
717 /* cmd: string or array of strings */
718 FTH
fth_io_popen(FTH cmd,int fam)719 fth_io_popen(FTH cmd, int fam)
720 {
721 char *name;
722 FTH io;
723 FILE *fp;
724
725 FTH_ASSERT_ARGS((FTH_STRING_P(cmd) || FTH_ARRAY_P(cmd)),
726 cmd, FTH_ARG1, "a string or an array of strings");
727 io = make_io_base(fam);
728 name = NULL;
729
730 if (FTH_STRING_P(cmd)) {
731 name = fth_string_ref(cmd);
732 FTH_IO_FILENAME(io) = cmd;
733 } else if (FTH_ARRAY_P(cmd)) {
734 name = fth_string_ref(fth_array_join(cmd, string_space));
735 FTH_IO_FILENAME(io) = fth_array_ref(cmd, 0L);
736 }
737 if (name == NULL) {
738 FTH_ASSERT_ARGS(0, cmd, FTH_ARG1,
739 "a string or an array of strings");
740 /* NOTREACHED */
741 return (FTH_FALSE);
742 }
743 fp = popen(name, fam_to_mode(fam));
744
745 if (fp == NULL) {
746 IO_FILE_ERROR_ARG(popen, name);
747 /* NOTREACHED */
748 return (FTH_FALSE);
749 }
750 FTH_IO_TYPE(io) = FTH_IO_PIPE;
751 FTH_IO_NAME(io) = fth_make_string("pipe");
752 FTH_IO_DATA(io) = (void *) fp;
753 FTH_IO_OBJECT(io)->read_char = file_read_char;
754 FTH_IO_OBJECT(io)->write_char = file_write_char;
755 FTH_IO_OBJECT(io)->read_line = file_read_line;
756 FTH_IO_OBJECT(io)->write_line = file_write_line;
757 FTH_IO_OBJECT(io)->eof_p = file_eof_p;
758 FTH_IO_OBJECT(io)->flush = file_flush;
759 FTH_IO_OBJECT(io)->close = pipe_close;
760 return (io);
761 }
762
763 /* === STRING-IO === */
764
765 static int
string_read_char(void * ptr)766 string_read_char(void *ptr)
767 {
768 ficlInteger idx;
769 int c;
770
771 c = EOF;
772 idx = FTH_IO_STRING_INDEX_REF(ptr);
773
774 if (idx < FTH_IO_STRING_LENGTH(ptr)) {
775 c = fth_string_c_char_fast_ref((FTH) ptr, idx++);
776 FTH_IO_STRING_INDEX_SET(ptr, idx);
777 }
778 return (c);
779 }
780
781 static void
string_write_char(void * ptr,int c)782 string_write_char(void *ptr, int c)
783 {
784 ficlInteger idx;
785
786 idx = FTH_IO_STRING_INDEX_REF(ptr);
787
788 if (idx >= FTH_IO_STRING_LENGTH(ptr) - 1) {
789 FTH fs;
790
791 fs = fth_make_string_format("%c", (char) c);
792 fth_string_push((FTH) ptr, fs);
793 } else
794 fth_string_c_char_fast_set((FTH) ptr, idx, (char) c);
795
796 FTH_IO_STRING_INDEX_SET(ptr, ++idx);
797 }
798
799 static char *
string_read_line(void * ptr)800 string_read_line(void *ptr)
801 {
802 ficlInteger idx, len;
803 size_t i, size;
804 char *line;
805
806 idx = FTH_IO_STRING_INDEX_REF(ptr);
807 len = FTH_IO_STRING_LENGTH(ptr);
808
809 if (idx >= len)
810 return (NULL);
811
812 line = io_scratch;
813 size = sizeof(io_scratch);
814
815 for (i = 0; i < size && idx < len; i++, idx++) {
816 char c;
817
818 c = fth_string_c_char_fast_ref((FTH) ptr, idx);
819 line[i] = c;
820 if (c == '\n') {
821 idx++;
822 i++;
823 break;
824 }
825 }
826
827 FTH_IO_STRING_INDEX_SET(ptr, idx);
828 line[i] = '\0';
829 return (line);
830 }
831
832 static void
string_write_line(void * ptr,const char * line)833 string_write_line(void *ptr, const char *line)
834 {
835 ficlInteger idx, len;
836 size_t i, size;
837
838 if (line == NULL)
839 return;
840
841 idx = FTH_IO_STRING_INDEX_REF(ptr);
842 len = FTH_IO_STRING_LENGTH(ptr);
843 size = fth_strlen(line);
844
845 if (idx >= len - 1) {
846 fth_string_push((FTH) ptr, fth_make_string(line));
847 idx += size;
848 } else {
849 for (i = 0; i < size && idx < len; i++, idx++)
850 fth_string_c_char_fast_set((FTH) ptr, idx, line[i]);
851
852 if (i < size) {
853 fth_string_push((FTH) ptr, fth_make_string(line + i));
854 idx += (size - i);
855 }
856 }
857 FTH_IO_STRING_INDEX_SET(ptr, idx);
858 }
859
860 static int
string_eof_p(void * ptr)861 string_eof_p(void *ptr)
862 {
863 return (FTH_IO_STRING_INDEX_REF(ptr) >= FTH_IO_STRING_LENGTH(ptr));
864 }
865
866 static ficl2Integer
string_tell(void * ptr)867 string_tell(void *ptr)
868 {
869 return (FTH_IO_STRING_INDEX_REF(ptr));
870 }
871
872 static ficl2Integer
string_seek(void * ptr,ficl2Integer dpos,int whence)873 string_seek(void *ptr, ficl2Integer dpos, int whence)
874 {
875 ficlInteger pos, end;
876
877 pos = (ficlInteger) dpos;
878
879 switch (whence) {
880 case SEEK_SET:
881 FTH_IO_STRING_INDEX_SET(ptr, pos);
882 break;
883 case SEEK_CUR:
884 FTH_IO_STRING_INDEX_SET(ptr,
885 FTH_IO_STRING_INDEX_REF(ptr) + pos);
886 break;
887 case SEEK_END:
888 default:
889 end = FTH_IO_STRING_LENGTH(ptr) - 1;
890 if (pos > 0)
891 end -= pos;
892 else
893 end += pos;
894 FTH_IO_STRING_INDEX_SET(ptr, end);
895 break;
896 }
897
898 return ((ficl2Integer) FTH_IO_STRING_INDEX_REF(ptr));
899 }
900
901 static void
string_rewind_and_close(void * ptr)902 string_rewind_and_close(void *ptr)
903 {
904 fth_cycle_pos_0((FTH) ptr);
905 }
906
907 FTH
fth_io_sopen(FTH string,int fam)908 fth_io_sopen(FTH string, int fam)
909 {
910 FTH io;
911
912 if (!FTH_STRING_P(string))
913 string = fth_make_empty_string();
914
915 io = make_io_base(fam);
916 FTH_IO_TYPE(io) = FTH_IO_STRING;
917 FTH_IO_NAME(io) = fth_make_string("string");
918 FTH_IO_DATA(io) = (void *) string;
919 FTH_IO_LENGTH(io) = fth_string_length(string);
920 FTH_IO_OBJECT(io)->read_char = string_read_char;
921 FTH_IO_OBJECT(io)->write_char = string_write_char;
922 FTH_IO_OBJECT(io)->read_line = string_read_line;
923 FTH_IO_OBJECT(io)->write_line = string_write_line;
924 FTH_IO_OBJECT(io)->eof_p = string_eof_p;
925 FTH_IO_OBJECT(io)->tell = string_tell;
926 FTH_IO_OBJECT(io)->seek = string_seek;
927 FTH_IO_OBJECT(io)->rewind = string_rewind_and_close;
928 FTH_IO_OBJECT(io)->close = string_rewind_and_close;
929
930 if ((fam & FICL_FAM_APPEND) || (fam & FICL_FAM_WRITE))
931 FTH_IO_SEEK(io, 0L, SEEK_END);
932 else
933 FTH_IO_SEEK(io, 0L, SEEK_SET);
934
935 return (io);
936 }
937
938 ficl2Integer
fth_io_length(FTH io)939 fth_io_length(FTH io)
940 {
941 ficl2Integer io_len, pos;
942
943 IO_ASSERT_IO(io);
944
945 if (!FTH_INSTANCE_CHANGED_P(io))
946 return (FTH_IO_LENGTH(io));
947
948 switch (FTH_IO_TYPE(io)) {
949 case FTH_IO_FILE:
950 if (fth_io_fileno(io) < 3)
951 io_len = FTH_IO_TELL(io);
952 else {
953 pos = FTH_IO_TELL(io);
954 io_len = FTH_IO_SEEK(io, (off_t) 0, SEEK_END);
955 FTH_IO_SEEK(io, pos, SEEK_SET);
956 }
957 break;
958 case FTH_IO_STRING:
959 io_len = FTH_IO_STRING_LENGTH(FTH_IO_DATA(io));
960 break;
961 case FTH_IO_PORT:
962 io_len = 0;
963 break;
964 case FTH_IO_SOCKET:
965 case FTH_IO_PIPE:
966 default:
967 io_len = FTH_IO_TELL(io);
968 break;
969 }
970
971 return (FTH_IO_LENGTH(io) = io_len);
972 }
973
974 static void
ficl_io_filename(ficlVm * vm)975 ficl_io_filename(ficlVm *vm)
976 {
977 #define h_io_filename "( io -- filename|#f ) return filename\n\
978 \".fthrc\" io-open-read value io\n\
979 io io-filename => \".fthrc\"\n\
980 Return filename of IO object or #f if filename is not available."
981 FTH io;
982
983 FTH_STACK_CHECK(vm, 1, 1);
984 io = fth_pop_ficl_cell(vm);
985 IO_ASSERT_IO(io);
986 ficlStackPushFTH(vm->dataStack, FTH_IO_FILENAME(io));
987 }
988
989 static void
ficl_io_mode(ficlVm * vm)990 ficl_io_mode(ficlVm *vm)
991 {
992 #define h_io_mode "( io -- mode ) return access mode\n\
993 \".fthrc\" io-open-read value io\n\
994 io io-mode => \"r\"\n\
995 Return access mode of IO object."
996 FTH io;
997
998 FTH_STACK_CHECK(vm, 1, 1);
999 io = fth_pop_ficl_cell(vm);
1000 IO_ASSERT_IO(io);
1001 push_cstring(vm, fam_to_mode(FTH_IO_FAM(io)));
1002 }
1003
1004 static void
ficl_io_fileno(ficlVm * vm)1005 ficl_io_fileno(ficlVm *vm)
1006 {
1007 #define h_io_fileno "( io -- fd ) return file descriptor\n\
1008 \".fthrc\" io-open-read value io\n\
1009 io io-fileno => 3\n\
1010 Return file descriptor of IO."
1011 FTH io;
1012
1013 FTH_STACK_CHECK(vm, 1, 1);
1014 io = fth_pop_ficl_cell(vm);
1015 ficlStackPushInteger(vm->dataStack, (ficlInteger) fth_io_fileno(io));
1016 }
1017
1018 FTH
fth_io_to_string(FTH io)1019 fth_io_to_string(FTH io)
1020 {
1021 #define h_io_to_string "( io -- str ) return IO content as string\n\
1022 \".fthrc\" io-open-read value io\n\
1023 io io->string => \"...\"\n\
1024 Return content of IO object as string if possible."
1025 IO_ASSERT_IO(io);
1026
1027 if (FTH_IO_TYPE(io) == FTH_IO_STRING)
1028 return (fth_string_copy((FTH) FTH_IO_DATA(io)));
1029
1030 return (fth_array_join(fth_object_to_array(io), string_empty));
1031 }
1032
1033 static void
ficl_io_p(ficlVm * vm)1034 ficl_io_p(ficlVm *vm)
1035 {
1036 #define h_io_p "( obj -- f ) test if OBJ is an IO object\n\
1037 \".fthrc\" io-open-read value io\n\
1038 io io? => #t\n\
1039 10 io? => #f\n\
1040 Return #t if OBJ is an IO object, otherwise #f."
1041 FTH obj;
1042
1043 FTH_STACK_CHECK(vm, 1, 1);
1044 obj = fth_pop_ficl_cell(vm);
1045 ficlStackPushBoolean(vm->dataStack, FTH_IO_P(obj));
1046 }
1047
1048 int
fth_io_input_p(FTH obj)1049 fth_io_input_p(FTH obj)
1050 {
1051 return (IO_INPUT_P(obj));
1052 }
1053
1054 static void
ficl_io_input_p(ficlVm * vm)1055 ficl_io_input_p(ficlVm *vm)
1056 {
1057 #define h_io_input_p "( obj -- f ) test if OBJ is an input IO object\n\
1058 \".fthrc\" io-open-read value io1\n\
1059 \"foo\" io-open-write value io2\n\
1060 io1 io-input? => #t\n\
1061 io2 io-input? => #f\n\
1062 Return #t if OBJ is an input IO object, otherwise #f."
1063 FTH io;
1064
1065 FTH_STACK_CHECK(vm, 1, 1);
1066 io = fth_pop_ficl_cell(vm);
1067 ficlStackPushBoolean(vm->dataStack, IO_INPUT_P(io));
1068 }
1069
1070 int
fth_io_output_p(FTH obj)1071 fth_io_output_p(FTH obj)
1072 {
1073 return (IO_OUTPUT_P(obj));
1074 }
1075
1076 static void
ficl_io_output_p(ficlVm * vm)1077 ficl_io_output_p(ficlVm *vm)
1078 {
1079 #define h_io_output_p "( obj -- f ) test if OBJ is an output IO object\n\
1080 \".fthrc\" io-open-read value io1\n\
1081 \"foo\" io-open-write value io2\n\
1082 io1 io-output? => #f\n\
1083 io2 io-output? => #t\n\
1084 Return #t if OBJ is an output IO object, otherwise #f."
1085 FTH io;
1086
1087 FTH_STACK_CHECK(vm, 1, 1);
1088 io = fth_pop_ficl_cell(vm);
1089 ficlStackPushBoolean(vm->dataStack, IO_OUTPUT_P(io));
1090 }
1091
1092 int
fth_io_closed_p(FTH obj)1093 fth_io_closed_p(FTH obj)
1094 {
1095 return (FTH_IO_P(obj) && FTH_IO_CLOSED_P(obj));
1096 }
1097
1098 static void
ficl_io_closed_p(ficlVm * vm)1099 ficl_io_closed_p(ficlVm *vm)
1100 {
1101 #define h_io_closed_p "( io -- f ) test if IO is closed\n\
1102 \".fthrc\" io-open-read value io\n\
1103 io io-closed? => #f\n\
1104 io io-close\n\
1105 io io-closed? => #t\n\
1106 Return #t if IO object is closed, otherwise #f."
1107 FTH io;
1108
1109 FTH_STACK_CHECK(vm, 1, 1);
1110 io = fth_pop_ficl_cell(vm);
1111 ficlStackPushBoolean(vm->dataStack, fth_io_closed_p(io));
1112 }
1113
1114 static FTH version_control;
1115 static FTH version_number_string;
1116
1117 static int
file_number(char * name)1118 file_number(char *name)
1119 {
1120 FTH dir, files;
1121 char *bname, *path, *s;
1122 size_t flen, blen, plen;
1123 ficlInteger i, len;
1124 int numb, x;
1125
1126 if (name == NULL)
1127 return (0);
1128
1129 dir = fth_file_dirname(name);
1130 files = fth_file_match_dir(dir, version_number_string);
1131 flen = (size_t) fth_array_length(files);
1132 bname = fth_basename(name);
1133 blen = fth_strlen(bname);
1134
1135 if (flen <= 0 || blen <= 0)
1136 return (0);
1137
1138 numb = 0;
1139 len = (ficlInteger) flen;
1140 path = fth_format("%S/%.*s", dir, (int) blen, bname);
1141 plen = fth_strlen(path);
1142
1143 for (i = 0; i < len; i++) {
1144 s = fth_string_ref(fth_array_ref(files, i));
1145
1146 if (s != NULL && (strncmp(s, path, plen) == 0)) {
1147 x = (int) strtol(s + plen + 2, NULL, 10);
1148
1149 if (++x > numb)
1150 numb = x;
1151 }
1152 }
1153 FTH_FREE(path);
1154 return (numb);
1155 }
1156
1157 static void
file_version_rename(char * name)1158 file_version_rename(char *name)
1159 {
1160 char *new_name;
1161 int numb;
1162
1163 if (FTH_TRUE_P(version_control)) {
1164 /* numbered backups */
1165 numb = file_number(name);
1166
1167 if (numb == 0)
1168 numb++;
1169
1170 new_name = fth_format("%s.~%d~", name, numb);
1171 fth_file_rename(name, new_name);
1172 FTH_FREE(new_name);
1173 return;
1174 }
1175 if (FTH_NIL_P(version_control)) {
1176 /* numbered/simple backups */
1177 numb = file_number(name);
1178
1179 if (numb > 0)
1180 new_name = fth_format("%s.~%d~", name, numb);
1181 else
1182 new_name = fth_format("%s~", name);
1183
1184 fth_file_rename(name, new_name);
1185 FTH_FREE(new_name);
1186 return;
1187 }
1188 if (FTH_FALSE_P(version_control)) {
1189 /* simple backups */
1190 new_name = fth_format("%s~", name);
1191 fth_file_rename(name, new_name);
1192 FTH_FREE(new_name);
1193 }
1194 /* else no backups */
1195 }
1196
1197 static void
io_if_exists(char * name,FTH exists,int fam)1198 io_if_exists(char *name, FTH exists, int fam)
1199 {
1200 if ((fam & (FICL_FAM_WRITE | FICL_FAM_APPEND)) &&
1201 fth_file_exists_p(name)) {
1202 if (exists == FTH_KEYWORD_RENAME)
1203 file_version_rename(name);
1204 else if (exists == FTH_KEYWORD_ERROR)
1205 fth_throw(FTH_FILE_IO_ERROR, "%s: \"%s\" exists",
1206 RUNNING_WORD(), name);
1207 /* else overwrite */
1208 }
1209 }
1210
1211 static void
ficl_version_control(ficlVm * vm)1212 ficl_version_control(ficlVm *vm)
1213 {
1214 #define h_version_control "( -- val ) version-control\n\
1215 Return current version control style.\n\
1216 #t => numbered backups\n\
1217 nil => numbered/simple backups\n\
1218 #f => simple backups\n\
1219 undef => no backups"
1220 fth_push_ficl_cell(vm, version_control);
1221 }
1222
1223 static void
ficl_set_version_control(ficlVm * vm)1224 ficl_set_version_control(ficlVm *vm)
1225 {
1226 #define h_set_vc "( val -- ) set version-control\n\
1227 Set current version control style. \
1228 Accepted values:\n\
1229 #t => numbered backups\n\
1230 nil => numbered/simple backups\n\
1231 #f => simple backups\n\
1232 undef => no backups"
1233 FTH val;
1234
1235 FTH_STACK_CHECK(vm, 1, 0);
1236 val = fth_pop_ficl_cell(vm);
1237
1238 if (FTH_BOOLEAN_P(val) || FTH_NIL_TYPE_P(val))
1239 version_control = val;
1240 else
1241 version_control = FTH_UNDEF;
1242 }
1243
1244 static void
ficl_io_open_file(ficlVm * vm)1245 ficl_io_open_file(ficlVm *vm)
1246 {
1247 #define h_io_open_file "( :key fam r/o args -- io ) open IO\n\
1248 :filename \"foo\" io-open-file value io1\n\
1249 :filename \"foo\" :fam r/o io-open-file value io2\n\
1250 :filename \"bar\" :fam r/w io-open-file value io3\n\
1251 :command \"ls -lF\" io-open-file value io4\n\
1252 :command #( \"ls\" \"-lF\" ) io-open-file value io5\n\
1253 :string \"test string\" io-open-file value io6\n\
1254 :soft-port \"test\" io-open-file value io7\n\
1255 Keyword argument :fam defaults to r/o.\n\
1256 General IO open function. \
1257 Return IO object for io-read/io-write etc.\n\
1258 " keyword_args_string
1259 int arg;
1260
1261 arg = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ);
1262 fth_push_ficl_cell(vm, io_keyword_args_ref(arg));
1263 }
1264
1265 static void
ficl_io_open_input_file(ficlVm * vm)1266 ficl_io_open_input_file(ficlVm *vm)
1267 {
1268 #define h_io_oi_file "( :key args -- io ) open IO for reading\n\
1269 :filename \"foo\" io-open-input-file value io1\n\
1270 :command \"ls -lF\" io-open-input-file value io2\n\
1271 :command #( \"ls\" \"-lF\" ) io-open-input-file value io3\n\
1272 :string \"test string\" io-open-input-file value io4\n\
1273 :soft-port \"input-test\" io-open-input-file value io5\n\
1274 General IO open function. \
1275 Return IO object for reading.\n\
1276 " keyword_args_string
1277 fth_push_ficl_cell(vm, io_keyword_args_ref(FICL_FAM_READ));
1278 }
1279
1280 static void
ficl_io_open_output_file(ficlVm * vm)1281 ficl_io_open_output_file(ficlVm *vm)
1282 {
1283 #define h_io_oo_file "( :key args -- io ) open IO for writing\n\
1284 :filename \"foo\" io-open-output-file value io1\n\
1285 :command \"cat\" io-open-output-file value io2\n\
1286 :command #( \"cat\" ) io-open-output-file value io3\n\
1287 \"\" value s1\n\
1288 :string s1 io-open-output-file value io4\n\
1289 :soft-port \"output-test\" io-open-output-file value io5\n\
1290 General IO open function. \
1291 Return IO object for writing.\n\
1292 " keyword_args_string
1293 fth_push_ficl_cell(vm, io_keyword_args_ref(FICL_FAM_WRITE));
1294 }
1295
1296 FTH
fth_io_open(const char * name,int fam)1297 fth_io_open(const char *name, int fam)
1298 {
1299 return (make_file_io(NULL, name, fam));
1300 }
1301
1302 #define h_fam_values "\
1303 Possible FAM values:\n\
1304 r/o -- read-only \"r\"\n\
1305 w/o -- write-only \"w\"\n\
1306 r/w -- read/write \"w+\"\n\
1307 a/o -- append \"a\"\n\
1308 r/a -- read/write-append \"a+\""
1309
1310 #define h_if_exist_help "\
1311 If keyword IF-EXISTS was not specified, \
1312 overwrite possible existing file before open it for writing or appending.\n\
1313 Possible IF-EXISTS values:\n\
1314 :overwrite -- overwrite existing file (default)\n\
1315 :error -- raise IO-ERROR exception if NAME already exist\n\
1316 :rename -- depends on environment variable $VERSION_CONTROL\n\
1317 and global Fth variable VERSION-CONTROL,\n\
1318 see version-control and set-version-control for details."
1319
1320 static void
ficl_io_open(ficlVm * vm)1321 ficl_io_open(ficlVm *vm)
1322 {
1323 #define h_io_open "( name :key fam r/o if-exists overwrite -- io ) open\n\
1324 \"in-test\" io-open value read-io1\n\
1325 \"in-test\" :fam r/o io-open value read-io2\n\
1326 \"out-test\" :fam w/o io-open value overwrite-io1\n\
1327 \"out-test\" :fam w/o :if-exists :overwrite io-open value overwrite-io2\n\
1328 \"out-test\" :fam r/w :if-exists :error io-open value read-write-io1\n\
1329 \"out-test\" :fam r/w :if-exists :rename io-open value rename-io1\n\
1330 Open file NAME and return new IO object. \
1331 If keyword FAM was not specified, open file read-only, otherwise take FAM.\n\
1332 " h_fam_values "\n" h_if_exist_help "\n\
1333 See also io-open-read and io-open-write."
1334 FTH exists, fs;
1335 int fam;
1336 char *name;
1337
1338 exists = fth_get_optkey(FTH_KEYWORD_IF_EXISTS, FTH_KEYWORD_OVERWRITE);
1339 fam = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ);
1340 FTH_STACK_CHECK(vm, 1, 1);
1341 fs = fth_pop_ficl_cell(vm);
1342 IO_ASSERT_STRING(fs, FTH_ARG1);
1343 name = IO_STRING_REF(fs);
1344 io_if_exists(name, exists, fam);
1345 ficlStackPushFTH(vm->dataStack, fth_io_open(name, fam));
1346 }
1347
1348 static void
ficl_io_open_read(ficlVm * vm)1349 ficl_io_open_read(ficlVm *vm)
1350 {
1351 #define h_io_open_read "( name -- io ) open\n\
1352 \"in-test\" io-open-read value read-io1\n\
1353 Open file NAME for reading and return new IO object.\n\
1354 See also io-open and io-open-write."
1355 FTH fs;
1356 char *name;
1357
1358 FTH_STACK_CHECK(vm, 1, 1);
1359 fs = fth_pop_ficl_cell(vm);
1360 IO_ASSERT_STRING(fs, FTH_ARG1);
1361 name = IO_STRING_REF(fs);
1362
1363 if (!fth_file_exists_p(name))
1364 fth_throw(FTH_NO_SUCH_FILE, "%s: \"%s\" doesn't exist",
1365 RUNNING_WORD(), name);
1366
1367 ficlStackPushFTH(vm->dataStack, fth_io_open(name, FICL_FAM_READ));
1368 }
1369
1370 static void
ficl_io_open_write(ficlVm * vm)1371 ficl_io_open_write(ficlVm *vm)
1372 {
1373 #define h_io_open_write "( name :key if-exists overwrite -- io ) open\n\
1374 \"out-test\" io-open-write value overwrite-io1\n\
1375 \"out-test\" :if-exists :overwrite io-open-write value overwrite-io2\n\
1376 \"out-test\" :if-exists :error io-open-write value error-io1\n\
1377 \"out-test\" :if-exists :rename io-open-write value rename-io1\n\
1378 Open file NAME for writing and return new IO object.\n\
1379 " h_if_exist_help "\n\
1380 See also io-open and io-open-read."
1381 FTH exists, fs;
1382 char *name;
1383
1384 exists = fth_get_optkey(FTH_KEYWORD_IF_EXISTS, FTH_KEYWORD_OVERWRITE);
1385 FTH_STACK_CHECK(vm, 1, 1);
1386 fs = fth_pop_ficl_cell(vm);
1387 name = IO_STRING_REF(fs);
1388 io_if_exists(name, exists, FICL_FAM_WRITE);
1389 ficlStackPushFTH(vm->dataStack, fth_io_open(name, FICL_FAM_WRITE));
1390 }
1391
1392 static void
ficl_io_reopen(ficlVm * vm)1393 ficl_io_reopen(ficlVm *vm)
1394 {
1395 #define h_io_reopen "( io1 name :key fam io1-fam -- io2 ) copy IO1\n\
1396 \"1-test\" io-open-write value io1\n\
1397 io1 \"hello\" io-write\n\
1398 io1 \"2-test\" io-reopen value io2\n\
1399 io1 io-closed? => #t\n\
1400 io2 \"world\" io-write\n\
1401 io2 io-close\n\
1402 io2 io-closed? => #t\n\
1403 \"1-test\" readlines => #( \"hello\" )\n\
1404 \"2-test\" readlines => #( \"world\" )\n\
1405 *stderr* \"error.log\" io-reopen value err-io\n\
1406 Return new IO object as copy of IO1 and close IO1. \
1407 If NAME is not a string, e.g. #f or nil, use filename from IO1. \
1408 If keyword FAM was not given, use mode from IO1, otherwise use FAM. \
1409 All restrictions on reopen apply, \
1410 ie. a file opened for reading can't reopened for writing etc.\n\
1411 See freopen(3) for more information."
1412 FTH io, fname, ffam;
1413 char *name;
1414 int fam;
1415 FILE *fp;
1416
1417 ffam = fth_get_optkey(FTH_KEYWORD_FAM, FTH_UNDEF);
1418 FTH_STACK_CHECK(vm, 2, 1);
1419 fname = ficlStackPopFTH(vm->dataStack);
1420 io = ficlStackPopFTH(vm->dataStack);
1421 IO_ASSERT_IO(io);
1422
1423 if (FTH_IO_TYPE(io) != FTH_IO_FILE) {
1424 ficlStackPushFTH(vm->dataStack, io);
1425 return;
1426 }
1427 if (FTH_STRING_P(fname))
1428 name = fth_string_ref(fname);
1429 else
1430 name = IO_STRING_REF(FTH_IO_FILENAME(io));
1431
1432 if (FTH_BOUND_P(ffam))
1433 fam = FIX_TO_INT32(ffam);
1434 else
1435 fam = FTH_IO_FAM(io);
1436
1437 fp = freopen(name, fam_to_mode(fam), FTH_IO_DATA(io));
1438 /* The original file pointer is already closed by freopen. */
1439 FTH_IO_CLOSED_P(io) = 1;
1440
1441 if (fp == NULL) {
1442 IO_FILE_ERROR_ARG(freopen, name);
1443 /* NOTREACHED */
1444 return;
1445 }
1446 ficlStackPushFTH(vm->dataStack, make_file_io(fp, name, fam));
1447 }
1448
1449 static void
ficl_io_fdopen(ficlVm * vm)1450 ficl_io_fdopen(ficlVm *vm)
1451 {
1452 #define h_io_fdopen "( fd :key fam r/o -- io ) return IO with FD\n\
1453 2 :fam w/o io-fdopen value err-io\n\
1454 err-io \"our error log\" io-write\n\
1455 err-io io-flush => \"our error log\" (on stderr)\n\
1456 Connect file descriptor FD to new IO object. \
1457 If keyword FAM was not given, open file read-only, otherwise use FAM.\n\
1458 See fdopen(3) for more information."
1459 FTH io;
1460 FILE *fp;
1461 int fd, fam;
1462
1463 fam = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ);
1464 FTH_STACK_CHECK(vm, 1, 1);
1465 fd = (int) ficlStackPopInteger(vm->dataStack);
1466 fp = fdopen(fd, fam_to_mode(fam));
1467
1468 if (fp == NULL) {
1469 IO_FILE_ERROR(fdopen);
1470 /* NOTREACHED */
1471 return;
1472 }
1473 io = make_file_io(fp, RUNNING_WORD(), fam);
1474 ficlStackPushFTH(vm->dataStack, io);
1475 }
1476
1477 static void
ficl_io_popen(ficlVm * vm)1478 ficl_io_popen(ficlVm *vm)
1479 {
1480 #define h_io_popen "( cmd :key fam r/o -- io ) open pipe\n\
1481 \"ls -lAF ~/\" io-popen value read-io1\n\
1482 #( \"ls\" \"-lAF\" \"~/\") io-popen value read-io2\n\
1483 read-io1 io->string => \"...\"\n\
1484 read-io1 io-close\n\
1485 \"cat\" :fam w/o io-popen-write value write-io1\n\
1486 write-io1 \"hello\" io-write\n\
1487 write-io1 io-close\n\
1488 Open pipe for command CMD and return new IO object. \
1489 CMD may be a string (with shell expansion) or an array of strings. \
1490 If keyword FAM was not given, open pipe read-only, otherwise use FAM.\n\
1491 " h_fam_values "\n\
1492 See also io-popen-read, io-popen-write and exec."
1493 FTH obj, io;
1494 int fam;
1495
1496 fam = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ);
1497 FTH_STACK_CHECK(vm, 1, 1);
1498 obj = fth_pop_ficl_cell(vm);
1499 io = fth_io_popen(obj, fam);
1500 ficlStackPushFTH(vm->dataStack, io);
1501 }
1502
1503 static void
ficl_io_popen_read(ficlVm * vm)1504 ficl_io_popen_read(ficlVm *vm)
1505 {
1506 #define h_io_popen_read "( cmd -- io ) open pipe for reading\n\
1507 \"ls -lAF ~/\" io-popen-read value io1\n\
1508 #( \"ls\" \"-lAF\" \"~/\") io-popen-read value io2\n\
1509 io1 io->string => \"...\"\n\
1510 io1 io-close\n\
1511 Open read-only pipe for command CMD and return new IO object. \
1512 CMD may be a string (with shell expansion) or an array of strings.\n\
1513 See also io-popen, io-popen-write and exec."
1514 FTH obj, io;
1515
1516 FTH_STACK_CHECK(vm, 1, 1);
1517 obj = fth_pop_ficl_cell(vm);
1518 io = fth_io_popen(obj, FICL_FAM_READ);
1519 ficlStackPushFTH(vm->dataStack, io);
1520 }
1521
1522 static void
ficl_io_popen_write(ficlVm * vm)1523 ficl_io_popen_write(ficlVm *vm)
1524 {
1525 #define h_io_powrite "( cmd -- io ) open pipe for writing\n\
1526 \"cat\" io-popen-write value io1\n\
1527 #( \"cat\" ) io-popen-write value io2\n\
1528 io1 \"hello\" io-write\n\
1529 io1 io-close\n\
1530 Open write-only pipe for command CMD and return new IO object. \
1531 CMD may be a string (with shell expansion) or an array of strings.\n\
1532 See also io-popen, io-popen-read and exec."
1533 FTH obj, io;
1534
1535 FTH_STACK_CHECK(vm, 1, 1);
1536 obj = fth_pop_ficl_cell(vm);
1537 io = fth_io_popen(obj, FICL_FAM_WRITE);
1538 ficlStackPushFTH(vm->dataStack, io);
1539 }
1540
1541 static void
ficl_io_sopen(ficlVm * vm)1542 ficl_io_sopen(ficlVm *vm)
1543 {
1544 #define h_io_sopen "( string :key fam r/o -- io ) open string\n\
1545 \"test-string\" value s1\n\
1546 s1 io-sopen value read-io1\n\
1547 read-io1 io-read => \"test-string\"\n\
1548 read-io1 io-close\n\
1549 s1 :fam r/a io-sopen value append-io1\n\
1550 append-io1 \" with append content\" io-write\n\
1551 append-io1 io-rewind\n\
1552 append-io1 io-read => \"test-string with append content\"\n\
1553 append-io1 io-close\n\
1554 s1 .string => \"test-string with append content\"\n\
1555 Open string with content STRING and return new IO object. \
1556 If keyword FAM was not given, opens string read-only, otherwise takes FAM.\n\
1557 " h_fam_values
1558 FTH fs, io;
1559 int fam;
1560
1561 fam = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ);
1562 FTH_STACK_CHECK(vm, 1, 1);
1563 fs = fth_pop_ficl_cell(vm);
1564 io = fth_io_sopen(fs, fam);
1565 ficlStackPushFTH(vm->dataStack, io);
1566
1567 }
1568
1569 static void
ficl_io_sopen_read(ficlVm * vm)1570 ficl_io_sopen_read(ficlVm *vm)
1571 {
1572 #define h_io_soread "( string -- io ) open string for reading\n\
1573 \"test-string\" value s1\n\
1574 s1 io-sopen-read value io1\n\
1575 io1 io-read => \"test-string\"\n\
1576 io1 io-close\n\
1577 Open read-only string with content STRING and return new IO object.\n\
1578 See also io-sopen."
1579 FTH fs, io;
1580
1581 FTH_STACK_CHECK(vm, 1, 1);
1582 fs = fth_pop_ficl_cell(vm);
1583 io = fth_io_sopen(fs, FICL_FAM_READ);
1584 ficlStackPushFTH(vm->dataStack, io);
1585 }
1586
1587 static void
ficl_io_sopen_write(ficlVm * vm)1588 ficl_io_sopen_write(ficlVm *vm)
1589 {
1590 #define h_io_sowrite "( string -- io ) open string for writing\n\
1591 \"\" value s1\n\
1592 s1 io-sopen-write value io1\n\
1593 io1 \"test-string\" io-write\n\
1594 io1 io-close\n\
1595 s1 .string => \"test-string\"\n\
1596 Open STRING for writing and return new IO object.\n\
1597 See also io-sopen."
1598 FTH fs, io;
1599
1600 FTH_STACK_CHECK(vm, 1, 1);
1601 fs = fth_pop_ficl_cell(vm);
1602 io = fth_io_sopen(fs, FICL_FAM_WRITE);
1603 ficlStackPushFTH(vm->dataStack, io);
1604 }
1605
1606 #if HAVE_SOCKET
1607
1608 /* === SOCKET-IO === */
1609
1610 static int
socket_read_char(void * ptr)1611 socket_read_char(void *ptr)
1612 {
1613 char msg[2];
1614 ssize_t len;
1615
1616 msg[0] = '\0';
1617 len = recv(FTH_IO_SOCKET_FD(ptr), msg, 1L, 0);
1618
1619 if (len == -1) {
1620 IO_SOCKET_ERROR(recv);
1621 /* NOTREACHED */
1622 return (-1);
1623 }
1624 if (len == 1)
1625 return ((int) msg[0]);
1626
1627 return (-1);
1628 }
1629
1630 static void
socket_write_char(void * ptr,int c)1631 socket_write_char(void *ptr, int c)
1632 {
1633 char msg[2];
1634
1635 msg[0] = (char) c;
1636 msg[1] = '\0';
1637
1638 if (send(FTH_IO_SOCKET_FD(ptr), msg, 1L, 0) == -1)
1639 IO_SOCKET_ERROR(send);
1640 }
1641
1642 static char *
socket_read_line(void * ptr)1643 socket_read_line(void *ptr)
1644 {
1645 char *line;
1646 size_t size;
1647 ssize_t len;
1648 socklen_t slen;
1649
1650 line = io_scratch;
1651 size = sizeof(io_scratch);
1652 len = recvfrom(FTH_IO_SOCKET_FD(ptr), line, size, 0, NULL, &slen);
1653
1654 if (len == -1) {
1655 IO_SOCKET_ERROR(recvfrom);
1656 /* NOTREACHED */
1657 return (NULL);
1658 }
1659 if (len > 0) {
1660 line[len] = '\0';
1661 return (line);
1662 }
1663 return (NULL);
1664 }
1665
1666 static void
socket_write_line(void * ptr,const char * line)1667 socket_write_line(void *ptr, const char *line)
1668 {
1669 if (send(FTH_IO_SOCKET_FD(ptr), line, fth_strlen(line), 0) == -1)
1670 IO_SOCKET_ERROR(send);
1671 }
1672
1673 static int
socket_eof_p(void * ptr)1674 socket_eof_p(void *ptr)
1675 {
1676 int fd;
1677 off_t cur, end;
1678
1679 fd = FTH_IO_SOCKET_FD(ptr);
1680 cur = lseek(fd, (off_t) 0, SEEK_CUR);
1681
1682 if (cur == -1)
1683 IO_SOCKET_ERROR(lseek);
1684
1685 end = lseek(fd, (off_t) 0, SEEK_END);
1686
1687 if (end == -1)
1688 IO_SOCKET_ERROR(lseek);
1689
1690 if (lseek(fd, cur, SEEK_SET) == -1)
1691 IO_SOCKET_ERROR(lseek);
1692
1693 return (cur == end);
1694 }
1695
1696 static ficl2Integer
socket_tell(void * ptr)1697 socket_tell(void *ptr)
1698 {
1699 off_t pos;
1700
1701 pos = lseek(FTH_IO_SOCKET_FD(ptr), (off_t) 0, SEEK_CUR);
1702 return ((ficl2Integer) pos);
1703 }
1704
1705 static ficl2Integer
socket_seek(void * ptr,ficl2Integer pos,int whence)1706 socket_seek(void *ptr, ficl2Integer pos, int whence)
1707 {
1708 off_t npos;
1709
1710 npos = lseek(FTH_IO_SOCKET_FD(ptr), (off_t) pos, whence);
1711 return ((ficl2Integer) npos);
1712 }
1713
1714 static void
socket_rewind(void * ptr)1715 socket_rewind(void *ptr)
1716 {
1717 lseek(FTH_IO_SOCKET_FD(ptr), (off_t) 0, SEEK_SET);
1718 }
1719
1720 static void
socket_unlink(const char * host)1721 socket_unlink(const char *host)
1722 {
1723 char *host_del;
1724 int old_errno;
1725
1726 host_del = fth_format("%.*s", (int) fth_strlen(host) - 1, host);
1727 old_errno = errno;
1728 unlink(host_del);
1729 errno = old_errno;
1730 FTH_FREE(host_del);
1731 }
1732
1733 static void
socket_close(void * ptr)1734 socket_close(void *ptr)
1735 {
1736 if (close(FTH_IO_SOCKET_FD(ptr)) == -1)
1737 IO_SOCKET_ERROR(close);
1738 socket_unlink(IO_STRING_REF(FTH_IO_SOCKET_HOST(ptr)));
1739 }
1740
1741 #if defined(HAVE_STRUCT_SOCKADDR_UN_SUN_LEN)
1742
1743 #define IO_SOCKADDR(Addr, Host, Port, Domain, Len) do { \
1744 if (Domain == AF_UNIX) { \
1745 struct sockaddr_un sun; \
1746 \
1747 Addr = (struct sockaddr *)&sun; \
1748 sun.sun_family = (sa_family_t)AF_UNIX; \
1749 sun.sun_path[0] = '\0'; \
1750 fth_strcat(sun.sun_path, sizeof(sun.sun_path), Host); \
1751 Len = (socklen_t)(sizeof(sun.sun_family) + \
1752 fth_strlen(sun.sun_path)); \
1753 sun.sun_len = (unsigned char)Len; \
1754 } else { \
1755 struct sockaddr_in sin; \
1756 struct hostent *hp; \
1757 \
1758 Addr = (struct sockaddr *)&sin; \
1759 sin.sin_family = (sa_family_t)AF_INET; \
1760 sin.sin_port = (in_port_t)htons((in_port_t)Port); \
1761 Len = sin.sin_len = (socklen_t)sizeof(sin); \
1762 hp = gethostbyname(Host); \
1763 if (hp != NULL) \
1764 memmove(&sin.sin_addr, hp->h_addr, \
1765 (size_t)hp->h_length); \
1766 else \
1767 IO_SOCKET_ERROR_ARG(gethostbyname, Host); \
1768 } \
1769 } while (0)
1770
1771 #else /* !HAVE_STRUCT_SOCKADDR_UN_SUN_LEN */
1772
1773 #define IO_SOCKADDR(Addr, Host, Port, Domain, Len) do { \
1774 if (Domain == AF_UNIX) { \
1775 struct sockaddr_un sun; \
1776 \
1777 Addr = (struct sockaddr *)&sun; \
1778 sun.sun_family = (sa_family_t)AF_UNIX; \
1779 sun.sun_path[0] = '\0'; \
1780 fth_strcat(sun.sun_path, sizeof(sun.sun_path), Host); \
1781 Len = (socklen_t)(sizeof(sun.sun_family) + \
1782 fth_strlen(sun.sun_path)); \
1783 } else { \
1784 struct sockaddr_in sin; \
1785 struct hostent *hp; \
1786 \
1787 Addr = (struct sockaddr *)&sin; \
1788 sin.sin_family = (sa_family_t)AF_INET; \
1789 sin.sin_port = (in_port_t)htons((in_port_t)Port); \
1790 Len = (socklen_t)sizeof(sin); \
1791 hp = gethostbyname(Host); \
1792 if (hp != NULL) \
1793 memmove(&sin.sin_addr, hp->h_addr, \
1794 (size_t)hp->h_length); \
1795 else \
1796 IO_SOCKET_ERROR_ARG(gethostbyname, Host); \
1797 } \
1798 } while (0)
1799
1800 #endif /* HAVE_STRUCT_SOCKADDR_UN_SUN_LEN */
1801
1802 static int
socket_bind(const char * host,int port,int domain,int fd)1803 socket_bind(const char *host, int port, int domain, int fd)
1804 {
1805 struct sockaddr *addr;
1806 socklen_t len;
1807
1808 if (host == NULL)
1809 return (-1);
1810
1811 socket_unlink(host);
1812 IO_SOCKADDR(addr, host, port, domain, len);
1813 return (bind(fd, addr, len));
1814 }
1815
1816 static int
socket_accept(int domain,int fd)1817 socket_accept(int domain, int fd)
1818 {
1819 struct sockaddr_un sun;
1820 struct sockaddr_in sin;
1821 struct sockaddr *addr;
1822 socklen_t len;
1823
1824 len = 0;
1825 if (domain == AF_UNIX)
1826 addr = (struct sockaddr *) & sun;
1827 else
1828 addr = (struct sockaddr *) & sin;
1829
1830 return (accept(fd, addr, &len));
1831 }
1832
1833 static int
socket_connect(const char * host,int port,int domain,int fd)1834 socket_connect(const char *host, int port, int domain, int fd)
1835 {
1836 struct sockaddr *addr;
1837 socklen_t len;
1838
1839 if (host == NULL)
1840 return (-1);
1841
1842 IO_SOCKADDR(addr, host, port, domain, len);
1843 return (connect(fd, addr, len));
1844 }
1845
1846 static int
socket_open(int domain,int type)1847 socket_open(int domain, int type)
1848 {
1849 if (domain < AF_UNSPEC || domain > AF_MAX)
1850 domain = FTH_DEFAULT_ADDRFAM;
1851
1852 if (type < SOCK_STREAM || type > SOCK_SEQPACKET)
1853 type = SOCK_DGRAM;
1854
1855 return (socket(domain, type, 0));
1856 }
1857
1858 static FTH
make_socket_io(const char * host,int port,int domain,int fd)1859 make_socket_io(const char *host, int port, int domain, int fd)
1860 {
1861 FIO_Socket *s;
1862 FTH io;
1863
1864 if (fd == -1) {
1865 fd = socket_open(domain, SOCK_STREAM);
1866
1867 if (fd == -1) {
1868 IO_SOCKET_ERROR_ARG(socket, host);
1869 /* NOTREACHED */
1870 return (FTH_FALSE);
1871 }
1872 if (socket_connect(host, port, domain, fd) == -1) {
1873 close(fd);
1874 IO_SOCKET_ERROR_ARG(connect, host);
1875 /* NOTREACHED */
1876 return (FTH_FALSE);
1877 }
1878 }
1879 s = FTH_MALLOC(sizeof(FIO_Socket));
1880 s->fd = fd;
1881 s->host = fth_make_string(host);
1882 io = make_io_base(FICL_FAM_READ | FICL_FAM_WRITE);
1883 FTH_IO_TYPE(io) = FTH_IO_SOCKET;
1884 FTH_IO_FILENAME(io) = s->host;
1885 FTH_IO_NAME(io) = fth_make_string("socket");
1886 FTH_IO_DATA(io) = (void *) s;
1887 FTH_IO_OBJECT(io)->read_char = socket_read_char;
1888 FTH_IO_OBJECT(io)->write_char = socket_write_char;
1889 FTH_IO_OBJECT(io)->read_line = socket_read_line;
1890 FTH_IO_OBJECT(io)->write_line = socket_write_line;
1891 FTH_IO_OBJECT(io)->eof_p = socket_eof_p;
1892 FTH_IO_OBJECT(io)->tell = socket_tell;
1893 FTH_IO_OBJECT(io)->seek = socket_seek;
1894 FTH_IO_OBJECT(io)->rewind = socket_rewind;
1895 FTH_IO_OBJECT(io)->close = socket_close;
1896 return (io);
1897 }
1898
1899 #else /* !HAVE_SOCKET */
1900
1901 static FTH
make_socket_io(const char * host,int port,int domain,int fd)1902 make_socket_io(const char *host, int port, int domain, int fd)
1903 {
1904 FTH io;
1905
1906 io = make_io_base(FICL_FAM_READ | FICL_FAM_WRITE);
1907 FTH_IO_FILENAME(io) = fth_make_string(host);
1908 FTH_IO_TYPE(io) = FTH_IO_SOCKET;
1909 FTH_IO_NAME(io) = fth_make_string("socket");
1910 return (io);
1911 }
1912
1913 #endif /* HAVE_SOCKET */
1914
1915 FTH
fth_io_nopen(const char * host,int port,int domain)1916 fth_io_nopen(const char *host, int port, int domain)
1917 {
1918 return (make_socket_io(host, port, domain, -1));
1919 }
1920
1921 #if HAVE_SOCKET
1922
1923 #define h_socket_open_info "\
1924 HOST is a host name (AF_INET) or a path name (AF_UNIX). \
1925 If HOST is not a string, \"localhost\" will be used. \
1926 PORT is the connection port (default 1024) if DOMAIN is AF_INET, \
1927 otherwise unused, \
1928 and DOMAIN can be one of AF_INET (default) or AF_UNIX. \
1929 The socket is opend with DOMAIN, \
1930 hardcoded second argument SOCK_STREAM, \
1931 and hardcoded third argument of 0.\n\
1932 See socket(2) and connect(2) for more information."
1933
1934 static void
ficl_io_nopen(ficlVm * vm)1935 ficl_io_nopen(ficlVm *vm)
1936 {
1937 #define h_io_nopen "( host :key port 1024 domain AF_INET -- io ) open socket\n\
1938 \"localhost\" :port 25 io-nopen value io\n\
1939 io io-read => \"220 fth-devel.net ESMTP Sendmail ...\"\n\
1940 io \"HELP\\r\\n\" io-write\n\
1941 io io-read => \"... (sendmail help output)\"\n\
1942 io io-close\n\
1943 \"ftp.freebsd.org\" :port 21 io-nopen to io\n\
1944 io io-read\n\
1945 => \"220 ftp.beastie.tdk.net FTP server (Version 6.00LS) ready.\"\n\
1946 io \"HELP\\r\\n\" io-write\n\
1947 io io-read => \"... (ftpd help output)\"\n\
1948 io io-close\n\
1949 Connect to an already established server and return new IO object. \
1950 Raise an SOCKET-ERROR exception if an error occured.\n\
1951 " h_socket_open_info
1952 int domain, port;
1953 FTH fs, io;
1954
1955 domain = fth_get_optkey_fix(FTH_KEYWORD_DOMAIN, FTH_DEFAULT_ADDRFAM);
1956 port = fth_get_optkey_fix(FTH_KEYWORD_PORT, FTH_DEFAULT_PORT);
1957 FTH_STACK_CHECK(vm, 1, 1);
1958 fs = fth_pop_ficl_cell(vm);
1959 io = fth_io_nopen(IO_STRING_REF(fs), port, domain);
1960 ficlStackPushFTH(vm->dataStack, io);
1961 }
1962
1963 /*-
1964 : connection-handler { io -- }
1965 begin
1966 io io-read ( line ) dup
1967 while
1968 \ real work here
1969 ( line ) .$ cr
1970 repeat
1971 ( line ) drop
1972 io io-close
1973 ;
1974
1975 : io-server <{ proc host :key port 1024 domain AF_INET -- }>
1976 domain SOCK_STREAM net-socket { fd }
1977 fd host port domain net-bind
1978 fd net-listen
1979 $" === stop with: %d SIGHUP kill\n" #( getpid ) fth-print
1980 begin
1981 fd host domain net-accept ( io ) proc fork
1982 again
1983 ;
1984 <'> connection-handler "localhost" io-server
1985
1986
1987 : io-client <{ host :key port 1024 domain AF_INET -- io }>
1988 domain SOCK_STREAM net-socket { fd }
1989 fd host port domain net-bind
1990 fd host port domain net-connect ( io )
1991 ;
1992 */
1993
1994 static void
ficl_socket(ficlVm * vm)1995 ficl_socket(ficlVm *vm)
1996 {
1997 #define h_socket "( domain type -- fd ) return socket descriptor\n\
1998 AF_INET SOCK_STREAM net-socket value fd\n\
1999 fd \"localhost\" 1024 AF_INET net-bind\n\
2000 fd net-listen\n\
2001 fd \"localhost\" AF_INET net-accept value io\n\
2002 Return socket descriptor. \
2003 DOMAIN can be AF_INET or AF_UNIX. \
2004 TYPE can be SOCK_STREAM or SOCK_DGRAM. \
2005 The third argument to socket is 0 and can't be set by the user. \
2006 Raise SOCKET-ERROR exception if socket fails.\n\
2007 See socket(2) for more information."
2008 int fd, domain, type;
2009
2010 FTH_STACK_CHECK(vm, 2, 1);
2011 type = (int) ficlStackPopInteger(vm->dataStack);
2012 domain = (int) ficlStackPopInteger(vm->dataStack);
2013 fd = socket_open(domain, type);
2014
2015 if (fd == -1) {
2016 IO_SOCKET_ERROR(socket);
2017 /* NOTREACHED */
2018 return;
2019 }
2020 ficlStackPushInteger(vm->dataStack, (ficlInteger) fd);
2021 }
2022
2023 static void
ficl_bind(ficlVm * vm)2024 ficl_bind(ficlVm *vm)
2025 {
2026 #define h_bind "( fd host port domain -- ) bind to FD\n\
2027 AF_INET SOCK_STREAM net-socket value fd\n\
2028 fd \"localhost\" 1024 AF_INET net-bind\n\
2029 fd net-listen\n\
2030 fd \"localhost\" AF_INET net-accept value io\n\
2031 Assign a name to a socket. \
2032 FD is the socket descriptor, \
2033 HOST is a host name (AF_INET) or a path name (AF_UNIX), \
2034 PORT is the port if DOMAIN is AF_INET, otherwise unused, \
2035 and DOMAIN is one of AF_INET or AF_UNIX. \
2036 This is used on the server side of a socket connection. \
2037 Raise SOCKET-ERROR exception if bind fails.\n\
2038 See bind(2) for more information."
2039 FTH fs;
2040 char *host;
2041 int fd, domain, port;
2042
2043 FTH_STACK_CHECK(vm, 4, 0);
2044 domain = (int) ficlStackPopInteger(vm->dataStack);
2045 port = (int) ficlStackPopInteger(vm->dataStack);
2046 fs = fth_pop_ficl_cell(vm);
2047 fd = (int) ficlStackPopInteger(vm->dataStack);
2048 host = IO_STRING_REF(fs);
2049
2050 if (socket_bind(host, port, domain, fd) == -1) {
2051 close(fd);
2052 IO_SOCKET_ERROR_ARG(bind, host);
2053 }
2054 }
2055
2056 static void
ficl_listen(ficlVm * vm)2057 ficl_listen(ficlVm *vm)
2058 {
2059 #define h_listen "( fd -- ) listen on socket FD\n\
2060 AF_INET SOCK_STREAM net-socket value fd\n\
2061 fd \"localhost\" 1024 AF_INET net-bind\n\
2062 fd net-listen\n\
2063 fd \"localhost\" AF_INET net-accept value io\n\
2064 Inform the operating system that connection requests should be delivered. \
2065 FD is the previously opened socket descriptor. \
2066 This is used on the server side of a socket connection. \
2067 Raise SOCKET-ERROR exception if listen fails.\n\
2068 See listen(2) for more information."
2069 int fd;
2070
2071 FTH_STACK_CHECK(vm, 1, 0);
2072 fd = (int) ficlStackPopInteger(vm->dataStack);
2073
2074 if (listen(fd, -1) == -1)
2075 IO_SOCKET_ERROR(listen);
2076 }
2077
2078 static void
ficl_shutdown(ficlVm * vm)2079 ficl_shutdown(ficlVm *vm)
2080 {
2081 #define h_shutdown "( fd how -- ) close socket connection\n\
2082 AF_INET SOCK_STREAM net-socket value fd\n\
2083 fd \"localhost\" 1024 AF_INET net-bind\n\
2084 fd net-listen\n\
2085 fd SHUT_RDWR net-shutdown\n\
2086 Close socket connection. \
2087 FD is the socket descriptor and HOW is one of SHUT_RD, SHUT_WR or SHUT_RDWR. \
2088 Raise SOCKET-ERROR exception if shutdown fails.\n\
2089 See shutdown(2) for more information."
2090 int fd, how;
2091
2092 FTH_STACK_CHECK(vm, 2, 0);
2093 how = (int) ficlStackPopInteger(vm->dataStack);
2094 fd = (int) ficlStackPopInteger(vm->dataStack);
2095
2096 if (shutdown(fd, how) == -1)
2097 IO_SOCKET_ERROR(shutdown);
2098 }
2099
2100 static void
ficl_accept(ficlVm * vm)2101 ficl_accept(ficlVm *vm)
2102 {
2103 #define h_accept "( fd host domain -- io ) accept socket and return IO\n\
2104 AF_INET SOCK_STREAM net-socket value fd\n\
2105 fd \"localhost\" 1024 AF_INET net-bind\n\
2106 fd net-listen\n\
2107 fd \"localhost\" AF_INET net-accept value io\n\
2108 Accept a connection on a socket and return an IO object \
2109 after established connection. \
2110 FD is the socket descriptor, \
2111 HOST can be an arbitrary name, \
2112 its only use is the name for the IO object, \
2113 DOMAIN is one of AF_INET or AF_UNIX. \
2114 This is used on the server side of a socket connection. \
2115 Raise SOCKET-ERROR exception if accept fails.\n\
2116 See accept(2) for more information."
2117 FTH fs, io;
2118 int fd, nd, domain;
2119
2120 FTH_STACK_CHECK(vm, 3, 1);
2121 domain = (int) ficlStackPopInteger(vm->dataStack);
2122 fs = fth_pop_ficl_cell(vm);
2123 fd = (int) ficlStackPopInteger(vm->dataStack);
2124 nd = socket_accept(domain, fd);
2125
2126 if (nd == -1) {
2127 close(fd);
2128 IO_SOCKET_ERROR(accept);
2129 /* NOTREACHED */
2130 return;
2131 }
2132 io = make_socket_io(IO_STRING_REF(fs), -1, -1, nd);
2133 ficlStackPushFTH(vm->dataStack, io);
2134 }
2135
2136 static void
ficl_connect(ficlVm * vm)2137 ficl_connect(ficlVm *vm)
2138 {
2139 #define h_connect "( fd host port domain -- io ) connect to socket\n\
2140 AF_INET SOCK_STREAM net-socket value fd\n\
2141 fd \"localhost\" 1024 AF_INET net-bind\n\
2142 fd \"localhost\" 1024 AF_INET net-connect value io\n\
2143 Connect to a server and return IO object after an established connection. \
2144 FD is the socket descriptor, \
2145 HOST is a host name (AF_INET) or a name (AF_UNIX), \
2146 PORT is the port if DOMAIN is AF_INET, otherwise unused, \
2147 and DOMAIN is one of AF_INET or AF_UNIX. \
2148 This is used on the client side of a socket connection. \
2149 Raise SOCKET-ERROR exception if connect fails.\n\
2150 See connet(2) for more information."
2151 FTH fs, io;
2152 char *host;
2153 int domain, fd, port;
2154
2155 FTH_STACK_CHECK(vm, 4, 1);
2156 domain = (int) ficlStackPopInteger(vm->dataStack);
2157 port = (int) ficlStackPopInteger(vm->dataStack);
2158 fs = fth_pop_ficl_cell(vm);
2159 fd = (int) ficlStackPopInteger(vm->dataStack);
2160 host = IO_STRING_REF(fs);
2161
2162 if (socket_connect(host, port, domain, fd) == -1) {
2163 close(fd);
2164 IO_SOCKET_ERROR_ARG(connect, host);
2165 /* NOTREACHED */
2166 return;
2167 }
2168 io = make_socket_io(host, -1, -1, fd);
2169 ficlStackPushFTH(vm->dataStack, io);
2170 }
2171
2172 static void
ficl_send(ficlVm * vm)2173 ficl_send(ficlVm *vm)
2174 {
2175 #define h_send "( fd msg flags -- ) send data\n\
2176 fd \"data message\" 0 net-send\n\
2177 Send data via a socket. \
2178 FD is the socket descriptor, \
2179 MSG is the data to send \
2180 and FLAGS can be 0, MSG_PEEK or MSG_OOB. \
2181 Raise SOCKET-ERROR exception if send fails.\n\
2182 See send(2) for more information."
2183 int fd, flags;
2184 size_t size;
2185 FTH msg;
2186 char *text;
2187
2188 FTH_STACK_CHECK(vm, 3, 0);
2189 flags = (int) ficlStackPopInteger(vm->dataStack);
2190 msg = fth_pop_ficl_cell(vm);
2191 fd = (int) ficlStackPopInteger(vm->dataStack);
2192 size = (size_t) fth_string_length(msg);
2193 text = IO_STRING_REF(msg);
2194
2195 if (send(fd, text, size, flags) == -1)
2196 IO_SOCKET_ERROR_ARG(send, text);
2197 }
2198
2199 static void
ficl_recv(ficlVm * vm)2200 ficl_recv(ficlVm *vm)
2201 {
2202 #define h_recv "( fd flags -- msg ) receive data\n\
2203 fd 0 net-recv => \"data message ...\"\n\
2204 Receive data via a socket and return it. \
2205 FD is the socket descriptor \
2206 and FLAGS can be 0, MSG_PEEK, or MSG_OOB. \
2207 Raise SOCKET-ERROR exception if recv fails.\n\
2208 See recv(2) for more information."
2209 FTH fs;
2210 int fd, flags;
2211 ssize_t len;
2212
2213 FTH_STACK_CHECK(vm, 2, 1);
2214 flags = (int) ficlStackPopInteger(vm->dataStack);
2215 fd = (int) ficlStackPopInteger(vm->dataStack);
2216 len = recv(fd, vm->pad, sizeof(vm->pad), flags);
2217
2218 if (len == -1) {
2219 IO_SOCKET_ERROR(recv);
2220 /* NOTREACHED */
2221 return;
2222 }
2223 fs = fth_make_string_len(vm->pad, (ficlInteger) len);
2224 ficlStackPushFTH(vm->dataStack, fs);
2225 }
2226
2227 static void
ficl_sendto(ficlVm * vm)2228 ficl_sendto(ficlVm *vm)
2229 {
2230 #define h_sendto "( fd msg flags host port domain -- ) send data\n\
2231 fd \"data message\" \"localhost\" 1024 AF_INET net-sendto\n\
2232 Send data via a socket. \
2233 FD is the socket descriptor, \
2234 MSG is the data to send, \
2235 FLAGS can be 0, MSG_PEEK, or MSG_OOB. \
2236 HOST is a host name (AF_INET) or a name (AF_UNIX), \
2237 PORT is the port if DOMAIN is AF_INET, otherwise unused, \
2238 and DOMAIN is one of AF_INET or AF_UNIX. \
2239 Raise SOCKET-ERROR exception if sendto fails.\n\
2240 See sendto(2) for more information."
2241 FTH fhost, fmsg;
2242 int fd, flags, domain;
2243 char *host, *msg;
2244 ficlUnsigned16 port;
2245 struct sockaddr *addr;
2246 socklen_t len = 0;
2247
2248 FTH_STACK_CHECK(vm, 6, 0);
2249 domain = (int) ficlStackPopInteger(vm->dataStack);
2250 port = (ficlUnsigned16) ficlStackPopUnsigned(vm->dataStack);
2251 fhost = fth_pop_ficl_cell(vm);
2252 flags = (int) ficlStackPopInteger(vm->dataStack);
2253 fmsg = fth_pop_ficl_cell(vm);
2254 fd = (int) ficlStackPopInteger(vm->dataStack);
2255 host = IO_STRING_REF(fhost);
2256 msg = IO_STRING_REF(fmsg);
2257 IO_SOCKADDR(addr, host, port, domain, len);
2258
2259 if (sendto(fd, msg, fth_strlen(msg), flags, addr, len) == -1)
2260 IO_SOCKET_ERROR_ARG(sendto, host);
2261 }
2262
2263 static void
ficl_recvfrom(ficlVm * vm)2264 ficl_recvfrom(ficlVm *vm)
2265 {
2266 #define h_recvfrom "( fd flags host port domain -- msg ) receive data\n\
2267 fd 0 \"localhost\" 1024 AF_INET net-recvfrom => \"data message\"\n\
2268 Receive data via a socket and return it. \
2269 FD is the socket descriptor, \
2270 FLAGS can be 0, MSG_PEEK, or MSG_OOB. \
2271 HOST is a host name (AF_INET) or a path name (AF_UNIX), \
2272 PORT is the port if DOMAIN is AF_INET, otherwise unused, \
2273 and DOMAIN is one of AF_INET or AF_UNIX. \
2274 Raise SOCKET-ERROR exception if recvfrom fails.\n\
2275 See recvfrom(2) for more information."
2276 FTH fhost, fs;
2277 int fd, flags, domain;
2278 ficlUnsigned16 port;
2279 char *host;
2280 struct sockaddr *addr;
2281 socklen_t len = 0;
2282
2283 FTH_STACK_CHECK(vm, 5, 1);
2284 domain = (int) ficlStackPopInteger(vm->dataStack);
2285 port = (ficlUnsigned16) ficlStackPopUnsigned(vm->dataStack);
2286 fhost = fth_pop_ficl_cell(vm);
2287 flags = (int) ficlStackPopInteger(vm->dataStack);
2288 fd = (int) ficlStackPopInteger(vm->dataStack);
2289 host = IO_STRING_REF(fhost);
2290 IO_SOCKADDR(addr, host, port, domain, len);
2291
2292 if (recvfrom(fd, vm->pad, sizeof(vm->pad), flags, addr, &len) == -1) {
2293 IO_SOCKET_ERROR_ARG(recvfrom, host);
2294 /* NOTREACHED */
2295 return;
2296 }
2297 fs = fth_make_string_len(vm->pad, (ficlInteger) len);
2298 ficlStackPushFTH(vm->dataStack, fs);
2299 }
2300
2301 #endif /* HAVE_SOCKET */
2302
2303 static int fth_exit_status = 0;
2304
2305 int
fth_set_exit_status(int status)2306 fth_set_exit_status(int status)
2307 {
2308 if (WIFEXITED(status))
2309 fth_exit_status = (int) WEXITSTATUS(status);
2310 else
2311 fth_exit_status = -1;
2312
2313 return (fth_exit_status);
2314 }
2315
2316 static void
ficl_exit_status(ficlVm * vm)2317 ficl_exit_status(ficlVm *vm)
2318 {
2319 #define h_exit_status "( -- n ) return exit-status\n\
2320 \"ls -lAF\" file-system drop\n\
2321 exit-status => 0\n\
2322 \"lx\" file-system drop\n\
2323 exit-status => 127\n\
2324 Return exit status of last extern process \
2325 called via file-shell, file-system, etc."
2326 ficlStackPushInteger(vm->dataStack, (ficlInteger) fth_exit_status);
2327 }
2328
2329 void
fth_io_close(FTH io)2330 fth_io_close(FTH io)
2331 {
2332 if (FTH_NOT_FALSE_P(io) && FTH_IO_P(io)) {
2333 if (!FTH_IO_CLOSED_P(io))
2334 FTH_IO_CLOSE(io);
2335
2336 FTH_IO_CLOSED_P(io) = 1;
2337 return;
2338 }
2339 IO_ASSERT_IO(io);
2340 }
2341
2342 static void
ficl_io_close(ficlVm * vm)2343 ficl_io_close(ficlVm *vm)
2344 {
2345 #define h_io_close "( io -- ) close IO\n\
2346 \"test\" io-open value io\n\
2347 io io-close\n\
2348 If necessary, flush IO, close IO object and set closed? to #t."
2349 FTH_STACK_CHECK(vm, 1, 0);
2350 fth_io_close(fth_pop_ficl_cell(vm));
2351 }
2352
2353 static void
ficl_print_io(ficlVm * vm)2354 ficl_print_io(ficlVm *vm)
2355 {
2356 #define h_print_io "( io -- ) print IO object\n\
2357 \"test\" io-open value io\n\
2358 io .io => #<io[0]: \"test\", file-input>\n\
2359 Print IO object to current output."
2360 FTH io;
2361
2362 FTH_STACK_CHECK(vm, 1, 0);
2363 io = fth_pop_ficl_cell(vm);
2364 IO_ASSERT_IO(io);
2365 fth_print(fth_string_ref(io_to_string(io)));
2366 }
2367
2368 int
fth_io_equal_p(FTH obj1,FTH obj2)2369 fth_io_equal_p(FTH obj1, FTH obj2)
2370 {
2371 if (!FTH_IO_P(obj1) || !FTH_IO_P(obj2))
2372 return (0);
2373
2374 return (FTH_TO_BOOL(io_equal_p(obj1, obj2)));
2375 }
2376
2377 static void
ficl_io_equal_p(ficlVm * vm)2378 ficl_io_equal_p(ficlVm *vm)
2379 {
2380 #define h_io_equal_p "( obj1 obj2 -- f ) compare OBJ1 with OBJ2\n\
2381 \"test\" io-open value io1\n\
2382 \"test\" io-open value io2\n\
2383 \"foo\" io-open value io3\n\
2384 io1 io1 io= => #t\n\
2385 io1 io2 io= => #t\n\
2386 io1 io3 io= => #f\n\
2387 Return #t if OBJ1 and OBJ2 are IO objects with equal filenames, \
2388 modes and file positions, otherwise #f."
2389 FTH obj1, obj2;
2390
2391 FTH_STACK_CHECK(vm, 2, 1);
2392 obj2 = fth_pop_ficl_cell(vm);
2393 obj1 = fth_pop_ficl_cell(vm);
2394 ficlStackPushBoolean(vm->dataStack, fth_io_equal_p(obj1, obj2));
2395 }
2396
2397 int
fth_io_getc(FTH io)2398 fth_io_getc(FTH io)
2399 {
2400 IO_ASSERT_IO_INPUT(io);
2401 return (FTH_IO_READ_CHAR(io));
2402 }
2403
2404 static void
ficl_io_getc(ficlVm * vm)2405 ficl_io_getc(ficlVm *vm)
2406 {
2407 #define h_io_getc "( io -- c|#f ) return next character from IO\n\
2408 \"test\" io-open value io\n\
2409 io io-getc => 104\n\
2410 io io-getc => 101\n\
2411 io io-close\n\
2412 Return next character from IO object or #f if EOF.\n\
2413 See also io-read."
2414 FTH io;
2415 int c;
2416
2417 FTH_STACK_CHECK(vm, 1, 1);
2418 io = fth_pop_ficl_cell(vm);
2419 c = fth_io_getc(io);
2420 fth_push_ficl_cell(vm, (c == EOF) ? FTH_FALSE : CHAR_TO_FTH(c));
2421 }
2422
2423 void
fth_io_putc(FTH io,int c)2424 fth_io_putc(FTH io, int c)
2425 {
2426 IO_ASSERT_IO_OUTPUT(io);
2427 FTH_IO_WRITE_CHAR(io, c);
2428 FTH_INSTANCE_CHANGED(io);
2429 }
2430
2431 static void
ficl_io_putc(ficlVm * vm)2432 ficl_io_putc(ficlVm *vm)
2433 {
2434 #define h_io_putc "( io c -- ) write character C to IO\n\
2435 \"test\" io-open-write value io\n\
2436 io <char> a io-putc\n\
2437 io <char> b io-putc\n\
2438 io <char> c io-putc\n\
2439 io io-close\n\
2440 Write character C to IO object.\n\
2441 See also io-write, io-write-format."
2442 FTH ch, io;
2443
2444 FTH_STACK_CHECK(vm, 2, 0);
2445 ch = fth_pop_ficl_cell(vm);
2446 io = fth_pop_ficl_cell(vm);
2447 FTH_ASSERT_ARGS(FTH_INTEGER_P(ch), ch, FTH_ARG2, "a char");
2448 fth_io_putc(io, FTH_TO_CHAR(ch));
2449 }
2450
2451 char *
fth_io_read(FTH io)2452 fth_io_read(FTH io)
2453 {
2454 IO_ASSERT_IO_INPUT(io);
2455 return (FTH_IO_READ_LINE(io));
2456 }
2457
2458 /* For object-apply. */
2459 FTH
fth_io_read_line(FTH io)2460 fth_io_read_line(FTH io)
2461 {
2462 #define h_io_read "( io -- line|#f ) read next line from IO\n\
2463 \"test\" io-open value io\n\
2464 io io-read => \"content of entire line\"\n\
2465 io io-close\n\
2466 Return next line from IO object or #f if EOF.\n\
2467 See also io-getc."
2468 char *line;
2469
2470 line = fth_io_read(io);
2471
2472 if (line == NULL)
2473 return (FTH_FALSE);
2474
2475 return (fth_make_string(line));
2476 }
2477
2478 void
fth_io_write(FTH io,const char * line)2479 fth_io_write(FTH io, const char *line)
2480 {
2481 IO_ASSERT_IO_OUTPUT(io);
2482 FTH_IO_WRITE_LINE(io, line);
2483 FTH_INSTANCE_CHANGED(io);
2484 }
2485
2486 void
fth_io_write_and_flush(FTH io,const char * line)2487 fth_io_write_and_flush(FTH io, const char *line)
2488 {
2489 fth_io_write(io, line);
2490 FTH_IO_FLUSH(io);
2491 }
2492
2493 static void
ficl_io_write(ficlVm * vm)2494 ficl_io_write(ficlVm *vm)
2495 {
2496 #define h_io_write "( io line -- ) write LINE to IO\n\
2497 \"test\" io-open-write value io\n\
2498 io \"content of entire line\" io-write\n\
2499 io io-close\n\
2500 Write LINE to IO object.\n\
2501 See also io-putc, io-write-format."
2502 FTH io, fs;
2503
2504 FTH_STACK_CHECK(vm, 2, 0);
2505 fs = fth_pop_ficl_cell(vm);
2506 io = fth_pop_ficl_cell(vm);
2507 fth_io_write(io, IO_STRING_REF(fs));
2508 }
2509
2510 void
fth_io_write_format(FTH io,FTH fmt,FTH args)2511 fth_io_write_format(FTH io, FTH fmt, FTH args)
2512 {
2513 fth_io_write(io, IO_STRING_REF(fth_string_format(fmt, args)));
2514 }
2515
2516 static void
ficl_io_write_format(ficlVm * vm)2517 ficl_io_write_format(ficlVm *vm)
2518 {
2519 #define h_io_write_format "( io fmt fmt-args -- ) write formatted line\n\
2520 \"test\" io-open-write value io\n\
2521 io \"%d %d + .\\n\" #( 10 20 ) io-write-format\n\
2522 io \"%d %d + .\\n\" #( 10 20 ) string-format io-write\n\
2523 io io-close\n\
2524 Write string built from FMT and array FMT-ARGS to IO object.\n\
2525 See also io-putc, io-write."
2526 FTH io, fmt, args;
2527
2528 FTH_STACK_CHECK(vm, 3, 0);
2529 args = fth_pop_ficl_cell(vm);
2530 fmt = fth_pop_ficl_cell(vm);
2531 io = fth_pop_ficl_cell(vm);
2532 fth_io_write_format(io, fmt, args);
2533 }
2534
2535 FTH
fth_io_readlines(FTH io)2536 fth_io_readlines(FTH io)
2537 {
2538 #define h_io_rlns "( io -- array-of-lines ) return content as array\n\
2539 \"test\" io-open value io\n\
2540 io io-readlines => #( \"1st line\\n\" \"2nd line\\n\" ...)\n\
2541 io io-close\n\
2542 Return the entire IO object content as an array of strings, line by line.\n\
2543 See also io-getc, io-read."
2544 FTH array;
2545 char *line;
2546 ficl2Integer pos;
2547
2548 IO_ASSERT_IO_NOT_CLOSED(io);
2549 array = fth_make_empty_array();
2550 pos = FTH_IO_TELL(io);
2551 FTH_IO_REWIND(io);
2552
2553 while ((line = FTH_IO_READ_LINE(io)) != NULL)
2554 fth_array_push(array, fth_make_string(line));
2555
2556 FTH_IO_SEEK(io, pos, SEEK_SET);
2557 return (array);
2558 }
2559
2560 void
fth_io_writelines(FTH io,FTH array)2561 fth_io_writelines(FTH io, FTH array)
2562 {
2563 #define h_io_wlns "( io array-of-lines -- ) write array of strings\n\
2564 \"test\" io-open-write value io\n\
2565 io #( \"1st line\\n\" \"2nd line\\n\" ...) io-writelines\n\
2566 io io-close\n\
2567 Write ARRAY-OF-LINES to IO object.\n\
2568 See also io-putc, io-write, io-write-format."
2569 FTH fs;
2570 ficlInteger i, len;
2571 ficl2Integer pos;
2572
2573 IO_ASSERT_IO_OUTPUT(io);
2574 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG2, "an array");
2575 pos = FTH_IO_TELL(io);
2576 FTH_IO_REWIND(io);
2577 len = fth_array_length(array);
2578
2579 for (i = 0; i < len; i++) {
2580 fs = fth_array_fast_ref(array, i);
2581 FTH_IO_WRITE_LINE(io, IO_STRING_REF(fs));
2582 }
2583
2584 FTH_INSTANCE_CHANGED(io);
2585 FTH_IO_SEEK(io, pos, SEEK_SET);
2586 }
2587
2588 int
fth_io_eof_p(FTH io)2589 fth_io_eof_p(FTH io)
2590 {
2591 IO_ASSERT_IO(io);
2592 return (FTH_IO_EOF_P(io));
2593 }
2594
2595 static void
ficl_io_eof_p(ficlVm * vm)2596 ficl_io_eof_p(ficlVm *vm)
2597 {
2598 #define h_io_eof_p "( io -- f ) test if IO reached EOF\n\
2599 \"test\" io-open value io\n\
2600 io io-eof? => #f\n\
2601 io io-readlines => #( \"1st line\\n\" \"2nd line\\n\" ...)\n\
2602 io io-eof? => #t\n\
2603 io io-close\n\
2604 Return #t if EOF is reached, otherwise #f."
2605 FTH io;
2606 int flag;
2607
2608 FTH_STACK_CHECK(vm, 1, 1);
2609 io = fth_pop_ficl_cell(vm);
2610 flag = fth_io_eof_p(io);
2611 ficlStackPushBoolean(vm->dataStack, flag);
2612 }
2613
2614 char *
fth_io_filename(FTH io)2615 fth_io_filename(FTH io)
2616 {
2617 IO_ASSERT_IO(io);
2618 return (IO_STRING_REF(FTH_IO_FILENAME(io)));
2619 }
2620
2621 void *
fth_io_ptr(FTH io)2622 fth_io_ptr(FTH io)
2623 {
2624 IO_ASSERT_IO(io);
2625 return (FTH_IO_DATA(io));
2626 }
2627
2628 int
fth_io_mode(FTH io)2629 fth_io_mode(FTH io)
2630 {
2631 IO_ASSERT_IO(io);
2632 return (FTH_IO_FAM(io));
2633 }
2634
2635 int
fth_io_fileno(FTH io)2636 fth_io_fileno(FTH io)
2637 {
2638 IO_ASSERT_IO(io);
2639
2640 switch (FTH_IO_TYPE(io)) {
2641 case FTH_IO_FILE:
2642 case FTH_IO_PIPE:
2643 return (fileno((FILE *) FTH_IO_DATA(io)));
2644 break;
2645 case FTH_IO_SOCKET:
2646 return (FTH_IO_SOCKET_FD(FTH_IO_DATA(io)));
2647 break;
2648 default:
2649 return (-1);
2650 break;
2651 }
2652 }
2653
2654 static int
seek_constant_p(int whence)2655 seek_constant_p(int whence)
2656 {
2657 switch (whence) {
2658 case SEEK_SET:
2659 case SEEK_CUR:
2660 case SEEK_END:
2661 return (1);
2662 break;
2663 }
2664 return (0);
2665 }
2666
2667 static void
ficl_io_seek(ficlVm * vm)2668 ficl_io_seek(ficlVm *vm)
2669 {
2670 #define h_io_seek "( io offset :key whence io-seek-set -- pos ) set pos\n\
2671 \"test\" io-open value io\n\
2672 io 10 io-seek => 10\n\
2673 io 10 :whence SEEK_CUR io-seek => 20\n\
2674 io io-close\n\
2675 Add OFFSET to the file position in IO object and return new position. \
2676 Keyword WHENCE can have the following values:\n\
2677 SEEK_SET -- offset counts from begin of file (default)\n\
2678 SEEK_CUR -- offset counts from current position\n\
2679 SEEK_END -- offset counts from end of file."
2680 FTH io, pos;
2681 int whence;
2682 ficl2Integer where;
2683
2684 whence = fth_get_optkey_fix(FTH_KEYWORD_WHENCE, SEEK_SET);
2685 FTH_STACK_CHECK(vm, 2, 1);
2686 pos = fth_pop_ficl_cell(vm);
2687 io = fth_pop_ficl_cell(vm);
2688 IO_ASSERT_IO(io);
2689 FTH_ASSERT_ARGS(FTH_INTEGER_P(pos), pos, FTH_ARG2, "an integer");
2690 FTH_ASSERT_ARGS(seek_constant_p(whence), INT_TO_FIX(whence), FTH_ARG3,
2691 "one of SEEK_SET, SEEK_CUR, SEEK_END");
2692 where = FTH_IO_SEEK(io, fth_long_long_ref(pos), whence);
2693 ficlStackPush2Integer(vm->dataStack, where);
2694 }
2695
2696 ficl2Integer
fth_io_pos_ref(FTH io)2697 fth_io_pos_ref(FTH io)
2698 {
2699 IO_ASSERT_IO(io);
2700 return (FTH_IO_TELL(io));
2701 }
2702
2703 static void
ficl_io_pos_ref(ficlVm * vm)2704 ficl_io_pos_ref(ficlVm *vm)
2705 {
2706 #define h_io_pos_ref "( io -- pos ) return file position\n\
2707 \"test\" io-open value io\n\
2708 io io-pos-ref => 0\n\
2709 io io-close\n\
2710 Return current IO object position.\n\
2711 See also io-pos-set!, io-seek and io-rewind."
2712 FTH io;
2713 ficl2Integer pos;
2714
2715 FTH_STACK_CHECK(vm, 1, 1);
2716 io = fth_pop_ficl_cell(vm);
2717 pos = fth_io_pos_ref(io);
2718 ficlStackPush2Integer(vm->dataStack, pos);
2719 }
2720
2721 void
fth_io_pos_set(FTH io,ficl2Integer pos)2722 fth_io_pos_set(FTH io, ficl2Integer pos)
2723 {
2724 IO_ASSERT_IO(io);
2725 FTH_IO_SEEK(io, pos, SEEK_SET);
2726 }
2727
2728 static void
ficl_io_pos_set(ficlVm * vm)2729 ficl_io_pos_set(ficlVm *vm)
2730 {
2731 #define h_io_pos_set "( io pos -- ) set file position\n\
2732 \"test\" io-open value io\n\
2733 io 10 io-pos-set!\n\
2734 io io-close\n\
2735 Set IO object position to POS.\n\
2736 See also io-pos-ref, io-seek and io-rewind."
2737 FTH io;
2738 ficl2Integer pos;
2739
2740 FTH_STACK_CHECK(vm, 2, 0);
2741 pos = ficlStackPop2Integer(vm->dataStack);
2742 io = fth_pop_ficl_cell(vm);
2743 fth_io_pos_set(io, pos);
2744 }
2745
2746 void
fth_io_rewind(FTH io)2747 fth_io_rewind(FTH io)
2748 {
2749 IO_ASSERT_IO(io);
2750 FTH_IO_REWIND(io);
2751 }
2752
2753 static void
ficl_io_rewind(ficlVm * vm)2754 ficl_io_rewind(ficlVm *vm)
2755 {
2756 #define h_io_rewind "( io -- ) set file position to 0\n\
2757 \"test\" io-open value io\n\
2758 io io-readlines => #( \"...\" ...)\n\
2759 io io-rewind\n\
2760 io io-pos-ref => 0\n\
2761 io io-close\n\
2762 Rewind position to begin of IO object.\n\
2763 See also io-pos-ref, io-pos-set!, io-seek."
2764 FTH io;
2765
2766 FTH_STACK_CHECK(vm, 1, 0);
2767 io = fth_pop_ficl_cell(vm);
2768 fth_io_rewind(io);
2769 }
2770
2771 FTH
fth_readlines(const char * name)2772 fth_readlines(const char *name)
2773 {
2774 FTH io, array;
2775
2776 io = fth_io_open(name, FICL_FAM_READ);
2777 array = fth_io_readlines(io);
2778 fth_io_close(io);
2779 return (array);
2780 }
2781
2782 static void
ficl_readlines(ficlVm * vm)2783 ficl_readlines(ficlVm *vm)
2784 {
2785 #define h_readlines "( fname -- array-of-lines ) content as array\n\
2786 \"test\" readlines => #( \"1st line\\n\" \"2nd line\\n\" ...)\n\
2787 Open file FNAME, read its content in an array, \
2788 close file and return the array."
2789 FTH fs, array;
2790
2791 FTH_STACK_CHECK(vm, 1, 1);
2792 fs = fth_pop_ficl_cell(vm);
2793 array = fth_readlines(IO_STRING_REF(fs));
2794 ficlStackPushFTH(vm->dataStack, array);
2795 }
2796
2797 void
fth_writelines(const char * name,FTH array)2798 fth_writelines(const char *name, FTH array)
2799 {
2800 FTH io;
2801
2802 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG2, "an array");
2803 io = fth_io_open(name, FICL_FAM_WRITE);
2804 fth_io_writelines(io, array);
2805 fth_io_close(io);
2806 }
2807
2808 static void
ficl_writelines(ficlVm * vm)2809 ficl_writelines(ficlVm *vm)
2810 {
2811 #define h_writelines "( fname array-of-lines -- ) write array\n\
2812 \"test\" #( \"1st line\\n\" \"2nd line\\n\" ) writelines\n\
2813 Open file FNAME, write the content of ARRAY-OF-LINES to it and close file."
2814 FTH array, fs;
2815
2816 FTH_STACK_CHECK(vm, 2, 1);
2817 array = fth_pop_ficl_cell(vm);
2818 fs = fth_pop_ficl_cell(vm);
2819 fth_writelines(IO_STRING_REF(fs), array);
2820 }
2821
2822 void
fth_io_flush(FTH io)2823 fth_io_flush(FTH io)
2824 {
2825 IO_ASSERT_IO_NOT_CLOSED(io);
2826 FTH_IO_FLUSH(io);
2827 }
2828
2829 static void
ficl_io_flush(ficlVm * vm)2830 ficl_io_flush(ficlVm *vm)
2831 {
2832 #define h_io_flush "( io -- ) flush IO\n\
2833 \"test\" io-open-write value io\n\
2834 io #( \"1st line\\n\" \"2nd line\\n\" ...) io-writelines\n\
2835 io io-flush\n\
2836 io io-close\n\
2837 Flushe IO object if possible."
2838 FTH io;
2839
2840 FTH_STACK_CHECK(vm, 1, 0);
2841 io = fth_pop_ficl_cell(vm);
2842 fth_io_flush(io);
2843 }
2844
2845 FTH
fth_set_io_stdin(FTH io)2846 fth_set_io_stdin(FTH io)
2847 {
2848 FTH old_io;
2849 int fd;
2850
2851 if (!IO_INPUT_P(io))
2852 return (FTH_FALSE);
2853
2854 old_io = FTH_FICL_VM()->callback.port_in;
2855 fd = fileno((FILE *) FTH_IO_DATA(io));
2856 FTH_FICL_VM()->callback.port_in = io;
2857 FTH_FICL_VM()->callback.stdin_ptr = FTH_IO_DATA(io);
2858 FTH_FICL_VM()->callback.stdin_fileno = fd;
2859 return (old_io);
2860 }
2861
2862 FTH
fth_set_io_stdout(FTH io)2863 fth_set_io_stdout(FTH io)
2864 {
2865 FTH old_io;
2866 int fd;
2867
2868 if (!IO_OUTPUT_P(io))
2869 return (FTH_FALSE);
2870
2871 old_io = FTH_FICL_VM()->callback.port_out;
2872 fd = fileno((FILE *) FTH_IO_DATA(io));
2873 FTH_FICL_VM()->callback.port_out = io;
2874 FTH_FICL_VM()->callback.stdout_ptr = FTH_IO_DATA(io);
2875 FTH_FICL_VM()->callback.stdout_fileno = fd;
2876 return (old_io);
2877 }
2878
2879 FTH
fth_set_io_stderr(FTH io)2880 fth_set_io_stderr(FTH io)
2881 {
2882 FTH old_io;
2883 int fd;
2884
2885 if (!IO_OUTPUT_P(io))
2886 return (FTH_FALSE);
2887
2888 old_io = FTH_FICL_VM()->callback.port_err;
2889 fd = fileno((FILE *) FTH_IO_DATA(io));
2890 FTH_FICL_VM()->callback.port_err = io;
2891 FTH_FICL_VM()->callback.stderr_ptr = FTH_IO_DATA(io);
2892 FTH_FICL_VM()->callback.stderr_fileno = fd;
2893 return (old_io);
2894 }
2895
2896 static void
ficl_io_stdin(ficlVm * vm)2897 ficl_io_stdin(ficlVm *vm)
2898 {
2899 #define h_io_stdin "( -- stdin ) return stdin IO\n\
2900 *stdin* #f io-reopen value new-stdin\n\
2901 Return current standard input IO object.\n\
2902 See also set-*stdin*, *stdout*, set-*stdout*, *stderr*, set-*stderr*."
2903 FTH_STACK_CHECK(vm, 0, 1);
2904 fth_push_ficl_cell(vm, vm->callback.port_in);
2905 }
2906
2907 static void
ficl_set_io_stdin(ficlVm * vm)2908 ficl_set_io_stdin(ficlVm *vm)
2909 {
2910 #define h_set_io_stdin "( io -- old ) set stdin to IO\n\
2911 \"input-file\" io-open-read set-*stdin* value old-stdin\n\
2912 Set IO to current standard input and return old IO object.\n\
2913 See also *stdin*, *stdout*, set-*stdout*, *stderr*, set-*stderr*."
2914 FTH io;
2915
2916 FTH_STACK_CHECK(vm, 1, 1);
2917 io = fth_pop_ficl_cell(vm);
2918 fth_push_ficl_cell(vm, fth_set_io_stdin(io));
2919 }
2920
2921 static void
ficl_io_stdout(ficlVm * vm)2922 ficl_io_stdout(ficlVm *vm)
2923 {
2924 #define h_io_stdout "( -- stdout) return stdout IO\n\
2925 *stdout* \"stdout.log\" io-reopen value new-stdout\n\
2926 Return current standard output IO object.\n\
2927 See also *stdin*, set-*stdin*, set-*stdout*, *stderr*, set-*stderr*."
2928 FTH_STACK_CHECK(vm, 0, 1);
2929 fth_push_ficl_cell(vm, vm->callback.port_out);
2930 }
2931
2932 static void
ficl_set_io_stdout(ficlVm * vm)2933 ficl_set_io_stdout(ficlVm *vm)
2934 {
2935 #define h_set_io_stdout "( io -- old ) set stdout to IO\n\
2936 \"stdout.log\" io-open-write set-*stdout* value old-stdout\n\
2937 Set IO to current standard output and return old IO object.\n\
2938 See also *stdin*, set-*stdin*, *stdout*, *stderr*, set-*stderr*."
2939 FTH io;
2940
2941 FTH_STACK_CHECK(vm, 1, 1);
2942 io = fth_pop_ficl_cell(vm);
2943 fth_push_ficl_cell(vm, fth_set_io_stdout(io));
2944 }
2945
2946 static void
ficl_io_stderr(ficlVm * vm)2947 ficl_io_stderr(ficlVm *vm)
2948 {
2949 #define h_io_stderr "( -- stderr ) return stderr IO\n\
2950 *stderr* \"stderr.log\" io-reopen value new-stderr\n\
2951 Return current standard error IO object.\n\
2952 See also *stdin*, set-*stdin*, *stdout*, set-*stdout*, set-*stderr*."
2953 FTH_STACK_CHECK(vm, 0, 1);
2954 fth_push_ficl_cell(vm, vm->callback.port_err);
2955 }
2956
2957 static void
ficl_set_io_stderr(ficlVm * vm)2958 ficl_set_io_stderr(ficlVm *vm)
2959 {
2960 #define h_set_io_stderr "( io -- old ) set stderr to IO\n\
2961 \"error.log\" io-open-write set-*stderr* value old-stderr\n\
2962 Set IO to current standard error and return old IO object.\n\
2963 See also *stdin*, set-*stdin*, *stdout*, set-*stdout*, *stderr*."
2964 FTH io;
2965
2966 FTH_STACK_CHECK(vm, 1, 1);
2967 io = fth_pop_ficl_cell(vm);
2968 fth_push_ficl_cell(vm, fth_set_io_stderr(io));
2969 }
2970
2971 void
init_io_type(void)2972 init_io_type(void)
2973 {
2974 /* init io */
2975 io_tag = make_object_type(FTH_STR_IO, FTH_IO_T);
2976 fth_set_object_inspect(io_tag, io_inspect);
2977 fth_set_object_to_string(io_tag, io_to_string);
2978 fth_set_object_to_array(io_tag, io_to_array);
2979 fth_set_object_value_ref(io_tag, io_ref);
2980 fth_set_object_equal_p(io_tag, io_equal_p);
2981 fth_set_object_length(io_tag, io_length);
2982 fth_set_object_mark(io_tag, io_mark);
2983 fth_set_object_free(io_tag, io_free);
2984 }
2985
2986 void
init_io(void)2987 init_io(void)
2988 {
2989 char *vc;
2990
2991 vc = fth_getenv("VERSION_CONTROL", NULL);
2992 version_control = FTH_UNDEF;
2993
2994 if (vc != NULL) {
2995 if ((strncmp(vc, "t", 1L) == 0) ||
2996 (strncmp(vc, "numbered", 8L) == 0))
2997 version_control = FTH_TRUE;
2998 else if ((strncmp(vc, "nil", 3L) == 0) ||
2999 (strncmp(vc, "existing", 8L) == 0))
3000 version_control = FTH_NIL;
3001 else if ((strncmp(vc, "never", 5L) == 0) ||
3002 (strncmp(vc, "simple", 6L) == 0))
3003 version_control = FTH_FALSE;
3004 else /* "off" || "none" || any */
3005 version_control = FTH_UNDEF;
3006 }
3007
3008 fth_set_object_apply(io_tag, (void *) fth_io_read_line, 0, 0, 0);
3009 version_number_string = fth_gc_permanent(fth_make_string("~[0-9]+~$"));
3010 string_empty = fth_gc_permanent(fth_make_string(""));
3011 string_cr = fth_gc_permanent(fth_make_string("\n"));
3012 string_space = fth_gc_permanent(fth_make_string(" "));
3013
3014 /* io */
3015 fth_set_io_stdin(make_file_io(stdin, "*stdin*", FICL_FAM_READ));
3016 fth_set_io_stdout(make_file_io(stdout, "*stdout*", FICL_FAM_WRITE));
3017 fth_set_io_stderr(make_file_io(stderr, "*stderr*", FICL_FAM_WRITE));
3018 FTH_PRI1("io-filename", ficl_io_filename, h_io_filename);
3019 FTH_PRI1("io-mode", ficl_io_mode, h_io_mode);
3020 FTH_PRI1("io-fileno", ficl_io_fileno, h_io_fileno);
3021 FTH_PROC("io->string", fth_io_to_string, 1, 0, 0, h_io_to_string);
3022 FTH_PRI1("io?", ficl_io_p, h_io_p);
3023 FTH_PRI1("io-input?", ficl_io_input_p, h_io_input_p);
3024 FTH_PRI1("io-output?", ficl_io_output_p, h_io_output_p);
3025 FTH_PRI1("io-closed?", ficl_io_closed_p, h_io_closed_p);
3026 FTH_PRI1("version-control", ficl_version_control, h_version_control);
3027 FTH_PRI1("set-version-control", ficl_set_version_control, h_set_vc);
3028
3029 /* file */
3030 FTH_PRI1("io-open-file", ficl_io_open_file, h_io_open_file);
3031 FTH_PRI1("io-open-input-file", ficl_io_open_input_file, h_io_oi_file);
3032 FTH_PRI1("io-open-output-file", ficl_io_open_output_file, h_io_oo_file);
3033 FTH_PRI1("io-open", ficl_io_open, h_io_open);
3034 FTH_PRI1("make-file-port", ficl_io_open, h_io_open);
3035 FTH_PRI1("io-open-read", ficl_io_open_read, h_io_open_read);
3036 FTH_PRI1("make-file-input-port", ficl_io_open_read, h_io_open_read);
3037 FTH_PRI1("io-open-write", ficl_io_open_write, h_io_open_write);
3038 FTH_PRI1("make-file-output-port", ficl_io_open_write, h_io_open_write);
3039 FTH_PRI1("io-reopen", ficl_io_reopen, h_io_reopen);
3040 FTH_PRI1("io-fdopen", ficl_io_fdopen, h_io_fdopen);
3041
3042 /* pipe */
3043 FTH_PRI1("io-popen", ficl_io_popen, h_io_popen);
3044 FTH_PRI1("make-pipe-port", ficl_io_popen, h_io_popen);
3045 FTH_PRI1("io-popen-read", ficl_io_popen_read, h_io_popen_read);
3046 FTH_PRI1("make-pipe-input-port", ficl_io_popen_read, h_io_popen_read);
3047 FTH_PRI1("io-popen-write", ficl_io_popen_write, h_io_powrite);
3048 FTH_PRI1("make-pipe-output-port", ficl_io_popen_write, h_io_powrite);
3049
3050 /* io-string */
3051 FTH_PRI1("io-sopen", ficl_io_sopen, h_io_sopen);
3052 FTH_PRI1("make-string-port", ficl_io_sopen, h_io_sopen);
3053 FTH_PRI1("io-sopen-read", ficl_io_sopen_read, h_io_soread);
3054 FTH_PRI1("make-string-input-port", ficl_io_sopen_read, h_io_soread);
3055 FTH_PRI1("io-sopen-write", ficl_io_sopen_write, h_io_sowrite);
3056 FTH_PRI1("make-string-output-port", ficl_io_sopen_write, h_io_sowrite);
3057
3058 #if HAVE_SOCKET
3059 /* socket */
3060 FTH_PRI1("io-nopen", ficl_io_nopen, h_io_nopen);
3061 FTH_PRI1("make-socket-port", ficl_io_nopen, h_io_nopen);
3062 FTH_PRI1("net-socket", ficl_socket, h_socket);
3063 FTH_PRI1("net-bind", ficl_bind, h_bind);
3064 FTH_PRI1("net-listen", ficl_listen, h_listen);
3065 FTH_PRI1("net-shutdown", ficl_shutdown, h_shutdown);
3066 FTH_PRI1("net-accept", ficl_accept, h_accept);
3067 FTH_PRI1("net-connect", ficl_connect, h_connect);
3068 FTH_PRI1("net-send", ficl_send, h_send);
3069 FTH_PRI1("net-recv", ficl_recv, h_recv);
3070 FTH_PRI1("net-sendto", ficl_sendto, h_sendto);
3071 FTH_PRI1("net-recvfrom", ficl_recvfrom, h_recvfrom);
3072 FTH_ADD_FEATURE_AND_INFO(FTH_STR_SOCKET, h_list_of_io_socket_functions);
3073 #endif /* HAVE_SOCKET */
3074
3075 /* io words */
3076 FTH_PRI1("io-exit-status", ficl_exit_status, h_exit_status);
3077 FTH_PRI1("exit-status", ficl_exit_status, h_exit_status);
3078 FTH_PRI1("io-close", ficl_io_close, h_io_close);
3079 FTH_PRI1(".io", ficl_print_io, h_print_io);
3080 FTH_PRI1("io=", ficl_io_equal_p, h_io_equal_p);
3081 FTH_PRI1("io-getc", ficl_io_getc, h_io_getc);
3082 FTH_PRI1("io-putc", ficl_io_putc, h_io_putc);
3083 FTH_PROC("io-read", fth_io_read_line, 1, 0, 0, h_io_read);
3084 FTH_PRI1("io-write", ficl_io_write, h_io_write);
3085 FTH_PRI1("io-write-format", ficl_io_write_format, h_io_write_format);
3086 FTH_PROC("io-readlines", fth_io_readlines, 1, 0, 0, h_io_rlns);
3087 FTH_VOID_PROC("io-writelines", fth_io_writelines, 2, 0, 0, h_io_wlns);
3088 FTH_PRI1("io-eof?", ficl_io_eof_p, h_io_eof_p);
3089 FTH_PRI1("io-seek", ficl_io_seek, h_io_seek);
3090 FTH_PRI1("io-tell", ficl_io_pos_ref, h_io_pos_ref);
3091 FTH_PRI1("io-pos-ref", ficl_io_pos_ref, h_io_pos_ref);
3092 FTH_PRI1("io-pos-set!", ficl_io_pos_set, h_io_pos_set);
3093 FTH_PRI1("io-rewind", ficl_io_rewind, h_io_rewind);
3094 FTH_PRI1("readlines", ficl_readlines, h_readlines);
3095 FTH_PRI1("writelines", ficl_writelines, h_writelines);
3096 FTH_PRI1("io-flush", ficl_io_flush, h_io_flush);
3097 FTH_PRI1("*stdin*", ficl_io_stdin, h_io_stdin);
3098 FTH_PRI1("set-*stdin*", ficl_set_io_stdin, h_set_io_stdin);
3099 FTH_PRI1("*stdout*", ficl_io_stdout, h_io_stdout);
3100 FTH_PRI1("set-*stdout*", ficl_set_io_stdout, h_set_io_stdout);
3101 FTH_PRI1("*stderr*", ficl_io_stderr, h_io_stderr);
3102 FTH_PRI1("set-*stderr*", ficl_set_io_stderr, h_set_io_stderr);
3103 FTH_ADD_FEATURE_AND_INFO(FTH_STR_IO, h_list_of_io_functions);
3104
3105 FTH_SET_CONSTANT(SEEK_SET);
3106 FTH_SET_CONSTANT(SEEK_CUR);
3107 FTH_SET_CONSTANT(SEEK_END);
3108 #if defined(AF_UNSPEC)
3109 FTH_SET_CONSTANT(AF_UNSPEC);
3110 #endif
3111 #if defined(AF_LOCAL)
3112 FTH_SET_CONSTANT(AF_LOCAL);
3113 #endif
3114 #if defined(AF_UNIX)
3115 FTH_SET_CONSTANT(AF_UNIX);
3116 #endif
3117 #if defined(AF_INET)
3118 FTH_SET_CONSTANT(AF_INET);
3119 #endif
3120 #if defined(AF_PUP)
3121 FTH_SET_CONSTANT(AF_PUP);
3122 #endif
3123 #if defined(AF_APPLETALK)
3124 FTH_SET_CONSTANT(AF_APPLETALK);
3125 #endif
3126 #if defined(AF_ROUTE)
3127 FTH_SET_CONSTANT(AF_ROUTE);
3128 #endif
3129 #if defined(AF_LINK)
3130 FTH_SET_CONSTANT(AF_LINK);
3131 #endif
3132 #if defined(AF_IPX)
3133 FTH_SET_CONSTANT(AF_IPX);
3134 #endif
3135 #if defined(AF_SIP)
3136 FTH_SET_CONSTANT(AF_SIP);
3137 #endif
3138 #if defined(AF_ISDN)
3139 FTH_SET_CONSTANT(AF_ISDN);
3140 #endif
3141 #if defined(AF_INET6)
3142 FTH_SET_CONSTANT(AF_INET6);
3143 #endif
3144 #if defined(AF_NATM)
3145 FTH_SET_CONSTANT(AF_NATM);
3146 #endif
3147 #if defined(AF_ATM)
3148 FTH_SET_CONSTANT(AF_ATM);
3149 #endif
3150 #if defined(AF_NETGRAPH)
3151 FTH_SET_CONSTANT(AF_NETGRAPH);
3152 #endif
3153 #if defined(AF_MAX)
3154 FTH_SET_CONSTANT(AF_MAX);
3155 #endif
3156 #if defined(SOCK_STREAM)
3157 FTH_SET_CONSTANT(SOCK_STREAM);
3158 #endif
3159 #if defined(SOCK_DGRAM)
3160 FTH_SET_CONSTANT(SOCK_DGRAM);
3161 #endif
3162 #if defined(SOCK_RAW)
3163 FTH_SET_CONSTANT(SOCK_RAW);
3164 #endif
3165 #if defined(SOCK_RDM)
3166 FTH_SET_CONSTANT(SOCK_RDM);
3167 #endif
3168 #if defined(SOCK_SEQPACKET)
3169 FTH_SET_CONSTANT(SOCK_SEQPACKET);
3170 #endif
3171 #if defined(SHUT_RD)
3172 FTH_SET_CONSTANT(SHUT_RD);
3173 #endif
3174 #if defined(SHUT_WR)
3175 FTH_SET_CONSTANT(SHUT_WR);
3176 #endif
3177 #if defined(SHUT_RDWR)
3178 FTH_SET_CONSTANT(SHUT_RDWR);
3179 #endif
3180 #if defined(MSG_PEEK)
3181 FTH_SET_CONSTANT(MSG_PEEK);
3182 #endif
3183 #if defined(MSG_OOB)
3184 FTH_SET_CONSTANT(MSG_OOB);
3185 #endif
3186 }
3187
3188 /*
3189 * io.c ends here
3190 */
3191