static void uname_cmd (void)
{
#ifdef HAVE_UNAME
struct utsname u;
SLFUTURE_CONST char *field_names [6];
SLtype field_types[6];
VOID_STAR field_values [6];
char *ptrs[6];
int i;
if (-1 == uname (&u))
(void) SLang_push_null ();
field_names[0] = "sysname"; ptrs[0] = u.sysname;
field_names[1] = "nodename"; ptrs[1] = u.nodename;
field_names[2] = "release"; ptrs[2] = u.release;
field_names[3] = "version"; ptrs[3] = u.version;
field_names[4] = "machine"; ptrs[4] = u.machine;
for (i = 0; i < 5; i++)
{
field_types[i] = SLANG_STRING_TYPE;
field_values[i] = (VOID_STAR) &ptrs[i];
}
if (0 == SLstruct_create_struct (5, field_names, field_types, field_values))
return;
#endif
SLang_push_null ();
}
static void posix_fileno (void)
{
FILE *fp;
SLang_MMT_Type *mmt;
int fd;
SLFile_FD_Type *f;
SLFUTURE_CONST char *name;
if (-1 == SLang_pop_fileptr (&mmt, &fp))
{
SLang_push_null ();
return;
}
name = SLang_get_name_from_fileptr (mmt);
fd = fileno (fp);
f = SLfile_create_fd (name, fd);
if (f != NULL)
{
/* prevent fd from being closed when it goes out of scope */
f->flags |= _SLFD_NO_AUTO_CLOSE;
f->close = dummy_close;
}
SLang_free_mmt (mmt);
if (-1 == SLfile_push_fd (f))
SLang_push_null ();
SLfile_free_fd (f);
}
static void get_prompt_hook (void)
{
if (Prompt_Hook == NULL)
(void) SLang_push_null ();
else
(void) SLang_push_function (Prompt_Hook);
}
static void posix_ttyname (void)
{
SLFile_FD_Type *f;
SLang_MMT_Type *mmt;
int fd;
char buf[512];
int e;
if (SLang_Num_Function_Args == 0)
{
fd = 0;
f = NULL;
mmt = NULL;
}
else if (-1 == pop_fd (&fd, &f, &mmt))
return;
if (0 != (e = TTYNAME_R (fd, buf, sizeof(buf))))
{
_pSLerrno_errno = e;
SLang_push_null ();
}
else
(void) SLang_push_string (buf);
if (mmt != NULL) SLang_free_mmt (mmt);
if (f != NULL) SLfile_free_fd (f);
}
static int push_opt_data (Isis_Fit_Statistic_Optional_Data_Type *opt_data) /*{{{*/
{
Optional_Data_Type odt;
int n, status=-1;
if (opt_data == NULL)
{
SLang_push_null ();
return 0;
}
memset ((char *)&odt, 0, sizeof odt);
n = opt_data->num;
if ((NULL == (odt.bkg = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| (NULL == (odt.bkg_at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| ((NULL == (odt.src_at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))))
goto free_and_return;
memcpy ((char *)odt.bkg->data, (char *)opt_data->bkg, n*sizeof(double));
memcpy ((char *)odt.bkg_at->data, (char *)opt_data->bkg_at, n*sizeof(double));
memcpy ((char *)odt.src_at->data, (char *)opt_data->src_at, n*sizeof(double));
if (-1 == SLang_push_cstruct ((VOID_STAR)&odt, Optional_Data_Type_Layout))
goto free_and_return;
status = 0;
free_and_return:
SLang_free_array (odt.bkg);
SLang_free_array (odt.bkg_at);
SLang_free_array (odt.src_at);
return status;
}
static void chksum_close (Chksum_Object_Type *obj)
{
unsigned char *digest;
unsigned int digest_len;
SLChksum_Type *c;
if (NULL == (c = obj->c))
{
(void) SLang_push_null ();
return;
}
digest_len = c->digest_len;
if (NULL == (digest = (unsigned char *)SLmalloc(2*digest_len+1)))
return;
if (-1 == c->close (c, digest))
{
SLfree ((char *)digest);
return;
}
obj->c = NULL;
hexify_string (digest, digest_len);
(void) SLang_push_malloced_string ((char *)digest);
}
int _pSLang_dup_and_push_slstring (SLCONST char *s)
{
if (NULL == (s = _pSLstring_dup_slstring (s)))
return SLang_push_null ();
return _pSLang_push_slstring ((char *) s);
}
int SLang_push_list (SLang_List_Type *list, int free_flag)
{
if (list == NULL)
return SLang_push_null ();
return push_list (list, free_flag);
}
static int push_values_array (Values_Array_Type *av, int allow_empty_array)
{
SLang_Array_Type *at;
char **new_values;
if (av->num == 0)
{
if (allow_empty_array == 0)
return SLang_push_null ();
SLfree ((char *) av->values);
av->values = NULL;
}
else
{
if (NULL == (new_values = (char **)SLrealloc ((char *)av->values, av->num*sizeof(char *))))
return -1;
av->values = new_values;
}
av->num_allocated = av->num;
at = SLang_create_array (SLANG_STRING_TYPE, 0, av->values, &av->num, 1);
if (at == NULL)
return -1;
av->num_allocated = 0;
av->num = 0;
av->values = NULL;
return SLang_push_array (at, 1);
}
static int fdtype_datatype_deref (SLtype type)
{
SLFile_FD_Type *f;
int status;
int fd;
(void) type;
if (-1 == SLang_pop_int (&fd))
return -1;
#ifdef F_GETFL
while (-1 == fcntl (fd, F_GETFL))
{
if (is_interrupt (errno, 1))
continue;
return SLang_push_null ();
}
#endif
f = find_chained_fd (fd);
if (f != NULL)
return SLfile_push_fd (f);
/* The descriptor is valid, but we have no record of what it is. So make sure
* it is not automatically closed.
*/
if (NULL == (f = SLfile_create_fd (NULL, fd)))
return -1;
f->flags |= _SLFD_NO_AUTO_CLOSE;
status = SLfile_push_fd (f);
SLfile_free_fd (f);
return status;
}
static void posix_open (void)
{
char *file;
int mode, flags;
SLFile_FD_Type *f;
switch (SLang_Num_Function_Args)
{
case 3:
if (-1 == pop_string_int_int (&file, &flags, &mode))
{
SLang_push_null ();
return;
}
break;
case 2:
default:
if (-1 == pop_string_int (&file, &flags))
return;
mode = 0777;
break;
}
f = SLfile_create_fd (file, -1);
if (f == NULL)
{
SLang_free_slstring (file);
SLang_push_null ();
return;
}
SLang_free_slstring (file);
while (-1 == (f->fd = open (f->name, flags, mode)))
{
if (is_interrupt (errno, 1))
continue;
SLfile_free_fd (f);
SLang_push_null ();
return;
}
if (-1 == SLfile_push_fd (f))
SLang_push_null ();
SLfile_free_fd (f);
}
static void posix_dup (SLFile_FD_Type *f)
{
if ((NULL == (f = SLfile_dup_fd (f)))
|| (-1 == SLfile_push_fd (f)))
SLang_push_null ();
SLfile_free_fd (f);
}
int SLang_push_string (SLFUTURE_CONST char *t) /*{{{*/
{
if (t == NULL)
return SLang_push_null ();
if (NULL == (t = SLang_create_slstring (t)))
return -1;
return _pSLang_push_slstring ((char *) t);
}
static int istruct_push (unsigned char type, VOID_STAR ptr)
{
_SLang_IStruct_Type *s;
s = *(_SLang_IStruct_Type **) ptr;
if ((s == NULL)
|| (s->addr == NULL)
|| (*(char **) s->addr == NULL))
return SLang_push_null ();
return SLclass_push_ptr_obj (type, (VOID_STAR) s);
}
static void getpriority_intrin (int *which, int *who)
{
int ret;
errno = 0;
ret = getpriority (*which, *who);
if ((ret == -1) && (errno != 0))
{
_pSLerrno_errno = errno;
(void) SLang_push_null ();
return;
}
(void) SLang_push_int (ret);
}
int SLang_push_bstring (SLang_BString_Type *b)
{
if (b == NULL)
return SLang_push_null ();
b->num_refs += 1;
if (0 == SLclass_push_ptr_obj (SLANG_BSTRING_TYPE, (VOID_STAR)b))
return 0;
b->num_refs -= 1;
return -1;
}
static void datatype_intrinsic (SLtype *t)
{
SLang_Class_Type *cl;
if (0 == SLclass_is_class_defined (*t))
{
(void) SLang_push_null ();
return;
}
cl = _pSLclass_get_class (*t);
(void) SLang_push_datatype (cl->cl_data_type);
}
static int ref_push (SLtype type, VOID_STAR ptr)
{
SLang_Ref_Type *ref;
(void) type;
ref = *(SLang_Ref_Type **) ptr;
if (ref == NULL)
return SLang_push_null ();
return SLang_push_ref (ref);
}
int SLfile_push_fd (SLFile_FD_Type *f)
{
if (f == NULL)
return SLang_push_null ();
f->num_refs += 1;
if (0 == SLclass_push_ptr_obj (SLANG_FILE_FD_TYPE, (VOID_STAR) f))
return 0;
f->num_refs -= 1;
return -1;
}
static void get_doc_string_intrin (char *topic)
{
char *file;
char **files;
unsigned int i, num_files;
if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_slstring (&file))
return;
if (-1 == get_doc_string (file, topic))
(void) SLang_push_null ();
SLang_free_slstring (file);
return;
}
if ((Doc_Files == NULL)
|| (NULL == (files = Doc_Files->buf)))
{
SLang_push_null ();
return;
}
num_files = Doc_Files->num;
for (i = 0; i < num_files; i++)
{
file = files[i];
if (file == NULL)
continue;
if (0 == get_doc_string (file, topic))
return;
}
(void) SLang_push_null ();
}
static void tcgetattr_intrin (SLFile_FD_Type *f)
{
struct termios s;
SLang_MMT_Type *mmt;
if (-1 == DO_SYSCALL_STRUCT_1(tcgetattr,f,&s))
{
SLang_push_null ();
return;
}
mmt = allocate_termios (&s); /* NULL ok */
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
static void nth_substr (Onig_Type *o, char *str, int *np)
{
unsigned int start, stop;
unsigned int len;
len = strlen (str);
if ((-1 == get_nth_start_stop (o, (unsigned int) *np, &start, &stop))
|| (start > len) || (stop > len))
{
SLang_push_null ();
return;
}
str = SLang_create_nslstring (str + start, stop - start);
(void) SLang_push_string (str);
SLang_free_slstring (str);
}
/* This function frees the socket before returning */
static int push_socket (Socket_Type *s)
{
SLFile_FD_Type *f;
int status;
if (s == NULL)
return SLang_push_null ();
if (NULL == (f = socket_to_fd (s)))
{
free_socket (s);
return -1;
}
status = SLfile_push_fd (f);
SLfile_free_fd (f);
return status;
}
int _pSLstring_list_push (_pSLString_List_Type *p, int delete_list)
{
SLang_Array_Type *at;
if ((p == NULL)
|| (p->buf == NULL))
{
int ret = SLang_push_null ();
if (delete_list)
_pSLstring_list_delete (p);
return ret;
}
if (NULL == (at = string_list_to_array (p, delete_list)))
return -1;
return SLang_push_array (at, 1);
}
static void nth_match (Onig_Type *o, int *np)
{
unsigned int start, stop;
SLang_Array_Type *at;
SLindex_Type two = 2;
int *data;
if (-1 == get_nth_start_stop (o, (unsigned int) *np, &start, &stop))
{
SLang_push_null ();
return;
}
if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &two, 1)))
return;
data = (int *)at->data;
data[0] = (int)start;
data[1] = (int)stop;
(void) SLang_push_array (at, 1);
}
static void waitpid_intrinsic (int *pid, int *options)
{
int status, ret;
Waitpid_Type s;
while (-1 == (ret = waitpid ((pid_t)*pid, &status, *options)))
{
if (errno == EINTR)
{
if (-1 != SLang_handle_interrupt ())
continue;
}
(void) SLerrno_set_errno (errno);
(void) SLang_push_null ();
return;
}
memset ((char *)&s, 0, sizeof(Waitpid_Type));
if (WIFEXITED(status))
{
s.exited = 1;
s.exit_status = WEXITSTATUS(status);
}
if (WIFSIGNALED(status))
{
s.signal = WTERMSIG(status);
#ifdef WCOREDUMP
s.coredump = WCOREDUMP(status) != 0;
#endif
}
if (WIFSTOPPED(status))
s.stopped = WSTOPSIG(status);
#ifdef WIFCONTINUED
s.continued = WIFCONTINUED(status);
#endif
s.pid = ret;
(void) SLang_push_cstruct ((VOID_STAR)&s, Waitpid_Struct);
}
static void qualifier_intrin (void)
{
int has_default;
char *name;
SLang_Struct_Type *q;
SLang_Object_Type *objp;
if (-1 == _pSLang_get_qualifiers (&q))
return;
has_default = (SLang_Num_Function_Args == 2);
if (has_default)
{
if (-1 == SLroll_stack (2))
return;
}
if (-1 == SLang_pop_slstring (&name))
return;
if (q != NULL)
objp = _pSLstruct_get_field_value (q, name);
else
objp = NULL;
SLang_free_slstring (name);
if (objp != NULL)
{
if (has_default)
SLdo_pop ();
_pSLpush_slang_obj (objp);
}
else if (has_default == 0)
(void) SLang_push_null ();
/* Note: objp and q should _not_ be freed since they were not allocated */
}
static void getrusage_intrin (void)
{
RUsage_Type rut;
int who = RUSAGE_SELF;
if ((SLang_Num_Function_Args == 1)
&& (-1 == SLang_pop_int (&who)))
return;
if (-1 == getrusage (who, &rut.r))
{
_pSLerrno_errno = errno;
(void) SLang_push_null ();
return;
}
rut.ru_stimesecs
= (double)rut.r.ru_stime.tv_sec + 1e-6*rut.r.ru_stime.tv_usec;
rut.ru_utimesecs
= (double)rut.r.ru_utime.tv_sec + 1e-6*rut.r.ru_utime.tv_usec;
(void) SLang_push_cstruct ((VOID_STAR) &rut, RUsage_Struct);
}
static void rline_get_history_intrinsic (void)
{
SLindex_Type i, num;
RL_History_Type *h;
char **data;
SLang_Array_Type *at;
if (Active_Rline_Info == NULL)
{
SLang_push_null ();
return;
}
num = 0;
h = Active_Rline_Info->root;
while (h != NULL)
{
h = h->next;
num++;
}
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1)))
return;
data = (char **)at->data;
h = Active_Rline_Info->root;
for (i = 0; i < num; i++)
{
if (NULL == (data[i] = SLang_create_slstring (h->buf)))
{
SLang_free_array (at);
return;
}
h = h->next;
}
(void) SLang_push_array (at, 1);
}
static void select_intrin (double *secsp)
{
SLang_Array_Type *at_read, *at_write, *at_except;
fd_set readfs_buf, writefds_buf, exceptfds_buf;
fd_set readfs_save_buf, writefds_save_buf, exceptfds_save_buf;
fd_set *readfs, *writefds, *exceptfds;
struct timeval tv, *tv_ptr;
double secs;
int ret, n;
secs = *secsp;
if (secs < 0.0) tv_ptr = NULL;
else
{
tv.tv_sec = (unsigned long) secs;
tv.tv_usec = (unsigned long) ((secs - tv.tv_sec) * 1e6);
tv_ptr = &tv;
}
n = 0;
if (-1 == pop_fd_set (&at_except, &exceptfds, &exceptfds_buf, &n))
return;
if (-1 == pop_fd_set (&at_write, &writefds, &writefds_buf, &n))
{
SLang_free_array (at_except);
return;
}
if (-1 == pop_fd_set (&at_read, &readfs, &readfs_buf, &n))
goto free_return;
readfs_save_buf = readfs_buf;
writefds_save_buf = writefds_buf;
exceptfds_save_buf = exceptfds_buf;
n += 1;
while (-1 == (ret = select (n, readfs, writefds, exceptfds, tv_ptr)))
{
#ifdef EINTR
if (errno == EINTR)
{
readfs_buf = readfs_save_buf;
writefds_buf = writefds_save_buf;
exceptfds_buf = exceptfds_save_buf;
if (0 == SLang_handle_interrupt ())
continue;
}
#endif
(void) SLerrno_set_errno (errno);
break;
}
if (ret == -1)
(void) SLang_push_null ();
else
(void) push_select_struct (ret, at_read, at_write, at_except,
readfs, writefds, exceptfds);
free_return:
SLang_free_array (at_read);
SLang_free_array (at_write);
SLang_free_array (at_except);
}
