1 /* $Id$
2
3 Part of SWI-Prolog
4
5 Author: Jan Wielemaker
6 E-mail: wielemak@science.uva.nl
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 1985-2008, University of Amsterdam
9
10 This library is free software; you can redistribute it and/or
11 modify it under the terms of the GNU Lesser General Public
12 License as published by the Free Software Foundation; either
13 version 2.1 of the License, or (at your option) any later version.
14
15 This library is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 Lesser General Public License for more details.
19
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 */
24
25 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
26 This module is far too big. It defines a layer around open(), etc. to
27 get opening and closing of files to the symbolic level required for
28 Prolog. It also defines basic I/O predicates, stream based I/O and
29 finally a bundle of operations on files, such as name expansion,
30 renaming, deleting, etc. Most of this module is rather straightforward.
31
32 If time is there I will have a look at all this to clean it. Notably
33 handling times must be cleaned, but that not only holds for this module.
34 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
35
36 /*#define O_DEBUG 1*/
37 /*#define O_DEBUG_MT 1*/
38
39 #include "pl-incl.h"
40 #include "pl-ctype.h"
41 #include "pl-utf8.h"
42 #include <errno.h>
43
44 #ifdef HAVE_SYS_SELECT_H
45 #include <sys/select.h>
46 #endif
47 #ifdef HAVE_SYS_TIME_H
48 #include <sys/time.h>
49 #endif
50 #ifdef HAVE_SYS_PARAM_H
51 #include <sys/param.h>
52 #endif
53 #ifdef HAVE_SYS_FILE_H
54 #include <sys/file.h>
55 #endif
56 #ifdef HAVE_UNISTD_H
57 #include <unistd.h>
58 #endif
59 #ifdef HAVE_BSTRING_H
60 #include <bstring.h>
61 #endif
62 #ifdef HAVE_SYS_STAT_H
63 #include <sys/stat.h>
64 #endif
65 #ifdef HAVE_WINSOCK2_H
66 #include <winsock2.h>
67 #endif
68
69 #define LOCK() PL_LOCK(L_FILE) /* MT locking */
70 #define UNLOCK() PL_UNLOCK(L_FILE)
71
72 #undef LD /* fetch LD once per function */
73 #define LD LOCAL_LD
74
75 static int bad_encoding(const char *msg, atom_t name);
76 static int noprotocol(void);
77
78 static int streamStatus(IOSTREAM *s);
79
80 const atom_t standardStreams[] =
81 { ATOM_user_input, /* 0 */
82 ATOM_user_output, /* 1 */
83 ATOM_user_error, /* 2 */
84 ATOM_current_input, /* 3 */
85 ATOM_current_output, /* 4 */
86 ATOM_protocol, /* 5 */
87 NULL_ATOM
88 };
89
90
91 static int
standardStreamIndexFromName(atom_t name)92 standardStreamIndexFromName(atom_t name)
93 { const atom_t *ap;
94
95 for(ap=standardStreams; *ap; ap++)
96 { if ( *ap == name )
97 return (int)(ap - standardStreams);
98 }
99
100 return -1;
101 }
102
103
104 static int
standardStreamIndexFromStream(IOSTREAM * s)105 standardStreamIndexFromStream(IOSTREAM *s)
106 { GET_LD
107 IOSTREAM **sp = LD->IO.streams;
108 int i = 0;
109
110 for( ; i<6; i++, sp++ )
111 { if ( *sp == s )
112 return i;
113 }
114
115 return -1;
116 }
117
118
119 /*******************************
120 * BOOKKEEPING *
121 *******************************/
122
123 static void aliasStream(IOSTREAM *s, atom_t alias);
124 static void unaliasStream(IOSTREAM *s, atom_t name);
125
126 static Table streamAliases; /* alias --> stream */
127 static Table streamContext; /* stream --> extra data */
128
129 typedef struct _alias
130 { struct _alias *next;
131 atom_t name;
132 } alias;
133
134
135 #define IO_TELL 0x001 /* opened by tell/1 */
136 #define IO_SEE 0x002 /* opened by see/1 */
137
138 typedef struct
139 { alias *alias_head;
140 alias *alias_tail;
141 atom_t filename; /* associated filename */
142 unsigned flags;
143 } stream_context;
144
145
146 static stream_context *
getStreamContext(IOSTREAM * s)147 getStreamContext(IOSTREAM *s)
148 { Symbol symb;
149
150 if ( !(symb = lookupHTable(streamContext, s)) )
151 { GET_LD
152 stream_context *ctx = allocHeap(sizeof(*ctx));
153
154 DEBUG(1, Sdprintf("Created ctx=%p for stream %p\n", ctx, s));
155
156 ctx->alias_head = ctx->alias_tail = NULL;
157 ctx->filename = NULL_ATOM;
158 ctx->flags = 0;
159 addHTable(streamContext, s, ctx);
160
161 return ctx;
162 }
163
164 return symb->value;
165 }
166
167
168 void
aliasStream(IOSTREAM * s,atom_t name)169 aliasStream(IOSTREAM *s, atom_t name)
170 { GET_LD
171 stream_context *ctx;
172 Symbol symb;
173 alias *a;
174
175 /* ensure name is free (error?) */
176 if ( (symb = lookupHTable(streamAliases, (void *)name)) )
177 unaliasStream(symb->value, name);
178
179 ctx = getStreamContext(s);
180 addHTable(streamAliases, (void *)name, s);
181 PL_register_atom(name);
182
183 a = allocHeap(sizeof(*a));
184 a->next = NULL;
185 a->name = name;
186
187 if ( ctx->alias_tail )
188 { ctx->alias_tail->next = a;
189 ctx->alias_tail = a;
190 } else
191 { ctx->alias_head = ctx->alias_tail = a;
192 }
193 }
194
195 /* MT: Locked by freeStream()
196 */
197
198 static void
unaliasStream(IOSTREAM * s,atom_t name)199 unaliasStream(IOSTREAM *s, atom_t name)
200 { GET_LD
201 Symbol symb;
202
203 if ( name )
204 { if ( (symb = lookupHTable(streamAliases, (void *)name)) )
205 { deleteSymbolHTable(streamAliases, symb);
206
207 if ( (symb=lookupHTable(streamContext, s)) )
208 { stream_context *ctx = symb->value;
209 alias **a;
210
211 for(a = &ctx->alias_head; *a; a = &(*a)->next)
212 { if ( (*a)->name == name )
213 { alias *tmp = *a;
214
215 *a = tmp->next;
216 freeHeap(tmp, sizeof(*tmp));
217 if ( tmp == ctx->alias_tail )
218 ctx->alias_tail = NULL;
219
220 break;
221 }
222 }
223 }
224
225 PL_unregister_atom(name);
226 }
227 } else /* delete them all */
228 { if ( (symb=lookupHTable(streamContext, s)) )
229 { stream_context *ctx = symb->value;
230 alias *a, *n;
231
232 for(a = ctx->alias_head; a; a=n)
233 { Symbol s2;
234
235 n = a->next;
236
237 if ( (s2 = lookupHTable(streamAliases, (void *)a->name)) )
238 { deleteSymbolHTable(streamAliases, s2);
239 PL_unregister_atom(a->name);
240 }
241
242 freeHeap(a, sizeof(*a));
243 }
244
245 ctx->alias_head = ctx->alias_tail = NULL;
246 }
247 }
248 }
249
250
251 static void
freeStream(IOSTREAM * s)252 freeStream(IOSTREAM *s)
253 { GET_LD
254 Symbol symb;
255 int i;
256 IOSTREAM **sp;
257
258 DEBUG(1, Sdprintf("freeStream(%p)\n", s));
259
260 LOCK();
261 unaliasStream(s, NULL_ATOM);
262 if ( (symb=lookupHTable(streamContext, s)) )
263 { stream_context *ctx = symb->value;
264
265 if ( ctx->filename != NULL_ATOM )
266 { PL_unregister_atom(ctx->filename);
267
268 if ( ctx->filename == source_file_name )
269 { source_file_name = NULL_ATOM; /* TBD: pop? */
270 source_line_no = -1;
271 }
272 }
273
274 freeHeap(ctx, sizeof(*ctx));
275 deleteSymbolHTable(streamContext, symb);
276 }
277 /* if we are a standard stream */
278 /* reassociate with standard I/O */
279 /* NOTE: there may be more! */
280 for(i=0, sp = LD->IO.streams; i<6; i++, sp++)
281 { if ( *sp == s )
282 { if ( s->flags & SIO_INPUT )
283 *sp = Sinput;
284 else if ( sp == &Suser_error )
285 *sp = Serror;
286 else if ( sp == &Sprotocol )
287 *sp = NULL;
288 else
289 *sp = Soutput;
290 }
291 }
292 UNLOCK();
293 }
294
295
296 /* MT: locked by caller (openStream()) */
297 /* name must be registered by the caller */
298
299 static void
setFileNameStream(IOSTREAM * s,atom_t name)300 setFileNameStream(IOSTREAM *s, atom_t name)
301 { stream_context *ctx = getStreamContext(s);
302
303 if ( ctx->filename )
304 { PL_unregister_atom(ctx->filename);
305 ctx->filename = NULL_ATOM;
306 }
307 if ( name != NULL_ATOM )
308 ctx->filename = name;
309 }
310
311
312 static atom_t
fileNameStream(IOSTREAM * s)313 fileNameStream(IOSTREAM *s)
314 { atom_t name;
315
316 LOCK();
317 name = getStreamContext(s)->filename;
318 UNLOCK();
319
320 return name;
321 }
322
323 #if __YAP_PROLOG__
324 static void
325 init_yap_extras(void);
326 #endif
327
328 void
initIO()329 initIO()
330 { GET_LD
331 const atom_t *np;
332 int i;
333
334 #if __YAP_PROLOG__
335 init_yap_extras();
336 #endif
337 streamAliases = newHTable(16);
338 streamContext = newHTable(16);
339 #ifdef __unix__
340 { int fd;
341
342 if ( (fd=Sfileno(Sinput)) < 0 || !isatty(fd) ||
343 (fd=Sfileno(Soutput)) < 0 || !isatty(fd) )
344 PL_set_prolog_flag("tty_control", PL_BOOL, FALSE);
345 }
346 #endif
347 ResetTty();
348
349 Sclosehook(freeStream);
350
351 Sinput->position = &Sinput->posbuf; /* position logging */
352 Soutput->position = &Sinput->posbuf;
353 Serror->position = &Sinput->posbuf;
354
355 ttymode = TTY_COOKED;
356 PushTty(Sinput, &ttytab, TTY_SAVE);
357 LD->prompt.current = ATOM_prompt;
358 PL_register_atom(ATOM_prompt);
359
360 Suser_input = Sinput;
361 Suser_output = Soutput;
362 Suser_error = Serror;
363 Scurin = Sinput; /* see/tell */
364 Scurout = Soutput;
365 Sprotocol = NULL; /* protocolling */
366
367 getStreamContext(Sinput); /* add for enumeration */
368 getStreamContext(Soutput);
369 getStreamContext(Serror);
370 for( i=0, np = standardStreams; *np; np++, i++ )
371 addHTable(streamAliases, (void *)*np, (void *)(intptr_t)i);
372
373 GD->io_initialised = TRUE;
374 }
375
376 /*******************************
377 * GET HANDLES *
378 *******************************/
379
380 #ifdef O_PLMT
381
382 static inline IOSTREAM *
getStream(IOSTREAM * s)383 getStream(IOSTREAM *s)
384 { if ( s && s->magic == SIO_MAGIC ) /* TBD: ensure visibility? */
385 { Slock(s);
386 return s;
387 }
388
389 return NULL;
390 }
391
392 static inline IOSTREAM *
tryGetStream(IOSTREAM * s)393 tryGetStream(IOSTREAM *s)
394 { if ( s && s->magic == SIO_MAGIC && StryLock(s) == 0 )
395 return s;
396
397 return NULL;
398 }
399
400 static inline void
releaseStream(IOSTREAM * s)401 releaseStream(IOSTREAM *s)
402 { if ( s->magic == SIO_MAGIC )
403 Sunlock(s);
404 }
405
406 #else /*O_PLMT*/
407
408 #define getStream(s) (s)
409 #define tryGetStream(s) (s)
410 #define releaseStream(s)
411
412 #endif /*O_PLMT*/
413
414 int
PL_release_stream(IOSTREAM * s)415 PL_release_stream(IOSTREAM *s)
416 { if ( Sferror(s) )
417 return streamStatus(s);
418
419 releaseStream(s);
420 return TRUE;
421 }
422
423
424 #define SH_ERRORS 0x01 /* generate errors */
425 #define SH_ALIAS 0x02 /* allow alias */
426 #define SH_UNLOCKED 0x04 /* don't lock the stream */
427 #define SH_SAFE 0x08 /* Lookup in table */
428
429 static int
get_stream_handle__LD(term_t t,IOSTREAM ** s,int flags ARG_LD)430 get_stream_handle__LD(term_t t, IOSTREAM **s, int flags ARG_LD)
431 { atom_t alias;
432
433 if ( PL_is_functor(t, FUNCTOR_dstream1) )
434 { void *p;
435 term_t a = PL_new_term_ref();
436
437 _PL_get_arg(1, t, a);
438 if ( PL_get_pointer(a, &p) )
439 { if ( flags & SH_SAFE )
440 { Symbol symb;
441
442 LOCK();
443 symb = lookupHTable(streamContext, p);
444 UNLOCK();
445
446 if ( !symb )
447 goto noent;
448 }
449
450 if ( flags & SH_UNLOCKED )
451 { if ( ((IOSTREAM *)p)->magic == SIO_MAGIC )
452 { *s = p;
453 return TRUE;
454 }
455 goto noent;
456 }
457
458 if ( (*s = getStream(p)) )
459 return TRUE;
460
461 goto noent;
462 }
463 } else if ( PL_get_atom(t, &alias) )
464 { Symbol symb;
465
466 if ( !(flags & SH_UNLOCKED) )
467 LOCK();
468 if ( (symb=lookupHTable(streamAliases, (void *)alias)) )
469 { IOSTREAM *stream;
470 uintptr_t n = (uintptr_t)symb->value;
471
472 if ( n < 6 ) /* standard stream! */
473 { stream = LD->IO.streams[n];
474 } else
475 stream = symb->value;
476
477 if ( !(flags & SH_UNLOCKED) )
478 UNLOCK();
479
480 if ( stream )
481 { if ( (flags & SH_UNLOCKED) )
482 { if ( stream->magic == SIO_MAGIC )
483 { *s = stream;
484 return TRUE;
485 }
486 } else if ( (*s = getStream(stream)) )
487 return TRUE;
488 goto noent;
489 }
490 }
491 if ( !(flags & SH_UNLOCKED) )
492 UNLOCK();
493
494 goto noent;
495 }
496
497 if ( flags & SH_ERRORS )
498 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
499 (flags&SH_ALIAS) ? ATOM_stream_or_alias : ATOM_stream, t);
500
501 return FALSE;
502
503 noent:
504 if ( flags & SH_ERRORS )
505 PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_stream, t);
506 return FALSE;
507 }
508
509 #define get_stream_handle(t, sp, flags) \
510 get_stream_handle__LD(t, sp, flags PASS_LD)
511
512 X_API int
PL_get_stream_handle(term_t t,IOSTREAM ** s)513 PL_get_stream_handle(term_t t, IOSTREAM **s)
514 { GET_LD
515 return get_stream_handle(t, s, SH_ERRORS|SH_ALIAS);
516 }
517
518 X_API int
PL_unify_stream_or_alias(term_t t,IOSTREAM * s)519 PL_unify_stream_or_alias(term_t t, IOSTREAM *s)
520 { GET_LD
521 int rval;
522 stream_context *ctx;
523 int i;
524
525 if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
526 return PL_unify_atom(t, standardStreams[i]);
527
528 LOCK();
529 ctx = getStreamContext(s);
530 if ( ctx->alias_head )
531 { rval = PL_unify_atom(t, ctx->alias_head->name);
532 } else
533 { term_t a = PL_new_term_ref();
534
535 rval = ( (a=PL_new_term_ref()) &&
536 PL_put_pointer(a, s) &&
537 PL_cons_functor(a, FUNCTOR_dstream1, a) &&
538 PL_unify(t, a)
539 );
540 }
541 UNLOCK();
542
543 if ( !rval && !PL_is_variable(t) )
544 return PL_error(NULL, 0, "stream-argument", ERR_MUST_BE_VAR, 0);
545
546 return rval;
547 }
548
549
550 int
PL_unify_stream(term_t t,IOSTREAM * s)551 PL_unify_stream(term_t t, IOSTREAM *s)
552 { GET_LD
553 stream_context *ctx;
554 term_t a = PL_new_term_ref();
555
556 LOCK();
557 ctx = getStreamContext(s);
558 UNLOCK();
559
560 if ( !(a = PL_new_term_ref()) ||
561 !PL_put_pointer(a, s) ||
562 !PL_cons_functor(a, FUNCTOR_dstream1, a) )
563 return FALSE; /* resource error */
564
565 if ( PL_unify(t, a) )
566 return TRUE;
567 if ( PL_is_functor(t, FUNCTOR_dstream1) )
568 return FALSE;
569
570 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream, t);
571 }
572
573
574 IOSTREAM ** /* provide access to Suser_input, */
_PL_streams(void)575 _PL_streams(void) /* Suser_output and Suser_error */
576 { GET_LD
577 return &Suser_input;
578 }
579
580
581 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
582 getInputStream(term_t t, IOSTREAM **s)
583 getOutputStream(term_t t, IOSTREAM **s)
584 These functions are the basis used by all Prolog predicates to get
585 a input or output stream handle. If t = 0, current input/output is
586 returned. This allows us to define the standard-stream based version
587 simply by calling the explicit stream-based version with 0 for the
588 stream argument.
589
590 MT: The returned stream is always locked and should be returned
591 using releaseStream() or streamStatus().
592 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
593
594 static int
getOutputStream(term_t t,IOSTREAM ** stream)595 getOutputStream(term_t t, IOSTREAM **stream)
596 { GET_LD
597 atom_t a;
598 IOSTREAM *s;
599
600 if ( t == 0 )
601 { *stream = getStream(Scurout);
602 return TRUE;
603 } else if ( PL_get_atom(t, &a) && a == ATOM_user )
604 { *stream = getStream(Suser_output);
605 return TRUE;
606 } else
607 { *stream = NULL; /* make compiler happy */
608 }
609
610 if ( !PL_get_stream_handle(t, &s) )
611 return FALSE;
612
613 if ( !(s->flags &SIO_OUTPUT) )
614 { releaseStream(s);
615 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
616 ATOM_output, ATOM_stream, t);
617 }
618
619 *stream = s;
620 return TRUE;
621 }
622
623
624 static int
getInputStream__LD(term_t t,IOSTREAM ** stream ARG_LD)625 getInputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
626 { atom_t a;
627 IOSTREAM *s;
628
629 if ( t == 0 )
630 { *stream = getStream(Scurin);
631 return TRUE;
632 } else if ( PL_get_atom(t, &a) && a == ATOM_user )
633 { *stream = getStream(Suser_input);
634 return TRUE;
635 } else
636 { *stream = NULL; /* make compiler happy */
637 }
638
639 if ( !get_stream_handle(t, &s, SH_ERRORS|SH_ALIAS) )
640 return FALSE;
641
642 if ( !(s->flags &SIO_INPUT) )
643 { releaseStream(s);
644 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
645 ATOM_input, ATOM_stream, t);
646 }
647
648 *stream = s;
649 return TRUE;
650 }
651
652
653 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
654 In windows GUI applications, the IO-streams are not bound. We do not
655 wish to generate an error on the stream errors that may be caused by
656 this. It is a bit of a hack, but the alternative is to define a stream
657 that ignores the error. This might get hairy if the user is playing with
658 these streams too.
659 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
660
661 #if defined(__WINDOWS__) || defined(__MINGW32__)
662 static int
isConsoleStream(IOSTREAM * s)663 isConsoleStream(IOSTREAM *s)
664 { int i = standardStreamIndexFromStream(s);
665
666 return i >= 0 && i < 3;
667 }
668 #else
669 #define isConsoleStream(s) FALSE
670 #endif
671
672
673 int
reportStreamError(IOSTREAM * s)674 reportStreamError(IOSTREAM *s)
675 { if ( GD->cleaning == CLN_NORMAL &&
676 !isConsoleStream(s) &&
677 (s->flags & (SIO_FERR|SIO_WARN)) )
678 { GET_LD
679 atom_t op;
680 term_t stream = PL_new_term_ref();
681 char *msg;
682
683 PL_unify_stream_or_alias(stream, s);
684
685 if ( (s->flags & SIO_FERR) )
686 { if ( s->exception )
687 { fid_t fid;
688 term_t ex;
689 int rc;
690
691 LD->exception.processing = TRUE; /* allow using spare stack */
692 if ( !(fid = PL_open_foreign_frame()) )
693 return FALSE;
694 ex = PL_new_term_ref();
695 rc = PL_recorded(s->exception, ex);
696 PL_erase(s->exception);
697 s->exception = NULL;
698 if ( rc )
699 rc = PL_raise_exception(ex);
700 PL_close_foreign_frame(fid);
701 return rc;
702 }
703
704 if ( s->flags & SIO_INPUT )
705 { if ( Sfpasteof(s) )
706 { return PL_error(NULL, 0, NULL, ERR_PERMISSION,
707 ATOM_input, ATOM_past_end_of_stream, stream);
708 } else if ( (s->flags & SIO_TIMEOUT) )
709 { PL_error(NULL, 0, NULL, ERR_TIMEOUT,
710 ATOM_read, stream);
711 Sclearerr(s);
712 return FALSE;
713 } else
714 op = ATOM_read;
715 } else
716 op = ATOM_write;
717
718 if ( s->message )
719 { msg = s->message;
720 } else
721 { msg = MSG_ERRNO;
722 if ( s->io_errno )
723 errno = s->io_errno;
724 }
725
726 PL_error(NULL, 0, msg, ERR_STREAM_OP, op, stream);
727
728 if ( (s->flags & SIO_CLEARERR) )
729 Sseterr(s, SIO_FERR, NULL);
730
731 return FALSE;
732 } else
733 { printMessage(ATOM_warning,
734 PL_FUNCTOR_CHARS, "io_warning", 2,
735 PL_TERM, stream,
736 PL_CHARS, s->message);
737
738 Sseterr(s, SIO_WARN, NULL);
739 }
740 }
741
742 return TRUE;
743 }
744
745
746 static int
streamStatus(IOSTREAM * s)747 streamStatus(IOSTREAM *s)
748 { if ( (s->flags & (SIO_FERR|SIO_WARN)) )
749 { releaseStream(s);
750 return reportStreamError(s);
751 }
752
753 releaseStream(s);
754 return TRUE;
755 }
756
757
758 /*******************************
759 * TTY MODES *
760 *******************************/
761
762 ttybuf ttytab; /* saved terminal status on entry */
763 int ttymode; /* Current tty mode */
764
765 typedef struct input_context * InputContext;
766 typedef struct output_context * OutputContext;
767
768 struct input_context
769 { IOSTREAM * stream; /* pushed input */
770 atom_t term_file; /* old term_position file */
771 int term_line; /* old term_position line */
772 InputContext previous; /* previous context */
773 };
774
775
776 struct output_context
777 { IOSTREAM * stream; /* pushed output */
778 OutputContext previous; /* previous context */
779 };
780
781 #define input_context_stack (LD->IO.input_stack)
782 #define output_context_stack (LD->IO.output_stack)
783
784 static IOSTREAM *openStream(term_t file, term_t mode, term_t options);
785
786 void
dieIO()787 dieIO()
788 { if ( GD->io_initialised )
789 { noprotocol();
790 closeFiles(TRUE);
791 PopTty(Sinput, &ttytab);
792 }
793 }
794
795
796 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
797 closeStream() performs Prolog-level closing. Most important right now is
798 to to avoid closing the user-streams. If a stream cannot be flushed (due
799 to a write-error), an exception is generated.
800
801 MT: We assume the stream is locked and will unlock it here.
802 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
803
804 static int
closeStream(IOSTREAM * s)805 closeStream(IOSTREAM *s)
806 { if ( s == Sinput )
807 { Sclearerr(s);
808 releaseStream(s);
809 } else if ( s == Soutput || s == Serror )
810 { if ( Sflush(s) < 0 )
811 return streamStatus(s);
812 releaseStream(s);
813 } else
814 { if ( !Sferror(s) && Sflush(s) < 0 )
815 { streamStatus(s);
816 Sclose(s);
817 return FALSE;
818 }
819 if ( Sclose(s) < 0 ) /* will unlock as well */
820 return FALSE;
821 }
822
823 return TRUE;
824 }
825
826
827 void
closeFiles(int all)828 closeFiles(int all)
829 { GET_LD
830 TableEnum e;
831 Symbol symb;
832
833 e = newTableEnum(streamContext);
834 while( (symb=advanceTableEnum(e)) )
835 { IOSTREAM *s = symb->name;
836
837 if ( all || !(s->flags & SIO_NOCLOSE) )
838 { IOSTREAM *s2 = tryGetStream(s);
839
840 if ( s2 )
841 { if ( !all )
842 { term_t t = PL_new_term_ref();
843
844 PL_unify_stream_or_alias(t, s2);
845 printMessage(ATOM_informational,
846 PL_FUNCTOR, FUNCTOR_close_on_abort1,
847 PL_TERM, t);
848 PL_reset_term_refs(t);
849 }
850
851 closeStream(s2);
852 }
853 }
854 }
855 freeTableEnum(e);
856 }
857
858
859 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
860 PL_cleanup_fork() must be called between fork() and exec() to remove
861 traces of Prolog that are not supposed to leak into the new process.
862 Note that we must be careful here. Notably, the code cannot lock or
863 unlock any mutex as the behaviour of mutexes is undefined over fork().
864
865 Earlier versions used the file-table to close file descriptors that are
866 in use by Prolog. This can't work as the table is guarded by a mutex.
867 Now we use the FD_CLOEXEC flag in Snew();
868 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
869
870 X_API void
PL_cleanup_fork(void)871 PL_cleanup_fork(void)
872 { stopItimer();
873 }
874
875
876 void
protocol(const char * str,size_t n)877 protocol(const char *str, size_t n)
878 { GET_LD
879 IOSTREAM *s;
880
881 if ( LD && (s = getStream(Sprotocol)) )
882 { while( n-- > 0 )
883 Sputcode(*str++&0xff, s);
884 Sflush(s);
885 releaseStream(s); /* we don not check errors */
886 }
887 }
888
889
890 /*******************************
891 * TEMPORARY I/O *
892 *******************************/
893
894
895 static int
push_input_context(void)896 push_input_context(void)
897 { GET_LD
898 InputContext c = allocHeap(sizeof(struct input_context));
899
900 c->stream = Scurin;
901 c->term_file = source_file_name;
902 c->term_line = source_line_no;
903 c->previous = input_context_stack;
904 input_context_stack = c;
905
906 return TRUE;
907 }
908
909
910 static int
pop_input_context(void)911 pop_input_context(void)
912 { GET_LD
913 InputContext c = input_context_stack;
914
915 if ( c )
916 { Scurin = c->stream;
917 source_file_name = c->term_file;
918 source_line_no = c->term_line;
919 input_context_stack = c->previous;
920 freeHeap(c, sizeof(struct input_context));
921
922 return TRUE;
923 } else
924 { Scurin = Sinput;
925 return FALSE;
926 }
927 }
928
929
930 static
931 PRED_IMPL("$push_input_context", 0, push_input_context, 0)
932 { return push_input_context();
933 }
934
935
936 static
937 PRED_IMPL("$pop_input_context", 0, pop_input_context, 0)
938 { return pop_input_context();
939 }
940
941
942 static void
pushOutputContext(void)943 pushOutputContext(void)
944 { GET_LD
945 OutputContext c = allocHeap(sizeof(struct output_context));
946
947 c->stream = Scurout;
948 c->previous = output_context_stack;
949 output_context_stack = c;
950 }
951
952
953 static void
popOutputContext(void)954 popOutputContext(void)
955 { GET_LD
956 OutputContext c = output_context_stack;
957
958 if ( c )
959 { if ( c->stream->magic == SIO_MAGIC )
960 Scurout = c->stream;
961 else
962 { Sdprintf("Oops, current stream closed?");
963 Scurout = Soutput;
964 }
965 output_context_stack = c->previous;
966 freeHeap(c, sizeof(struct output_context));
967 } else
968 Scurout = Soutput;
969 }
970
971
972 int
setupOutputRedirect(term_t to,redir_context * ctx,int redir)973 setupOutputRedirect(term_t to, redir_context *ctx, int redir)
974 { GET_LD
975 atom_t a;
976
977 ctx->term = to;
978 ctx->redirected = redir;
979
980 if ( to == 0 )
981 { ctx->stream = getStream(Scurout);
982 ctx->is_stream = TRUE;
983 } else if ( PL_get_atom(to, &a) && a == ATOM_user )
984 { ctx->stream = getStream(Suser_output);
985 ctx->is_stream = TRUE;
986 } else if ( get_stream_handle(to, &ctx->stream, SH_SAFE) )
987 { if ( !(ctx->stream->flags &SIO_OUTPUT) )
988 { releaseStream(ctx->stream);
989 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
990 ATOM_output, ATOM_stream, to);
991 }
992
993 ctx->is_stream = TRUE;
994 } else
995 { if ( PL_is_functor(to, FUNCTOR_codes2) )
996 { ctx->out_format = PL_CODE_LIST;
997 ctx->out_arity = 2;
998 } else if ( PL_is_functor(to, FUNCTOR_codes1) )
999 { ctx->out_format = PL_CODE_LIST;
1000 ctx->out_arity = 1;
1001 } else if ( PL_is_functor(to, FUNCTOR_chars2) )
1002 { ctx->out_format = PL_CHAR_LIST;
1003 ctx->out_arity = 2;
1004 } else if ( PL_is_functor(to, FUNCTOR_chars1) )
1005 { ctx->out_format = PL_CHAR_LIST;
1006 ctx->out_arity = 1;
1007 } else if ( PL_is_functor(to, FUNCTOR_string1) )
1008 { ctx->out_format = PL_STRING;
1009 ctx->out_arity = 1;
1010 } else if ( PL_is_functor(to, FUNCTOR_atom1) )
1011 { ctx->out_format = PL_ATOM;
1012 ctx->out_arity = 1;
1013 } else
1014 { return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_output, to);
1015 }
1016
1017 ctx->is_stream = FALSE;
1018 ctx->data = ctx->buffer;
1019 ctx->size = sizeof(ctx->buffer);
1020 ctx->stream = Sopenmem(&ctx->data, &ctx->size, "w");
1021 ctx->stream->encoding = ENC_WCHAR;
1022 }
1023
1024 ctx->magic = REDIR_MAGIC;
1025
1026 if ( redir )
1027 { pushOutputContext();
1028 Scurout = ctx->stream;
1029 }
1030
1031 return TRUE;
1032 }
1033
1034
1035 int
closeOutputRedirect(redir_context * ctx)1036 closeOutputRedirect(redir_context *ctx)
1037 { int rval = TRUE;
1038
1039 if ( ctx->magic != REDIR_MAGIC )
1040 return rval; /* already done */
1041 ctx->magic = 0;
1042
1043 if ( ctx->redirected )
1044 popOutputContext();
1045
1046 if ( ctx->is_stream )
1047 { rval = streamStatus(ctx->stream);
1048 } else
1049 { GET_LD
1050 term_t out = PL_new_term_ref();
1051 term_t diff, tail;
1052
1053 closeStream(ctx->stream);
1054 _PL_get_arg(1, ctx->term, out);
1055 if ( ctx->out_arity == 2 )
1056 { diff = PL_new_term_ref();
1057 _PL_get_arg(2, ctx->term, diff);
1058 tail = PL_new_term_ref();
1059 } else
1060 { diff = tail = 0;
1061 }
1062
1063 rval = PL_unify_wchars_diff(out, tail, ctx->out_format,
1064 ctx->size/sizeof(wchar_t),
1065 (wchar_t*)ctx->data);
1066 if ( rval && tail )
1067 rval = PL_unify(tail, diff);
1068
1069 if ( ctx->data != ctx->buffer )
1070 Sfree(ctx->data);
1071 }
1072
1073 return rval;
1074 }
1075
1076
1077 void
discardOutputRedirect(redir_context * ctx)1078 discardOutputRedirect(redir_context *ctx)
1079 { if ( ctx->magic != REDIR_MAGIC )
1080 return; /* already done */
1081
1082 ctx->magic = 0;
1083
1084 if ( ctx->redirected )
1085 popOutputContext();
1086
1087 if ( ctx->is_stream )
1088 { releaseStream(ctx->stream);
1089 } else
1090 { closeStream(ctx->stream);
1091 if ( ctx->data != ctx->buffer )
1092 Sfree(ctx->data);
1093 }
1094 }
1095
1096
1097 static
1098 PRED_IMPL("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
1099 { redir_context outctx;
1100
1101 if ( setupOutputRedirect(A1, &outctx, TRUE) )
1102 { term_t ex = 0;
1103 int rval;
1104
1105 if ( (rval = callProlog(NULL, A2, PL_Q_CATCH_EXCEPTION, &ex)) )
1106 return closeOutputRedirect(&outctx);
1107 discardOutputRedirect(&outctx);
1108 if ( ex )
1109 return PL_raise_exception(ex);
1110 }
1111
1112 return FALSE;
1113 }
1114
1115
1116
1117 void
PL_write_prompt(int dowrite)1118 PL_write_prompt(int dowrite)
1119 { GET_LD
1120 IOSTREAM *s = getStream(Suser_output);
1121
1122 if ( s )
1123 { if ( dowrite )
1124 { atom_t a = PrologPrompt();
1125
1126 if ( a )
1127 writeAtomToStream(s, a);
1128 }
1129
1130 Sflush(s);
1131 releaseStream(s);
1132 }
1133
1134 LD->prompt.next = FALSE;
1135 }
1136
1137
1138 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1139 Get a single character from Sinput without waiting for a return. The
1140 character should not be echoed. If PLFLAG_TTY_CONTROL is false this
1141 function will read the first character and then skip all character upto
1142 and including the newline.
1143 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1144
1145 static int
Sgetcode_intr(IOSTREAM * s,int signals)1146 Sgetcode_intr(IOSTREAM *s, int signals)
1147 { int c;
1148
1149 #ifdef __WINDOWS__
1150 int newline = s->newline;
1151 s->newline = SIO_NL_POSIX; /* avoid blocking \r */
1152 #endif
1153 do
1154 { Sclearerr(s);
1155 c = Sgetcode(s);
1156 } while ( c == -1 &&
1157 errno == EINTR &&
1158 (!signals || PL_handle_signals() >= 0)
1159 );
1160 #ifdef __WINDOWS__
1161 s->newline = newline;
1162 #endif
1163
1164 return c;
1165 }
1166
1167
1168 static int
getSingleChar(IOSTREAM * stream,int signals)1169 getSingleChar(IOSTREAM *stream, int signals)
1170 { GET_LD
1171 int c;
1172 ttybuf buf;
1173
1174 #if __SWI_PROLOG__
1175 debugstatus.suspendTrace++;
1176 #endif
1177 Slock(stream);
1178 Sflush(stream);
1179 PushTty(stream, &buf, TTY_RAW); /* just donot prompt */
1180
1181 if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
1182 { int c2;
1183
1184 c2 = Sgetcode_intr(stream, signals);
1185 while( c2 == ' ' || c2 == '\t' ) /* skip blanks */
1186 c2 = Sgetcode_intr(stream, signals);
1187 c = c2;
1188 while( c2 != EOF && c2 != '\n' ) /* read upto newline */
1189 c2 = Sgetcode_intr(stream, signals);
1190 } else
1191 { if ( stream->position )
1192 { IOPOS oldpos = *stream->position;
1193 c = Sgetcode_intr(stream, signals);
1194 *stream->position = oldpos;
1195 } else
1196 c = Sgetcode_intr(stream, signals);
1197 }
1198
1199 if ( c == 4 || c == 26 ) /* should ask the terminal! */
1200 c = -1;
1201
1202 PopTty(stream, &buf);
1203 #if __SWI_PROLOG__
1204 debugstatus.suspendTrace--;
1205 #endif
1206 Sunlock(stream);
1207
1208 return c;
1209 }
1210
1211
1212 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1213 readLine() reads a line from the terminal. It is used only by the tracer.
1214 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1215
1216 #ifndef DEL
1217 #define DEL 127
1218 #endif
1219
1220 int
readLine(IOSTREAM * in,IOSTREAM * out,char * buffer)1221 readLine(IOSTREAM *in, IOSTREAM *out, char *buffer)
1222 { GET_LD
1223 int c;
1224 char *buf = &buffer[strlen(buffer)];
1225 ttybuf tbuf;
1226
1227 Slock(in);
1228 Slock(out);
1229
1230 PushTty(in, &tbuf, TTY_RAW); /* just donot prompt */
1231
1232 for(;;)
1233 { Sflush(out);
1234
1235 switch( (c=Sgetcode_intr(in, FALSE)) )
1236 { case '\n':
1237 case '\r':
1238 case EOF:
1239 *buf++ = EOS;
1240 PopTty(in, &tbuf);
1241 Sunlock(in);
1242 Sunlock(out);
1243
1244 return c == EOF ? FALSE : TRUE;
1245 case '\b':
1246 case DEL:
1247 if ( truePrologFlag(PLFLAG_TTY_CONTROL) && buf > buffer )
1248 { Sfputs("\b \b", out);
1249 buf--;
1250 continue;
1251 }
1252 default:
1253 if ( truePrologFlag(PLFLAG_TTY_CONTROL) )
1254 Sputcode(c, out);
1255 *buf++ = c;
1256 }
1257 }
1258 }
1259
1260
1261 IOSTREAM *
PL_current_input()1262 PL_current_input()
1263 { GET_LD
1264 return getStream(Scurin);
1265 }
1266
1267
1268 IOSTREAM *
PL_current_output()1269 PL_current_output()
1270 { GET_LD
1271 return getStream(Scurout);
1272 }
1273
1274
1275 static int
openProtocol(term_t f,int appnd)1276 openProtocol(term_t f, int appnd)
1277 { GET_LD
1278 IOSTREAM *s;
1279 term_t mode = PL_new_term_ref();
1280
1281 noprotocol();
1282
1283 PL_put_atom(mode, appnd ? ATOM_append : ATOM_write);
1284 if ( (s = openStream(f, mode, 0)) )
1285 { s->flags |= SIO_NOCLOSE; /* do not close on abort */
1286
1287 Sprotocol = s;
1288 Suser_input->tee = s;
1289 Suser_output->tee = s;
1290 Suser_error->tee = s;
1291
1292 return TRUE;
1293 }
1294
1295 return FALSE;
1296 }
1297
1298
1299 static int
noprotocol(void)1300 noprotocol(void)
1301 { GET_LD
1302 IOSTREAM *s;
1303
1304 if ( (s = getStream(Sprotocol)) )
1305 { TableEnum e;
1306 Symbol symb;
1307
1308 e = newTableEnum(streamContext);
1309 while( (symb=advanceTableEnum(e)) )
1310 { IOSTREAM *p = symb->name;
1311
1312 if ( p->tee == s )
1313 p->tee = NULL;
1314 }
1315 freeTableEnum(e);
1316
1317 closeStream(s);
1318 Sprotocol = NULL;
1319 }
1320
1321 return TRUE;
1322 }
1323
1324
1325 static
1326 PRED_IMPL("noprotocol", 0, noprotocol, 0)
1327 { return noprotocol();
1328 }
1329
1330
1331 /*******************************
1332 * STREAM ATTRIBUTES *
1333 *******************************/
1334
1335
1336 static
1337 PRED_IMPL("set_stream", 2, set_stream, 0)
1338 { PRED_LD
1339 IOSTREAM *s;
1340 atom_t aname;
1341 int arity;
1342
1343 term_t stream = A1;
1344 term_t attr = A2;
1345
1346 if ( !PL_get_stream_handle(stream, &s) )
1347 return FALSE;
1348
1349 if ( PL_get_name_arity(attr, &aname, &arity) )
1350 { if ( arity == 1 )
1351 { term_t a = PL_new_term_ref();
1352
1353 _PL_get_arg(1, attr, a);
1354
1355 if ( aname == ATOM_alias ) /* alias(name) */
1356 { atom_t alias;
1357 int i;
1358
1359 if ( !PL_get_atom_ex(a, &alias) )
1360 goto error;
1361
1362 if ( (i=standardStreamIndexFromName(alias)) >= 0 )
1363 { LD->IO.streams[i] = s;
1364 if ( i == 0 )
1365 LD->prompt.next = TRUE; /* changed standard input: prompt! */
1366 goto ok;
1367 }
1368
1369 LOCK();
1370 aliasStream(s, alias);
1371 UNLOCK();
1372 goto ok;
1373 } else if ( aname == ATOM_buffer ) /* buffer(Buffering) */
1374 { atom_t b;
1375
1376 #define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF)
1377 if ( !PL_get_atom_ex(a, &b) )
1378 goto error;
1379 if ( b == ATOM_full )
1380 { s->flags &= ~SIO_ABUF;
1381 s->flags |= SIO_FBUF;
1382 } else if ( b == ATOM_line )
1383 { s->flags &= ~SIO_ABUF;
1384 s->flags |= SIO_LBUF;
1385 } else if ( b == ATOM_false )
1386 { Sflush(s);
1387 s->flags &= ~SIO_ABUF;
1388 s->flags |= SIO_NBUF;
1389 } else
1390 { PL_error("set_stream", 2, NULL, ERR_DOMAIN,
1391 ATOM_buffer, a);
1392 goto error;
1393 }
1394 goto ok;
1395 } else if ( aname == ATOM_buffer_size )
1396 { int size;
1397
1398 if ( !PL_get_integer_ex(a, &size) )
1399 goto error;
1400 if ( size < 1 )
1401 { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a);
1402 goto error;
1403 }
1404 Ssetbuffer(s, NULL, size);
1405 goto ok;
1406 } else if ( aname == ATOM_eof_action ) /* eof_action(Action) */
1407 { atom_t action;
1408
1409 if ( !PL_get_atom_ex(a, &action) )
1410 return FALSE;
1411 if ( action == ATOM_eof_code )
1412 { s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR);
1413 } else if ( action == ATOM_reset )
1414 { s->flags &= ~SIO_FEOF2ERR;
1415 s->flags |= SIO_NOFEOF;
1416 } else if ( action == ATOM_error )
1417 { s->flags &= ~SIO_NOFEOF;
1418 s->flags |= SIO_FEOF2ERR;
1419 } else
1420 { PL_error("set_stream", 2, NULL, ERR_DOMAIN,
1421 ATOM_eof_action, a);
1422 goto error;
1423 }
1424
1425 goto ok;
1426 } else if ( aname == ATOM_type ) /* type(Type) */
1427 { atom_t type;
1428
1429 if ( !PL_get_atom_ex(a, &type) )
1430 return FALSE;
1431 if ( type == ATOM_text )
1432 { s->flags |= SIO_TEXT;
1433 } else if ( type == ATOM_binary )
1434 { s->flags &= ~SIO_TEXT;
1435 } else
1436 { PL_error("set_stream", 2, NULL, ERR_DOMAIN,
1437 ATOM_type, a);
1438 goto error;
1439 }
1440
1441 goto ok;
1442 } else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */
1443 { int close;
1444
1445 if ( !PL_get_bool_ex(a, &close) )
1446 goto error;
1447
1448 if ( close )
1449 s->flags &= ~SIO_NOCLOSE;
1450 else
1451 s->flags |= SIO_NOCLOSE;
1452
1453 goto ok;
1454 } else if ( aname == ATOM_record_position )
1455 { int rec;
1456
1457 if ( !PL_get_bool_ex(a, &rec) )
1458 goto error;
1459
1460 if ( rec )
1461 s->position = &s->posbuf;
1462 else
1463 s->position = NULL;
1464
1465 goto ok;
1466 } else if ( aname == ATOM_file_name ) /* file_name(Atom) */
1467 { atom_t fn;
1468
1469 if ( !PL_get_atom_ex(a, &fn) )
1470 goto error;
1471
1472 PL_register_atom(fn);
1473 LOCK();
1474 setFileNameStream(s, fn);
1475 UNLOCK();
1476
1477 goto ok;
1478 } else if ( aname == ATOM_timeout )
1479 { double f;
1480 atom_t v;
1481
1482 if ( PL_get_atom(a, &v) && v == ATOM_infinite )
1483 { s->timeout = -1;
1484 goto ok;
1485 }
1486 if ( !PL_get_float_ex(a, &f) )
1487 goto error;
1488
1489 s->timeout = (int)(f*1000.0);
1490 if ( s->timeout < 0 )
1491 s->timeout = 0;
1492 goto ok;
1493 } else if ( aname == ATOM_tty ) /* tty(bool) */
1494 { int val;
1495
1496 if ( !PL_get_bool_ex(a, &val) )
1497 goto error;
1498
1499 if ( val )
1500 set(s, SIO_ISATTY);
1501 else
1502 clear(s, SIO_ISATTY);
1503
1504 goto ok;
1505 } else if ( aname == ATOM_encoding ) /* encoding(atom) */
1506 { atom_t val;
1507 IOENC enc;
1508
1509 if ( !PL_get_atom_ex(a, &val) )
1510 goto error;
1511 if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN )
1512 { bad_encoding(NULL, val);
1513 goto error;
1514 }
1515
1516 if ( Ssetenc(s, enc, NULL) == 0 )
1517 goto ok;
1518
1519 PL_error(NULL, 0, NULL, ERR_PERMISSION,
1520 ATOM_encoding, ATOM_stream, stream);
1521 goto error;
1522 } else if ( aname == ATOM_representation_errors )
1523 { atom_t val;
1524
1525 if ( !PL_get_atom_ex(a, &val) )
1526 goto error;
1527 clear(s, SIO_REPXML|SIO_REPPL);
1528 if ( val == ATOM_error )
1529 ;
1530 else if ( val == ATOM_xml )
1531 set(s, SIO_REPXML);
1532 else if ( val == ATOM_prolog )
1533 set(s, SIO_REPPL);
1534 else
1535 { PL_error(NULL, 0, NULL, ERR_DOMAIN,
1536 ATOM_representation_errors, a);
1537 goto error;
1538 }
1539 goto ok;
1540 } else if ( aname == ATOM_newline )
1541 { atom_t val;
1542
1543 if ( !PL_get_atom_ex(a, &val) )
1544 goto error;
1545 if ( val == ATOM_posix )
1546 s->newline = SIO_NL_POSIX;
1547 else if ( val == ATOM_dos )
1548 s->newline = SIO_NL_DOS;
1549 else if ( val == ATOM_detect )
1550 { if ( false(s, SIO_INPUT) )
1551 { PL_error(NULL, 0, "detect only allowed for input streams",
1552 ERR_DOMAIN, ATOM_newline, a);
1553 goto error;
1554 }
1555 s->newline = SIO_NL_DETECT;
1556 } else
1557 { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a);
1558 goto error;
1559 }
1560 goto ok;
1561 }
1562 }
1563 }
1564
1565 PL_error("set_stream", 2, NULL, ERR_TYPE,
1566 PL_new_atom("stream_attribute"), attr);
1567 goto error;
1568
1569 ok:
1570 releaseStream(s);
1571 return TRUE;
1572 error:
1573 releaseStream(s);
1574 return FALSE;
1575 }
1576
1577
1578 /********************************
1579 * STRING I/O *
1580 *********************************/
1581
1582 extern IOFUNCTIONS Smemfunctions;
1583
1584 int
tellString(char ** s,size_t * size,IOENC enc)1585 tellString(char **s, size_t *size, IOENC enc)
1586 { GET_LD
1587 IOSTREAM *stream;
1588
1589 stream = Sopenmem(s, size, "w");
1590 stream->encoding = enc;
1591 pushOutputContext();
1592 Scurout = stream;
1593
1594 return TRUE;
1595 }
1596
1597
1598 int
toldString()1599 toldString()
1600 { GET_LD
1601 IOSTREAM *s = getStream(Scurout);
1602
1603 if ( !s )
1604 return TRUE;
1605
1606 if ( s->functions == &Smemfunctions )
1607 { closeStream(s);
1608 popOutputContext();
1609 } else
1610 releaseStream(s);
1611
1612 return TRUE;
1613 }
1614
1615
1616 /********************************
1617 * WAITING FOR INPUT *
1618 ********************************/
1619
1620 #ifndef HAVE_SELECT
1621
1622 static
1623 PRED_IMPL("wait_for_input", 3, wait_for_input, 0)
1624 { return notImplemented("wait_for_input", 3);
1625 }
1626
1627 #else
1628
1629 typedef struct fdentry
1630 { int fd;
1631 term_t stream;
1632 struct fdentry *next;
1633 } fdentry;
1634
1635
1636 static inline term_t
findmap(fdentry * map,int fd)1637 findmap(fdentry *map, int fd)
1638 { for( ; map; map = map->next )
1639 { if ( map->fd == fd )
1640 return map->stream;
1641 }
1642 assert(0);
1643 return 0;
1644 }
1645
1646
1647 static
1648 PRED_IMPL("wait_for_input", 3, wait_for_input, 0)
1649 { PRED_LD
1650 fd_set fds;
1651 struct timeval t, *to;
1652 double time;
1653 int n, max = 0, ret, min = 1 << (INTBITSIZE-2);
1654 fdentry *map = NULL;
1655 term_t head = PL_new_term_ref();
1656 term_t streams = PL_copy_term_ref(A1);
1657 term_t available = PL_copy_term_ref(A2);
1658 term_t ahead = PL_new_term_ref();
1659 int from_buffer = 0;
1660 atom_t a;
1661
1662 term_t timeout = A3;
1663
1664 FD_ZERO(&fds);
1665 while( PL_get_list(streams, head, streams) )
1666 { IOSTREAM *s;
1667 int fd;
1668 fdentry *e;
1669
1670 if ( !PL_get_stream_handle(head, &s) )
1671 return FALSE;
1672 if ( (fd=Sfileno(s)) < 0 )
1673 { releaseStream(s);
1674 return PL_error("wait_for_input", 3, NULL, ERR_DOMAIN,
1675 PL_new_atom("file_stream"), head);
1676 }
1677 releaseStream(s);
1678 /* check for input in buffer */
1679 if ( s->bufp < s->limitp )
1680 { if ( !PL_unify_list(available, ahead, available) ||
1681 !PL_unify(ahead, head) )
1682 return FALSE;
1683 from_buffer++;
1684 }
1685
1686 e = alloca(sizeof(*e));
1687 e->fd = fd;
1688 e->stream = PL_copy_term_ref(head);
1689 e->next = map;
1690 map = e;
1691
1692 #ifdef __WINDOWS__
1693 FD_SET((SOCKET)fd, &fds);
1694 #else
1695 FD_SET(fd, &fds);
1696 #endif
1697
1698 if ( fd > max )
1699 max = fd;
1700 if( fd < min )
1701 min = fd;
1702 }
1703 if ( !PL_get_nil(streams) )
1704 return PL_error("wait_for_input", 3, NULL, ERR_TYPE, ATOM_list, A1);
1705
1706 if ( from_buffer > 0 )
1707 return PL_unify_nil(available);
1708
1709 if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
1710 { to = NULL;
1711 } else if ( PL_is_integer(timeout) )
1712 { long v;
1713
1714 PL_get_long(timeout, &v);
1715 if ( v > 0L )
1716 { t.tv_sec = v;
1717 t.tv_usec = 0;
1718 to = &t;
1719 } else if ( v == 0 )
1720 { to = NULL;
1721 } else
1722 { t.tv_sec = 0;
1723 t.tv_usec = 0;
1724 to = &t;
1725 }
1726 } else
1727 { if ( !PL_get_float(timeout, &time) )
1728 return PL_error("wait_for_input", 3, NULL,
1729 ERR_TYPE, ATOM_float, timeout);
1730
1731 if ( time >= 0.0 )
1732 { t.tv_sec = (int)time;
1733 t.tv_usec = ((int)(time * 1000000) % 1000000);
1734 } else
1735 { t.tv_sec = 0;
1736 t.tv_usec = 0;
1737 }
1738 to = &t;
1739 }
1740
1741 while( (ret=select(max+1, &fds, NULL, NULL, to)) == -1 &&
1742 errno == EINTR )
1743 { fdentry *e;
1744
1745 if ( PL_handle_signals() < 0 )
1746 return FALSE; /* exception */
1747
1748 FD_ZERO(&fds); /* EINTR may leave fds undefined */
1749 for(e=map; e; e=e->next) /* so we rebuild it to be safe */
1750 {
1751 #ifdef __WINDOWS__
1752 FD_SET((SOCKET)e->fd, &fds);
1753 #else
1754 FD_SET(e->fd, &fds);
1755 #endif
1756 }
1757 }
1758
1759 switch(ret)
1760 { case -1:
1761 return PL_error("wait_for_input", 3, MSG_ERRNO, ERR_FILE_OPERATION,
1762 ATOM_select, ATOM_stream, A1);
1763
1764 case 0: /* Timeout */
1765 break;
1766
1767 default: /* Something happend -> check fds */
1768 for(n=min; n <= max; n++)
1769 { if ( FD_ISSET(n, &fds) )
1770 { if ( !PL_unify_list(available, ahead, available) ||
1771 !PL_unify(ahead, findmap(map, n)) )
1772 return FALSE;
1773 }
1774 }
1775 break;
1776 }
1777
1778 return PL_unify_nil(available);
1779 }
1780
1781 #endif /* HAVE_SELECT */
1782
1783
1784 /********************************
1785 * PROLOG CONNECTION *
1786 *********************************/
1787
1788 #define MAX_PENDING SIO_BUFSIZE /* 4096 */
1789
1790 static void
re_buffer(IOSTREAM * s,const char * from,size_t len)1791 re_buffer(IOSTREAM *s, const char *from, size_t len)
1792 { if ( s->bufp < s->limitp )
1793 { size_t size = s->limitp - s->bufp;
1794
1795 memmove(s->buffer, s->bufp, size);
1796 s->bufp = s->buffer;
1797 s->limitp = &s->bufp[size];
1798 } else
1799 { s->bufp = s->limitp = s->buffer;
1800 }
1801
1802 memcpy(s->bufp, from, len);
1803 s->bufp += len;
1804 }
1805
1806
1807 #ifndef HAVE_MBSNRTOWCS
1808 static size_t
mbsnrtowcs(wchar_t * dest,const char ** src,size_t nms,size_t len,mbstate_t * ps)1809 mbsnrtowcs(wchar_t *dest, const char **src,
1810 size_t nms, size_t len, mbstate_t *ps)
1811 { wchar_t c;
1812 const char *us = *src;
1813 const char *es = us+nms;
1814 size_t count = 0;
1815
1816 assert(dest == NULL); /* incomplete implementation */
1817
1818 while(us<es)
1819 { size_t skip = mbrtowc(&c, us, es-us, ps);
1820
1821 if ( skip == (size_t)-1 ) /* error */
1822 { DEBUG(1, Sdprintf("mbsnrtowcs(): bad multibyte seq\n"));
1823 return skip;
1824 }
1825 if ( skip == (size_t)-2 ) /* incomplete */
1826 { *src = us;
1827 return count;
1828 }
1829
1830 count++;
1831 us += skip;
1832 }
1833
1834 *src = us;
1835 return count;
1836 }
1837 #else
1838 #if defined(HAVE_DECL_MBSNRTOWCS) && !HAVE_DECL_MBSNRTOWCS
1839 size_t mbsnrtowcs(wchar_t *dest, const char **src,
1840 size_t nms, size_t len, mbstate_t *ps);
1841 #endif
1842 #endif /*HAVE_MBSNRTOWCS*/
1843
1844 static int
skip_cr(IOSTREAM * s)1845 skip_cr(IOSTREAM *s)
1846 { if ( s->flags&SIO_TEXT )
1847 { switch(s->newline)
1848 { case SIO_NL_DETECT:
1849 s->newline = SIO_NL_DOS;
1850 /*FALLTHROUGH*/
1851 case SIO_NL_DOS:
1852 return TRUE;
1853 }
1854 }
1855 return FALSE;
1856 }
1857
1858
1859 static
1860 PRED_IMPL("read_pending_input", 3, read_pending_input, 0)
1861 { PRED_LD
1862 IOSTREAM *s;
1863
1864 if ( getInputStream(A1, &s) )
1865 { char buf[MAX_PENDING];
1866 ssize_t n;
1867 int64_t off0 = Stell64(s);
1868 IOPOS pos0;
1869 list_ctx ctx;
1870
1871 if ( Sferror(s) )
1872 return streamStatus(s);
1873
1874 n = Sread_pending(s, buf, sizeof(buf), 0);
1875 if ( n < 0 ) /* should not happen */
1876 return streamStatus(s);
1877 if ( n == 0 ) /* end-of-file */
1878 { S__fcheckpasteeof(s, -1);
1879 return PL_unify(A2, A3);
1880 }
1881 if ( s->position )
1882 { pos0 = *s->position;
1883 } else
1884 { memset(&pos0, 0, sizeof(pos0)); /* make compiler happy */
1885 }
1886
1887 switch(s->encoding)
1888 { case ENC_OCTET:
1889 case ENC_ISO_LATIN_1:
1890 case ENC_ASCII:
1891 { ssize_t i;
1892
1893 if ( !allocList(n, &ctx) )
1894 return FALSE;
1895
1896 for(i=0; i<n; i++)
1897 { int c = buf[i]&0xff;
1898
1899 if ( c == '\r' && skip_cr(s) )
1900 continue;
1901
1902 if ( s->position )
1903 S__fupdatefilepos_getc(s, c);
1904
1905 addSmallIntList(&ctx, c);
1906 }
1907 if ( s->position )
1908 s->position->byteno = pos0.byteno+n;
1909
1910 break;
1911 }
1912 case ENC_ANSI:
1913 { size_t count, i;
1914 mbstate_t s0;
1915 const char *us = buf;
1916 const char *es = buf+n;
1917
1918 if ( !s->mbstate )
1919 { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) )
1920 { PL_error(NULL, 0, NULL, ERR_NOMEM);
1921 goto failure;
1922 }
1923 memset(s->mbstate, 0, sizeof(*s->mbstate));
1924 }
1925 s0 = *s->mbstate;
1926 count = mbsnrtowcs(NULL, &us, n, 0, &s0);
1927 if ( count == (size_t)-1 )
1928 { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence");
1929 goto failure;
1930 }
1931
1932 DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
1933 count, n, es-us));
1934
1935 if ( !allocList(count, &ctx) )
1936 return FALSE;
1937
1938 for(us=buf,i=0; i<count; i++)
1939 { wchar_t c;
1940
1941 us += mbrtowc(&c, us, es-us, s->mbstate);
1942 if ( c == '\r' && skip_cr(s) )
1943 continue;
1944 if ( s->position )
1945 S__fupdatefilepos_getc(s, c);
1946
1947 addSmallIntList(&ctx, c);
1948 }
1949 if ( s->position )
1950 s->position->byteno = pos0.byteno+us-buf;
1951
1952 re_buffer(s, us, es-us);
1953 break;
1954 }
1955 case ENC_UTF8:
1956 { const char *us = buf;
1957 const char *es = buf+n;
1958 size_t count = 0, i;
1959
1960 while(us<es)
1961 { const char *ec = us + UTF8_FBN(us[0]) + 1;
1962
1963 if ( ec <= es )
1964 { count++;
1965 us=ec;
1966 } else
1967 break;
1968 }
1969
1970 DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
1971 count, n, es-us));
1972
1973 if ( !allocList(count, &ctx) )
1974 return FALSE;
1975
1976 for(us=buf,i=0; i<count; i++)
1977 { int c;
1978
1979 us = utf8_get_char(us, &c);
1980 if ( c == '\r' && skip_cr(s) )
1981 continue;
1982 if ( s->position )
1983 S__fupdatefilepos_getc(s, c);
1984
1985 addSmallIntList(&ctx, c);
1986 }
1987 if ( s->position )
1988 s->position->byteno = pos0.byteno+us-buf;
1989
1990 re_buffer(s, us, es-us);
1991 break;
1992 }
1993 case ENC_UNICODE_BE:
1994 case ENC_UNICODE_LE:
1995 { size_t count = (size_t)n/2;
1996 const char *us = buf;
1997 size_t done, i;
1998
1999 if ( !allocList(count, &ctx) )
2000 return FALSE;
2001
2002 for(i=0; i<count; us+=2, i++)
2003 { int c;
2004
2005 if ( s->encoding == ENC_UNICODE_BE )
2006 c = ((us[0]&0xff)<<8)+(us[1]&0xff);
2007 else
2008 c = ((us[1]&0xff)<<8)+(us[0]&0xff);
2009 if ( c == '\r' && skip_cr(s) )
2010 continue;
2011
2012 if ( s->position )
2013 S__fupdatefilepos_getc(s, c);
2014
2015 addSmallIntList(&ctx, c);
2016 }
2017
2018 done = count*2;
2019 if ( s->position )
2020 s->position->byteno = pos0.byteno+done;
2021 re_buffer(s, buf+done, n-done);
2022 break;
2023 }
2024 case ENC_WCHAR:
2025 { const pl_wchar_t *ws = (const pl_wchar_t*)buf;
2026 size_t count = (size_t)n/sizeof(pl_wchar_t);
2027 size_t done, i;
2028
2029 if ( !allocList(count, &ctx) )
2030 return FALSE;
2031
2032 for(i=0; i<count; i++)
2033 { int c = ws[i];
2034
2035 if ( c == '\r' && skip_cr(s) )
2036 continue;
2037 if ( s->position )
2038 S__fupdatefilepos_getc(s, c);
2039
2040 addSmallIntList(&ctx, c);
2041 }
2042
2043 done = count*sizeof(pl_wchar_t);
2044 if ( s->position )
2045 s->position->byteno = pos0.byteno+done;
2046 re_buffer(s, buf+done, n-done);
2047 break;
2048 }
2049 case ENC_UNKNOWN:
2050 default:
2051 assert(0);
2052 return FALSE;
2053 }
2054
2055 if ( !unifyDiffList(A2, A3, &ctx) )
2056 goto failure;
2057
2058 releaseStream(s);
2059 return TRUE;
2060
2061 failure:
2062 Sseek64(s, off0, SIO_SEEK_SET); /* TBD: error? */
2063 if ( s->position )
2064 *s->position = pos0;
2065 releaseStream(s);
2066 return FALSE;
2067 }
2068
2069 return FALSE;
2070 }
2071
2072
2073 static foreign_t
put_byte(term_t stream,term_t byte ARG_LD)2074 put_byte(term_t stream, term_t byte ARG_LD)
2075 { IOSTREAM *s;
2076 int c;
2077
2078 if ( !PL_get_integer(byte, &c) || c < 0 || c > 255 )
2079 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_byte, byte);
2080 if ( !getOutputStream(stream, &s) )
2081 return FALSE;
2082
2083 Sputc(c, s);
2084
2085 return streamStatus(s);
2086 }
2087
2088
2089 static
2090 PRED_IMPL("put_byte", 2, put_byte2, 0)
2091 { PRED_LD
2092
2093 return put_byte(A1, A2 PASS_LD);
2094 }
2095
2096
2097 static
2098 PRED_IMPL("put_byte", 1, put_byte1, 0)
2099 { PRED_LD
2100
2101 return put_byte(0, A1 PASS_LD);
2102 }
2103
2104
2105 static foreign_t
put_code(term_t stream,term_t chr ARG_LD)2106 put_code(term_t stream, term_t chr ARG_LD)
2107 { IOSTREAM *s;
2108 int c = 0;
2109
2110 if ( !PL_get_char(chr, &c, FALSE) )
2111 return FALSE;
2112 if ( !getOutputStream(stream, &s) )
2113 return FALSE;
2114
2115 Sputcode(c, s);
2116
2117 return streamStatus(s);
2118 }
2119
2120
2121 static
2122 PRED_IMPL("put_code", 2, put_code2, 0)
2123 { PRED_LD
2124
2125 return put_code(A1, A2 PASS_LD);
2126 }
2127
2128
2129 static
2130 PRED_IMPL("put_code", 1, put_code1, 0)
2131 { PRED_LD
2132
2133 return put_code(0, A1 PASS_LD);
2134 }
2135
2136
2137 static
2138 PRED_IMPL("put", 2, put2, 0)
2139 { PRED_LD
2140
2141 return put_code(A1, A2 PASS_LD);
2142 }
2143
2144
2145 static
2146 PRED_IMPL("put", 1, put1, 0)
2147 { PRED_LD
2148
2149 return put_code(0, A1 PASS_LD);
2150 }
2151
2152
2153 static foreign_t
get_nonblank(term_t in,term_t chr ARG_LD)2154 get_nonblank(term_t in, term_t chr ARG_LD)
2155 { IOSTREAM *s;
2156
2157 if ( getInputStream(in, &s) )
2158 { int c;
2159
2160 for(;;)
2161 { c = Sgetcode(s);
2162
2163 if ( c == EOF )
2164 { TRY(PL_unify_integer(chr, -1));
2165 return streamStatus(s);
2166 }
2167
2168 if ( !isBlankW(c) )
2169 { releaseStream(s);
2170 return PL_unify_integer(chr, c);
2171 }
2172 }
2173 }
2174
2175 return FALSE;
2176 }
2177
2178
2179 static
2180 PRED_IMPL("get", 1, get1, 0)
2181 { PRED_LD
2182
2183 return get_nonblank(0, A1 PASS_LD);
2184 }
2185
2186
2187 static
2188 PRED_IMPL("get", 2, get2, 0)
2189 { PRED_LD
2190
2191 return get_nonblank(A1, A2 PASS_LD);
2192 }
2193
2194
2195 static foreign_t
skip(term_t in,term_t chr ARG_LD)2196 skip(term_t in, term_t chr ARG_LD)
2197 { int c = -1;
2198 int r;
2199 IOSTREAM *s;
2200
2201 if ( !PL_get_char(chr, &c, FALSE) )
2202 return FALSE;
2203 if ( !getInputStream(in, &s) )
2204 return FALSE;
2205
2206 while((r=Sgetcode(s)) != c && r != EOF )
2207 ;
2208
2209 return streamStatus(s);
2210 }
2211
2212
2213 static
2214 PRED_IMPL("skip", 1, skip1, 0)
2215 { PRED_LD
2216
2217 return skip(0, A1 PASS_LD);
2218 }
2219
2220
2221 static
2222 PRED_IMPL("skip", 2, skip2, 0)
2223 { PRED_LD
2224
2225 return skip(A1, A2 PASS_LD);
2226 }
2227
2228
2229 static
2230 PRED_IMPL("get_single_char", 1, get_single_char, 0)
2231 { GET_LD
2232 IOSTREAM *s = getStream(Suser_input);
2233 int c = getSingleChar(s, TRUE);
2234
2235 if ( c == EOF )
2236 { if ( PL_exception(0) )
2237 { releaseStream(s);
2238 return FALSE;
2239 }
2240
2241 PL_unify_integer(A1, -1);
2242 return streamStatus(s);
2243 }
2244
2245 releaseStream(s);
2246
2247 return PL_unify_integer(A1, c);
2248 }
2249
2250
2251 static foreign_t
get_byte2(term_t in,term_t chr ARG_LD)2252 get_byte2(term_t in, term_t chr ARG_LD)
2253 { IOSTREAM *s;
2254
2255 if ( getInputStream(in, &s) )
2256 { int c = Sgetc(s);
2257
2258 if ( PL_unify_integer(chr, c) )
2259 return streamStatus(s);
2260
2261 if ( Sferror(s) )
2262 return streamStatus(s);
2263
2264 PL_get_char(chr, &c, TRUE); /* set type-error */
2265 }
2266
2267 return FALSE;
2268 }
2269
2270
2271 static
2272 PRED_IMPL("get_byte", 2, get_byte2, 0)
2273 { PRED_LD
2274
2275 return get_byte2(A1, A2 PASS_LD);
2276 }
2277
2278
2279 static
2280 PRED_IMPL("get_byte", 1, get_byte1, 0)
2281 { PRED_LD
2282
2283 return get_byte2(0, A1 PASS_LD);
2284 }
2285
2286
2287 static foreign_t
get_code2(term_t in,term_t chr ARG_LD)2288 get_code2(term_t in, term_t chr ARG_LD)
2289 { IOSTREAM *s;
2290
2291 if ( getInputStream(in, &s) )
2292 { int c = Sgetcode(s);
2293
2294 if ( PL_unify_integer(chr, c) )
2295 return streamStatus(s);
2296
2297 if ( Sferror(s) )
2298 return streamStatus(s);
2299
2300 PL_get_char(chr, &c, TRUE); /* set type-error */
2301 releaseStream(s);
2302 }
2303
2304 return FALSE;
2305 }
2306
2307
2308 static
2309 PRED_IMPL("get_code", 2, get_code2, 0)
2310 { PRED_LD
2311 return get_code2(A1, A2 PASS_LD);
2312 }
2313
2314
2315 static
2316 PRED_IMPL("get_code", 1, get_code1, 0)
2317 { PRED_LD
2318 return get_code2(0, A1 PASS_LD);
2319 }
2320
2321
2322 static foreign_t
get_char2(term_t in,term_t chr ARG_LD)2323 get_char2(term_t in, term_t chr ARG_LD)
2324 { IOSTREAM *s;
2325
2326 if ( getInputStream(in, &s) )
2327 { int c = Sgetcode(s);
2328
2329 if ( PL_unify_atom(chr, c == -1 ? ATOM_end_of_file : codeToAtom(c)) )
2330 return streamStatus(s);
2331
2332 if ( Sferror(s) )
2333 return streamStatus(s);
2334
2335 PL_get_char(chr, &c, TRUE); /* set type-error */
2336 releaseStream(s);
2337 }
2338
2339 return FALSE;
2340 }
2341
2342
2343 static
2344 PRED_IMPL("get_char", 2, get_char2, 0)
2345 { PRED_LD
2346 return get_char2(A1, A2 PASS_LD);
2347 }
2348
2349
2350 static
2351 PRED_IMPL("get_char", 1, get_char1, 0)
2352 { PRED_LD
2353 return get_char2(0, A1 PASS_LD);
2354 }
2355
2356
2357 static
2358 PRED_IMPL("ttyflush", 0, ttyflush, 0)
2359 { PRED_LD
2360 IOSTREAM *s = getStream(Suser_output);
2361
2362 Sflush(s);
2363
2364 return streamStatus(s);
2365 }
2366
2367
2368 static
2369 PRED_IMPL("protocol", 1, protocol, 0)
2370 { return openProtocol(A1, FALSE);
2371 }
2372
2373
2374 static
2375 PRED_IMPL("protocola", 1, protocola, 0)
2376 { return openProtocol(A1, TRUE);
2377 }
2378
2379
2380 static
2381 PRED_IMPL("protocolling", 1, protocolling, 0)
2382 { PRED_LD
2383 IOSTREAM *s;
2384
2385 if ( (s = Sprotocol) )
2386 { atom_t a;
2387
2388 if ( (a = fileNameStream(s)) )
2389 return PL_unify_atom(A1, a);
2390 else
2391 return PL_unify_stream_or_alias(A1, s);
2392 }
2393
2394 return FALSE;
2395 }
2396
2397
2398 static
2399 PRED_IMPL("prompt", 2, prompt, 0)
2400 { PRED_LD
2401 atom_t a;
2402
2403 term_t old = A1;
2404 term_t new = A2;
2405
2406 if ( PL_unify_atom(old, LD->prompt.current) &&
2407 PL_get_atom(new, &a) )
2408 { if ( LD->prompt.current )
2409 PL_unregister_atom(LD->prompt.current);
2410 LD->prompt.current = a;
2411 PL_register_atom(a);
2412 return TRUE;
2413 }
2414
2415 return FALSE;
2416 }
2417
2418
2419 static void
prompt1(atom_t prompt)2420 prompt1(atom_t prompt)
2421 { GET_LD
2422
2423 if ( LD->prompt.first != prompt )
2424 { if ( LD->prompt.first )
2425 PL_unregister_atom(LD->prompt.first);
2426 LD->prompt.first = prompt;
2427 PL_register_atom(LD->prompt.first);
2428 }
2429
2430 LD->prompt.first_used = FALSE;
2431 }
2432
2433
2434 static
2435 PRED_IMPL("prompt1", 1, prompt1, 0)
2436 { GET_LD
2437 atom_t a;
2438 PL_chars_t txt;
2439
2440 if ( PL_get_atom(A1, &a) )
2441 { prompt1(a);
2442 } else if ( PL_get_text(A1, &txt, CVT_ALL|CVT_EXCEPTION) )
2443 { prompt1(textToAtom(&txt));
2444 } else
2445 return FALSE;
2446
2447 return TRUE;
2448 }
2449
2450
2451 atom_t
PrologPrompt()2452 PrologPrompt()
2453 { GET_LD
2454
2455 if ( !LD->prompt.first_used && LD->prompt.first )
2456 { LD->prompt.first_used = TRUE;
2457
2458 return LD->prompt.first;
2459 }
2460
2461 if ( Sinput->position && Sinput->position->linepos == 0 )
2462 return LD->prompt.current;
2463 else
2464 return 0; /* "" */
2465 }
2466
2467
2468 static int
tab(term_t out,term_t spaces)2469 tab(term_t out, term_t spaces)
2470 { int64_t count;
2471 IOSTREAM *s;
2472
2473 if ( !getOutputStream(out, &s) )
2474 return FALSE;
2475 if ( !PL_eval_expression_to_int64_ex(spaces, &count) )
2476 return FALSE;
2477
2478 while(count-- > 0)
2479 { if ( Sputcode(' ', s) < 0 )
2480 break;
2481 }
2482
2483 return streamStatus(s);
2484 }
2485
2486
2487 static
2488 PRED_IMPL("tab", 2, tab2, 0)
2489 { return tab(A1, A2);
2490 }
2491
2492 static
2493 PRED_IMPL("tab", 1, tab1, 0)
2494 { return tab(0, A1);
2495 }
2496
2497
2498 /*******************************
2499 * ENCODING *
2500 *******************************/
2501
2502
2503 static struct encname
2504 { IOENC code;
2505 atom_t name;
2506 } encoding_names[] =
2507 { { ENC_UNKNOWN, ATOM_unknown },
2508 { ENC_OCTET, ATOM_octet },
2509 { ENC_ASCII, ATOM_ascii },
2510 { ENC_ISO_LATIN_1, ATOM_iso_latin_1 },
2511 { ENC_ANSI, ATOM_text },
2512 { ENC_UTF8, ATOM_utf8 },
2513 { ENC_UNICODE_BE, ATOM_unicode_be },
2514 { ENC_UNICODE_LE, ATOM_unicode_le },
2515 { ENC_WCHAR, ATOM_wchar_t },
2516 { ENC_UNKNOWN, 0 },
2517 };
2518
2519
2520 IOENC
atom_to_encoding(atom_t a)2521 atom_to_encoding(atom_t a)
2522 { struct encname *en;
2523
2524 for(en=encoding_names; en->name; en++)
2525 { if ( en->name == a )
2526 return en->code;
2527 }
2528
2529 return ENC_UNKNOWN;
2530 }
2531
2532
2533 static atom_t
encoding_to_atom(IOENC enc)2534 encoding_to_atom(IOENC enc)
2535 { return encoding_names[enc].name;
2536 }
2537
2538
2539 static int
bad_encoding(const char * msg,atom_t name)2540 bad_encoding(const char *msg, atom_t name)
2541 { GET_LD
2542 term_t t = PL_new_term_ref();
2543
2544 PL_put_atom(t, name);
2545 return PL_error(NULL, 0, msg, ERR_DOMAIN, ATOM_encoding, t);
2546 }
2547
2548
2549 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2550 fn_to_atom() translates a 8-bit filename into a unicode atom. The
2551 encoding is generic `multibyte' on Unix systems and fixed to UTF-8 on
2552 Windows, where the uxnt layer translates the UTF-8 sequences to the
2553 Windows *W() functions.
2554 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2555
2556 static atom_t
fn_to_atom(const char * fn)2557 fn_to_atom(const char *fn)
2558 { PL_chars_t text;
2559 atom_t a;
2560
2561 text.text.t = (char *)fn;
2562 text.encoding = ((REP_FN&REP_UTF8) ? ENC_UTF8 :
2563 (REP_FN&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
2564 text.storage = PL_CHARS_HEAP;
2565 text.length = strlen(fn);
2566 text.canonical = FALSE;
2567
2568 a = textToAtom(&text);
2569 PL_free_text(&text);
2570
2571 return a;
2572 }
2573
2574
2575 /********************************
2576 * STREAM BASED I/O *
2577 *********************************/
2578 static const opt_spec open4_options[] =
2579 { { ATOM_type, OPT_ATOM },
2580 { ATOM_reposition, OPT_BOOL },
2581 { ATOM_alias, OPT_ATOM },
2582 { ATOM_eof_action, OPT_ATOM },
2583 { ATOM_close_on_abort, OPT_BOOL },
2584 { ATOM_buffer, OPT_ATOM },
2585 { ATOM_lock, OPT_ATOM },
2586 { ATOM_encoding, OPT_ATOM },
2587 { ATOM_bom, OPT_BOOL },
2588 { NULL_ATOM, 0 }
2589 };
2590
2591 IOSTREAM *
openStream(term_t file,term_t mode,term_t options)2592 openStream(term_t file, term_t mode, term_t options)
2593 { GET_LD
2594 atom_t mname;
2595 atom_t type = ATOM_text;
2596 int reposition = TRUE;
2597 atom_t alias = NULL_ATOM;
2598 atom_t eof_action = ATOM_eof_code;
2599 atom_t buffer = ATOM_full;
2600 atom_t lock = ATOM_none;
2601 atom_t encoding = NULL_ATOM;
2602 int close_on_abort = TRUE;
2603 int bom = -1;
2604 char how[10];
2605 char *h = how;
2606 char *path;
2607 IOSTREAM *s;
2608 IOENC enc;
2609
2610 if ( options )
2611 { if ( !scan_options(options, 0, ATOM_stream_option, open4_options,
2612 &type, &reposition, &alias, &eof_action,
2613 &close_on_abort, &buffer, &lock, &encoding, &bom) )
2614 return FALSE;
2615 }
2616
2617 /* MODE */
2618 if ( PL_get_atom(mode, &mname) )
2619 { if ( mname == ATOM_write )
2620 { *h++ = 'w';
2621 } else if ( mname == ATOM_append )
2622 { bom = FALSE;
2623 *h++ = 'a';
2624 } else if ( mname == ATOM_update )
2625 { bom = FALSE;
2626 *h++ = 'u';
2627 } else if ( mname == ATOM_read )
2628 { *h++ = 'r';
2629 } else
2630 { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_io_mode, mode);
2631 return NULL;
2632 }
2633 } else
2634 { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, mode);
2635 return NULL;
2636 }
2637
2638 /* ENCODING */
2639 if ( encoding != NULL_ATOM )
2640 { enc = atom_to_encoding(encoding);
2641 if ( enc == ENC_UNKNOWN )
2642 { bad_encoding(NULL, encoding);
2643 return NULL;
2644 }
2645 if ( type == ATOM_binary && enc != ENC_OCTET )
2646 { bad_encoding("type(binary) implies encoding(octet)", encoding);
2647 return NULL;
2648 }
2649 switch(enc) /* explicitely specified: do not */
2650 { case ENC_OCTET: /* switch to Unicode. For implicit */
2651 case ENC_ASCII: /* and unicode types we must detect */
2652 case ENC_ISO_LATIN_1: /* and skip the BOM */
2653 case ENC_WCHAR:
2654 bom = FALSE;
2655 break;
2656 default:
2657 ;
2658 }
2659 } else if ( type == ATOM_binary )
2660 { enc = ENC_OCTET;
2661 bom = FALSE;
2662 } else
2663 { enc = LD->encoding;
2664 }
2665
2666 if ( bom == -1 )
2667 bom = (mname == ATOM_read ? TRUE : FALSE);
2668 if ( type == ATOM_binary )
2669 *h++ = 'b';
2670
2671 /* LOCK */
2672 if ( lock != ATOM_none )
2673 { *h++ = 'l';
2674 if ( lock == ATOM_read || lock == ATOM_shared )
2675 *h++ = 'r';
2676 else if ( lock == ATOM_write || lock == ATOM_exclusive )
2677 *h++ = 'w';
2678 else
2679 { term_t l = PL_new_term_ref();
2680 PL_put_atom(l, lock);
2681 PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_lock, l);
2682 return NULL;
2683 }
2684 }
2685
2686 *h = EOS;
2687
2688 /* FILE */
2689 if ( PL_get_chars(file, &path,
2690 CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_FN) )
2691 { if ( !(s = Sopen_file(path, how)) )
2692 { PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
2693 ATOM_open, ATOM_source_sink, file);
2694 return NULL;
2695 }
2696 setFileNameStream(s, fn_to_atom(path));
2697 }
2698 #ifdef HAVE_POPEN
2699 else if ( PL_is_functor(file, FUNCTOR_pipe1) )
2700 { term_t a;
2701 char *cmd;
2702
2703 PL_clear_exception();
2704 a = PL_new_term_ref();
2705 _PL_get_arg(1, file, a);
2706 if ( !PL_get_chars(a, &cmd, CVT_ATOM|CVT_STRING|REP_FN) )
2707 { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, a);
2708 return NULL;
2709 }
2710
2711 if ( !(s = Sopen_pipe(cmd, how)) )
2712 { PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
2713 ATOM_open, ATOM_source_sink, file);
2714 return NULL;
2715 }
2716 }
2717 #endif /*HAVE_POPEN*/
2718 else
2719 { return NULL;
2720 }
2721
2722 s->encoding = enc;
2723 if ( !close_on_abort )
2724 s->flags |= SIO_NOCLOSE;
2725
2726 if ( how[0] == 'r' )
2727 { if ( eof_action != ATOM_eof_code )
2728 { if ( eof_action == ATOM_reset )
2729 s->flags |= SIO_NOFEOF;
2730 else if ( eof_action == ATOM_error )
2731 s->flags |= SIO_FEOF2ERR;
2732 }
2733 } else
2734 { if ( buffer != ATOM_full )
2735 { s->flags &= ~SIO_FBUF;
2736 if ( buffer == ATOM_line )
2737 s->flags |= SIO_LBUF;
2738 if ( buffer == ATOM_false )
2739 s->flags |= SIO_NBUF;
2740 }
2741 }
2742
2743 if ( alias != NULL_ATOM )
2744 aliasStream(s, alias);
2745 if ( !reposition )
2746 s->position = NULL;
2747
2748 if ( bom )
2749 { if ( mname == ATOM_read )
2750 { if ( ScheckBOM(s) < 0 )
2751 { bom_error:
2752
2753 streamStatus(getStream(s));
2754 return NULL;
2755 }
2756 } else
2757 { if ( SwriteBOM(s) < 0 )
2758 goto bom_error;
2759 }
2760 }
2761
2762 return s;
2763 }
2764
2765
2766 static
2767 PRED_IMPL("open", 4, open4, PL_FA_ISO)
2768 { IOSTREAM *s = openStream(A1, A2, A4);
2769
2770 if ( s )
2771 return PL_unify_stream_or_alias(A3, s);
2772
2773 return FALSE;
2774 }
2775
2776
2777 static
2778 PRED_IMPL("open", 3, open3, PL_FA_ISO)
2779 { IOSTREAM *s = openStream(A1, A2, 0);
2780
2781 if ( s )
2782 return PL_unify_stream_or_alias(A3, s);
2783
2784 return FALSE;
2785 }
2786
2787 /*******************************
2788 * EDINBURGH I/O *
2789 *******************************/
2790
2791 static IOSTREAM *
findStreamFromFile(atom_t name,unsigned int flags)2792 findStreamFromFile(atom_t name, unsigned int flags)
2793 { TableEnum e;
2794 Symbol symb;
2795 IOSTREAM *s = NULL;
2796
2797 e = newTableEnum(streamContext);
2798 while( (symb=advanceTableEnum(e)) )
2799 { stream_context *ctx = symb->value;
2800
2801 if ( ctx->filename == name &&
2802 true(ctx, flags) )
2803 { s = symb->name;
2804 break;
2805 }
2806 }
2807 freeTableEnum(e);
2808
2809 return s;
2810 }
2811
2812
2813 static int
pl_see(term_t f)2814 pl_see(term_t f)
2815 { GET_LD
2816 IOSTREAM *s;
2817 atom_t a;
2818 term_t mode;
2819
2820 LOCK();
2821 if ( get_stream_handle(f, &s, SH_ALIAS|SH_UNLOCKED) )
2822 { Scurin = s;
2823 goto ok;
2824 }
2825
2826 if ( PL_get_atom(f, &a) && a == ATOM_user )
2827 { Scurin = Suser_input;
2828 goto ok;
2829 }
2830 if ( (s = findStreamFromFile(a, IO_SEE)) )
2831 { Scurin = s;
2832 goto ok;
2833 }
2834
2835 mode = PL_new_term_ref();
2836 PL_put_atom(mode, ATOM_read);
2837 if ( !(s = openStream(f, mode, 0)) )
2838 { UNLOCK();
2839 return FALSE;
2840 }
2841
2842 set(getStreamContext(s), IO_SEE);
2843 push_input_context();
2844 Scurin = s;
2845
2846 ok:
2847 UNLOCK();
2848
2849 return TRUE;
2850 }
2851
2852 static int
pl_seen(void)2853 pl_seen(void)
2854 { GET_LD
2855 IOSTREAM *s = getStream(Scurin);
2856
2857 pop_input_context();
2858
2859 if ( s->flags & SIO_NOFEOF )
2860 return TRUE;
2861
2862 return closeStream(s);
2863 }
2864
2865 static
2866 PRED_IMPL("see", 1, see, 0)
2867 { return pl_see(A1);
2868 }
2869
2870
2871 static
2872 PRED_IMPL("seen", 0, seen, 0)
2873 { return pl_seen();
2874 }
2875
2876
2877 static
2878 PRED_IMPL("seeing", 1, seeing, 0)
2879 { PRED_LD
2880
2881 if ( Scurin == Suser_input )
2882 return PL_unify_atom(A1, ATOM_user);
2883
2884 return PL_unify_stream(A1, Scurin);
2885 }
2886
2887
2888 /* MT: Does not create a lock on the stream
2889 */
2890
2891 static int
do_tell(term_t f,atom_t m)2892 do_tell(term_t f, atom_t m)
2893 { GET_LD
2894 IOSTREAM *s;
2895 atom_t a;
2896 term_t mode;
2897
2898 LOCK();
2899 if ( get_stream_handle(f, &s, SH_UNLOCKED) )
2900 { Scurout = s;
2901 goto ok;
2902 }
2903
2904 if ( PL_get_atom(f, &a) && a == ATOM_user )
2905 { Scurout = Suser_output;
2906 goto ok;
2907 }
2908
2909 if ( (s = findStreamFromFile(a, IO_TELL)) )
2910 { Scurout = s;
2911 goto ok;
2912 }
2913
2914 mode = PL_new_term_ref();
2915 PL_put_atom(mode, m);
2916 if ( !(s = openStream(f, mode, 0)) )
2917 { UNLOCK();
2918 return FALSE;
2919 }
2920
2921 set(getStreamContext(s), IO_TELL);
2922 pushOutputContext();
2923 Scurout = s;
2924
2925 ok:
2926 UNLOCK();
2927 return TRUE;
2928 }
2929
2930 static
2931 PRED_IMPL("tell", 1, tell, 0)
2932 { return do_tell(A1, ATOM_write);
2933 }
2934
2935 static
2936 PRED_IMPL("append", 1, append, 0)
2937 { return do_tell(A1, ATOM_append);
2938 }
2939
2940 static
2941 PRED_IMPL("telling", 1, telling, 0)
2942 { PRED_LD
2943
2944 if ( Scurout == Suser_output )
2945 return PL_unify_atom(A1, ATOM_user);
2946
2947 return PL_unify_stream(A1, Scurout);
2948 }
2949
2950 static
2951 PRED_IMPL("told", 0, told, 0)
2952 { PRED_LD
2953 IOSTREAM *s = getStream(Scurout);
2954
2955 popOutputContext();
2956
2957 if ( s->flags & SIO_NOFEOF )
2958 return TRUE;
2959
2960 return closeStream(s);
2961 }
2962
2963 /*******************************
2964 * NULL-STREAM *
2965 *******************************/
2966
2967 static ssize_t
Swrite_null(void * handle,char * buf,size_t size)2968 Swrite_null(void *handle, char *buf, size_t size)
2969 { return size;
2970 }
2971
2972
2973 static ssize_t
Sread_null(void * handle,char * buf,size_t size)2974 Sread_null(void *handle, char *buf, size_t size)
2975 { return 0;
2976 }
2977
2978
2979 static long
Sseek_null(void * handle,long offset,int whence)2980 Sseek_null(void *handle, long offset, int whence)
2981 { switch(whence)
2982 { case SIO_SEEK_SET:
2983 return offset;
2984 case SIO_SEEK_CUR:
2985 case SIO_SEEK_END:
2986 default:
2987 return -1;
2988 }
2989 }
2990
2991
2992 static int
Sclose_null(void * handle)2993 Sclose_null(void *handle)
2994 { return 0;
2995 }
2996
2997
2998 static const IOFUNCTIONS nullFunctions =
2999 { Sread_null,
3000 Swrite_null,
3001 Sseek_null,
3002 Sclose_null
3003 };
3004
3005
3006 static
3007 PRED_IMPL("open_null_stream", 1, open_null_stream, 0)
3008 { int sflags = SIO_NBUF|SIO_RECORDPOS|SIO_OUTPUT;
3009 IOSTREAM *s = Snew((void *)NULL, sflags, (IOFUNCTIONS *)&nullFunctions);
3010
3011 if ( s )
3012 { s->encoding = ENC_UTF8;
3013 return PL_unify_stream_or_alias(A1, s);
3014 }
3015
3016 return FALSE;
3017 }
3018
3019
3020 static
3021 PRED_IMPL("close", 1, close, PL_FA_ISO)
3022 { IOSTREAM *s;
3023
3024 if ( PL_get_stream_handle(A1, &s) )
3025 return closeStream(s);
3026
3027 return FALSE;
3028 }
3029
3030 static const opt_spec close2_options[] =
3031 { { ATOM_force, OPT_BOOL },
3032 { NULL_ATOM, 0 }
3033 };
3034
3035
3036 static
3037 PRED_IMPL("close", 2, close2, PL_FA_ISO)
3038 { IOSTREAM *s;
3039 int force = FALSE;
3040
3041 if ( !scan_options(A2, 0, ATOM_close_option, close2_options, &force) )
3042 return FALSE;
3043
3044 if ( !PL_get_stream_handle(A1, &s) )
3045 return FALSE;
3046 if ( !force )
3047 return closeStream(s);
3048
3049 if ( s == Sinput )
3050 Sclearerr(s);
3051 else if ( s == Soutput || s == Serror )
3052 { Sflush(s);
3053 Sclearerr(s);
3054 } else
3055 { Sflush(s);
3056 Sclose(s);
3057 }
3058
3059 return TRUE;
3060 }
3061
3062
3063 /*******************************
3064 * STREAM-PROPERTY *
3065 *******************************/
3066
3067 static int
stream_file_name_propery(IOSTREAM * s,term_t prop ARG_LD)3068 stream_file_name_propery(IOSTREAM *s, term_t prop ARG_LD)
3069 { atom_t name;
3070
3071 if ( (name = getStreamContext(s)->filename) )
3072 { return PL_unify_atom(prop, name);
3073 }
3074
3075 return FALSE;
3076 }
3077
3078
3079 static int
stream_mode_property(IOSTREAM * s,term_t prop ARG_LD)3080 stream_mode_property(IOSTREAM *s, term_t prop ARG_LD)
3081 { atom_t mode;
3082
3083 if ( s->flags & SIO_INPUT )
3084 mode = ATOM_read;
3085 else
3086 { assert(s->flags & SIO_OUTPUT);
3087
3088 if ( s->flags & SIO_APPEND )
3089 mode = ATOM_append;
3090 else if ( s->flags & SIO_UPDATE )
3091 mode = ATOM_update;
3092 else
3093 mode = ATOM_write;
3094 }
3095
3096 return PL_unify_atom(prop, mode);
3097 }
3098
3099
3100 static int
stream_input_prop(IOSTREAM * s ARG_LD)3101 stream_input_prop(IOSTREAM *s ARG_LD)
3102 { return (s->flags & SIO_INPUT) ? TRUE : FALSE;
3103 }
3104
3105
3106 static int
stream_output_prop(IOSTREAM * s ARG_LD)3107 stream_output_prop(IOSTREAM *s ARG_LD)
3108 { return (s->flags & SIO_OUTPUT) ? TRUE : FALSE;
3109 }
3110
3111
3112 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3113 Incomplete: should be non-deterministic if the stream has multiple aliases!
3114 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3115
3116 static int
stream_alias_prop(IOSTREAM * s,term_t prop ARG_LD)3117 stream_alias_prop(IOSTREAM *s, term_t prop ARG_LD)
3118 { atom_t name;
3119 stream_context *ctx = getStreamContext(s);
3120 int i;
3121
3122 if ( PL_get_atom(prop, &name) )
3123 { alias *a;
3124
3125 for( a = ctx->alias_head; a; a = a->next )
3126 { if ( a->name == name )
3127 return TRUE;
3128 }
3129
3130 if ( (i=standardStreamIndexFromName(name)) >= 0 &&
3131 i < 6 &&
3132 s == LD->IO.streams[i] )
3133 return TRUE;
3134
3135 return FALSE;
3136 }
3137
3138 if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
3139 return PL_unify_atom(prop, standardStreams[i]);
3140 if ( ctx->alias_head )
3141 return PL_unify_atom(prop, ctx->alias_head->name);
3142
3143 return FALSE;
3144 }
3145
3146
3147 static int
stream_position_prop(IOSTREAM * s,term_t prop ARG_LD)3148 stream_position_prop(IOSTREAM *s, term_t prop ARG_LD)
3149 { if ( s->position )
3150 { return PL_unify_term(prop,
3151 PL_FUNCTOR, FUNCTOR_stream_position4,
3152 PL_INT64, s->position->charno,
3153 PL_INT, s->position->lineno,
3154 PL_INT, s->position->linepos,
3155 PL_INT64, s->position->byteno);
3156 }
3157
3158 return FALSE;
3159 }
3160
3161
3162 static int
stream_end_of_stream_prop(IOSTREAM * s,term_t prop ARG_LD)3163 stream_end_of_stream_prop(IOSTREAM *s, term_t prop ARG_LD)
3164 { if ( s->flags & SIO_INPUT )
3165 { GET_LD
3166 atom_t val;
3167
3168 if ( s->flags & SIO_FEOF2 )
3169 val = ATOM_past;
3170 else if ( s->flags & SIO_FEOF )
3171 val = ATOM_at;
3172 else
3173 val = ATOM_not;
3174
3175 return PL_unify_atom(prop, val);
3176 }
3177
3178 return FALSE;
3179 }
3180
3181
3182 static int
stream_eof_action_prop(IOSTREAM * s,term_t prop ARG_LD)3183 stream_eof_action_prop(IOSTREAM *s, term_t prop ARG_LD)
3184 { atom_t val;
3185
3186 if ( s->flags & SIO_NOFEOF )
3187 val = ATOM_reset;
3188 else if ( s->flags & SIO_FEOF2ERR )
3189 val = ATOM_error;
3190 else
3191 val = ATOM_eof_code;
3192
3193 return PL_unify_atom(prop, val);
3194 }
3195
3196
3197 #ifdef HAVE_FSTAT
3198 #include <sys/stat.h>
3199 #endif
3200
3201 #if !defined(S_ISREG) && defined(S_IFREG)
3202 #define S_ISREG(m) ((m&S_IFMT) == S_IFREG)
3203 #endif
3204
3205 static int
stream_reposition_prop(IOSTREAM * s,term_t prop ARG_LD)3206 stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD)
3207 { atom_t val;
3208
3209 if ( s->functions->seek )
3210 {
3211 #ifdef HAVE_FSTAT
3212 int fd = Sfileno(s);
3213 struct stat buf;
3214
3215 if ( fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) )
3216 val = ATOM_true;
3217 else
3218 val = ATOM_false;
3219 #else
3220 val = ATOM_true;
3221 #endif
3222 } else
3223 val = ATOM_false;
3224
3225 return PL_unify_atom(prop, val);
3226 }
3227
3228
3229 static int
stream_close_on_abort_prop(IOSTREAM * s,term_t prop ARG_LD)3230 stream_close_on_abort_prop(IOSTREAM *s, term_t prop ARG_LD)
3231 { return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE));
3232 }
3233
3234
3235 static int
stream_type_prop(IOSTREAM * s,term_t prop ARG_LD)3236 stream_type_prop(IOSTREAM *s, term_t prop ARG_LD)
3237 { return PL_unify_atom(prop, s->flags & SIO_TEXT ? ATOM_text : ATOM_binary);
3238 }
3239
3240
3241 static int
stream_file_no_prop(IOSTREAM * s,term_t prop ARG_LD)3242 stream_file_no_prop(IOSTREAM *s, term_t prop ARG_LD)
3243 { int fd;
3244
3245 if ( (fd = Sfileno(s)) >= 0 )
3246 return PL_unify_integer(prop, fd);
3247
3248 return FALSE;
3249 }
3250
3251
3252 static int
stream_tty_prop(IOSTREAM * s,term_t prop ARG_LD)3253 stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD)
3254 { if ( (s->flags & SIO_ISATTY) )
3255 return PL_unify_bool_ex(prop, TRUE);
3256
3257 return FALSE;
3258 }
3259
3260
3261 static int
stream_bom_prop(IOSTREAM * s,term_t prop ARG_LD)3262 stream_bom_prop(IOSTREAM *s, term_t prop ARG_LD)
3263 { if ( (s->flags & SIO_BOM) )
3264 return PL_unify_bool_ex(prop, TRUE);
3265
3266 return FALSE;
3267 }
3268
3269
3270 static int
stream_newline_prop(IOSTREAM * s,term_t prop ARG_LD)3271 stream_newline_prop(IOSTREAM *s, term_t prop ARG_LD)
3272 { switch ( s->newline )
3273 { case SIO_NL_POSIX:
3274 case SIO_NL_DETECT:
3275 return PL_unify_atom(prop, ATOM_posix);
3276 case SIO_NL_DOS:
3277 return PL_unify_atom(prop, ATOM_dos);
3278 }
3279
3280 return FALSE;
3281 }
3282
3283
3284 static int
stream_encoding_prop(IOSTREAM * s,term_t prop ARG_LD)3285 stream_encoding_prop(IOSTREAM *s, term_t prop ARG_LD)
3286 { return PL_unify_atom(prop, encoding_to_atom(s->encoding));
3287 }
3288
3289
3290 static int
stream_reperror_prop(IOSTREAM * s,term_t prop ARG_LD)3291 stream_reperror_prop(IOSTREAM *s, term_t prop ARG_LD)
3292 { atom_t a;
3293
3294 if ( (s->flags & SIO_REPXML) )
3295 a = ATOM_xml;
3296 else if ( (s->flags & SIO_REPPL) )
3297 a = ATOM_prolog;
3298 else
3299 a = ATOM_error;
3300
3301 return PL_unify_atom(prop, a);
3302 }
3303
3304
3305 static int
stream_buffer_prop(IOSTREAM * s,term_t prop ARG_LD)3306 stream_buffer_prop(IOSTREAM *s, term_t prop ARG_LD)
3307 { atom_t b;
3308
3309 if ( s->flags & SIO_FBUF )
3310 b = ATOM_full;
3311 else if ( s->flags & SIO_LBUF )
3312 b = ATOM_line;
3313 else /*if ( s->flags & SIO_NBUF )*/
3314 b = ATOM_false;
3315
3316 return PL_unify_atom(prop, b);
3317 }
3318
3319
3320 static int
stream_buffer_size_prop(IOSTREAM * s,term_t prop ARG_LD)3321 stream_buffer_size_prop(IOSTREAM *s, term_t prop ARG_LD)
3322 { if ( (s->flags & SIO_NBUF) )
3323 return FALSE;
3324
3325 return PL_unify_integer(prop, s->bufsize);
3326 }
3327
3328
3329 static int
stream_timeout_prop(IOSTREAM * s,term_t prop ARG_LD)3330 stream_timeout_prop(IOSTREAM *s, term_t prop ARG_LD)
3331 { if ( s->timeout == -1 )
3332 return PL_unify_atom(prop, ATOM_infinite);
3333
3334 return PL_unify_float(prop, (double)s->timeout/1000.0);
3335 }
3336
3337
3338 static int
stream_nlink_prop(IOSTREAM * s,term_t prop ARG_LD)3339 stream_nlink_prop(IOSTREAM *s, term_t prop ARG_LD)
3340 { int fd;
3341
3342 if ( (fd = Sfileno(s)) >= 0 )
3343 { struct stat buf;
3344
3345 if ( fstat(fd, &buf) == 0 )
3346 { return PL_unify_integer(prop, buf.st_nlink);
3347 }
3348 }
3349
3350 return FALSE;
3351 }
3352
3353
3354 typedef struct
3355 { functor_t functor; /* functor of property */
3356 int (*function)(); /* function to generate */
3357 } sprop;
3358
3359
3360 static const sprop sprop_list [] =
3361 { { FUNCTOR_file_name1, stream_file_name_propery },
3362 { FUNCTOR_mode1, stream_mode_property },
3363 { FUNCTOR_input0, stream_input_prop },
3364 { FUNCTOR_output0, stream_output_prop },
3365 { FUNCTOR_alias1, stream_alias_prop },
3366 { FUNCTOR_position1, stream_position_prop },
3367 { FUNCTOR_end_of_stream1, stream_end_of_stream_prop },
3368 { FUNCTOR_eof_action1, stream_eof_action_prop },
3369 { FUNCTOR_reposition1, stream_reposition_prop },
3370 { FUNCTOR_type1, stream_type_prop },
3371 { FUNCTOR_file_no1, stream_file_no_prop },
3372 { FUNCTOR_buffer1, stream_buffer_prop },
3373 { FUNCTOR_buffer_size1, stream_buffer_size_prop },
3374 { FUNCTOR_close_on_abort1,stream_close_on_abort_prop },
3375 { FUNCTOR_tty1, stream_tty_prop },
3376 { FUNCTOR_encoding1, stream_encoding_prop },
3377 { FUNCTOR_bom1, stream_bom_prop },
3378 { FUNCTOR_newline1, stream_newline_prop },
3379 { FUNCTOR_representation_errors1, stream_reperror_prop },
3380 { FUNCTOR_timeout1, stream_timeout_prop },
3381 { FUNCTOR_nlink1, stream_nlink_prop },
3382 { 0, NULL }
3383 };
3384
3385
3386 typedef struct
3387 { TableEnum e; /* Enumerator on stream-table */
3388 IOSTREAM *s; /* Stream we are enumerating */
3389 const sprop *p; /* Pointer in properties */
3390 int fixed_p; /* Propety is given */
3391 } prop_enum;
3392
3393
3394 static
3395 PRED_IMPL("stream_property", 2, stream_property,
3396 PL_FA_ISO|PL_FA_NONDETERMINISTIC)
3397 { PRED_LD
3398 IOSTREAM *s;
3399 prop_enum *pe;
3400 fid_t fid;
3401 term_t a1;
3402
3403 term_t stream = A1;
3404 term_t property = A2;
3405
3406 switch( CTX_CNTRL )
3407 { case FRG_FIRST_CALL:
3408 a1 = PL_new_term_ref();
3409
3410 if ( PL_is_variable(stream) ) /* generate */
3411 { const sprop *p = sprop_list;
3412 int fixed = FALSE;
3413 functor_t f;
3414
3415 if ( PL_get_functor(property, &f) ) /* test for defined property */
3416 { for( ; p->functor; p++ )
3417 { if ( f == p->functor )
3418 { fixed = TRUE;
3419 break;
3420 }
3421 }
3422 if ( !p->functor )
3423 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
3424 ATOM_stream_property, property);
3425 }
3426
3427 pe = allocHeap(sizeof(*pe));
3428
3429 pe->e = newTableEnum(streamContext);
3430 pe->s = NULL;
3431 pe->p = p;
3432 pe->fixed_p = fixed;
3433
3434 break;
3435 }
3436
3437 LOCK(); /* given stream */
3438 if ( get_stream_handle(stream, &s, SH_ERRORS|SH_UNLOCKED) )
3439 { functor_t f;
3440
3441 if ( PL_is_variable(property) ) /* generate properties */
3442 { pe = allocHeap(sizeof(*pe));
3443
3444 pe->e = NULL;
3445 pe->s = s;
3446 pe->p = sprop_list;
3447 pe->fixed_p = FALSE;
3448 UNLOCK();
3449
3450 break;
3451 }
3452
3453 if ( PL_get_functor(property, &f) )
3454 { const sprop *p = sprop_list;
3455
3456 for( ; p->functor; p++ )
3457 { if ( f == p->functor )
3458 { int rval;
3459
3460 switch(arityFunctor(f))
3461 { case 0:
3462 rval = (*p->function)(s PASS_LD);
3463 break;
3464 case 1:
3465 { term_t a1 = PL_new_term_ref();
3466
3467 _PL_get_arg(1, property, a1);
3468 rval = (*p->function)(s, a1 PASS_LD);
3469 break;
3470 }
3471 default:
3472 assert(0);
3473 rval = FALSE;
3474 }
3475 UNLOCK();
3476 return rval;
3477 }
3478 }
3479 } else
3480 { UNLOCK();
3481 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
3482 ATOM_stream_property, property);
3483 }
3484 }
3485 UNLOCK();
3486 return FALSE; /* bad stream handle */
3487 case FRG_REDO:
3488 { pe = CTX_PTR;
3489 a1 = PL_new_term_ref();
3490
3491 break;
3492 }
3493 case FRG_CUTTED:
3494 { pe = CTX_PTR;
3495
3496 if ( pe ) /* 0 if exception on FRG_FIRST_CALL */
3497 { if ( pe->e )
3498 freeTableEnum(pe->e);
3499
3500 freeHeap(pe, sizeof(*pe));
3501 }
3502 return TRUE;
3503 }
3504 default:
3505 assert(0);
3506 return FALSE;
3507 }
3508
3509
3510 if ( !(fid = PL_open_foreign_frame()) )
3511 { error:
3512
3513 if ( pe->e )
3514 freeTableEnum(pe->e);
3515
3516 freeHeap(pe, sizeof(*pe));
3517 return FALSE;
3518 }
3519
3520 for(;;)
3521 { if ( pe->s ) /* given stream */
3522 { fid_t fid2;
3523
3524 if ( PL_is_variable(stream) )
3525 { if ( !PL_unify_stream(stream, pe->s) )
3526 goto enum_e;
3527 }
3528
3529 if ( !(fid2 = PL_open_foreign_frame()) )
3530 goto error;
3531 for( ; pe->p->functor ; pe->p++ )
3532 { if ( PL_unify_functor(property, pe->p->functor) )
3533 { int rval;
3534
3535 switch(arityFunctor(pe->p->functor))
3536 { case 0:
3537 rval = (*pe->p->function)(pe->s PASS_LD);
3538 break;
3539 case 1:
3540 { _PL_get_arg(1, property, a1);
3541
3542 rval = (*pe->p->function)(pe->s, a1 PASS_LD);
3543 break;
3544 }
3545 default:
3546 assert(0);
3547 rval = FALSE;
3548 }
3549 if ( rval )
3550 { if ( pe->fixed_p )
3551 pe->s = NULL;
3552 else
3553 pe->p++;
3554 ForeignRedoPtr(pe);
3555 }
3556 }
3557
3558 if ( exception_term )
3559 goto error;
3560
3561 if ( pe->fixed_p )
3562 break;
3563 PL_rewind_foreign_frame(fid2);
3564 }
3565 PL_close_foreign_frame(fid2);
3566 pe->s = NULL;
3567 }
3568
3569 enum_e:
3570 if ( pe->e )
3571 { Symbol symb;
3572
3573 while ( (symb=advanceTableEnum(pe->e)) )
3574 { PL_rewind_foreign_frame(fid);
3575 if ( PL_unify_stream(stream, symb->name) )
3576 { pe->s = symb->name;
3577 if ( !pe->fixed_p )
3578 pe->p = sprop_list;
3579 break;
3580 }
3581 if ( exception_term )
3582 goto error;
3583 }
3584 }
3585
3586 if ( !pe->s )
3587 { if ( pe->e )
3588 freeTableEnum(pe->e);
3589
3590 freeHeap(pe, sizeof(*pe));
3591 return FALSE;
3592 }
3593 }
3594 }
3595
3596
3597 static
3598 PRED_IMPL("is_stream", 1, is_stream, 0)
3599 { GET_LD
3600 IOSTREAM *s;
3601
3602 if ( get_stream_handle(A1, &s, SH_SAFE) )
3603 { releaseStream(s);
3604 return TRUE;
3605 }
3606
3607 return FALSE;
3608 }
3609
3610
3611
3612 /*******************************
3613 * FLUSH *
3614 *******************************/
3615
3616
3617 static int
flush_output(term_t out)3618 flush_output(term_t out)
3619 { IOSTREAM *s;
3620
3621 if ( getOutputStream(out, &s) )
3622 { Sflush(s);
3623 return streamStatus(s);
3624 }
3625
3626 return FALSE;
3627 }
3628
3629 static
3630 PRED_IMPL("flush_output", 0, flush_output, PL_FA_ISO)
3631 { return flush_output(0);
3632 }
3633
3634 static
3635 PRED_IMPL("flush_output", 1, flush_output1, PL_FA_ISO)
3636 { return flush_output(A1);
3637 }
3638
3639
3640 static int
getStreamWithPosition(term_t stream,IOSTREAM ** sp)3641 getStreamWithPosition(term_t stream, IOSTREAM **sp)
3642 { IOSTREAM *s;
3643
3644 if ( PL_get_stream_handle(stream, &s) )
3645 { if ( !s->position )
3646 { PL_error(NULL, 0, NULL, ERR_PERMISSION, /* non-ISO */
3647 ATOM_property, ATOM_position, stream);
3648 releaseStream(s);
3649 return FALSE;
3650 }
3651
3652 *sp = s;
3653 return TRUE;
3654 }
3655
3656 return FALSE;
3657 }
3658
3659
3660 static int
getRepositionableStream(term_t stream,IOSTREAM ** sp)3661 getRepositionableStream(term_t stream, IOSTREAM **sp)
3662 { GET_LD
3663 IOSTREAM *s;
3664
3665 if ( get_stream_handle(stream, &s, SH_ERRORS) )
3666 { if ( !s->position || !s->functions || !s->functions->seek )
3667 { PL_error(NULL, 0, NULL, ERR_PERMISSION,
3668 ATOM_reposition, ATOM_stream, stream);
3669 releaseStream(s);
3670 return FALSE;
3671 }
3672
3673 *sp = s;
3674 return TRUE;
3675 }
3676
3677 return FALSE;
3678 }
3679
3680
3681 static
3682 PRED_IMPL("set_stream_position", 2, set_stream_position, PL_FA_ISO)
3683 { PRED_LD
3684 IOSTREAM *s;
3685 int64_t charno, byteno;
3686 long linepos, lineno;
3687 term_t a = PL_new_term_ref();
3688
3689 term_t stream = A1;
3690 term_t pos = A2;
3691
3692 if ( !(getRepositionableStream(stream, &s)) )
3693 return FALSE;
3694
3695 if ( !PL_is_functor(pos, FUNCTOR_stream_position4) ||
3696 !PL_get_arg(1, pos, a) ||
3697 !PL_get_int64(a, &charno) ||
3698 !PL_get_arg(2, pos, a) ||
3699 !PL_get_long(a, &lineno) ||
3700 !PL_get_arg(3, pos, a) ||
3701 !PL_get_long(a, &linepos) ||
3702 !PL_get_arg(4, pos, a) ||
3703 !PL_get_int64(a, &byteno) )
3704 { releaseStream(s);
3705 return PL_error("stream_position", 3, NULL,
3706 ERR_DOMAIN, ATOM_stream_position, pos);
3707 }
3708
3709 if ( Sseek64(s, byteno, SIO_SEEK_SET) != 0 )
3710 return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
3711 ATOM_reposition, ATOM_stream, stream);
3712
3713 s->position->byteno = byteno;
3714 s->position->charno = charno;
3715 s->position->lineno = (int)lineno;
3716 s->position->linepos = (int)linepos;
3717
3718 releaseStream(s);
3719
3720 return TRUE;
3721 }
3722
3723
3724 static
3725 PRED_IMPL("seek", 4, seek, 0)
3726 { PRED_LD
3727 atom_t m;
3728 int whence = -1;
3729 int64_t off, new;
3730 IOSTREAM *s;
3731
3732 term_t stream = A1;
3733 term_t offset = A2;
3734 term_t method = A3;
3735 term_t newloc = A4;
3736
3737 if ( !(PL_get_atom_ex(method, &m)) )
3738 return FALSE;
3739
3740 if ( m == ATOM_bof )
3741 whence = SIO_SEEK_SET;
3742 else if ( m == ATOM_current )
3743 whence = SIO_SEEK_CUR;
3744 else if ( m == ATOM_eof )
3745 whence = SIO_SEEK_END;
3746 else
3747 return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_seek_method, method);
3748
3749 if ( !PL_get_int64(offset, &off) )
3750 return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_integer, offset);
3751
3752 if ( PL_get_stream_handle(stream, &s) )
3753 { int unit = Sunit_size(s);
3754
3755 off *= unit;
3756 if ( Sseek64(s, off, whence) < 0 )
3757 { if ( errno == EINVAL )
3758 PL_error("seek", 4, "offset out of range", ERR_DOMAIN,
3759 ATOM_position, offset);
3760 else
3761 PL_error("seek", 4, OsError(), ERR_PERMISSION,
3762 ATOM_reposition, ATOM_stream, stream);
3763 Sclearerr(s);
3764 releaseStream(s);
3765 return FALSE;
3766 }
3767
3768 new = Stell64(s);
3769 releaseStream(s);
3770 new /= unit;
3771
3772 return PL_unify_int64(newloc, new);
3773 }
3774
3775 return FALSE;
3776 }
3777
3778
3779 static
3780 PRED_IMPL("set_input", 1, set_input, PL_FA_ISO)
3781 { PRED_LD
3782 IOSTREAM *s;
3783
3784 if ( getInputStream(A1, &s) )
3785 { Scurin = s;
3786 releaseStream(s);
3787 return TRUE;
3788 }
3789
3790 return FALSE;
3791 }
3792
3793
3794 static
3795 PRED_IMPL("set_output", 1, set_output, PL_FA_ISO)
3796 { PRED_LD
3797 IOSTREAM *s;
3798
3799 if ( getOutputStream(A1, &s) )
3800 { Scurout = s;
3801 releaseStream(s);
3802 return TRUE;
3803 }
3804
3805 return FALSE;
3806 }
3807
3808
3809 static
3810 PRED_IMPL("current_input", 1, current_input, PL_FA_ISO)
3811 { PRED_LD
3812 return PL_unify_stream(A1, Scurin);
3813 }
3814
3815
3816 static
3817 PRED_IMPL("current_output", 1, current_output, PL_FA_ISO)
3818 { PRED_LD
3819 return PL_unify_stream(A1, Scurout);
3820 }
3821
3822
3823 static
3824 PRED_IMPL("byte_count", 2, byte_count, 0)
3825 { IOSTREAM *s;
3826
3827 if ( getStreamWithPosition(A1, &s) )
3828 { int64_t n = s->position->byteno;
3829
3830 releaseStream(s);
3831 return PL_unify_int64(A2, n);
3832 }
3833
3834 return FALSE;
3835 }
3836
3837
3838 static
3839 PRED_IMPL("character_count", 2, character_count, 0)
3840 { IOSTREAM *s;
3841
3842 if ( getStreamWithPosition(A1, &s) )
3843 { int64_t n = s->position->charno;
3844
3845 releaseStream(s);
3846 return PL_unify_int64(A2, n);
3847 }
3848
3849 return FALSE;
3850 }
3851
3852
3853 static
3854 PRED_IMPL("line_count", 2, line_count, 0)
3855 { GET_LD
3856 IOSTREAM *s;
3857
3858 if ( getStreamWithPosition(A1, &s) )
3859 { intptr_t n = s->position->lineno;
3860
3861 releaseStream(s);
3862 return PL_unify_integer(A2, n);
3863 }
3864
3865 return FALSE;
3866 }
3867
3868
3869 static
3870 PRED_IMPL("line_position", 2, line_position, 0)
3871 { GET_LD
3872 IOSTREAM *s;
3873
3874 if ( getStreamWithPosition(A1, &s) )
3875 { intptr_t n = s->position->linepos;
3876
3877 releaseStream(s);
3878 return PL_unify_integer(A2, n);
3879 }
3880
3881 return FALSE;
3882 }
3883
3884
3885 static
3886 PRED_IMPL("source_location", 2, source_location, 0)
3887 { PRED_LD
3888 if ( ReadingSource &&
3889 PL_unify_atom(A1, source_file_name) &&
3890 PL_unify_integer(A2, source_line_no) )
3891 return TRUE;
3892
3893 return FALSE;
3894 }
3895
3896
3897 static int
at_end_of_stream(term_t stream ARG_LD)3898 at_end_of_stream(term_t stream ARG_LD)
3899 { IOSTREAM *s;
3900
3901 if ( getInputStream(stream, &s) )
3902 { int rval = Sfeof(s);
3903
3904 if ( rval < 0 )
3905 { PL_error(NULL, 0, "not-buffered stream", ERR_PERMISSION,
3906 ATOM_end_of_stream, ATOM_stream, stream);
3907 rval = FALSE;
3908 }
3909
3910 if ( rval && Sferror(s) ) /* due to error */
3911 return streamStatus(s);
3912 else
3913 releaseStream(s);
3914
3915 return rval;
3916 }
3917
3918 return FALSE; /* exception */
3919 }
3920
3921 static
3922 PRED_IMPL("at_end_of_stream", 1, at_end_of_stream, PL_FA_ISO)
3923 { PRED_LD
3924 return at_end_of_stream(A1 PASS_LD);
3925 }
3926
3927 static
3928 PRED_IMPL("at_end_of_stream", 0, at_end_of_stream0, PL_FA_ISO)
3929 { PRED_LD
3930 return at_end_of_stream(0 PASS_LD);
3931 }
3932
3933
3934 static foreign_t
peek(term_t stream,term_t chr,int how ARG_LD)3935 peek(term_t stream, term_t chr, int how ARG_LD)
3936 { IOSTREAM *s;
3937 IOPOS pos;
3938 int c;
3939
3940 if ( !getInputStream(stream, &s) )
3941 return FALSE;
3942
3943 pos = s->posbuf;
3944 if ( how == PL_BYTE )
3945 { c = Sgetc(s);
3946 if ( c != EOF )
3947 Sungetc(c, s);
3948 } else
3949 { c = Sgetcode(s);
3950 if ( c != EOF )
3951 Sungetcode(c, s);
3952 }
3953 s->posbuf = pos;
3954 if ( Sferror(s) )
3955 return streamStatus(s);
3956 releaseStream(s);
3957
3958 return PL_unify_char(chr, c, how);
3959 }
3960
3961
3962 static
3963 PRED_IMPL("peek_byte", 2, peek_byte2, 0)
3964 { PRED_LD
3965 return peek(A1, A2, PL_BYTE PASS_LD);
3966 }
3967
3968
3969 static
3970 PRED_IMPL("peek_byte", 1, peek_byte1, 0)
3971 { PRED_LD
3972 return peek(0, A1, PL_BYTE PASS_LD);
3973 }
3974
3975
3976 static
3977 PRED_IMPL("peek_code", 2, peek_code2, 0)
3978 { PRED_LD
3979 return peek(A1, A2, PL_CODE PASS_LD);
3980 }
3981
3982
3983 static
3984 PRED_IMPL("peek_code", 1, peek_code1, 0)
3985 { PRED_LD
3986 return peek(0, A1, PL_CODE PASS_LD);
3987 }
3988
3989
3990 static
3991 PRED_IMPL("peek_char", 2, peek_char2, 0)
3992 { PRED_LD
3993 return peek(A1, A2, PL_CHAR PASS_LD);
3994 }
3995
3996
3997 static
3998 PRED_IMPL("peek_char", 1, peek_char1, 0)
3999 { PRED_LD
4000 return peek(0, A1, PL_CHAR PASS_LD);
4001 }
4002
4003
4004 /*******************************
4005 * INTERACTION *
4006 *******************************/
4007
4008 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4009 set_prolog_IO(+In, +Out, +Error)
4010
4011 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4012
4013 typedef struct wrappedIO
4014 { void *wrapped_handle; /* original handle */
4015 IOFUNCTIONS *wrapped_functions; /* original functions */
4016 IOSTREAM *wrapped_stream; /* stream we wrapped */
4017 IOFUNCTIONS functions; /* new function block */
4018 } wrappedIO;
4019
4020
4021 ssize_t
Sread_user(void * handle,char * buf,size_t size)4022 Sread_user(void *handle, char *buf, size_t size)
4023 { GET_LD
4024 wrappedIO *wio = handle;
4025
4026 if ( LD->prompt.next && ttymode != TTY_RAW )
4027 PL_write_prompt(TRUE);
4028 else
4029 Sflush(Suser_output);
4030
4031 size = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size);
4032 if ( size == 0 ) /* end-of-file */
4033 { Sclearerr(Suser_input);
4034 LD->prompt.next = TRUE;
4035 } else if ( size > 0 && buf[size-1] == '\n' )
4036 LD->prompt.next = TRUE;
4037
4038 return size;
4039 }
4040
4041
4042 static int
closeWrappedIO(void * handle)4043 closeWrappedIO(void *handle)
4044 { wrappedIO *wio = handle;
4045 int rval;
4046
4047 if ( wio->wrapped_functions->close )
4048 rval = (*wio->wrapped_functions->close)(wio->wrapped_handle);
4049 else
4050 rval = 0;
4051
4052 wio->wrapped_stream->functions = wio->wrapped_functions;
4053 wio->wrapped_stream->handle = wio->wrapped_handle;
4054 PL_free(wio);
4055
4056 return rval;
4057 }
4058
4059
4060 static void
wrapIO(IOSTREAM * s,ssize_t (* read)(void *,char *,size_t),ssize_t (* write)(void *,char *,size_t))4061 wrapIO(IOSTREAM *s,
4062 ssize_t (*read)(void *, char *, size_t),
4063 ssize_t (*write)(void *, char *, size_t))
4064 { wrappedIO *wio = PL_malloc(sizeof(*wio));
4065
4066 wio->wrapped_functions = s->functions;
4067 wio->wrapped_handle = s->handle;
4068 wio->wrapped_stream = s;
4069
4070 wio->functions = *s->functions;
4071 if ( read ) wio->functions.read = read;
4072 if ( write ) wio->functions.write = write;
4073 wio->functions.close = closeWrappedIO;
4074
4075 s->functions = &wio->functions;
4076 s->handle = wio;
4077 }
4078
4079
4080 static
4081 PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
4082 { PRED_LD
4083 IOSTREAM *in = NULL, *out = NULL, *error = NULL;
4084 int rval = FALSE;
4085 int wrapin = FALSE;
4086
4087 if ( !get_stream_handle(A1, &in, SH_ERRORS|SH_ALIAS|SH_UNLOCKED) ||
4088 !get_stream_handle(A2, &out, SH_ERRORS|SH_ALIAS) )
4089 goto out;
4090
4091 wrapin = (LD->IO.streams[0] != in);
4092 if ( wrapin )
4093 in = getStream(in); /* lock it */
4094
4095 if ( PL_compare(A2, A3) == 0 ) /* == */
4096 { error = getStream(Snew(out->handle, out->flags, out->functions));
4097 error->flags &= ~SIO_ABUF; /* disable buffering */
4098 error->flags |= SIO_NBUF;
4099 } else
4100 { if ( !PL_get_stream_handle(A3, &error) )
4101 goto out;
4102 }
4103
4104 LOCK();
4105 out->flags &= ~SIO_ABUF; /* output: line buffered */
4106 out->flags |= SIO_LBUF;
4107
4108 LD->IO.streams[1] = out; /* user_output */
4109 LD->IO.streams[2] = error; /* user_error */
4110 LD->IO.streams[4] = out; /* current_output */
4111
4112 if ( wrapin )
4113 { LD->IO.streams[3] = in; /* current_input */
4114 LD->IO.streams[0] = in; /* user_input */
4115 wrapIO(in, Sread_user, NULL);
4116 LD->prompt.next = TRUE;
4117 }
4118
4119 UNLOCK();
4120 rval = TRUE;
4121
4122 out:
4123 if ( wrapin && in )
4124 releaseStream(in);
4125 if ( out )
4126 releaseStream(out);
4127 if ( error && error != out )
4128 releaseStream(error);
4129
4130 return rval;
4131 }
4132
4133
4134 static
4135 PRED_IMPL("$size_stream", 2, size_stream, 0)
4136 { GET_LD
4137 IOSTREAM *s;
4138 int rval;
4139
4140 if ( !PL_get_stream_handle(A1, &s) )
4141 return FALSE;
4142
4143 rval = PL_unify_integer(A2, Ssize(s));
4144 PL_release_stream(s);
4145
4146 return rval;
4147 }
4148
4149
4150 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4151 copy_stream_data(+StreamIn, +StreamOut, [Len])
4152 Copy all data from StreamIn to StreamOut. Should be somewhere else,
4153 and maybe we need something else to copy resources.
4154 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4155
4156 static int
copy_stream_data(term_t in,term_t out,term_t len ARG_LD)4157 copy_stream_data(term_t in, term_t out, term_t len ARG_LD)
4158 { IOSTREAM *i, *o;
4159 int c;
4160 int count = 0;
4161
4162 if ( !getInputStream(in, &i) )
4163 return FALSE;
4164 if ( !getOutputStream(out, &o) )
4165 { releaseStream(i);
4166 return FALSE;
4167 }
4168
4169 if ( !len )
4170 { while ( (c = Sgetcode(i)) != EOF )
4171 { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
4172 { releaseStream(i);
4173 releaseStream(o);
4174 return FALSE;
4175 }
4176 if ( Sputcode(c, o) < 0 )
4177 { releaseStream(i);
4178 return streamStatus(o);
4179 }
4180 }
4181 } else
4182 { int64_t n;
4183
4184 if ( !PL_get_int64_ex(len, &n) )
4185 return FALSE;
4186
4187 while ( n-- > 0 && (c = Sgetcode(i)) != EOF )
4188 { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
4189 { releaseStream(i);
4190 releaseStream(o);
4191 return FALSE;
4192 }
4193 if ( Sputcode(c, o) < 0 )
4194 { releaseStream(i);
4195 return streamStatus(o);
4196 }
4197 }
4198 }
4199
4200 releaseStream(o);
4201 return streamStatus(i);
4202 }
4203
4204 static
4205 PRED_IMPL("copy_stream_data", 3, copy_stream_data3, 0)
4206 { PRED_LD
4207 return copy_stream_data(A1, A2, A3 PASS_LD);
4208 }
4209
4210 static
4211 PRED_IMPL("copy_stream_data", 2, copy_stream_data2, 0)
4212 { PRED_LD
4213 return copy_stream_data(A1, A2, 0 PASS_LD);
4214 }
4215
4216
4217
4218 /*******************************
4219 * PUBLISH PREDICATES *
4220 *******************************/
4221
4222 BeginPredDefs(file)
4223 /* ISO IO */
4224 PRED_DEF("swi_open", 4, open4, PL_FA_ISO)
4225 PRED_DEF("swi_open", 3, open3, PL_FA_ISO)
4226 PRED_DEF("swi_close", 1, close, PL_FA_ISO)
4227 PRED_DEF("swi_close", 2, close2, PL_FA_ISO)
4228 PRED_DEF("swi_set_input", 1, set_input, PL_FA_ISO)
4229 PRED_DEF("swi_set_output", 1, set_output, PL_FA_ISO)
4230 PRED_DEF("swi_current_input", 1, current_input, PL_FA_ISO)
4231 PRED_DEF("swi_current_output", 1, current_output, PL_FA_ISO)
4232 PRED_DEF("swi_get_code", 2, get_code2, PL_FA_ISO)
4233 PRED_DEF("swi_get_code", 1, get_code1, PL_FA_ISO)
4234 PRED_DEF("swi_get_char", 2, get_char2, PL_FA_ISO)
4235 PRED_DEF("swi_get_char", 1, get_char1, PL_FA_ISO)
4236 PRED_DEF("swi_get_byte", 2, get_byte2, PL_FA_ISO)
4237 PRED_DEF("swi_get_byte", 1, get_byte1, PL_FA_ISO)
4238 PRED_DEF("swi_peek_code", 2, peek_code2, PL_FA_ISO)
4239 PRED_DEF("swi_peek_code", 1, peek_code1, PL_FA_ISO)
4240 PRED_DEF("swi_peek_char", 2, peek_char2, PL_FA_ISO)
4241 PRED_DEF("swi_peek_char", 1, peek_char1, PL_FA_ISO)
4242 PRED_DEF("swi_peek_byte", 2, peek_byte2, PL_FA_ISO)
4243 PRED_DEF("swi_peek_byte", 1, peek_byte1, PL_FA_ISO)
4244 PRED_DEF("swi_put_byte", 2, put_byte2, PL_FA_ISO)
4245 PRED_DEF("swi_put_byte", 1, put_byte1, PL_FA_ISO)
4246 PRED_DEF("swi_put_code", 2, put_code2, PL_FA_ISO)
4247 PRED_DEF("swi_put_code", 1, put_code1, PL_FA_ISO)
4248 PRED_DEF("swi_put_char", 2, put_code2, PL_FA_ISO)
4249 PRED_DEF("swi_put_char", 1, put_code1, PL_FA_ISO)
4250 PRED_DEF("swi_flush_output", 0, flush_output, PL_FA_ISO)
4251 PRED_DEF("swi_flush_output", 1, flush_output1, PL_FA_ISO)
4252 PRED_DEF("swi_at_end_of_stream", 1, at_end_of_stream, PL_FA_ISO)
4253 PRED_DEF("swi_at_end_of_stream", 0, at_end_of_stream0, PL_FA_ISO)
4254 PRED_DEF("swi_stream_property", 2, stream_property,
4255 PL_FA_ISO|PL_FA_NONDETERMINISTIC)
4256 PRED_DEF("swi_set_stream_position", 2, set_stream_position, PL_FA_ISO)
4257
4258 /* edinburgh IO */
4259 PRED_DEF("swi_see", 1, see, 0)
4260 PRED_DEF("swi_seen", 0, seen, 0)
4261 PRED_DEF("swi_seeing", 1, seeing, 0)
4262 PRED_DEF("swi_tell", 1, tell, 0)
4263 PRED_DEF("swi_append", 1, append, 0)
4264 PRED_DEF("swi_told", 0, told, 0)
4265 PRED_DEF("swi_telling", 1, telling, 0)
4266 PRED_DEF("swi_put", 2, put2, 0)
4267 PRED_DEF("swi_put", 1, put1, 0)
4268 PRED_DEF("swi_skip", 1, skip1, 0)
4269 PRED_DEF("swi_skip", 2, skip2, 0)
4270 PRED_DEF("swi_get", 1, get1, 0)
4271 PRED_DEF("swi_get", 2, get2, 0)
4272 PRED_DEF("swi_get0", 2, get_code2, 0)
4273 PRED_DEF("swi_get0", 1, get_code1, 0)
4274 PRED_DEF("swi_ttyflush", 0, ttyflush, 0)
4275 PRED_DEF("swi_prompt", 2, prompt, 0)
4276 PRED_DEF("swi_tab", 2, tab2, 0)
4277 PRED_DEF("swi_tab", 1, tab1, 0)
4278 /* Quintus IO */
4279 PRED_DEF("swi_byte_count", 2, byte_count, 0)
4280 PRED_DEF("swi_character_count", 2, character_count, 0)
4281 PRED_DEF("swi_line_count", 2, line_count, 0)
4282 PRED_DEF("swi_line_position", 2, line_position, 0)
4283 PRED_DEF("swi_open_null_stream", 1, open_null_stream, 0)
4284
4285 /* SWI specific */
4286 PRED_DEF("swi_is_stream", 1, is_stream, 0)
4287 PRED_DEF("swi_set_stream", 2, set_stream, 0)
4288 PRED_DEF("swi_with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
4289 PRED_DEF("swi_set_prolog_IO", 3, set_prolog_IO, 0)
4290 PRED_DEF("swi_protocol", 1, protocol, 0)
4291 PRED_DEF("swi_protocola", 1, protocola, 0)
4292 PRED_DEF("swi_noprotocol", 0, noprotocol, 0)
4293 PRED_DEF("swi_protocolling", 1, protocolling, 0)
4294 PRED_DEF("swi_prompt1", 1, prompt1, 0)
4295 PRED_DEF("swi_seek", 4, seek, 0)
4296 PRED_DEF("swi_wait_for_input", 3, wait_for_input, 0)
4297 PRED_DEF("swi_get_single_char", 1, get_single_char, 0)
4298 PRED_DEF("swi_read_pending_input", 3, read_pending_input, 0)
4299 PRED_DEF("swi_source_location", 2, source_location, 0)
4300 PRED_DEF("swi_copy_stream_data", 3, copy_stream_data3, 0)
4301 PRED_DEF("swi_copy_stream_data", 2, copy_stream_data2, 0)
4302
4303 /* SWI internal */
4304 PRED_DEF("swi_$push_input_context", 0, push_input_context, 0)
4305 PRED_DEF("swi_$pop_input_context", 0, pop_input_context, 0)
4306 PRED_DEF("swi_$size_stream", 2, size_stream, 0)
4307 EndPredDefs
4308
4309 #if __YAP_PROLOG__
4310 static int
pl_Sgetc(IOSTREAM * s)4311 pl_Sgetc(IOSTREAM *s)
4312 {
4313 return Sgetc(s);
4314 }
4315
4316 /* copied by VSC */
4317
4318 static word
pl_nl1(term_t stream)4319 pl_nl1(term_t stream)
4320 { IOSTREAM *s;
4321
4322 if ( getOutputStream(stream, &s) )
4323 { Sputcode('\n', s);
4324 return streamStatus(s);
4325 }
4326
4327 fail;
4328 }
4329
4330 static word
pl_nl(void)4331 pl_nl(void)
4332 { return pl_nl1(0);
4333 }
4334
4335 static const PL_extension foreigns[] = {
4336 FRG("swi_nl", 0, pl_nl, ISO),
4337 FRG("swi_nl", 1, pl_nl1, ISO),
4338 /* DO NOT ADD ENTRIES BELOW THIS ONE */
4339 FRG((char *)NULL, 0, NULL, 0)
4340 };
4341
4342 static int
get_stream_handle_no_errors(term_t t,int read,int write,IOSTREAM ** s)4343 get_stream_handle_no_errors(term_t t, int read, int write, IOSTREAM **s)
4344 { GET_LD
4345 if ( t == 0 )
4346 { if (write) *s = getStream(Scurout);
4347 else *s = getStream(Scurin);
4348 return TRUE;
4349 }
4350 return get_stream_handle(t, s, SH_ALIAS);
4351 }
4352
4353 static int
get_stream_position(IOSTREAM * s,term_t t)4354 get_stream_position(IOSTREAM *s, term_t t)
4355 { GET_LD
4356 return stream_position_prop(s, t);
4357 }
4358
4359 static void
init_yap_extras(void)4360 init_yap_extras(void)
4361 {
4362 swi_io_struct swiio;
4363
4364 swiio.f = FUNCTOR_dstream1;
4365 swiio.get_c = pl_Sgetc;
4366 swiio.put_c = Sputc;
4367 swiio.get_w = Sgetcode;
4368 swiio.put_w = Sputcode;
4369 swiio.flush_s = Sflush;
4370 swiio.close_s = closeStream;
4371 swiio.get_stream_handle = get_stream_handle_no_errors;
4372 swiio.get_stream_position = get_stream_position;
4373 PL_YAP_InitSWIIO(&swiio);
4374 initCharTypes();
4375 initFiles();
4376 initGlob();
4377 PL_register_extensions(PL_predicates_from_file);
4378 PL_register_extensions(foreigns);
4379 fileerrors = TRUE;
4380 SinitStreams();
4381 }
4382
4383 #ifdef _WIN32
4384
4385 #include <windows.h>
4386
4387 int WINAPI PROTO(win_plstream, (HANDLE, DWORD, LPVOID));
4388
win_plstream(HANDLE hinst,DWORD reason,LPVOID reserved)4389 int WINAPI win_plstream(HANDLE hinst, DWORD reason, LPVOID reserved)
4390 {
4391 switch (reason)
4392 {
4393 case DLL_PROCESS_ATTACH:
4394 break;
4395 case DLL_PROCESS_DETACH:
4396 break;
4397 case DLL_THREAD_ATTACH:
4398 break;
4399 case DLL_THREAD_DETACH:
4400 break;
4401 }
4402 return 1;
4403 }
4404 #endif
4405 #endif
4406