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 int is_numeric_intrinsic (void)
{
int type;
if (-1 == (type = SLang_peek_at_stack1 ()))
return -1;
(void) SLdo_pop ();
return is_numeric ((SLtype) type);
}
static Isis_Fit_Engine_Type *add_slang_fit_engine (char *eng_name, char *stat_name) /*{{{*/
{
Isis_Fit_Engine_Type *e;
if (NULL == (e = (Isis_Fit_Engine_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Engine_Type))))
return NULL;
memset ((char *)e, 0, sizeof (*e));
if ((NULL == (e->engine_name = isis_make_string (eng_name)))
|| (NULL == (e->default_statistic_name = isis_make_string (stat_name))))
{
slfe_deallocate (e);
ISIS_FREE (e);
return NULL;
}
e->method = &slfe_optimize;
e->deallocate = &slfe_deallocate;
e->set_options = &slfe_set_options;
e->set_range_hook = NULL;
e->range_hook = NULL;
e->verbose_hook = NULL;
e->warn_hook = NULL;
if (NULL == (e->sl_optimize = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (SLANG_NULL_TYPE == SLang_peek_at_stack())
SLdo_pop();
else if (NULL == (e->sl_set_options = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (NULL == (e->option_string = isis_make_string (eng_name)))
{
slfe_deallocate (e);
return NULL;
}
return e;
}
static int is_callable_intrinsic (void)
{
SLang_Ref_Type *ref;
int ret;
if (SLang_peek_at_stack () != SLANG_REF_TYPE)
{
(void) SLdo_pop ();
return 0;
}
if (-1 == SLang_pop_ref (&ref))
return -1;
ret = _pSLang_ref_is_callable (ref);
SLang_free_ref (ref);
return ret;
}
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 */
}
int SLang_assign_to_ref (SLang_Ref_Type *ref, SLtype type, VOID_STAR v)
{
SLang_Object_Type *stkptr;
SLang_Class_Type *cl;
cl = _pSLclass_get_class (type);
/* Use apush since this function is passing ``array'' bytes rather than the
* address of the data. I need to somehow make this more consistent. To
* see what I mean, consider:
*
* double z[2];
* char *s = "silly";
* char bytes[10]; BAD--- Don't do this
* int i;
*
* SLang_assign_to_ref (ref, SLANG_INT_TYPE, &i);
* SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s);
* SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z);
*
* That is, all external routines that take a VOID_STAR argument need to
* be documented such that how the function should be called with the
* various class_types.
*/
if (-1 == (*cl->cl_apush) (type, v))
return -1;
stkptr = _pSLang_get_run_stack_pointer ();
if (0 == _pSLang_deref_assign (ref))
return 0;
if (stkptr != _pSLang_get_run_stack_pointer ())
SLdo_pop ();
return -1;
}
/* Usage: array_reverse (a, [,from, to] [,dim]) */
static void array_reverse (void)
{
int len;
unsigned char *src, *dst;
size_t sizeof_type;
int dim = 0;
/* int has_dim = 0; */
int from = 0;
int to = -1;
int nargs;
SLang_Array_Type *at;
nargs = SLang_Num_Function_Args;
if ((nargs == 2) || (nargs == 4))
{
/* FIXME!!! */
/* has_dim = 1; */
if (-1 == SLang_pop_integer (&dim))
return;
_pSLang_verror (SL_NotImplemented_Error, "dim argument not yet implemented");
return;
}
if (nargs >= 3)
{
if ((-1 == SLang_pop_integer (&to))
|| (-1 == SLang_pop_integer (&from)))
return;
}
if ((from == to)
|| (SLang_peek_at_stack () != SLANG_ARRAY_TYPE))
{
(void) SLdo_pop (); /* do nothing */
return;
}
if (-1 == pop_writable_array (&at))
return;
len = (int) at->num_elements;
if (len == 0)
{ /* nothing to reverse */
SLang_free_array (at);
return;
}
if (-1 == check_range_indices (len, &from, &to))
{
SLang_free_array (at);
return;
}
sizeof_type = at->cl->cl_sizeof_type;
src = (unsigned char *)at->data + from*sizeof_type;
dst = (unsigned char *)at->data + to*sizeof_type;
while (src < dst)
{
unsigned int k;
for (k = 0; k < sizeof_type; k++)
{
unsigned char tmp = src[k];
src[k] = dst[k];
dst[k] = tmp;
}
src += sizeof_type;
dst -= sizeof_type;
}
SLang_free_array (at);
}