1 /* $Id: io.c,v 1.207 2020-11-26 17:15:09 phil Exp $ */
2
3 /*
4 * I/O support for CSNOBOL4
5 *
6 * FINALLY refactored in 2020 (last attempted in 2002, but never debugged)
7 * this file is now an adaptation layer over
8 * I/O Objects (and some nastiness has moved to stdio_obj.c!)
9 *
10 * Still the largest file in the support library, and still has manu
11 * ifdefs. The complexity (and fragility) of the I/O support is
12 * due to a number of factors:
13 *
14 * Assumptions built into the SIL source (both compiler and runtime) e.g.
15 * * compiler insists lines end with a space, appear in designated buffer
16 * * Multiple layers of I/O:
17 * A single disk file or device might be associated with one or more:
18 * + SNOBOL variable associations (w/ record length, unit number)
19 * + FORTRAN unit numbers
20 * + stdio FILE streams
21 * + POSIX file descriptors and/or C runtime system handles/channels
22 * + open file object in system space
23 * * Interactions of (extensive/excessive) I/O options/flags
24 * * Handling file lists.
25 */
26
27 #ifdef HAVE_CONFIG_H
28 #include "config.h"
29 #endif /* HAVE_CONFIG_H defined */
30
31 #include <stdarg.h>
32 #include <stdlib.h> /* before stdio(?) */
33 #include <stdio.h>
34 #include <ctype.h>
35 #ifdef HAVE_UNISTD_H
36 #include <unistd.h> /* ssize_t */
37 #endif
38
39 #include "h.h"
40 #include "units.h"
41 #include "snotypes.h"
42 #include "macros.h"
43 #include "path.h"
44 #include "lib.h"
45 #include "inet.h" /* INET_XXX */
46 #include "libret.h" /* IO_xxx, INC_xxx */
47 #include "str.h"
48 #include "io_obj.h" /* io_obj, FL_xxx */
49 #include "stdio_obj.h" /* stdio_{wrap,obj} */
50 #include "globals.h" /* rflag, lflag */
51 #include "compio_obj.h" /* compio_open */
52
53 /* generated */
54 #include "equ.h" /* for BCDFLD (for X_LOCSP), res.h */
55 #include "res.h" /* needed on VAX/VMS for data.h */
56 #include "data.h" /* for FILENM */
57 #include "proc.h" /* UNDF() */
58
59 #ifdef COMPILER_READLINE /* after proc.h */
60 #undef RETURN
61 #include <readline/readline.h>
62 #include <readline/history.h>
63 #endif /* COMPILER_READLINE */
64
65 #ifndef PRELOAD_FILENAME
66 #define PRELOAD_FILENAME "preload.sno"
67 #endif
68
69 #define ISTTY(FP) ((FP)->iop && ((FP)->iop->flags & FL_TTY))
70
71 /* GOAL: "struct unit" does not leave io.c */
72 struct unit {
73 struct file *curr; /* ptr to current file */
74 /* for rewind; */
75 struct file *head; /* first file in list */
76 io_off_t offset; /* offset in "head" to rewind to */
77 /*
78 * PLB 2020-09-11 keep flags & recl HERE??
79 * would only matter if INPUT/OUTPUT calls allowed lists of files
80 * (like SITBOL)?
81 */
82 };
83
84 /* GOAL: "struct file" does not leave io.c
85 * Represents a named file from the command line, an include file,
86 * INPUT or OUTPUT call (or passed into a DLL)
87 *
88 * Open files are represented by io_obj.
89 */
90 struct file {
91 struct file *next; /* next input file */
92 struct io_obj *iop;
93 int flags; /* XXX per unit?? (need FL_INCLUDE) */
94 char compression; /* compression option (jJzZ) */
95 char complvl; /* '0' thru '9' */
96 /* MUST BE LAST!! */
97 char fname[1];
98 };
99
100 #define MAXFNAME 1024 /* XXX use MAXPATHLEN? POSIX?? */
101 #define MAXOPTS 1024
102
103 static VAR struct unit units[NUNITS]; /* XXX malloc at runtime? */
104 static VAR struct file *includes; /* list of included files */
105 static VAR int finger; /* for io_findunit */
106 static VAR struct file *lib_dirs; /* list of include directories */
107 static VAR struct file *lib_dir_last; /* tail of include directory list */
108
109 /*
110 * private, r/o array of pointers to io_open functions
111 * taking filename, flags, 'r' or 'w'
112 * returning pointers to io_obj
113 */
114 static struct io_obj *(*const io_open_funcs[])(const char *fname,
115 int flags, int rw) =
116 {
117 #ifdef OSDEPIO_OBJ
118 osdepio_open, /* local I/O that can't be wrapped */
119 #endif
120 ptyio_open, /* dummy ptyio_open available */
121 pipeio_open, /* dummy popen available */
122 #ifdef INET_IO
123 inetio_open, /* e.g. winsockets */
124 #endif
125 #ifdef TLS_IO
126 tlsio_open,
127 #endif
128 stdio_open /* LAST! Never returns NOMATCH!! */
129 };
130 #define N_OPEN_FUNCS (sizeof(io_open_funcs)/sizeof(io_open_funcs[0]))
131
132 /* convert to internal (zero based) unit number; */
133 #define INTERN(U) ((U)-1)
134
135 /* check a (zero based) unit number; */
136 #define BADUNIT(U) ((U) < 0 || (U) >= NUNITS)
137
138 /*
139 * take internal (zero-based) unit number; return "struct unit *"
140 * all access to units array hidden, so it can be made sparse
141 */
142 #define FINDUNIT(N) (units + (N))
143
144 struct io_obj nomatch; /* for NOMATCH */
145
146 /****************
147 * io_obj wrappers
148 *
149 * for efficiency, could leave io_ops structs writable (non-const)
150 * and drag up (swizzle?) the superclass method pointer on first use.
151 * BUT, MOST I/O will be thru stdio_ops, which is fully populated.
152 * Currently, only oddball things like pipes, ptys and winsock are layered.
153 */
154
155 /* leaves input in iop->linebuf (expanded as needed) */
156 static ssize_t
ioo_getline(struct io_obj * iop)157 ioo_getline(struct io_obj *iop) {
158 const struct io_ops *op;
159
160 for (op = iop->ops; op; op = op->io_super)
161 if (op->io_getline)
162 return (op->io_getline)(iop);
163
164 return -1;
165 }
166
167 static ssize_t
ioo_read_raw(struct io_obj * iop,char * buf,size_t len)168 ioo_read_raw(struct io_obj *iop, char *buf, size_t len) {
169 const struct io_ops *op;
170
171 for (op = iop->ops; op; op = op->io_super)
172 if (op->io_read_raw)
173 return (op->io_read_raw)(iop, buf, len);
174
175 return -1;
176 }
177
178 static ssize_t
ioo_write(struct io_obj * iop,const char * buf,size_t len)179 ioo_write(struct io_obj *iop, const char *buf, size_t len) {
180 const struct io_ops *op;
181
182 if (!iop)
183 return -1;
184
185 for (op = iop->ops; op; op = op->io_super)
186 if (op->io_write)
187 return (op->io_write)(iop, buf, len);
188
189 return -1;
190 }
191
192 static int
ioo_flush(struct io_obj * iop)193 ioo_flush(struct io_obj *iop) {
194 const struct io_ops *op;
195 for (op = iop->ops; op; op = op->io_super)
196 if (op->io_flush)
197 return (op->io_flush)(iop);
198
199 return FALSE;
200 }
201
202 static int
ioo_seeko(struct io_obj * iop,io_off_t off,int whence)203 ioo_seeko(struct io_obj *iop, io_off_t off, int whence) {
204 const struct io_ops *op;
205
206 for (op = iop->ops; op; op = op->io_super)
207 if (op->io_seeko)
208 return (op->io_seeko)(iop, off, whence);
209
210 /* in case not implemented: the expected response */
211 return FALSE;
212 }
213
214 static io_off_t
ioo_tello(struct io_obj * iop)215 ioo_tello(struct io_obj *iop) {
216 const struct io_ops *op;
217
218 for (op = iop->ops; op; op = op->io_super)
219 if (op->io_tello)
220 return (op->io_tello)(iop);
221
222 /* in case not implemented: the expected response */
223 return -1;
224 }
225
226 static int
ioo_eof(struct io_obj * iop)227 ioo_eof(struct io_obj *iop) {
228 const struct io_ops *op;
229
230 for (op = iop->ops; op; op = op->io_super)
231 if (op->io_eof)
232 return (op->io_eof)(iop);
233
234 return FALSE; /* treat as non-EOF I/O error */
235 }
236
237 int
ioo_close(struct io_obj * iop)238 ioo_close(struct io_obj *iop) {
239 const struct io_ops *op;
240 int ret = TRUE;
241
242 if (!iop)
243 return FALSE;
244
245 for (op = iop->ops; op; op = op->io_super) {
246 if (op->io_close) {
247 ret = (op->io_close)(iop);
248 break;
249 }
250 }
251 if (iop->linebuf)
252 free(iop->linebuf);
253 free(iop);
254 return ret;
255 }
256
257 /* internal helper; take internal unit, return struct file *, or NULL */
258 static struct file *
findfile(int iunit)259 findfile(int iunit) {
260 struct unit *up;
261
262 if (BADUNIT(iunit))
263 return NULL;
264
265 up = FINDUNIT(iunit);
266 return up->curr; /* may be NULL */
267 }
268
269 /*
270 * this is the ONE place that allocates a "struct file"
271 * path is saved at the end of the struct
272 * (so only one free(fp) is needed)
273 */
274 static struct file *
io_newfile(const char * path)275 io_newfile(const char *path) {
276 struct file *fp;
277
278 fp = (struct file *) malloc( sizeof( struct file ) + strlen(path) );
279 if (fp == NULL)
280 return NULL;
281
282 bzero( (char *)fp, sizeof (struct file) );
283 strcpy(fp->fname,path);
284 return fp;
285 }
286
287 #ifdef SHARED
288 static struct file *
io_memfile(const char * name,char * data,int len,int dir)289 io_memfile(const char *name, char *data, int len, int dir) {
290 struct file *fp;
291
292 fp = io_newfile(name);
293 if (!fp)
294 return NULL;
295
296 fp->iop = memio_open(data, len, 0, dir);
297 if (!fp->iop) {
298 free(fp);
299 return NULL;
300 }
301 fp->iop->fname = fp->fname; /* "borrowed" */
302 return fp;
303 }
304 #endif /* SHARED defined */
305
306 void
io_initvars(void)307 io_initvars(void) {
308 /* XXX cleanup here? */
309 }
310
311 /* add file to input list */
312 /* calls made here BEFORE io_init() called! */
313 static int
io_addfile(int unit,struct file * fp,int append)314 io_addfile(int unit, struct file *fp, int append) {
315 /* XXX check for commas in path? */
316 struct unit *up;
317
318 io_initvars();
319
320 /* XXX allocate units array here? */
321
322 up = FINDUNIT(unit);
323 if (append) { /* add to end of list */
324 struct file *tp;
325
326 tp = up->curr;
327 if (tp == NULL) {
328 up->head = up->curr = fp;
329 up->offset = 0;
330 }
331 else {
332 while (tp->next)
333 tp = tp->next;
334 tp->next = fp;
335 }
336 }
337 else { /* prepend (ie; for "include") */
338 fp->next = up->curr;
339 up->head = up->curr = fp;
340 up->offset = 0;
341 }
342 return TRUE;
343 } /* io_addfile */
344
345 /* close currently open file on a unit */
346 /* XXX take flag: to free struct file, or not? */
347 static int
io_close(int unit)348 io_close(int unit) { /* internal (zero-based unit) */
349 struct file *fp;
350 struct unit *up;
351 int ret = TRUE;
352
353 up = FINDUNIT(unit);
354 fp = up->curr;
355 if (fp == NULL)
356 return TRUE;
357
358 if (fp->iop) {
359 ret = ioo_close(fp->iop);
360 fp->iop = NULL;
361 }
362 up->curr = fp->next;
363 if (fp->flags & FL_INCLUDE)
364 free(fp);
365 return ret;
366 } /* io_close */
367
368 /* close a unit, flush current file list */
369 EXPORT(int)
io_closeall(int unit)370 io_closeall(int unit) { /* internal (zero-based unit) */
371 struct file *fp, *next;
372 struct unit *up;
373 int ret;
374
375 /* close any/all open files on chain */
376 ret = TRUE;
377 up = FINDUNIT(unit);
378 while (up->curr != NULL)
379 if (!io_close(unit))
380 ret = FALSE;
381
382 /* free up all file structs */
383 fp = up->head;
384 while (fp != NULL) {
385 next = fp->next;
386 free(fp);
387 fp = next;
388 }
389 up->curr = up->head = NULL;
390
391 return ret;
392 }
393
394 static struct io_obj *
io_fopen(struct file * fp,int dir)395 io_fopen(struct file *fp,
396 int dir) { /* 'r' or 'w' */
397 unsigned int i;
398 int flags = fp->flags;
399
400 if (fp->compression) {
401 #ifdef USE_COMPIO
402 flags |= FL_BINARY; /* force binary I/O on underlying file */
403 #else
404 return NULL;
405 #endif
406 }
407
408 for (i = 0; i < N_OPEN_FUNCS; i++) {
409 struct io_obj *iop = (io_open_funcs[i])(fp->fname, flags, dir);
410 if (iop == NOMATCH)
411 continue;
412 #ifdef USE_COMPIO
413 if (iop && fp->compression) {
414 struct io_obj *ciop =
415 compio_open(iop, fp->flags, fp->compression, fp->complvl, dir);
416 if (!ciop) {
417 ioo_close(iop);
418 return NULL;
419 }
420 iop->fname = fp->fname; /* borrow pointer (in case) */
421 iop = ciop;
422 }
423 #endif
424 fp->iop = iop;
425 if (iop)
426 iop->fname = fp->fname; /* borrow pointer */
427 return fp->iop;
428 }
429 /* should not happen: stdio should never return NOMATCH */
430 fp->iop = NULL;
431 return NULL;
432 } /* io_fopen */
433
434 /* skip to next input file */
435 static int
io_next(int unit)436 io_next(int unit) { /* internal (zero-based unit) */
437 struct file *fp;
438 struct unit *up;
439
440 up = FINDUNIT(unit);
441 fp = up->curr;
442 if (fp == NULL)
443 return FALSE;
444
445 /* in case called preemptively! */
446 if (fp->iop != NULL)
447 io_close(unit); /* close, and advance */
448
449 /* get new current file (io_close advances to next file in list) */
450 fp = up->curr;
451 if (fp == NULL)
452 return FALSE;
453
454 if (fp->iop != NULL) /* already open? */
455 return TRUE;
456
457 /* XXX let io_read() do the work??? */
458 /* XXX copy flags from previous file? */
459 io_fopen( fp, 'r');
460
461 return fp->iop != NULL;
462 } /* io_next */
463
464
465 /* skip to next file, for external use, takes external unit */
466 EXPORT(int)
io_skip(int unit)467 io_skip(int unit) {
468 return io_next(INTERN(unit));
469 }
470
471 /* here with filename from command line */
472 EXPORT(void)
io_input_file(const char * path)473 io_input_file(const char *path) {
474 struct file *fp;
475
476 fp = io_newfile(path);
477 if (fp == NULL)
478 return;
479
480 io_addfile( INTERN(UNITI), fp, TRUE ); /* append to list! */
481 }
482
483 #ifdef SHARED
484 EXPORT(void)
io_input_string(const char * name,char * str)485 io_input_string(const char *name, char *str) {
486 struct file *fp;
487
488 fp = io_memfile(name, str, strlen(str), 'r');
489 if (fp == NULL)
490 return;
491
492 io_addfile( INTERN(UNITI), fp, TRUE ); /* append to list! */
493 }
494 #endif /* SHARED defined */
495
496 /* attach a "struct file" to a unit (external) */
497 static void
io_setfile(int unit,struct file * fp)498 io_setfile(int unit, struct file *fp) {
499 struct unit *up;
500
501 unit = INTERN(unit);
502 io_closeall(unit); /* close unit */
503
504 up = FINDUNIT(unit);
505 up->head = up->curr = fp;
506 up->offset = 0;
507 }
508
509 /* setup a unit given an open stdio stream and a "filename" */
510 static int
io_mkfile2(int unit,FILE * f,const char * fname,int flags)511 io_mkfile2(int unit, /* external (1-based) unit */
512 FILE *f,
513 const char *fname, /* "filename" for error reports */
514 int flags) {
515 struct file *fp;
516
517 fp = io_newfile(fname);
518 if (fp == NULL)
519 return FALSE;
520 fp->flags |= flags;
521 fp->iop = stdio_wrap(fp->fname, f, 0, NULL, fp->flags);
522 io_setfile(unit, fp);
523 return TRUE;
524 }
525
526 EXPORT(int)
io_mkfile(int unit,FILE * f,const char * fname)527 io_mkfile(int unit, /* external (1-based) unit */
528 FILE *f,
529 const char *fname) { /* "filename" for error reports */
530 return io_mkfile2( unit, f, fname, 0 );
531 }
532
533 EXPORT(int)
io_mkfile_noclose(int unit,FILE * f,const char * fname)534 io_mkfile_noclose(int unit, /* external (1-based) unit */
535 FILE *f,
536 const char *fname) { /* "filename" for error reports */
537 return io_mkfile2( unit, f, fname, FL_NOCLOSE );
538 }
539
540 /* return true if unit attached */
541 EXPORT(int)
io_attached(int unit)542 io_attached(int unit) {
543 struct unit *up = FINDUNIT(INTERN(unit));
544 return up->curr != NULL;
545 }
546
547 #ifdef SHARED
548 /*
549 * create a memory based output file and attach for output
550 * pass in a char ** to be filled with a malloced buffer?
551 */
552 EXPORT(int)
io_output_string(int unit,char * fname,char * buf,int len)553 io_output_string(int unit, /* external (1-based) unit */
554 char *fname, /* "filename" for error reports */
555 char *buf,
556 int len) {
557 struct file *fp;
558
559 fp = io_memfile(fname, buf, len, 'w');
560 if (fp == NULL)
561 return FALSE;
562 io_setfile(unit, fp);
563 return TRUE;
564 }
565 #endif /* SHARED defined */
566
567 /*
568 * implement SIL operations;
569 */
570
571 /* limited printf */
572
573 #define COPY(SRC,LEN) \
574 { \
575 size_t len = LEN; \
576 if (LEN > space) \
577 len = space; \
578 memcpy(lp, SRC, len); \
579 lp += len; \
580 space -= len; \
581 *lp = '\0'; \
582 }
583
584 #define COPYTEMP COPY(temp, strlen(temp))
585
586 /*
587 * IOPRINT -- formatted stats/error output (SIL OUTPUT op)
588 * orignally "format" was in FORTRAN FORMAT format!!
589 */
590 void
io_printf(int_t unit,...)591 io_printf(int_t unit, ...) {
592 va_list vp;
593 char *format;
594 register char c;
595 char line[1024]; /* XXX */
596 size_t space;
597 char *lp;
598 struct file *fp;
599
600 va_start(vp,unit);
601 fp = findfile((int)INTERN(unit));
602 if (!fp || !fp->iop)
603 return;
604
605 /* keep output in line buffer, in case output unbuffered (ie; stderr) */
606 lp = line;
607 space = sizeof(line) - 1;
608 format = va_arg(vp, char *);
609 while ((c = *format++) != '\0' && space > 0) {
610 struct descr *dp;
611 struct spec *sp;
612 char temp[32]; /* large enough for 2^64 */
613 char *cp;
614
615 /* scan forward until first %, and print all at once? */
616 if (c != '%') {
617 *lp++ = c;
618 space--;
619 continue;
620 }
621 c = *format++;
622 if (c == '\0')
623 break;
624 switch (c) {
625 case 'd': /* plain decimal */
626 dp = va_arg(vp, struct descr *);
627 sprintf(temp, "%ld", (long)D_A(dp)); /* XXX handle LP32LL64 int_t */
628 COPYTEMP;
629 break;
630 case 'D': /* padded decimal */
631 dp = va_arg(vp, struct descr *);
632 sprintf(temp, "%15ld", (long)D_A(dp)); /* XXX handle LP32LL64 int_t */
633 COPYTEMP;
634 break;
635 case 'F': /* padded float */
636 dp = va_arg(vp, struct descr *);
637 sprintf(temp, "%15.3f", D_RV(dp));
638 COPYTEMP;
639 break;
640 case 'G': /* padded g/float */
641 dp = va_arg(vp, struct descr *);
642 sprintf(temp, "%15.3g", D_RV(dp));
643 COPYTEMP;
644 break;
645 case 'g': /* unpadded g/float */
646 dp = va_arg(vp, struct descr *);
647 sprintf(temp, "%g", D_RV(dp));
648 COPYTEMP;
649 break;
650 case 's': /* c-string (from version.c) */
651 cp = va_arg(vp, char *);
652 COPY(cp, strlen(cp));
653 break;
654 case 'S': /* spec */
655 sp = va_arg(vp, struct spec *);
656 /* might contain NUL's... will stop short! */
657 COPY(S_SP(sp), (size_t)S_L(sp));
658 break;
659 case 'v': /* variable */
660 dp = va_arg(vp, struct descr *);
661 dp = (struct descr *) D_A(dp); /* get var pointer */
662 if (dp) {
663 struct spec s[1];
664
665 S_A(s) = 0; /* try to keep gcc quiet */
666 S_O(s) = 0; /* try to keep gcc quiet */
667 X_LOCSP(s, dp); /* get specifier */
668
669 /* might contain NUL's... will stop short! */
670 COPY(S_SP(s), (size_t)S_L(s));
671 }
672 break;
673 case 'A': /* padded descriptor Addr */
674 dp = va_arg(vp, struct descr *);
675 if (D_V(dp) == I) /* INTEGER */
676 sprintf(temp, "%15ld", (long)D_A(dp)); /* XXX handle LP32LL64 int_t */
677 else if (D_V(dp) == R) /* REAL */
678 sprintf(temp, "%#15.3g", (double)D_RV(dp));
679 else /* presumed to be pointer */
680 sprintf(temp, "%#15lx", (unsigned long)D_A(dp)); /* XXX handle LP32LL64 int_t */
681 COPYTEMP;
682 break;
683 case 'L': /* padded descriptor fLags */
684 dp = va_arg(vp, struct descr *);
685 sprintf(temp, "%#15o", (int)D_F(dp)); /* defined in octal!! */
686 COPYTEMP;
687 break;
688 case 'V': /* padded descriptor Value (type) */
689 dp = va_arg(vp, struct descr *);
690 sprintf(temp, "%15d", (int)D_V(dp));
691 COPYTEMP;
692 break;
693 default:
694 *lp++ = c;
695 space--;
696 break;
697 }
698 } /* while */
699 va_end(vp);
700 *lp = '\0';
701
702 ioo_write(fp->iop, line, strlen(line)); /* was fputs */
703 } /* io_printf */
704
705 static int
io_write(struct file * fp,const char * cp,int_t len)706 io_write(struct file *fp, const char *cp, int_t len) {
707 if (len == 0)
708 return TRUE;
709
710 return ioo_write(fp->iop, cp, len) == len;
711 }
712
713 static int /* bool */
io_print_str(struct file * fp,char * cp,int_t len,int needfill,int eol)714 io_print_str(struct file *fp,
715 char *cp,
716 int_t len,
717 int needfill,
718 int eol) {
719 int ret = TRUE;
720
721 if (fp == NULL)
722 return FALSE;
723
724 if (cp && len) {
725 if (needfill) {
726 char *ep;
727 int l2;
728 char *tp = cp;
729
730 /* trim trailing spaces & NUL's (without altering specifier) */
731 ep = tp + len - 1;
732 while (len > 0 && (*ep == ' ' || *ep == '\0')) {
733 len--;
734 ep--;
735 }
736
737 /* plug remaining NULs with spaces */
738 for (l2 = len; l2 > 0; l2--) {
739 if (*tp == '\0')
740 *tp = ' ';
741 tp++;
742 }
743 } /* compiling */
744
745 ret = io_write(fp, cp, len);
746 } /* have string */
747
748 /* XXX check ret first? */
749
750 if (ret && eol && !(fp->flags & FL_KEEPEOL))
751 ret = io_write(fp, "\n", 1);
752
753 #ifdef NO_UNBUF_RW
754 if ((fp->flags & FL_UNBUF)) {
755 /* simulate unbuffered I/O (noop now that setvbuf used) */
756 ret = ioo_flush(f);
757 }
758 #endif /* NO_UNBUF_RW defined */
759 return ret;
760 } /* io_print_str */
761
762 void
io_print(struct descr * iokey,struct descr * iob,struct spec * sp)763 io_print(struct descr *iokey, struct descr *iob, struct spec *sp) { /* STPRNT */
764 /* IOB->
765 * title descr
766 * integer unit number
767 * pointer to natural var for format
768 */
769 int xunit = D_A(D_A(iob) + DESCR);
770 struct file *fp = findfile(INTERN(xunit));
771 D_A(iokey) = io_print_str(fp, S_SP(sp), S_L(sp), (int)D_A(COMPCL), 1);
772 }
773
774 int
io_endfile(int_t unit)775 io_endfile(int_t unit) { /* ENFILE */
776 struct unit *up;
777
778 unit = INTERN(unit);
779
780 /* bad unit a fatal error in SPITBOL, but not in SNOBOL4+; */
781 if (BADUNIT(unit))
782 return TRUE;
783 up = FINDUNIT(unit);
784 if (up->curr == NULL && up->head == NULL)
785 return TRUE;
786
787 return io_closeall(unit);
788 }
789
790 #define COMPILING(UNIT) ((UNIT) == INTERN(UNITI) && D_A(COMPCL))
791
792 #ifdef COMPILER_READLINE
793 static VAR int readline_inited;
794 #ifdef HAVE_RL_SET_KEYMAP
795 static VAR Keymap initial_keymap, compile_keymap;
796 #endif
797
798 static void
init_readline(void)799 init_readline(void) {
800 rl_initialize();
801 #ifdef HAVE_RL_SET_KEYMAP
802 initial_keymap = rl_get_keymap();
803 compile_keymap = rl_copy_keymap(initial_keymap);
804 rl_set_keymap(compile_keymap);
805 #endif
806 /* disable TAB completion */
807 rl_bind_key('\t', rl_insert);
808
809 readline_inited = 1;
810 }
811
812 static void
restore_readline(void)813 restore_readline(void) {
814 if (!readline_inited)
815 return;
816 #ifdef HAVE_RL_SET_KEYMAP
817 /* restore initial keymap */
818 if (initial_keymap)
819 rl_set_keymap(initial_keymap);
820 #if 0
821 /* dies with free() of invalid pointer on Ubuntu. */
822 if (compile_keymap)
823 rl_discard_keymap(compile_keymap);
824 compile_keymap = NULL;
825 #endif
826 #else
827 /*
828 * probably here with "editline" library (OS X, NetBSD?)
829 */
830 rl_initialize(); /* seems to work */
831 #endif
832 clear_history();
833 }
834 #endif /* ifdef COMPILER_READLINE */
835
836 enum io_read_ret
io_read(struct descr * dp,struct spec * sp)837 io_read(struct descr *dp, struct spec *sp) { /* STREAD */
838 int unit;
839 int_t recl;
840 ssize_t len;
841 char *cp;
842 struct file *fp;
843 struct unit *up;
844 struct io_obj *iop;
845
846 unit = INTERN(D_A(dp));
847 if (BADUNIT(unit) || (up = FINDUNIT(unit)) == NULL || up->curr == NULL) {
848 if (COMPILING(unit)) {
849 return IO_ERR; /* compiler never quits!! */
850 }
851 return IO_EOF;
852 }
853
854 recl = S_L(sp); /* YUK! */
855 cp = S_SP(sp);
856 for (;;) {
857 fp = up->curr;
858 iop = fp->iop;
859 if (iop == NULL) {
860 iop = io_fopen( fp, 'r' );
861 if (iop == NULL)
862 return IO_ERR;
863 }
864
865 if (iop->flags & FL_BINARY) {
866 if (recl == 0)
867 return IO_ERR;
868
869 len = ioo_read_raw(iop, cp, recl);
870 if (len > 0)
871 break;
872 }
873 #ifdef COMPILER_READLINE
874 else if (ISTTY(fp) && COMPILING(unit)) {
875 char *tp;
876
877 if (!readline_inited)
878 init_readline();
879 tp = readline("snobol4> ");
880 if (!tp)
881 return IO_EOF;
882 if (*tp)
883 add_history(tp);
884 len = strlen(tp);
885 if (len > recl-1) /* leave room for space */
886 len = recl-1;
887 strncpy(cp, tp, len);
888 free(tp);
889 break;
890 }
891 #endif /* COMPILER_READLINE defined */
892 else { /* normal, cooked (line) I/O */
893 len = ioo_getline(iop);
894 if (len > 0) {
895 /* if normal EOL processing, discard newline */
896 if (!(iop->flags & FL_KEEPEOL) && iop->linebuf[len-1] == '\n') {
897 len--;
898 if (len && iop->linebuf[len-1] == '\r')
899 len--;
900 }
901
902 if (COMPILING(unit)) {
903 /* compiler expects data in-place, so copy it */
904 if (!recl)
905 return IO_ERR;
906 if (len > recl)
907 len = recl;
908 /* NOTE! truncates line (discards rest of record) */
909 memcpy(cp, iop->linebuf, len);
910 break;
911 }
912 else { /* not compiling */
913 /*
914 * 2020-09-20: point at getline buffer!!!
915 * no more truncation (at the cost of another copy)
916 */
917 S_A(sp) = (int_t) iop->linebuf;
918 S_O(sp) = 0; /* offset */
919 S_F(sp) = 0; /* flags S_A not PTR!! */
920 /* S_L(sp) set below */
921 break;
922 }
923 }
924 } /* else (normal, cooked) */
925
926 /* here when read failed; see if non-EOF error */
927 if (!ioo_eof(iop) )
928 return IO_ERR; /* error wasn't EOF */
929
930 /* here with EOF */
931 if (!io_next(unit)) { /* skip to next file, if any */
932 return IO_EOF; /* no more files */
933 }
934 if (COMPILING(unit)) {
935 /* force call to INCCK to pop old FILENM and LNNOCL */
936 return IO_EOF;
937 }
938 /* here with next file, if not compiling (command line -r?) */
939 } /* forever */
940
941 /* here on successful read */
942 if (COMPILING(unit)) {
943 /* compiler doesn't handle exaustion well; tack on a space.
944 * INBUF has extra room (for LIST RIGHT output)
945 */
946 cp[len++] = ' ';
947 }
948 S_L(sp) = len;
949
950 return IO_OK;
951 } /* io_read */
952
953 /*
954 * will never be implemented
955 * I/O is not record oriented (no magtape support); use "SET" to seek
956 * (might as well just remove from the SIL code!)
957 */
958 void
io_backspace(int_t unit)959 io_backspace(int_t unit) { /* SIL BKSPCE op */
960 (void) unit;
961 UNDF(NORET);
962 }
963
964 void
io_rewind(int_t unit)965 io_rewind(int_t unit) { /* SIL REWIND op */
966 struct file *fp;
967 struct unit *up;
968
969 unit = INTERN(unit);
970 if (BADUNIT(unit))
971 return;
972
973 up = FINDUNIT(unit);
974 if (up->curr != up->head) {
975 if (up->curr != NULL) /* open file not first in list */
976 io_close((int)unit); /* close it */
977 up->curr = up->head; /* reset to head of list */
978 if (up->curr->iop == NULL)
979 io_fopen(up->curr, 'r');
980 }
981 fp = up->curr;
982 if (fp == NULL)
983 return;
984
985 ioo_seeko(fp->iop, up->offset, SEEK_SET);
986 } /* io_rewind */
987
988 /* extensions; */
989
990 /* here at end of compilation */
991 void
io_ecomp(void)992 io_ecomp(void) { /* SIL XECOMP op */
993 struct unit *up;
994 struct file *fp;
995
996 #ifdef COMPILER_READLINE
997 restore_readline();
998 #endif
999
1000 if (lflag) {
1001 /* if -l was given, switch OUTPUT to stdout! */
1002
1003 /* XXX check return?! */
1004 io_mkfile2( UNITO, stdout, STDOUT_NAME, FL_NOCLOSE );
1005 }
1006
1007 if (rflag == 0) {
1008 /* if -r was not given, switch INPUT to stdin!! */
1009
1010 /* XXX check return?! */
1011 io_mkfile2( UNITI, stdin, STDIN_NAME, FL_NOCLOSE );
1012 return;
1013 }
1014
1015 /*
1016 * else (start INPUT after END stmt)
1017 * save the file position the data begins at for rewind.
1018 *
1019 * SITBOL would skip to next input file (ie; io_next())
1020 * but SPARC SPITBOL doesn't!
1021 */
1022
1023 up = FINDUNIT(UNITI - 1);
1024
1025 /* free source files... */
1026 fp = up->head;
1027 while (fp && fp != up->curr) {
1028 struct file *tp;
1029
1030 tp = fp->next;
1031 free(fp);
1032 fp = tp;
1033 }
1034
1035 up->head = up->curr; /* save file for rewind */
1036 up->offset = ioo_tello(up->curr->iop); /* save offset for rewind */
1037
1038 /* free list of included filenames */
1039 while (includes) {
1040 struct file *tp;
1041
1042 tp = includes->next;
1043 free(includes);
1044 includes = tp;
1045 }
1046
1047 /* loadx.c uses list of include directories, cannot free!! */
1048 }
1049
1050 /* process I/O option strings for io_openi and io_openo */
1051 static int
io_options(char * op,int * rp,struct file * fp)1052 io_options(char *op, /* IN: options */
1053 int *rp, /* OUT: recl (optional) */
1054 struct file *fp) { /* OUT: flags & comp */
1055 int flags;
1056 int recl;
1057
1058 flags = fp->flags;
1059 recl = 0;
1060
1061 /* XXX check here for leading hyphen; process SPITBOL style options? */
1062
1063 while (*op) {
1064 switch (*op) {
1065 case '-': /* reserved for SPITBOL ops */
1066 /* XXX skip ahead 'till space or EOS? */
1067 return FALSE;
1068
1069 case ',': /* optional SNOBOL4+ seperator */
1070 op++; /* skip it */
1071 break;
1072
1073 case '0':
1074 case '1':
1075 case '2':
1076 case '3':
1077 case '4':
1078 case '5':
1079 case '6':
1080 case '7':
1081 case '8':
1082 case '9':
1083 #if 0
1084 if (recl) /* already got one? */
1085 return FALSE; /* boing! */
1086 #endif /* 0 */
1087 recl = 0;
1088 while (isdigit((unsigned char)*op)) {
1089 recl = recl * 10 + *op - '0'; /* works for ASCII, EBDCIC */
1090 op++;
1091 }
1092 break;
1093
1094 case 'A': /* SITBOL/SPITBOL: append */
1095 case 'a':
1096 flags |= FL_APPEND;
1097 op++;
1098 break;
1099
1100 case 'B': /* SITBOL/SNOBOL4+: binary */
1101 case 'b':
1102 flags |= FL_BINARY|FL_KEEPEOL;
1103 op++;
1104 break;
1105
1106 case 'C': /* SITBOL/SPITBOL: character */
1107 case 'c':
1108 flags |= FL_BINARY|FL_KEEPEOL;
1109 #if 0
1110 if (recl) /* already have recl? */
1111 return FALSE; /* fail */
1112 #endif /* 0 */
1113 recl = 1;
1114 op++;
1115 break;
1116
1117 case 'E': /* 2.1 extension: close on Exec */
1118 case 'e':
1119 flags |= FL_CLOEXEC;
1120 op++;
1121 break;
1122
1123 /* J, j see below */
1124
1125 case 'K': /* Local/experimental: breaK long lines */
1126 case 'k':
1127 /* XXX complain? once?? */
1128 op++;
1129 break; /* dead in 2.2 */
1130
1131 /* reserve 'M' for memory I/O (take input instead of filename?) */
1132
1133 case 'T': /* SITBOL: "terminal" (no EOL) */
1134 case 't':
1135 flags |= FL_UNBUF|FL_KEEPEOL; /* force prompt output */
1136 op++;
1137 break;
1138
1139 case 'Q': /* SNOBOL4+/SPITBOL: quiet */
1140 case 'q':
1141 flags |= FL_NOECHO;
1142 op++;
1143 break;
1144
1145 case 'U': /* SITBOL/SPITBOL: update */
1146 case 'u':
1147 flags |= FL_UPDATE;
1148 op++;
1149 break;
1150
1151 case 'W': /* SPITBOL: write unbuffered */
1152 case 'w':
1153 flags |= FL_UNBUF;
1154 op++;
1155 break;
1156
1157 case 'X': /* 2.1 extension: eXclusive (fail if eXists) */
1158 case 'x':
1159 flags |= FL_EXCL;
1160 op++;
1161 break;
1162
1163 case 'J': /* 2.2: xz compression */
1164 case 'j': /* 2.2: bzip2 compression */
1165 case 'Z': /* 2.2: compress compression */
1166 case 'z': /* 2.2: zlib (gzip) compression */
1167 fp->compression = *op++;
1168 if (isdigit((unsigned char)*op))
1169 fp->complvl = *op++;
1170 break;
1171
1172 case '{': /* 2.2: reserved for long names */
1173 op++;
1174 while (*op) {
1175 if (*op == '}') {
1176 op++;
1177 break;
1178 }
1179 else
1180 op++;
1181 }
1182 break;
1183 default:
1184 op++;
1185 break;
1186 }
1187 } /* while *op */
1188
1189 fp->flags = flags;
1190 if (rp)
1191 *rp = recl;
1192 return TRUE;
1193 }
1194
1195 /* here via XCALL IO_OPENI */
1196 /* called from SNOBOL INPUT() */
1197 int
io_openi(struct descr * dunit,struct spec * sfile,struct spec * sopts,struct descr * drecl)1198 io_openi(struct descr *dunit, /* IN: unit */
1199 struct spec *sfile, /* IN: filename */
1200 struct spec *sopts, /* IN: options */
1201 struct descr *drecl) { /* OUT: rec len */
1202 char fname[MAXFNAME]; /* XXX */
1203 char opts[MAXOPTS]; /* XXX */
1204 struct file *fp;
1205 struct unit *up;
1206 int xunit, unit;
1207 int recl;
1208
1209 xunit = D_A(dunit); /* external unit number */
1210 unit = INTERN(xunit); /* internal unit number */
1211 if (BADUNIT(unit))
1212 return FALSE; /* fail */
1213 up = FINDUNIT(unit);
1214
1215 /* XXX handle arbitrary length strings? */
1216 spec2str( sfile, fname, sizeof(fname) ); /* XXX mspec2str */
1217 spec2str( sopts, opts, sizeof(opts) ); /* XXX mspec2str */
1218
1219 /* XXX if no sopts;
1220 * extract spitbol style options suffix (if any) from filename here?
1221 */
1222
1223 if (fname[0]) {
1224 /*
1225 * SITBOL takes comma seperated file list
1226 * would need to keep flags per-unit
1227 */
1228 fp = io_newfile(fname);
1229 }
1230 else {
1231 fp = up->curr;
1232 }
1233 if (fp == NULL)
1234 return FALSE;
1235
1236 /* process options */
1237 if (!io_options(opts, &recl, fp)) {
1238 free(fp);
1239 return FALSE;
1240 }
1241
1242 if (recl && !(fp->flags & FL_BINARY)) {
1243 #if 0
1244 static VAR char recl_ignored_warning = 0;
1245 /* just once per run: have an environment variable suppress this?? */
1246 if (!recl_ignored_warning) {
1247 fprintf(stderr, "Ignoring record length %d on I/O unit %d\n",
1248 recl, xunit);
1249 recl_ignored_warning = 1;
1250 }
1251 #endif
1252 recl = VLRECL; /* Keep PUTIN from pre-allocating */
1253 }
1254
1255 /* open it now, so we can return status! */
1256 if (fname[0]) {
1257 if (io_fopen( fp, 'r') == NULL) {
1258 free(fp);
1259 return FALSE; /* fail; no harm done! */
1260 }
1261 io_closeall(unit);
1262 up->curr = up->head = fp;
1263 }
1264
1265 /* pass recl back up */
1266 D_A(drecl) = recl;
1267 D_F(drecl) = 0;
1268 D_V(drecl) = I;
1269
1270 return TRUE;
1271 } /* io_openi */
1272
1273 /* here via XCALL IO_OPENO */
1274 /* called from SNOBOL OUTPUT() */
1275 int
io_openo(struct descr * dunit,struct spec * sfile,struct spec * sopts)1276 io_openo(struct descr *dunit, /* IN: unit */
1277 struct spec *sfile, /* IN: filename */
1278 struct spec *sopts) { /* IN: options */
1279 char fname[MAXFNAME]; /* XXX malloc(S_L(sfile)+1)? */
1280 char opts[MAXOPTS]; /* XXX malloc(S_L(sopts)+1)? */
1281 struct file *fp;
1282 struct unit *up;
1283 int unit;
1284
1285 unit = INTERN(D_A(dunit));
1286 if (BADUNIT(unit))
1287 return FALSE; /* fail */
1288 up = FINDUNIT(unit);
1289
1290 spec2str( sfile, fname, sizeof(fname) );
1291 spec2str( sopts, opts, sizeof(opts) );
1292
1293 /* XXX if no sopts;
1294 * extract options suffix (if any) from filename here?
1295 */
1296
1297 if (fname[0]) {
1298 /* SITBOL takes comma seperated file list */
1299 fp = io_newfile(fname);
1300 }
1301 else {
1302 fp = up->curr;
1303 }
1304
1305 if (fp == NULL)
1306 return FALSE; /* fail; no harm done! */
1307
1308 /* process options */
1309 if (!io_options(opts, NULL, fp)) { /* XXX error if recl set?? */
1310 free(fp);
1311 return FALSE;
1312 }
1313
1314 /* open it now, so we can return status! */
1315 if (fname[0]) {
1316 if (io_fopen( fp, 'w') == NULL) {
1317 free(fp);
1318 return FALSE; /* fail; no harm done! */
1319 }
1320 io_closeall(unit);
1321 up->curr = up->head = fp;
1322 }
1323 return TRUE;
1324 } /* io_openo */
1325
1326 static enum io_include_ret
io_include2(struct descr * dp,char * fname)1327 io_include2(struct descr *dp, /* input unit */
1328 char *fname) { /* file name (with quotes) */
1329 int l;
1330 struct file *fp;
1331 struct unit *up;
1332 char *fn2;
1333
1334 /* search includes list to see if file already included!! */
1335 for (fp = includes; fp; fp = fp->next)
1336 if (strcmp(fname, fp->fname) == 0) /* found it!!! */
1337 return INC_SKIP; /* as you were! */
1338
1339 /* strip off trailing spaces after uniqueness test */
1340 l = strlen(fname);
1341 while (l > 0 && fname[l-1] == ' ') {
1342 l--;
1343 }
1344 fname[l] = '\0';
1345
1346 /* NOTE!!! No longer trying local directory: must be in path!!! */
1347
1348 fn2 = io_lib_find(NULL, fname, NULL);
1349 if (!fn2)
1350 return INC_FAIL; /* not found */
1351
1352 fp = io_newfile(fn2);
1353 free(fn2);
1354 if (fp == NULL)
1355 return INC_FAIL; /* alloc failure */
1356
1357 if (io_fopen( fp, 'r') == NULL) {
1358 free(fp);
1359 return INC_FAIL;
1360 }
1361
1362 up = FINDUNIT(INTERN(D_A(dp)));
1363
1364 /* push new file onto top of input list */
1365 fp->next = up->curr;
1366 fp->flags |= FL_INCLUDE;
1367 up->curr = fp;
1368
1369 /* add base filename to list of files already included */
1370 fp = io_newfile(fname); /* reuse struct file!! */
1371 if (fp) {
1372 fp->next = includes;
1373 includes = fp;
1374 }
1375 return INC_OK;
1376 } /* io_include2 */
1377
1378 enum io_include_ret
io_include(struct descr * dp,struct spec * sp)1379 io_include(struct descr *dp, /* input unit */
1380 struct spec *sp) { /* file name (with quotes) */
1381 char *fname = mspec2str(sp);
1382 enum io_include_ret ret = io_include2(dp, fname);
1383 free(fname);
1384 return ret;
1385 } /* io_include */
1386
1387 /*
1388 * retrieve file name currently associated with a unit, or NULL.
1389 * data only valid while current file open
1390 */
1391 EXPORT(const char *)
io_fname(int unit)1392 io_fname(int unit) { /* takes external (1-based) unit */
1393 struct unit *up;
1394 struct file *fp;
1395
1396 unit = INTERN(unit);
1397 if (BADUNIT(unit))
1398 return NULL;
1399
1400 up = FINDUNIT(unit);
1401 if (up == NULL)
1402 return NULL;
1403
1404 fp = up->curr;
1405 if (fp == NULL)
1406 return NULL;
1407
1408 return fp->fname;
1409 }
1410
1411 /*
1412 * retrieve file currently associated with a unit
1413 * used by compiler to pick up filenames from command line
1414 */
1415 int
io_file(struct descr * dp,struct spec * sp)1416 io_file(struct descr *dp, /* IN: unit number */
1417 struct spec *sp) { /* OUT: filename */
1418 const char *fname;
1419
1420 fname = io_fname(D_A(dp));
1421 if (fname == NULL)
1422 return FALSE;
1423
1424 S_A(sp) = (int_t) fname; /* OY! */
1425 S_F(sp) = 0; /* NOTE: *not* a PTR! */
1426 S_V(sp) = 0;
1427 S_O(sp) = 0;
1428 S_L(sp) = strlen(fname);
1429 CLR_S_UNUSED(sp);
1430
1431 return TRUE;
1432 }
1433
1434 /*
1435 * support for SPITBOL SET() function
1436 *
1437 * problems on modern 32-bit systems where sizeof(off_t) > sizeof(int_t)
1438 * called via IO_SEEK macro using XCALLC in SIL code
1439 */
1440
1441 int
io_seek(struct descr * dunit,struct descr * doff,struct descr * dwhence)1442 io_seek(struct descr *dunit, struct descr *doff, struct descr *dwhence) {
1443 int unit, whence;
1444 io_off_t off;
1445 struct file *fp;
1446 struct unit *up;
1447
1448 unit = INTERN(D_A(dunit));
1449 if (BADUNIT(unit))
1450 return FALSE;
1451 up = FINDUNIT(unit);
1452 fp = up->curr;
1453 if (fp == NULL)
1454 return FALSE;
1455
1456 off = (io_off_t) D_A(doff);
1457 whence = D_A(dwhence);
1458 if (whence < 0 || whence > 2)
1459 return FALSE;
1460
1461 /* translate n -> SEEK_xxx using switch stmt (if SEEK_xxx available)? */
1462
1463 if (ioo_seeko(fp->iop, off, whence) == 0)
1464 D_A(doff) = (int_t)ioo_tello(fp->iop); /* XXX truncation possible (on 32b)! */
1465 else
1466 return FALSE;
1467
1468 return TRUE;
1469 }
1470
1471 /*
1472 * new 3/12/99
1473 * Experimental "scaled SET" function
1474 * called as external function from snolib/sset.c
1475 * (not needed on 64-bit systems)
1476 */
1477 int
io_sseek(int_t unit,int_t soff,int_t whence,int_t scale,int_t * oof)1478 io_sseek(int_t unit, int_t soff, int_t whence, int_t scale, int_t *oof ) {
1479 io_off_t off;
1480 struct file *fp;
1481 struct unit *up;
1482 struct io_obj *iop;
1483
1484 unit = INTERN(unit);
1485 if (BADUNIT(unit))
1486 return FALSE;
1487 up = FINDUNIT(unit);
1488 fp = up->curr;
1489 if (fp == NULL)
1490 return FALSE;
1491
1492 off = soff * (io_off_t)scale;
1493 if (whence < 0 || whence > 2)
1494 return FALSE;
1495
1496 /* translate n -> SEEK_xxx using switch stmt (if SEEK_xxx available)? */
1497
1498 iop = fp->iop;
1499 if (iop == NULL)
1500 return FALSE;
1501
1502 if (ioo_seeko(iop, off, whence) == 0)
1503 *oof = ioo_tello(iop)/scale;
1504 else
1505 return FALSE;
1506
1507 return TRUE;
1508 }
1509
1510 /* flush all pending output before system(), exec(), or death */
1511 int
io_flushall(int dummy)1512 io_flushall(int dummy) { /* called w/ SIL XCALLC */
1513 int i;
1514
1515 (void) dummy;
1516 for (i = 1; i <= NUNITS; i++) {
1517 struct file *fp;
1518 struct unit *up;
1519
1520 up = FINDUNIT(INTERN(i));
1521 fp = up->curr;
1522 if (fp && fp->iop) {
1523 /* keep err count?? */
1524 ioo_flush(fp->iop);
1525 }
1526 } /* foreach unit */
1527 return TRUE;
1528 }
1529
1530 /*
1531 * for PML functions; return a free unit number, returns -1 on failure
1532 * (use io_mkfile() to attach open file to unit)
1533 *
1534 * available in SNOBOL via snolib/findunit.c (PML'ed) as IO_FINDUNIT()
1535 */
1536
1537 #define MINFIND 20 /* minimum unit to return */
1538 #define MAXFIND NUNITS /* maximum unit to return */
1539
1540 EXPORT(int)
io_findunit(void)1541 io_findunit(void) {
1542 int start;
1543
1544 for (;;) {
1545 if (finger < MINFIND)
1546 finger = MAXFIND;
1547
1548 start = finger;
1549 while (finger >= MINFIND) {
1550 int u;
1551 struct unit *up;
1552 int ret;
1553
1554 u = INTERN(finger);
1555 up = FINDUNIT(u);
1556 ret = finger--;
1557 if (up->curr == NULL && up->head == NULL)
1558 return ret; /* found a free unit */
1559 }
1560
1561 /*
1562 * if we didn't find anything, and we started from scratch,
1563 * then we're out of luck. Only REALLY need to search from
1564 * start0 downto MINFIND, then from MAXFIND to start0+1,
1565 * but this code is ugly enough
1566 */
1567 if (start == MAXFIND)
1568 return -1;
1569
1570 /* if we didn't start from scratch, then do that */
1571 }
1572 } /* io_findunit */
1573
1574 /*
1575 * only stdio_obj subclass of io_obj has FILE pointer.
1576 * COULD implement a getfp io_obj method
1577 * and all files implementing io_obj interface already include <stdio.h>
1578 * (for NULL and size_t)
1579 */
1580 #if 0
1581 /* for PML functions; get current fp on a unit */
1582 EXPORT(FILE *)
1583 io_getfp(int unit) { /* "external" unit */
1584 struct unit *up;
1585
1586 unit = INTERN(unit);
1587 if (BADUNIT(unit))
1588 return NULL;
1589
1590 up = FINDUNIT(unit);
1591 if (up->curr == NULL)
1592 return NULL;
1593
1594 return up->curr->f;
1595 } /* io_getfp */
1596 #endif
1597
1598 /*
1599 * new 9/9/97
1600 * Pad listing line out to input record length for "-LIST RIGHT"
1601 * Not strictly an "I/O" function, but here because the work used
1602 * to be done in io_read() for all compiler input, regardless of
1603 * listing on/off and left/right.
1604 */
1605
1606 int
io_pad(struct spec * sp,int len)1607 io_pad(struct spec *sp, int len) {
1608 register char *cp;
1609 register int i;
1610
1611 cp = S_SP(sp) + S_L(sp);
1612 for (i = len - S_L(sp); i > 0; i--)
1613 *cp++ = ' ';
1614 S_L(sp) = len;
1615
1616 return 1; /* for XCALLC */
1617 }
1618
1619 /* new 9/21/97 called from lib/endex.c (which is called from main.c) */
1620 int
io_finish(void)1621 io_finish(void) {
1622 int i;
1623
1624 /* should visit from most recently opened to least recent? */
1625 for (i = 0; i < NUNITS; i++)
1626 io_closeall(i);
1627
1628 while (lib_dirs) {
1629 struct file *tp;
1630
1631 tp = lib_dirs->next;
1632 free(lib_dirs);
1633 lib_dirs = tp;
1634 }
1635 lib_dir_last = NULL;
1636
1637 return TRUE;
1638 }
1639
1640 /* new 1/12/2012 called to add a dir to include dir list (from init.c) */
1641 int
io_add_lib_dir(const char * dirname)1642 io_add_lib_dir(const char *dirname) {
1643 struct file *fp = io_newfile(dirname);
1644 if (!fp)
1645 return FALSE;
1646 if (lib_dir_last)
1647 lib_dir_last->next = fp;
1648 else
1649 lib_dirs = fp; /* new list */
1650 lib_dir_last = fp;
1651 return TRUE;
1652 }
1653
1654 /* new 1/12/2012 add a (PATH_SEP separated) path to include dir list
1655 * (called from init.c)
1656 */
1657 int
io_add_lib_path(char * path)1658 io_add_lib_path(char *path) {
1659 char *p2 = strdup(path);
1660 char *pp = p2;
1661 if (!p2)
1662 return FALSE;
1663
1664 while (pp) {
1665 /* XXX need strstr if sizeof(PATH_SEP) != 2 */
1666 char *tpp = strchr(pp, PATH_SEP[0]);
1667 if (tpp)
1668 *tpp++ = '\0'; /* tie off and advance */
1669 io_add_lib_dir(pp);
1670 pp = tpp;
1671 }
1672 free(p2);
1673 return TRUE;
1674 }
1675
1676 /* called from init.c to display paths (for -z option) */
1677 void
io_show_paths(void)1678 io_show_paths(void)
1679 {
1680 struct file *fp;
1681 for (fp = lib_dirs; fp; fp = fp->next)
1682 puts(fp->fname);
1683 }
1684
1685 /*
1686 * search for a file, given a path, and optional subdir and extension
1687 * returns malloc'ed string or NULL
1688 */
1689
1690 /* helper */
1691 static char *
trypath(const char * dir,const char * subdir,const char * file,const char * ext)1692 trypath(const char *dir,
1693 const char *subdir, /* optional: may be NULL */
1694 const char *file,
1695 const char *ext) { /* optional: may be NULL */
1696 int l = strlen(dir) + strlen(file) + sizeof(DIR_SEP);
1697 char *path;
1698
1699 if (subdir)
1700 l += strlen(subdir) + sizeof(DIR_SEP) - 1;
1701 if (ext)
1702 l += strlen(ext);
1703 path = malloc(l);
1704 if (!path)
1705 return NULL;
1706 strcpy(path, dir);
1707 strcat(path, DIR_SEP);
1708 if (subdir) {
1709 strcat(path, subdir);
1710 strcat(path, DIR_SEP);
1711 }
1712 strcat(path, file);
1713 if (ext)
1714 strcat(path, ext);
1715 #if 0
1716 fprintf(stderr, "trypath: %s\n", path);
1717 #endif
1718 if (exists(path))
1719 return path;
1720 free(path);
1721 return NULL;
1722 }
1723
1724 /* used by io_include(), lib/loadx.c, -L option */
1725 char *
io_lib_find(const char * subdir,char * file,const char * ext)1726 io_lib_find(const char *subdir, char *file, const char *ext) {
1727 struct file *ip;
1728
1729 if (abspath(file))
1730 return NULL; /* absolute path */
1731
1732 for (ip = lib_dirs; ip; ip = ip->next) {
1733 char *path;
1734
1735 path = trypath(ip->fname, subdir, file, ext);
1736 if (path)
1737 return path;
1738
1739 if (ext) {
1740 path = trypath(ip->fname, subdir, file, NULL);
1741 if (path)
1742 return path;
1743 }
1744
1745 /* if given subdir, try without it (for dynamic libraries) */
1746 if (subdir) {
1747 path = trypath(ip->fname, NULL, file, ext);
1748 if (path)
1749 return path;
1750
1751 if (ext) {
1752 path = trypath(ip->fname, NULL, file, NULL);
1753 if (path)
1754 return path;
1755 }
1756 }
1757 }
1758 return NULL;
1759 }
1760
1761 /* 12/13/14 return n'th lib directory for HOST() */
1762 char *
io_lib_dir(int n)1763 io_lib_dir(int n) {
1764 struct file *ip = lib_dirs;
1765
1766 while (ip && n > 0) {
1767 n--;
1768 ip = ip->next;
1769 }
1770 if (ip)
1771 return ip->fname;
1772 return NULL;
1773 }
1774
1775 /* helper for io_preload (adds to input file list) */
1776 static void
try_preload(char * path)1777 try_preload(char *path) {
1778 if (!exists(path))
1779 return;
1780
1781 if (isdir(path)) {
1782 int len = strlen(path) + sizeof(PRELOAD_FILENAME) + sizeof(DIR_SEP) - 1;
1783 char *fname = malloc(len);
1784 if (fname) {
1785 strcpy(fname, path);
1786 strcat(fname, DIR_SEP);
1787 strcat(fname, PRELOAD_FILENAME);
1788 if (exists(fname))
1789 io_input_file(fname);
1790 free(fname);
1791 }
1792 }
1793 else
1794 io_input_file(path);
1795 } /* try_preload */
1796
1797 /* called from init.c to preload source files */
1798 void
io_preload(void)1799 io_preload(void) {
1800 char *env = getenv("SNOBOL_PRELOAD_PATH");
1801 if (env) {
1802 char *tmp, *tp;
1803 tmp = tp = strdup(env);
1804 strcpy(tmp, env);
1805 while (tp) {
1806 char *np = strchr(tp, PATH_SEP[0]); /* strstr? */
1807 if (np)
1808 *np++ = '\0';
1809 try_preload(tp);
1810 tp = np;
1811 }
1812 free(tmp);
1813 }
1814 else { /* no SNOBOL_PRELOAD_PATH */
1815 struct file *ip;
1816
1817 /* use include search path */
1818 for (ip = lib_dirs; ip; ip = ip->next)
1819 try_preload(ip->fname);
1820 }
1821 } /* io_preload */
1822
1823 #ifdef BLOCKS
1824 /*
1825 * support for BLOCKS FASTPR macro
1826 * translated from the BAL in "cleanio"
1827 * 9/26/2013
1828 */
1829 void
io_fastpr(struct descr * iokey,struct descr * unit,struct descr * ccfp,struct spec * sp1,struct spec * sp2)1830 io_fastpr(struct descr *iokey, struct descr *unit, struct descr *ccfp,
1831 struct spec *sp1, struct spec *sp2) {
1832 int_t len = S_L(sp1);
1833 char *src = S_SP(sp1);
1834 int xunit = D_A(unit); /* external */
1835 int ccf = D_A(ccfp); /* carriage control flag */
1836 struct file *fp = findfile(INTERN(xunit));
1837 int ret;
1838
1839 /* NOTE!! CC doesn't get written in one write if unbuffered!! */
1840 if (ccf > 0) { /* FORTRAN/ASA carriage control */
1841 ret = (io_print_str(fp, S_SP(sp2), 1, 0, 0) &&
1842 io_print_str(fp, src, len, 1, 1));
1843 }
1844 else if (ccf < 0) { /* EXT: ASCII carriage control */
1845 char ccc = *S_SP(sp2); /* carriage control char */
1846 ret = TRUE;
1847 switch (ccc) {
1848 case '1': /* form feed */
1849 ret = io_write(fp, "\f", 1);
1850 break;
1851 case '+': /* overstrike */
1852 ret = io_write(fp, "\r", 1);
1853 break;
1854 case ' ': /* fresh line */
1855 ret = io_write(fp, "\n", 1);
1856 break;
1857 }
1858 if (src && len && ret)
1859 ret = io_print_str(fp, src, len, 1, 0); /* NO EOL! */
1860 }
1861 else /* ccf == 0: no carriage control */
1862 ret = io_print_str(fp, src, len, 1, 1);
1863 D_A(iokey) = !ret;
1864 } /* io_fastpr */
1865 #endif /* BLOCKS */
1866
1867 /*
1868 * support for io_obj framework: the one place to allocate an io_obj
1869 */
1870 struct io_obj *
io_alloc(int size,const struct io_ops * ops,int flags)1871 io_alloc(int size, const struct io_ops *ops, int flags) {
1872 struct io_obj *iop = calloc(1, size); /* note zeroed! */
1873 if (iop) {
1874 iop->ops = ops;
1875 iop->flags = flags;
1876 }
1877 return iop;
1878 }
1879
1880 /*
1881 * code excised from io_fopen2. called from stdio_obj.c (& winsock inetio)
1882 * NOTE!! path must be writable, and point AFTER the initial prefix
1883 * returned pointers will point inside path buffer.
1884 */
1885 int
inet_parse(char * path,char ** hostp,char ** servicep,int * inet_flagp)1886 inet_parse(char *path, char **hostp, char **servicep, int *inet_flagp) {
1887 char *host, *service, *cp;
1888 int flags;
1889
1890 flags = 0;
1891
1892 host = path;
1893 service = strchr(host, '/');
1894 if (service == NULL)
1895 return -1;
1896 *service++ = '\0';
1897
1898 /* look for option suffixes, ignore if unknown */
1899 cp = strchr(service, '/');
1900 if (cp) {
1901 char *op;
1902
1903 *cp++ = '\0';
1904 do {
1905 op = cp;
1906 cp = strchr(cp, '/');
1907 if (cp)
1908 *cp++ = '\0';
1909
1910 if (strcmp(op, "priv") == 0)
1911 flags |= INET_PRIV;
1912 else if (strcmp(op, "broadcast") == 0)
1913 flags |= INET_BROADCAST;
1914 else if (strcmp(op, "reuseaddr") == 0)
1915 flags |= INET_REUSEADDR;
1916 else if (strcmp(op, "dontroute") == 0)
1917 flags |= INET_DONTROUTE;
1918 else if (strcmp(op, "oobinline") == 0)
1919 flags |= INET_OOBINLINE;
1920 else if (strcmp(op, "keepalive") == 0)
1921 flags |= INET_KEEPALIVE;
1922 else if (strcmp(op, "nodelay") == 0)
1923 flags |= INET_NODELAY;
1924 else if (strcmp(op, "verify") == 0)
1925 flags |= INET_VERIFY;
1926
1927 /* XXX more magic? non-booleans? linger?? */
1928 } while (cp);
1929 } /* have suffixes */
1930
1931 if (flags & FL_CLOEXEC)
1932 flags |= INET_CLOEXEC;
1933
1934 if (!(flags & FL_EXCL))
1935 flags |= INET_REUSEADDR; /* NEW: reuse, unless exclusive */
1936
1937 *hostp = host;
1938 *servicep = service;
1939 *inet_flagp = flags;
1940
1941 return 0;
1942 }
1943