static foreign_t
tipc_socket(term_t socket, term_t opt)
{ atom_t a;
int arity;
if ( PL_get_name_arity(opt, &a, &arity) && arity == 0)
{ int type;
if ( a == ATOM_dgram )
type = SOCK_DGRAM;
else if ( a == ATOM_rdm )
type = SOCK_RDM;
else if ( a == ATOM_seqpacket )
type = SOCK_SEQPACKET;
else if ( a == ATOM_stream )
type = SOCK_STREAM;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "rdm, dgram, seqpacket, or stream");
return create_tipc_socket(socket, type);
}
else return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1, opt, "atom");
return FALSE;
}
static foreign_t
pl_tipc_subscribe(term_t Socket, term_t Address,
term_t timeout, term_t filter, term_t usr_handle)
{ struct sockaddr_tipc sockaddr;
struct tipc_subscr subscr;
int socket;
unsigned time, filt;
char *handle;
size_t handle_len;
SOCKET fd;
memset(&subscr, 0, sizeof(subscr));
memset(&sockaddr, 0, sizeof(sockaddr));
if ( !tipc_get_socket(Socket, &socket) ||
!nbio_get_tipc_sockaddr(Address, &sockaddr))
return FALSE;
if(sockaddr.addrtype != TIPC_ADDR_NAMESEQ)
return pl_error(NULL, 0, NULL, ERR_DOMAIN, Address, "name_seq/3");
if( !get_uint(timeout, &time))
return pl_error(NULL, 0, NULL, ERR_DOMAIN, timeout, "integer");
if( !get_uint(filter, &filt))
return pl_error(NULL, 0, NULL, ERR_DOMAIN, filter, "integer");
if ( !PL_get_nchars(usr_handle, &handle_len, &handle, CVT_ALL|CVT_EXCEPTION) )
return FALSE;
if(tipc_version > 1)
{ struct tipc_name_seq *p = &subscr.seq,
*p1 = &sockaddr.addr.nameseq;
p->type = htonl(p1->type);
p->lower = htonl(p1->lower);
p->upper = htonl(p1->upper);
subscr.timeout = htonl(time);
subscr.filter = htonl((filt == V1_TIPC_SUB_SERVICE)
? TIPC_SUB_SERVICE
: filt);
} else {
memcpy(&subscr.seq, &sockaddr.addr.nameseq, sizeof(subscr.seq));
subscr.timeout = time;
subscr.filter = filt;
}
memcpy(&subscr.usr_handle, handle,
(handle_len < sizeof(subscr.usr_handle))
? handle_len
: sizeof(subscr.usr_handle));
fd = nbio_fd(socket);
if ( (send(fd, &subscr, sizeof(subscr), 0)) != sizeof(subscr) )
return nbio_error(errno, TCP_ERRNO);
else
return TRUE;
}
static foreign_t
pl_setopt(term_t Socket, term_t opt)
{ int socket;
atom_t a;
int arity;
if ( !tcp_get_socket(Socket, &socket) )
return FALSE;
if ( PL_get_name_arity(opt, &a, &arity) )
{ if ( a == ATOM_reuseaddr && arity == 0 )
{ if ( nbio_setopt(socket, TCP_REUSEADDR, TRUE) == 0 )
return TRUE;
return FALSE;
} else if ( a == ATOM_nodelay && arity <= 1 )
{ int enable, rc;
if ( arity == 0 )
{ enable = TRUE;
} else /*if ( arity == 1 )*/
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( !PL_get_bool(a, &enable) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "boolean");
}
if ( (rc=nbio_setopt(socket, TCP_NO_DELAY, enable) == 0) )
return TRUE;
if ( rc == -2 )
goto not_implemented;
return FALSE;
} else if ( a == ATOM_broadcast && arity == 0 )
{ if ( nbio_setopt(socket, UDP_BROADCAST, TRUE) == 0 )
return TRUE;
return FALSE;
} else if ( a == ATOM_dispatch && arity == 1 )
{ int val;
term_t a1 = PL_new_term_ref();
if ( PL_get_arg(1, opt, a1) && PL_get_bool(a1, &val) )
{ if ( nbio_setopt(socket, TCP_DISPATCH, val) == 0 )
return TRUE;
return FALSE;
}
} else if ( a == ATOM_nonblock && arity == 0 )
{ if ( nbio_setopt(socket, TCP_NONBLOCK) == 0 )
return TRUE;
return FALSE;
}
}
not_implemented:
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "socket_option");
}
static int
sha_options(term_t options, optval *result)
{ term_t opts = PL_copy_term_ref(options);
term_t opt = PL_new_term_ref();
/* defaults */
memset(result, 0, sizeof(*result));
result->algorithm = ALGORITHM_SHA1;
result->digest_size = SHA1_DIGEST_SIZE;
while(PL_get_list(opts, opt, opts))
{ atom_t aname;
int arity;
if ( PL_get_name_arity(opt, &aname, &arity) && arity == 1 )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( aname == ATOM_algorithm )
{ atom_t a_algorithm;
result->algorithm_term = a;
if ( !PL_get_atom(a, &a_algorithm) )
return pl_error(NULL, 0, NULL, ERR_TYPE, a, "algorithm");
if ( a_algorithm == ATOM_sha1 )
{ result->algorithm = ALGORITHM_SHA1;
result->digest_size = SHA1_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha224 )
{ result->algorithm = ALGORITHM_SHA224;
result->digest_size = SHA224_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha256 )
{ result->algorithm = ALGORITHM_SHA256;
result->digest_size = SHA256_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha384 )
{ result->algorithm = ALGORITHM_SHA384;
result->digest_size = SHA384_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha512 )
{ result->algorithm = ALGORITHM_SHA512;
result->digest_size = SHA512_DIGEST_SIZE;
} else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "algorithm");
}
} else
{ return pl_error(NULL, 0, NULL, ERR_TYPE, opt, "option");
}
}
if ( !PL_get_nil(opts) )
return pl_error("sha_hash", 1, NULL, ERR_TYPE, opts, "list");
return TRUE;
}
int
alarm_error(term_t alarm, int err)
{ switch(err)
{ case ERR_RESOURCE:
return pl_error(NULL, 0, NULL, ERR_RESOURCE, "timers");
case ERR_PERMISSION:
return pl_error(NULL, 0, "already installed", ERR_PERMISSION,
alarm, "install", "alarm");
default:
assert(0);
return FALSE;
}
}
static foreign_t
pl_tipc_bind(term_t Socket, term_t Address, term_t opt)
{ struct sockaddr_tipc sockaddr;
size_t addrlen = sizeof(sockaddr);
int socket;
atom_t a;
int arity;
memset(&sockaddr, 0, sizeof(sockaddr));
if ( !tipc_get_socket(Socket, &socket) ||
!nbio_get_tipc_sockaddr(Address, &sockaddr) )
return FALSE;
if ( PL_get_name_arity(opt, &a, &arity) )
{ if ( (a == ATOM_scope || a == ATOM_no_scope) && arity == 1 )
{ atom_t val;
term_t a1 = PL_new_term_ref();
if (PL_get_arg(1, opt, a1))
{ signed char ival = 0;
if ( !PL_get_atom(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "atom");
if ( val == ATOM_zone )
ival = TIPC_ZONE_SCOPE;
else if ( val == ATOM_cluster )
ival = TIPC_CLUSTER_SCOPE;
else if ( val == ATOM_node )
ival = TIPC_NODE_SCOPE;
else if ( val == ATOM_all && a == ATOM_no_scope)
addrlen = 0;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "node, cluster, or zone");
sockaddr.scope = (a == ATOM_scope) ? ival
: -ival;
if ( nbio_bind(socket, (struct sockaddr*)&sockaddr, addrlen) < 0 )
return FALSE;
}
} else
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1, opt, "scoping option");
return TRUE;
}
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "scope/1");
}
static foreign_t
pl_cgi_get_form(term_t form)
{ size_t len = 0;
char *data;
int must_free = FALSE;
term_t list = PL_copy_term_ref(form);
char *ct, *boundary;
if ( !get_raw_form_data(&data, &len, &must_free) )
return FALSE;
if ( (ct = getenv("CONTENT_TYPE")) &&
(boundary = strstr(ct, "boundary=")) )
{ boundary = strchr(boundary, '=')+1;
switch( break_multipart(data, len, boundary,
mp_add_to_form, (void *)list) )
{ case FALSE:
return FALSE;
case TRUE:
break;
default:
assert(0);
return FALSE;
}
} else
{ switch( break_form_argument(data, add_to_form, (void *)list) )
{ case FALSE:
return FALSE;
case TRUE:
break;
case ERROR_NOMEM:
return pl_error("cgi_get_form", 1, NULL,
ERR_RESOURCE, "memory");
case ERROR_SYNTAX_ERROR:
return pl_error("cgi_get_form", 1, NULL,
ERR_SYNTAX, "cgi_value");
default:
assert(0);
return FALSE;
}
}
if ( must_free )
free(data);
return PL_unify_nil(list);
}
static int
pl_get_bool_ex(term_t arg, int *val)
{ if ( PL_get_bool(arg, val) )
return TRUE;
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 0, arg, "bool");
}
static int
wait_for_pid(pid_t pid, term_t code, wait_options *opts)
{ pid_t p2;
int status;
if ( opts->has_timeout && opts->timeout == 0.0 )
{ if ( (p2=waitpid(pid, &status, WNOHANG)) == pid )
return unify_exit_status(code, status);
else if ( p2 == 0 )
return PL_unify_atom(code, ATOM_timeout);
else
{ term_t PID;
error:
return ((PID = PL_new_term_ref()) &&
PL_put_integer(PID, pid) &&
pl_error(NULL, 0, "waitpid", ERR_ERRNO,
errno, "wait", "process", PID));
}
}
for(;;)
{ if ( (p2=waitpid(pid, &status, 0)) == pid )
return unify_exit_status(code, status);
if ( p2 == -1 && errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
} else
{ goto error;
}
}
}
static HANDLE
find_process_from_pid(DWORD pid, const char *pred)
{ win_process *wp;
LOCK();
for(wp=processes; wp; wp=wp->next)
{ if ( wp->pid == pid )
{ HANDLE h = wp->handle;
UNLOCK();
return h;
}
}
UNLOCK();
if ( pred )
{ term_t ex = PL_new_term_ref();
PL_put_integer(ex, pid);
pl_error(NULL, 2, NULL, ERR_EXISTENCE,
"process", ex);
}
return (HANDLE)0;
}
static foreign_t
pl_hmac_sha(term_t key, term_t data, term_t mac, term_t options)
{ char *sdata, *skey;
size_t datalen, keylen;
optval opts;
unsigned char digest[SHA2_MAX_DIGEST_SIZE];
if ( !PL_get_nchars(key, &keylen, &skey,
CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
return FALSE;
if ( !PL_get_nchars(data, &datalen, &sdata,
CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
return FALSE;
if ( !sha_options(options, &opts) )
return FALSE;
switch(opts.algorithm)
{ case ALGORITHM_SHA1:
hmac_sha1((unsigned char*)skey, (unsigned long)keylen,
(unsigned char*)sdata, (unsigned long)datalen,
digest, (unsigned long)opts.digest_size);
break;
case ALGORITHM_SHA256:
hmac_sha256((unsigned char*)skey, (unsigned long)keylen,
(unsigned char*)sdata, (unsigned long)datalen,
digest, (unsigned long)opts.digest_size);
break;
default:
return pl_error(NULL, 0, "HMAC-SHA only for SHA-1 and SHA-256",
ERR_DOMAIN, opts.algorithm_term, "algorithm");
}
return PL_unify_list_ncodes(mac, opts.digest_size, (char*)digest);
}
static int
nbio_get_tipc_sockaddr(term_t Address, struct sockaddr_tipc *addr)
{ if ( !nbio_get_tipc(Address, addr) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1, Address, "tipc address");
return TRUE;
}
int
break_multipart(char *formdata, size_t len,
const char *boundary,
int (*func)(const char *name,
size_t namelen,
const char *value,
size_t valuelen,
const char *filename,
void *closure),
void *closure)
{ char *enddata = formdata+len;
while(formdata < enddata)
{ char *header;
char *name, *filename;
char *data = NULL;
char *end;
if ( !(formdata=find_boundary(formdata, enddata, boundary)) ||
!(formdata=next_line(formdata)) )
break;
header = formdata;
/* find the end of the header */
for( ; formdata < enddata; formdata++ )
{ char *end;
if ( (end = looking_at_blank_lines(formdata, 2)) )
{ formdata[0] = '\0';
formdata = data = end;
break;
}
}
if ( !data )
break;
if ( !(name = attribute_of_multipart_header("name", header, data)) )
{ term_t t = PL_new_term_ref();
PL_put_atom_chars(t, "name");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "field", t);
}
filename = attribute_of_multipart_header("filename", header, data);
if ( !(formdata=find_boundary(data, enddata, boundary)) )
break;
end = formdata-1;
if ( end[-1] == '\r' )
end--;
end[0] = '\0';
if ( !(func)(name, strlen(name), data, end-data, filename, closure) )
return FALSE;
}
return TRUE;
}
static int
unify_timer(term_t t, Event ev)
{ if ( !PL_is_variable(t) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 0, t, "unbound");
return PL_unify_term(t,
PL_FUNCTOR, FUNCTOR_alarm1,
PL_POINTER, ev);
}
static foreign_t
process_kill(term_t pid, term_t signal)
{ int p;
if ( !get_pid(pid, &p) )
return FALSE;
{
#ifdef __WINDOWS__
HANDLE h;
if ( !(h=find_process_from_pid(p, "process_kill")) )
return FALSE;
if ( TerminateProcess(h, 255) )
return TRUE;
return win_error("TerminateProcess");
#else /*__WINDOWS__*/
int sig;
if ( !PL_get_signum_ex(signal, &sig) )
return FALSE;
if ( kill(p, sig) == 0 )
return TRUE;
switch(errno)
{ case EPERM:
return pl_error("process_kill", 2, NULL, ERR_PERMISSION,
pid, "kill", "process");
case ESRCH:
return pl_error("process_kill", 2, NULL, ERR_EXISTENCE,
"process", pid);
default:
return pl_error("process_kill", 2, "kill", ERR_ERRNO, errno, "kill", "process", pid);
}
#endif /*__WINDOWS__*/
}
}
static Event
allocEvent()
{ Event ev = malloc(sizeof(*ev));
if ( !ev )
{ pl_error(NULL, 0, NULL, ERR_ERRNO, errno, "allocate", "memory", 0);
return NULL;
}
memset(ev, 0, sizeof(*ev));
ev->magic = EV_MAGIC;
return ev;
}
static int
get_timer(term_t t, Event *ev)
{ if ( PL_is_functor(t, FUNCTOR_alarm1) )
{ term_t a = PL_new_term_ref();
void *p;
_PL_get_arg(1, t, a);
if ( PL_get_pointer(a, &p) )
{ Event e = p;
if ( e->magic == EV_MAGIC )
{ *ev = e;
return TRUE;
} else
{ return pl_error("get_timer", 1, NULL,
ERR_DOMAIN, t, "alarm");
}
}
}
return pl_error("get_timer", 1, NULL,
ERR_ARGTYPE, 1, t, "alarm");
}
static foreign_t
pl_listen(term_t Sock, term_t BackLog)
{ int socket;
int backlog;
if ( !tcp_get_socket(Sock, &socket) )
return FALSE;
if ( !PL_get_integer(BackLog, &backlog) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, -1, BackLog, "integer");
if ( nbio_listen(socket, backlog) < 0 )
return FALSE;
return TRUE;
}
static foreign_t
install_alarm2(term_t alarm, term_t time)
{ Event ev = NULL;
double t;
int rc;
if ( !get_timer(alarm, &ev) )
return FALSE;
if ( !PL_get_float(time, &t) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1,
time, "number");
setTimeEvent(ev, t);
if ( (rc=installEvent(ev)) != TRUE )
return alarm_error(alarm, rc);
return TRUE;
}
tcp_get_socket(term_t Socket, int *id)
{ IOSTREAM *s;
int socket;
if ( PL_is_functor(Socket, FUNCTOR_socket1) )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, Socket, a);
if ( PL_get_integer(a, id) )
return TRUE;
}
if ( PL_get_stream_handle(Socket, &s) )
{ socket = (int)(intptr_t)s->handle;
*id = socket;
return TRUE;
}
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, -1, Socket, "socket");
}
static foreign_t
pl_sha_hash_ctx(term_t old_ctx, term_t from, term_t new_ctx, term_t hash)
{ char *data;
size_t datalen;
struct context *cp;
size_t clen;
unsigned char hval[SHA2_MAX_DIGEST_SIZE];
if ( !PL_get_nchars(from, &datalen, &data,
CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
return FALSE;
if ( !PL_get_string_chars(old_ctx, (char **)&cp, &clen) )
return FALSE;
if ( clen != sizeof (*cp)
|| cp->magic != CONTEXT_MAGIC ) {
return pl_error(NULL, 0, "Invalid OldContext passed",
ERR_DOMAIN, old_ctx, "algorithm");
}
if ( cp->opts.algorithm == ALGORITHM_SHA1 )
{ sha1_ctx *c1p = &(cp->context.sha1);
sha1_hash((unsigned char*)data, (unsigned long)datalen, c1p);
if ( !PL_unify_string_nchars(new_ctx, sizeof(*cp), (char*)cp) )
return FALSE;
sha1_end((unsigned char *)hval, c1p);
} else
{ sha2_ctx *c1p = &(cp->context.sha2);
sha2_hash((unsigned char*)data, (unsigned long)datalen, c1p);
if ( !PL_unify_string_nchars(new_ctx, sizeof(*cp), (char*)cp) )
return FALSE;
sha2_end((unsigned char *)hval, c1p);
}
/* . */
return PL_unify_list_ncodes(hash, cp->opts.digest_size, (char*)hval);
}
static int
installEvent(Event ev)
{ int rc;
ev->thread_id = pthread_self();
ev->pl_thread_id = PL_thread_self();
LOCK();
if ( !scheduler_running )
{ pthread_attr_t attr;
TheSchedule()->stop = FALSE;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
pthread_attr_setstacksize(&attr, 8192);
rc = pthread_create(&scheduler, &attr, alarm_loop, NULL);
pthread_attr_destroy(&attr);
if ( rc != 0 )
{ UNLOCK();
return pl_error("alarm", 4, "Failed to start schedule thread",
ERR_ERRNO, rc);
}
DEBUG(1, Sdprintf("Started scheduler thread\n"));
scheduler_running = TRUE;
}
rc = insertEvent(ev);
UNLOCK();
if ( rc )
pthread_cond_signal(&cond);
return rc;
}
static foreign_t
tcp_select(term_t Streams, term_t Available, term_t timeout)
{ fd_set fds;
struct timeval t, *to;
double time;
int n, max = 0, ret, min = 1000000;
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;
#ifdef __WINDOWS__
nbio_sock_t fd;
#else
int fd;
#endif
fdentry *e;
if ( !PL_get_stream_handle(head, &s) )
return FALSE;
#ifdef __WINDOWS__
fd = fdFromHandle(s->handle);
#else
fd = Sfileno(s);
#endif
PL_release_stream(s);
if ( fd < 0 || !is_socket_stream(s) )
{ return pl_error("tcp_select", 3, NULL, ERR_DOMAIN,
head, "socket_stream");
}
/* check for input in buffer */
if ( s->bufp < s->limitp )
{ if ( !PL_unify_list(available, ahead, available) ||
!PL_unify(ahead, head) )
return FALSE;
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("tcp_select", 3, NULL, ERR_TYPE, Streams, "list");
if ( from_buffer > 0 )
return PL_unify_nil(available);
if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
{ to = NULL;
} else
{ if ( !PL_get_float(timeout, &time) )
return pl_error("tcp_select", 3, NULL,
ERR_TYPE, timeout, "number");
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=nbio_select(max+1, &fds, NULL, NULL, to)) == -1 &&
errno == EINTR )
{ fdentry *e;
if ( PL_handle_signals() < 0 )
return FALSE; /* exception */
FD_ZERO(&fds); /* EINTR may leave fds undefined */
for(e=map; e; e=e->next) /* so we rebuild it to be safe */
{ FD_SET((SOCKET)e->fd, &fds);
}
}
switch(ret)
{ case -1:
return pl_error("tcp_select", 3, NULL, ERR_ERRNO, errno, "select", "streams", Streams);
case 0: /* Timeout */
break;
default: /* Something happened -> 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)) )
return FALSE;
}
}
break;
}
return PL_unify_nil(available);
}
static foreign_t
udp_receive(term_t Socket, term_t Data, term_t From, term_t options)
{ struct sockaddr_in sockaddr;
#ifdef __WINDOWS__
int alen = sizeof(sockaddr);
#else
socklen_t alen = sizeof(sockaddr);
#endif
int socket;
int flags = 0;
char buf[UDP_MAXDATA];
ssize_t n;
int as = PL_STRING;
if ( !PL_get_nil(options) )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) && arity == 1 )
{ _PL_get_arg(1, head, arg);
if ( name == ATOM_as )
{ atom_t a;
if ( !PL_get_atom(arg, &a) )
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "atom");
if ( a == ATOM_atom )
as = PL_ATOM;
else if ( a == ATOM_codes )
as = PL_CODE_LIST;
else if ( a == ATOM_string )
as = PL_STRING;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "as_option");
}
} else
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "option");
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_TYPE, tail, "list");
}
if ( !tcp_get_socket(Socket, &socket) ||
!nbio_get_sockaddr(From, &sockaddr) )
return FALSE;
if ( (n=nbio_recvfrom(socket, buf, sizeof(buf), flags,
(struct sockaddr*)&sockaddr, &alen)) == -1 )
return nbio_error(errno, TCP_ERRNO);
if ( !PL_unify_chars(Data, as, n, buf) )
return FALSE;
return unify_address(From, &sockaddr);
}
static int
do_create_process(p_options *info)
{ int pid;
if ( !(pid=vfork()) ) /* child */
{ int fd;
PL_cleanup_fork();
if ( info->detached )
setsid();
if ( info->cwd )
{ if ( chdir(info->cwd) )
{ perror(info->cwd);
exit(1);
}
}
/* stdin */
switch( info->streams[0].type )
{ case std_pipe:
dup2(info->streams[0].fd[0], 0);
close(info->streams[0].fd[1]);
break;
case std_null:
if ( (fd = open("/dev/null", O_RDONLY)) >= 0 )
dup2(fd, 0);
break;
case std_std:
break;
}
/* stdout */
switch( info->streams[1].type )
{ case std_pipe:
dup2(info->streams[1].fd[1], 1);
close(info->streams[1].fd[0]);
break;
case std_null:
if ( (fd = open("/dev/null", O_WRONLY)) >= 0 )
dup2(fd, 1);
break;
case std_std:
break;
}
/* stderr */
switch( info->streams[2].type )
{ case std_pipe:
dup2(info->streams[2].fd[1], 2);
close(info->streams[2].fd[0]);
break;
case std_null:
if ( (fd = open("/dev/null", O_WRONLY)) >= 0 )
dup2(fd, 2);
break;
case std_std:
break;
}
if ( info->envp )
execve(info->exe, info->argv, info->envp);
else
execv(info->exe, info->argv);
perror(info->exe);
exit(1);
} else if ( pid < 0 ) /* parent */
{ term_t exe = PL_new_term_ref();
PL_put_atom_chars(exe, info->exe);
return pl_error(NULL, 0, "fork", ERR_ERRNO, errno, "fork", "process", exe);
} else
{ if ( info->pipes > 0 && info->pid == 0 )
{ IOSTREAM *s;
process_context *pc = PL_malloc(sizeof(*pc));
DEBUG(Sdprintf("Wait on pipes\n"));
memset(pc, 0, sizeof(*pc));
pc->magic = PROCESS_MAGIC;
pc->pid = pid;
if ( info->streams[0].type == std_pipe )
{ close(info->streams[0].fd[0]);
s = open_process_pipe(pc, 0, info->streams[0].fd[1]);
PL_unify_stream(info->streams[0].term, s);
}
if ( info->streams[1].type == std_pipe )
{ close(info->streams[1].fd[1]);
s = open_process_pipe(pc, 1, info->streams[1].fd[0]);
PL_unify_stream(info->streams[1].term, s);
}
if ( info->streams[2].type == std_pipe )
{ close(info->streams[2].fd[1]);
s = open_process_pipe(pc, 2, info->streams[2].fd[0]);
PL_unify_stream(info->streams[2].term, s);
}
return TRUE;
} else if ( info->pipes > 0 )
{ IOSTREAM *s;
if ( info->streams[0].type == std_pipe )
{ close(info->streams[0].fd[0]);
s = Sfdopen(info->streams[0].fd[1], "w");
PL_unify_stream(info->streams[0].term, s);
}
if ( info->streams[1].type == std_pipe )
{ close(info->streams[1].fd[1]);
s = Sfdopen(info->streams[1].fd[0], "r");
PL_unify_stream(info->streams[1].term, s);
}
if ( info->streams[2].type == std_pipe )
{ close(info->streams[2].fd[1]);
s = Sfdopen(info->streams[2].fd[0], "r");
PL_unify_stream(info->streams[2].term, s);
}
}
if ( info->pid )
return PL_unify_integer(info->pid, pid);
return wait_success(info->exe_name, pid);
}
}
static foreign_t
alarm4_gen(time_abs_rel abs_rel, term_t time, term_t callable,
term_t id, term_t options)
{ Event ev;
double t;
module_t m = NULL;
unsigned long flags = 0L;
if ( options )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
while( PL_get_list(tail, head, tail) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( arity == 1 )
{ term_t arg = PL_new_term_ref();
_PL_get_arg(1, head, arg);
if ( name == ATOM_remove )
{ int t = FALSE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( t )
flags |= EV_REMOVE;
} else if ( name == ATOM_install )
{ int t = TRUE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( !t )
flags |= EV_NOINSTALL;
}
}
}
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 4, options, "list");
}
if ( !PL_get_float(time, &t) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1,
time, "number");
if ( !(ev = allocEvent()) )
return FALSE;
if (abs_rel==TIME_REL)
setTimeEvent(ev, t);
else
setTimeEventAbs(ev,t);
if ( !unify_timer(id, ev) )
{ freeEvent(ev); /* not linked: no need to lock */
return FALSE;
}
ev->flags = flags;
PL_strip_module(callable, &m, callable);
ev->module = m;
ev->goal = PL_record(callable);
if ( !(ev->flags & EV_NOINSTALL) )
{ int rc;
if ( (rc=installEvent(ev)) != TRUE )
{ freeEvent(ev); /* not linked: no need to lock */
return alarm_error(id, rc);
}
}
return TRUE;
}
static foreign_t
udp_receive(term_t Socket, term_t Data, term_t From, term_t options)
{ struct sockaddr_in sockaddr;
#ifdef __WINDOWS__
int alen = sizeof(sockaddr);
#else
socklen_t alen = sizeof(sockaddr);
#endif
int socket;
int flags = 0;
char smallbuf[UDP_DEFAULT_BUFSIZE];
char *buf = smallbuf;
int bufsize = UDP_DEFAULT_BUFSIZE;
term_t varport = 0;
ssize_t n;
int as = PL_STRING;
int rc;
if ( !PL_get_nil(options) )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while(PL_get_list(tail, head, tail))
{ atom_t name;
size_t arity;
if ( PL_get_name_arity(head, &name, &arity) && arity == 1 )
{ _PL_get_arg(1, head, arg);
if ( name == ATOM_as )
{ atom_t a;
if ( !PL_get_atom(arg, &a) )
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "atom");
if ( a == ATOM_atom )
as = PL_ATOM;
else if ( a == ATOM_codes )
as = PL_CODE_LIST;
else if ( a == ATOM_string )
as = PL_STRING;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "as_option");
} else if ( name == ATOM_max_message_size )
{ if ( !PL_get_integer(arg, &bufsize) )
return pl_error(NULL, 0, NULL, ERR_TYPE, arg, "integer");
if ( bufsize < 0 || bufsize > UDP_MAXDATA )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "0 - 65535");
}
} else
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "option");
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_TYPE, tail, "list");
}
if ( !tcp_get_socket(Socket, &socket) ||
!nbio_get_sockaddr(From, &sockaddr, &varport) )
return FALSE;
if ( bufsize > UDP_DEFAULT_BUFSIZE )
{ if ( !(buf = malloc(bufsize)) )
return pl_error(NULL, 0, NULL, ERR_RESOURCE, "memory");
}
if ( (n=nbio_recvfrom(socket, buf, bufsize, flags,
(struct sockaddr*)&sockaddr, &alen)) == -1 )
{ rc = nbio_error(errno, TCP_ERRNO);
goto out;
}
rc = ( PL_unify_chars(Data, as, n, buf) &&
unify_address(From, &sockaddr)
);
out:
if ( buf != smallbuf )
free(buf);
return rc;
}
int
get_raw_form_data(char **data, size_t *lenp, int *must_free)
{ char *method;
char *s;
if ( (method = getenv("REQUEST_METHOD")) &&
strcmp(method, "POST") == 0 )
{ char *lenvar = getenv("CONTENT_LENGTH");
char *q;
long len;
if ( !lenvar )
{ term_t env = PL_new_term_ref();
PL_put_atom_chars(env, "CONTENT_LENGTH");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "environment", env);
}
len = atol(lenvar);
if ( len < 0 )
{ term_t t = PL_new_term_ref();
if ( !PL_put_integer(t, len) )
return FALSE;
return pl_error(NULL, 0, "< 0", ERR_DOMAIN, t, "content_length");
}
if ( lenp )
{ if ( *lenp && (size_t)len > *lenp )
{ term_t t = PL_new_term_ref();
char msg[100];
if ( !PL_put_integer(t, len) )
return FALSE;
sprintf(msg, "> %ld", (long)*lenp);
return pl_error(NULL, 0, msg, ERR_DOMAIN, t, "content_length");
}
*lenp = len;
}
q = s = malloc(len+1);
if ( !q )
return pl_error(NULL, 0, NULL, ERR_RESOURCE, "memory");
while(len > 0)
{ int done;
while( (done=read(fileno(stdin), q, len)) > 0 )
{ q+=done;
len-=done;
}
if ( done < 0 )
{ int e;
term_t obj;
no_data:
e = errno;
obj = PL_new_term_ref();
free(s);
PL_put_nil(obj);
return pl_error(NULL, 0, NULL, ERR_ERRNO, e, "read", "cgi_data", obj);
}
}
if ( len == 0 )
{ *q = '\0';
*data = s;
*must_free = TRUE;
return TRUE;
} else
goto no_data;
} else if ( (s = getenv("QUERY_STRING")) )
{ if ( lenp )
*lenp = strlen(s);
*data = s;
*must_free = FALSE;
return TRUE;
} else
{ term_t env = PL_new_term_ref();
PL_put_atom_chars(env, "QUERY_STRING");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "environment", env);
}
}
static foreign_t
pl_crypt(term_t passwd, term_t encrypted)
{ char *pw, *e;
char salt[20];
if ( !PL_get_chars(passwd, &pw, CVT_ATOM|CVT_STRING|CVT_LIST|BUF_RING) )
return pl_error("crypt", 2, NULL, ERR_ARGTYPE,
1, passwd, "text");
if ( PL_get_chars(encrypted, &e, CVT_ATOM|CVT_STRING|CVT_LIST|BUF_RING) )
{ char *s2;
if ( strncmp(e, "$1$", 3) == 0 ) /* MD5 Hash */
{ char *p = strchr(e+3, '$');
size_t slen;
if ( p && (slen=(size_t)(p-e-3)) < sizeof(salt) )
{ strncpy(salt, e+3, slen);
salt[slen] = 0;
s2 = md5_crypt(pw, salt);
return (strcmp(s2, e) == 0) ? TRUE : FALSE;
} else
{ Sdprintf("No salt???\n");
return FALSE;
}
} else
{ int rval;
salt[0] = e[0];
salt[1] = e[1];
salt[2] = '\0';
LOCK();
s2 = crypt(pw, salt);
rval = (strcmp(s2, e) == 0 ? TRUE : FALSE);
UNLOCK();
return rval;
}
} else
{ term_t tail = PL_copy_term_ref(encrypted);
term_t head = PL_new_term_ref();
int slen = 2;
int n;
int (*unify)(term_t t, const char *s) = PL_unify_list_codes;
char *s2;
int rval;
for(n=0; n<slen; n++)
{ if ( PL_get_list(tail, head, tail) )
{ int i;
char *t;
if ( PL_get_integer(head, &i) && i>=0 && i<=255 )
{ salt[n] = i;
} else if ( PL_get_atom_chars(head, &t) && t[1] == '\0' )
{ salt[n] = t[0];
unify = PL_unify_list_chars;
} else
{ return pl_error("crypt", 2, NULL, ERR_ARGTYPE,
2, head, "character");
}
if ( n == 1 && salt[0] == '$' && salt[1] == '1' )
slen = 3;
else if ( n == 2 && salt[2] == '$' )
slen = 8+3;
} else
break;
}
for( ; n < slen; n++ )
{ int c = 'a'+(int)(26.0*rand()/(RAND_MAX+1.0));
if ( rand() & 0x1 )
c += 'A' - 'a';
salt[n] = c;
}
salt[n] = 0;
LOCK();
if ( slen > 2 )
{ s2 = md5_crypt(pw, salt);
} else
{ s2 = crypt(pw, salt);
}
rval = (*unify)(encrypted, s2);
UNLOCK();
return rval;
}
}
static foreign_t
pl_tipc_setopt(term_t Socket, term_t opt)
{ int socket;
atom_t a;
int arity;
if ( !tipc_get_socket(Socket, &socket) )
return FALSE;
if ( PL_get_name_arity(opt, &a, &arity) )
{ if ( a == ATOM_importance && arity == 1 )
{ atom_t val;
term_t a1 = PL_new_term_ref();
int ival = TIPC_LOW_IMPORTANCE;
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_atom(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "atom");
if(val == ATOM_low)
ival = TIPC_LOW_IMPORTANCE;
else if(val == ATOM_medium)
ival = TIPC_MEDIUM_IMPORTANCE;
else if(val == ATOM_high)
ival = TIPC_HIGH_IMPORTANCE;
else if(val == ATOM_critical)
ival = TIPC_CRITICAL_IMPORTANCE;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "low, medium, high, or critical");
return((tipc_setopt(socket, NB_TIPC_IMPORTANCE, ival) == 0) ? TRUE : FALSE);
}
}
if ( ((a == ATOM_dest_droppable) ||
(a == ATOM_src_droppable)) && arity == 1 )
{ int val;
term_t a1 = PL_new_term_ref();
int option = (a == ATOM_dest_droppable) ? NB_TIPC_DEST_DROPPABLE
: NB_TIPC_SRC_DROPPABLE;
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_bool(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "boolean");
return((tipc_setopt(socket, option, val) == 0) ? TRUE : FALSE);
}
}
if ( a == ATOM_conn_timeout && arity == 1 )
{ double val;
int ival;
term_t a1 = PL_new_term_ref();
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_float(a1, &val) || val < 0)
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "float");
ival = val * 1000; // time is in milliseconds
return((tipc_setopt(socket, NB_TIPC_CONN_TIMEOUT, ival) == 0) ? TRUE : FALSE);
}
}
if ( a == ATOM_nodelay && arity <= 1 )
{ int enable, rc;
if ( arity == 0 )
{ enable = TRUE;
} else /*if ( arity == 1 )*/
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( !PL_get_bool(a, &enable) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "boolean");
}
if ( (rc=nbio_setopt(socket, TCP_NO_DELAY, enable) == 0) )
return TRUE;
if ( rc == -2 )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "socket_option");
}
if ( a == ATOM_nonblock && arity == 0 )
return((nbio_setopt(socket, TCP_NONBLOCK) == 0) ? TRUE : FALSE );
if ( a == ATOM_dispatch && arity == 1 )
{ int val;
term_t a1 = PL_new_term_ref();
if ( PL_get_arg(1, opt, a1) && PL_get_bool(a1, &val) )
{ if ( nbio_setopt(socket, TCP_DISPATCH, val) == 0 )
return TRUE;
return FALSE;
}
}
}
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "socket_option");
}
