int _SLns_set_namespace_name (SLang_NameSpace_Type *t, char *name)
{
SLang_NameSpace_Type *t1;
t1 = _SLns_find_namespace (name);
if (t == t1)
return 0; /* already has this name */
if (t1 == NULL)
t1 = t;
if ((t != t1) || (*name == 0))
{
SLang_verror (SL_INTRINSIC_ERROR, "Namespace \"%s\" already exists",
name);
return -1;
}
if (t->namespace_name != NULL)
{
SLang_verror (SL_INTRINSIC_ERROR, "An attempt was made to redefine namespace from \"%s\" to \"%s\"\n",
t->namespace_name, name);
return -1;
}
if (NULL == (name = SLang_create_slstring (name)))
return -1;
SLang_free_slstring (t->namespace_name); /* NULL ok */
t->namespace_name = name;
return 0;
}
static int bind_af_unix (Socket_Type *s, int nargs)
{
struct sockaddr_un addr;
char *file;
if (nargs != 1)
{
SLang_verror (SL_NumArgs_Error, "This socket expects a filename");
return -1;
}
if (-1 == SLang_pop_slstring (&file))
return -1;
if (strlen (file) >= sizeof(addr.sun_path))
{
SLang_verror (SL_InvalidParm_Error, "filename too long for PF_UNIX socket");
SLang_free_slstring (file);
return -1;
}
memset ((char *)&addr, 0, sizeof (struct sockaddr_un));
addr.sun_family = AF_UNIX;
strcpy (addr.sun_path, file); /* \0 terminated */
(void) unlink (file);
s->socket_data = (VOID_STAR) file;
return perform_bind (s->fd, (struct sockaddr *)&addr, sizeof (addr));
}
static Png_Type *open_png_file (char *file)
{
png_byte header[8];
Png_Type *p;
if (NULL == (p = alloc_png_type ('r')))
return NULL;
if ((NULL == (p->fp = fopen (file, "rb")))
|| (8 != fread (header, 1, 8, p->fp))
|| (0 != png_sig_cmp(header, 0, 8)))
{
SLang_verror (SL_Open_Error, "Unable to open %s as a png file", file);
free_png_type (p);
return NULL;
}
if (NULL == (p->png = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, NULL, NULL)))
{
SLang_verror (SL_Open_Error, "Unable to read png structure from %s", file);
free_png_type (p);
return NULL;
}
if (NULL == (p->info = png_create_info_struct (p->png)))
{
SLang_verror (SL_Read_Error, "Unable to create info struct for %s", file);
free_png_type (p);
return NULL;
}
return p;
}
int init_slsmg_module_ns (char *ns_name)
{
SLang_NameSpace_Type *ns;
static int inited = 0;
if (inited == 0)
{
#if defined(VMS) || defined(REAL_UNIX_SYSTEM)
int status;
char *term = getenv ("TERM");
if (term == NULL)
{
SLang_verror (SL_Application_Error, "The TERM environment variable is not set");
return -1;
}
status = SLtt_initialize (term);
if (status == -1)
{
SLang_verror (SL_RunTime_Error, "Cannot deduce properties for '%s' terminal", term);
return -1;
}
if (status < 0)
{
SLang_verror (SL_RunTime_Error, "The terminal '%s' lacks sufficient capabilities for controlling it", term);
return -1;
}
#else
SLtt_get_terminfo ();
#endif
inited = 1;
}
ns = SLns_create_namespace (ns_name);
if (ns == NULL)
return -1;
if ((-1 == SLns_add_intrin_fun_table (ns, Smg_Intrinsics, "__SLSMG__"))
|| (-1 == SLns_add_iconstant_table (ns, Smg_Constants, NULL)))
return -1;
if ((-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Display_Eight_Bit", (VOID_STAR)&SLsmg_Display_Eight_Bit, SLANG_INT_TYPE, 0))
|| (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Tab_Width", (VOID_STAR)&SLsmg_Tab_Width, SLANG_INT_TYPE, 0))
|| (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Newline_Behavior", (VOID_STAR)&SLsmg_Newline_Behavior, SLANG_INT_TYPE, 0))
|| (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Backspace_Moves", (VOID_STAR)&SLsmg_Backspace_Moves, SLANG_INT_TYPE, 0))
|| (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Screen_Rows", (VOID_STAR)&SLtt_Screen_Rows, SLANG_INT_TYPE, 0))
|| (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Screen_Cols", (VOID_STAR)&SLtt_Screen_Cols, SLANG_INT_TYPE, 0)))
return -1;
Smg_Initialized = 0;
return 0;
}
static void accept_intrin (void)
{
SLFile_FD_Type *f;
Socket_Type *s, *s1;
Domain_Methods_Type *methods;
int nargs = SLang_Num_Function_Args;
SLang_Ref_Type *refs[MAX_ACCEPT_REF_ARGS];
int i;
if (nargs <= 0)
{
SLang_verror (SL_Usage_Error, "s1 = accept (s [,&v...])");
return;
}
if (-1 == SLroll_stack (-nargs))
return;
if (NULL == (s = pop_socket (&f)))
return;
nargs--;
if (nargs > MAX_ACCEPT_REF_ARGS)
{
SLang_verror (SL_NumArgs_Error, "accept: too many reference args");
SLfile_free_fd (f);
}
memset ((char *)refs, 0, sizeof (refs));
i = nargs;
while (i != 0)
{
i--;
if (-1 == SLang_pop_ref (refs+i))
goto free_return;
}
methods = s->methods;
if (NULL != (s1 = (*methods->accept)(s, nargs, refs)))
(void) push_socket (s1); /* frees it upon error */
/* drop */
free_return:
for (i = 0; i < nargs; i++)
{
if (refs[i] != NULL)
SLang_free_ref (refs[i]);
}
SLfile_free_fd (f);
}
static void run_hooks_cmd (void)
{
unsigned int n;
SLang_Array_Type *at;
int method;
char *hook;
n = (unsigned int) SLang_Num_Function_Args;
at = NULL;
hook = NULL;
switch (n)
{
case 3:
if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
return;
/* drop */
case 2:
if (-1 == SLang_pop_integer (&method))
goto the_return;
if (-1 == SLang_pop_slstring (&hook))
goto the_return;
break;
default:
SLang_verror (SL_USAGE_ERROR, "usage: expecting 2 or 3 arguments");
return;
}
switch (method)
{
case JED_HOOKS_RUN_ALL:
case JED_HOOKS_RUN_UNTIL_0:
case JED_HOOKS_RUN_UNTIL_NON_0:
break;
default:
SLang_verror (SL_INVALID_PARM, "run method %d is not supported", method);
goto the_return;
}
if (at == NULL)
(void) jed_run_hooks (hook, method, 0, NULL);
else
(void) jed_run_hooks (hook, method, at->num_elements, (char **) at->data);
the_return:
SLang_free_slstring (hook);
SLang_free_array (at);
}
static int connect_af_inet (Socket_Type *s, int nargs)
{
struct sockaddr_in s_in;
int port;
char *host;
Host_Addr_Info_Type *hinfo;
unsigned int i;
if (-1 == pop_host_port ("connect", nargs, &host, &port))
return -1;
if (NULL == (hinfo = get_host_addr_info (host)))
{
SLang_free_slstring (host);
return -1;
}
if (hinfo->h_addrtype != AF_INET)
{
# ifdef AF_INET6
if (hinfo->h_addrtype == AF_INET6)
SLang_verror (SL_NOT_IMPLEMENTED, "AF_INET6 not implemented");
else
# endif
SLang_verror (SocketError, "Unknown socket family for host %s", host);
SLang_free_slstring (host);
free_host_addr_info (hinfo);
return -1;
}
memset ((char *) &s_in, 0, sizeof(s_in));
s_in.sin_family = hinfo->h_addrtype;
s_in.sin_port = htons((unsigned short) port);
for (i = 0; i < hinfo->num; i++)
{
memcpy ((char *) &s_in.sin_addr, hinfo->h_addr_list[i], hinfo->h_length);
if (-1 == perform_connect (s->fd, (struct sockaddr *)&s_in, sizeof (s_in), 0))
continue;
free_host_addr_info (hinfo);
SLang_free_slstring (host);
return 0;
}
throw_errno_error ("connect", errno);
free_host_addr_info (hinfo);
SLang_free_slstring (host);
return -1;
}
int user_create_ray (double *delta_t, double *energy,
double *cosx, double *cosy, double *cosz)
{
if (Num_Rays == 0)
{
if (-1 == SLexecute_function (Create_Ray))
{
SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray");
return -1;
}
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
return -1; /* done */
if ((-1 == pop_array (&CosZ_Array))
|| (-1 == pop_array (&CosY_Array))
|| (-1 == pop_array (&CosX_Array))
|| (-1 == pop_array (&Energy_Array))
|| (-1 == pop_array (&dT_Array)))
{
SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray");
return -1;
}
if (Num_Rays == 0)
return -1;
if (CosX_Array.num_elements < Num_Rays)
CosX_Array.di = 0;
if (CosY_Array.num_elements < Num_Rays)
CosY_Array.di = 0;
if (CosZ_Array.num_elements < Num_Rays)
CosZ_Array.di = 0;
if (dT_Array.num_elements < Num_Rays)
dT_Array.di = 0;
if (Energy_Array.num_elements < Num_Rays)
Energy_Array.di = 0;
}
*cosx = next_element (&CosX_Array);
*cosy = next_element (&CosY_Array);
*cosz = next_element (&CosZ_Array);
*delta_t = next_element (&dT_Array);
*energy = next_element (&Energy_Array);
Num_Rays--;
return 0;
}
static int test_type_sput (SLtype type, SLFUTURE_CONST char *name)
{
Test_Type *t;
int status;
(void) type;
if (-1 == pop_test_type (&t))
return -1;
status = -1;
if (0 == strcmp (name, "field1"))
status = SLang_pop_int (&t->field1);
else if (0 == strcmp (name, "field2"))
status = SLang_pop_int (&t->field2);
else if (0 == strcmp (name, "any"))
{
SLang_Any_Type *any;
if (0 == (status = SLang_pop_anytype (&any)))
{
SLang_free_anytype (t->any);
t->any = any;
}
}
else
SLang_verror (SL_INVALID_PARM,
"Test_Type.%s is invalid", name);
free_test_type (t);
return status;
}
/* printing arrays [code adapted from jdl functions by John Davis] */
static int
pop_matrix (SLang_Array_Type **at_ptr, unsigned int *nr, unsigned int *nc) /*{{{*/
{
SLang_Array_Type *at;
if (-1 == SLang_pop_array (&at, 0))
return -1;
switch (at->num_dims)
{
case 0:
*nr = *nc = 0;
break;
case 1:
*nr = (unsigned int)at->dims[0];
*nc = 1;
break;
case 2:
*nr = (unsigned int)at->dims[0];
*nc = (unsigned int)at->dims[1];
break;
default:
SLang_verror (SL_TYPE_MISMATCH, "operation limited to 2-d arrays");
SLang_free_array (at);
*at_ptr = NULL;
return -1;
}
*at_ptr = at;
return 0;
}
static void _iconv_open(char *tocode, char *fromcode)
{
iconv_t cd;
SLang_MMT_Type *mmt;
cd = iconv_open(tocode, fromcode);
if (cd == (iconv_t)(-1))
{
SLang_verror (SL_INTRINSIC_ERROR, "Error preparing iconv to convert from '%s' to '%s'.", fromcode, tocode);
return;
}
if (NULL == (mmt = allocate_iconv_type (cd)))
{
iconv_close(cd);
return;
}
if (-1 == SLang_push_mmt (mmt))
{
SLang_free_mmt (mmt);
return;
}
return;
}
/* This function is reentrant */
static int handle_signal (Signal_Type *s)
{
int status = 0;
int was_blocked;
(void) block_signal (s->sig, &was_blocked);
/* At this point, sig is blocked and the handler is about to be called.
* The pending flag can be safely set to 0 here.
*/
s->pending = 0;
if (s->handler != NULL)
{
int depth = SLstack_depth ();
if ((-1 == SLang_start_arg_list ())
|| (-1 == SLang_push_integer (s->sig))
|| (-1 == SLang_end_arg_list ())
|| (-1 == SLexecute_function (s->handler)))
status = -1;
if ((status == 0)
&& (depth != SLstack_depth ()))
{
SLang_verror (SL_Application_Error, "The signal handler %s corrupted the stack", s->handler->name);
status = -1;
}
}
if (was_blocked == 0)
(void) unblock_signal (s->sig);
return status;
}
static int do_onig_search_internal (Onig_Type *o, OnigOptionType option, UChar *str, UChar *str_end, int start_pos, int end_pos)
{
UChar *start, *range;
int status;
onig_region_clear (o->region);
start = str + start_pos;
range = str + end_pos;
/* fwd search: (start <= search string < range)
* bkw search: (range <= search string <= start)
*/
if ((start < str) || (start > str_end)
|| (range < str) || (range > str_end))
{
SLang_verror (SL_InvalidParm_Error, "Invalid string offsets");
return -1;
}
status = onig_search (o->re, str, str_end, start, range, o->region, option);
if (status >= 0)
return status;
if (status == ONIG_MISMATCH)
return -1;
throw_onig_error (status, NULL);
return -2;
}
/* Here nx corresponds to the fastest varying dimension and ny the slowest */
static SLang_Array_Type *pop_2d_float_array (float **data, unsigned int *ny, unsigned int *nx)
{
SLang_Array_Type *at;
*data = NULL;
*nx = *ny = 0;
if (-1 == SLclass_typecast (SLANG_FLOAT_TYPE, 1, 1))
return NULL;
if (-1 == SLang_pop_array (&at, 1))
return NULL;
if (at->num_dims > 2)
{
SLang_verror (SL_TYPE_MISMATCH,
"A 2d numeric array is expected");
SLang_free_array (at);
return NULL;
}
*data = (float *)at->data;
*ny = at->dims[0];
if (at->num_dims == 1)
*nx = 1;
else
*nx = at->dims[1];
return at;
}
static void sl_ssl_read(void){
SLssl_Type *ssl;
SLang_MMT_Type *sslmmt;
SLang_Ref_Type *buff;
void *ibuff;
SLang_BString_Type *data;
int r, rlen;
if (SLang_pop_integer(&rlen)==-1 ||
SLang_pop_ref(&buff)==-1 ||
NULL==(sslmmt=SLang_pop_mmt(SLssl_Type_Id)))
return;
ssl=(SLssl_Type *)SLang_object_from_mmt(sslmmt);
ibuff=(void *)malloc(rlen);
r=SSL_read((SSL *)ssl->ssl,ibuff,rlen);
data=SLbstring_create((unsigned char *)ibuff,r);
SLang_assign_to_ref(buff, SLANG_BSTRING_TYPE, (VOID_STAR)&data);
if (r>=0)
SLang_push_integer(r);
else
SLang_verror(r,"SSL read returned error code %d",
SSL_get_error((SSL *)ssl->ssl,r));
SLang_free_ref(buff);
}
static int setup_onig (void)
{
static int inited = 0;
if (inited)
return 0;
if ((-1 == slOnig_Error)
&& (-1 == (slOnig_Error = SLerr_new_exception (SL_RunTime_Error, "OnigError", "Onig Error"))))
return -1;
if (-1 == onig_init ())
{
SLang_verror (slOnig_Error, "onig_init failed");
return -1;
}
onig_set_warn_func (&warn_func);
onig_set_verb_warn_func (&verb_warn_func);
onig_set_default_syntax (ONIG_SYNTAX_PERL);
inited = 1;
return 0;
}
static void throw_onig_error (int err_code, OnigErrorInfo *einfo)
{
UChar err_buf[ONIG_MAX_ERROR_MESSAGE_LEN];
(void) onig_error_code_to_str (err_buf, err_code, einfo);
SLang_verror (slOnig_Error, "%s", err_buf);
}
static void termios_set_cc (void)
{
SLang_Array_Type *at;
SLang_MMT_Type *mmt;
struct termios *s;
unsigned char *at_data;
int i;
if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE))
return;
if (NULL == (mmt = SLang_pop_mmt (Termios_Type_Id)))
goto free_and_return;
s = (struct termios *) SLang_object_from_mmt (mmt);
if (at->num_elements != NCCS)
{
SLang_verror (SL_TYPE_MISMATCH,
"Expecting UChar_Type[%d]", NCCS);
goto free_and_return;
}
at_data = (unsigned char *) at->data;
for (i = 0; i < NCCS; i++)
s->c_cc[i] = at_data[i];
/* drop */
free_and_return:
SLang_free_array (at);
SLang_free_mmt (mmt);
}
static void pipe_intrin (void)
{
int fds[2];
SLFile_FD_Type *f0;
SLFile_FD_Type *f1;
while (-1 == pipe (fds))
{
if (errno == EINTR)
{
if (-1 != SLang_handle_interrupt ())
continue;
}
SLerrno_set_errno (errno);
SLang_verror (SL_OS_Error, "pipe failed: %s", SLerrno_strerror(errno));
return;
}
f0 = SLfile_create_fd ("*pipe*", fds[0]);
f1 = SLfile_create_fd ("*pipe*", fds[1]);
if ((NULL != f0) && (NULL != f1))
{
/* Ignore errors and allow the free_fd routines to clean up */
(void) SLfile_push_fd (f0);
(void) SLfile_push_fd (f1);
}
SLfile_free_fd (f1);
SLfile_free_fd (f0);
}
static int execve_intrin (void)
{
if (SLang_Num_Function_Args != 2)
SLang_verror (SL_Usage_Error, "Usage: ret = execvp(path, argv[]);");
return exec_what (CALL_EXECVE, 0);
}
static SLang_BString_Type *create_bstring_of_type (char *bytes, unsigned int len, int type)
{
SLang_BString_Type *b;
unsigned int size;
unsigned int malloced_len = len;
size = sizeof(SLang_BString_Type);
if (type == IS_BSTRING)
{
unsigned int dlen = BSTRING_EXTRA_BYTES(len);
malloced_len = len + dlen;
if ((malloced_len < len)
|| (size + malloced_len < size))
{
SLang_verror (SL_Malloc_Error, "Unable to create a binary string of the desired size");
return NULL;
}
size += malloced_len;
}
if (NULL == (b = (SLang_BString_Type *)SLmalloc (size)))
return NULL;
b->len = len;
b->malloced_len = malloced_len;
b->num_refs = 1;
b->ptr_type = type;
switch (type)
{
default:
case IS_BSTRING:
if (bytes != NULL) memcpy ((char *) b->v.bytes, bytes, len);
/* Now \0 terminate it because we want to also use it as a C string
* whenever possible. Note that sizeof(SLang_BString_Type) includes
* space for 1 character and we allocated len extra bytes. Thus, it is
* ok to add a \0 to the end.
*/
b->v.bytes[len] = 0;
break;
case IS_SLSTRING:
if (NULL == (b->v.ptr = (unsigned char *)SLang_create_nslstring (bytes, len)))
{
SLfree ((char *) b);
return NULL;
}
break;
case IS_MALLOCED:
case IS_NOT_TO_BE_FREED:
b->v.ptr = (unsigned char *)bytes;
bytes [len] = 0; /* NULL terminate */
break;
}
return b;
}
static MMap_Type *mmap_file (char *file, size_t offset, size_t num_bytes)
{
FILE *fp;
int fd;
struct stat st;
VOID_STAR addr;
MMap_Type *m;
fp = fopen (file, "rb");
if (fp == NULL)
{
SLang_verror (SL_OBJ_NOPEN, "mmap_array: unable to open %s for reading", file);
return NULL;
}
fd = fileno (fp);
if (-1 == fstat (fd, &st))
{
SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: stat %s failed", file);
fclose (fp);
return NULL;
}
if (NULL == (m = (MMap_Type *) SLmalloc (sizeof (MMap_Type))))
{
fclose (fp);
return NULL;
}
m->size_mmapped = num_bytes + offset;
addr = (VOID_STAR)mmap (NULL, m->size_mmapped, PROT_READ, MAP_SHARED, fd, 0);
if (addr == (VOID_STAR)MAP_FAILED)
{
SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: mmap %s failed", file);
SLfree ((char *) m);
fclose (fp);
return NULL;
}
m->addr = addr;
m->data = (VOID_STAR) ((char *)addr + offset);
fclose (fp);
return m;
}
static int check_vectors (SLang_Array_Type *a, SLang_Array_Type *b)
{
if (a->num_elements != b->num_elements)
{
SLang_verror (SL_TYPE_MISMATCH, "Arrays do not match in size");
return -1;
}
return 0;
}
static void sl_ssl_client (void){
// create an ssl object and return the memory managed type back to
// SLang. It needs the file descriptor of the object upon which
// communication will occur, and the protocol to use.
//
SSL_CTX *ctx;
SSL *ssl;
int proto, cret;
SLang_MMT_Type *mmt, *sslmmt;
SLsslctx_Type *slctx;
char *cadir=NULL, *cafile=NULL;
if (SLang_Num_Function_Args == 3)
if (SLang_pop_slstring(&cadir) == -1)
return;
if (SLang_Num_Function_Args > 1)
if (SLANG_NULL_TYPE==SLang_peek_at_stack())
SLdo_pop();
else if (SLang_pop_slstring(&cafile) == -1)
goto free;
if (SLang_pop_integer(&proto) == -1)
goto free;
if (proto==SSL_PROTO_SSL2)
ctx = SSL_CTX_new(SSLv23_client_method());
else if (proto==SSL_PROTO_SSL3)
ctx = SSL_CTX_new(SSLv3_client_method());
else if (proto==SSL_PROTO_TLS1)
ctx = SSL_CTX_new(TLSv1_client_method());
else if (proto==SSL_PROTO_ANY)
ctx = SSL_CTX_new(SSLv23_client_method());
cret = SSL_CTX_load_verify_locations(ctx, cafile, cadir);
if (cret == 0 && SLang_Num_Function_Args > 1){
SLang_verror(SL_APPLICATION_ERROR, "Failed to load CA file or path");
goto free;
}
slctx = (SLsslctx_Type *)malloc(sizeof(SLsslctx_Type));
slctx->is_server = 0;
slctx->ctx = (void *)ctx;
sslmmt = SLang_create_mmt(SLsslctx_Type_Id, (VOID_STAR) slctx);
if (0!=SLang_push_mmt(sslmmt))
SLang_free_mmt(sslmmt);
free:
if (NULL!=cadir)
SLang_free_slstring(cadir);
if (NULL!=cafile)
SLang_free_slstring(cafile);
}
static Socket_Type *socket_from_fd (SLFile_FD_Type *f)
{
Socket_Type *s;
if (-1 == SLfile_get_clientdata (f, Socket_Type_Id, (VOID_STAR *)&s))
{
SLang_verror (SL_TypeMismatch_Error, "File descriptor does not represent a socket");
return NULL;
}
return s;
}
static SLang_IStruct_Field_Type *istruct_pop_field (char *name, int no_readonly, VOID_STAR *addr)
{
_SLang_IStruct_Type *s;
SLang_IStruct_Field_Type *f;
char *struct_addr;
/* Note: There is no need to free this object */
if (-1 == SLclass_pop_ptr_obj (SLANG_ISTRUCT_TYPE, (VOID_STAR *) &s))
return NULL;
if (NULL == (struct_addr = *(char **)s->addr))
{
SLang_verror (SL_INTRINSIC_ERROR,
"%s is NULL. Unable to access field", s->name);
return NULL;
}
f = s->fields;
while (f->field_name != NULL)
{
/* Since both these are slstrings, just test pointers */
if (f->field_name != name)
{
f++;
continue;
}
if (no_readonly && f->read_only)
{
SLang_verror (SL_READONLY_ERROR,
"%s.%s is read-only", s->name, name);
return NULL;
}
*addr = (VOID_STAR) (struct_addr + f->offset);
return f;
}
SLang_verror (SL_TYPE_MISMATCH,
"%s has no field called %s", s->name, name);
return NULL;
}
static void sl_decrypt (void){
/* input types */
char *ctype;
unsigned char *outbuf, *iiv, *ikey, *idata;
SLang_BString_Type *iv, *key, *data;
/* internal types */
EVP_CIPHER_CTX ctx;
const EVP_CIPHER *cipher;
int outlen, tmplen, dlen, i;
/* output types */
SLang_BString_Type *output;
if (SLang_Num_Function_Args != 4 ||
SLang_pop_slstring(&ctype) == -1 ){
return; }
cipher = EVP_get_cipherbyname(ctype);
if (!cipher){
SLang_verror(SL_UNDEFINED_NAME,"could not find cipher %s",ctype);
return;
}
if (SLang_pop_bstring(&iv) == -1 ||
SLang_pop_bstring(&key) == -1 ||
SLang_pop_bstring(&data) == -1 ){
return; }
iiv = SLbstring_get_pointer (iv,&i);
ikey = SLbstring_get_pointer (key,&i);
idata = SLbstring_get_pointer (data,&dlen);
outbuf = (char*)malloc(dlen+EVP_CIPHER_block_size(cipher));
EVP_CIPHER_CTX_init(&ctx);
EVP_DecryptInit_ex(&ctx, cipher, NULL, ikey, iiv);
if (!EVP_DecryptUpdate(&ctx, outbuf, &outlen, idata, dlen)){
return; /*emit an error here*/
}
if (!EVP_DecryptFinal(&ctx, outbuf + outlen, &tmplen)){
return; /*emit an error here*/
}
outlen+=tmplen;
output = SLbstring_create (outbuf, outlen);
SLang_push_bstring(output);
SLbstring_free(output);
SLbstring_free(data);
SLbstring_free(key);
SLbstring_free(iv);
free(outbuf);
}
static int init_slang (void)
{
if ((-1 == SLang_init_all ())
|| (-1 == SLang_init_array_extra ())
|| (-1 == SLang_init_import ()) /* dynamic linking */
|| (-1 == SLadd_intrin_fun_table (Intrinsics, NULL)))
{
SLang_verror (0, "Unable to initialize S-Lang.\n");
return -1;
}
return 0;
}
static void getitimer_intrinsic (int *wp)
{
struct itimerval it;
if (-1 == getitimer (*wp, &it))
{
SLerrno_set_errno (errno);
SLang_verror (SL_OS_Error, "getitimer failed: %s", SLerrno_strerror (errno));
return;
}
(void) SLang_push_double (timeval_to_double (&it.it_value));
(void) SLang_push_double (timeval_to_double (&it.it_interval));
}
static int intp_pop (SLtype unused, VOID_STAR ptr)
{
int *addr;
(void) unused;
addr = *(int **)ptr;
if (addr == NULL)
{
SLang_verror (SL_VariableUninitialized_Error, "_IntegerP_Type: integer pointer address is NULL");
return -1;
}
return SLang_pop_integer (addr);
}
