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);
}
/* {SO_PEERCRED, NULL, get_peercred_sockopt}, */
# endif
# ifdef SO_RCVTIMEO
{SO_RCVTIMEO, set_timeval_sockopt, get_timeval_sockopt},
# endif
# ifdef SO_SNDTIMEO
{SO_SNDTIMEO, set_timeval_sockopt, get_timeval_sockopt},
# endif
# ifdef SO_LINGER
{SO_LINGER, set_linger_sockopt, get_linger_sockopt},
# endif
{-1, NULL, NULL}
};
#endif /* SOL_SOCKET */
#if defined(IP_ADD_MEMBERSHIP) /* either add or drop same args */
static int set_multicast_sockopt (Socket_Type *s, int level, int option)
{
struct ip_mreq group;
char *multi;
char *local = NULL;
Host_Addr_Info_Type *multi_info = NULL;
Host_Addr_Info_Type *local_info = NULL;
int ret = -1;
if (-1 == SLang_pop_slstring(&multi))
return -1;
if (5 == SLang_Num_Function_Args)
{
if (-1 == SLang_pop_slstring(&local))
{
SLang_free_slstring (multi);
return -1;
}
}
if (NULL == (multi_info = get_host_addr_info (multi)))
goto free_and_return;
if (local != NULL)
{
if (NULL == (local_info = get_host_addr_info (local)))
goto free_and_return;
memcpy ((char *) &group.imr_interface.s_addr, local_info->h_addr_list[0], local_info->h_length);
}
else
{
group.imr_interface.s_addr = INADDR_ANY;
}
memcpy ((char *) &group.imr_multiaddr.s_addr, multi_info->h_addr_list[0], multi_info->h_length);
ret = do_setsockopt (s->fd, level, option, (void *)&group, sizeof(group));
free_and_return:
SLang_free_slstring(multi);
if (NULL != local)
SLang_free_slstring(local);
free_host_addr_info (multi_info);
if (NULL != local_info)
free_host_addr_info (local_info);
return ret;
}
static void sl_base64_decode (void){
char* input, *in;
BIO* bmem,* b64;
SLang_BString_Type* output;
int i, outlen;
char nl[]="\n";
if (SLang_Num_Function_Args != 1 ||
SLang_pop_slstring(&in) == -1 ){
return; }
/* For some reason, the input is required to have a newline at the
end, doesn't matter how many, so tack one on here*/
input = SLang_concat_slstrings(in,nl);
SLang_free_slstring(in);
unsigned char* buff = (char*)malloc((int)strlen(input)+1);
memset(buff,0,(int)strlen(input));
b64 = BIO_new(BIO_f_base64());
bmem = BIO_new_mem_buf(input,(int)strlen(input));
bmem = BIO_push(b64,bmem);
outlen = BIO_read(bmem,buff,(int)strlen(input));
BIO_free_all(bmem);
output = SLbstring_create(buff, outlen);
SLang_push_bstring(output);
SLang_free_slstring(input);
SLbstring_free(output);
free(buff);
}
static int sl_report_function (Isis_Fit_Statistic_Type *s, void *pfp, double stat, unsigned int npts, unsigned int nvpars) /*{{{*/
{
FILE *fp = (FILE *)pfp;
char *str;
if (s == NULL || s->sl_report == NULL)
return -1;
SLang_start_arg_list ();
if ((-1 == SLang_push_double (stat))
|| (-1 == SLang_push_integer ((int) npts))
|| (-1 == SLang_push_integer ((int) nvpars)))
return -1;
SLang_end_arg_list ();
if (-1 == SLexecute_function ((SLang_Name_Type *)s->sl_report))
return -1;
if (-1 == SLang_pop_slstring (&str))
return -1;
if (EOF == fputs (str, fp))
{
SLang_free_slstring (str);
return -1;
}
SLang_free_slstring (str);
return 0;
}
static int pop_index (unsigned int num_indices,
SLang_MMT_Type **mmt,
SLang_Assoc_Array_Type **a,
SLstr_Type **str, unsigned long *hashp)
{
/* if (NULL == (*mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE))) */
if (-1 == SLclass_pop_ptr_obj (SLANG_ASSOC_TYPE, (VOID_STAR *) mmt))
{
*a = NULL;
*str = NULL;
return -1;
}
if ((num_indices != 1)
|| (-1 == SLang_pop_slstring (str)))
{
_pSLang_verror (SL_NOT_IMPLEMENTED,
"Assoc_Type arrays require a single string index");
SLang_free_mmt (*mmt);
*mmt = NULL;
*a = NULL;
*str = NULL;
return -1;
}
/* *a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*mmt); */
*a = (SLang_Assoc_Array_Type *) (*mmt)->user_data;
*hashp = _pSLstring_get_hash (*str);
return 0;
}
void _pSLpack (void)
{
SLang_BString_Type *bs;
char *fmt;
int nitems;
check_native_byte_order ();
nitems = SLang_Num_Function_Args;
if (nitems <= 0)
{
_pSLang_verror (SL_SYNTAX_ERROR,
"pack: not enough arguments");
return;
}
if ((-1 == SLreverse_stack (nitems))
|| (-1 == SLang_pop_slstring (&fmt)))
bs = NULL;
else
{
bs = pack_according_to_format (fmt, (unsigned int)nitems - 1);
SLang_free_slstring (fmt);
}
SLang_push_bstring (bs);
SLbstring_free (bs);
}
static void read_image (int flipped)
{
int color_type;
char *file;
SLang_Ref_Type *ref = NULL;
SLang_Array_Type *at;
if ((SLang_Num_Function_Args == 2)
&& (-1 == SLang_pop_ref (&ref)))
return;
if (-1 == SLang_pop_slstring (&file))
{
file = NULL;
goto free_return;
}
if (NULL == (at = read_image_internal (file, flipped, &color_type)))
goto free_return;
if ((ref != NULL)
&& (-1 == SLang_assign_to_ref (ref, SLANG_INT_TYPE, &color_type)))
{
SLang_free_array (at);
goto free_return;
}
(void) SLang_push_array (at, 1);
free_return:
SLang_free_slstring (file);
if (ref != NULL)
SLang_free_ref (ref);
}
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 void rline_setkey_intrinsic (char *keyseq)
{
char *str;
SLkeymap_Type *kmap;
if (NULL == (kmap = get_keymap ()))
return;
if (SLang_peek_at_stack () == SLANG_REF_TYPE)
{
SLang_Name_Type *nt;
if (NULL == (nt = SLang_pop_function ()))
return;
(void) SLkm_define_slkey (keyseq, nt, kmap);
return;
}
if (-1 == SLang_pop_slstring (&str))
return;
(void) SLang_define_key (keyseq, str, kmap);
SLang_free_slstring (str);
}
SLang_Name_Type *SLang_pop_function (void)
{
SLang_Ref_Type *ref;
SLang_Name_Type *f;
if (SLang_peek_at_stack () == SLANG_STRING_TYPE)
{
char *name;
if (-1 == SLang_pop_slstring (&name))
return NULL;
if (NULL == (f = SLang_get_function (name)))
{
_pSLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name);
SLang_free_slstring (name);
return NULL;
}
SLang_free_slstring (name);
return f;
}
if (-1 == SLang_pop_ref (&ref))
return NULL;
f = SLang_get_fun_from_ref (ref);
SLang_free_ref (ref);
return f;
}
static int exec_what (int what, int has_envp)
{
SLang_Array_Type *at_argv = NULL;
SLang_Array_Type *at_envp = NULL;
char **argv = NULL, **envp = NULL;
char *path = NULL;
int status = -1;
if (has_envp)
{
if (NULL == (envp = pop_argv (&at_envp)))
goto free_and_return;
}
if (NULL == (argv = pop_argv (&at_argv)))
goto free_and_return;
if (-1 == SLang_pop_slstring (&path))
goto free_and_return;
status = call_what (what, path, argv, envp);
free_and_return:
if (path != NULL) SLang_free_slstring (path);
if (argv != NULL) SLfree ((char *)argv);
if (at_argv != NULL) SLang_free_array (at_argv);
if (envp != NULL) SLfree ((char *)envp);
if (at_envp != NULL) SLang_free_array (at_envp);
return status;
}
static SLang_Foreach_Context_Type *
cl_foreach_open (SLtype type, unsigned int num)
{
SLang_Foreach_Context_Type *c;
unsigned char flags;
SLang_MMT_Type *mmt;
(void) type;
if (NULL == (mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE)))
return NULL;
flags = 0;
while (num--)
{
char *s;
if (-1 == SLang_pop_slstring (&s))
{
SLang_free_mmt (mmt);
return NULL;
}
if (0 == strcmp (s, "keys"))
flags |= CTX_WRITE_KEYS;
else if (0 == strcmp (s, "values"))
flags |= CTX_WRITE_VALUES;
else
{
_pSLang_verror (SL_NOT_IMPLEMENTED,
"using '%s' not supported by SLassoc_Type",
s);
_pSLang_free_slstring (s);
SLang_free_mmt (mmt);
return NULL;
}
_pSLang_free_slstring (s);
}
if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
{
SLang_free_mmt (mmt);
return NULL;
}
memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
if (flags == 0) flags = CTX_WRITE_VALUES|CTX_WRITE_KEYS;
c->flags = flags;
c->mmt = mmt;
c->a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (mmt);
#if SLANG_OPTIMIZE_FOR_SPEED
c->is_scalar = (SLANG_CLASS_TYPE_SCALAR == _pSLang_get_class_type (c->a->type));
#endif
return c;
}
static void strftime_cmd (void)
{
/* Rather then using some sort of portable version of strftime, which would
* miss the locale-specific features, just call the system routine. However,
* it cannot be called blindly because some versions (e.g., the the one from
* c.snippets.org) do no input checking, and use code such as
*
* static char *day[] = {"Sunday", "Monday", ..., "Saturday"};
* [...]
* switch (*f++)
* {
* case 'A' :
* r = day[t->tm_wday];
* break;
* [...]
*
* and lead to a SEGV if t->tm_wday is not in the range [0:6].
*/
struct tm tms;
char buf[4096];
int status;
char *fmt;
if (SLang_Num_Function_Args == 1)
{
time_t t = time(NULL);
if (-1 == call_localtime (t, &tms))
return;
if (-1 == validate_tm (&tms))
return;
}
else if (-1 == pop_tm_struct (&tms))
return;
if (-1 == SLang_pop_slstring (&fmt))
return;
/* Ugh. The man page says:
*
* The strftime() function returns the number of characters placed in the
* array s, not including the terminating NUL character, provided the
* string, including the terminating NUL, fits. Otherwise, it returns 0,
* and the contents of the array is undefined. (Thus at least since libc
* 4.4.4; very old versions of libc, such as libc 4.4.1, would return max
* if the array was too small.)
*
* Note that the return value 0 does not necessarily indicate an error;
* for example, in many locales %p yields an empty string.
*
* Was this too designed by committee?
*/
status = strftime (buf, sizeof(buf), fmt, &tms);
if (status == 0)
buf[0] = 0;
buf[sizeof(buf)-1] = 0;
(void) SLang_push_string (buf);
SLang_free_slstring (fmt);
}
static int pop_string_int (char **s, int *i)
{
*s = NULL;
if ((-1 == SLang_pop_integer (i))
|| (-1 == SLang_pop_slstring (s)))
return -1;
return 0;
}
static int pop_hooks_info (char **s, SLang_Name_Type **nt)
{
if (NULL == (*nt = SLang_pop_function ()))
return -1;
if (-1 == SLang_pop_slstring (s))
return -1;
return 0;
}
static void intrin_apropos (void)
{
int num_args;
char *pat;
char *namespace_name;
unsigned int flags;
SLang_Array_Type *at;
num_args = SLang_Num_Function_Args;
if (-1 == SLang_pop_uinteger (&flags))
return;
if (-1 == SLang_pop_slstring (&pat))
return;
namespace_name = NULL;
at = NULL;
if (num_args == 3)
{
if (-1 == SLang_pop_slstring (&namespace_name))
goto free_and_return;
}
at = _pSLang_apropos (namespace_name, pat, flags);
if (num_args == 3)
{
(void) SLang_push_array (at, 0);
goto free_and_return;
}
/* Maintain compatibility with old version of the function. That version
* did not take three arguments and returned everything to the stack.
* Yuk.
*/
(void) push_string_array_elements (at);
free_and_return:
/* NULLs ok */
SLang_free_slstring (namespace_name);
SLang_free_slstring (pat);
SLang_free_array (at);
}
static void usage (void)
{
char *msg;
_pSLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */
if (-1 == SLang_pop_slstring (&msg))
return;
_pSLang_verror (SL_USAGE_ERROR, "Usage: %s", msg);
SLang_free_slstring (msg);
}
static void import_module_intrin (void)
{
char *module;
char *ns = NULL;
if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_slstring (&ns))
return;
}
if (-1 == SLang_pop_slstring (&module))
{
SLang_free_slstring (ns); /* NULL ok */
return;
}
(void) import_module (module, ns);
SLang_free_slstring (module);
SLang_free_slstring (ns); /* NULL ok */
}
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 set_str_sockopt (Socket_Type *s, int level, int optname)
{
char *val;
socklen_t len;
int ret;
if (-1 == SLang_pop_slstring (&val))
return -1;
len = strlen (val); len++;
ret = do_setsockopt (s->fd, level, optname, (void *)val, len);
SLang_free_slstring (val);
return ret;
}
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 load_string_or_file (int (*f) (SLFUTURE_CONST char *, SLFUTURE_CONST char *))
{
char *file;
char *ns = NULL;
int status;
if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_slstring (&ns))
return -1;
}
if (-1 == SLang_pop_slstring (&file))
{
SLang_free_slstring (ns);
return -1;
}
status = (*f) (file, ns);
SLang_free_slstring (file);
SLang_free_slstring (ns);
return status;
}
int _pSLerr_throw (void)
{
int e;
int nargs = SLang_Num_Function_Args;
char *msg = NULL;
free_thrown_object ();
switch (nargs)
{
case 3:
if (-1 == SLang_pop (&Object_Thrown))
return -1;
Object_Thrownp = &Object_Thrown;
/* drop */
case 2:
if (-1 == SLang_pop_slstring (&msg))
{
free_thrown_object ();
return -1;
}
case 1:
/* drop */
if (-1 == _pSLerr_pop_exception (&e))
{
SLang_free_slstring (msg);/* NULL ok */
free_thrown_object ();
return -1;
}
break;
case 0: /* rethrow */
return rethrow_error ();
default:
_pSLang_verror (SL_NumArgs_Error, "expecting: throw error [, optional-message [, optional-arg]]");
return -1;
}
if (msg != NULL)
{
_pSLang_verror (e, "%s", msg);
SLang_free_slstring (msg);
}
else
SLang_set_error (e);
return 0;
}
static void set_frame_variable (void)
{
char *name;
int depth;
if (-1 == SLroll_stack (3))
return;
if (-1 == SLang_pop_slstring (&name))
return;
if (0 == SLang_pop_int (&depth))
(void) _pSLang_set_frame_variable ((unsigned int) depth, name);
SLang_free_slstring (name);
}
static void _pgtick (void)
{
float x1, x2, y1, y2, v, tikl, tikr, orient, disp;
char *s;
if (-1 == SLang_pop_slstring (&s))
return;
if ((0 == pop_5_floats (&v, &tikl, &tikr, &disp, &orient))
&& (0 == pop_5_floats (&x1, &y1, &x2, &y2, NULL)))
{
cpgtick (x1, y1, x2, y2, v, tikl, tikr, disp, orient, s);
}
SLang_free_slstring (s);
}
int SLpop_string (char **s) /*{{{*/
{
char *sls;
*s = NULL;
if (-1 == SLang_pop_slstring (&sls))
return -1;
if (NULL == (*s = SLmake_string (sls)))
{
SLang_free_slstring (sls);
return -1;
}
SLang_free_slstring (sls);
return 0;
}
/*}}}*/
#if defined(PF_INET) && defined(AF_INET) /*{{{*/
static int pop_host_port (SLFUTURE_CONST char *what, int nargs, char **hostp, int *portp)
{
char *host;
int port;
if (nargs != 2)
{
SLang_verror (SL_NumArgs_Error, "%s on an PF_INET socket requires a hostname and portnumber", what);
return -1;
}
*hostp = NULL;
if ((-1 == SLang_pop_int (&port))
|| (-1 == SLang_pop_slstring (&host)))
return -1;
*hostp = host;
*portp = port;
return 0;
}
static int set_multicast_if_sockopt (Socket_Type *s, int level, int option)
{
struct in_addr iface;
char *local;
Host_Addr_Info_Type *local_info;
if (-1 == SLang_pop_slstring(&local))
return -1;
if (NULL == (local_info = get_host_addr_info (local)))
{
SLang_free_slstring (local);
return -1;
}
memcpy ((char *) &iface.s_addr, local_info->h_addr_list[0], local_info->h_length);
SLang_free_slstring(local);
free_host_addr_info (local_info);
return do_setsockopt (s->fd, level, option, (void *)&iface, sizeof(iface));
}
static VOID_STAR pop_onig_name_ptr (Name_Map_Type *map, char *onig_object)
{
char *str;
if (-1 == SLang_pop_slstring (&str))
return NULL;
while (map->name != NULL)
{
if (0 == strcmp (str, map->name))
{
SLang_free_slstring (str);
return map->ptr;
}
map++;
}
SLang_verror (SL_InvalidParm_Error, "Unsupported or unknown onig %s: %s", onig_object, str);
SLang_free_slstring (str);
return NULL;
}
static void _pgaxis (void)
{
char *opt;
float x1, y_1, x2, y2, v1, v2, step;
int nsub;
float dmajl, dmajr, f_min, disp, orient;
if (-1 == pop_5_floats (&dmajl, &dmajr, &f_min, &disp, &orient))
return;
if (-1 == SLang_pop_integer (&nsub))
return;
if (-1 == pop_5_floats (&x2, &y2, &v1, &v2, &step))
return;
if (-1 == pop_5_floats (&x1, &y_1, NULL, NULL, NULL))
return;
if (-1 == SLang_pop_slstring (&opt))
return;
cpgaxis (opt, x1, y_1, x2, y2, v1, v2, step,
nsub, dmajl, dmajr, f_min, disp, orient);
SLang_free_slstring (opt);
}
