1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 2011-2020, University of Amsterdam
7 VU University Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 This module is far too big. It defines a layer around open(), etc. to
38 get opening and closing of files to the symbolic level required for
39 Prolog. It also defines basic I/O predicates, stream based I/O and
40 finally a bundle of operations on files, such as name expansion,
41 renaming, deleting, etc. Most of this module is rather straightforward.
42
43 If time is there I will have a look at all this to clean it. Notably
44 handling times must be cleaned, but that not only holds for this module.
45 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
46
47 /*#define O_DEBUG 1*/
48 /*#define O_DEBUG_MT 1*/
49
50 #ifdef __WINDOWS__
51 #include <winsock2.h>
52 #include <windows.h>
53 #endif
54
55 #define NEEDS_SWINSOCK
56 #include "pl-incl.h"
57 #include "pl-arith.h"
58 #include "pl-ctype.h"
59 #include "pl-utf8.h"
60 #include "pl-stream.h"
61 #include <errno.h>
62
63 #if defined(HAVE_POLL_H) && defined(HAVE_POLL)
64 #include <poll.h>
65 #elif defined(HAVE_SYS_SELECT_H)
66 #include <sys/select.h>
67 #endif
68 #ifdef HAVE_SYS_TIME_H
69 #include <sys/time.h>
70 #endif
71 #ifdef HAVE_SYS_PARAM_H
72 #include <sys/param.h>
73 #endif
74 #ifdef HAVE_SYS_FILE_H
75 #include <sys/file.h>
76 #endif
77 #ifdef HAVE_UNISTD_H
78 #include <unistd.h>
79 #include <fcntl.h>
80 #endif
81 #ifdef HAVE_BSTRING_H
82 #include <bstring.h>
83 #endif
84
85 #undef LD /* fetch LD once per function */
86 #define LD LOCAL_LD
87
88 #define STD_HANDLE_MASK 0x10
89
90 /* there are two types of stream property functions. In the usual case,
91 they have an argument, but in a few cases they don't */
92 typedef int (*property0_t)(IOSTREAM *s ARG_LD);
93 typedef int (*property_t)(IOSTREAM *s, term_t prop ARG_LD);
94
95 static int bad_encoding(const char *msg, atom_t name);
96 static int noprotocol(void);
97 static PL_blob_t stream_blob;
98
99 const atom_t standardStreams[] =
100 { ATOM_user_input, /* 0 */
101 ATOM_user_output, /* 1 */
102 ATOM_user_error, /* 2 */
103 ATOM_current_input, /* 3 */
104 ATOM_current_output, /* 4 */
105 ATOM_protocol, /* 5 */
106 NULL_ATOM
107 };
108
109
110 static int
standardStreamIndexFromName(atom_t name)111 standardStreamIndexFromName(atom_t name)
112 { const atom_t *ap;
113
114 for(ap=standardStreams; *ap; ap++)
115 { if ( *ap == name )
116 return (int)(ap - standardStreams);
117 }
118
119 return -1;
120 }
121
122
123 static int
standardStreamIndexFromStream(IOSTREAM * s)124 standardStreamIndexFromStream(IOSTREAM *s)
125 { GET_LD
126 IOSTREAM **sp = LD->IO.streams;
127 int i = 0;
128
129 for( ; i<6; i++, sp++ )
130 { if ( *sp == s )
131 return i;
132 }
133
134 return -1;
135 }
136
137
138 /*******************************
139 * BOOKKEEPING *
140 *******************************/
141
142 static void aliasStream(IOSTREAM *s, atom_t alias);
143 static void unaliasStream(IOSTREAM *s, atom_t name);
144
145 static Table streamAliases; /* alias --> stream */
146 static Table streamContext; /* stream --> extra data */
147
148 typedef struct _alias
149 { struct _alias *next;
150 atom_t name;
151 } alias;
152
153
154 #define IO_TELL 0x001 /* opened by tell/1 */
155 #define IO_SEE 0x002 /* opened by see/1 */
156
157 typedef struct
158 { alias *alias_head;
159 alias *alias_tail;
160 atom_t filename; /* associated filename */
161 unsigned flags;
162 } stream_context;
163
164
165 static stream_context *
getStreamContext(IOSTREAM * s)166 getStreamContext(IOSTREAM *s)
167 { if ( !s->context )
168 { stream_context *ctx = allocHeapOrHalt(sizeof(*ctx));
169
170 DEBUG(1, Sdprintf("Created ctx=%p for stream %p\n", ctx, s));
171
172 if ( s->erased )
173 Sdprintf("WARNING: created stream context for erased stream\n");
174
175 ctx->alias_head = ctx->alias_tail = NULL;
176 ctx->filename = NULL_ATOM;
177 ctx->flags = 0;
178 if ( COMPARE_AND_SWAP_PTR(&s->context, NULL, ctx) )
179 addNewHTable(streamContext, s, ctx);
180 else
181 freeHeap(ctx, sizeof(*ctx));
182 }
183
184 return (stream_context*)s->context;
185 }
186
187 static stream_context *
getExistingStreamContext(IOSTREAM * s)188 getExistingStreamContext(IOSTREAM *s)
189 { return (stream_context*)s->context;
190 }
191
192
193 /* MT: Must be called locked */
194
195 static void
aliasStream(IOSTREAM * s,atom_t name)196 aliasStream(IOSTREAM *s, atom_t name)
197 { GET_LD
198 stream_context *ctx;
199 IOSTREAM *sp;
200 alias *a;
201
202 /* ensure name is free (error?) */
203 if ( (sp = lookupHTable(streamAliases, (void *)name)) )
204 unaliasStream(sp, name);
205
206 ctx = getStreamContext(s);
207 addNewHTable(streamAliases, (void *)name, s);
208 PL_register_atom(name);
209
210 a = allocHeapOrHalt(sizeof(*a));
211 a->next = NULL;
212 a->name = name;
213
214 if ( ctx->alias_tail )
215 { ctx->alias_tail->next = a;
216 ctx->alias_tail = a;
217 } else
218 { ctx->alias_head = ctx->alias_tail = a;
219 }
220 }
221
222 /* MT: Locked by freeStream()
223 */
224
225 static void
unaliasStream(IOSTREAM * s,atom_t name)226 unaliasStream(IOSTREAM *s, atom_t name)
227 { GET_LD
228 if ( name )
229 { if ( lookupHTable(streamAliases, (void *)name) )
230 { stream_context *ctx;
231
232 deleteHTable(streamAliases, (void *)name);
233
234 if ( (ctx=getExistingStreamContext(s)) )
235 { alias **a;
236
237 for(a = &ctx->alias_head; *a; a = &(*a)->next)
238 { if ( (*a)->name == name )
239 { alias *tmp = *a;
240
241 *a = tmp->next;
242 freeHeap(tmp, sizeof(*tmp));
243 if ( tmp == ctx->alias_tail )
244 ctx->alias_tail = NULL;
245
246 break;
247 }
248 }
249 }
250
251 PL_unregister_atom(name);
252 }
253 } else /* delete them all */
254 { stream_context *ctx;
255
256 if ( (ctx=getExistingStreamContext(s)) )
257 { alias *a, *n;
258
259 for(a = ctx->alias_head; a; a=n)
260 { n = a->next;
261
262 if ( lookupHTable(streamAliases, (void *)a->name) )
263 { deleteHTable(streamAliases, (void *)a->name);
264 PL_unregister_atom(a->name);
265 }
266
267 freeHeap(a, sizeof(*a));
268 }
269
270 ctx->alias_head = ctx->alias_tail = NULL;
271 }
272 }
273 }
274
275
276 static void
freeStream(IOSTREAM * s)277 freeStream(IOSTREAM *s)
278 { GET_LD
279 stream_context *ctx;
280 int i;
281 IOSTREAM **sp;
282
283 DEBUG(1, Sdprintf("freeStream(%p)\n", s));
284
285 PL_LOCK(L_FILE);
286 unaliasStream(s, NULL_ATOM);
287 ctx = s->context;
288 if ( ctx && COMPARE_AND_SWAP_PTR(&s->context, ctx, NULL) )
289 { deleteHTable(streamContext, s);
290 if ( ctx->filename != NULL_ATOM )
291 { PL_unregister_atom(ctx->filename);
292
293 if ( ctx->filename == source_file_name )
294 { source_file_name = NULL_ATOM; /* TBD: pop? */
295 source_line_no = -1;
296 }
297 }
298
299 freeHeap(ctx, sizeof(*ctx));
300 }
301 /* if we are a standard stream */
302 /* reassociate with standard I/O */
303 /* NOTE: there may be more! */
304 if (
305 #ifdef O_PLMT
306 LD &&
307 #endif
308 (sp=LD->IO.streams) )
309 { for(i=0; i<6; i++, sp++)
310 { if ( *sp == s )
311 { if ( s->flags & SIO_INPUT )
312 *sp = Sinput;
313 else if ( sp == &Suser_error )
314 *sp = Serror;
315 else if ( sp == &Sprotocol )
316 *sp = NULL;
317 else
318 *sp = Soutput;
319 }
320 }
321 }
322 PL_UNLOCK(L_FILE);
323 }
324
325
326 /* MT: locked by caller (openStream()) */
327 /* name must be registered by the caller */
328
329 static void
setFileNameStream_unlocked(IOSTREAM * s,atom_t name)330 setFileNameStream_unlocked(IOSTREAM *s, atom_t name)
331 { stream_context *ctx = getStreamContext(s);
332
333 if ( ctx->filename )
334 { PL_unregister_atom(ctx->filename);
335 ctx->filename = NULL_ATOM;
336 }
337 if ( !(name == NULL_ATOM || name == ATOM_) )
338 ctx->filename = name;
339 }
340
341
342 int
setFileNameStream(IOSTREAM * s,atom_t name)343 setFileNameStream(IOSTREAM *s, atom_t name)
344 { PL_LOCK(L_FILE);
345 setFileNameStream_unlocked(s, name);
346 PL_register_atom(name);
347 PL_UNLOCK(L_FILE);
348
349 return TRUE;
350 }
351
352
353 atom_t
fileNameStream(IOSTREAM * s)354 fileNameStream(IOSTREAM *s)
355 { atom_t name;
356
357 PL_LOCK(L_FILE);
358 name = getStreamContext(s)->filename;
359 PL_UNLOCK(L_FILE);
360
361 return name;
362 }
363
364
365 void
initIO(void)366 initIO(void)
367 { GET_LD
368 const atom_t *np;
369 int i;
370
371 streamAliases = newHTable(16);
372 streamContext = newHTable(16);
373 PL_register_blob_type(&stream_blob);
374
375 if ( false(Sinput, SIO_ISATTY) ||
376 false(Soutput, SIO_ISATTY) )
377 { /* clear PLFLAG_TTY_CONTROL */
378 PL_set_prolog_flag("tty_control", PL_BOOL, FALSE);
379 }
380
381 ResetTty();
382
383 Sclosehook(freeStream);
384
385 Sinput->position = &Sinput->posbuf; /* position logging */
386 Soutput->position = &Sinput->posbuf;
387 Serror->position = &Sinput->posbuf;
388
389 PushTty(Sinput, &ttytab, TTY_SAVE);
390 ttymodified = FALSE;
391 ttyfileno = Sfileno(Sinput);
392 LD->prompt.current = ATOM_prompt;
393 PL_register_atom(ATOM_prompt);
394
395 Suser_input = Sinput;
396 Suser_output = Soutput;
397 Suser_error = Serror;
398 Scurin = Sinput; /* see/tell */
399 Scurout = Soutput;
400 Sprotocol = NULL; /* protocolling */
401
402 getStreamContext(Sinput); /* add for enumeration */
403 getStreamContext(Soutput);
404 getStreamContext(Serror);
405
406 for( i=0, np = standardStreams; *np; np++, i++ )
407 addNewHTable(streamAliases, (void *)*np, (void *)(intptr_t)(i ^ STD_HANDLE_MASK));
408
409 GD->io_initialised = TRUE;
410 }
411
412
413 /*******************************
414 * GET HANDLES *
415 *******************************/
416
417 static inline IOSTREAM *
getStream(IOSTREAM * s)418 getStream(IOSTREAM *s)
419 { if ( s && s->magic == SIO_MAGIC && Slock(s) == 0 )
420 { if ( unlikely(s->magic == SIO_CMAGIC) )
421 { Sunlock(s);
422 return NULL;
423 }
424 return s;
425 }
426
427 return NULL;
428 }
429
430 static inline IOSTREAM *
tryGetStream(IOSTREAM * s)431 tryGetStream(IOSTREAM *s)
432 { if ( s && s->magic == SIO_MAGIC && StryLock(s) == 0 )
433 { if ( unlikely(s->magic == SIO_CMAGIC) )
434 { Sunlock(s);
435 return NULL;
436 }
437 return s;
438 }
439
440 return NULL;
441 }
442
443 static int
releaseStream(IOSTREAM * s)444 releaseStream(IOSTREAM *s)
445 { if ( s->magic == SIO_MAGIC )
446 return Sunlock(s) == 0;
447 return TRUE;
448 }
449
450 int
PL_release_stream(IOSTREAM * s)451 PL_release_stream(IOSTREAM *s)
452 { return streamStatus(s);
453 }
454
455 int
PL_release_stream_noerror(IOSTREAM * s)456 PL_release_stream_noerror(IOSTREAM *s)
457 { if ( !releaseStream(s) )
458 PL_clear_exception();
459
460 return TRUE;
461 }
462
463 IOSTREAM *
PL_acquire_stream(IOSTREAM * s)464 PL_acquire_stream(IOSTREAM *s)
465 { return getStream(s);
466 }
467
468
469
470 /*******************************
471 * ERRORS *
472 *******************************/
473
474 static int symbol_no_stream(atom_t symbol);
475
476 static int
no_stream(term_t t,atom_t name)477 no_stream(term_t t, atom_t name)
478 { if ( t )
479 return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_stream, t);
480 else
481 return symbol_no_stream(name);
482 }
483
484 static int
not_a_stream(term_t t)485 not_a_stream(term_t t)
486 { return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream_or_alias, t);
487 }
488
489 static int
symbol_no_stream(atom_t symbol)490 symbol_no_stream(atom_t symbol)
491 { GET_LD
492 term_t t;
493
494 if ( (t = PL_new_term_ref()) )
495 { PL_put_atom(t, symbol);
496 return no_stream(t, 0);
497 } else
498 return FALSE;
499 }
500
501 static int
symbol_not_a_stream(atom_t symbol)502 symbol_not_a_stream(atom_t symbol)
503 { GET_LD
504 term_t t = PL_new_term_ref();
505 PL_put_atom(t, symbol);
506 return not_a_stream(t);
507 }
508
509
510 static int
symbol_stream_pair_not_allowed(atom_t symbol)511 symbol_stream_pair_not_allowed(atom_t symbol)
512 { GET_LD
513 term_t t = PL_new_term_ref();
514 PL_put_atom(t, symbol);
515
516 return PL_error(NULL, 0, "operation is ambiguous on a stream pair",
517 ERR_TYPE, ATOM_stream, t);
518 }
519
520
521
522 /*******************************
523 * PROLOG HANDLES *
524 *******************************/
525
526 typedef struct stream_ref
527 { IOSTREAM *read;
528 IOSTREAM *write;
529 } stream_ref;
530
531
532 static int
write_stream_ref(IOSTREAM * s,atom_t aref,int flags)533 write_stream_ref(IOSTREAM *s, atom_t aref, int flags)
534 { stream_ref *ref = PL_blob_data(aref, NULL, NULL);
535 (void)flags;
536
537 if ( ref->read && ref->write )
538 Sfprintf(s, "<stream>(%p,%p)", ref->read, ref->write);
539 else if ( ref->read )
540 Sfprintf(s, "<stream>(%p)", ref->read);
541 else
542 Sfprintf(s, "<stream>(%p)", ref->write);
543
544 return TRUE;
545 }
546
547
548 static void
acquire_stream_ref(atom_t aref)549 acquire_stream_ref(atom_t aref)
550 { stream_ref *ref = PL_blob_data(aref, NULL, NULL);
551
552 if ( ref->read )
553 Sreference(ref->read);
554 if ( ref->write )
555 Sreference(ref->write);
556 }
557
558
559 static int
release_stream_ref(atom_t aref)560 release_stream_ref(atom_t aref)
561 { stream_ref *ref = PL_blob_data(aref, NULL, NULL);
562
563 if ( ref->read )
564 { if ( Sunreference(ref->read) == 0 && ref->read->erased )
565 unallocStream(ref->read);
566 }
567 if ( ref->write )
568 { if ( Sunreference(ref->write) == 0 && ref->write->erased )
569 unallocStream(ref->write);
570 }
571
572 return TRUE;
573 }
574
575
576 static int
save_stream_ref(atom_t aref,IOSTREAM * fd)577 save_stream_ref(atom_t aref, IOSTREAM *fd)
578 { stream_ref *ref = PL_blob_data(aref, NULL, NULL);
579 (void)fd;
580
581 return PL_warning("Cannot save reference to <stream>(%p,%p)",
582 ref->read, ref->write);
583 }
584
585
586 static atom_t
load_stream_ref(IOSTREAM * fd)587 load_stream_ref(IOSTREAM *fd)
588 { (void)fd;
589
590 return PL_new_atom("<saved-stream-ref>");
591 }
592
593
594 static PL_blob_t stream_blob =
595 { PL_BLOB_MAGIC,
596 PL_BLOB_UNIQUE,
597 "stream",
598 release_stream_ref,
599 NULL,
600 write_stream_ref,
601 acquire_stream_ref,
602 save_stream_ref,
603 load_stream_ref
604 };
605
606
607 #define SH_ERRORS 0x01 /* generate errors */
608 #define SH_ALIAS 0x02 /* allow alias */
609 #define SH_UNLOCKED 0x04 /* don't lock the stream */
610 #define SH_OUTPUT 0x08 /* We want an output stream */
611 #define SH_INPUT 0x10 /* We want an input stream */
612 #define SH_NOPAIR 0x20 /* Do not allow for a pair */
613
614 static int
get_stream_handle__LD(atom_t a,IOSTREAM ** sp,int flags ARG_LD)615 get_stream_handle__LD(atom_t a, IOSTREAM **sp, int flags ARG_LD)
616 { stream_ref *ref;
617 PL_blob_t *type;
618 IOSTREAM *s;
619
620 ref = PL_blob_data(a, NULL, &type);
621 if ( type == &stream_blob )
622 { if ( ref->read ) assert(ref->read->references);
623 if ( ref->write ) assert(ref->write->references);
624
625 if ( ref->read )
626 { if ( ref->write )
627 { if ( (flags&SH_OUTPUT) )
628 s = ref->write;
629 else if ( (flags&SH_INPUT) )
630 s = ref->read;
631 else if ( (flags&SH_NOPAIR) )
632 { if ( truePrologFlag(PLFLAG_ERROR_AMBIGUOUS_STREAM_PAIR) )
633 { return symbol_stream_pair_not_allowed(a);
634 } else
635 { term_t t;
636
637 if ( (t=PL_new_term_ref()) &&
638 PL_put_atom(t, a) )
639 { if ( !printMessage(ATOM_warning,
640 PL_FUNCTOR_CHARS, "ambiguous_stream_pair", 1,
641 PL_TERM, t) )
642 return FALSE;
643 }
644 s = ref->read;
645 }
646 } else
647 s = ref->read; /* dubious */
648 } else
649 s = ref->read;
650 } else
651 s = ref->write;
652
653 if ( s->erased )
654 goto noent;
655
656 if ( flags & SH_UNLOCKED )
657 { assert( s->magic == SIO_MAGIC || s->magic == SIO_CMAGIC );
658 *sp = s;
659 return TRUE;
660 } else if ( (s=getStream(s)) )
661 { *sp = s;
662 return TRUE;
663 }
664
665 return symbol_no_stream(a);
666 } else
667 { void *s0;
668
669 if ( !(flags & SH_UNLOCKED) )
670 PL_LOCK(L_FILE);
671 if ( (s0 = lookupHTable(streamAliases, (void *)a)) )
672 { IOSTREAM *stream;
673 uintptr_t n = (uintptr_t)s0 & ~STD_HANDLE_MASK;
674
675 if ( n < 6 ) /* standard stream! */
676 { stream = LD->IO.streams[n]; /* TBD: No need to lock for std-streams */
677 } else
678 stream = s0;
679
680 if ( !(flags & SH_UNLOCKED) )
681 PL_UNLOCK(L_FILE);
682
683 if ( stream )
684 { if ( (flags & SH_UNLOCKED) )
685 { if ( stream->magic == SIO_MAGIC )
686 { *sp = stream;
687 return TRUE;
688 }
689 } else if ( (*sp = getStream(stream)) )
690 return TRUE;
691 goto noent;
692 }
693 }
694 if ( !(flags & SH_UNLOCKED) )
695 PL_UNLOCK(L_FILE);
696
697 goto noent;
698 }
699
700 if ( flags & SH_ERRORS )
701 symbol_not_a_stream(a);
702
703 return FALSE;
704
705 noent:
706 if ( flags & SH_ERRORS )
707 symbol_no_stream(a);
708
709 return FALSE;
710 }
711
712 #define get_stream_handle(t, sp, flags) \
713 get_stream_handle__LD(t, sp, flags PASS_LD)
714
715
716 static int
term_stream_handle(term_t t,IOSTREAM ** s,int flags ARG_LD)717 term_stream_handle(term_t t, IOSTREAM **s, int flags ARG_LD)
718 { atom_t a;
719
720 if ( !PL_get_atom(t, &a) )
721 return not_a_stream(t);
722
723 return get_stream_handle(a, s, flags);
724 }
725
726
727 int
PL_get_stream_handle(term_t t,IOSTREAM ** s)728 PL_get_stream_handle(term_t t, IOSTREAM **s)
729 { GET_LD
730
731 return term_stream_handle(t, s, SH_ERRORS|SH_ALIAS|SH_NOPAIR PASS_LD);
732 }
733
734
735 int
PL_get_stream(term_t t,IOSTREAM ** s,int flags)736 PL_get_stream(term_t t, IOSTREAM **s, int flags)
737 { GET_LD
738 int myflags = SH_ERRORS|SH_ALIAS;
739
740 if ( flags&SIO_INPUT ) myflags |= SH_INPUT;
741 if ( flags&SIO_OUTPUT ) myflags |= SH_OUTPUT;
742 if ( flags&SIO_NOERROR ) myflags &= ~SH_ERRORS;
743 if ( !(flags&(SIO_INPUT|SIO_OUTPUT)) )
744 myflags |= SH_NOPAIR;
745
746 return term_stream_handle(t, s, myflags PASS_LD);
747 }
748
749
750 static int
unify_stream_ref(term_t t,IOSTREAM * s)751 unify_stream_ref(term_t t, IOSTREAM *s)
752 { GET_LD
753 stream_ref ref;
754 int rval;
755
756 memset(&ref, 0, sizeof(ref));
757 if ( s->flags & SIO_INPUT )
758 ref.read = s;
759 else
760 ref.write = s;
761
762 rval = PL_unify_blob(t, &ref, sizeof(ref), &stream_blob);
763
764 if ( !rval && !PL_is_variable(t) )
765 return PL_error(NULL, 0, "stream-argument", ERR_UNINSTANTIATION, 0, t);
766
767 return rval;
768 }
769
770
771 int
PL_unify_stream_or_alias(term_t t,IOSTREAM * s)772 PL_unify_stream_or_alias(term_t t, IOSTREAM *s)
773 { GET_LD
774 int rval;
775 stream_context *ctx;
776 int i;
777
778 if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
779 return PL_unify_atom(t, standardStreams[i]);
780
781 if ( (ctx=getExistingStreamContext(s)) && ctx->alias_head )
782 { PL_LOCK(L_FILE);
783 if ( ctx->alias_head )
784 rval = PL_unify_atom(t, ctx->alias_head->name);
785 else
786 rval = unify_stream_ref(t, s);
787 PL_UNLOCK(L_FILE);
788 } else
789 { rval = unify_stream_ref(t, s);
790 }
791
792 return rval;
793 }
794
795
796 int
PL_unify_stream(term_t t,IOSTREAM * s)797 PL_unify_stream(term_t t, IOSTREAM *s)
798 { (void)getStreamContext(s); /* get stream known to Prolog */
799
800 return unify_stream_ref(t, s);
801 }
802
803
804 IOSTREAM ** /* provide access to Suser_input, */
_PL_streams(void)805 _PL_streams(void) /* Suser_output and Suser_error */
806 { GET_LD
807 return &Suser_input;
808 }
809
810
811 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
812 getInputStream(term_t t, IOSTREAM **s)
813 getOutputStream(term_t t, IOSTREAM **s)
814 These functions are the basis used by all Prolog predicates to get
815 a input or output stream handle. If t = 0, current input/output is
816 returned. This allows us to define the standard-stream based version
817 simply by calling the explicit stream-based version with 0 for the
818 stream argument.
819
820 MT: The returned stream is always locked and should be returned
821 using releaseStream() or streamStatus().
822 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
823
824 typedef enum
825 { S_DONTCARE = 0,
826 S_TEXT,
827 S_BINARY
828 } s_type;
829
830
831 static int
checkStreamType(s_type text,IOSTREAM * s,atom_t * error ARG_LD)832 checkStreamType(s_type text, IOSTREAM *s, atom_t *error ARG_LD)
833 { if ( text == S_DONTCARE || LD->IO.stream_type_check == ST_FALSE )
834 return TRUE; /* no checking */
835
836 /* ok? */
837 if ( text == S_TEXT && (s->flags&SIO_TEXT) )
838 return TRUE;
839 if ( text == S_BINARY && !(s->flags&SIO_TEXT) )
840 return TRUE;
841 /* no */
842 if ( LD->IO.stream_type_check == ST_LOOSE )
843 { if ( text == S_TEXT )
844 return TRUE;
845 if ( s->encoding == ENC_ISO_LATIN_1 ||
846 s->encoding == ENC_OCTET )
847 return TRUE;
848 }
849
850 *error = (text == S_TEXT ? ATOM_binary_stream : ATOM_text_stream);
851 return FALSE;
852 }
853
854
855 static int
getOutputStream__LD(term_t t,s_type text,IOSTREAM ** stream ARG_LD)856 getOutputStream__LD(term_t t, s_type text, IOSTREAM **stream ARG_LD)
857 { atom_t a;
858 IOSTREAM *s;
859 atom_t tp;
860
861 if ( t == 0 )
862 { if ( (s = getStream(Scurout)) )
863 goto ok;
864 no_stream(t, ATOM_current_output);
865 return FALSE;
866 }
867
868 if ( !PL_get_atom(t, &a) )
869 { not_a_stream(t);
870 return FALSE;
871 }
872
873 if ( a == ATOM_user )
874 { if ( (s = getStream(Suser_output)) )
875 goto ok;
876 no_stream(t, ATOM_user);
877 return FALSE;
878 }
879
880 if ( !get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS|SH_OUTPUT) )
881 return FALSE;
882
883 ok:
884 if ( !(s->flags&SIO_OUTPUT) )
885 { tp = ATOM_stream;
886 } else if ( checkStreamType(text, s, &tp PASS_LD) )
887 { *stream = s;
888 return TRUE;
889 }
890
891 if ( !releaseStream(s) )
892 return FALSE;
893 if ( t == 0 )
894 { if ( (t = PL_new_term_ref()) )
895 PL_put_atom(t, ATOM_current_output);
896 else
897 return FALSE; /* resource error */
898 }
899 PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_output, tp, t);
900
901 return FALSE;
902 }
903
904
905 int
getTextOutputStream__LD(term_t t,IOSTREAM ** stream ARG_LD)906 getTextOutputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
907 { return getOutputStream(t, S_TEXT, stream);
908 }
909
910
911 int
getBinaryOutputStream__LD(term_t t,IOSTREAM ** stream ARG_LD)912 getBinaryOutputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
913 { return getOutputStream(t, S_BINARY, stream);
914 }
915
916
917 static int
getInputStream__LD(term_t t,s_type text,IOSTREAM ** stream ARG_LD)918 getInputStream__LD(term_t t, s_type text, IOSTREAM **stream ARG_LD)
919 { atom_t a;
920 IOSTREAM *s = NULL; /* make compiler happy */
921 atom_t tp;
922
923 if ( t == 0 )
924 { if ( (s = getStream(Scurin)) )
925 goto ok;
926 no_stream(t, ATOM_current_input);
927 return FALSE;
928 }
929
930 if ( !PL_get_atom(t, &a) )
931 { not_a_stream(t);
932 return FALSE;
933 }
934
935 if ( a == ATOM_user )
936 { if ( (s = getStream(Suser_input)) )
937 goto ok;
938 no_stream(t, ATOM_user);
939 return FALSE;
940 }
941
942 if ( !get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS|SH_INPUT) )
943 return FALSE;
944
945 ok:
946 if ( !(s->flags&SIO_INPUT) )
947 { tp = ATOM_stream;
948 } else if ( checkStreamType(text, s, &tp PASS_LD) )
949 { *stream = s;
950 return TRUE;
951 }
952
953 if ( !releaseStream(s) )
954 return FALSE;
955 if ( t == 0 )
956 { if ( (t = PL_new_term_ref()) )
957 PL_put_atom(t, ATOM_current_input);
958 else
959 return FALSE; /* resource error */
960 }
961 PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_input, tp, t);
962
963 return FALSE;
964 }
965
966 int
getTextInputStream__LD(term_t t,IOSTREAM ** stream ARG_LD)967 getTextInputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
968 { return getInputStream__LD(t, S_TEXT, stream PASS_LD);
969 }
970
971 int
getBinaryInputStream__LD(term_t t,IOSTREAM ** stream ARG_LD)972 getBinaryInputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
973 { return getInputStream__LD(t, S_BINARY, stream PASS_LD);
974 }
975
976
977 /** stream_pairs(+Pair, -Read, -Write)
978 stream_pairs(-Pair, +Read, +Write)
979 */
980
981 static
982 PRED_IMPL("stream_pair", 3, stream_pair, 0)
983 { PRED_LD
984 IOSTREAM *in = NULL, *out = NULL;
985 int rc = FALSE;
986
987 if ( !PL_is_variable(A1) )
988 { stream_ref *ref;
989 atom_t a = 0;
990 PL_blob_t *type;
991 int rc = TRUE;
992
993 if ( PL_get_atom(A1, &a) &&
994 (ref=PL_blob_data(a, NULL, &type)) &&
995 type == &stream_blob )
996 { if ( ref->read && !ref->read->erased )
997 rc = rc && PL_unify_stream_or_alias(A2, ref->read);
998 if ( ref->write && !ref->write->erased )
999 rc = rc && PL_unify_stream_or_alias(A3, ref->write);
1000
1001 return rc;
1002 } else
1003 { IOSTREAM *s;
1004
1005 if ( a && get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS|SH_UNLOCKED) )
1006 { if ( (s->flags & SIO_INPUT) )
1007 rc = PL_unify_stream_or_alias(A2, s);
1008 else
1009 rc = PL_unify_stream_or_alias(A3, s);
1010
1011 return rc;
1012 }
1013
1014 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_stream_pair, A1);
1015 }
1016 }
1017
1018 if ( getInputStream(A2, S_DONTCARE, &in) &&
1019 getOutputStream(A3, S_DONTCARE, &out) )
1020 { stream_ref ref;
1021
1022 ref.read = in;
1023 ref.write = out;
1024
1025 rc = PL_unify_blob(A1, &ref, sizeof(ref), &stream_blob);
1026 if ( rc )
1027 { assert(ref.read->references >= 2);
1028 assert(ref.write->references >= 2);
1029 }
1030 }
1031
1032 if ( in )
1033 rc = releaseStream(in) && rc;
1034 if ( out )
1035 rc = releaseStream(out) && rc;
1036
1037 return rc;
1038 }
1039
1040
1041 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1042 In windows GUI applications, the IO-streams are not bound. We do not
1043 wish to generate an error on the stream errors that may be caused by
1044 this. It is a bit of a hack, but the alternative is to define a stream
1045 that ignores the error. This might get hairy if the user is playing with
1046 these streams too.
1047 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1048
1049 #ifdef __WINDOWS__
1050 static int
isConsoleStream(IOSTREAM * s)1051 isConsoleStream(IOSTREAM *s)
1052 { int i = standardStreamIndexFromStream(s);
1053
1054 return i >= 1 && i < 3; /* only output streams */
1055 }
1056 #else
1057 #define isConsoleStream(s) FALSE
1058 #endif
1059
1060
1061 int
reportStreamError(IOSTREAM * s)1062 reportStreamError(IOSTREAM *s)
1063 { if ( GD->cleaning >= CLN_IO ||
1064 isConsoleStream(s) )
1065 return TRUE;
1066
1067 if ( (s->flags & (SIO_FERR|SIO_WARN)) )
1068 { GET_LD
1069 atom_t op;
1070 term_t stream;
1071 char *msg;
1072
1073 if ( !HAS_LD ||
1074 !(stream=PL_new_term_ref()) ||
1075 !PL_unify_stream_or_alias(stream, s) )
1076 return FALSE;
1077
1078 if ( (s->flags & SIO_FERR) )
1079 { if ( exception_term )
1080 return FALSE;
1081
1082 if ( s->exception )
1083 { fid_t fid;
1084 term_t ex;
1085 int rc;
1086
1087 LD->exception.processing = TRUE; /* allow using spare stack */
1088 if ( !(fid = PL_open_foreign_frame()) )
1089 return FALSE;
1090 ex = PL_new_term_ref();
1091 rc = PL_recorded(s->exception, ex);
1092 PL_erase(s->exception);
1093 s->exception = NULL;
1094 if ( rc )
1095 rc = PL_raise_exception(ex);
1096 Sclearerr(s);
1097 PL_close_foreign_frame(fid);
1098 return rc;
1099 }
1100
1101 if ( s->flags & SIO_INPUT )
1102 { if ( Sfpasteof(s) )
1103 { return PL_error(NULL, 0, NULL, ERR_PERMISSION,
1104 ATOM_input, ATOM_past_end_of_stream, stream);
1105 } else if ( (s->flags & SIO_TIMEOUT) )
1106 { PL_error(NULL, 0, NULL, ERR_TIMEOUT,
1107 ATOM_read, stream);
1108 Sclearerr(s);
1109 return FALSE;
1110 } else
1111 op = ATOM_read;
1112 } else
1113 { if ( (s->flags & SIO_TIMEOUT) )
1114 { PL_error(NULL, 0, NULL, ERR_TIMEOUT,
1115 ATOM_write, stream);
1116 Sclearerr(s);
1117 return FALSE;
1118 } else
1119 op = ATOM_write;
1120 }
1121
1122 if ( s->message )
1123 { msg = s->message;
1124 } else
1125 { msg = MSG_ERRNO;
1126 if ( s->io_errno )
1127 errno = s->io_errno;
1128 }
1129
1130 PL_error(NULL, 0, msg, ERR_STREAM_OP, op, stream);
1131 Sclearerr(s);
1132
1133 return FALSE;
1134 } else
1135 { int rc;
1136
1137 rc = printMessage(ATOM_warning,
1138 PL_FUNCTOR_CHARS, "io_warning", 2,
1139 PL_TERM, stream,
1140 PL_CHARS, s->message);
1141 Sseterr(s, 0, NULL);
1142
1143 return rc;
1144 }
1145 }
1146
1147 return TRUE;
1148 }
1149
1150
1151 int
streamStatus(IOSTREAM * s)1152 streamStatus(IOSTREAM *s)
1153 { if ( (s->flags & (SIO_FERR|SIO_WARN)) )
1154 { int ret = reportStreamError(s);
1155 return releaseStream(s) && ret;
1156 }
1157
1158 return releaseStream(s);
1159 }
1160
1161
1162 /*******************************
1163 * TTY MODES *
1164 *******************************/
1165
1166 ttybuf ttytab; /* saved terminal status on entry */
1167 int ttymodified; /* is tty modified? */
1168 int ttyfileno = -1;
1169
1170 typedef struct input_context * InputContext;
1171 typedef struct output_context * OutputContext;
1172
1173 struct input_context
1174 { IOSTREAM * stream; /* pushed input */
1175 atom_t type; /* Type of input */
1176 atom_t term_file; /* old term_position file */
1177 int term_line; /* old term_position line */
1178 InputContext previous; /* previous context */
1179 };
1180
1181
1182 struct output_context
1183 { IOSTREAM * stream; /* pushed output */
1184 OutputContext previous; /* previous context */
1185 };
1186
1187 #define input_context_stack (LD->IO.input_stack)
1188 #define output_context_stack (LD->IO.output_stack)
1189
1190 static IOSTREAM *openStream(term_t file, term_t mode, term_t options);
1191
1192 void
dieIO(void)1193 dieIO(void)
1194 { if ( GD->io_initialised )
1195 { noprotocol();
1196 closeFiles(TRUE);
1197 if ( ttymodified && ttyfileno == Sfileno(Sinput) )
1198 PopTty(Sinput, &ttytab, TRUE);
1199 }
1200 }
1201
1202
1203 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1204 closeStream() performs Prolog-level closing. Most important right now is
1205 to to avoid closing the user-streams. If a stream cannot be flushed (due
1206 to a write-error), an exception is generated.
1207
1208 MT: We assume the stream is locked and will unlock it here.
1209 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1210
1211 static int
closeStream(IOSTREAM * s)1212 closeStream(IOSTREAM *s)
1213 { if ( s == Sinput )
1214 { Sclearerr(s);
1215 return releaseStream(s);
1216 } else if ( s == Soutput || s == Serror )
1217 { if ( Sflush(s) < 0 )
1218 return streamStatus(s);
1219 return releaseStream(s);
1220 } else
1221 { if ( !Sferror(s) && Sflush(s) < 0 )
1222 { int rc = reportStreamError(s);
1223 Sclose(s);
1224 return rc;
1225 }
1226 return (Sclose(s) == 0); /* will unlock as well */
1227 }
1228 }
1229
1230
1231 /* Close all files. As this only happens during termination we report,
1232 * but otherwise ignore possible errors.
1233 */
1234
1235 void
closeFiles(int all)1236 closeFiles(int all)
1237 { GET_LD
1238 TableEnum e;
1239 IOSTREAM *s;
1240
1241 e = newTableEnum(streamContext);
1242 while( advanceTableEnum(e, (void**)&s, NULL) )
1243 { if ( all || !(s->flags & SIO_NOCLOSE) )
1244 { IOSTREAM *s2 = tryGetStream(s);
1245
1246 if ( s2 )
1247 { if ( !all )
1248 { term_t t = PL_new_term_ref();
1249
1250 PL_unify_stream_or_alias(t, s2);
1251 if ( !printMessage(ATOM_informational,
1252 PL_FUNCTOR, FUNCTOR_close_on_abort1,
1253 PL_TERM, t) )
1254 PL_clear_exception();
1255 PL_reset_term_refs(t);
1256 }
1257
1258 if ( !closeStream(s2) && exception_term )
1259 { int rc = printMessage(ATOM_warning, PL_TERM, exception_term);
1260 (void)rc;
1261 PL_clear_exception();
1262 }
1263 }
1264 }
1265 }
1266 freeTableEnum(e);
1267 }
1268
1269
1270 void
protocol(const char * str,size_t n)1271 protocol(const char *str, size_t n)
1272 { GET_LD
1273 IOSTREAM *s;
1274
1275 if ( HAS_LD && Sprotocol && (s = getStream(Sprotocol)) )
1276 { while( n-- > 0 )
1277 Sputcode(*str++&0xff, s);
1278 Sflush(s);
1279 if ( !releaseStream(s) ) /* we don not check errors */
1280 PL_clear_exception();
1281 }
1282 }
1283
1284
1285 /*******************************
1286 * TEMPORARY I/O *
1287 *******************************/
1288
1289
1290 int
push_input_context(atom_t type)1291 push_input_context(atom_t type)
1292 { GET_LD
1293 InputContext c = allocHeapOrHalt(sizeof(struct input_context));
1294
1295 PL_register_atom(type);
1296
1297 c->stream = Scurin;
1298 c->type = type;
1299 c->term_file = source_file_name;
1300 c->term_line = source_line_no;
1301 c->previous = input_context_stack;
1302 input_context_stack = c;
1303
1304 return TRUE;
1305 }
1306
1307
1308 int
pop_input_context(void)1309 pop_input_context(void)
1310 { GET_LD
1311 InputContext c = input_context_stack;
1312
1313 if ( c )
1314 { Scurin = c->stream;
1315 source_file_name = c->term_file;
1316 source_line_no = c->term_line;
1317 input_context_stack = c->previous;
1318 PL_unregister_atom(c->type);
1319 freeHeap(c, sizeof(struct input_context));
1320
1321 return TRUE;
1322 } else
1323 { Scurin = Sinput;
1324 return FALSE;
1325 }
1326 }
1327
1328
1329 static
1330 PRED_IMPL("$push_input_context", 1, push_input_context, 0)
1331 { PRED_LD
1332 atom_t type;
1333
1334 if ( PL_get_atom_ex(A1, &type) )
1335 return push_input_context(type);
1336
1337 return FALSE;
1338 }
1339
1340
1341 static
1342 PRED_IMPL("$pop_input_context", 0, pop_input_context, 0)
1343 { return pop_input_context();
1344 }
1345
1346
1347 /** '$input_context'(-List) is det.
1348
1349 True if List is a list of input(Type,File,Line) terms describing the
1350 current input context.
1351 */
1352
1353 static
1354 PRED_IMPL("$input_context", 1, input_context, 0)
1355 { PRED_LD
1356 term_t tail = PL_copy_term_ref(A1);
1357 term_t head = PL_new_term_ref();
1358 term_t stream = PL_new_term_ref();
1359 InputContext c = input_context_stack;
1360
1361 for(c=input_context_stack; c; c=c->previous)
1362 { atom_t file = c->term_file ? c->term_file : ATOM_minus;
1363 int line = c->term_file ? c->term_line : 0;
1364
1365 PL_put_variable(stream);
1366
1367 if ( !PL_unify_stream_or_alias(stream, c->stream) ||
1368 !PL_unify_list(tail, head, tail) ||
1369 !PL_unify_term(head, PL_FUNCTOR, FUNCTOR_input4,
1370 PL_ATOM, c->type,
1371 PL_ATOM, file,
1372 PL_INT, line,
1373 PL_TERM, stream) )
1374 return FALSE;
1375 }
1376
1377 return PL_unify_nil(tail);
1378 }
1379
1380
1381 void
pushOutputContext(void)1382 pushOutputContext(void)
1383 { GET_LD
1384 OutputContext c = allocHeapOrHalt(sizeof(struct output_context));
1385
1386 c->stream = Scurout;
1387 c->previous = output_context_stack;
1388 output_context_stack = c;
1389 }
1390
1391
1392 void
popOutputContext(void)1393 popOutputContext(void)
1394 { GET_LD
1395 OutputContext c = output_context_stack;
1396
1397 if ( c )
1398 { if ( c->stream->magic == SIO_MAGIC )
1399 Scurout = c->stream;
1400 else
1401 { Sdprintf("Oops, current stream closed?");
1402 Scurout = Soutput;
1403 }
1404 output_context_stack = c->previous;
1405 freeHeap(c, sizeof(struct output_context));
1406 } else
1407 Scurout = Soutput;
1408 }
1409
1410
1411 int
setupOutputRedirect(term_t to,redir_context * ctx,int redir)1412 setupOutputRedirect(term_t to, redir_context *ctx, int redir)
1413 { GET_LD
1414 atom_t a;
1415
1416 ctx->term = to;
1417 ctx->redirected = redir;
1418
1419 if ( to == 0 )
1420 { if ( !(ctx->stream = getStream(Scurout)) )
1421 return no_stream(to, ATOM_current_output);
1422 ctx->is_stream = TRUE;
1423 } else if ( PL_get_atom(to, &a) )
1424 { if ( a == ATOM_user )
1425 { if ( !(ctx->stream = getStream(Suser_output)) )
1426 return no_stream(to, ATOM_user);
1427 ctx->is_stream = TRUE;
1428 } else if ( get_stream_handle(a, &ctx->stream, SH_OUTPUT|SH_ERRORS) )
1429 { if ( !(ctx->stream->flags &SIO_OUTPUT) )
1430 { releaseStream(ctx->stream);
1431 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
1432 ATOM_output, ATOM_stream, to);
1433 }
1434
1435 ctx->is_stream = TRUE;
1436 } else
1437 return FALSE;
1438 } else
1439 { if ( PL_is_functor(to, FUNCTOR_codes2) )
1440 { ctx->out_format = PL_CODE_LIST;
1441 ctx->out_arity = 2;
1442 } else if ( PL_is_functor(to, FUNCTOR_codes1) )
1443 { ctx->out_format = PL_CODE_LIST;
1444 ctx->out_arity = 1;
1445 } else if ( PL_is_functor(to, FUNCTOR_chars2) )
1446 { ctx->out_format = PL_CHAR_LIST;
1447 ctx->out_arity = 2;
1448 } else if ( PL_is_functor(to, FUNCTOR_chars1) )
1449 { ctx->out_format = PL_CHAR_LIST;
1450 ctx->out_arity = 1;
1451 } else if ( PL_is_functor(to, FUNCTOR_string1) )
1452 { ctx->out_format = PL_STRING;
1453 ctx->out_arity = 1;
1454 } else if ( PL_is_functor(to, FUNCTOR_atom1) )
1455 { ctx->out_format = PL_ATOM;
1456 ctx->out_arity = 1;
1457 } else
1458 { return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_output, to);
1459 }
1460
1461 ctx->is_stream = FALSE;
1462 ctx->data = ctx->buffer;
1463 ctx->size = sizeof(ctx->buffer);
1464 ctx->stream = Sopenmem(&ctx->data, &ctx->size, "w");
1465 ctx->stream->encoding = ENC_WCHAR;
1466 ctx->stream->newline = SIO_NL_POSIX;
1467 }
1468
1469 ctx->magic = REDIR_MAGIC;
1470
1471 if ( redir )
1472 { pushOutputContext();
1473 Scurout = ctx->stream;
1474 }
1475
1476 return TRUE;
1477 }
1478
1479
1480 int
closeOutputRedirect(redir_context * ctx)1481 closeOutputRedirect(redir_context *ctx)
1482 { int rval = TRUE;
1483
1484 if ( ctx->magic != REDIR_MAGIC )
1485 return rval; /* already done */
1486 ctx->magic = 0;
1487
1488 if ( ctx->redirected )
1489 popOutputContext();
1490
1491 if ( ctx->is_stream )
1492 { rval = streamStatus(ctx->stream);
1493 } else
1494 { GET_LD
1495 term_t out = PL_new_term_ref();
1496 term_t diff, tail;
1497
1498 if ( Sclose(ctx->stream) == 0 )
1499 { _PL_get_arg(1, ctx->term, out);
1500 if ( ctx->out_arity == 2 )
1501 { diff = PL_new_term_ref();
1502 _PL_get_arg(2, ctx->term, diff);
1503 tail = PL_new_term_ref();
1504 } else
1505 { diff = tail = 0;
1506 }
1507
1508 rval = PL_unify_wchars_diff(out, tail, ctx->out_format,
1509 ctx->size/sizeof(wchar_t),
1510 (wchar_t*)ctx->data);
1511 if ( rval && tail )
1512 rval = PL_unify(tail, diff);
1513 } else
1514 rval = FALSE;
1515
1516 if ( ctx->data != ctx->buffer )
1517 Sfree(ctx->data);
1518 }
1519
1520 return rval;
1521 }
1522
1523
1524 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1525 discardOutputRedirect() is called if the `implementation' failed. One of
1526 the reasons for failure can be that the implementation detected a
1527 pending I/O stream error, in which case continuation is meaningless.
1528 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1529
1530 void
discardOutputRedirect(redir_context * ctx)1531 discardOutputRedirect(redir_context *ctx)
1532 { if ( ctx->magic != REDIR_MAGIC )
1533 return; /* already done */
1534
1535 ctx->magic = 0;
1536
1537 if ( ctx->redirected )
1538 popOutputContext();
1539
1540 if ( ctx->is_stream )
1541 { streamStatus(ctx->stream);
1542 } else
1543 { closeStream(ctx->stream);
1544 if ( ctx->data != ctx->buffer )
1545 Sfree(ctx->data);
1546 }
1547 }
1548
1549
1550 static
1551 PRED_IMPL("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
1552 { redir_context outctx;
1553
1554 if ( setupOutputRedirect(A1, &outctx, TRUE) )
1555 { term_t ex = 0;
1556 int rval;
1557
1558 if ( (rval = callProlog(NULL, A2, PL_Q_CATCH_EXCEPTION, &ex)) )
1559 return closeOutputRedirect(&outctx);
1560 discardOutputRedirect(&outctx);
1561 if ( ex )
1562 return PL_raise_exception(ex);
1563 }
1564
1565 return FALSE;
1566 }
1567
1568
1569
1570 void
PL_write_prompt(int dowrite)1571 PL_write_prompt(int dowrite)
1572 { GET_LD
1573 IOSTREAM *s = getStream(Suser_output);
1574
1575 if ( s )
1576 { if ( dowrite )
1577 { atom_t a = PrologPrompt();
1578
1579 if ( a )
1580 writeAtomToStream(s, a);
1581 }
1582
1583 Sflush(s);
1584 releaseStream(s);
1585 }
1586
1587 LD->prompt.next = FALSE;
1588 }
1589
1590
1591 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1592 Get a single character from Sinput without waiting for a return. The
1593 character should not be echoed. If PLFLAG_TTY_CONTROL is false this
1594 function will read the first character and then skip all character upto
1595 and including the newline.
1596 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1597
1598 static int
Sgetcode_intr(IOSTREAM * s,int signals)1599 Sgetcode_intr(IOSTREAM *s, int signals)
1600 { int c;
1601
1602 #ifdef __WINDOWS__
1603 int newline = s->newline;
1604 s->newline = SIO_NL_POSIX; /* avoid blocking \r */
1605 #endif
1606 do
1607 { c = Sgetcode(s);
1608 Sclearerr(s);
1609 } while ( c == -1 &&
1610 errno == EINTR &&
1611 (!signals || PL_handle_signals() >= 0)
1612 );
1613 #ifdef __WINDOWS__
1614 s->newline = newline;
1615 #endif
1616
1617 return c;
1618 }
1619
1620
1621 int
getSingleChar(IOSTREAM * stream,int signals)1622 getSingleChar(IOSTREAM *stream, int signals)
1623 { GET_LD
1624 int c;
1625 ttybuf buf;
1626
1627 suspendTrace(TRUE);
1628 Slock(stream);
1629 Sflush(stream);
1630 PushTty(stream, &buf, TTY_RAW); /* just donot prompt */
1631
1632 if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
1633 { int c2;
1634
1635 c2 = Sgetcode_intr(stream, signals);
1636 while( c2 == ' ' || c2 == '\t' ) /* skip blanks */
1637 c2 = Sgetcode_intr(stream, signals);
1638 c = c2;
1639 while( c2 != EOF && c2 != '\n' ) /* read upto newline */
1640 c2 = Sgetcode_intr(stream, signals);
1641 } else
1642 { if ( stream->position )
1643 { IOPOS oldpos = *stream->position;
1644 c = Sgetcode_intr(stream, signals);
1645 *stream->position = oldpos;
1646 } else
1647 c = Sgetcode_intr(stream, signals);
1648 }
1649
1650 if ( c == 4 || c == 26 ) /* should ask the terminal! */
1651 c = -1;
1652
1653 PopTty(stream, &buf, TRUE);
1654 suspendTrace(FALSE);
1655 Sunlock(stream);
1656
1657 return c;
1658 }
1659
1660
1661 static
1662 PRED_IMPL("with_tty_raw", 1, with_tty_raw, PL_FA_TRANSPARENT)
1663 { PRED_LD
1664 int rval;
1665 ttybuf buf;
1666 int save;
1667 IOSTREAM *stream = getStream(Suser_input);
1668
1669 if ( !stream )
1670 return symbol_no_stream(ATOM_user_input);
1671 save = true(Sinput, SIO_ISATTY);
1672
1673 Slock(stream);
1674 Sflush(stream);
1675 if ( save )
1676 PushTty(stream, &buf, TTY_RAW);
1677
1678 rval = callProlog(NULL, A1, PL_Q_PASS_EXCEPTION, NULL);
1679
1680 if ( save )
1681 PopTty(stream, &buf, TRUE);
1682 Sunlock(stream);
1683
1684 return rval;
1685 }
1686
1687
1688 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1689 readLine() reads a line from the terminal. It is used only by the tracer.
1690 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1691
1692 #ifndef DEL
1693 #define DEL 127
1694 #endif
1695
1696 int
readLine(IOSTREAM * in,IOSTREAM * out,char * buffer)1697 readLine(IOSTREAM *in, IOSTREAM *out, char *buffer)
1698 { GET_LD
1699 int c;
1700 char *buf = &buffer[strlen(buffer)];
1701 ttybuf tbuf;
1702
1703 Slock(in);
1704 Slock(out);
1705
1706 PushTty(in, &tbuf, TTY_RAW); /* just donot prompt */
1707
1708 for(;;)
1709 { Sflush(out);
1710
1711 switch( (c=Sgetcode_intr(in, FALSE)) )
1712 { case '\n':
1713 case '\r':
1714 case EOF:
1715 *buf++ = EOS;
1716 PopTty(in, &tbuf, TRUE);
1717 Sunlock(in);
1718 Sunlock(out);
1719
1720 return c == EOF ? FALSE : TRUE;
1721 case '\b':
1722 case DEL:
1723 if ( truePrologFlag(PLFLAG_TTY_CONTROL) && buf > buffer )
1724 { Sfputs("\b \b", out);
1725 buf--;
1726 continue;
1727 }
1728 default:
1729 if ( truePrologFlag(PLFLAG_TTY_CONTROL) )
1730 Sputcode(c, out);
1731 *buf++ = c;
1732 }
1733 }
1734 }
1735
1736
1737 IOSTREAM *
PL_current_input()1738 PL_current_input()
1739 { GET_LD
1740 return getStream(Scurin);
1741 }
1742
1743
1744 IOSTREAM *
PL_current_output()1745 PL_current_output()
1746 { GET_LD
1747 return getStream(Scurout);
1748 }
1749
1750
1751 static int
openProtocol(term_t f,int appnd)1752 openProtocol(term_t f, int appnd)
1753 { GET_LD
1754 IOSTREAM *s;
1755 term_t mode = PL_new_term_ref();
1756
1757 noprotocol();
1758
1759 PL_put_atom(mode, appnd ? ATOM_append : ATOM_write);
1760 if ( (s = openStream(f, mode, 0)) )
1761 { s->flags |= SIO_NOCLOSE; /* do not close on abort */
1762
1763 Sprotocol = s;
1764 Suser_input->tee = s;
1765 Suser_output->tee = s;
1766 Suser_error->tee = s;
1767
1768 return TRUE;
1769 }
1770
1771 return FALSE;
1772 }
1773
1774
1775 static int
noprotocol(void)1776 noprotocol(void)
1777 { GET_LD
1778 IOSTREAM *s;
1779
1780 if ( Sprotocol && (s = getStream(Sprotocol)) )
1781 { TableEnum e;
1782 IOSTREAM *p;
1783
1784 e = newTableEnum(streamContext);
1785 while( advanceTableEnum(e, (void**)&p, NULL) )
1786 { if ( p->tee == s )
1787 p->tee = NULL;
1788 }
1789 freeTableEnum(e);
1790
1791 closeStream(s);
1792 Sprotocol = NULL;
1793 }
1794
1795 return TRUE;
1796 }
1797
1798
1799 static
1800 PRED_IMPL("noprotocol", 0, noprotocol, 0)
1801 { return noprotocol();
1802 }
1803
1804
1805 /*******************************
1806 * STREAM ATTRIBUTES *
1807 *******************************/
1808
1809 static int
setCloseOnExec(IOSTREAM * s,int val)1810 setCloseOnExec(IOSTREAM *s, int val)
1811 { int fd;
1812
1813 if ( (fd = Sfileno(s)) < 0)
1814 return FALSE;
1815
1816 #if defined(F_SETFD) && defined(FD_CLOEXEC)
1817 { int fd_flags = fcntl(fd, F_GETFD);
1818
1819 if ( fd_flags == -1 )
1820 return FALSE;
1821 if ( val )
1822 fd_flags |= FD_CLOEXEC;
1823 else
1824 fd_flags &= ~FD_CLOEXEC;
1825
1826 if ( fcntl(fd, F_SETFD, fd_flags) == -1 )
1827 return FALSE;
1828 }
1829 #elif defined __WINDOWS__
1830 { if ( !SetHandleInformation((HANDLE)_get_osfhandle(fd),
1831 HANDLE_FLAG_INHERIT, !val) )
1832 return FALSE;
1833 }
1834 #else
1835 return -1;
1836 #endif
1837
1838 return TRUE;
1839 }
1840
1841
1842 static int
set_eof_action(IOSTREAM * s,atom_t action)1843 set_eof_action(IOSTREAM *s, atom_t action)
1844 { if ( action == ATOM_eof_code )
1845 { s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR);
1846 } else if ( action == ATOM_reset )
1847 { s->flags &= ~SIO_FEOF2ERR;
1848 s->flags |= SIO_NOFEOF;
1849 } else if ( action == ATOM_error )
1850 { s->flags &= ~SIO_NOFEOF;
1851 s->flags |= SIO_FEOF2ERR;
1852 } else
1853 { GET_LD
1854 term_t t;
1855
1856 return ((t=PL_new_term_ref()) &&
1857 PL_put_atom(t, action) &&
1858 PL_domain_error("eof_action", t));
1859 }
1860
1861 return TRUE;
1862 }
1863
1864
1865 static int
set_buffering(IOSTREAM * s,atom_t b)1866 set_buffering(IOSTREAM *s, atom_t b)
1867 {
1868 #define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF)
1869
1870 if ( b == ATOM_full )
1871 { s->flags &= ~SIO_ABUF;
1872 s->flags |= SIO_FBUF;
1873 } else if ( b == ATOM_line )
1874 { s->flags &= ~SIO_ABUF;
1875 s->flags |= SIO_LBUF;
1876 } else if ( b == ATOM_false )
1877 { Sflush(s);
1878 s->flags &= ~SIO_ABUF;
1879 s->flags |= SIO_NBUF;
1880 } else
1881 { GET_LD
1882 term_t t;
1883
1884 return ((t=PL_new_term_ref()) &&
1885 PL_put_atom(t, b) &&
1886 PL_domain_error("buffer", t));
1887 }
1888
1889 return TRUE;
1890 }
1891
1892
1893 /* returns TRUE: ok, FALSE: error, -1: not available
1894 */
1895
1896 static int
set_stream(IOSTREAM * s,term_t stream,atom_t aname,term_t a ARG_LD)1897 set_stream(IOSTREAM *s, term_t stream, atom_t aname, term_t a ARG_LD)
1898 { if ( aname == ATOM_alias ) /* alias(name) */
1899 { atom_t alias;
1900 int i;
1901
1902 if ( !PL_get_atom_ex(a, &alias) )
1903 return FALSE;
1904
1905 if ( (i=standardStreamIndexFromName(alias)) >= 0 )
1906 { LD->IO.streams[i] = s;
1907 if ( i == 0 )
1908 LD->prompt.next = TRUE; /* changed standard input: prompt! */
1909 return TRUE;
1910 }
1911
1912 PL_LOCK(L_FILE);
1913 aliasStream(s, alias);
1914 PL_UNLOCK(L_FILE);
1915 return TRUE;
1916 } else if ( aname == ATOM_buffer ) /* buffer(Buffering) */
1917 { atom_t b;
1918
1919 if ( !PL_get_atom_ex(a, &b) )
1920 return FALSE;
1921 return set_buffering(s, b);
1922 } else if ( aname == ATOM_buffer_size )
1923 { int size;
1924
1925 if ( !PL_get_integer_ex(a, &size) )
1926 return FALSE;
1927 if ( size < 1 )
1928 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a);
1929 Ssetbuffer(s, NULL, size);
1930 return TRUE;
1931 } else if ( aname == ATOM_eof_action ) /* eof_action(Action) */
1932 { atom_t action;
1933
1934 if ( !PL_get_atom_ex(a, &action) )
1935 return FALSE;
1936
1937 return set_eof_action(s, action);
1938 } else if ( aname == ATOM_type ) /* type(Type) */
1939 { atom_t type;
1940
1941 if ( !PL_get_atom_ex(a, &type) )
1942 return FALSE;
1943 if ( type == ATOM_text )
1944 { if ( false(s, SIO_TEXT) && Ssetenc(s, LD->encoding, NULL) != 0 )
1945 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
1946 ATOM_encoding, ATOM_stream, stream);
1947 s->flags |= SIO_TEXT;
1948 } else if ( type == ATOM_binary )
1949 { if ( true(s, SIO_TEXT) && Ssetenc(s, ENC_OCTET, NULL) != 0 )
1950 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
1951 ATOM_encoding, ATOM_stream, stream);
1952
1953 s->flags &= ~SIO_TEXT;
1954 } else
1955 { return PL_error("set_stream", 2, NULL, ERR_DOMAIN,
1956 ATOM_type, a);
1957 }
1958
1959 return TRUE;
1960 } else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */
1961 { int close;
1962
1963 if ( !PL_get_bool_ex(a, &close) )
1964 return FALSE;
1965
1966 if ( close )
1967 s->flags &= ~SIO_NOCLOSE;
1968 else
1969 s->flags |= SIO_NOCLOSE;
1970
1971 return TRUE;
1972 } else if ( aname == ATOM_record_position )
1973 { int rec;
1974
1975 if ( !PL_get_bool_ex(a, &rec) )
1976 return FALSE;
1977
1978 if ( rec ) {
1979 memset(&s->posbuf, 0, sizeof(s->posbuf));
1980 s->posbuf.lineno = 1;
1981 s->position = &s->posbuf;
1982 } else
1983 s->position = NULL;
1984
1985 return TRUE;
1986 } else if ( aname == ATOM_line_position )
1987 { int lpos;
1988
1989 if ( !PL_get_integer_ex(a, &lpos) )
1990 return FALSE;
1991
1992 if ( s->position )
1993 s->position->linepos = lpos;
1994 else
1995 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
1996 ATOM_line_position, ATOM_stream, stream);
1997
1998 return TRUE;
1999 } else if ( aname == ATOM_file_name ) /* file_name(Atom) */
2000 { atom_t fn;
2001
2002 if ( !PL_get_text_as_atom(a, &fn, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
2003 return FALSE;
2004
2005 setFileNameStream(s, fn);
2006
2007 return TRUE;
2008 } else if ( aname == ATOM_timeout )
2009 { double f;
2010 atom_t v;
2011 int tmo;
2012
2013 if ( PL_get_atom(a, &v) && v == ATOM_infinite )
2014 { tmo = -1;
2015 } else
2016 { if ( !PL_get_float_ex(a, &f) )
2017 return FALSE;
2018
2019 if ( (tmo = (int)(f*1000.0)) < 0 )
2020 tmo = 0;
2021 }
2022
2023 if ( Sset_timeout(s, tmo) == 0 )
2024 return TRUE;
2025 return PL_permission_error("timeout", "stream", stream);
2026 } else if ( aname == ATOM_tty ) /* tty(bool) */
2027 { int val;
2028
2029 if ( !PL_get_bool_ex(a, &val) )
2030 return FALSE;
2031
2032 if ( val )
2033 set(s, SIO_ISATTY);
2034 else
2035 clear(s, SIO_ISATTY);
2036
2037 return TRUE;
2038 } else if ( aname == ATOM_encoding ) /* encoding(atom) */
2039 { atom_t val;
2040 IOENC enc;
2041
2042 if ( !PL_get_atom_ex(a, &val) )
2043 return FALSE;
2044 if ( val == ATOM_bom )
2045 { IOSTREAM *s2;
2046
2047 if ( (s2 = getStream(s)) )
2048 { if ( ScheckBOM(s2) == 0 )
2049 { releaseStream(s2);
2050 return (s2->flags&SIO_BOM) ? TRUE:FALSE;
2051 }
2052 return streamStatus(s2);
2053 }
2054 return streamStatus(s);
2055 } else if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN )
2056 { bad_encoding(NULL, val);
2057 return FALSE;
2058 }
2059
2060 if ( Ssetenc(s, enc, NULL) == 0 )
2061 return TRUE;
2062
2063 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
2064 ATOM_encoding, ATOM_stream, stream);
2065 #ifdef O_LOCALE
2066 } else if ( aname == ATOM_locale ) /* locale(Locale) */
2067 { PL_locale *val;
2068
2069 if ( !getLocaleEx(a, &val) )
2070 return FALSE;
2071 if ( Ssetlocale(s, val, NULL) == 0 )
2072 return TRUE;
2073
2074 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
2075 ATOM_locale, ATOM_stream, stream);
2076 #endif
2077 } else if ( aname == ATOM_representation_errors )
2078 { atom_t val;
2079
2080 if ( !PL_get_atom_ex(a, &val) )
2081 return FALSE;
2082
2083 clear(s, SIO_REPXML|SIO_REPPL);
2084
2085 if ( val == ATOM_error )
2086 ;
2087 else if ( val == ATOM_xml )
2088 set(s, SIO_REPXML);
2089 else if ( val == ATOM_prolog )
2090 set(s, SIO_REPPL);
2091 else
2092 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
2093 ATOM_representation_errors, a);
2094
2095 return TRUE;
2096 } else if ( aname == ATOM_write_errors )
2097 { atom_t val;
2098
2099 if ( !PL_get_atom_ex(a, &val) )
2100 return FALSE;
2101
2102 if ( val == ATOM_error )
2103 clear(s, SIO_NOERROR);
2104 else if ( val == ATOM_ignore )
2105 set(s, SIO_NOERROR);
2106 else
2107 return PL_domain_error("write_errors", a);
2108
2109 return TRUE;
2110 } else if ( aname == ATOM_newline )
2111 { atom_t val;
2112
2113 if ( !PL_get_atom_ex(a, &val) )
2114 return FALSE;
2115 if ( val == ATOM_posix )
2116 s->newline = SIO_NL_POSIX;
2117 else if ( val == ATOM_dos )
2118 s->newline = SIO_NL_DOS;
2119 else if ( val == ATOM_detect )
2120 { if ( false(s, SIO_INPUT) )
2121 return PL_error(NULL, 0, "detect only allowed for input streams",
2122 ERR_DOMAIN, ATOM_newline, a);
2123 s->newline = SIO_NL_DETECT;
2124 } else
2125 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a);
2126
2127 return TRUE;
2128 } else if ( aname == ATOM_close_on_exec ) /* close_on_exec(bool) */
2129 { int val;
2130
2131 if ( !PL_get_bool_ex(a, &val) )
2132 return FALSE;
2133
2134 return setCloseOnExec(s, val);
2135 } else
2136 { assert(0);
2137 return FALSE;
2138 }
2139 }
2140
2141
2142 typedef struct set_stream_info
2143 { atom_t name;
2144 int flags;
2145 } set_stream_info;
2146
2147 #define SS_READ 0x01
2148 #define SS_WRITE 0x02
2149 #define SS_BOTH (SS_READ|SS_WRITE)
2150 #define SS_NOPAIR (0x4)
2151 #define SS_EITHER (SS_BOTH|SS_NOPAIR)
2152
2153 #define SS_INFO(name, flags) { name, flags }
2154
2155 static const set_stream_info ss_info[] =
2156 { SS_INFO(ATOM_alias, SS_EITHER),
2157 SS_INFO(ATOM_buffer, SS_BOTH),
2158 SS_INFO(ATOM_buffer_size, SS_BOTH),
2159 SS_INFO(ATOM_eof_action, SS_READ),
2160 SS_INFO(ATOM_type, SS_BOTH),
2161 SS_INFO(ATOM_close_on_abort, SS_BOTH),
2162 SS_INFO(ATOM_record_position, SS_BOTH),
2163 SS_INFO(ATOM_line_position, SS_EITHER),
2164 SS_INFO(ATOM_file_name, SS_BOTH),
2165 SS_INFO(ATOM_timeout, SS_BOTH),
2166 SS_INFO(ATOM_tty, SS_BOTH),
2167 SS_INFO(ATOM_encoding, SS_BOTH),
2168 SS_INFO(ATOM_locale, SS_BOTH),
2169 SS_INFO(ATOM_representation_errors, SS_WRITE),
2170 SS_INFO(ATOM_write_errors, SS_WRITE),
2171 SS_INFO(ATOM_newline, SS_BOTH),
2172 SS_INFO(ATOM_close_on_exec, SS_BOTH),
2173 SS_INFO((atom_t)0, 0)
2174 };
2175
2176
2177 static
2178 PRED_IMPL("set_stream", 2, set_stream, 0)
2179 { PRED_LD
2180 IOSTREAM *s;
2181 atom_t sblob, aname;
2182 stream_ref *ref;
2183 PL_blob_t *type;
2184 int rc;
2185 size_t arity;
2186 const set_stream_info *info;
2187 term_t aval = PL_new_term_ref();
2188
2189 term_t stream = A1;
2190 term_t attr = A2;
2191
2192 if ( PL_get_name_arity(attr, &aname, &arity) && arity == 1 )
2193 { for(info = ss_info; info->name; info++)
2194 { if ( info->name == aname )
2195 goto found;
2196 }
2197 return PL_domain_error("stream_attribute", attr);
2198 } else
2199 return PL_type_error("stream_attribute", attr);
2200
2201 found:
2202 _PL_get_arg(1, attr, aval);
2203
2204 if ( !PL_get_atom(stream, &sblob) )
2205 return not_a_stream(stream);
2206
2207 ref = PL_blob_data(sblob, NULL, &type);
2208 if ( type == &stream_blob ) /* got a stream handle */
2209 { if ( ref->read && ref->write && /* stream pair */
2210 (info->flags & SS_NOPAIR) )
2211 return symbol_stream_pair_not_allowed(sblob);
2212
2213 rc = TRUE;
2214 if ( ref->read && (info->flags&SS_READ))
2215 { if ( !(s = getStream(ref->read)) )
2216 return symbol_no_stream(sblob);
2217 rc = set_stream(s, stream, aname, aval PASS_LD);
2218 releaseStream(ref->read);
2219 }
2220 if ( rc && ref->write && (info->flags&SS_WRITE) )
2221 { if ( !(s = getStream(ref->write)) )
2222 return symbol_no_stream(sblob);
2223 rc = set_stream(s, stream, aname, aval PASS_LD);
2224 releaseStream(ref->write);
2225 }
2226 } else if ( PL_get_stream_handle(stream, &s) )
2227 { rc = set_stream(s, stream, aname, aval PASS_LD);
2228 releaseStream(s);
2229 } else
2230 rc = FALSE;
2231
2232 if ( rc < 0 ) /* not on this OS */
2233 return PL_domain_error("stream_attribute", attr);
2234
2235 return rc;
2236 }
2237
2238
2239 #ifdef _MSC_VER /* defined in pl-nt.c */
2240 extern int ftruncate(int fileno, int64_t length);
2241 #define HAVE_FTRUNCATE
2242 #endif
2243
2244 static
2245 PRED_IMPL("set_end_of_stream", 1, set_end_of_stream, 0)
2246 { IOSTREAM *s;
2247 int rc;
2248
2249 if ( (rc=PL_get_stream(A1, &s, SIO_OUTPUT)) )
2250 {
2251 #ifdef HAVE_FTRUNCATE
2252 int fileno = Sfileno(s);
2253
2254 if ( fileno >= 0 )
2255 { if ( ftruncate(fileno, Stell64(s)) != 0 )
2256 rc = PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
2257 ATOM_set_end_of_stream, ATOM_stream,
2258 A1);
2259 } else
2260 { rc = PL_error(NULL, 0, "not a file", ERR_PERMISSION,
2261 ATOM_set_end_of_stream, ATOM_stream, A1);
2262 }
2263 #else
2264 rc = notImplemented("set_end_of_stream", 1);
2265 #endif
2266
2267 releaseStream(s);
2268 }
2269
2270 return rc;
2271 }
2272
2273
2274
2275 /********************************
2276 * STRING I/O *
2277 *********************************/
2278
2279 extern IOFUNCTIONS Smemfunctions;
2280
2281 int
tellString(char ** s,size_t * size,IOENC enc)2282 tellString(char **s, size_t *size, IOENC enc)
2283 { GET_LD
2284 IOSTREAM *stream;
2285
2286 stream = Sopenmem(s, size, "w");
2287 stream->encoding = enc;
2288 pushOutputContext();
2289 Scurout = stream;
2290
2291 return TRUE;
2292 }
2293
2294
2295 int
toldString()2296 toldString()
2297 { GET_LD
2298 IOSTREAM *s = getStream(Scurout);
2299
2300 if ( !s )
2301 return TRUE;
2302
2303 if ( s->functions == &Smemfunctions )
2304 { closeStream(s);
2305 popOutputContext();
2306 } else
2307 releaseStream(s);
2308
2309 return TRUE;
2310 }
2311
2312
2313 /********************************
2314 * WAITING FOR INPUT *
2315 ********************************/
2316
2317 #if defined(HAVE_SELECT) || defined(HAVE_POLL)
2318 #define HAVE_PRED_WAIT_FOR_INPUT 1
2319
2320 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2321 Windows<->Unix note. This function uses the Windows socket API for its
2322 implementation and defines the Unix API in terms of the Windows API.
2323 This approach allows full support of the restrictions of the Windows
2324 implementation. Because the Unix emulation is more generic, this still
2325 supports the generic facilities of Unix select() that make this
2326 predicate work on pipes, serial devices, etc.
2327 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2328
2329 #ifndef __WINDOWS__
2330 typedef int SOCKET;
2331 #define INVALID_SOCKET -1
2332 #define Swinsock(s) Sfileno(s)
2333 #define NFDS(max) (max+1) /* see also S__wait() */
2334 #else
2335 #define NFDS(n) 0
2336 #ifdef HAVE_WSAPOLL
2337 #define HAVE_POLL 1
2338 static inline int
poll(struct pollfd * pfd,int nfds,int timeout)2339 poll(struct pollfd *pfd, int nfds, int timeout)
2340 { return WSAPoll(pfd, nfds, timeout);
2341 }
2342 #endif
2343 #endif
2344
2345 typedef struct fdentry
2346 { SOCKET fd;
2347 term_t stream;
2348 } fdentry;
2349
2350 #define FASTMAP_SIZE 32
2351
2352 #ifdef HAVE_POLL
2353 #define ADD_FD(i) do { poll_map[i].fd = map[i].fd; \
2354 poll_map[i].events = POLLIN; \
2355 } while(0)
2356 #define IS_SETFD(i) (poll_map[i].revents & (POLLIN|POLLERR|POLLHUP))
2357 #define ACTION_WAIT ATOM_poll
2358 #else
2359 #define ADD_FD(i) do { FD_SET(map[i].fd, &fds); } while(0)
2360 #define IS_SETFD(i) FD_ISSET(map[i].fd, &fds)
2361 #define ACTION_WAIT ATOM_select
2362 #endif
2363
2364 static
2365 PRED_IMPL("wait_for_input", 3, wait_for_input, 0)
2366 { PRED_LD
2367 double time;
2368 fdentry map_buf[FASTMAP_SIZE];
2369 fdentry *map;
2370 #ifdef HAVE_POLL
2371 struct pollfd poll_buf[FASTMAP_SIZE];
2372 struct pollfd *poll_map;
2373 int to;
2374 #else
2375 SOCKET max = 0;
2376 fd_set fds;
2377 struct timeval t, *to;
2378 #endif
2379 term_t head = PL_new_term_ref();
2380 term_t streams = PL_copy_term_ref(A1);
2381 term_t available = PL_copy_term_ref(A2);
2382 term_t ahead = PL_new_term_ref();
2383 int from_buffer = 0;
2384 atom_t a;
2385 size_t count;
2386 int i, nfds;
2387 int rc = FALSE;
2388
2389 term_t timeout = A3;
2390
2391 switch ( PL_skip_list(A1, 0, &count) )
2392 { case PL_LIST:
2393 break;
2394 case PL_PARTIAL_LIST:
2395 return PL_instantiation_error(A1);
2396 default:
2397 return PL_type_error("list", A1);
2398 }
2399
2400 if ( count <= FASTMAP_SIZE )
2401 map = map_buf;
2402 else if ( !(map = malloc(count*sizeof(*map))) )
2403 return PL_no_memory();
2404 memset(map, 0, count*sizeof(*map));
2405
2406 #ifdef HAVE_POLL
2407 if ( count <= FASTMAP_SIZE )
2408 poll_map = poll_buf;
2409 else if ( !(poll_map = malloc(count*sizeof(*poll_map))) )
2410 return PL_no_memory();
2411 memset(poll_map, 0, count*sizeof(*poll_map));
2412 #else
2413 #ifdef __WINDOWS__
2414 if ( count > FD_SETSIZE )
2415 { PL_representation_error("FD_SETSIZE");
2416 goto out;
2417 }
2418 #endif
2419 FD_ZERO(&fds);
2420 #endif
2421
2422 for(nfds=0; PL_get_list(streams, head, streams); )
2423 { IOSTREAM *s;
2424 SOCKET fd;
2425 fdentry *e;
2426 int ifd;
2427
2428 if ( PL_get_integer(head, &ifd) )
2429 { fd = ifd;
2430 } else
2431 { if ( !PL_get_stream(head, &s, SIO_INPUT) )
2432 goto out;
2433
2434 if ( (fd = Swinsock(s)) == INVALID_SOCKET )
2435 { releaseStream(s);
2436 PL_domain_error("waitable_stream", head);
2437 goto out;
2438 }
2439 /* check for input in buffer */
2440 if ( Spending(s) > 0 )
2441 { if ( !PL_unify_list(available, ahead, available) ||
2442 !PL_unify(ahead, head) )
2443 { releaseStream(s);
2444 goto out;
2445 }
2446 from_buffer++;
2447 }
2448
2449 releaseStream(s); /* dubious, but what else? */
2450 }
2451
2452 e = &map[nfds];
2453 e->fd = fd;
2454 e->stream = PL_copy_term_ref(head);
2455 ADD_FD(nfds);
2456 nfds++;
2457
2458 #ifndef HAVE_POLL
2459 if ( fd > max )
2460 max = fd;
2461 #endif
2462 }
2463
2464 if ( from_buffer > 0 )
2465 { rc = PL_unify_nil(available);
2466 goto out;
2467 }
2468
2469 #ifdef HAVE_POLL
2470 if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
2471 { to = -1;
2472 } else if ( PL_is_integer(timeout) )
2473 { int i;
2474
2475 if ( PL_get_integer(timeout, &i) )
2476 { if ( i <= 0 )
2477 { to = 0;
2478 } else if ( (int64_t)i*1000 <= INT_MAX )
2479 { to = i*1000;
2480 } else
2481 { PL_representation_error("timeout");
2482 goto out;
2483 }
2484 } else
2485 { PL_representation_error("timeout");
2486 goto out;
2487 }
2488 } else if ( PL_get_float_ex(timeout, &time) )
2489 { if ( time > 0.0 )
2490 { if ( time * 1000.0 <= (double)INT_MAX )
2491 { to = (int)(time*1000.0);
2492 } else
2493 { PL_domain_error("timeout", timeout);
2494 goto out;
2495 }
2496 } else
2497 { to = 0;
2498 }
2499 } else
2500 goto out;
2501 #else /*HAVE_POLL*/
2502 if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
2503 { to = NULL;
2504 } else if ( PL_is_integer(timeout) )
2505 { long v;
2506
2507 PL_get_long(timeout, &v);
2508 if ( v > 0L )
2509 { t.tv_sec = v;
2510 t.tv_usec = 0;
2511 to = &t;
2512 } else
2513 { t.tv_sec = 0;
2514 t.tv_usec = 0;
2515 to = &t;
2516 }
2517 } else
2518 { if ( !PL_get_float_ex(timeout, &time) )
2519 goto out;
2520
2521 if ( time >= 0.0 )
2522 { t.tv_sec = (int)time;
2523 t.tv_usec = ((int)(time * 1000000) % 1000000);
2524 } else
2525 { t.tv_sec = 0;
2526 t.tv_usec = 0;
2527 }
2528 to = &t;
2529 }
2530 #endif /*HAVE_POLL*/
2531
2532 #ifdef HAVE_POLL
2533 while ( (rc=poll(poll_map, nfds, to)) == -1 &&
2534 errno == EINTR )
2535 { if ( PL_handle_signals() < 0 )
2536 goto out; /* exception */
2537 }
2538 #else
2539 #if defined(FD_SETSIZE) && !defined(__WINDOWS__)
2540 if ( max >= FD_SETSIZE )
2541 { PL_representation_error("FD_SETSIZE");
2542 goto out;
2543 }
2544 #endif
2545
2546 while( (rc=select(NFDS(max), &fds, NULL, NULL, to)) == -1 &&
2547 errno == EINTR )
2548 { if ( PL_handle_signals() < 0 )
2549 goto out; /* exception */
2550
2551 FD_ZERO(&fds); /* EINTR may leave fds undefined */
2552 for(i=0; i<count; i++) /* so we rebuild it to be safe */
2553 FD_SET(map[i].fd, &fds);
2554 }
2555 #endif
2556
2557 switch(rc)
2558 { case -1:
2559 PL_error("wait_for_input", 3, MSG_ERRNO, ERR_FILE_OPERATION,
2560 ACTION_WAIT, ATOM_stream, A1);
2561 goto out;
2562
2563 case 0: /* Timeout */
2564 break;
2565
2566 default: /* Something happend -> check fds */
2567 { for(i=0; i<nfds; i++)
2568 { if ( IS_SETFD(i) )
2569 { if ( !PL_unify_list(available, ahead, available) ||
2570 !PL_unify(ahead, map[i].stream) )
2571 goto out;
2572 }
2573 }
2574 break;
2575 }
2576 }
2577
2578 rc = PL_unify_nil(available);
2579
2580 out:
2581 if ( map != map_buf )
2582 free(map);
2583 #ifdef HAVE_POLL
2584 if ( poll_map != poll_buf )
2585 free(poll_map);
2586 #endif
2587
2588 return rc;
2589 }
2590
2591 #endif /* HAVE_SELECT */
2592
2593
2594 /********************************
2595 * PROLOG CONNECTION *
2596 *********************************/
2597
2598 #define MAX_PENDING SIO_BUFSIZE /* 4096 */
2599
2600 static void
re_buffer(IOSTREAM * s,const char * from,size_t len)2601 re_buffer(IOSTREAM *s, const char *from, size_t len)
2602 { if ( s->bufp < s->limitp )
2603 { size_t size = s->limitp - s->bufp;
2604
2605 memmove(s->buffer, s->bufp, size);
2606 s->bufp = s->buffer;
2607 s->limitp = &s->bufp[size];
2608 } else
2609 { s->bufp = s->limitp = s->buffer;
2610 }
2611
2612 memcpy(s->bufp, from, len);
2613 s->limitp = s->bufp + len;
2614 }
2615
2616
2617 #ifndef HAVE_MBSNRTOWCS
2618 static size_t
mbsnrtowcs(wchar_t * dest,const char ** src,size_t nms,size_t len,mbstate_t * ps)2619 mbsnrtowcs(wchar_t *dest, const char **src,
2620 size_t nms, size_t len, mbstate_t *ps)
2621 { wchar_t c;
2622 const char *us = *src;
2623 const char *es = us+nms;
2624 size_t count = 0;
2625
2626 assert(dest == NULL); /* incomplete implementation */
2627
2628 while(us<es)
2629 { size_t skip = mbrtowc(&c, us, es-us, ps);
2630
2631 if ( skip == (size_t)-1 ) /* error */
2632 { DEBUG(1, Sdprintf("mbsnrtowcs(): bad multibyte seq\n"));
2633 return skip;
2634 }
2635 if ( skip == (size_t)-2 ) /* incomplete */
2636 { *src = us;
2637 return count;
2638 }
2639
2640 count++;
2641 us += skip;
2642 }
2643
2644 *src = us;
2645 return count;
2646 }
2647 #else
2648 #if defined(HAVE_DECL_MBSNRTOWCS) && !HAVE_DECL_MBSNRTOWCS
2649 size_t mbsnrtowcs(wchar_t *dest, const char **src,
2650 size_t nms, size_t len, mbstate_t *ps);
2651 #endif
2652 #endif /*HAVE_MBSNRTOWCS*/
2653
2654 static int
skip_cr(IOSTREAM * s)2655 skip_cr(IOSTREAM *s)
2656 { if ( s->flags&SIO_TEXT )
2657 { switch(s->newline)
2658 { case SIO_NL_DETECT:
2659 s->newline = SIO_NL_DOS;
2660 /*FALLTHROUGH*/
2661 case SIO_NL_DOS:
2662 return TRUE;
2663 }
2664 }
2665 return FALSE;
2666 }
2667
2668 static foreign_t
read_pending_input(term_t input,term_t list,term_t tail,int chars ARG_LD)2669 read_pending_input(term_t input, term_t list, term_t tail, int chars ARG_LD)
2670 { IOSTREAM *s;
2671
2672 #define ADD_CODE(c) \
2673 do \
2674 { if ( likely(chars==FALSE) ) \
2675 addSmallIntList(&ctx, c); \
2676 else \
2677 addCharList(&ctx, c); \
2678 } while(0)
2679
2680 if ( getInputStream(input, S_DONTCARE, &s) )
2681 { char buf[MAX_PENDING];
2682 ssize_t n;
2683 int64_t off0 = Stell64(s);
2684 IOPOS pos0;
2685 list_ctx ctx;
2686
2687 if ( Sferror(s) )
2688 return streamStatus(s);
2689
2690 n = Sread_pending(s, buf, sizeof(buf), SIO_RP_NOPOS);
2691 if ( n < 0 ) /* should not happen */
2692 return streamStatus(s);
2693 if ( n == 0 ) /* end-of-file */
2694 { return ( PL_unify(list, tail) &&
2695 PL_unify_nil(list) );
2696 }
2697 if ( s->position )
2698 { pos0 = *s->position;
2699 } else
2700 { memset(&pos0, 0, sizeof(pos0)); /* make compiler happy */
2701 }
2702
2703 switch(s->encoding)
2704 { case ENC_OCTET:
2705 case ENC_ISO_LATIN_1:
2706 case ENC_ASCII:
2707 { ssize_t i;
2708
2709 if ( !allocList(n, &ctx) )
2710 return FALSE;
2711
2712 for(i=0; i<n; i++)
2713 { int c = buf[i]&0xff;
2714
2715 if ( c == '\r' && skip_cr(s) )
2716 continue;
2717
2718 if ( s->position )
2719 S__fupdatefilepos_getc(s, c);
2720
2721 ADD_CODE(c);
2722 }
2723 if ( s->position )
2724 s->position->byteno = pos0.byteno+n;
2725
2726 break;
2727 }
2728 case ENC_ANSI:
2729 { size_t count, i;
2730 mbstate_t s0;
2731 const char *us = buf;
2732 const char *es = buf+n;
2733
2734 if ( !s->mbstate )
2735 { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) )
2736 { PL_error(NULL, 0, NULL, ERR_NOMEM);
2737 goto failure;
2738 }
2739 memset(s->mbstate, 0, sizeof(*s->mbstate));
2740 }
2741 s0 = *s->mbstate;
2742 count = mbsnrtowcs(NULL, &us, n, 0, &s0);
2743 if ( count == (size_t)-1 )
2744 { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence");
2745 goto failure;
2746 }
2747
2748 DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
2749 count, n, es-us));
2750
2751 if ( !allocList(count, &ctx) )
2752 return FALSE;
2753
2754 for(us=buf,i=0; i<count; i++)
2755 { wchar_t c;
2756
2757 us += mbrtowc(&c, us, es-us, s->mbstate);
2758 if ( c == '\r' && skip_cr(s) )
2759 continue;
2760 if ( s->position )
2761 S__fupdatefilepos_getc(s, c);
2762
2763 ADD_CODE(c);
2764 }
2765 if ( s->position )
2766 s->position->byteno = pos0.byteno+us-buf;
2767
2768 re_buffer(s, us, es-us);
2769 break;
2770 }
2771 case ENC_UTF8:
2772 { const char *us = buf;
2773 const char *es = buf+n;
2774 size_t count = 0, i;
2775
2776 while(us<es)
2777 { if ( !(us[0]&0x80) )
2778 { count++;
2779 us++;
2780 } else
2781 { int ex = UTF8_FBN(us[0]);
2782
2783 if ( ex >= 0 )
2784 { const char *ec = us + ex + 1;
2785
2786 if ( ec <= es )
2787 { count++;
2788 us=ec;
2789 } else /* incomplete multi-byte */
2790 break;
2791 } else
2792 { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence");
2793 goto failure;
2794 }
2795 }
2796 }
2797
2798 DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
2799 count, n, es-us));
2800
2801 if ( !allocList(count, &ctx) )
2802 return FALSE;
2803
2804 for(us=buf,i=0; i<count; i++)
2805 { int c;
2806
2807 us = utf8_get_char(us, &c);
2808 if ( c == '\r' && skip_cr(s) )
2809 continue;
2810 if ( s->position )
2811 S__fupdatefilepos_getc(s, c);
2812
2813 ADD_CODE(c);
2814 }
2815 if ( s->position )
2816 s->position->byteno = pos0.byteno+us-buf;
2817
2818 re_buffer(s, us, es-us);
2819 break;
2820 }
2821 case ENC_UNICODE_BE:
2822 case ENC_UNICODE_LE:
2823 { size_t count = (size_t)n/2;
2824 const char *us = buf;
2825 size_t done, i;
2826
2827 if ( !allocList(count, &ctx) )
2828 return FALSE;
2829
2830 for(i=0; i<count; us+=2, i++)
2831 { int c;
2832
2833 if ( s->encoding == ENC_UNICODE_BE )
2834 c = ((us[0]&0xff)<<8)+(us[1]&0xff);
2835 else
2836 c = ((us[1]&0xff)<<8)+(us[0]&0xff);
2837 if ( c == '\r' && skip_cr(s) )
2838 continue;
2839
2840 if ( s->position )
2841 S__fupdatefilepos_getc(s, c);
2842
2843 ADD_CODE(c);
2844 }
2845
2846 done = count*2;
2847 if ( s->position )
2848 s->position->byteno = pos0.byteno+done;
2849 re_buffer(s, buf+done, n-done);
2850 break;
2851 }
2852 case ENC_WCHAR:
2853 { const pl_wchar_t *ws = (const pl_wchar_t*)buf;
2854 size_t count = (size_t)n/sizeof(pl_wchar_t);
2855 size_t done, i;
2856
2857 if ( !allocList(count, &ctx) )
2858 return FALSE;
2859
2860 for(i=0; i<count; i++)
2861 { int c = ws[i];
2862
2863 if ( c == '\r' && skip_cr(s) )
2864 continue;
2865 if ( s->position )
2866 S__fupdatefilepos_getc(s, c);
2867
2868 ADD_CODE(c);
2869 }
2870
2871 done = count*sizeof(pl_wchar_t);
2872 if ( s->position )
2873 s->position->byteno = pos0.byteno+done;
2874 re_buffer(s, buf+done, n-done);
2875 break;
2876 }
2877 case ENC_UNKNOWN:
2878 default:
2879 assert(0);
2880 return FALSE;
2881 }
2882
2883 if ( !unifyDiffList(list, tail, &ctx) )
2884 goto failure;
2885
2886 releaseStream(s);
2887 return TRUE;
2888
2889 failure:
2890 Sseek64(s, off0, SIO_SEEK_SET); /* TBD: error? */
2891 if ( s->position )
2892 *s->position = pos0;
2893 releaseStream(s);
2894 return FALSE;
2895 }
2896
2897 return FALSE;
2898 }
2899
2900
2901 static
2902 PRED_IMPL("read_pending_codes", 3, read_pending_codes, 0)
2903 { PRED_LD
2904
2905 return read_pending_input(A1, A2, A3, FALSE PASS_LD);
2906 }
2907
2908
2909 static
2910 PRED_IMPL("read_pending_chars", 3, read_pending_chars, 0)
2911 { PRED_LD
2912
2913 return read_pending_input(A1, A2, A3, TRUE PASS_LD);
2914 }
2915
2916
2917 /** peek_string(+Stream, +Len, -String) is det.
2918
2919 Peek input from Stream for Len characters or the entire content of
2920 Stream.
2921 */
2922
2923 PRED_IMPL("peek_string", 3, peek_string, 0)
2924 { PRED_LD
2925 IOSTREAM *s;
2926 size_t len;
2927
2928 if ( !PL_get_size_ex(A2, &len) )
2929 return FALSE;
2930
2931 if ( getInputStream(A1, S_DONTCARE, &s) )
2932 { for(;;)
2933 { if ( s->limitp > s->bufp )
2934 { PL_chars_t text;
2935
2936 text.text.t = s->bufp;
2937 text.length = s->limitp - s->bufp;
2938 text.storage = PL_CHARS_HEAP;
2939 text.canonical = FALSE;
2940 text.encoding = s->encoding;
2941
2942 PL_canonicalise_text(&text);
2943 if ( text.length >= len )
2944 { int rc = PL_unify_text_range(A3, &text, 0, len, PL_STRING);
2945 PL_free_text(&text);
2946 releaseStream(s);
2947 return rc;
2948 }
2949
2950 PL_free_text(&text);
2951 }
2952
2953 if ( s->limitp - s->bufp == s->bufsize )
2954 Ssetbuffer(s, NULL, s->bufsize*2);
2955
2956 if ( S__fillbuf(s) < 0 )
2957 { PL_chars_t text;
2958 int rc;
2959
2960 if ( Sferror(s) )
2961 return streamStatus(s);
2962 s->flags &= ~SIO_FEOF;
2963
2964 text.text.t = s->bufp;
2965 text.length = s->limitp - s->bufp;
2966 text.storage = PL_CHARS_HEAP;
2967 text.canonical = FALSE;
2968 text.encoding = s->encoding;
2969
2970 PL_canonicalise_text(&text);
2971 rc = PL_unify_text(A3, 0, &text, PL_STRING);
2972 releaseStream(s);
2973 return rc;
2974 }
2975 s->bufp--;
2976 }
2977 }
2978
2979 return FALSE;
2980 }
2981
2982
2983 static foreign_t
put_byte(term_t stream,term_t byte ARG_LD)2984 put_byte(term_t stream, term_t byte ARG_LD)
2985 { IOSTREAM *s;
2986 int c;
2987
2988 if ( !PL_get_integer(byte, &c) || c < 0 || c > 255 )
2989 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_byte, byte);
2990 if ( !getBinaryOutputStream(stream, &s) )
2991 return FALSE;
2992
2993 Sputc(c, s);
2994
2995 return streamStatus(s);
2996 }
2997
2998
2999 static
3000 PRED_IMPL("put_byte", 2, put_byte2, 0)
3001 { PRED_LD
3002
3003 return put_byte(A1, A2 PASS_LD);
3004 }
3005
3006
3007 static
3008 PRED_IMPL("put_byte", 1, put_byte1, 0)
3009 { PRED_LD
3010
3011 return put_byte(0, A1 PASS_LD);
3012 }
3013
3014
3015 static foreign_t
put_code(term_t stream,term_t chr ARG_LD)3016 put_code(term_t stream, term_t chr ARG_LD)
3017 { IOSTREAM *s;
3018 int c = 0;
3019
3020 if ( !PL_get_char(chr, &c, FALSE) )
3021 return FALSE;
3022 if ( !getTextOutputStream(stream, &s) )
3023 return FALSE;
3024
3025 Sputcode(c, s);
3026
3027 return streamStatus(s);
3028 }
3029
3030
3031 static
3032 PRED_IMPL("put_code", 2, put_code2, 0)
3033 { PRED_LD
3034
3035 return put_code(A1, A2 PASS_LD);
3036 }
3037
3038
3039 static
3040 PRED_IMPL("put_code", 1, put_code1, 0)
3041 { PRED_LD
3042
3043 return put_code(0, A1 PASS_LD);
3044 }
3045
3046
3047 static
3048 PRED_IMPL("put", 2, put2, 0)
3049 { PRED_LD
3050
3051 return put_code(A1, A2 PASS_LD);
3052 }
3053
3054
3055 static
3056 PRED_IMPL("put", 1, put1, 0)
3057 { PRED_LD
3058
3059 return put_code(0, A1 PASS_LD);
3060 }
3061
3062
3063 static foreign_t
get_nonblank(term_t in,term_t chr ARG_LD)3064 get_nonblank(term_t in, term_t chr ARG_LD)
3065 { IOSTREAM *s;
3066
3067 if ( getTextInputStream(in, &s) )
3068 { int c;
3069
3070 for(;;)
3071 { c = Sgetcode(s);
3072
3073 if ( c == EOF )
3074 { TRY(PL_unify_integer(chr, -1));
3075 return streamStatus(s);
3076 }
3077
3078 if ( !isBlankW(c) )
3079 { releaseStream(s);
3080 return PL_unify_integer(chr, c);
3081 }
3082 }
3083 }
3084
3085 return FALSE;
3086 }
3087
3088
3089 static
3090 PRED_IMPL("get", 1, get1, 0)
3091 { PRED_LD
3092
3093 return get_nonblank(0, A1 PASS_LD);
3094 }
3095
3096
3097 static
3098 PRED_IMPL("get", 2, get2, 0)
3099 { PRED_LD
3100
3101 return get_nonblank(A1, A2 PASS_LD);
3102 }
3103
3104
3105 static foreign_t
skip(term_t in,term_t chr ARG_LD)3106 skip(term_t in, term_t chr ARG_LD)
3107 { int c = -1;
3108 int r;
3109 IOSTREAM *s;
3110
3111 if ( !PL_get_char(chr, &c, FALSE) )
3112 return FALSE;
3113 if ( !getTextInputStream(in, &s) )
3114 return FALSE;
3115
3116 while((r=Sgetcode(s)) != c && r != EOF )
3117 ;
3118
3119 return streamStatus(s);
3120 }
3121
3122
3123 static
3124 PRED_IMPL("skip", 1, skip1, 0)
3125 { PRED_LD
3126
3127 return skip(0, A1 PASS_LD);
3128 }
3129
3130
3131 static
3132 PRED_IMPL("skip", 2, skip2, 0)
3133 { PRED_LD
3134
3135 return skip(A1, A2 PASS_LD);
3136 }
3137
3138
3139 static
3140 PRED_IMPL("get_single_char", 1, get_single_char, 0)
3141 { GET_LD
3142 IOSTREAM *s = getStream(Suser_input);
3143 int c;
3144
3145 if ( !s )
3146 return symbol_no_stream(ATOM_user_input);
3147
3148 c = getSingleChar(s, TRUE);
3149 if ( c == EOF )
3150 { if ( PL_exception(0) )
3151 { releaseStream(s);
3152 return FALSE;
3153 }
3154
3155 PL_unify_integer(A1, -1);
3156 return streamStatus(s);
3157 }
3158
3159 releaseStream(s);
3160
3161 return PL_unify_integer(A1, c);
3162 }
3163
3164
3165 static foreign_t
get_byte2(term_t in,term_t chr ARG_LD)3166 get_byte2(term_t in, term_t chr ARG_LD)
3167 { IOSTREAM *s;
3168
3169 if ( getBinaryInputStream(in, &s) )
3170 { int c = Sgetc(s);
3171
3172 if ( PL_unify_integer(chr, c) )
3173 return streamStatus(s);
3174
3175 if ( Sferror(s) )
3176 return streamStatus(s);
3177
3178 PL_get_char(chr, &c, TRUE); /* set type-error */
3179 }
3180
3181 return FALSE;
3182 }
3183
3184
3185 static
3186 PRED_IMPL("get_byte", 2, get_byte2, 0)
3187 { PRED_LD
3188
3189 return get_byte2(A1, A2 PASS_LD);
3190 }
3191
3192
3193 static
3194 PRED_IMPL("get_byte", 1, get_byte1, 0)
3195 { PRED_LD
3196
3197 return get_byte2(0, A1 PASS_LD);
3198 }
3199
3200
3201 static foreign_t
get_code2(term_t in,term_t chr ARG_LD)3202 get_code2(term_t in, term_t chr ARG_LD)
3203 { IOSTREAM *s;
3204
3205 if ( getTextInputStream(in, &s) )
3206 { int c = Sgetcode(s);
3207
3208 if ( !streamStatus(s) ) /* I/O error */
3209 return FALSE;
3210
3211 if ( PL_unify_integer(chr, c) )
3212 return TRUE;
3213
3214 PL_get_char(chr, &c, TRUE); /* set type-error */
3215 }
3216
3217 return FALSE;
3218 }
3219
3220
3221 static
3222 PRED_IMPL("get_code", 2, get_code2, 0)
3223 { PRED_LD
3224 return get_code2(A1, A2 PASS_LD);
3225 }
3226
3227
3228 static
3229 PRED_IMPL("get_code", 1, get_code1, 0)
3230 { PRED_LD
3231 return get_code2(0, A1 PASS_LD);
3232 }
3233
3234
3235 static foreign_t
get_char2(term_t in,term_t chr ARG_LD)3236 get_char2(term_t in, term_t chr ARG_LD)
3237 { IOSTREAM *s;
3238
3239 if ( getTextInputStream(in, &s) )
3240 { int c = Sgetcode(s);
3241
3242 if ( !streamStatus(s) ) /* I/O error */
3243 return FALSE;
3244
3245 if ( PL_unify_atom(chr, c == -1 ? ATOM_end_of_file : codeToAtom(c)) )
3246 return TRUE;
3247
3248 PL_get_char(chr, &c, TRUE); /* set type-error */
3249 }
3250
3251 return FALSE;
3252 }
3253
3254
3255 static
3256 PRED_IMPL("get_char", 2, get_char2, 0)
3257 { PRED_LD
3258 return get_char2(A1, A2 PASS_LD);
3259 }
3260
3261
3262 static
3263 PRED_IMPL("get_char", 1, get_char1, 0)
3264 { PRED_LD
3265 return get_char2(0, A1 PASS_LD);
3266 }
3267
3268
3269 static
3270 PRED_IMPL("ttyflush", 0, ttyflush, 0)
3271 { PRED_LD
3272 IOSTREAM *s = getStream(Suser_output);
3273
3274 if ( s )
3275 { Sflush(s);
3276
3277 return streamStatus(s);
3278 }
3279
3280 return symbol_no_stream(ATOM_user_output);
3281 }
3282
3283
3284 static
3285 PRED_IMPL("protocol", 1, protocol, 0)
3286 { return openProtocol(A1, FALSE);
3287 }
3288
3289
3290 static
3291 PRED_IMPL("protocola", 1, protocola, 0)
3292 { return openProtocol(A1, TRUE);
3293 }
3294
3295
3296 static
3297 PRED_IMPL("protocolling", 1, protocolling, 0)
3298 { PRED_LD
3299 IOSTREAM *s;
3300
3301 if ( (s = Sprotocol) )
3302 { atom_t a;
3303
3304 if ( (a = fileNameStream(s)) )
3305 return PL_unify_atom(A1, a);
3306 else
3307 return PL_unify_stream_or_alias(A1, s);
3308 }
3309
3310 return FALSE;
3311 }
3312
3313
3314 static
3315 PRED_IMPL("prompt", 2, prompt, 0)
3316 { PRED_LD
3317 atom_t a;
3318
3319 term_t old = A1;
3320 term_t new = A2;
3321
3322 if ( !PL_unify_atom(old, LD->prompt.current) )
3323 return FALSE;
3324 if ( PL_compare(A1,A2) == 0 )
3325 return TRUE;
3326
3327 if ( PL_get_atom_ex(new, &a) )
3328 { if ( LD->prompt.current )
3329 PL_unregister_atom(LD->prompt.current);
3330 LD->prompt.current = a;
3331 PL_register_atom(a);
3332 return TRUE;
3333 }
3334
3335 return FALSE;
3336 }
3337
3338
3339 void
prompt1(atom_t prompt)3340 prompt1(atom_t prompt)
3341 { GET_LD
3342
3343 if ( LD->prompt.first != prompt )
3344 { if ( LD->prompt.first )
3345 PL_unregister_atom(LD->prompt.first);
3346 LD->prompt.first = prompt;
3347 PL_register_atom(LD->prompt.first);
3348 }
3349
3350 LD->prompt.first_used = FALSE;
3351 }
3352
3353
3354 static
3355 PRED_IMPL("prompt1", 1, prompt1, 0)
3356 { GET_LD
3357 atom_t a;
3358 PL_chars_t txt;
3359
3360 if ( PL_get_atom(A1, &a) )
3361 { prompt1(a);
3362 } else if ( PL_get_text(A1, &txt, CVT_ALL|CVT_EXCEPTION) )
3363 { prompt1(textToAtom(&txt));
3364 } else
3365 return FALSE;
3366
3367 return TRUE;
3368 }
3369
3370
3371 atom_t
PrologPrompt(void)3372 PrologPrompt(void)
3373 { GET_LD
3374 IOSTREAM *in;
3375
3376 if ( !LD->prompt.first_used && LD->prompt.first )
3377 { LD->prompt.first_used = TRUE;
3378
3379 return LD->prompt.first;
3380 }
3381
3382 if ( (in=Suser_input) &&
3383 in->position &&
3384 in->position->linepos == 0 )
3385 return LD->prompt.current;
3386 else
3387 return 0; /* "" */
3388 }
3389
3390
3391 static int
tab(term_t out,term_t spaces ARG_LD)3392 tab(term_t out, term_t spaces ARG_LD)
3393 { int64_t count;
3394 IOSTREAM *s;
3395
3396 if ( !getTextOutputStream(out, &s) )
3397 return FALSE;
3398 if ( !PL_eval_expression_to_int64_ex(spaces, &count) )
3399 return FALSE;
3400
3401 while(count-- > 0)
3402 { if ( Sputcode(' ', s) < 0 )
3403 break;
3404 }
3405
3406 return streamStatus(s);
3407 }
3408
3409
3410 static
3411 PRED_IMPL("tab", 2, tab2, 0)
3412 { PRED_LD
3413
3414 return tab(A1, A2 PASS_LD);
3415 }
3416
3417 static
3418 PRED_IMPL("tab", 1, tab1, 0)
3419 { PRED_LD
3420
3421 return tab(0, A1 PASS_LD);
3422 }
3423
3424
3425 /*******************************
3426 * ENCODING *
3427 *******************************/
3428
3429 static struct encname
3430 { IOENC code;
3431 atom_t name;
3432 } encoding_names[] =
3433 { { ENC_UNKNOWN, ATOM_unknown },
3434 { ENC_OCTET, ATOM_octet },
3435 { ENC_ASCII, ATOM_ascii },
3436 { ENC_ISO_LATIN_1, ATOM_iso_latin_1 },
3437 { ENC_ANSI, ATOM_text },
3438 { ENC_UTF8, ATOM_utf8 },
3439 { ENC_UNICODE_BE, ATOM_unicode_be },
3440 { ENC_UNICODE_LE, ATOM_unicode_le },
3441 { ENC_WCHAR, ATOM_wchar_t },
3442 { ENC_UNKNOWN, 0 },
3443 };
3444
3445
3446 IOENC
atom_to_encoding(atom_t a)3447 atom_to_encoding(atom_t a)
3448 { struct encname *en;
3449
3450 for(en=encoding_names; en->name; en++)
3451 { if ( en->name == a )
3452 return en->code;
3453 }
3454
3455 return ENC_UNKNOWN;
3456 }
3457
3458
3459 atom_t
encoding_to_atom(IOENC enc)3460 encoding_to_atom(IOENC enc)
3461 { if ( (int)enc > 0 &&
3462 (int)enc < sizeof(encoding_names)/sizeof(encoding_names[0]) )
3463 return encoding_names[enc].name;
3464 return NULL_ATOM;
3465 }
3466
3467
3468 static int
bad_encoding(const char * msg,atom_t name)3469 bad_encoding(const char *msg, atom_t name)
3470 { GET_LD
3471 term_t t = PL_new_term_ref();
3472
3473 PL_put_atom(t, name);
3474 return PL_error(NULL, 0, msg, ERR_DOMAIN, ATOM_encoding, t);
3475 }
3476
3477
3478 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3479 file_name_to_atom() translates a 8-bit filename into a unicode atom. The
3480 encoding is generic `multibyte' on Unix systems and fixed to UTF-8 on
3481 Windows, where the uxnt layer translates the UTF-8 sequences to the
3482 Windows *W() functions.
3483 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3484
3485 atom_t
file_name_to_atom(const char * fn)3486 file_name_to_atom(const char *fn)
3487 { PL_chars_t text;
3488 atom_t a;
3489
3490 text.text.t = (char *)fn;
3491 text.encoding = ((REP_FN&REP_UTF8) ? ENC_UTF8 :
3492 (REP_FN&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
3493 text.storage = PL_CHARS_HEAP;
3494 text.length = strlen(fn);
3495 text.canonical = FALSE;
3496
3497 a = textToAtom(&text);
3498 PL_free_text(&text);
3499
3500 return a;
3501 }
3502
3503
3504 /*******************************
3505 * IRI HOOKS *
3506 *******************************/
3507
3508 int
file_name_is_iri(const char * path)3509 file_name_is_iri(const char *path)
3510 { const char *s;
3511
3512 for(s=path; *s >= 'a' && *s <= 'z'; )
3513 s++;
3514 if ( s >= path+2 && /* >= two letter scheme */
3515 s[0] == ':' && s[1] == '/' && s[2] == '/' )
3516 return s-path;
3517
3518 return 0;
3519 }
3520
3521
3522 static int
call_iri_hook(term_t argv,iri_op op,va_list args)3523 call_iri_hook(term_t argv, iri_op op, va_list args)
3524 { GET_LD
3525 static predicate_t pred = NULL;
3526
3527 if ( !pred )
3528 pred = PL_predicate("iri_hook", 4, "$iri");
3529
3530 if ( !hasClausesDefinition(pred->definition) )
3531 { sysError("IRI scheme handler not yet installed");
3532 return FALSE;
3533 }
3534
3535 switch(op)
3536 { case IRI_OPEN:
3537 { atom_t mode = va_arg(args, atom_t);
3538 term_t options = va_arg(args, term_t);
3539
3540 if ( !options )
3541 { options = PL_new_term_ref();
3542 PL_put_nil(options);
3543 }
3544
3545 if ( !PL_unify_term(argv+2,
3546 PL_FUNCTOR, FUNCTOR_open2,
3547 PL_ATOM, mode,
3548 PL_TERM, options) )
3549 return FALSE;
3550 break;
3551 }
3552 case IRI_ACCESS:
3553 { int md = va_arg(args, int);
3554 atom_t mode;
3555
3556 switch(md)
3557 { case ACCESS_WRITE: mode = ATOM_write; break;
3558 case ACCESS_READ: mode = ATOM_read; break;
3559 case ACCESS_EXECUTE: mode = ATOM_execute; break;
3560 case ACCESS_EXIST: mode = ATOM_exist; break;
3561 case ACCESS_FILE: mode = ATOM_file; break;
3562 case ACCESS_DIRECTORY: mode = ATOM_directory; break;
3563 default: assert(0); return FALSE;
3564 }
3565 if ( !PL_unify_term(argv+2,
3566 PL_FUNCTOR, FUNCTOR_access1,
3567 PL_ATOM, mode) )
3568 return FALSE;
3569 break;
3570 }
3571 case IRI_TIME:
3572 if ( !PL_put_atom(argv+2, ATOM_time) )
3573 return FALSE;
3574 break;
3575 case IRI_SIZE:
3576 if ( !PL_put_atom(argv+2, ATOM_size) )
3577 return FALSE;
3578 break;
3579 default:
3580 assert(0);
3581 return FALSE;
3582 }
3583
3584 if ( PL_call_predicate(NULL, PL_Q_PASS_EXCEPTION, pred, argv) )
3585 { switch(op)
3586 { case IRI_OPEN:
3587 { IOSTREAM **vp = va_arg(args, IOSTREAM**);
3588 return PL_get_stream(argv+3, vp, (SIO_INPUT|SIO_OUTPUT));
3589 }
3590 case IRI_ACCESS:
3591 { int *vp = va_arg(args, int*);
3592 return PL_get_bool_ex(argv+3, vp);
3593 }
3594 case IRI_TIME:
3595 { double *vp = va_arg(args, double*);
3596 return PL_get_float_ex(argv+3, vp);
3597 }
3598 case IRI_SIZE:
3599 { int64_t *vp = va_arg(args, int64_t*);
3600 return PL_get_int64_ex(argv+3, vp);
3601 }
3602 default:
3603 assert(0);
3604 return FALSE;
3605 }
3606 } else
3607 { return FALSE;
3608 }
3609 }
3610
3611
3612 static int
iri_hook_va(const char * url,iri_op op,va_list args)3613 iri_hook_va(const char *url, iri_op op, va_list args)
3614 { GET_LD
3615 fid_t fid;
3616 const char *escheme = strchr(url, ':');
3617
3618 if ( (fid = PL_open_foreign_frame()) )
3619 { term_t argv;
3620 int rc;
3621
3622 rc = ( (argv = PL_new_term_refs(4)) &&
3623 PL_put_atom_nchars(argv+0, escheme-url, url) &&
3624 PL_unify_chars(argv+1, PL_STRING|REP_FN, (size_t)-1, url) &&
3625 call_iri_hook(argv, op, args) );
3626
3627 PL_close_foreign_frame(fid);
3628
3629 return rc;
3630 }
3631
3632 return FALSE;
3633 }
3634
3635 int
iri_hook(const char * url,iri_op op,...)3636 iri_hook(const char *url, iri_op op, ...)
3637 { int rc;
3638 va_list args;
3639
3640 va_start(args, op);
3641 rc = iri_hook_va(url, op, args);
3642 va_end(args);
3643
3644 return rc;
3645 }
3646
3647 /********************************
3648 * STREAM BASED I/O *
3649 *********************************/
3650
3651 static const opt_spec open4_options[] =
3652 { { ATOM_type, OPT_ATOM },
3653 { ATOM_reposition, OPT_BOOL },
3654 { ATOM_alias, OPT_ATOM },
3655 { ATOM_eof_action, OPT_ATOM },
3656 { ATOM_close_on_abort, OPT_BOOL },
3657 { ATOM_buffer, OPT_ATOM },
3658 { ATOM_lock, OPT_ATOM },
3659 { ATOM_wait, OPT_BOOL },
3660 { ATOM_encoding, OPT_ATOM },
3661 { ATOM_bom, OPT_BOOL },
3662 { ATOM_create, OPT_TERM },
3663 #ifdef O_LOCALE
3664 { ATOM_locale, OPT_LOCALE },
3665 #endif
3666 { NULL_ATOM, 0 }
3667 };
3668
3669
3670 int
stream_encoding_options(atom_t type,atom_t encoding,int * bom,IOENC * enc)3671 stream_encoding_options(atom_t type, atom_t encoding, int *bom, IOENC *enc)
3672 { GET_LD
3673
3674 if ( encoding != NULL_ATOM )
3675 { *enc = atom_to_encoding(encoding);
3676
3677 if ( *enc == ENC_UNKNOWN )
3678 return bad_encoding(NULL, encoding);
3679 if ( type == ATOM_binary && *enc != ENC_OCTET )
3680 return bad_encoding("type(binary) implies encoding(octet)", encoding);
3681
3682 switch(*enc) /* explicitely specified: do not */
3683 { case ENC_OCTET: /* switch to Unicode. For implicit */
3684 case ENC_ASCII: /* and unicode types we must detect */
3685 case ENC_ISO_LATIN_1: /* and skip the BOM */
3686 case ENC_WCHAR:
3687 *bom = FALSE;
3688 break;
3689 default:
3690 ;
3691 }
3692 } else if ( type == ATOM_binary )
3693 { *enc = ENC_OCTET;
3694 *bom = FALSE;
3695 } else if ( type == ATOM_text )
3696 { *enc = LD->encoding;
3697 } else
3698 { term_t ex;
3699
3700 return ( (ex = PL_new_term_ref()) &&
3701 PL_unify_term(ex, PL_FUNCTOR, FUNCTOR_type1, PL_ATOM, type) &&
3702 PL_domain_error("stream_option", ex)
3703 );
3704 }
3705
3706 return TRUE;
3707 }
3708
3709 /* MT: openStream() must be called unlocked */
3710
3711 IOSTREAM *
openStream(term_t file,term_t mode,term_t options)3712 openStream(term_t file, term_t mode, term_t options)
3713 { GET_LD
3714 atom_t mname;
3715 atom_t type = ATOM_text;
3716 int reposition = TRUE;
3717 atom_t alias = NULL_ATOM;
3718 atom_t eof_action = ATOM_eof_code;
3719 atom_t buffer = ATOM_full;
3720 atom_t lock = ATOM_none;
3721 int wait = TRUE;
3722 atom_t encoding = NULL_ATOM;
3723 #ifdef O_LOCALE
3724 PL_locale *locale = NULL;
3725 #endif
3726 int close_on_abort = TRUE;
3727 int bom = -1;
3728 term_t create = 0;
3729 char how[16];
3730 char *h = how;
3731 char *path;
3732 IOSTREAM *s;
3733 IOENC enc;
3734
3735 if ( options )
3736 { if ( !scan_options(options, 0, ATOM_stream_option, open4_options,
3737 &type, &reposition, &alias, &eof_action,
3738 &close_on_abort, &buffer, &lock, &wait,
3739 &encoding, &bom, &create
3740 #ifdef O_LOCALE
3741 , &locale
3742 #endif
3743 ) )
3744 return FALSE;
3745 }
3746
3747 /* MODE */
3748 if ( PL_get_atom_ex(mode, &mname) )
3749 { if ( mname == ATOM_write )
3750 { *h++ = 'w';
3751 } else if ( mname == ATOM_append )
3752 { *h++ = 'a';
3753 } else if ( mname == ATOM_update )
3754 { *h++ = 'u';
3755 } else if ( mname == ATOM_read )
3756 { *h++ = 'r';
3757 } else
3758 { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_io_mode, mode);
3759 return NULL;
3760 }
3761 } else
3762 { return NULL;
3763 }
3764 if ( create )
3765 { term_t tail = PL_copy_term_ref(create);
3766 term_t head = PL_new_term_ref();
3767 int mode = 0;
3768 int n = 0;
3769
3770 while(PL_get_list(tail, head, tail))
3771 { atom_t a;
3772
3773 if ( !PL_get_atom_ex(head, &a) )
3774 return FALSE;
3775 if ( a == ATOM_read )
3776 mode |= 0444;
3777 else if ( a == ATOM_write )
3778 mode |= 0666;
3779 else if ( a == ATOM_execute )
3780 mode |= 0111;
3781 else if ( a == ATOM_default )
3782 mode |= 0666;
3783 else if ( a == ATOM_all )
3784 mode |= 0777;
3785
3786 if ( ++n == 10 && PL_skip_list(tail, 0, NULL) != PL_LIST )
3787 { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, create);
3788 return NULL;
3789 }
3790 }
3791 if ( !PL_get_nil_ex(tail) )
3792 return FALSE;
3793 *h++ = 'm';
3794 *h++ = ((mode >> 6) & 07) + '0';
3795 *h++ = ((mode >> 3) & 07) + '0';
3796 *h++ = ((mode >> 0) & 07) + '0';
3797 }
3798
3799 if ( !stream_encoding_options(type, encoding, &bom, &enc) )
3800 return NULL;
3801
3802 if ( bom == -1 )
3803 bom = (mname == ATOM_read ? TRUE : FALSE);
3804 if ( type == ATOM_binary )
3805 *h++ = 'b';
3806
3807 /* File locking */
3808 if ( lock != ATOM_none )
3809 { *h++ = (wait ? 'l' : 'L');
3810 if ( lock == ATOM_read || lock == ATOM_shared )
3811 *h++ = 'r';
3812 else if ( lock == ATOM_write || lock == ATOM_exclusive )
3813 *h++ = 'w';
3814 else
3815 { term_t l = PL_new_term_ref();
3816 PL_put_atom(l, lock);
3817 PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_lock, l);
3818 return NULL;
3819 }
3820 }
3821
3822 *h = EOS;
3823
3824 if ( alias != NULL_ATOM &&
3825 streamAliases &&
3826 lookupHTable(streamAliases, (void *)alias) )
3827 { term_t aliast;
3828
3829 if ( (aliast = PL_new_term_ref()) &&
3830 PL_unify_term(aliast,
3831 PL_FUNCTOR, FUNCTOR_alias1,
3832 PL_ATOM, alias) )
3833 PL_error(NULL, 0, NULL, ERR_PERMISSION,
3834 ATOM_open, ATOM_source_sink, aliast);
3835
3836 return NULL;
3837 }
3838
3839 /* FILE */
3840 #ifdef HAVE_POPEN
3841 if ( PL_is_functor(file, FUNCTOR_pipe1) )
3842 { term_t a;
3843 char *cmd;
3844
3845 PL_clear_exception();
3846 a = PL_new_term_ref();
3847 _PL_get_arg(1, file, a);
3848 if ( !PL_get_chars(a, &cmd, CVT_ATOM|CVT_STRING|REP_FN) )
3849 { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, a);
3850 return NULL;
3851 }
3852
3853 if ( !(s = Sopen_pipe(cmd, how)) )
3854 { PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
3855 ATOM_open, ATOM_source_sink, file);
3856 return NULL;
3857 }
3858 } else
3859 #endif /*HAVE_POPEN*/
3860 if ( PL_get_file_name(file, &path, 0) )
3861 { int sl;
3862
3863 if ( (sl=file_name_is_iri(path)) )
3864 { if ( !iri_hook(path, IRI_OPEN, mname, options, &s) )
3865 goto error;
3866 } else
3867 { s = Sopen_file(path, how);
3868 }
3869
3870 if ( s == NULL )
3871 { error:
3872 if ( !PL_exception(0) )
3873 PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
3874 ATOM_open, ATOM_source_sink, file);
3875 return NULL;
3876 }
3877 setFileNameStream_unlocked(s, file_name_to_atom(path));
3878 } else
3879 { return NULL;
3880 }
3881
3882 s->encoding = enc;
3883 #ifdef O_LOCALE
3884 if ( locale )
3885 { Ssetlocale(s, locale, NULL);
3886 releaseLocale(locale); /* acquired by scan_options() */
3887 }
3888 #endif
3889 if ( !close_on_abort )
3890 s->flags |= SIO_NOCLOSE;
3891
3892 if ( how[0] == 'r' )
3893 { if ( !set_eof_action(s, eof_action) )
3894 { Sclose(s);
3895 return NULL;
3896 }
3897 } else
3898 { if ( buffer != ATOM_full &&
3899 !set_buffering(s, buffer) )
3900 { Sclose(s);
3901 return NULL;
3902 }
3903 }
3904
3905 if ( alias != NULL_ATOM )
3906 { PL_LOCK(L_FILE);
3907 aliasStream(s, alias);
3908 PL_UNLOCK(L_FILE);
3909 }
3910 if ( !reposition )
3911 s->position = NULL;
3912
3913 if ( bom )
3914 { if ( mname == ATOM_read )
3915 { if ( ScheckBOM(s) < 0 )
3916 { bom_error:
3917
3918 streamStatus(getStream(s));
3919 Sclose(s);
3920 return NULL;
3921 }
3922 } else
3923 { if ( mname == ATOM_write ||
3924 ( (mname == ATOM_append || mname == ATOM_update) &&
3925 Ssize(s) == 0 ) )
3926 { if ( SwriteBOM(s) < 0 )
3927 goto bom_error;
3928 }
3929 }
3930 }
3931
3932 return s;
3933 }
3934
3935
3936 static
3937 PRED_IMPL("open", 4, open4, PL_FA_ISO)
3938 { IOSTREAM *s = openStream(A1, A2, A4);
3939
3940 if ( s )
3941 return PL_unify_stream_or_alias(A3, s);
3942
3943 return FALSE;
3944 }
3945
3946
3947 static
3948 PRED_IMPL("open", 3, open3, PL_FA_ISO)
3949 { IOSTREAM *s = openStream(A1, A2, 0);
3950
3951 if ( s )
3952 return PL_unify_stream_or_alias(A3, s);
3953
3954 return FALSE;
3955 }
3956
3957 /*******************************
3958 * EDINBURGH I/O *
3959 *******************************/
3960
3961 static IOSTREAM *
findStreamFromFile(atom_t name,unsigned int flags)3962 findStreamFromFile(atom_t name, unsigned int flags)
3963 { TableEnum e;
3964 IOSTREAM *s = NULL, *s0;
3965 stream_context *ctx;
3966
3967 e = newTableEnum(streamContext);
3968 while( advanceTableEnum(e, (void**)&s0, (void**)&ctx) )
3969 { if ( ctx->filename == name &&
3970 true(ctx, flags) )
3971 { s = s0;
3972 break;
3973 }
3974 }
3975 freeTableEnum(e);
3976
3977 return s;
3978 }
3979
3980
3981 int
pl_see(term_t f)3982 pl_see(term_t f)
3983 { GET_LD
3984 IOSTREAM *s;
3985 atom_t a;
3986 term_t mode;
3987
3988 if ( !PL_get_atom_ex(f, &a) )
3989 return FALSE;
3990
3991 PL_LOCK(L_SEETELL);
3992 if ( get_stream_handle(a, &s, SH_ALIAS|SH_UNLOCKED) )
3993 { Scurin = s;
3994 goto ok;
3995 }
3996 if ( a == ATOM_user )
3997 { Scurin = Suser_input;
3998 goto ok;
3999 }
4000 if ( (s = findStreamFromFile(a, IO_SEE)) )
4001 { Scurin = s;
4002 goto ok;
4003 }
4004
4005 mode = PL_new_term_ref();
4006 PL_put_atom(mode, ATOM_read);
4007 if ( !(s = openStream(f, mode, 0)) )
4008 { PL_UNLOCK(L_SEETELL);
4009 return FALSE;
4010 }
4011
4012 set(getStreamContext(s), IO_SEE);
4013 push_input_context(ATOM_see);
4014 Scurin = s;
4015
4016 ok:
4017 PL_UNLOCK(L_SEETELL);
4018
4019 return TRUE;
4020 }
4021
4022 int
pl_seen(void)4023 pl_seen(void)
4024 { GET_LD
4025 IOSTREAM *s = getStream(Scurin);
4026
4027 pop_input_context();
4028
4029 if ( s && s->flags & SIO_NOFEOF )
4030 return TRUE;
4031
4032 if ( s )
4033 return closeStream(s);
4034
4035 return symbol_no_stream(ATOM_current_input);
4036 }
4037
4038 static
4039 PRED_IMPL("see", 1, see, 0)
4040 { return pl_see(A1);
4041 }
4042
4043
4044 static
4045 PRED_IMPL("seen", 0, seen, 0)
4046 { return pl_seen();
4047 }
4048
4049
4050 static
4051 PRED_IMPL("seeing", 1, seeing, 0)
4052 { PRED_LD
4053
4054 if ( Scurin == Suser_input )
4055 return PL_unify_atom(A1, ATOM_user);
4056
4057 return PL_unify_stream(A1, Scurin);
4058 }
4059
4060
4061 /* MT: Does not create a lock on the stream
4062 */
4063
4064 static int
do_tell(term_t f,atom_t m)4065 do_tell(term_t f, atom_t m)
4066 { GET_LD
4067 IOSTREAM *s;
4068 atom_t a;
4069 term_t mode;
4070
4071 if ( !PL_get_atom_ex(f, &a) )
4072 return FALSE;
4073
4074 PL_LOCK(L_SEETELL);
4075 if ( get_stream_handle(a, &s, SH_UNLOCKED) )
4076 { Scurout = s;
4077 goto ok;
4078 }
4079 if ( a == ATOM_user )
4080 { Scurout = Suser_output;
4081 goto ok;
4082 }
4083 if ( (s = findStreamFromFile(a, IO_TELL)) )
4084 { Scurout = s;
4085 goto ok;
4086 }
4087
4088 mode = PL_new_term_ref();
4089 PL_put_atom(mode, m);
4090 if ( !(s = openStream(f, mode, 0)) )
4091 { PL_UNLOCK(L_SEETELL);
4092 return FALSE;
4093 }
4094
4095 set(getStreamContext(s), IO_TELL);
4096 pushOutputContext();
4097 Scurout = s;
4098
4099 ok:
4100 PL_UNLOCK(L_SEETELL);
4101 return TRUE;
4102 }
4103
4104 static
4105 PRED_IMPL("tell", 1, tell, 0)
4106 { return do_tell(A1, ATOM_write);
4107 }
4108
4109 static
4110 PRED_IMPL("append", 1, append, 0)
4111 { return do_tell(A1, ATOM_append);
4112 }
4113
4114 static
4115 PRED_IMPL("telling", 1, telling, 0)
4116 { PRED_LD
4117
4118 if ( Scurout == Suser_output )
4119 return PL_unify_atom(A1, ATOM_user);
4120
4121 return PL_unify_stream(A1, Scurout);
4122 }
4123
4124 static
4125 PRED_IMPL("told", 0, told, 0)
4126 { PRED_LD
4127 IOSTREAM *s = getStream(Scurout);
4128
4129 popOutputContext();
4130
4131 if ( s && s->flags & SIO_NOFEOF )
4132 return TRUE;
4133
4134 if ( s )
4135 return closeStream(s);
4136
4137 return symbol_no_stream(ATOM_current_output);
4138 }
4139
4140 /*******************************
4141 * NULL-STREAM *
4142 *******************************/
4143
4144 static ssize_t
Swrite_null(void * handle,char * buf,size_t size)4145 Swrite_null(void *handle, char *buf, size_t size)
4146 { (void)handle;
4147 (void)buf;
4148
4149 return size;
4150 }
4151
4152
4153 static ssize_t
Sread_null(void * handle,char * buf,size_t size)4154 Sread_null(void *handle, char *buf, size_t size)
4155 { (void)handle;
4156 (void)buf;
4157 (void)size;
4158
4159 return 0;
4160 }
4161
4162
4163 static long
Sseek_null(void * handle,long offset,int whence)4164 Sseek_null(void *handle, long offset, int whence)
4165 { (void)handle;
4166
4167 switch(whence)
4168 { case SIO_SEEK_SET:
4169 return offset;
4170 case SIO_SEEK_CUR:
4171 case SIO_SEEK_END:
4172 default:
4173 return -1;
4174 }
4175 }
4176
4177
4178 static int
Sclose_null(void * handle)4179 Sclose_null(void *handle)
4180 { (void)handle;
4181
4182 return 0;
4183 }
4184
4185
4186 static const IOFUNCTIONS nullFunctions =
4187 { Sread_null,
4188 Swrite_null,
4189 Sseek_null,
4190 Sclose_null
4191 };
4192
4193
4194 static
4195 PRED_IMPL("open_null_stream", 1, open_null_stream, 0)
4196 { int sflags = SIO_NBUF|SIO_RECORDPOS|SIO_OUTPUT|SIO_TEXT;
4197 IOSTREAM *s = Snew((void *)NULL, sflags, (IOFUNCTIONS *)&nullFunctions);
4198
4199 if ( s )
4200 { s->encoding = ENC_UTF8;
4201 return PL_unify_stream_or_alias(A1, s);
4202 }
4203
4204 return FALSE;
4205 }
4206
4207
4208 static int
do_close(IOSTREAM * s,int force)4209 do_close(IOSTREAM *s, int force)
4210 { if ( force )
4211 { if ( !s )
4212 return TRUE;
4213 if ( s == Sinput )
4214 { Sclearerr(s);
4215 } else if ( s == Soutput || s == Serror )
4216 { Sflush(s);
4217 Sclearerr(s);
4218 } else
4219 { Sflush(s);
4220 if ( Sclose(s) < 0 )
4221 PL_clear_exception();
4222 }
4223
4224 return TRUE;
4225 } else if ( s )
4226 { return closeStream(s);
4227 } else
4228 { return FALSE;
4229 }
4230 }
4231
4232
4233 static int
pl_close(term_t stream,int force ARG_LD)4234 pl_close(term_t stream, int force ARG_LD)
4235 { IOSTREAM *s;
4236 atom_t a;
4237 stream_ref *ref;
4238 PL_blob_t *type;
4239
4240 if ( !PL_get_atom(stream, &a) )
4241 return not_a_stream(stream);
4242
4243 ref = PL_blob_data(a, NULL, &type);
4244 if ( type == &stream_blob ) /* close(Stream[pair], ...) */
4245 { int rc = TRUE;
4246
4247 if ( ref->read && ref->write )
4248 { assert(ref->read->references);
4249 assert(ref->write->references);
4250 if ( ref->write && !ref->write->erased )
4251 rc = do_close(getStream(ref->write), force);
4252 if ( ref->read && !ref->read->erased )
4253 rc = do_close(getStream(ref->read), force) && rc;
4254 } else
4255 { if ( ref->read )
4256 { assert(ref->read->references);
4257 rc = do_close(getStream(ref->read), force);
4258 } else if ( ref->write )
4259 { assert(ref->write->references);
4260 rc = do_close(getStream(ref->write), force);
4261 }
4262 }
4263
4264 if ( rc == FALSE && !PL_exception(0) )
4265 rc = PL_error(NULL, 0, "already closed",
4266 ERR_EXISTENCE, ATOM_stream, stream);
4267
4268
4269
4270 return rc;
4271 }
4272
4273 /* close(Alias, ...) */
4274 if ( get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS) )
4275 return do_close(s, force);
4276
4277 return FALSE;
4278 }
4279
4280
4281 static
4282 PRED_IMPL("close", 1, close, PL_FA_ISO)
4283 { PRED_LD
4284
4285 return pl_close(A1, FALSE PASS_LD);
4286 }
4287
4288
4289 static const opt_spec close2_options[] =
4290 { { ATOM_force, OPT_BOOL },
4291 { NULL_ATOM, 0 }
4292 };
4293
4294
4295 static
4296 PRED_IMPL("close", 2, close2, PL_FA_ISO)
4297 { PRED_LD
4298 int force = FALSE;
4299
4300 if ( !scan_options(A2, 0, ATOM_close_option, close2_options, &force) )
4301 return FALSE;
4302
4303 return pl_close(A1, force PASS_LD);
4304 }
4305
4306
4307 /*******************************
4308 * STREAM-PROPERTY *
4309 *******************************/
4310
4311 static int
stream_file_name_propery(IOSTREAM * s,term_t prop ARG_LD)4312 stream_file_name_propery(IOSTREAM *s, term_t prop ARG_LD)
4313 { atom_t name;
4314
4315 for(; s && s->magic == SIO_MAGIC; s=s->downstream)
4316 { if ( s->context &&
4317 (name = getStreamContext(s)->filename) )
4318 { return PL_unify_atom(prop, name);
4319 }
4320 }
4321
4322 return FALSE;
4323 }
4324
4325
4326 static int
stream_mode_property(IOSTREAM * s,term_t prop ARG_LD)4327 stream_mode_property(IOSTREAM *s, term_t prop ARG_LD)
4328 { atom_t mode;
4329
4330 if ( s->flags & SIO_INPUT )
4331 mode = ATOM_read;
4332 else
4333 { assert(s->flags & SIO_OUTPUT);
4334
4335 if ( s->flags & SIO_APPEND )
4336 mode = ATOM_append;
4337 else if ( s->flags & SIO_UPDATE )
4338 mode = ATOM_update;
4339 else
4340 mode = ATOM_write;
4341 }
4342
4343 return PL_unify_atom(prop, mode);
4344 }
4345
4346
4347 static int
stream_input_prop(IOSTREAM * s ARG_LD)4348 stream_input_prop(IOSTREAM *s ARG_LD)
4349 { IGNORE_LD
4350
4351 return (s->flags & SIO_INPUT) ? TRUE : FALSE;
4352 }
4353
4354
4355 static int
stream_output_prop(IOSTREAM * s ARG_LD)4356 stream_output_prop(IOSTREAM *s ARG_LD)
4357 { IGNORE_LD
4358
4359 return (s->flags & SIO_OUTPUT) ? TRUE : FALSE;
4360 }
4361
4362
4363 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4364 Incomplete: should be non-deterministic if the stream has multiple aliases!
4365 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4366
4367 static int
stream_alias_prop(IOSTREAM * s,term_t prop ARG_LD)4368 stream_alias_prop(IOSTREAM *s, term_t prop ARG_LD)
4369 { atom_t name;
4370 stream_context *ctx;
4371 int i;
4372
4373 if ( s->magic != SIO_MAGIC || !(ctx=s->context) )
4374 return FALSE;
4375
4376 if ( PL_get_atom(prop, &name) )
4377 { alias *a;
4378
4379 for( a = ctx->alias_head; a; a = a->next )
4380 { if ( a->name == name )
4381 return TRUE;
4382 }
4383
4384 if ( (i=standardStreamIndexFromName(name)) >= 0 &&
4385 i < 6 &&
4386 s == LD->IO.streams[i] )
4387 return TRUE;
4388
4389 return FALSE;
4390 }
4391
4392 if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
4393 return PL_unify_atom(prop, standardStreams[i]);
4394 if ( ctx->alias_head )
4395 return PL_unify_atom(prop, ctx->alias_head->name);
4396
4397 return FALSE;
4398 }
4399
4400
4401 static int
stream_position_prop(IOSTREAM * s,term_t prop ARG_LD)4402 stream_position_prop(IOSTREAM *s, term_t prop ARG_LD)
4403 { IGNORE_LD
4404 IOPOS pos;
4405
4406 if ( s->magic == SIO_MAGIC && s->position )
4407 { pos = *s->position;
4408 return PL_unify_term(prop,
4409 PL_FUNCTOR, FUNCTOR_dstream_position4,
4410 PL_INT64, pos.charno,
4411 PL_INT, pos.lineno,
4412 PL_INT, pos.linepos,
4413 PL_INT64, pos.byteno);
4414 }
4415
4416 return FALSE;
4417 }
4418
4419
4420 static int
stream_end_of_stream_prop(IOSTREAM * s,term_t prop ARG_LD)4421 stream_end_of_stream_prop(IOSTREAM *s, term_t prop ARG_LD)
4422 { if ( s->magic == SIO_MAGIC && (s->flags & SIO_INPUT) )
4423 { atom_t val;
4424
4425 if ( s->flags & SIO_FEOF2 )
4426 val = ATOM_past;
4427 else if ( s->flags & SIO_FEOF )
4428 val = ATOM_at;
4429 else
4430 val = ATOM_not;
4431
4432 return PL_unify_atom(prop, val);
4433 }
4434
4435 return FALSE;
4436 }
4437
4438
4439 static int
stream_eof_action_prop(IOSTREAM * s,term_t prop ARG_LD)4440 stream_eof_action_prop(IOSTREAM *s, term_t prop ARG_LD)
4441 { atom_t val;
4442
4443 if ( s->flags & SIO_NOFEOF )
4444 val = ATOM_reset;
4445 else if ( s->flags & SIO_FEOF2ERR )
4446 val = ATOM_error;
4447 else
4448 val = ATOM_eof_code;
4449
4450 return PL_unify_atom(prop, val);
4451 }
4452
4453
4454 #ifdef HAVE_FSTAT
4455 #include <sys/stat.h>
4456 #endif
4457
4458 #if !defined(S_ISREG) && defined(S_IFREG)
4459 #define S_ISREG(m) ((m&S_IFMT) == S_IFREG)
4460 #endif
4461
4462 static int
stream_reposition_prop(IOSTREAM * s,term_t prop ARG_LD)4463 stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD)
4464 { atom_t val;
4465
4466 if ( s->magic == SIO_MAGIC && s->functions->seek )
4467 {
4468 #ifdef HAVE_FSTAT
4469 int fd = Sfileno(s);
4470 struct stat buf;
4471
4472 if ( fd != -1 && fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) )
4473 val = ATOM_true;
4474 else
4475 val = ATOM_false;
4476 #else
4477 val = ATOM_true;
4478 #endif
4479 } else
4480 val = ATOM_false;
4481
4482 return PL_unify_atom(prop, val);
4483 }
4484
4485
4486 static int
stream_close_on_abort_prop(IOSTREAM * s,term_t prop ARG_LD)4487 stream_close_on_abort_prop(IOSTREAM *s, term_t prop ARG_LD)
4488 { IGNORE_LD
4489
4490 return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE));
4491 }
4492
4493
4494 static int
stream_type_prop(IOSTREAM * s,term_t prop ARG_LD)4495 stream_type_prop(IOSTREAM *s, term_t prop ARG_LD)
4496 { return PL_unify_atom(prop, (s->flags & SIO_TEXT) ? ATOM_text : ATOM_binary);
4497 }
4498
4499
4500 static int
stream_file_no_prop(IOSTREAM * s,term_t prop ARG_LD)4501 stream_file_no_prop(IOSTREAM *s, term_t prop ARG_LD)
4502 { int fd;
4503
4504 if ( (fd = Sfileno(s)) >= 0 )
4505 return PL_unify_integer(prop, fd);
4506
4507 return FALSE;
4508 }
4509
4510
4511 static int
stream_tty_prop(IOSTREAM * s,term_t prop ARG_LD)4512 stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD)
4513 { IGNORE_LD
4514
4515 if ( (s->flags & SIO_ISATTY) )
4516 return PL_unify_bool_ex(prop, TRUE);
4517
4518 return FALSE;
4519 }
4520
4521
4522 static int
stream_bom_prop(IOSTREAM * s,term_t prop ARG_LD)4523 stream_bom_prop(IOSTREAM *s, term_t prop ARG_LD)
4524 { IGNORE_LD
4525
4526 if ( (s->flags & SIO_BOM) )
4527 return PL_unify_bool_ex(prop, TRUE);
4528
4529 return FALSE;
4530 }
4531
4532
4533 static int
stream_newline_prop(IOSTREAM * s,term_t prop ARG_LD)4534 stream_newline_prop(IOSTREAM *s, term_t prop ARG_LD)
4535 { switch ( s->newline )
4536 { case SIO_NL_POSIX:
4537 case SIO_NL_DETECT:
4538 return PL_unify_atom(prop, ATOM_posix);
4539 case SIO_NL_DOS:
4540 return PL_unify_atom(prop, ATOM_dos);
4541 }
4542
4543 return FALSE;
4544 }
4545
4546
4547 static int
stream_encoding_prop(IOSTREAM * s,term_t prop ARG_LD)4548 stream_encoding_prop(IOSTREAM *s, term_t prop ARG_LD)
4549 { atom_t ename = encoding_to_atom(s->encoding);
4550
4551 if ( ename )
4552 return PL_unify_atom(prop, ename);
4553 return FALSE;
4554 }
4555
4556
4557 #ifdef O_LOCALE
4558 static int
stream_locale_prop(IOSTREAM * s,term_t prop ARG_LD)4559 stream_locale_prop(IOSTREAM *s, term_t prop ARG_LD)
4560 { if ( s->locale )
4561 return unifyLocale(prop, s->locale, TRUE);
4562 return FALSE;
4563 }
4564 #endif
4565
4566 static int
stream_reperror_prop(IOSTREAM * s,term_t prop ARG_LD)4567 stream_reperror_prop(IOSTREAM *s, term_t prop ARG_LD)
4568 { atom_t a;
4569
4570 if ( (s->flags & SIO_REPXML) )
4571 a = ATOM_xml;
4572 else if ( (s->flags & SIO_REPPL) )
4573 a = ATOM_prolog;
4574 else
4575 a = ATOM_error;
4576
4577 return PL_unify_atom(prop, a);
4578 }
4579
4580
4581 static int
stream_writeerror_prop(IOSTREAM * s,term_t prop ARG_LD)4582 stream_writeerror_prop(IOSTREAM *s, term_t prop ARG_LD)
4583 { atom_t a;
4584
4585 if ( (s->flags & SIO_NOERROR) )
4586 a = ATOM_ignore;
4587 else
4588 a = ATOM_error;
4589
4590 return PL_unify_atom(prop, a);
4591 }
4592
4593
4594 static int
stream_buffer_prop(IOSTREAM * s,term_t prop ARG_LD)4595 stream_buffer_prop(IOSTREAM *s, term_t prop ARG_LD)
4596 { atom_t b;
4597
4598 if ( s->flags & SIO_FBUF )
4599 b = ATOM_full;
4600 else if ( s->flags & SIO_LBUF )
4601 b = ATOM_line;
4602 else /*if ( s->flags & SIO_NBUF )*/
4603 b = ATOM_false;
4604
4605 return PL_unify_atom(prop, b);
4606 }
4607
4608
4609 static int
stream_buffer_size_prop(IOSTREAM * s,term_t prop ARG_LD)4610 stream_buffer_size_prop(IOSTREAM *s, term_t prop ARG_LD)
4611 { int size;
4612
4613 if ( (s->flags & SIO_NBUF) )
4614 return FALSE;
4615
4616 if ( (size = s->bufsize) == 0 )
4617 size = SIO_BUFSIZE;
4618
4619 return PL_unify_integer(prop, size);
4620 }
4621
4622
4623 static int
stream_timeout_prop(IOSTREAM * s,term_t prop ARG_LD)4624 stream_timeout_prop(IOSTREAM *s, term_t prop ARG_LD)
4625 { if ( s->timeout == -1 )
4626 return PL_unify_atom(prop, ATOM_infinite);
4627
4628 return PL_unify_float(prop, (double)s->timeout/1000.0);
4629 }
4630
4631
4632 static int
stream_nlink_prop(IOSTREAM * s,term_t prop ARG_LD)4633 stream_nlink_prop(IOSTREAM *s, term_t prop ARG_LD)
4634 { int fd;
4635
4636 if ( (fd = Sfileno(s)) >= 0 )
4637 { struct stat buf;
4638
4639 if ( fstat(fd, &buf) == 0 )
4640 { return PL_unify_integer(prop, buf.st_nlink);
4641 }
4642 }
4643
4644 return FALSE;
4645 }
4646
4647 static int
stream_close_on_exec_prop(IOSTREAM * s,term_t prop ARG_LD)4648 stream_close_on_exec_prop(IOSTREAM *s, term_t prop ARG_LD)
4649 { int fd;
4650 #ifdef __WINDOWS__
4651 DWORD Flags;
4652 #else
4653 int fd_flags;
4654 #endif
4655 IGNORE_LD
4656
4657 if ( (fd = Sfileno(s)) < 0)
4658 return FALSE;
4659
4660 #if defined(F_GETFD) && defined(FD_CLOEXEC)
4661
4662 if ( (fd_flags = fcntl(fd, F_GETFD)) == -1)
4663 return FALSE;
4664
4665 return PL_unify_bool_ex(prop, (fd_flags&FD_CLOEXEC) != 0 );
4666
4667 #elif defined __WINDOWS__
4668
4669 if ( GetHandleInformation((HANDLE)_get_osfhandle(fd), &Flags) == 0 )
4670 return FALSE;
4671
4672 return PL_unify_bool_ex(prop, (Flags & HANDLE_FLAG_INHERIT) == 0);
4673
4674 #endif
4675
4676 return FALSE;
4677 }
4678
4679 typedef struct
4680 { functor_t functor; /* functor of property */
4681 property_t function; /* function to generate */
4682 } sprop;
4683
4684
4685 static const sprop sprop_list [] =
4686 { { FUNCTOR_file_name1, stream_file_name_propery },
4687 { FUNCTOR_mode1, stream_mode_property },
4688 { FUNCTOR_input0, (property_t)stream_input_prop },
4689 { FUNCTOR_output0, (property_t)stream_output_prop },
4690 { FUNCTOR_alias1, stream_alias_prop },
4691 { FUNCTOR_position1, stream_position_prop },
4692 { FUNCTOR_end_of_stream1, stream_end_of_stream_prop },
4693 { FUNCTOR_eof_action1, stream_eof_action_prop },
4694 { FUNCTOR_reposition1, stream_reposition_prop },
4695 { FUNCTOR_type1, stream_type_prop },
4696 { FUNCTOR_file_no1, stream_file_no_prop },
4697 { FUNCTOR_buffer1, stream_buffer_prop },
4698 { FUNCTOR_buffer_size1, stream_buffer_size_prop },
4699 { FUNCTOR_close_on_abort1,stream_close_on_abort_prop },
4700 { FUNCTOR_tty1, stream_tty_prop },
4701 { FUNCTOR_encoding1, stream_encoding_prop },
4702 #ifdef O_LOCALE
4703 { FUNCTOR_locale1, stream_locale_prop },
4704 #endif
4705 { FUNCTOR_bom1, stream_bom_prop },
4706 { FUNCTOR_newline1, stream_newline_prop },
4707 { FUNCTOR_representation_errors1, stream_reperror_prop },
4708 { FUNCTOR_write_errors1, stream_writeerror_prop },
4709 { FUNCTOR_timeout1, stream_timeout_prop },
4710 { FUNCTOR_nlink1, stream_nlink_prop },
4711 { FUNCTOR_close_on_exec1, stream_close_on_exec_prop },
4712 { 0, NULL }
4713 };
4714
4715
4716 /** '$stream_property'(+Stream, +Property) is det.
4717 '$stream_properties'(+Stream, -PropertyList) is det.
4718 '$streams_properties'(?Property, -Pairs) is det.
4719 */
4720
4721 static const sprop *
get_stream_property_def(term_t t ARG_LD)4722 get_stream_property_def(term_t t ARG_LD)
4723 { functor_t f;
4724
4725 if ( PL_get_functor(t, &f) )
4726 { const sprop *p;
4727
4728 for(p = sprop_list; p->functor; p++ )
4729 { if ( f == p->functor )
4730 return p;
4731 }
4732 }
4733
4734 return NULL;
4735 }
4736
4737
4738 static
4739 PRED_IMPL("$stream_property", 2, dstream_property, 0)
4740 { PRED_LD
4741 const sprop *p;
4742 IOSTREAM *s;
4743 int rc;
4744
4745 if ( !(p=get_stream_property_def(A2 PASS_LD)) )
4746 return FALSE;
4747
4748 PL_LOCK(L_FILE);
4749 if ( (rc=term_stream_handle(A1, &s, SH_ERRORS|SH_UNLOCKED PASS_LD)) )
4750 { switch(arityFunctor(p->functor))
4751 { case 0:
4752 rc = (*(property0_t)p->function)(s PASS_LD);
4753 break;
4754 case 1:
4755 { term_t a1 = PL_new_term_ref();
4756
4757 _PL_get_arg(1, A2, a1);
4758 rc = (*p->function)(s, a1 PASS_LD);
4759 break;
4760 }
4761 default:
4762 assert(0);
4763 rc = FALSE;
4764 }
4765 }
4766 PL_UNLOCK(L_FILE);
4767 return rc;
4768 }
4769
4770
4771 static int
unify_stream_property_list(IOSTREAM * s,term_t plist ARG_LD)4772 unify_stream_property_list(IOSTREAM *s, term_t plist ARG_LD)
4773 { term_t tail = PL_copy_term_ref(plist);
4774 term_t head = PL_new_term_ref();
4775 term_t prop = PL_new_term_ref();
4776 const sprop *p;
4777 int rc;
4778
4779 for(p = sprop_list; p->functor; p++)
4780 { if ( !(rc=PL_put_functor(prop, p->functor)) )
4781 break;
4782
4783 switch(arityFunctor(p->functor))
4784 { case 0:
4785 rc = (*(property0_t)p->function)(s PASS_LD);
4786 break;
4787 case 1:
4788 { term_t a1 = PL_new_term_ref();
4789 _PL_get_arg(1, prop, a1);
4790 rc = (*p->function)(s, a1 PASS_LD);
4791 break;
4792 }
4793 default:
4794 assert(0);
4795 rc = FALSE;
4796 }
4797 if ( rc )
4798 { rc = ( PL_unify_list(tail, head, tail) &&
4799 PL_unify(head, prop) );
4800 if ( !rc )
4801 break;
4802 } else
4803 { if ( PL_exception(0) )
4804 break;
4805 rc = TRUE;
4806 }
4807 }
4808
4809 rc = (rc && PL_unify_nil(tail));
4810 PL_reset_term_refs(tail);
4811
4812 return rc;
4813 }
4814
4815
4816 static
4817 PRED_IMPL("$stream_properties", 2, dstream_properties, 0)
4818 { PRED_LD
4819 int rc;
4820 IOSTREAM *s;
4821
4822 PL_LOCK(L_FILE);
4823 rc = ( term_stream_handle(A1, &s, SH_ERRORS|SH_UNLOCKED PASS_LD) &&
4824 unify_stream_property_list(s, A2 PASS_LD)
4825 );
4826 PL_UNLOCK(L_FILE);
4827
4828 return rc;
4829 }
4830
4831
4832 static int
unify_stream_property(IOSTREAM * s,const sprop * p,term_t t ARG_LD)4833 unify_stream_property(IOSTREAM *s, const sprop *p, term_t t ARG_LD)
4834 { int rc;
4835
4836 if ( !(rc=PL_put_functor(t, p->functor)) )
4837 return FALSE;
4838 switch(arityFunctor(p->functor))
4839 { case 0:
4840 rc = (*(property0_t)p->function)(s PASS_LD);
4841 break;
4842 case 1:
4843 { term_t a1 = PL_new_term_ref();
4844 _PL_get_arg(1, t, a1);
4845 rc = (*p->function)(s, a1 PASS_LD);
4846 PL_reset_term_refs(a1);
4847 break;
4848 }
4849 default:
4850 assert(0);
4851 rc = FALSE;
4852 }
4853
4854 return rc;
4855 }
4856
4857
4858 static
4859 PRED_IMPL("$streams_properties", 2, dstreams_properties, 0)
4860 { PRED_LD
4861 int rc = FALSE;
4862 const sprop *p;
4863 term_t tail = PL_copy_term_ref(A2);
4864 term_t head = PL_new_term_ref();
4865
4866 if ( (p=get_stream_property_def(A1 PASS_LD)) )
4867 { TableEnum e = newTableEnum(streamContext);
4868 IOSTREAM *s;
4869 term_t st = PL_new_term_ref();
4870 term_t pt = PL_new_term_ref();
4871 term_t ex = PL_new_term_ref();
4872
4873 PL_LOCK(L_FILE);
4874 while( advanceTableEnum(e, (void**)&s, NULL))
4875 { rc = ( s->context != NULL &&
4876 unify_stream_property(s, p, pt PASS_LD) &&
4877 can_unify(valTermRef(A1), valTermRef(pt), ex) &&
4878 PL_unify_list(tail, head, tail) &&
4879 PL_unify_functor(head, FUNCTOR_minus2) &&
4880 PL_get_arg(1, head, st) &&
4881 unify_stream_ref(st, s) &&
4882 PL_unify_arg(2, head, pt)
4883 );
4884 if ( !rc && (!PL_is_variable(ex) || PL_exception(0)) )
4885 break;
4886 }
4887 freeTableEnum(e);
4888 PL_UNLOCK(L_FILE);
4889 if ( !PL_is_variable(ex) )
4890 rc = PL_raise_exception(ex);
4891 else
4892 rc = !PL_exception(0) && PL_unify_nil(tail);
4893 } else if ( PL_is_variable(A1) )
4894 { TableEnum e = newTableEnum(streamContext);
4895 IOSTREAM *s;
4896 term_t st = PL_new_term_ref();
4897 term_t pl = PL_new_term_ref();
4898
4899 rc = TRUE;
4900 PL_LOCK(L_FILE);
4901 while( rc && advanceTableEnum(e, (void**)&s, NULL))
4902 { rc = ( s->context != NULL &&
4903 PL_unify_list(tail, head, tail) &&
4904 PL_unify_functor(head, FUNCTOR_minus2) &&
4905 PL_get_arg(1, head, st) &&
4906 unify_stream_ref(st, s) &&
4907 PL_get_arg(2, head, pl) &&
4908 unify_stream_property_list(s, pl PASS_LD)
4909 );
4910 }
4911 freeTableEnum(e);
4912 PL_UNLOCK(L_FILE);
4913 rc = !PL_exception(0) && PL_unify_nil(tail);
4914 }
4915
4916 return rc;
4917 }
4918
4919 static
4920 PRED_IMPL("$alias_stream", 2, dalias_stream, 0)
4921 { PRED_LD
4922 atom_t a;
4923 IOSTREAM *s;
4924 int rc;
4925
4926 PL_LOCK(L_FILE);
4927 rc = ( PL_get_atom_ex(A1, &a) &&
4928 get_stream_handle(a, &s, SH_UNLOCKED) &&
4929 s->context &&
4930 unify_stream_ref(A2, s)
4931 );
4932 PL_UNLOCK(L_FILE);
4933
4934 return rc;
4935 }
4936
4937
4938 static
4939 PRED_IMPL("is_stream", 1, is_stream, 0)
4940 { GET_LD
4941 IOSTREAM *s;
4942 atom_t a;
4943
4944 if ( PL_get_atom(A1, &a) &&
4945 get_stream_handle(a, &s, SH_UNLOCKED) )
4946 return TRUE;
4947
4948 return FALSE;
4949 }
4950
4951
4952
4953 /*******************************
4954 * FLUSH *
4955 *******************************/
4956
4957
4958 static int
flush_output(term_t out ARG_LD)4959 flush_output(term_t out ARG_LD)
4960 { IOSTREAM *s;
4961
4962 if ( getOutputStream(out, S_DONTCARE, &s) )
4963 { Sflush(s);
4964 return streamStatus(s);
4965 }
4966
4967 return FALSE;
4968 }
4969
4970 static
4971 PRED_IMPL("flush_output", 0, flush_output, PL_FA_ISO)
4972 { PRED_LD
4973
4974 return flush_output(0 PASS_LD);
4975 }
4976
4977 static
4978 PRED_IMPL("flush_output", 1, flush_output1, PL_FA_ISO)
4979 { PRED_LD
4980
4981 return flush_output(A1 PASS_LD);
4982 }
4983
4984
4985 static int
getStreamWithPosition(term_t stream,IOSTREAM ** sp)4986 getStreamWithPosition(term_t stream, IOSTREAM **sp)
4987 { IOSTREAM *s;
4988
4989 if ( PL_get_stream(stream, &s, 0) )
4990 { if ( !s->position )
4991 { PL_error(NULL, 0, NULL, ERR_PERMISSION, /* non-ISO */
4992 ATOM_property, ATOM_position, stream);
4993 releaseStream(s);
4994 return FALSE;
4995 }
4996
4997 *sp = s;
4998 return TRUE;
4999 }
5000
5001 return FALSE;
5002 }
5003
5004
5005 static int
getRepositionableStream(term_t stream,IOSTREAM ** sp)5006 getRepositionableStream(term_t stream, IOSTREAM **sp)
5007 { GET_LD
5008 IOSTREAM *s;
5009 atom_t a;
5010
5011 if ( !PL_get_atom(stream, &a) )
5012 return not_a_stream(stream);
5013
5014 if ( get_stream_handle(a, &s, SH_ERRORS) )
5015 { if ( !s->position || !s->functions || !s->functions->seek )
5016 { PL_error(NULL, 0, NULL, ERR_PERMISSION,
5017 ATOM_reposition, ATOM_stream, stream);
5018 releaseStream(s);
5019 return FALSE;
5020 }
5021
5022 *sp = s;
5023 return TRUE;
5024 }
5025
5026 return FALSE;
5027 }
5028
5029
5030 static
5031 PRED_IMPL("set_stream_position", 2, set_stream_position, PL_FA_ISO)
5032 { PRED_LD
5033 IOSTREAM *s = NULL; /* make compiler happy */
5034 int64_t charno, byteno;
5035 long linepos, lineno;
5036 term_t a = PL_new_term_ref();
5037
5038 term_t stream = A1;
5039 term_t pos = A2;
5040
5041 if ( !(getRepositionableStream(stream, &s)) )
5042 return FALSE;
5043
5044 if ( !PL_is_functor(pos, FUNCTOR_dstream_position4) ||
5045 !PL_get_arg(1, pos, a) ||
5046 !PL_get_int64(a, &charno) ||
5047 !PL_get_arg(2, pos, a) ||
5048 !PL_get_long(a, &lineno) ||
5049 !PL_get_arg(3, pos, a) ||
5050 !PL_get_long(a, &linepos) ||
5051 !PL_get_arg(4, pos, a) ||
5052 !PL_get_int64(a, &byteno) )
5053 { releaseStream(s);
5054 return PL_error("stream_position", 3, NULL,
5055 ERR_DOMAIN, ATOM_stream_position, pos);
5056 }
5057
5058 if ( Sseek64(s, byteno, SIO_SEEK_SET) != 0 )
5059 return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
5060 ATOM_reposition, ATOM_stream, stream);
5061
5062 s->position->byteno = byteno;
5063 s->position->charno = charno;
5064 s->position->lineno = (int)lineno;
5065 s->position->linepos = (int)linepos;
5066
5067 releaseStream(s);
5068
5069 return TRUE;
5070 }
5071
5072
5073 static
5074 PRED_IMPL("seek", 4, seek, 0)
5075 { PRED_LD
5076 atom_t m;
5077 int whence = -1;
5078 int64_t off, new;
5079 IOSTREAM *s;
5080
5081 term_t stream = A1;
5082 term_t offset = A2;
5083 term_t method = A3;
5084 term_t newloc = A4;
5085
5086 if ( !(PL_get_atom_ex(method, &m)) )
5087 return FALSE;
5088
5089 if ( m == ATOM_bof )
5090 whence = SIO_SEEK_SET;
5091 else if ( m == ATOM_current )
5092 whence = SIO_SEEK_CUR;
5093 else if ( m == ATOM_eof )
5094 whence = SIO_SEEK_END;
5095 else
5096 return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_seek_method, method);
5097
5098 if ( !PL_get_int64(offset, &off) )
5099 return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_integer, offset);
5100
5101 if ( PL_get_stream_handle(stream, &s) )
5102 { int unit = Sunit_size(s);
5103
5104 off *= unit;
5105 if ( Sseek64(s, off, whence) < 0 )
5106 { if ( errno == EINVAL )
5107 PL_error("seek", 4, "offset out of range", ERR_DOMAIN,
5108 ATOM_position, offset);
5109 else
5110 PL_error("seek", 4, OsError(), ERR_PERMISSION,
5111 ATOM_reposition, ATOM_stream, stream);
5112 Sclearerr(s);
5113 releaseStream(s);
5114 return FALSE;
5115 }
5116
5117 new = Stell64(s);
5118 releaseStream(s);
5119 new /= unit;
5120
5121 return PL_unify_int64(newloc, new);
5122 }
5123
5124 return FALSE;
5125 }
5126
5127
5128 static
5129 PRED_IMPL("set_input", 1, set_input, PL_FA_ISO)
5130 { PRED_LD
5131 IOSTREAM *s;
5132
5133 if ( getInputStream(A1, S_DONTCARE, &s) )
5134 { Scurin = s;
5135 releaseStream(s);
5136 return TRUE;
5137 }
5138
5139 return FALSE;
5140 }
5141
5142
5143 static
5144 PRED_IMPL("set_output", 1, set_output, PL_FA_ISO)
5145 { PRED_LD
5146 IOSTREAM *s;
5147
5148 if ( getOutputStream(A1, S_DONTCARE, &s) )
5149 { Scurout = s;
5150 releaseStream(s);
5151 return TRUE;
5152 }
5153
5154 return FALSE;
5155 }
5156
5157
5158 static int
current_io(term_t t,IOSTREAM * cur ARG_LD)5159 current_io(term_t t, IOSTREAM *cur ARG_LD)
5160 { if ( PL_is_variable(t) )
5161 { return PL_unify_stream(t, cur);
5162 } else
5163 { IOSTREAM *s;
5164
5165 if ( term_stream_handle(t, &s, SH_ERRORS|SH_ALIAS|SH_UNLOCKED PASS_LD) )
5166 return s == cur;
5167 return FALSE;
5168 }
5169 }
5170
5171 static
5172 PRED_IMPL("current_input", 1, current_input, PL_FA_ISO)
5173 { PRED_LD
5174 return current_io(A1, Scurin PASS_LD);
5175 }
5176
5177
5178 static
5179 PRED_IMPL("current_output", 1, current_output, PL_FA_ISO)
5180 { PRED_LD
5181 return current_io(A1, Scurout PASS_LD);
5182 }
5183
5184
5185 static
5186 PRED_IMPL("byte_count", 2, byte_count, 0)
5187 { PRED_LD
5188 IOSTREAM *s;
5189
5190 if ( getStreamWithPosition(A1, &s) )
5191 { int64_t n = s->position->byteno;
5192
5193 releaseStream(s);
5194 return PL_unify_int64(A2, n);
5195 }
5196
5197 return FALSE;
5198 }
5199
5200
5201 static
5202 PRED_IMPL("character_count", 2, character_count, 0)
5203 { PRED_LD
5204 IOSTREAM *s;
5205
5206 if ( getStreamWithPosition(A1, &s) )
5207 { int64_t n = s->position->charno;
5208
5209 releaseStream(s);
5210 return PL_unify_int64(A2, n);
5211 }
5212
5213 return FALSE;
5214 }
5215
5216
5217 static
5218 PRED_IMPL("line_count", 2, line_count, 0)
5219 { GET_LD
5220 IOSTREAM *s;
5221
5222 if ( getStreamWithPosition(A1, &s) )
5223 { intptr_t n = s->position->lineno;
5224
5225 releaseStream(s);
5226 return PL_unify_integer(A2, n);
5227 }
5228
5229 return FALSE;
5230 }
5231
5232
5233 static
5234 PRED_IMPL("line_position", 2, line_position, 0)
5235 { GET_LD
5236 IOSTREAM *s;
5237
5238 if ( getStreamWithPosition(A1, &s) )
5239 { intptr_t n = s->position->linepos;
5240
5241 releaseStream(s);
5242 return PL_unify_integer(A2, n);
5243 }
5244
5245 return FALSE;
5246 }
5247
5248
5249 static
5250 PRED_IMPL("source_location", 2, source_location, 0)
5251 { PRED_LD
5252 if ( ReadingSource &&
5253 PL_unify_atom(A1, source_file_name) &&
5254 PL_unify_integer(A2, source_line_no) )
5255 return TRUE;
5256
5257 return FALSE;
5258 }
5259
5260
5261 static
5262 PRED_IMPL("$set_source_location", 2, set_source_location, 0)
5263 { PRED_LD
5264 return ( PL_get_atom_ex(A1, &source_file_name) &&
5265 PL_get_integer_ex(A2, &source_line_no) );
5266 }
5267
5268
5269 static int
at_end_of_stream(term_t stream ARG_LD)5270 at_end_of_stream(term_t stream ARG_LD)
5271 { IOSTREAM *s;
5272
5273 if ( getInputStream(stream, S_DONTCARE, &s) )
5274 { int rval = Sfeof(s);
5275
5276 if ( rval < 0 )
5277 { PL_error(NULL, 0, "not-buffered stream", ERR_PERMISSION,
5278 ATOM_end_of_stream, ATOM_stream, stream);
5279 rval = FALSE;
5280 }
5281
5282 if ( rval && Sferror(s) ) /* due to error */
5283 return streamStatus(s);
5284 else
5285 releaseStream(s);
5286
5287 return rval;
5288 }
5289
5290 return FALSE; /* exception */
5291 }
5292
5293 static
5294 PRED_IMPL("at_end_of_stream", 1, at_end_of_stream, PL_FA_ISO)
5295 { PRED_LD
5296 return at_end_of_stream(A1 PASS_LD);
5297 }
5298
5299 static
5300 PRED_IMPL("at_end_of_stream", 0, at_end_of_stream0, PL_FA_ISO)
5301 { PRED_LD
5302 return at_end_of_stream(0 PASS_LD);
5303 }
5304
5305
5306 /** fill_buffer(+Stream)
5307 *
5308 * Fill the buffer of Stream.
5309 */
5310
5311 static
5312 PRED_IMPL("fill_buffer", 1, fill_buffer, 0)
5313 { PRED_LD
5314 IOSTREAM *s;
5315
5316 term_t stream = A1;
5317
5318 if ( getInputStream(stream, S_DONTCARE, &s) )
5319 { if ( (s->flags & SIO_NBUF) )
5320 { return ( PL_release_stream(s) &&
5321 PL_permission_error("fill_buffer", "stream", stream) );
5322 }
5323
5324 if ( !(s->flags & SIO_FEOF) )
5325 { if ( S__fillbuf(s) < 0 )
5326 return PL_release_stream(s);
5327
5328 s->bufp--;
5329 }
5330 return PL_release_stream(s);
5331 }
5332
5333 return FALSE;
5334 }
5335
5336
5337 static foreign_t
peek(term_t stream,term_t chr,int how ARG_LD)5338 peek(term_t stream, term_t chr, int how ARG_LD)
5339 { IOSTREAM *s;
5340 int c;
5341
5342 if ( !getInputStream(stream, how == PL_BYTE ? S_BINARY : S_TEXT, &s) )
5343 return FALSE;
5344 if ( true(s, SIO_NBUF) || (s->bufsize && s->bufsize < PL_MB_LEN_MAX) )
5345 { releaseStream(s);
5346 return PL_error(NULL, 0, "stream is unbuffered", ERR_PERMISSION,
5347 ATOM_peek, ATOM_stream, stream);
5348 }
5349
5350 if ( how == PL_BYTE )
5351 { IOPOS pos = s->posbuf;
5352
5353 c = Sgetc(s);
5354 if ( c != EOF )
5355 Sungetc(c, s);
5356 s->posbuf = pos;
5357 } else
5358 { c = Speekcode(s);
5359 }
5360 if ( Sferror(s) )
5361 return streamStatus(s);
5362 releaseStream(s);
5363
5364 return PL_unify_char(chr, c, how);
5365 }
5366
5367
5368 static
5369 PRED_IMPL("peek_byte", 2, peek_byte2, 0)
5370 { PRED_LD
5371 return peek(A1, A2, PL_BYTE PASS_LD);
5372 }
5373
5374
5375 static
5376 PRED_IMPL("peek_byte", 1, peek_byte1, 0)
5377 { PRED_LD
5378 return peek(0, A1, PL_BYTE PASS_LD);
5379 }
5380
5381
5382 static
5383 PRED_IMPL("peek_code", 2, peek_code2, 0)
5384 { PRED_LD
5385 return peek(A1, A2, PL_CODE PASS_LD);
5386 }
5387
5388
5389 static
5390 PRED_IMPL("peek_code", 1, peek_code1, 0)
5391 { PRED_LD
5392 return peek(0, A1, PL_CODE PASS_LD);
5393 }
5394
5395
5396 static
5397 PRED_IMPL("peek_char", 2, peek_char2, 0)
5398 { PRED_LD
5399 return peek(A1, A2, PL_CHAR PASS_LD);
5400 }
5401
5402
5403 static
5404 PRED_IMPL("peek_char", 1, peek_char1, 0)
5405 { PRED_LD
5406 return peek(0, A1, PL_CHAR PASS_LD);
5407 }
5408
5409
5410 /*******************************
5411 * INTERACTION *
5412 *******************************/
5413
5414 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5415 set_prolog_IO(+In, +Out, +Error)
5416 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5417
5418 #define WRAP_CLEAR_FLAGS (SIO_FILE)
5419
5420 typedef struct wrappedIO
5421 { void *wrapped_handle; /* original handle */
5422 IOFUNCTIONS *wrapped_functions; /* original functions */
5423 IOSTREAM *wrapped_stream; /* stream we wrapped */
5424 IOFUNCTIONS functions; /* new function block */
5425 int saved_flags; /* SIO_flags we must restore */
5426 } wrappedIO;
5427
5428
5429 ssize_t
Sread_user(void * handle,char * buf,size_t size)5430 Sread_user(void *handle, char *buf, size_t size)
5431 { GET_LD
5432 wrappedIO *wio = handle;
5433 ssize_t rc;
5434
5435 if ( LD->prompt.next && Sttymode(wio->wrapped_stream) != TTY_RAW )
5436 PL_write_prompt(TRUE);
5437 else
5438 Sflush(Suser_output);
5439
5440 rc = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size);
5441 if ( rc == 0 ) /* end-of-file */
5442 { Sclearerr(Suser_input);
5443 LD->prompt.next = TRUE;
5444 } else if ( rc == 1 && buf[0] == 04 )
5445 { rc = 0; /* Map ^D to end-of-file */
5446 } else if ( rc > 0 && buf[rc-1] == '\n' )
5447 LD->prompt.next = TRUE;
5448
5449 return rc;
5450 }
5451
5452
5453 static int
closeWrappedIO(void * handle)5454 closeWrappedIO(void *handle)
5455 { wrappedIO *wio = handle;
5456 int rval;
5457
5458 if ( wio->wrapped_functions->close )
5459 rval = (*wio->wrapped_functions->close)(wio->wrapped_handle);
5460 else
5461 rval = 0;
5462
5463 wio->wrapped_stream->functions = wio->wrapped_functions;
5464 wio->wrapped_stream->handle = wio->wrapped_handle;
5465 clear(wio->wrapped_stream, WRAP_CLEAR_FLAGS);
5466 set(wio->wrapped_stream, wio->saved_flags);
5467 PL_free(wio);
5468
5469 return rval;
5470 }
5471
5472
5473 static int
controlWrappedIO(void * handle,int action,void * arg)5474 controlWrappedIO(void *handle, int action, void *arg)
5475 { wrappedIO *wio = handle;
5476 int rval;
5477
5478 if ( wio->wrapped_functions->control )
5479 rval = (*wio->wrapped_functions->control)(wio->wrapped_handle,
5480 action,
5481 arg);
5482 else
5483 rval = 0;
5484
5485 return rval;
5486 }
5487
5488
5489 static void
wrapIO(IOSTREAM * s,ssize_t (* read)(void *,char *,size_t),ssize_t (* write)(void *,char *,size_t))5490 wrapIO(IOSTREAM *s,
5491 ssize_t (*read)(void *, char *, size_t),
5492 ssize_t (*write)(void *, char *, size_t))
5493 { wrappedIO *wio = PL_malloc(sizeof(*wio));
5494
5495 wio->wrapped_functions = s->functions;
5496 wio->wrapped_handle = s->handle;
5497 wio->wrapped_stream = s;
5498 wio->saved_flags = s->flags & WRAP_CLEAR_FLAGS;
5499 clear(s, WRAP_CLEAR_FLAGS);
5500
5501 wio->functions = *s->functions;
5502 if ( read ) wio->functions.read = read;
5503 if ( write ) wio->functions.write = write;
5504 wio->functions.close = closeWrappedIO;
5505 wio->functions.control = controlWrappedIO;
5506
5507 s->functions = &wio->functions;
5508 s->handle = wio;
5509 }
5510
5511
5512 static int
getIOStreams(term_t tin,term_t tout,term_t terror,IOSTREAM ** in,IOSTREAM ** out,IOSTREAM ** error)5513 getIOStreams(term_t tin, term_t tout, term_t terror,
5514 IOSTREAM **in, IOSTREAM **out, IOSTREAM **error)
5515 {
5516 if ( !PL_get_stream(tin, in, SIO_INPUT) )
5517 return FALSE;
5518
5519 if ( !PL_get_stream(tout, out, SIO_OUTPUT) )
5520 return FALSE;
5521
5522 if ( PL_compare(tout, terror) == 0 ) /* == */
5523 { *error = getStream(Snew((*out)->handle, (*out)->flags, (*out)->functions));
5524 if ( !*error )
5525 return FALSE;
5526 } else
5527 { if ( !PL_get_stream(terror, error, SIO_OUTPUT) )
5528 return FALSE;
5529 }
5530
5531 (*out)->flags &= ~SIO_ABUF; /* output: line buffered */
5532 (*out)->flags |= SIO_LBUF;
5533
5534 (*error)->flags &= ~SIO_ABUF; /* disable buffering */
5535 (*error)->flags |= SIO_NBUF;
5536
5537 return TRUE;
5538 }
5539
5540
5541 static
5542 PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
5543 { PRED_LD
5544 IOSTREAM *in = NULL, *out = NULL, *error = NULL;
5545 int rval = FALSE;
5546 int wrapin = FALSE;
5547 int i;
5548
5549 if ( !getIOStreams(A1, A2, A3, &in, &out, &error) )
5550 goto out;
5551
5552 wrapin = (LD->IO.streams[0] != in);
5553
5554 PL_LOCK(L_FILE);
5555
5556 LD->IO.streams[1] = out; /* user_output */
5557 LD->IO.streams[2] = error; /* user_error */
5558 LD->IO.streams[4] = out; /* current_output */
5559
5560 if ( wrapin )
5561 { LD->IO.streams[3] = in; /* current_input */
5562 LD->IO.streams[0] = in; /* user_input */
5563 wrapIO(in, Sread_user, NULL);
5564 LD->prompt.next = TRUE;
5565 }
5566
5567 for(i=0; i<3; i++)
5568 { LD->IO.streams[i]->position = &LD->IO.streams[0]->posbuf;
5569 LD->IO.streams[i]->flags |= SIO_RECORDPOS;
5570 }
5571
5572 PL_UNLOCK(L_FILE);
5573 rval = TRUE;
5574
5575 out:
5576 if ( in )
5577 releaseStream(in);
5578 if ( out )
5579 releaseStream(out);
5580 if ( error && error != out )
5581 releaseStream(error);
5582
5583 return rval;
5584 }
5585
5586
5587 static int
sys_io_stream(IOSTREAM * s,IOSTREAM * ref,term_t t)5588 sys_io_stream(IOSTREAM *s, IOSTREAM *ref, term_t t)
5589 { int fd = Sfileno(s);
5590
5591 if ( s != ref && fd < 0 )
5592 return PL_domain_error("file_stream", t),-1;
5593
5594 return fd;
5595 }
5596
5597 static
5598 PRED_IMPL("set_system_IO", 3, set_system_IO, 0)
5599 { IOSTREAM *in = NULL, *out = NULL, *error = NULL;
5600 int fd_in, fd_out, fd_error;
5601 int rval = FALSE;
5602
5603 if ( !getIOStreams(A1, A2, A3, &in, &out, &error) )
5604 goto out;
5605
5606 if ( (fd_in = sys_io_stream(in, Sinput, A1)) < 0 ||
5607 (fd_out = sys_io_stream(out, Soutput, A2)) < 0 ||
5608 (fd_error = sys_io_stream(error, Serror, A3)) < 0 )
5609 goto out;
5610
5611 PL_LOCK(L_FILE);
5612 if ( in != Sinput )
5613 dup2(fd_in, 0); /* stdin */
5614 if ( out != Soutput )
5615 dup2(fd_out, 1); /* stdout */
5616 if ( error != Serror )
5617 dup2(fd_error, 2); /* stderr */
5618 PL_UNLOCK(L_FILE);
5619 rval = TRUE;
5620
5621 out:
5622 if ( in )
5623 releaseStream(in);
5624 if ( out )
5625 releaseStream(out);
5626 if ( error && error != out )
5627 releaseStream(error);
5628
5629 return rval;
5630 }
5631
5632
5633 static
5634 PRED_IMPL("$size_stream", 2, size_stream, 0)
5635 { GET_LD
5636 IOSTREAM *s;
5637 int64_t sz;
5638
5639 if ( !PL_get_stream_handle(A1, &s) )
5640 return FALSE;
5641 sz = Ssize(s);
5642 if ( !PL_release_stream(s) )
5643 return FALSE;
5644
5645 if ( sz >= 0 )
5646 return PL_unify_int64(A2, sz);
5647
5648 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
5649 ATOM_reposition, ATOM_stream, A1);
5650 }
5651
5652
5653 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5654 copy_stream_data(+StreamIn, +StreamOut, [Len])
5655 Copy all data from StreamIn to StreamOut. Should be somewhere else,
5656 and maybe we need something else to copy resources.
5657 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5658
5659 static int
copy_stream_data(term_t in,term_t out,term_t len ARG_LD)5660 copy_stream_data(term_t in, term_t out, term_t len ARG_LD)
5661 { IOSTREAM *i, *o;
5662 int c, rc;
5663 int count = 0;
5664
5665 if ( !getInputStream(in, S_DONTCARE, &i) )
5666 return FALSE;
5667 if ( !getOutputStream(out, S_DONTCARE, &o) )
5668 { releaseStream(i);
5669 return FALSE;
5670 }
5671
5672 if ( !len )
5673 { while ( (c = Sgetcode(i)) != EOF )
5674 { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
5675 { releaseStream(i);
5676 releaseStream(o);
5677 return FALSE;
5678 }
5679 if ( Sputcode(c, o) < 0 )
5680 { releaseStream(i);
5681 return streamStatus(o);
5682 }
5683 }
5684 } else
5685 { int64_t n;
5686
5687 if ( !PL_get_int64_ex(len, &n) )
5688 return FALSE;
5689
5690 while ( n-- > 0 && (c = Sgetcode(i)) != EOF )
5691 { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
5692 { releaseStream(i);
5693 releaseStream(o);
5694 return FALSE;
5695 }
5696 if ( Sputcode(c, o) < 0 )
5697 break;
5698 }
5699 }
5700
5701 rc = streamStatus(o);
5702 rc = streamStatus(i) && rc;
5703
5704 return rc;
5705 }
5706
5707 static
5708 PRED_IMPL("copy_stream_data", 3, copy_stream_data3, 0)
5709 { PRED_LD
5710 return copy_stream_data(A1, A2, A3 PASS_LD);
5711 }
5712
5713 static
5714 PRED_IMPL("copy_stream_data", 2, copy_stream_data2, 0)
5715 { PRED_LD
5716 return copy_stream_data(A1, A2, 0 PASS_LD);
5717 }
5718
5719
5720 /*******************************
5721 * PUBLISH PREDICATES *
5722 *******************************/
5723
5724 BeginPredDefs(file)
5725 /* ISO IO */
5726 PRED_DEF("open", 4, open4, PL_FA_ISO)
5727 PRED_DEF("open", 3, open3, PL_FA_ISO)
5728 PRED_DEF("close", 1, close, PL_FA_ISO)
5729 PRED_DEF("close", 2, close2, PL_FA_ISO)
5730 PRED_DEF("set_input", 1, set_input, PL_FA_ISO)
5731 PRED_DEF("set_output", 1, set_output, PL_FA_ISO)
5732 PRED_DEF("current_input", 1, current_input, PL_FA_ISO)
5733 PRED_DEF("current_output", 1, current_output, PL_FA_ISO)
5734 PRED_DEF("get_code", 2, get_code2, PL_FA_ISO)
5735 PRED_DEF("get_code", 1, get_code1, PL_FA_ISO)
5736 PRED_DEF("get_char", 2, get_char2, PL_FA_ISO)
5737 PRED_DEF("get_char", 1, get_char1, PL_FA_ISO)
5738 PRED_DEF("get_byte", 2, get_byte2, PL_FA_ISO)
5739 PRED_DEF("get_byte", 1, get_byte1, PL_FA_ISO)
5740 PRED_DEF("peek_code", 2, peek_code2, PL_FA_ISO)
5741 PRED_DEF("peek_code", 1, peek_code1, PL_FA_ISO)
5742 PRED_DEF("peek_char", 2, peek_char2, PL_FA_ISO)
5743 PRED_DEF("peek_char", 1, peek_char1, PL_FA_ISO)
5744 PRED_DEF("peek_byte", 2, peek_byte2, PL_FA_ISO)
5745 PRED_DEF("peek_byte", 1, peek_byte1, PL_FA_ISO)
5746 PRED_DEF("peek_string", 3, peek_string, 0)
5747 PRED_DEF("put_byte", 2, put_byte2, PL_FA_ISO)
5748 PRED_DEF("put_byte", 1, put_byte1, PL_FA_ISO)
5749 PRED_DEF("put_code", 2, put_code2, PL_FA_ISO)
5750 PRED_DEF("put_code", 1, put_code1, PL_FA_ISO)
5751 PRED_DEF("put_char", 2, put_code2, PL_FA_ISO)
5752 PRED_DEF("put_char", 1, put_code1, PL_FA_ISO)
5753 PRED_DEF("flush_output", 0, flush_output, PL_FA_ISO)
5754 PRED_DEF("flush_output", 1, flush_output1, PL_FA_ISO)
5755 PRED_DEF("at_end_of_stream", 1, at_end_of_stream, PL_FA_ISO)
5756 PRED_DEF("at_end_of_stream", 0, at_end_of_stream0, PL_FA_ISO)
5757 PRED_DEF("fill_buffer", 1, fill_buffer, 0)
5758 PRED_DEF("set_stream_position", 2, set_stream_position, PL_FA_ISO)
5759 PRED_DEF("$stream_property", 2, dstream_property, 0)
5760 PRED_DEF("$stream_properties", 2, dstream_properties, 0)
5761 PRED_DEF("$streams_properties", 2, dstreams_properties, 0)
5762 PRED_DEF("$alias_stream", 2, dalias_stream, 0)
5763
5764 /* edinburgh IO */
5765 PRED_DEF("see", 1, see, 0)
5766 PRED_DEF("seen", 0, seen, 0)
5767 PRED_DEF("seeing", 1, seeing, 0)
5768 PRED_DEF("tell", 1, tell, 0)
5769 PRED_DEF("append", 1, append, 0)
5770 PRED_DEF("told", 0, told, 0)
5771 PRED_DEF("telling", 1, telling, 0)
5772 PRED_DEF("put", 2, put2, 0)
5773 PRED_DEF("put", 1, put1, 0)
5774 PRED_DEF("skip", 1, skip1, 0)
5775 PRED_DEF("skip", 2, skip2, 0)
5776 PRED_DEF("get", 1, get1, 0)
5777 PRED_DEF("get", 2, get2, 0)
5778 PRED_DEF("get0", 2, get_code2, 0)
5779 PRED_DEF("get0", 1, get_code1, 0)
5780 PRED_DEF("ttyflush", 0, ttyflush, 0)
5781 PRED_DEF("prompt", 2, prompt, 0)
5782 PRED_DEF("tab", 2, tab2, 0)
5783 PRED_DEF("tab", 1, tab1, 0)
5784 /* Quintus IO */
5785 PRED_DEF("byte_count", 2, byte_count, 0)
5786 PRED_DEF("character_count", 2, character_count, 0)
5787 PRED_DEF("line_count", 2, line_count, 0)
5788 PRED_DEF("line_position", 2, line_position, 0)
5789 PRED_DEF("open_null_stream", 1, open_null_stream, 0)
5790
5791 /* SWI specific */
5792 PRED_DEF("is_stream", 1, is_stream, 0)
5793 PRED_DEF("set_stream", 2, set_stream, 0)
5794 PRED_DEF("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
5795 PRED_DEF("set_prolog_IO", 3, set_prolog_IO, 0)
5796 PRED_DEF("set_system_IO", 3, set_system_IO, 0)
5797 PRED_DEF("protocol", 1, protocol, 0)
5798 PRED_DEF("protocola", 1, protocola, 0)
5799 PRED_DEF("noprotocol", 0, noprotocol, 0)
5800 PRED_DEF("protocolling", 1, protocolling, 0)
5801 PRED_DEF("prompt1", 1, prompt1, 0)
5802 PRED_DEF("seek", 4, seek, 0)
5803 #ifdef HAVE_PRED_WAIT_FOR_INPUT
5804 PRED_DEF("wait_for_input", 3, wait_for_input, 0)
5805 #endif
5806 PRED_DEF("get_single_char", 1, get_single_char, 0)
5807 PRED_DEF("read_pending_codes", 3, read_pending_codes, 0)
5808 PRED_DEF("read_pending_chars", 3, read_pending_chars, 0)
5809 PRED_DEF("source_location", 2, source_location, 0)
5810 PRED_DEF("$set_source_location", 2, set_source_location, 0)
5811 PRED_DEF("copy_stream_data", 3, copy_stream_data3, 0)
5812 PRED_DEF("copy_stream_data", 2, copy_stream_data2, 0)
5813 PRED_DEF("stream_pair", 3, stream_pair, 0)
5814 PRED_DEF("set_end_of_stream", 1, set_end_of_stream, 0)
5815
5816 /* SWI internal */
5817 PRED_DEF("$push_input_context", 1, push_input_context, 0)
5818 PRED_DEF("$pop_input_context", 0, pop_input_context, 0)
5819 PRED_DEF("$input_context", 1, input_context, 0)
5820 PRED_DEF("$size_stream", 2, size_stream, 0)
5821 PRED_DEF("with_tty_raw", 1, with_tty_raw, PL_FA_TRANSPARENT)
5822 EndPredDefs
5823