/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This module is far too big. It defines a layer around open(), etc. to
get opening and closing of files to the symbolic level required for
Prolog. It also defines basic I/O predicates, stream based I/O and
finally a bundle of operations on files, such as name expansion,
renaming, deleting, etc. Most of this module is rather straightforward.
If time is there I will have a look at all this to clean it. Notably
handling times must be cleaned, but that not only holds for this module.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*#define O_DEBUG 1*/
/*#define O_DEBUG_MT 1*/
#define EXPERIMENT 1
#include "pl-incl.h"
#include "pl-ctype.h"
#include "pl-utf8.h"
#include <errno.h>
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#ifdef HAVE_SYS_PARAM_H
#include <sys/param.h>
#endif
#ifdef HAVE_SYS_FILE_H
#include <sys/file.h>
#endif
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#ifdef HAVE_SYS_FILE_H
#include <sys/file.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_BSTRING_H
#include <bstring.h>
#endif
#define LOCK() PL_LOCK(L_FILE) /* MT locking */
#define UNLOCK() PL_UNLOCK(L_FILE)
static int bad_encoding(atom_t name);
static bool streamStatus(IOSTREAM *s);
INIT_DEF(atom_t, standardStreams, 6)
ADD_STDSTREAM(ATOM_user_input) /* 0 */
ADD_STDSTREAM(ATOM_user_output) /* 1 */
ADD_STDSTREAM(ATOM_user_error) /* 2 */
ADD_STDSTREAM(ATOM_current_input) /* 3 */
ADD_STDSTREAM(ATOM_current_output) /* 4 */
ADD_STDSTREAM(ATOM_protocol) /* 5 */
END_STDSTREAMS(NULL_ATOM)
static int
standardStreamIndexFromName(atom_t name)
{ const atom_t *ap;
for(ap=standardStreams; *ap; ap++)
{ if ( *ap == name )
return (int)(ap - standardStreams);
}
return -1;
}
static int
standardStreamIndexFromStream(IOSTREAM *s)
{ GET_LD
IOSTREAM **sp = LD->IO.streams;
int i = 0;
for( ; i<6; i++, sp++ )
{ if ( *sp == s )
return i;
}
return -1;
}
/*******************************
* BOOKKEEPING *
*******************************/
static void aliasStream(IOSTREAM *s, atom_t alias);
static void unaliasStream(IOSTREAM *s, atom_t name);
static Table streamAliases; /* alias --> stream */
static Table streamContext; /* stream --> extra data */
typedef struct _alias
{ struct _alias *next;
atom_t name;
} alias;
#define IO_TELL 0x001 /* opened by tell/1 */
#define IO_SEE 0x002 /* opened by see/1 */
typedef struct
{ alias *alias_head;
alias *alias_tail;
atom_t filename; /* associated filename */
unsigned flags;
} stream_context;
static stream_context *
getStreamContext(IOSTREAM *s)
{ Symbol symb;
if ( !(symb = lookupHTable(streamContext, s)) )
{ GET_LD
stream_context *ctx = allocHeap(sizeof(*ctx));
DEBUG(1, Sdprintf("Created ctx=%p for stream %p\n", ctx, s));
ctx->alias_head = ctx->alias_tail = NULL;
ctx->filename = NULL_ATOM;
ctx->flags = 0;
addHTable(streamContext, s, ctx);
return ctx;
}
return symb->value;
}
void
aliasStream(IOSTREAM *s, atom_t name)
{ GET_LD
stream_context *ctx;
Symbol symb;
alias *a;
/* ensure name is free (error?) */
if ( (symb = lookupHTable(streamAliases, (void *)name)) )
unaliasStream(symb->value, name);
ctx = getStreamContext(s);
addHTable(streamAliases, (void *)name, s);
PL_register_atom(name);
a = allocHeap(sizeof(*a));
a->next = NULL;
a->name = name;
if ( ctx->alias_tail )
{ ctx->alias_tail->next = a;
ctx->alias_tail = a;
} else
{ ctx->alias_head = ctx->alias_tail = a;
}
}
/* MT: Locked by freeStream()
*/
static void
unaliasStream(IOSTREAM *s, atom_t name)
{ GET_LD
Symbol symb;
if ( name )
{ if ( (symb = lookupHTable(streamAliases, (void *)name)) )
{ deleteSymbolHTable(streamAliases, symb);
if ( (symb=lookupHTable(streamContext, s)) )
{ stream_context *ctx = symb->value;
alias **a;
for(a = &ctx->alias_head; *a; a = &(*a)->next)
{ if ( (*a)->name == name )
{ alias *tmp = *a;
*a = tmp->next;
freeHeap(tmp, sizeof(*tmp));
if ( tmp == ctx->alias_tail )
ctx->alias_tail = NULL;
break;
}
}
}
PL_unregister_atom(name);
}
} else /* delete them all */
{ if ( (symb=lookupHTable(streamContext, s)) )
{ stream_context *ctx = symb->value;
alias *a, *n;
for(a = ctx->alias_head; a; a=n)
{ Symbol s2;
n = a->next;
if ( (s2 = lookupHTable(streamAliases, (void *)a->name)) )
{ deleteSymbolHTable(streamAliases, s2);
PL_unregister_atom(a->name);
}
freeHeap(a, sizeof(*a));
}
ctx->alias_head = ctx->alias_tail = NULL;
}
}
}
static void
freeStream(IOSTREAM *s)
{ GET_LD
Symbol symb;
int i;
IOSTREAM **sp;
DEBUG(1, Sdprintf("freeStream(%p)\n", s));
LOCK();
unaliasStream(s, NULL_ATOM);
if ( (symb=lookupHTable(streamContext, s)) )
{ stream_context *ctx = symb->value;
if ( ctx->filename == source_file_name )
{ source_file_name = NULL_ATOM; /* TBD: pop? */
source_line_no = -1;
}
freeHeap(ctx, sizeof(*ctx));
deleteSymbolHTable(streamContext, symb);
}
/* if we are a standard stream */
/* reassociate with standard I/O */
/* NOTE: there may be more! */
for(i=0, sp = LD->IO.streams; i<6; i++, sp++)
{ if ( *sp == s )
{ if ( s->flags & SIO_INPUT )
*sp = Sinput;
else if ( sp == &Suser_error )
*sp = Serror;
else if ( sp == &Sprotocol )
*sp = NULL;
else
*sp = Soutput;
}
}
UNLOCK();
}
/* MT: locked by caller (openStream()) */
static void
setFileNameStream(IOSTREAM *s, atom_t name)
{ getStreamContext(s)->filename = name;
}
static atom_t
fileNameStream(IOSTREAM *s)
{ atom_t name;
LOCK();
name = getStreamContext(s)->filename;
UNLOCK();
return name;
}
/*******************************
* GET HANDLES *
*******************************/
#ifdef O_PLMT
static inline IOSTREAM *
getStream(IOSTREAM *s)
{ if ( s && s->magic == SIO_MAGIC ) /* TBD: ensure visibility? */
{ Slock(s);
return s;
}
return NULL;
}
static inline IOSTREAM *
tryGetStream(IOSTREAM *s)
{ if ( s && s->magic == SIO_MAGIC && StryLock(s) == 0 )
return s;
return NULL;
}
static inline void
releaseStream(IOSTREAM *s)
{ if ( s->magic == SIO_MAGIC )
Sunlock(s);
}
#else /*O_PLMT*/
#define getStream(s) (s)
#define tryGetStream(s) (s)
#define releaseStream(s)
#endif /*O_PLMT*/
int
PL_release_stream(IOSTREAM *s)
{ if ( Sferror(s) )
return streamStatus(s);
releaseStream(s);
return TRUE;
}
#define SH_ERRORS 0x01 /* generate errors */
#define SH_ALIAS 0x02 /* allow alias */
#define SH_UNLOCKED 0x04 /* don't lock the stream */
#define SH_SAFE 0x08 /* Lookup in table */
static int
get_stream_handle__LD(term_t t, IOSTREAM **s, int flags ARG_LD)
{ atom_t alias;
if ( PL_is_functor(t, FUNCTOR_dstream1) )
{ void *p;
term_t a = PL_new_term_ref();
_PL_get_arg(1, t, a);
if ( PL_get_pointer(a, &p) )
{ if ( flags & SH_SAFE )
{ Symbol symb;
LOCK();
symb = lookupHTable(streamContext, p);
UNLOCK();
if ( !symb )
goto noent;
}
if ( flags & SH_UNLOCKED )
{ if ( ((IOSTREAM *)p)->magic == SIO_MAGIC )
{ *s = p;
return TRUE;
}
goto noent;
}
if ( (*s = getStream(p)) )
return TRUE;
goto noent;
}
} else if ( PL_get_atom(t, &alias) )
{ Symbol symb;
if ( !(flags & SH_UNLOCKED) )
LOCK();
if ( (symb=lookupHTable(streamAliases, (void *)alias)) )
{ IOSTREAM *stream;
uintptr_t n = (uintptr_t)symb->value;
if ( n < 6 ) /* standard stream! */
{ stream = LD->IO.streams[n];
} else
stream = symb->value;
if ( !(flags & SH_UNLOCKED) )
UNLOCK();
if ( stream )
{ if ( (flags & SH_UNLOCKED) )
{ if ( stream->magic == SIO_MAGIC )
{ *s = stream;
return TRUE;
}
} else if ( (*s = getStream(stream)) )
return TRUE;
goto noent;
}
}
if ( !(flags & SH_UNLOCKED) )
UNLOCK();
goto noent;
}
if ( flags & SH_ERRORS )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
(flags&SH_ALIAS) ? ATOM_stream_or_alias : ATOM_stream, t);
fail;
noent:
if ( flags & SH_ERRORS )
PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_stream, t);
fail;
}
#define get_stream_handle(t, sp, flags) \
get_stream_handle__LD(t, sp, flags PASS_LD)
int
PL_get_stream_handle(term_t t, IOSTREAM **s)
{ GET_LD
return get_stream_handle(t, s, SH_ERRORS|SH_ALIAS);
}
int
PL_unify_stream_or_alias(term_t t, IOSTREAM *s)
{ GET_LD
int rval;
stream_context *ctx;
int i;
if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
return PL_unify_atom(t, standardStreams[i]);
LOCK();
ctx = getStreamContext(s);
if ( ctx->alias_head )
{ rval = PL_unify_atom(t, ctx->alias_head->name);
} else
{ term_t a = PL_new_term_ref();
PL_put_pointer(a, s);
PL_cons_functor(a, FUNCTOR_dstream1, a);
rval = PL_unify(t, a);
}
UNLOCK();
return rval;
}
int
PL_unify_stream(term_t t, IOSTREAM *s)
{ GET_LD
stream_context *ctx;
term_t a = PL_new_term_ref();
LOCK();
ctx = getStreamContext(s);
UNLOCK();
PL_put_pointer(a, s);
PL_cons_functor(a, FUNCTOR_dstream1, a);
if ( PL_unify(t, a) )
succeed;
if ( PL_is_functor(t, FUNCTOR_dstream1) )
fail;
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream, t);
}
bool /* old FLI name (compatibility) */
PL_open_stream(term_t handle, IOSTREAM *s)
{ return PL_unify_stream(handle, s);
}
IOSTREAM ** /* provide access to Suser_input, */
_PL_streams(void) /* Suser_output and Suser_error */
{ GET_LD
return &Suser_input;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
getInputStream(term_t t, IOSTREAM **s)
getOutputStream(term_t t, IOSTREAM **s)
These functions are the basis used by all Prolog predicates to get
a input or output stream handle. If t = 0, current input/output is
returned. This allows us to define the standard-stream based version
simply by calling the explicit stream-based version with 0 for the
stream argument.
MT: The returned stream is always locked and should be returned
using releaseStream() or streamStatus().
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static bool
getOutputStream(term_t t, IOSTREAM **stream)
{ GET_LD
atom_t a;
IOSTREAM *s;
if ( t == 0 )
{ *stream = getStream(Scurout);
return TRUE;
} else if ( PL_get_atom(t, &a) && a == ATOM_user )
{ *stream = getStream(Suser_output);
return TRUE;
} else
{ *stream = NULL; /* make compiler happy */
}
if ( !PL_get_stream_handle(t, &s) )
fail;
if ( !(s->flags &SIO_OUTPUT) )
{ releaseStream(s);
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_output, ATOM_stream, t);
}
*stream = s;
succeed;
}
static bool
getInputStream__LD(term_t t, IOSTREAM **stream ARG_LD)
{ atom_t a;
IOSTREAM *s;
if ( t == 0 )
{ *stream = getStream(Scurin);
return TRUE;
} else if ( PL_get_atom(t, &a) && a == ATOM_user )
{ *stream = getStream(Suser_input);
return TRUE;
} else
{ *stream = NULL; /* make compiler happy */
}
if ( !get_stream_handle(t, &s, SH_ERRORS|SH_ALIAS) )
fail;
if ( !(s->flags &SIO_INPUT) )
{ releaseStream(s);
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_input, ATOM_stream, t);
}
*stream = s;
succeed;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
In windows GUI applications, the IO-streams are not bound. We do not
wish to generate an error on the stream errors that may be caused by
this. It is a bit of a hack, but the alternative is to define a stream
that ignores the error. This might get hairy if the user is playing with
these streams too.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifdef __WINDOWS__
static int
isConsoleStream(IOSTREAM *s)
{ int i = standardStreamIndexFromStream(s);
return i >= 0 && i < 3;
}
#else
#define isConsoleStream(s) FALSE
#endif
static bool
reportStreamError(IOSTREAM *s)
{ if ( GD->cleaning == CLN_NORMAL &&
!isConsoleStream(s) &&
(s->flags & (SIO_FERR|SIO_WARN)) )
{ GET_LD
atom_t op;
term_t stream = PL_new_term_ref();
char *msg;
PL_unify_stream_or_alias(stream, s);
if ( (s->flags & SIO_FERR) )
{ if ( s->exception )
{ fid_t fid = PL_open_foreign_frame();
term_t ex = PL_new_term_ref();
PL_recorded(s->exception, ex);
PL_erase(s->exception);
s->exception = NULL;
PL_raise_exception(ex);
PL_close_foreign_frame(fid);
fail;
}
if ( s->flags & SIO_INPUT )
{ if ( Sfpasteof(s) )
{ return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_input, ATOM_past_end_of_stream, stream);
} else if ( (s->flags & SIO_TIMEOUT) )
{ PL_error(NULL, 0, NULL, ERR_TIMEOUT,
ATOM_read, stream);
Sclearerr(s);
fail;
} else
op = ATOM_read;
} else
op = ATOM_write;
msg = s->message ? s->message : MSG_ERRNO;
PL_error(NULL, 0, msg, ERR_STREAM_OP, op, stream);
if ( (s->flags & SIO_CLEARERR) )
Sseterr(s, SIO_FERR, NULL);
fail;
} else
{ printMessage(ATOM_warning,
PL_FUNCTOR_CHARS, "io_warning", 2,
PL_TERM, stream,
PL_CHARS, s->message);
Sseterr(s, SIO_WARN, NULL);
}
}
succeed;
}
bool
streamStatus(IOSTREAM *s)
{ if ( (s->flags & (SIO_FERR|SIO_WARN)) )
{ releaseStream(s);
return reportStreamError(s);
}
releaseStream(s);
succeed;
}
/*******************************
* TTY MODES *
*******************************/
ttybuf ttytab; /* saved terminal status on entry */
int ttymode; /* Current tty mode */
typedef struct input_context * InputContext;
typedef struct output_context * OutputContext;
struct input_context
{ IOSTREAM * stream; /* pushed input */
atom_t term_file; /* old term_position file */
int term_line; /* old term_position line */
InputContext previous; /* previous context */
};
struct output_context
{ IOSTREAM * stream; /* pushed output */
OutputContext previous; /* previous context */
};
#define input_context_stack (LD->IO.input_stack)
#define output_context_stack (LD->IO.output_stack)
static IOSTREAM *openStream(term_t file, term_t mode, term_t options);
void
dieIO(void)
{ if ( GD->io_initialised )
{ pl_noprotocol();
closeFiles(TRUE);
PopTty(Sinput, &ttytab);
}
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
closeStream() performs Prolog-level closing. Most important right now is
to to avoid closing the user-streams. If a stream cannot be flushed (due
to a write-error), an exception is generated.
MT: We assume the stream is locked and will unlock it here.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static bool
closeStream(IOSTREAM *s)
{ if ( s == Sinput )
{ Sclearerr(s);
releaseStream(s);
} else if ( s == Soutput || s == Serror )
{ if ( Sflush(s) < 0 )
return streamStatus(s);
releaseStream(s);
} else
{ if ( !Sferror(s) && Sflush(s) < 0 )
{ streamStatus(s);
Sclose(s);
return FALSE;
}
if ( Sclose(s) < 0 ) /* will unlock as well */
fail;
}
succeed;
}
void
closeFiles(int all)
{ GET_LD
TableEnum e;
Symbol symb;
e = newTableEnum(streamContext);
while( (symb=advanceTableEnum(e)) )
{ IOSTREAM *s = symb->name;
if ( all || !(s->flags & SIO_NOCLOSE) )
{ IOSTREAM *s2 = tryGetStream(s);
if ( s2 )
{ if ( !all )
{ term_t t = PL_new_term_ref();
PL_unify_stream_or_alias(t, s2);
printMessage(ATOM_informational,
PL_FUNCTOR, FUNCTOR_close_on_abort1,
PL_TERM, t);
PL_reset_term_refs(t);
}
closeStream(s2);
}
}
}
freeTableEnum(e);
}
void
PL_cleanup_fork(void)
{ TableEnum e;
Symbol symb;
e = newTableEnum(streamContext);
while( (symb=advanceTableEnum(e)) )
{ IOSTREAM *s = symb->name;
int fd;
if ( (fd=Sfileno(s)) >= 3 )
close(fd);
}
freeTableEnum(e);
stopItimer();
}
void
protocol(const char *str, size_t n)
{ GET_LD
IOSTREAM *s;
if ( LD && (s = getStream(Sprotocol)) )
{ while( n-- > 0 )
Sputcode(*str++&0xff, s);
Sflush(s);
releaseStream(s); /* we don not check errors */
}
}
/*******************************
* TEMPORARY I/O *
*******************************/
static word
pl_push_input_context(void)
{ GET_LD
InputContext c = allocHeap(sizeof(struct input_context));
c->stream = Scurin;
c->term_file = source_file_name;
c->term_line = source_line_no;
c->previous = input_context_stack;
input_context_stack = c;
succeed;
}
static word
pl_pop_input_context(void)
{ GET_LD
InputContext c = input_context_stack;
if ( c )
{ Scurin = c->stream;
source_file_name = c->term_file;
source_line_no = c->term_line;
input_context_stack = c->previous;
freeHeap(c, sizeof(struct input_context));
succeed;
} else
{ Scurin = Sinput;
fail;
}
}
static void
pushOutputContext(void)
{ GET_LD
OutputContext c = allocHeap(sizeof(struct output_context));
c->stream = Scurout;
c->previous = output_context_stack;
output_context_stack = c;
}
static void
popOutputContext(void)
{ GET_LD
OutputContext c = output_context_stack;
if ( c )
{ if ( c->stream->magic == SIO_MAGIC )
Scurout = c->stream;
else
{ Sdprintf("Oops, current stream closed?");
Scurout = Soutput;
}
output_context_stack = c->previous;
freeHeap(c, sizeof(struct output_context));
} else
Scurout = Soutput;
}
int
setupOutputRedirect(term_t to, redir_context *ctx, int redir)
{ GET_LD
atom_t a;
ctx->term = to;
ctx->redirected = redir;
if ( to == 0 )
{ ctx->stream = getStream(Scurout);
ctx->is_stream = TRUE;
} else if ( PL_get_atom(to, &a) && a == ATOM_user )
{ ctx->stream = getStream(Suser_output);
ctx->is_stream = TRUE;
} else if ( get_stream_handle(to, &ctx->stream, SH_SAFE) )
{ if ( !(ctx->stream->flags &SIO_OUTPUT) )
{ releaseStream(ctx->stream);
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_output, ATOM_stream, to);
}
ctx->is_stream = TRUE;
} else
{ if ( PL_is_functor(to, FUNCTOR_codes2) )
{ ctx->out_format = PL_CODE_LIST;
ctx->out_arity = 2;
} else if ( PL_is_functor(to, FUNCTOR_codes1) )
{ ctx->out_format = PL_CODE_LIST;
ctx->out_arity = 1;
} else if ( PL_is_functor(to, FUNCTOR_chars2) )
{ ctx->out_format = PL_CHAR_LIST;
ctx->out_arity = 2;
} else if ( PL_is_functor(to, FUNCTOR_chars1) )
{ ctx->out_format = PL_CHAR_LIST;
ctx->out_arity = 1;
} else if ( PL_is_functor(to, FUNCTOR_string1) )
{ ctx->out_format = PL_STRING;
ctx->out_arity = 1;
} else if ( PL_is_functor(to, FUNCTOR_atom1) )
{ ctx->out_format = PL_ATOM;
ctx->out_arity = 1;
} else
{ return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_output, to);
}
ctx->is_stream = FALSE;
ctx->data = ctx->buffer;
ctx->size = sizeof(ctx->buffer);
ctx->stream = Sopenmem(&ctx->data, &ctx->size, "w");
ctx->stream->encoding = ENC_WCHAR;
}
ctx->magic = REDIR_MAGIC;
if ( redir )
{ pushOutputContext();
Scurout = ctx->stream;
}
succeed;
}
int
closeOutputRedirect(redir_context *ctx)
{ int rval = TRUE;
if ( ctx->magic != REDIR_MAGIC )
return rval; /* already done */
ctx->magic = 0;
if ( ctx->redirected )
popOutputContext();
if ( ctx->is_stream )
{ rval = streamStatus(ctx->stream);
} else
{ GET_LD
term_t out = PL_new_term_ref();
term_t diff, tail;
closeStream(ctx->stream);
_PL_get_arg(1, ctx->term, out);
if ( ctx->out_arity == 2 )
{ diff = PL_new_term_ref();
_PL_get_arg(2, ctx->term, diff);
tail = PL_new_term_ref();
} else
{ diff = tail = 0;
}
rval = PL_unify_wchars_diff(out, tail, ctx->out_format,
ctx->size/sizeof(wchar_t),
(wchar_t*)ctx->data);
if ( tail )
rval = PL_unify(tail, diff);
if ( ctx->data != ctx->buffer )
free(ctx->data);
}
return rval;
}
void
discardOutputRedirect(redir_context *ctx)
{ if ( ctx->magic != REDIR_MAGIC )
return; /* already done */
ctx->magic = 0;
if ( ctx->redirected )
popOutputContext();
if ( ctx->is_stream )
{ releaseStream(ctx->stream);
} else
{ closeStream(ctx->stream);
if ( ctx->data != ctx->buffer )
free(ctx->data);
}
}
static
PRED_IMPL("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
{ redir_context outctx;
if ( setupOutputRedirect(A1, &outctx, TRUE) )
{ term_t ex = 0;
int rval;
if ( (rval = callProlog(NULL, A2, PL_Q_CATCH_EXCEPTION, &ex)) )
return closeOutputRedirect(&outctx);
discardOutputRedirect(&outctx);
if ( ex )
return PL_raise_exception(ex);
}
fail;
}
void
PL_write_prompt(int dowrite)
{ GET_LD
IOSTREAM *s = getStream(Suser_output);
if ( s )
{ if ( dowrite )
{ atom_t a = PrologPrompt();
if ( a )
writeAtomToStream(s, a);
}
Sflush(s);
releaseStream(s);
}
LD->prompt.next = FALSE;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Get a single character from Sinput without waiting for a return. The
character should not be echoed. If TTY_CONTROL_FEATURE is false this
function will read the first character and then skip all character upto
and including the newline.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
Sgetcode_intr(IOSTREAM *s, int signals)
{ int c;
#ifdef __WINDOWS__
int newline = s->newline;
s->newline = SIO_NL_POSIX; /* avoid blocking \r */
#endif
do
{ Sclearerr(s);
c = Sgetcode(s);
} while ( c == -1 &&
errno == EINTR &&
(!signals || PL_handle_signals() >= 0)
);
#ifdef __WINDOWS__
s->newline = newline;
#endif
return c;
}
static int
getSingleChar(IOSTREAM *stream, int signals)
{ GET_LD
int c;
ttybuf buf;
// debugstatus.suspendTrace++; WARNING: suspendTrace
Slock(stream);
Sflush(stream);
PushTty(stream, &buf, TTY_RAW); /* just donot prompt */
if ( !trueFeature(TTY_CONTROL_FEATURE) )
{ int c2;
c2 = Sgetcode_intr(stream, signals);
while( c2 == ' ' || c2 == '\t' ) /* skip blanks */
c2 = Sgetcode_intr(stream, signals);
c = c2;
while( c2 != EOF && c2 != '\n' ) /* read upto newline */
c2 = Sgetcode_intr(stream, signals);
} else
{ if ( stream->position )
{ IOPOS oldpos = *stream->position;
c = Sgetcode_intr(stream, signals);
*stream->position = oldpos;
} else
c = Sgetcode_intr(stream, signals);
}
if ( c == 4 || c == 26 ) /* should ask the terminal! */
c = -1;
PopTty(stream, &buf);
// debugstatus.suspendTrace--; WARNING: suspendTrace
Sunlock(stream);
return c;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
readLine() reads a line from the terminal. It is used only by the tracer.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifndef DEL
#define DEL 127
#endif
bool
readLine(IOSTREAM *in, IOSTREAM *out, char *buffer)
{ GET_LD
int c;
char *buf = &buffer[strlen(buffer)];
ttybuf tbuf;
Slock(in);
Slock(out);
PushTty(in, &tbuf, TTY_RAW); /* just donot prompt */
for(;;)
{ Sflush(out);
switch( (c=Sgetc(in)) )
{ case '\n':
case '\r':
case EOF:
*buf++ = EOS;
PopTty(in, &tbuf);
Sunlock(in);
Sunlock(out);
return c == EOF ? FALSE : TRUE;
case '\b':
case DEL:
if ( trueFeature(TTY_CONTROL_FEATURE) && buf > buffer )
{ Sfputs("\b \b", out);
buf--;
}
default:
if ( trueFeature(TTY_CONTROL_FEATURE) )
Sputc(c, out);
*buf++ = c;
}
}
}
IOSTREAM *
PL_current_input()
{ GET_LD
return getStream(Scurin);
}
IOSTREAM *
PL_current_output()
{ GET_LD
return getStream(Scurout);
}
static word
openProtocol(term_t f, bool appnd)
{ GET_LD
IOSTREAM *s;
term_t mode = PL_new_term_ref();
pl_noprotocol();
PL_put_atom(mode, appnd ? ATOM_append : ATOM_write);
if ( (s = openStream(f, mode, 0)) )
{ s->flags |= SIO_NOCLOSE; /* do not close on abort */
Sprotocol = s;
Suser_input->tee = s;
Suser_output->tee = s;
Suser_error->tee = s;
return TRUE;
}
return FALSE;
}
word
pl_noprotocol(void)
{ GET_LD
IOSTREAM *s;
if ( (s = getStream(Sprotocol)) )
{ TableEnum e;
Symbol symb;
e = newTableEnum(streamContext);
while( (symb=advanceTableEnum(e)) )
{ IOSTREAM *p = symb->name;
if ( p->tee == s )
p->tee = NULL;
}
freeTableEnum(e);
closeStream(s);
Sprotocol = NULL;
}
succeed;
}
/*******************************
* STREAM ATTRIBUTES *
*******************************/
static foreign_t
pl_set_stream(term_t stream, term_t attr)
{ GET_LD
IOSTREAM *s;
atom_t aname;
int arity;
if ( !PL_get_stream_handle(stream, &s) )
fail;
if ( PL_get_name_arity(attr, &aname, &arity) )
{ if ( arity == 1 )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, attr, a);
if ( aname == ATOM_alias ) /* alias(name) */
{ atom_t alias;
int i;
if ( !PL_get_atom_ex(a, &alias) )
goto error;
if ( (i=standardStreamIndexFromName(alias)) >= 0 )
{ LD->IO.streams[i] = s;
if ( i == 0 )
LD->prompt.next = TRUE; /* changed standard input: prompt! */
goto ok;
}
LOCK();
aliasStream(s, alias);
UNLOCK();
goto ok;
} else if ( aname == ATOM_buffer ) /* buffer(Buffering) */
{ atom_t b;
#define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF)
if ( !PL_get_atom_ex(a, &b) )
goto error;
if ( b == ATOM_full )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_FBUF;
} else if ( b == ATOM_line )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_LBUF;
} else if ( b == ATOM_false )
{ Sflush(s);
s->flags &= ~SIO_ABUF;
s->flags |= SIO_NBUF;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_buffer, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_buffer_size )
{ int size;
if ( !PL_get_integer_ex(a, &size) )
goto error;
if ( size < 1 )
{ PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a);
goto error;
}
Ssetbuffer(s, NULL, size);
goto ok;
} else if ( aname == ATOM_eof_action ) /* eof_action(Action) */
{ atom_t action;
if ( !PL_get_atom_ex(a, &action) )
fail;
if ( action == ATOM_eof_code )
{ s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR);
} else if ( action == ATOM_reset )
{ s->flags &= ~SIO_FEOF2ERR;
s->flags |= SIO_NOFEOF;
} else if ( action == ATOM_error )
{ s->flags &= ~SIO_NOFEOF;
s->flags |= SIO_FEOF2ERR;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_eof_action, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */
{ int close;
if ( !PL_get_bool_ex(a, &close) )
goto error;
if ( close )
s->flags &= ~SIO_NOCLOSE;
else
s->flags |= SIO_NOCLOSE;
goto ok;
} else if ( aname == ATOM_record_position )
{ int rec;
if ( !PL_get_bool_ex(a, &rec) )
goto error;
if ( rec )
s->position = &s->posbuf;
else
s->position = NULL;
goto ok;
} else if ( aname == ATOM_file_name ) /* file_name(Atom) */
{ atom_t fn;
if ( !PL_get_atom_ex(a, &fn) )
goto error;
LOCK();
setFileNameStream(s, fn);
UNLOCK();
goto ok;
} else if ( aname == ATOM_timeout )
{ double f;
atom_t v;
if ( PL_get_atom(a, &v) && v == ATOM_infinite )
{ s->timeout = -1;
goto ok;
}
if ( !PL_get_float_ex(a, &f) )
goto error;
s->timeout = (int)(f*1000.0);
if ( s->timeout < 0 )
s->timeout = 0;
goto ok;
} else if ( aname == ATOM_tty ) /* tty(bool) */
{ int val;
if ( !PL_get_bool_ex(a, &val) )
goto error;
if ( val )
set(s, SIO_ISATTY);
else
clear(s, SIO_ISATTY);
goto ok;
} else if ( aname == ATOM_encoding ) /* encoding(atom) */
{ atom_t val;
IOENC enc;
if ( !PL_get_atom_ex(a, &val) )
goto error;
if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN )
{ bad_encoding(val);
goto error;
}
if ( Ssetenc(s, enc, NULL) == 0 )
goto ok;
PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
goto error;
} else if ( aname == ATOM_representation_errors )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
goto error;
clear(s, SIO_REPXML|SIO_REPPL);
if ( val == ATOM_error )
;
else if ( val == ATOM_xml )
set(s, SIO_REPXML);
else if ( val == ATOM_prolog )
set(s, SIO_REPPL);
else
{ PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_representation_errors, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_newline )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
goto error;
if ( val == ATOM_posix )
s->newline = SIO_NL_POSIX;
else if ( val == ATOM_dos )
s->newline = SIO_NL_DOS;
else if ( val == ATOM_detect )
{ if ( false(s, SIO_INPUT) )
{ PL_error(NULL, 0, "detect only allowed for input streams",
ERR_DOMAIN, ATOM_newline, a);
goto error;
}
s->newline = SIO_NL_DETECT;
} else
{ PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a);
goto error;
}
goto ok;
}
}
}
PL_error("set_stream", 2, NULL, ERR_TYPE,
PL_new_atom("stream_attribute"), attr);
goto error;
ok:
releaseStream(s);
succeed;
error:
releaseStream(s);
fail;
}
/********************************
* STRING I/O *
*********************************/
extern IOFUNCTIONS Smemfunctions;
bool
tellString(char **s, size_t *size, IOENC enc)
{ GET_LD
IOSTREAM *stream;
stream = Sopenmem(s, size, "w");
stream->encoding = enc;
pushOutputContext();
Scurout = stream;
return TRUE;
}
bool
toldString(void)
{ GET_LD
IOSTREAM *s = getStream(Scurout);
if ( !s )
succeed;
if ( s->functions == &Smemfunctions )
{ closeStream(s);
popOutputContext();
} else
releaseStream(s);
succeed;
}
/********************************
* WAITING FOR INPUT *
********************************/
#ifndef HAVE_SELECT
word
pl_wait_for_input(term_t streams, term_t available,
term_t timeout)
{ GET_LD
return notImplemented("wait_for_input", 3);
}
#else
typedef struct fdentry
{ int fd;
term_t stream;
struct fdentry *next;
} fdentry;
static inline term_t
findmap(fdentry *map, int fd)
{ for( ; map; map = map->next )
{ if ( map->fd == fd )
return map->stream;
}
assert(0);
return 0;
}
static word
pl_wait_for_input(term_t Streams, term_t Available,
term_t timeout)
{ GET_LD
fd_set fds;
struct timeval t, *to;
double time;
int n, max = 0, ret, min = 1 << (INTBITSIZE-2);
fdentry *map = NULL;
term_t head = PL_new_term_ref();
term_t streams = PL_copy_term_ref(Streams);
term_t available = PL_copy_term_ref(Available);
term_t ahead = PL_new_term_ref();
int from_buffer = 0;
atom_t a;
FD_ZERO(&fds);
while( PL_get_list(streams, head, streams) )
{ IOSTREAM *s;
int fd;
fdentry *e;
if ( !PL_get_stream_handle(head, &s) )
fail;
if ( (fd=Sfileno(s)) < 0 )
{ releaseStream(s);
return PL_error("wait_for_input", 3, NULL, ERR_DOMAIN,
PL_new_atom("file_stream"), head);
}
releaseStream(s);
/* check for input in buffer */
if ( s->bufp < s->limitp )
{ if ( !PL_unify_list(available, ahead, available) ||
!PL_unify(ahead, head) )
fail;
from_buffer++;
}
e = alloca(sizeof(*e));
e->fd = fd;
e->stream = PL_copy_term_ref(head);
e->next = map;
map = e;
#ifdef __WINDOWS__
FD_SET((SOCKET)fd, &fds);
#else
FD_SET(fd, &fds);
#endif
if ( fd > max )
max = fd;
if( fd < min )
min = fd;
}
if ( !PL_get_nil(streams) )
return PL_error("wait_for_input", 3, NULL, ERR_TYPE, ATOM_list, Streams);
if ( from_buffer > 0 )
return PL_unify_nil(available);
if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
{ to = NULL;
} else if ( PL_is_integer(timeout) )
{ long v;
PL_get_long(timeout, &v);
if ( v > 0L )
{ t.tv_sec = v;
t.tv_usec = 0;
to = &t;
} else if ( v == 0 )
{ to = NULL;
} else
{ t.tv_sec = 0;
t.tv_usec = 0;
to = &t;
}
} else
{ if ( !PL_get_float(timeout, &time) )
return PL_error("wait_for_input", 3, NULL,
ERR_TYPE, ATOM_float, timeout);
if ( time >= 0.0 )
{ t.tv_sec = (int)time;
t.tv_usec = ((int)(time * 1000000) % 1000000);
} else
{ t.tv_sec = 0;
t.tv_usec = 0;
}
to = &t;
}
while( (ret=select(max+1, &fds, NULL, NULL, to)) == -1 &&
errno == EINTR )
{ fdentry *e;
if ( PL_handle_signals() < 0 )
fail; /* exception */
FD_ZERO(&fds); /* EINTR may leave fds undefined */
for(e=map; e; e=e->next) /* so we rebuild it to be safe */
{
#ifdef __WINDOWS__
FD_SET((SOCKET)e->fd, &fds);
#else
FD_SET(e->fd, &fds);
#endif
}
}
switch(ret)
{ case -1:
return PL_error("wait_for_input", 3, MSG_ERRNO, ERR_FILE_OPERATION,
ATOM_select, ATOM_stream, Streams);
case 0: /* Timeout */
break;
default: /* Something happend -> check fds */
for(n=min; n <= max; n++)
{ if ( FD_ISSET(n, &fds) )
{ if ( !PL_unify_list(available, ahead, available) ||
!PL_unify(ahead, findmap(map, n)) )
fail;
}
}
break;
}
return PL_unify_nil(available);
}
#endif /* HAVE_SELECT */
/********************************
* PROLOG CONNECTION *
*********************************/
#define MAX_PENDING SIO_BUFSIZE /* 4096 */
static void
re_buffer(IOSTREAM *s, const char *from, size_t len)
{ if ( s->bufp < s->limitp )
{ size_t size = s->limitp - s->bufp;
memmove(s->buffer, s->bufp, size);
s->bufp = s->buffer;
s->limitp = &s->bufp[size];
} else
{ s->bufp = s->limitp = s->buffer;
}
memcpy(s->bufp, from, len);
s->bufp += len;
}
#ifndef HAVE_MBSNRTOWCS
static size_t
mbsnrtowcs(wchar_t *dest, const char **src,
size_t nms, size_t len, mbstate_t *ps)
{ wchar_t c;
const char *us = *src;
const char *es = us+nms;
size_t count = 0;
assert(dest == NULL); /* incomplete implementation */
while(us<es)
{ size_t skip = mbrtowc(&c, us, es-us, ps);
if ( skip == (size_t)-1 ) /* error */
{ DEBUG(1, Sdprintf("mbsnrtowcs(): bad multibyte seq\n"));
return skip;
}
if ( skip == (size_t)-2 ) /* incomplete */
{ *src = us;
return count;
}
count++;
us += skip;
}
*src = us;
return count;
}
#else
#if defined(HAVE_DECL_MBSNRTOWCS) && !HAVE_DECL_MBSNRTOWCS
size_t mbsnrtowcs(wchar_t *dest, const char **src,
size_t nms, size_t len, mbstate_t *ps);
#endif
#endif /*HAVE_MBSNRTOWCS*/
static int
skip_cr(IOSTREAM *s)
{ if ( s->flags&SIO_TEXT )
{ switch(s->newline)
{ case SIO_NL_DETECT:
s->newline = SIO_NL_DOS;
/*FALLTHROUGH*/
case SIO_NL_DOS:
return TRUE;
}
}
return FALSE;
}
static
PRED_IMPL("read_pending_input", 3, read_pending_input, 0)
{ PRED_LD
IOSTREAM *s;
if ( getInputStream(A1, &s) )
{ char buf[MAX_PENDING];
ssize_t n;
word gstore, lp;
int64_t off0 = Stell64(s);
IOPOS pos0;
if ( Sferror(s) )
return streamStatus(s);
n = Sread_pending(s, buf, sizeof(buf), 0);
if ( n < 0 ) /* should not happen */
return streamStatus(s);
if ( n == 0 ) /* end-of-file */
{ S__fcheckpasteeof(s, -1);
return PL_unify(A2, A3);
}
if ( s->position )
{ pos0 = *s->position;
} else
{ memset(&pos0, 0, sizeof(pos0)); /* make compiler happy */
}
switch(s->encoding)
{ case ENC_OCTET:
case ENC_ISO_LATIN_1:
case ENC_ASCII:
{ ssize_t i;
lp = gstore = INIT_SEQ_CODES(n);
// lp = gstore = allocGlobal(1+n*3); /* TBD: shift */
for(i=0; i<n; i++)
{ int c = buf[i]&0xff;
if ( c == '\r' && skip_cr(s) )
continue;
if ( s->position )
S__fupdatefilepos_getc(s, c);
gstore = EXTEND_SEQ_CODES(gstore, c);
}
if ( s->position )
s->position->byteno = pos0.byteno+n;
break;
}
case ENC_ANSI:
{ size_t count, i;
mbstate_t s0;
const char *us = buf;
const char *es = buf+n;
if ( !s->mbstate )
{ if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) )
{ PL_error(NULL, 0, NULL, ERR_NOMEM);
goto failure;
}
memset(s->mbstate, 0, sizeof(*s->mbstate));
}
s0 = *s->mbstate;
count = mbsnrtowcs(NULL, &us, n, 0, &s0);
if ( count == (size_t)-1 )
{ Sseterr(s, SIO_WARN, "Illegal multibyte Sequence");
goto failure;
}
DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
count, n, es-us));
lp = gstore = INIT_SEQ_CODES(count);
for(us=buf,i=0; i<count; i++)
{ wchar_t c;
us += mbrtowc(&c, us, es-us, s->mbstate);
if ( c == '\r' && skip_cr(s) )
continue;
if ( s->position )
S__fupdatefilepos_getc(s, c);
gstore = EXTEND_SEQ_CODES(gstore, c);
}
if ( s->position )
s->position->byteno = pos0.byteno+us-buf;
re_buffer(s, us, es-us);
break;
}
case ENC_UTF8:
{ const char *us = buf;
const char *es = buf+n;
size_t count = 0, i;
while(us<es)
{ const char *ec = us + UTF8_FBN(us[0]) + 1;
if ( ec <= es )
{ count++;
us=ec;
} else
break;
}
DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n",
count, n, es-us));
lp = gstore = INIT_SEQ_CODES(count);
for(us=buf,i=0; i<count; i++)
{ int c;
us = utf8_get_char(us, &c);
if ( c == '\r' && skip_cr(s) )
continue;
if ( s->position )
S__fupdatefilepos_getc(s, c);
gstore = EXTEND_SEQ_CODES(gstore, c);
}
if ( s->position )
s->position->byteno = pos0.byteno+us-buf;
re_buffer(s, us, es-us);
break;
}
case ENC_UNICODE_BE:
case ENC_UNICODE_LE:
{ size_t count = (size_t)n/2;
const char *us = buf;
size_t done, i;
lp = gstore = INIT_SEQ_CODES(count);
for(i=0; i<count; us+=2, i++)
{ int c;
if ( s->encoding == ENC_UNICODE_BE )
c = ((us[0]&0xff)<<8)+(us[1]&0xff);
else
c = ((us[1]&0xff)<<8)+(us[0]&0xff);
if ( c == '\r' && skip_cr(s) )
continue;
if ( s->position )
S__fupdatefilepos_getc(s, c);
gstore = EXTEND_SEQ_CODES(gstore, c);
}
done = count*2;
if ( s->position )
s->position->byteno = pos0.byteno+done;
re_buffer(s, buf+done, n-done);
break;
}
case ENC_WCHAR:
{ const pl_wchar_t *ws = (const pl_wchar_t*)buf;
size_t count = (size_t)n/sizeof(pl_wchar_t);
size_t done, i;
lp = gstore = INIT_SEQ_CODES(count);
for(i=0; i<count; i++)
{ int c = ws[i];
if ( c == '\r' && skip_cr(s) )
continue;
if ( s->position )
S__fupdatefilepos_getc(s, c);
gstore = EXTEND_SEQ_CODES(gstore, c);
}
done = count*sizeof(pl_wchar_t);
if ( s->position )
s->position->byteno = pos0.byteno+done;
re_buffer(s, buf+done, n-done);
break;
}
case ENC_UNKNOWN:
default:
assert(0);
fail;
}
if (!CLOSE_SEQ_OF_CODES(gstore, lp, A2, A3))
goto failure;
releaseStream(s);
succeed;
failure:
Sseek64(s, off0, SIO_SEEK_SET); /* TBD: error? */
if ( s->position )
*s->position = pos0;
releaseStream(s);
fail;
}
fail;
}
int
PL_get_char(term_t c, int *p, int eof)
{ GET_LD
int chr;
atom_t name;
PL_chars_t text;
if ( PL_get_integer(c, &chr) )
{ if ( chr >= 0 )
{ *p = chr;
return TRUE;
}
if ( eof && chr == -1 )
{ *p = chr;
return TRUE;
}
} else if ( PL_get_text(c, &text, CVT_ATOM|CVT_STRING|CVT_LIST) &&
text.length == 1 )
{ *p = text.encoding == ENC_ISO_LATIN_1 ? text.text.t[0]&0xff
: text.text.w[0];
return TRUE;
} else if ( eof && PL_get_atom(c, &name) && name == ATOM_end_of_file )
{ *p = -1;
return TRUE;
}
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, c);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PL_unify_char(term_t chr, int c, int how)
Unify a character. Try to be as flexible as possible, only binding a
variable `chr' to a code or one-char-atom.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
int
PL_unify_char(term_t chr, int c, int how)
{ GET_LD
int c2 = -1;
if ( PL_is_variable(chr) )
{ switch(how)
{ case CHAR_MODE:
{ atom_t a = (c == -1 ? ATOM_end_of_file : codeToAtom(c));
return PL_unify_atom(chr, a);
}
case CODE_MODE:
case BYTE_MODE:
default:
return PL_unify_integer(chr, c);
}
} else if ( PL_get_char(chr, &c2, TRUE) )
return c == c2;
fail;
}
static foreign_t
put_byte(term_t stream, term_t byte ARG_LD)
{ IOSTREAM *s;
int c;
if ( !PL_get_integer(byte, &c) || c < 0 || c > 255 )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_byte, byte);
if ( !getOutputStream(stream, &s) )
fail;
Sputc(c, s);
return streamStatus(s);
}
static
PRED_IMPL("put_byte", 2, put_byte2, 0)
{ PRED_LD
return put_byte(A1, A2 PASS_LD);
}
static
PRED_IMPL("put_byte", 1, put_byte1, 0)
{ PRED_LD
return put_byte(0, A1 PASS_LD);
}
static foreign_t
put_code(term_t stream, term_t chr ARG_LD)
{ IOSTREAM *s;
int c = 0;
if ( !PL_get_char(chr, &c, FALSE) )
fail;
if ( !getOutputStream(stream, &s) )
fail;
Sputcode(c, s);
return streamStatus(s);
}
static
PRED_IMPL("put_code", 2, put_code2, 0)
{ PRED_LD
return put_code(A1, A2 PASS_LD);
}
static
PRED_IMPL("put_code", 1, put_code1, 0)
{ PRED_LD
return put_code(0, A1 PASS_LD);
}
static
PRED_IMPL("put", 2, put2, 0)
{ PRED_LD
return put_code(A1, A2 PASS_LD);
}
static
PRED_IMPL("put", 1, put1, 0)
{ PRED_LD
return put_code(0, A1 PASS_LD);
}
static foreign_t
get_nonblank(term_t in, term_t chr ARG_LD)
{ IOSTREAM *s;
if ( getInputStream(in, &s) )
{ int c;
for(;;)
{ c = Sgetcode(s);
if ( c == EOF )
{ TRY(PL_unify_integer(chr, -1));
return streamStatus(s);
}
if ( !isBlankW(c) )
{ releaseStream(s);
return PL_unify_integer(chr, c);
}
}
}
fail;
}
static
PRED_IMPL("get", 1, get1, 0)
{ PRED_LD
return get_nonblank(0, A1 PASS_LD);
}
static
PRED_IMPL("get", 2, get2, 0)
{ PRED_LD
return get_nonblank(A1, A2 PASS_LD);
}
static foreign_t
skip(term_t in, term_t chr ARG_LD)
{ int c = -1;
int r;
IOSTREAM *s;
if ( !PL_get_char(chr, &c, FALSE) )
fail;
if ( !getInputStream(in, &s) )
fail;
while((r=Sgetcode(s)) != c && r != EOF )
;
return streamStatus(s);
}
static
PRED_IMPL("skip", 1, skip1, 0)
{ PRED_LD
return skip(0, A1 PASS_LD);
}
static
PRED_IMPL("skip", 2, skip2, 0)
{ PRED_LD
return skip(A1, A2 PASS_LD);
}
static word
pl_get_single_char(term_t chr)
{ GET_LD
IOSTREAM *s = getStream(Suser_input);
int c = getSingleChar(s, TRUE);
if ( c == EOF )
{ PL_unify_integer(chr, -1);
return streamStatus(s);
}
releaseStream(s);
return PL_unify_integer(chr, c);
}
static foreign_t
pl_get_byte2(term_t in, term_t chr ARG_LD)
{ IOSTREAM *s;
if ( getInputStream(in, &s) )
{ int c = Sgetc(s);
if ( PL_unify_integer(chr, c) )
return streamStatus(s);
if ( Sferror(s) )
return streamStatus(s);
PL_get_char(chr, &c, TRUE); /* set type-error */
}
fail;
}
static
PRED_IMPL("get_byte", 2, get_byte2, 0)
{ PRED_LD
return pl_get_byte2(A1, A2 PASS_LD);
}
static
PRED_IMPL("get_byte", 1, get_byte1, 0)
{ PRED_LD
return pl_get_byte2(0, A1 PASS_LD);
}
static foreign_t
pl_get_code2(term_t in, term_t chr)
{ GET_LD
IOSTREAM *s;
if ( getInputStream(in, &s) )
{ int c = Sgetcode(s);
if ( PL_unify_integer(chr, c) )
return streamStatus(s);
if ( Sferror(s) )
return streamStatus(s);
PL_get_char(chr, &c, TRUE); /* set type-error */
releaseStream(s);
}
fail;
}
static
PRED_IMPL("get_code", 2, get_code2, 0)
{ return pl_get_code2(A1, A2);
}
static
PRED_IMPL("get_code", 1, get_code1, 0)
{ return pl_get_code2(0, A1);
}
static foreign_t
pl_get_char2(term_t in, term_t chr)
{ GET_LD
IOSTREAM *s;
if ( getInputStream(in, &s) )
{ int c = Sgetcode(s);
if ( PL_unify_atom(chr, c == -1 ? ATOM_end_of_file : codeToAtom(c)) )
return streamStatus(s);
if ( Sferror(s) )
return streamStatus(s);
PL_get_char(chr, &c, TRUE); /* set type-error */
releaseStream(s);
}
fail;
}
static
PRED_IMPL("get_char", 2, get_char2, 0)
{ return pl_get_char2(A1, A2);
}
static
PRED_IMPL("get_char", 1, get_char1, 0)
{ return pl_get_char2(0, A1);
}
static word
pl_ttyflush(void)
{ GET_LD
IOSTREAM *s = getStream(Suser_output);
Sflush(s);
return streamStatus(s);
}
static word
pl_protocol(term_t file)
{ return openProtocol(file, FALSE);
}
static word
pl_protocola(term_t file)
{ return openProtocol(file, TRUE);
}
static word
pl_protocolling(term_t file)
{ GET_LD
IOSTREAM *s;
if ( (s = Sprotocol) )
{ atom_t a;
if ( (a = fileNameStream(s)) )
return PL_unify_atom(file, a);
else
return PL_unify_stream_or_alias(file, s);
}
fail;
}
static word
pl_prompt(term_t old, term_t new)
{ GET_LD
atom_t a;
if ( PL_unify_atom(old, LD->prompt.current) &&
PL_get_atom(new, &a) )
{ if ( LD->prompt.current )
PL_unregister_atom(LD->prompt.current);
LD->prompt.current = a;
PL_register_atom(a);
succeed;
}
fail;
}
static void
prompt1(atom_t prompt)
{ GET_LD
if ( LD->prompt.first != prompt )
{ if ( LD->prompt.first )
PL_unregister_atom(LD->prompt.first);
LD->prompt.first = prompt;
PL_register_atom(LD->prompt.first);
}
LD->prompt.first_used = FALSE;
}
static word
pl_prompt1(term_t prompt)
{ GET_LD
atom_t a;
PL_chars_t txt;
if ( PL_get_atom(prompt, &a) )
{ prompt1(a);
} else if ( PL_get_text(prompt, &txt, CVT_ALL|CVT_EXCEPTION) )
{ prompt1(textToAtom(&txt));
} else
fail;
succeed;
}
atom_t
PrologPrompt()
{ GET_LD
if ( !LD->prompt.first_used && LD->prompt.first )
{ LD->prompt.first_used = TRUE;
return LD->prompt.first;
}
if ( Sinput->position && Sinput->position->linepos == 0 )
return LD->prompt.current;
else
return 0; /* "" */
}
static word
pl_tab2(term_t out, term_t spaces)
{ GET_LD
number n;
int rval = FALSE;
IOSTREAM *s;
if ( !getOutputStream(out, &s) )
fail;
if ( valueExpression(spaces, &n PASS_LD) )
{ if ( toIntegerNumber(&n, 0) )
{ int64_t m;
switch(n.type)
{ case V_INTEGER:
m = n.value.i;
break;
#ifdef O_GMP
case V_MPZ:
{ if ( !mpz_to_int64(n.value.mpz, &m) )
{ PL_error(NULL, 0, NULL, ERR_EVALUATION, ATOM_int_overflow);
goto error;
}
}
#endif
default:
assert(0);
}
while(m-- > 0)
{ if ( Sputcode(' ', s) < 0 )
break;
}
rval = TRUE;
}
clearNumber(&n);
} else
{ rval = PL_error("tab", 1, NULL, ERR_TYPE, ATOM_integer, spaces);
}
if ( rval )
return streamStatus(s);
#ifdef O_GMP
error:
#endif
(void)streamStatus(s);
fail;
}
static word
pl_tab(term_t n)
{ return pl_tab2(0, n);
}
/*******************************
* ENCODING *
*******************************/
typedef struct encname
{ IOENC code;
atom_t name;
} encoding_name;
INIT_DEF(struct encname, encoding_names, 10)
ADD_ENCODING( ENC_UNKNOWN, ATOM_unknown )
ADD_ENCODING( ENC_OCTET, ATOM_octet )
ADD_ENCODING( ENC_ASCII, ATOM_ascii )
ADD_ENCODING( ENC_ISO_LATIN_1, ATOM_iso_latin_1 )
ADD_ENCODING( ENC_ANSI, ATOM_text )
ADD_ENCODING( ENC_UTF8, ATOM_utf8 )
ADD_ENCODING( ENC_UNICODE_BE, ATOM_unicode_be )
ADD_ENCODING( ENC_UNICODE_LE, ATOM_unicode_le )
ADD_ENCODING( ENC_WCHAR, ATOM_wchar_t )
END_ENCODINGS( ENC_UNKNOWN, 0 )
IOENC
atom_to_encoding(atom_t a)
{ struct encname *en;
for(en=encoding_names; en->name; en++)
{ if ( en->name == a )
return en->code;
}
return ENC_UNKNOWN;
}
static atom_t
encoding_to_atom(IOENC enc)
{ return encoding_names[enc].name;
}
static int
bad_encoding(atom_t name)
{ GET_LD
term_t t = PL_new_term_ref();
PL_put_atom(t, name);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_encoding, t);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
fn_to_atom() translates a 8-bit filename into a unicode atom. The
encoding is generic `multibyte' on Unix systems and fixed to UTF-8 on
Windows, where the uxnt layer translates the UTF-8 sequences to the
Windows *W() functions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static atom_t
fn_to_atom(const char *fn)
{ PL_chars_t text;
atom_t a;
text.text.t = (char *)fn;
text.encoding = ((REP_FN&REP_UTF8) ? ENC_UTF8 :
(REP_FN&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
text.storage = PL_CHARS_HEAP;
text.length = strlen(fn);
text.canonical = FALSE;
a = textToAtom(&text);
PL_free_text(&text);
return a;
}
/********************************
* STREAM BASED I/O *
*********************************/
INIT_DEF(opt_spec, open4_options, 10)
ADD_OPEN4_OPT( ATOM_type, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_reposition, OPT_BOOL )
ADD_OPEN4_OPT( ATOM_alias, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_eof_action, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_close_on_abort, OPT_BOOL )
ADD_OPEN4_OPT( ATOM_buffer, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_lock, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_encoding, OPT_ATOM )
ADD_OPEN4_OPT( ATOM_bom, OPT_BOOL )
END_OPEN4_DEFS(NULL_ATOM, 0)
IOSTREAM *
openStream(term_t file, term_t mode, term_t options)
{ GET_LD
atom_t mname;
atom_t type = ATOM_text;
bool reposition = TRUE;
atom_t alias = NULL_ATOM;
atom_t eof_action = ATOM_eof_code;
atom_t buffer = ATOM_full;
atom_t lock = ATOM_none;
atom_t encoding = NULL_ATOM;
bool close_on_abort = TRUE;
bool bom = -1;
char how[10];
char *h = how;
char *path;
IOSTREAM *s;
IOENC enc;
if ( options )
{ if ( !
scan_options(options, 0, ATOM_stream_option, open4_options,
&type, &reposition, &alias, &eof_action,
&close_on_abort, &buffer, &lock, &encoding, &bom) )
fail;
}
/* MODE */
if ( PL_get_atom(mode, &mname) )
{ if ( mname == ATOM_write )
{ *h++ = 'w';
} else if ( mname == ATOM_append )
{ bom = FALSE;
*h++ = 'a';
} else if ( mname == ATOM_update )
{ bom = FALSE;
*h++ = 'u';
} else if ( mname == ATOM_read )
{ *h++ = 'r';
} else
{ PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_io_mode, mode);
return NULL;
}
} else
{ PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, mode);
return NULL;
}
/* ENCODING */
if ( encoding != NULL_ATOM )
{ enc = atom_to_encoding(encoding);
if ( enc == ENC_UNKNOWN )
{ bad_encoding(encoding);
return NULL;
}
} else if ( type == ATOM_binary )
{ enc = ENC_OCTET;
bom = FALSE;
} else
{ enc = LD->encoding;
}
if ( bom == -1 )
bom = (mname == ATOM_read ? TRUE : FALSE);
if ( type == ATOM_binary )
*h++ = 'b';
/* LOCK */
if ( lock != ATOM_none )
{ *h++ = 'l';
if ( lock == ATOM_read || lock == ATOM_shared )
*h++ = 'r';
else if ( lock == ATOM_write || lock == ATOM_exclusive )
*h++ = 'w';
else
{ term_t l = PL_new_term_ref();
PL_put_atom(l, lock);
PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_lock, l);
return NULL;
}
}
*h = EOS;
/* FILE */
if ( PL_get_chars(file, &path,
CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_FN) )
{ if ( !(s = Sopen_file(path, how)) )
{ PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
ATOM_open, ATOM_source_sink, file);
return NULL;
}
setFileNameStream(s, fn_to_atom(path));
}
#ifdef HAVE_POPEN
else if ( PL_is_functor(file, FUNCTOR_pipe1) )
{ term_t a = PL_new_term_ref();
char *cmd;
PL_get_arg(1, file, a);
if ( !PL_get_chars(a, &cmd, CVT_ATOM|CVT_STRING|REP_FN) )
{ PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, a);
return NULL;
}
if ( !(s = Sopen_pipe(cmd, how)) )
{ PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
ATOM_open, ATOM_source_sink, file);
return NULL;
}
}
#endif /*HAVE_POPEN*/
else
{ return NULL;
}
s->encoding = enc;
if ( !close_on_abort )
s->flags |= SIO_NOCLOSE;
if ( how[0] == 'r' )
{ if ( eof_action != ATOM_eof_code )
{ if ( eof_action == ATOM_reset )
s->flags |= SIO_NOFEOF;
else if ( eof_action == ATOM_error )
s->flags |= SIO_FEOF2ERR;
}
} else
{ if ( buffer != ATOM_full )
{ s->flags &= ~SIO_FBUF;
if ( buffer == ATOM_line )
s->flags |= SIO_LBUF;
if ( buffer == ATOM_false )
s->flags |= SIO_NBUF;
}
}
if ( alias != NULL_ATOM )
aliasStream(s, alias);
if ( !reposition )
s->position = NULL;
if ( bom )
{ if ( mname == ATOM_read )
{ if ( ScheckBOM(s) < 0 )
{ bom_error:
streamStatus(getStream(s));
return NULL;
}
} else
{ if ( SwriteBOM(s) < 0 )
goto bom_error;
}
}
return s;
}
static word
pl_open4(term_t file, term_t mode, term_t stream, term_t options)
{ IOSTREAM *s = openStream(file, mode, options);
if ( s )
return PL_unify_stream_or_alias(stream, s);
fail;
}
static word
pl_open(term_t file, term_t mode, term_t stream)
{ return pl_open4(file, mode, stream, 0);
}
/*******************************
* EDINBURGH I/O *
*******************************/
static IOSTREAM *
findStreamFromFile(atom_t name, unsigned int flags)
{ TableEnum e;
Symbol symb;
IOSTREAM *s = NULL;
e = newTableEnum(streamContext);
while( (symb=advanceTableEnum(e)) )
{ stream_context *ctx = symb->value;
if ( ctx->filename == name &&
true(ctx, flags) )
{ s = symb->name;
break;
}
}
freeTableEnum(e);
return s;
}
static word
pl_see(term_t f)
{ GET_LD
IOSTREAM *s;
atom_t a;
term_t mode;
LOCK();
if ( get_stream_handle(f, &s, SH_ALIAS|SH_UNLOCKED) )
{ Scurin = s;
goto ok;
}
if ( PL_get_atom(f, &a) && a == ATOM_user )
{ Scurin = Suser_input;
goto ok;
}
if ( (s = findStreamFromFile(a, IO_SEE)) )
{ Scurin = s;
goto ok;
}
mode = PL_new_term_ref();
PL_put_atom(mode, ATOM_read);
if ( !(s = openStream(f, mode, 0)) )
{ UNLOCK();
fail;
}
set(getStreamContext(s), IO_SEE);
pl_push_input_context();
Scurin = s;
ok:
UNLOCK();
succeed;
}
static word
pl_seeing(term_t f)
{ GET_LD
if ( Scurin == Suser_input )
return PL_unify_atom(f, ATOM_user);
return pl_current_input(f);
}
static word
pl_seen(void)
{ GET_LD
IOSTREAM *s = getStream(Scurin);
pl_pop_input_context();
if ( s->flags & SIO_NOFEOF )
succeed;
return closeStream(s);
}
/* MT: Does not create a lock on the stream
*/
static word
do_tell(term_t f, atom_t m)
{ GET_LD
IOSTREAM *s;
atom_t a;
term_t mode;
LOCK();
if ( get_stream_handle(f, &s, SH_UNLOCKED) )
{ Scurout = s;
goto ok;
}
if ( PL_get_atom(f, &a) && a == ATOM_user )
{ Scurout = Suser_output;
goto ok;
}
if ( (s = findStreamFromFile(a, IO_TELL)) )
{ Scurout = s;
goto ok;
}
mode = PL_new_term_ref();
PL_put_atom(mode, m);
if ( !(s = openStream(f, mode, 0)) )
{ UNLOCK();
fail;
}
set(getStreamContext(s), IO_TELL);
pushOutputContext();
Scurout = s;
ok:
UNLOCK();
succeed;
}
static word
pl_tell(term_t f)
{ return do_tell(f, ATOM_write);
}
static word
pl_append(term_t f)
{ return do_tell(f, ATOM_append);
}
static word
pl_telling(term_t f)
{ GET_LD
if ( Scurout == Suser_output )
return PL_unify_atom(f, ATOM_user);
return pl_current_output(f);
}
static word
pl_told(void)
{ GET_LD
IOSTREAM *s = getStream(Scurout);
popOutputContext();
if ( s->flags & SIO_NOFEOF )
succeed;
return closeStream(s);
}
/*******************************
* NULL-STREAM *
*******************************/
static ssize_t
Swrite_null(void *handle, char *buf, size_t size)
{ return size;
}
static ssize_t
Sread_null(void *handle, char *buf, size_t size)
{ return 0;
}
static long
Sseek_null(void *handle, long offset, int whence)
{ switch(whence)
{ case SIO_SEEK_SET:
return offset;
case SIO_SEEK_CUR:
case SIO_SEEK_END:
default:
return -1;
}
}
static int
Sclose_null(void *handle)
{ return 0;
}
static const IOFUNCTIONS nullFunctions =
{ Sread_null,
Swrite_null,
Sseek_null,
Sclose_null
};
static word
pl_open_null_stream(term_t stream)
{ int sflags = SIO_NBUF|SIO_RECORDPOS|SIO_OUTPUT;
IOSTREAM *s = Snew((void *)NULL, sflags, (IOFUNCTIONS *)&nullFunctions);
if ( s )
{ s->encoding = ENC_UTF8;
return PL_unify_stream_or_alias(stream, s);
}
fail;
}
static word
pl_close(term_t stream)
{ IOSTREAM *s;
if ( PL_get_stream_handle(stream, &s) )
return closeStream(s);
fail;
}
INIT_DEF(opt_spec, close2_options, 2)
ADD_CLOSE2_OPT( ATOM_force, OPT_BOOL )
END_CLOSE2_DEFS( NULL_ATOM, 0 )
static word
pl_close2(term_t stream, term_t options)
{ IOSTREAM *s;
bool force = FALSE;
if ( !scan_options(options, 0, ATOM_close_option, close2_options, &force) )
fail;
if ( !force )
return pl_close(stream);
if ( !PL_get_stream_handle(stream, &s) )
fail;
if ( s == Sinput )
Sclearerr(s);
else if ( s == Soutput || s == Serror )
{ Sflush(s);
Sclearerr(s);
} else
{ Sflush(s);
Sclose(s);
}
succeed;
}
/*******************************
* STREAM-PROPERTY *
*******************************/
static int
stream_file_name_propery(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t name;
if ( (name = getStreamContext(s)->filename) )
{ return PL_unify_atom(prop, name);
}
fail;
}
static int
stream_mode_property(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t mode;
if ( s->flags & SIO_INPUT )
mode = ATOM_read;
else
{ assert(s->flags & SIO_OUTPUT);
if ( s->flags & SIO_APPEND )
mode = ATOM_append;
else if ( s->flags & SIO_UPDATE )
mode = ATOM_update;
else
mode = ATOM_write;
}
return PL_unify_atom(prop, mode);
}
static int
stream_input_prop(IOSTREAM *s ARG_LD)
{ return (s->flags & SIO_INPUT) ? TRUE : FALSE;
}
static int
stream_output_prop(IOSTREAM *s ARG_LD)
{ return (s->flags & SIO_OUTPUT) ? TRUE : FALSE;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Incomplete: should be non-deterministic if the stream has multiple aliases!
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
stream_alias_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t name;
stream_context *ctx = getStreamContext(s);
int i;
if ( PL_get_atom(prop, &name) )
{ alias *a;
for( a = ctx->alias_head; a; a = a->next )
{ if ( a->name == name )
return TRUE;
}
if ( (i=standardStreamIndexFromName(name)) >= 0 &&
i < 6 &&
s == LD->IO.streams[i] )
return TRUE;
return FALSE;
}
if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 )
return PL_unify_atom(prop, standardStreams[i]);
if ( ctx->alias_head )
return PL_unify_atom(prop, ctx->alias_head->name);
return FALSE;
}
static int
stream_position_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( s->position )
{ return PL_unify_term(prop,
PL_FUNCTOR, FUNCTOR_stream_position4,
PL_INT64, s->position->charno,
PL_INT, s->position->lineno,
PL_INT, s->position->linepos,
PL_INT64, s->position->byteno);
}
fail;
}
static int
stream_end_of_stream_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( s->flags & SIO_INPUT )
{ GET_LD
atom_t val;
if ( s->flags & SIO_FEOF2 )
val = ATOM_past;
else if ( s->flags & SIO_FEOF )
val = ATOM_at;
else
val = ATOM_not;
return PL_unify_atom(prop, val);
}
return FALSE;
}
static int
stream_eof_action_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t val;
if ( s->flags & SIO_NOFEOF )
val = ATOM_reset;
else if ( s->flags & SIO_FEOF2ERR )
val = ATOM_error;
else
val = ATOM_eof_code;
return PL_unify_atom(prop, val);
}
#ifdef HAVE_FSTAT
#include <sys/stat.h>
#endif
#if !defined(S_ISREG) && defined(S_IFREG)
#define S_ISREG(m) ((m&S_IFMT) == S_IFREG)
#endif
static int
stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t val;
if ( s->functions->seek )
{
#ifdef HAVE_FSTAT
int fd = Sfileno(s);
struct stat buf;
if ( fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) )
val = ATOM_true;
else
val = ATOM_false;
#else
val = ATOM_true;
#endif
} else
val = ATOM_false;
return PL_unify_atom(prop, val);
}
static int
stream_close_on_abort_prop(IOSTREAM *s, term_t prop ARG_LD)
{ return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE));
}
static int
stream_type_prop(IOSTREAM *s, term_t prop ARG_LD)
{ return PL_unify_atom(prop, s->flags & SIO_TEXT ? ATOM_text : ATOM_binary);
}
static int
stream_file_no_prop(IOSTREAM *s, term_t prop ARG_LD)
{ int fd;
if ( (fd = Sfileno(s)) >= 0 )
return PL_unify_integer(prop, fd);
fail;
}
static int
stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( (s->flags & SIO_ISATTY) )
return PL_unify_bool_ex(prop, TRUE);
fail;
}
static int
stream_bom_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( (s->flags & SIO_BOM) )
return PL_unify_bool_ex(prop, TRUE);
fail;
}
static int
stream_newline_prop(IOSTREAM *s, term_t prop ARG_LD)
{ switch ( s->newline )
{ case SIO_NL_POSIX:
case SIO_NL_DETECT:
return PL_unify_atom(prop, ATOM_posix);
case SIO_NL_DOS:
return PL_unify_atom(prop, ATOM_dos);
}
fail;
}
static int
stream_encoding_prop(IOSTREAM *s, term_t prop ARG_LD)
{ return PL_unify_atom(prop, encoding_to_atom(s->encoding));
}
static int
stream_reperror_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t a;
if ( (s->flags & SIO_REPXML) )
a = ATOM_xml;
else if ( (s->flags & SIO_REPPL) )
a = ATOM_prolog;
else
a = ATOM_error;
return PL_unify_atom(prop, a);
}
static int
stream_buffer_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t b;
if ( s->flags & SIO_FBUF )
b = ATOM_full;
else if ( s->flags & SIO_LBUF )
b = ATOM_line;
else /*if ( s->flags & SIO_NBUF )*/
b = ATOM_false;
return PL_unify_atom(prop, b);
}
static int
stream_buffer_size_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( (s->flags & SIO_NBUF) )
fail;
return PL_unify_integer(prop, s->bufsize);
}
static int
stream_timeout_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( s->timeout == -1 )
return PL_unify_atom(prop, ATOM_infinite);
return PL_unify_float(prop, (double)s->timeout/1000.0);
}
typedef struct
{ functor_t functor; /* functor of property */
int (*function)(); /* function to generate */
} sprop;
INIT_DEF(sprop, sprop_list, 24)
ADD_SPROP( FUNCTOR_file_name1, stream_file_name_propery )
ADD_SPROP( FUNCTOR_mode1, stream_mode_property )
ADD_SPROP( FUNCTOR_input0, stream_input_prop )
ADD_SPROP( FUNCTOR_output0, stream_output_prop )
ADD_SPROP( FUNCTOR_alias1, stream_alias_prop )
ADD_SPROP( FUNCTOR_position1, stream_position_prop )
ADD_SPROP( FUNCTOR_end_of_stream1, stream_end_of_stream_prop )
ADD_SPROP( FUNCTOR_eof_action1, stream_eof_action_prop )
ADD_SPROP( FUNCTOR_reposition1, stream_reposition_prop )
ADD_SPROP( FUNCTOR_type1, stream_type_prop )
ADD_SPROP( FUNCTOR_file_no1, stream_file_no_prop )
ADD_SPROP( FUNCTOR_buffer1, stream_buffer_prop )
ADD_SPROP( FUNCTOR_buffer_size1, stream_buffer_size_prop )
ADD_SPROP( FUNCTOR_close_on_abort1,stream_close_on_abort_prop )
ADD_SPROP( FUNCTOR_tty1, stream_tty_prop )
ADD_SPROP( FUNCTOR_encoding1, stream_encoding_prop )
ADD_SPROP( FUNCTOR_bom1, stream_bom_prop )
ADD_SPROP( FUNCTOR_newline1, stream_newline_prop )
ADD_SPROP( FUNCTOR_representation_errors1, stream_reperror_prop )
ADD_SPROP( FUNCTOR_timeout1, stream_timeout_prop )
END_SPROP_DEFS( 0, NULL)
typedef struct
{ TableEnum e; /* Enumerator on stream-table */
IOSTREAM *s; /* Stream we are enumerating */
const sprop *p; /* Pointer in properties */
int fixed_p; /* Propety is given */
} prop_enum;
static foreign_t
pl_stream_property(term_t stream, term_t property, control_t h)
{ GET_LD
IOSTREAM *s;
prop_enum *pe;
fid_t fid;
term_t a1;
switch( ForeignControl(h) )
{ case FRG_FIRST_CALL:
a1 = PL_new_term_ref();
if ( PL_is_variable(stream) ) /* generate */
{ const sprop *p = sprop_list;
int fixed = FALSE;
functor_t f;
if ( PL_get_functor(property, &f) ) /* test for defined property */
{ for( ; p->functor; p++ )
{ if ( f == p->functor )
{ fixed = TRUE;
break;
}
}
if ( !p->functor )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_stream_property, property);
}
pe = allocHeap(sizeof(*pe));
pe->e = newTableEnum(streamContext);
pe->s = NULL;
pe->p = p;
pe->fixed_p = fixed;
break;
}
LOCK(); /* given stream */
if ( get_stream_handle(stream, &s, SH_ERRORS|SH_UNLOCKED) )
{ functor_t f;
if ( PL_is_variable(property) ) /* generate properties */
{ pe = allocHeap(sizeof(*pe));
pe->e = NULL;
pe->s = s;
pe->p = sprop_list;
pe->fixed_p = FALSE;
UNLOCK();
break;
}
if ( PL_get_functor(property, &f) )
{ const sprop *p = sprop_list;
for( ; p->functor; p++ )
{ if ( f == p->functor )
{ int rval;
switch(arityFunctor(f))
{ case 0:
rval = (*p->function)(s PASS_LD);
break;
case 1:
{ term_t a1 = PL_new_term_ref();
_PL_get_arg(1, property, a1);
rval = (*p->function)(s, a1 PASS_LD);
break;
}
default:
assert(0);
rval = FALSE;
}
UNLOCK();
return rval;
}
}
} else
{ UNLOCK();
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_stream_property, property);
}
}
UNLOCK();
fail; /* bad stream handle */
case FRG_REDO:
{ pe = ForeignContextPtr(h);
a1 = PL_new_term_ref();
break;
}
case FRG_CUTTED:
{ pe = ForeignContextPtr(h);
if ( pe ) /* 0 if exception on FRG_FIRST_CALL */
{ if ( pe->e )
freeTableEnum(pe->e);
freeHeap(pe, sizeof(*pe));
}
succeed;
}
default:
assert(0);
fail;
}
fid = PL_open_foreign_frame();
for(;;)
{ if ( pe->s ) /* given stream */
{ fid_t fid2;
if ( PL_is_variable(stream) )
{ if ( !PL_unify_stream(stream, pe->s) )
goto enum_e;
}
fid2 = PL_open_foreign_frame();
for( ; pe->p->functor ; pe->p++ )
{ if ( PL_unify_functor(property, pe->p->functor) )
{ int rval;
switch(arityFunctor(pe->p->functor))
{ case 0:
rval = (*pe->p->function)(pe->s PASS_LD);
break;
case 1:
{ _PL_get_arg(1, property, a1);
rval = (*pe->p->function)(pe->s, a1 PASS_LD);
break;
}
default:
assert(0);
rval = FALSE;
}
if ( rval )
{ if ( pe->fixed_p )
pe->s = NULL;
else
pe->p++;
ForeignRedoPtr(pe);
}
}
if ( pe->fixed_p )
break;
PL_rewind_foreign_frame(fid2);
}
PL_close_foreign_frame(fid2);
pe->s = NULL;
}
enum_e:
if ( pe->e )
{ Symbol symb;
while ( (symb=advanceTableEnum(pe->e)) )
{ PL_rewind_foreign_frame(fid);
if ( PL_unify_stream(stream, symb->name) )
{ pe->s = symb->name;
if ( !pe->fixed_p )
pe->p = sprop_list;
break;
}
}
}
if ( !pe->s )
{ if ( pe->e )
freeTableEnum(pe->e);
freeHeap(pe, sizeof(*pe));
fail;
}
}
}
static
PRED_IMPL("is_stream", 1, is_stream, 0)
{ GET_LD
IOSTREAM *s;
if ( get_stream_handle(A1, &s, SH_SAFE) )
{ releaseStream(s);
succeed;
}
fail;
}
/*******************************
* FLUSH *
*******************************/
static word
pl_flush_output1(term_t out)
{ IOSTREAM *s;
if ( getOutputStream(out, &s) )
{ Sflush(s);
return streamStatus(s);
}
fail;
}
static word
pl_flush_output(void)
{ return pl_flush_output1(0);
}
static int
getStreamWithPosition(term_t stream, IOSTREAM **sp)
{ IOSTREAM *s;
if ( PL_get_stream_handle(stream, &s) )
{ if ( !s->position )
{ PL_error(NULL, 0, NULL, ERR_PERMISSION, /* non-ISO */
ATOM_property, ATOM_position, stream);
releaseStream(s);
return FALSE;
}
*sp = s;
return TRUE;
}
return FALSE;
}
static int
getRepositionableStream(term_t stream, IOSTREAM **sp)
{ GET_LD
IOSTREAM *s;
if ( get_stream_handle(stream, &s, SH_ERRORS) )
{ if ( !s->position || !s->functions || !s->functions->seek )
{ PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_reposition, ATOM_stream, stream);
releaseStream(s);
return FALSE;
}
*sp = s;
return TRUE;
}
return FALSE;
}
static word
pl_set_stream_position(term_t stream, term_t pos)
{ GET_LD
IOSTREAM *s;
int64_t charno, byteno;
long linepos, lineno;
term_t a = PL_new_term_ref();
if ( !(getRepositionableStream(stream, &s)) )
fail;
if ( !PL_is_functor(pos, FUNCTOR_stream_position4) ||
!PL_get_arg(1, pos, a) ||
!PL_get_int64(a, &charno) ||
!PL_get_arg(2, pos, a) ||
!PL_get_long(a, &lineno) ||
!PL_get_arg(3, pos, a) ||
!PL_get_long(a, &linepos) ||
!PL_get_arg(4, pos, a) ||
!PL_get_int64(a, &byteno) )
{ releaseStream(s);
return PL_error("stream_position", 3, NULL,
ERR_DOMAIN, ATOM_stream_position, pos);
}
if ( Sseek64(s, byteno, SIO_SEEK_SET) != 0 )
return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
ATOM_reposition, ATOM_stream, stream);
s->position->byteno = byteno;
s->position->charno = charno;
s->position->lineno = (int)lineno;
s->position->linepos = (int)linepos;
releaseStream(s);
succeed;
}
static word
pl_seek(term_t stream, term_t offset, term_t method, term_t newloc)
{ GET_LD
atom_t m;
int whence = -1;
int64_t off, new;
IOSTREAM *s;
if ( !(PL_get_atom_ex(method, &m)) )
return FALSE;
if ( m == ATOM_bof )
whence = SIO_SEEK_SET;
else if ( m == ATOM_current )
whence = SIO_SEEK_CUR;
else if ( m == ATOM_eof )
whence = SIO_SEEK_END;
else
return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_seek_method, method);
if ( !PL_get_int64(offset, &off) )
return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_integer, offset);
if ( PL_get_stream_handle(stream, &s) )
{ int unit = Sunit_size(s);
off *= unit;
if ( Sseek64(s, off, whence) < 0 )
{ if ( errno == EINVAL )
PL_error("seek", 4, "offset out of range", ERR_DOMAIN,
ATOM_position, offset);
else
PL_error("seek", 4, OsError(), ERR_PERMISSION,
ATOM_reposition, ATOM_stream, stream);
releaseStream(s);
fail;
}
new = Stell64(s);
releaseStream(s);
new /= unit;
return PL_unify_int64(newloc, new);
}
fail;
}
static word
pl_set_input(term_t stream)
{ GET_LD
IOSTREAM *s;
if ( getInputStream(stream, &s) )
{ Scurin = s;
releaseStream(s);
return TRUE;
}
return FALSE;
}
static word
pl_set_output(term_t stream)
{ GET_LD
IOSTREAM *s;
if ( getOutputStream(stream, &s) )
{ Scurout = s;
releaseStream(s);
return TRUE;
}
return FALSE;
}
word
pl_current_input(term_t stream)
{ GET_LD
return PL_unify_stream(stream, Scurin);
}
word
pl_current_output(term_t stream)
{ GET_LD
return PL_unify_stream(stream, Scurout);
}
static
PRED_IMPL("byte_count", 2, byte_count, 0)
{ IOSTREAM *s;
if ( getStreamWithPosition(A1, &s) )
{ int64_t n = s->position->byteno;
releaseStream(s);
return PL_unify_int64(A2, n);
}
fail;
}
static
PRED_IMPL("character_count", 2, character_count, 0)
{ IOSTREAM *s;
if ( getStreamWithPosition(A1, &s) )
{ int64_t n = s->position->charno;
releaseStream(s);
return PL_unify_int64(A2, n);
}
fail;
}
static
PRED_IMPL("line_count", 2, line_count, 0)
{ GET_LD
IOSTREAM *s;
if ( getStreamWithPosition(A1, &s) )
{ intptr_t n = s->position->lineno;
releaseStream(s);
return PL_unify_integer(A2, n);
}
fail;
}
static
PRED_IMPL("line_position", 2, line_position, 0)
{ GET_LD
IOSTREAM *s;
if ( getStreamWithPosition(A1, &s) )
{ intptr_t n = s->position->linepos;
releaseStream(s);
return PL_unify_integer(A2, n);
}
fail;
}
static word
pl_source_location(term_t file, term_t line)
{ GET_LD
if ( ReadingSource &&
PL_unify_atom(file, source_file_name) &&
PL_unify_integer(line, source_line_no) )
succeed;
fail;
}
static word
pl_at_end_of_stream1(term_t stream)
{ GET_LD
IOSTREAM *s;
if ( getInputStream(stream, &s) )
{ int rval = Sfeof(s);
if ( rval < 0 )
{ PL_error(NULL, 0, "not-buffered stream", ERR_PERMISSION,
ATOM_end_of_stream, ATOM_stream, stream);
rval = FALSE;
}
if ( rval && Sferror(s) ) /* due to error */
return streamStatus(s);
else
releaseStream(s);
return rval;
}
return FALSE; /* exception */
}
static word
pl_at_end_of_stream0(void)
{ return pl_at_end_of_stream1(0);
}
static foreign_t
peek(term_t stream, term_t chr, int how)
{ GET_LD
IOSTREAM *s;
IOPOS pos;
int c;
if ( !getInputStream(stream, &s) )
fail;
pos = s->posbuf;
if ( how == BYTE_MODE )
{ c = Sgetc(s);
if ( c != EOF )
Sungetc(c, s);
} else
{ c = Sgetcode(s);
if ( c != EOF )
Sungetcode(c, s);
}
s->posbuf = pos;
if ( Sferror(s) )
return streamStatus(s);
releaseStream(s);
return PL_unify_char(chr, c, how);
}
static
PRED_IMPL("peek_byte", 2, peek_byte2, 0)
{ return peek(A1, A2, BYTE_MODE);
}
static
PRED_IMPL("peek_byte", 1, peek_byte1, 0)
{ return peek(0, A1, BYTE_MODE);
}
static
PRED_IMPL("peek_code", 2, peek_code2, 0)
{ return peek(A1, A2, CODE_MODE);
}
static
PRED_IMPL("peek_code", 1, peek_code1, 0)
{ return peek(0, A1, CODE_MODE);
}
static
PRED_IMPL("peek_char", 2, peek_char2, 0)
{ return peek(A1, A2, CHAR_MODE);
}
static
PRED_IMPL("peek_char", 1, peek_char1, 0)
{ return peek(0, A1, CHAR_MODE);
}
/*******************************
* INTERACTION *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
set_prolog_OI(+In, +Out, +Error)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
typedef struct wrappedIO
{ void *wrapped_handle; /* original handle */
IOFUNCTIONS *wrapped_functions; /* original functions */
IOSTREAM *wrapped_stream; /* stream we wrapped */
IOFUNCTIONS functions; /* new function block */
} wrappedIO;
static ssize_t
Sread_user(void *handle, char *buf, size_t size)
{ GET_LD
wrappedIO *wio = handle;
if ( LD->prompt.next && ttymode != TTY_RAW )
PL_write_prompt(TRUE);
else
Sflush(Suser_output);
size = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size);
if ( size == 0 ) /* end-of-file */
{ Sclearerr(Suser_input);
LD->prompt.next = TRUE;
} else if ( size > 0 && buf[size-1] == '\n' )
LD->prompt.next = TRUE;
return size;
}
static int
closeWrappedIO(void *handle)
{ wrappedIO *wio = handle;
int rval;
if ( wio->wrapped_functions->close )
rval = (*wio->wrapped_functions->close)(wio->wrapped_handle);
else
rval = 0;
wio->wrapped_stream->functions = wio->wrapped_functions;
wio->wrapped_stream->handle = wio->wrapped_handle;
PL_free(wio);
return rval;
}
static void
wrapIO(IOSTREAM *s,
ssize_t (*read)(void *, char *, size_t),
ssize_t (*write)(void *, char *, size_t))
{ wrappedIO *wio = PL_malloc(sizeof(*wio));
wio->wrapped_functions = s->functions;
wio->wrapped_handle = s->handle;
wio->wrapped_stream = s;
wio->functions = *s->functions;
if ( read ) wio->functions.read = read;
if ( write ) wio->functions.write = write;
wio->functions.close = closeWrappedIO;
s->functions = &wio->functions;
s->handle = wio;
}
static
PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
{ PRED_LD
IOSTREAM *in = NULL, *out = NULL, *error = NULL;
int rval = FALSE;
if ( !PL_get_stream_handle(A1, &in) ||
!PL_get_stream_handle(A2, &out) )
goto out;
if ( PL_compare(A2, A3) == 0 ) /* == */
{ error = getStream(Snew(out->handle, out->flags, out->functions));
error->flags &= ~SIO_ABUF; /* disable buffering */
error->flags |= SIO_NBUF;
} else
{ if ( !PL_get_stream_handle(A3, &error) )
goto out;
}
LOCK();
out->flags &= ~SIO_ABUF; /* output: line buffered */
out->flags |= SIO_LBUF;
LD->IO.streams[0] = in; /* user_input */
LD->IO.streams[1] = out; /* user_output */
LD->IO.streams[2] = error; /* user_error */
LD->IO.streams[3] = in; /* current_input */
LD->IO.streams[4] = out; /* current_output */
wrapIO(in, Sread_user, NULL);
LD->prompt.next = TRUE;
UNLOCK();
rval = TRUE;
out:
if ( in )
releaseStream(in);
if ( out )
releaseStream(out);
if ( error && error != out )
releaseStream(error);
return rval;
}
/********************************
* FILES *
*********************************/
static bool
unifyTime(term_t t, intptr_t time)
{ return PL_unify_float(t, (double)time);
}
static void
add_option(term_t options, functor_t f, atom_t val)
{ GET_LD
term_t head = PL_new_term_ref();
PL_unify_list(options, head, options);
PL_unify_term(head, PL_FUNCTOR, f, PL_ATOM, val);
PL_reset_term_refs(head);
}
#define CVT_FILENAME (CVT_ATOM|CVT_STRING|CVT_LIST)
static int
PL_get_file_name(term_t n, char **namep, int flags)
{ GET_LD
char *name;
char tmp[MAXPATHLEN];
char ospath[MAXPATHLEN];
if ( flags & PL_FILE_SEARCH )
{ predicate_t pred = PL_predicate("absolute_file_name", 3, "system");
term_t av = PL_new_term_refs(3);
term_t options = PL_copy_term_ref(av+2);
int cflags = ((flags&PL_FILE_NOERRORS) ? PL_Q_CATCH_EXCEPTION
: PL_Q_PASS_EXCEPTION);
PL_put_term(av+0, n);
if ( flags & PL_FILE_EXIST )
add_option(options, FUNCTOR_access1, ATOM_exist);
if ( flags & PL_FILE_READ )
add_option(options, FUNCTOR_access1, ATOM_read);
if ( flags & PL_FILE_WRITE )
add_option(options, FUNCTOR_access1, ATOM_write);
if ( flags & PL_FILE_EXECUTE )
add_option(options, FUNCTOR_access1, ATOM_execute);
PL_unify_nil(options);
if ( !PL_call_predicate(NULL, cflags, pred, av) )
fail;
return PL_get_chars_ex(av+1, namep, CVT_ATOMIC|BUF_RING|REP_FN);
}
if ( flags & PL_FILE_NOERRORS )
{ if ( !PL_get_chars(n, &name, CVT_FILENAME|REP_FN) )
fail;
} else
{ if ( !PL_get_chars_ex(n, &name, CVT_FILENAME|REP_FN) )
fail;
}
if ( trueFeature(FILEVARS_FEATURE) )
{ if ( !(name = ExpandOneFile(name, tmp)) )
fail;
}
if ( !(flags & PL_FILE_NOERRORS) )
{ atom_t op = 0;
if ( (flags&PL_FILE_READ) && !AccessFile(name, ACCESS_READ) )
op = ATOM_read;
if ( !op && (flags&PL_FILE_WRITE) && !AccessFile(name, ACCESS_WRITE) )
op = ATOM_write;
if ( !op && (flags&PL_FILE_EXECUTE) && !AccessFile(name, ACCESS_EXECUTE) )
op = ATOM_execute;
if ( op )
return PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_file, op, n);
if ( (flags & PL_FILE_EXIST) && !AccessFile(name, ACCESS_EXIST) )
return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_file, n);
}
if ( flags & PL_FILE_ABSOLUTE )
{ if ( !(name = AbsoluteFile(name, tmp)) )
fail;
}
if ( flags & PL_FILE_OSPATH )
{ if ( !(name = OsPath(name, ospath)) )
fail;
}
*namep = buffer_string(name, BUF_RING);
succeed;
}
static word
pl_time_file(term_t name, term_t t)
{ char *fn;
if ( PL_get_file_name(name, &fn, 0) )
{ intptr_t time;
if ( (time = LastModifiedFile(fn)) == -1 )
return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION, ATOM_time, ATOM_file, name);
return unifyTime(t, time);
}
fail;
}
static word
pl_size_file(term_t name, term_t len)
{ char *n;
if ( PL_get_file_name(name, &n, 0) )
{ int64_t size;
if ( (size = SizeFile(n)) < 0 )
return PL_error("size_file", 2, OsError(), ERR_FILE_OPERATION,
ATOM_size, ATOM_file, name);
return PL_unify_int64(len, size);
}
fail;
}
static word
pl_size_stream(term_t stream, term_t len)
{ GET_LD
IOSTREAM *s;
int rval;
if ( !PL_get_stream_handle(stream, &s) )
fail;
rval = PL_unify_integer(len, Ssize(s));
PL_release_stream(s);
return rval;
}
static word
pl_access_file(term_t name, term_t mode)
{ GET_LD
char *n;
int md;
atom_t m;
if ( !PL_get_atom(mode, &m) )
return PL_error("access_file", 2, NULL, ERR_TYPE, ATOM_atom, mode);
if ( !PL_get_file_name(name, &n, 0) )
fail;
if ( m == ATOM_none )
succeed;
if ( m == ATOM_write || m == ATOM_append )
md = ACCESS_WRITE;
else if ( m == ATOM_read )
md = ACCESS_READ;
else if ( m == ATOM_execute )
md = ACCESS_EXECUTE;
else if ( m == ATOM_exist )
md = ACCESS_EXIST;
else
return PL_error("access_file", 2, NULL, ERR_DOMAIN, ATOM_io_mode, mode);
if ( AccessFile(n, md) )
succeed;
if ( md == ACCESS_WRITE && !AccessFile(n, ACCESS_EXIST) )
{ char tmp[MAXPATHLEN];
char *dir = DirName(n, tmp);
if ( dir[0] )
{ if ( !ExistsDirectory(dir) )
fail;
}
if ( AccessFile(dir[0] ? dir : ".", md) )
succeed;
}
fail;
}
static word
pl_read_link(term_t file, term_t link, term_t to)
{ char *n, *l, *t;
char buf[MAXPATHLEN];
if ( !PL_get_file_name(file, &n, 0) )
fail;
if ( (l = ReadLink(n, buf)) &&
PL_unify_atom_chars(link, l) &&
(t = DeRefLink(n, buf)) &&
PL_unify_atom_chars(to, t) )
succeed;
fail;
}
word
pl_exists_file(term_t name)
{ char *n;
if ( !PL_get_file_name(name, &n, 0) )
fail;
return ExistsFile(n);
}
static word
pl_exists_directory(term_t name)
{ char *n;
if ( !PL_get_file_name(name, &n, 0) )
fail;
return ExistsDirectory(n);
}
static word
pl_tmp_file(term_t base, term_t name)
{ GET_LD
char *n;
if ( !PL_get_chars(base, &n, CVT_ALL) )
return PL_error("tmp_file", 2, NULL, ERR_TYPE, ATOM_atom, base);
return PL_unify_atom(name, TemporaryFile(n));
}
static word
pl_delete_file(term_t name)
{ char *n;
if ( !PL_get_file_name(name, &n, 0) )
fail;
if ( RemoveFile(n) )
succeed;
return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
ATOM_delete, ATOM_file, name);
}
static word
pl_delete_directory(term_t name)
{ char *n;
if ( !PL_get_file_name(name, &n, 0) )
fail;
if ( rmdir(n) == 0 )
succeed;
else
return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
ATOM_delete, ATOM_directory, name);
}
static word
pl_make_directory(term_t name)
{ char *n;
if ( !PL_get_file_name(name, &n, 0) )
fail;
if ( mkdir(n, 0777) == 0 )
succeed;
else
return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
ATOM_create, ATOM_directory, name);
}
static word
pl_same_file(term_t file1, term_t file2)
{ char *n1, *n2;
if ( PL_get_file_name(file1, &n1, 0) &&
PL_get_file_name(file2, &n2, 0) )
return SameFile(n1, n2);
fail;
}
static word
pl_rename_file(term_t old, term_t new)
{ GET_LD
char *o, *n;
if ( PL_get_file_name(old, &o, 0) &&
PL_get_file_name(new, &n, 0) )
{ if ( SameFile(o, n) )
{ if ( fileerrors )
return PL_error("rename_file", 2, "same file", ERR_PERMISSION,
ATOM_rename, ATOM_file, old);
fail;
}
if ( RenameFile(o, n) )
succeed;
if ( fileerrors )
return PL_error("rename_file", 2, OsError(), ERR_FILE_OPERATION,
ATOM_rename, ATOM_file, old);
fail;
}
fail;
}
static word
pl_fileerrors(term_t old, term_t new)
{ GET_LD
return setBoolean(&fileerrors, old, new);
}
static word
pl_absolute_file_name(term_t name, term_t expanded)
{ char *n;
char tmp[MAXPATHLEN];
if ( PL_get_file_name(name, &n, 0) &&
(n = AbsoluteFile(n, tmp)) )
return PL_unify_chars(expanded, PL_ATOM|REP_FN, -1, n);
fail;
}
static word
pl_is_absolute_file_name(term_t name)
{ char *n;
if ( PL_get_file_name(name, &n, 0) &&
IsAbsolutePath(n) )
succeed;
fail;
}
static word
pl_working_directory(term_t old, term_t new)
{ GET_LD
const char *wd;
if ( !(wd = PL_cwd()) )
fail;
if ( PL_unify_chars(old, PL_ATOM|REP_FN, -1, wd) )
{ if ( PL_compare(old, new) != 0 )
{ char *n;
if ( PL_get_file_name(new, &n, 0) )
{ if ( ChDir(n) )
succeed;
if ( fileerrors )
return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
ATOM_chdir, ATOM_directory, new);
fail;
}
}
succeed;
}
fail;
}
static word
pl_file_base_name(term_t f, term_t b)
{ char *n;
if ( !PL_get_chars_ex(f, &n, CVT_ALL|REP_FN) )
fail;
return PL_unify_chars(b, PL_ATOM|REP_FN, -1, BaseName(n));
}
static word
pl_file_dir_name(term_t f, term_t b)
{ char *n;
char tmp[MAXPATHLEN];
if ( !PL_get_chars_ex(f, &n, CVT_ALL|REP_FN) )
fail;
return PL_unify_chars(b, PL_ATOM|REP_FN, -1, DirName(n, tmp));
}
static int
has_extension(const char *name, const char *ext)
{ GET_LD
const char *s = name + strlen(name);
if ( ext[0] == EOS )
succeed;
while(*s != '.' && *s != '/' && s > name)
s--;
if ( *s == '.' && s > name && s[-1] != '/' )
{ if ( ext[0] == '.' )
ext++;
if ( trueFeature(FILE_CASE_FEATURE) )
return strcmp(&s[1], ext) == 0;
else
return strcasecmp(&s[1], ext) == 0;
}
fail;
}
static int
name_too_long(void)
{ return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
}
static word
pl_file_name_extension(term_t base, term_t ext, term_t full)
{ GET_LD
char *b = NULL, *e = NULL, *f;
char buf[MAXPATHLEN];
if ( !PL_is_variable(full) )
{ if ( PL_get_chars(full, &f, CVT_ALL|CVT_EXCEPTION|REP_FN) )
{ char *s = f + strlen(f); /* ?base, ?ext, +full */
while(*s != '.' && *s != '/' && s > f)
s--;
if ( *s == '.' )
{ if ( PL_get_chars(ext, &e, CVT_ALL|REP_FN) )
{ if ( e[0] == '.' )
e++;
if ( trueFeature(FILE_CASE_FEATURE) )
{ TRY(strcmp(&s[1], e) == 0);
} else
{ TRY(strcasecmp(&s[1], e) == 0);
}
} else
{ TRY(PL_unify_chars(ext, PL_ATOM|REP_FN, -1, &s[1]));
}
if ( s-f > MAXPATHLEN )
return name_too_long();
strncpy(buf, f, s-f);
buf[s-f] = EOS;
return PL_unify_chars(base, PL_ATOM|REP_FN, -1, buf);
}
if ( PL_unify_atom_chars(ext, "") &&
PL_unify(full, base) )
PL_succeed;
}
PL_fail;
}
if ( PL_get_chars_ex(base, &b, CVT_ALL|BUF_RING|REP_FN) &&
PL_get_chars_ex(ext, &e, CVT_ALL|REP_FN) )
{ char *s;
if ( e[0] == '.' ) /* +Base, +Extension, -full */
e++;
if ( has_extension(b, e) )
return PL_unify(base, full);
if ( strlen(b) + 1 + strlen(e) + 1 > MAXPATHLEN )
return name_too_long();
strcpy(buf, b);
s = buf + strlen(buf);
*s++ = '.';
strcpy(s, e);
return PL_unify_chars(full, PL_ATOM|REP_FN, -1, buf);
} else
fail;
}
static word
pl_prolog_to_os_filename(term_t pl, term_t os)
{ GET_LD
#ifdef O_XOS
wchar_t *wn;
if ( !PL_is_variable(pl) )
{ char *n;
wchar_t buf[MAXPATHLEN];
if ( PL_get_chars_ex(pl, &n, CVT_ALL|REP_UTF8) )
{ if ( !_xos_os_filenameW(n, buf, MAXPATHLEN) )
return name_too_long();
return PL_unify_wchars(os, PL_ATOM, -1, buf);
}
fail;
}
if ( PL_get_wchars(os, NULL, &wn, CVT_ALL) )
{ wchar_t lbuf[MAXPATHLEN];
char buf[MAXPATHLEN];
_xos_long_file_nameW(wn, lbuf, MAXPATHLEN);
_xos_canonical_filenameW(lbuf, buf, MAXPATHLEN, 0);
return PL_unify_chars(pl, PL_ATOM|REP_UTF8, -1, buf);
}
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, pl);
#else /*O_XOS*/
return PL_unify(pl, os);
#endif /*O_XOS*/
}
static foreign_t
pl_mark_executable(term_t path)
{ char *name;
if ( !PL_get_file_name(path, &name, 0) )
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_source_sink, path);
return MarkExecutable(name);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
copy_stream_data(+StreamIn, +StreamOut, [Len])
Copy all data from StreamIn to StreamOut. Should be somewhere else,
and maybe we need something else to copy resources.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static foreign_t
pl_copy_stream_data3(term_t in, term_t out, term_t len)
{ GET_LD
IOSTREAM *i, *o;
int c;
int count = 0;
if ( !getInputStream(in, &i) )
return FALSE;
if ( !getOutputStream(out, &o) )
{ releaseStream(i);
return FALSE;
}
if ( !len )
{ while ( (c = Sgetcode(i)) != EOF )
{ if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
{ releaseStream(i);
releaseStream(o);
fail;
}
if ( Sputcode(c, o) < 0 )
{ releaseStream(i);
return streamStatus(o);
}
}
} else
{ int64_t n;
if ( !PL_get_int64_ex(len, &n) )
fail;
while ( n-- > 0 && (c = Sgetcode(i)) != EOF )
{ if ( (++count % 4096) == 0 && PL_handle_signals() < 0 )
{ releaseStream(i);
releaseStream(o);
fail;
}
if ( Sputcode(c, o) < 0 )
{ releaseStream(i);
return streamStatus(o);
}
}
}
releaseStream(o);
return streamStatus(i);
}
static foreign_t
pl_copy_stream_data2(term_t in, term_t out)
{ return pl_copy_stream_data3(in, out, 0);
}
/*******************************
* PUBLISH PREDICATES *
*******************************/
BeginPredDefs(file)
PRED_DEF("set_prolog_IO", 3, set_prolog_IO, 0)
PRED_DEF("read_pending_input", 3, read_pending_input, 0)
PRED_DEF("get_code", 2, get_code2, PL_FA_ISO)
PRED_DEF("get_code", 1, get_code1, PL_FA_ISO)
PRED_DEF("get_char", 2, get_char2, PL_FA_ISO)
PRED_DEF("get_char", 1, get_char1, PL_FA_ISO)
PRED_DEF("get_byte", 2, get_byte2, PL_FA_ISO)
PRED_DEF("get_byte", 1, get_byte1, PL_FA_ISO)
PRED_DEF("peek_code", 2, peek_code2, PL_FA_ISO)
PRED_DEF("peek_code", 1, peek_code1, PL_FA_ISO)
PRED_DEF("peek_char", 2, peek_char2, PL_FA_ISO)
PRED_DEF("peek_char", 1, peek_char1, PL_FA_ISO)
PRED_DEF("peek_byte", 2, peek_byte2, PL_FA_ISO)
PRED_DEF("peek_byte", 1, peek_byte1, PL_FA_ISO)
PRED_DEF("put_byte", 2, put_byte2, PL_FA_ISO)
PRED_DEF("put_byte", 1, put_byte1, PL_FA_ISO)
PRED_DEF("put_code", 2, put_code2, PL_FA_ISO)
PRED_DEF("put_code", 1, put_code1, PL_FA_ISO)
PRED_DEF("put_char", 2, put_code2, PL_FA_ISO)
PRED_DEF("put_char", 1, put_code1, PL_FA_ISO)
PRED_DEF("put", 2, put2, 0)
PRED_DEF("put", 1, put1, 0)
PRED_DEF("skip", 1, skip1, 0)
PRED_DEF("skip", 2, skip2, 0)
PRED_DEF("get", 1, get1, 0)
PRED_DEF("get", 2, get2, 0)
PRED_DEF("get0", 2, get_code2, 0)
PRED_DEF("get0", 1, get_code1, 0)
PRED_DEF("is_stream", 1, is_stream, 0)
PRED_DEF("byte_count", 2, byte_count, 0)
PRED_DEF("character_count", 2, character_count, 0)
PRED_DEF("line_count", 2, line_count, 0)
PRED_DEF("line_position", 2, line_position, 0)
PRED_DEF("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
EndPredDefs
static const PL_extension file_foreigns[] = {
FRG("get_single_char", 1, pl_get_single_char, 0),
FRG("$push_input_context", 0, pl_push_input_context, 0),
FRG("$pop_input_context", 0, pl_pop_input_context, 0),
FRG("seeing", 1, pl_seeing, 0),
FRG("telling", 1, pl_telling, 0),
FRG("seen", 0, pl_seen, 0),
FRG("tmp_file", 2, pl_tmp_file, 0),
FRG("delete_file", 1, pl_delete_file, 0),
FRG("delete_directory", 1, pl_delete_directory, 0),
FRG("make_directory", 1, pl_make_directory, 0),
FRG("access_file", 2, pl_access_file, 0),
FRG("read_link", 3, pl_read_link, 0),
FRG("exists_file", 1, pl_exists_file, 0),
FRG("exists_directory", 1, pl_exists_directory, 0),
FRG("rename_file", 2, pl_rename_file, 0),
FRG("same_file", 2, pl_same_file, 0),
FRG("time_file", 2, pl_time_file, 0),
FRG("told", 0, pl_told, 0),
FRG("see", 1, pl_see, 0),
FRG("tell", 1, pl_tell, 0),
FRG("append", 1, pl_append, 0),
FRG("ttyflush", 0, pl_ttyflush, 0),
FRG("flush_output", 0, pl_flush_output, 0),
FRG("prompt", 2, pl_prompt, 0),
FRG("prompt1", 1, pl_prompt1, 0),
FRG("$absolute_file_name", 2, pl_absolute_file_name, 0),
FRG("is_absolute_file_name", 1, pl_is_absolute_file_name, 0),
FRG("file_base_name", 2, pl_file_base_name, 0),
FRG("file_directory_name", 2, pl_file_dir_name, 0),
FRG("file_name_extension", 3, pl_file_name_extension, 0),
FRG("prolog_to_os_filename", 2, pl_prolog_to_os_filename, 0),
FRG("set_stream_position", 2, pl_set_stream_position, ISO),
FRG("wait_for_input", 3, pl_wait_for_input, 0),
FRG("protocol", 1, pl_protocol, 0),
FRG("protocola", 1, pl_protocola, 0),
FRG("noprotocol", 0, pl_noprotocol, 0),
FRG("protocolling", 1, pl_protocolling, 0),
FRG("tab", 1, pl_tab, 0),
FRG("open", 3, pl_open, ISO),
FRG("open", 4, pl_open4, ISO),
FRG("open_null_stream", 1, pl_open_null_stream, 0),
FRG("close", 1, pl_close, ISO),
FRG("close", 2, pl_close2, ISO),
FRG("stream_property", 2, pl_stream_property, NDET|ISO),
FRG("flush_output", 1, pl_flush_output1, ISO),
FRG("set_stream_position", 2, pl_set_stream_position, ISO),
FRG("seek", 4, pl_seek, 0),
FRG("set_input", 1, pl_set_input, ISO),
FRG("set_output", 1, pl_set_output, ISO),
FRG("set_stream", 2, pl_set_stream, 0),
FRG("current_input", 1, pl_current_input, ISO),
FRG("current_output", 1, pl_current_output, ISO),
FRG("source_location", 2, pl_source_location, 0),
FRG("at_end_of_stream", 1, pl_at_end_of_stream1, ISO),
FRG("at_end_of_stream", 0, pl_at_end_of_stream0, ISO),
FRG("size_file", 2, pl_size_file, 0),
FRG("$size_stream", 2, pl_size_stream, 0),
FRG("fileerrors", 2, pl_fileerrors, 0),
FRG("working_directory", 2, pl_working_directory, 0),
FRG("$mark_executable", 1, pl_mark_executable, 0),
FRG("copy_stream_data", 2, pl_copy_stream_data2, 0),
FRG("copy_stream_data", 3, pl_copy_stream_data3, 0)
};
void
initIO(void)
{ GET_LD
const atom_t *np;
int i;
init_standardStreams();
init_encoding_names();
init_open4_options();
init_close2_options();
init_sprop_list();
streamAliases = newHTable(16);
streamContext = newHTable(16);
fileerrors = TRUE;
#ifdef __unix__
{ int fd;
if ( (fd=Sfileno(Sinput)) < 0 || !isatty(fd) ||
(fd=Sfileno(Soutput)) < 0 || !isatty(fd) )
defFeature("tty_control", FT_BOOL, FALSE);
}
#endif
ResetTty();
Sclosehook(freeStream);
Sinput->position = &Sinput->posbuf; /* position logging */
Soutput->position = &Sinput->posbuf;
Serror->position = &Sinput->posbuf;
ttymode = TTY_COOKED;
PushTty(Sinput, &ttytab, TTY_SAVE);
LD->prompt.current = ATOM_prompt;
PL_register_atom(ATOM_prompt);
Suser_input = Sinput;
Suser_output = Soutput;
Suser_error = Serror;
Scurin = Sinput; /* see/tell */
Scurout = Soutput;
Sprotocol = NULL; /* protocolling */
getStreamContext(Sinput); /* add for enumeration */
getStreamContext(Soutput);
getStreamContext(Serror);
for( i=0, np = standardStreams; *np; np++, i++ )
addHTable(streamAliases, (void *)*np, (void *)(intptr_t)i);
GD->io_initialised = TRUE;
}