static void posix_fdopen (SLFile_FD_Type *f, char *mode)
{
Stdio_MMT_List_Type *elem;
if (NULL == (elem = alloc_stdio_list_elem ()))
return;
if (-1 == _pSLstdio_fdopen (f->name, f->fd, mode))
{
SLfree ((char *)elem);
return;
}
if (NULL == (elem->stdio_mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE)))
{
SLfree ((char *) elem);
return;
}
if (-1 == SLang_push_mmt (elem->stdio_mmt))
{
SLfree ((char *) elem);
return;
}
elem->next = f->stdio_mmt_list;
f->stdio_mmt_list = elem;
}
static void rline_call_update_hook (SLrline_Type *rli,
SLFUTURE_CONST char *prompt,
SLFUTURE_CONST char *buf,
unsigned int len,
unsigned int point, VOID_STAR cd)
{
Rline_CB_Type *cb;
(void) rli;
(void) len;
cb = (Rline_CB_Type *)cd;
if (-1 == SLang_start_arg_list ())
return;
if ((-1 == SLang_push_mmt (cb->mmt))
|| (-1 == SLang_push_string (prompt))
|| (-1 == SLang_push_string (buf))
|| (-1 == SLang_push_int ((int) point))
|| ((cb->cd != NULL) && (-1 == SLang_push_anytype (cb->cd))))
{
(void) SLang_end_arg_list ();
return;
}
(void) SLexecute_function (cb->update_hook);
}
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;
}
static int default_push_mmt (SLtype type_unused, VOID_STAR ptr)
{
SLang_MMT_Type *ref;
(void) type_unused;
ref = *(SLang_MMT_Type **) ptr;
return SLang_push_mmt (ref);
}
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 void test_pop_mmt (void)
{
SLang_MMT_Type *mmt;
if (NULL == (mmt = SLang_pop_mmt (SLang_peek_at_stack ())))
return;
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
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 int call_simple_update_cb (SLang_Name_Type *f, Rline_CB_Type *cb, int *opt)
{
if (f == NULL)
return 0;
if (-1 == SLang_start_arg_list ())
return -1;
if ((-1 == SLang_push_mmt (cb->mmt))
|| ((opt != NULL) && (-1 == SLang_push_int (*opt)))
|| ((cb->cd != NULL) && (-1 == SLang_push_anytype (cb->cd))))
{
(void) SLang_end_arg_list ();
return -1;
}
return SLexecute_function (f);
}
static int push_onig_type (Onig_Type *o)
{
SLang_MMT_Type *mmt;
if (NULL == (mmt = SLang_create_mmt (Onig_Type_Id, (VOID_STAR) o)))
{
free_onig_type (o);
return -1;
}
if (-1 == SLang_push_mmt (mmt))
{
SLang_free_mmt (mmt);
return -1;
}
return 0;
}
static void new_slrline_intrinsic (char *name)
{
SLang_RLine_Info_Type *rli;
SLang_MMT_Type *mmt;
if (NULL == (rli = SLrline_open2 (name, SLtt_Screen_Cols, SL_RLINE_BLINK_MATCH)))
return;
if (NULL == (mmt = SLang_create_mmt (Rline_Type_Id, (VOID_STAR) rli)))
{
SLrline_close (rli);
return;
}
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
static void new_slrline_intrinsic (char *name)
{
Slsh_Readline_Type *sri;
SLang_MMT_Type *mmt;
if (NULL == (sri = open_slsh_readline (name, SL_RLINE_BLINK_MATCH)))
return;
if (NULL == (mmt = SLang_create_mmt (Rline_Type_Id, (VOID_STAR) sri)))
{
close_slsh_readline (sri);
return;
}
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
static int assoc_anew (SLtype type, unsigned int num_dims)
{
SLang_MMT_Type *mmt;
SLang_Assoc_Array_Type *a;
int has_default_value;
has_default_value = 0;
switch (num_dims)
{
case 0:
type = SLANG_ANY_TYPE;
break;
case 2:
(void) SLreverse_stack (2);
has_default_value = 1;
/* drop */
case 1:
if (0 == SLang_pop_datatype (&type))
break;
num_dims--;
/* drop */
default:
SLdo_pop_n (num_dims);
_pSLang_verror (SL_SYNTAX_ERROR, "Usage: Assoc_Type [DataType_Type]");
return -1;
}
a = alloc_assoc_array (type, has_default_value);
if (a == NULL)
return -1;
if (NULL == (mmt = SLang_create_mmt (SLANG_ASSOC_TYPE, (VOID_STAR) a)))
{
delete_assoc_array (a);
return -1;
}
if (-1 == SLang_push_mmt (mmt))
{
SLang_free_mmt (mmt);
return -1;
}
return 0;
}
static int termios_dereference (SLtype type, VOID_STAR addr)
{
struct termios *s;
SLang_MMT_Type *mmt;
(void) type;
mmt = *(SLang_MMT_Type **) addr;
if (NULL == (s = (struct termios *)SLang_object_from_mmt (mmt)))
return -1;
mmt = allocate_termios (s);
if (-1 == SLang_push_mmt (mmt))
{
SLang_free_mmt (mmt);
return -1;
}
return 0;
}
static void new_csv_encoder_intrin (void)
{
CSV_Type *csv;
SLang_MMT_Type *mmt;
if (NULL == (csv = (CSV_Type *)SLmalloc(sizeof(CSV_Type))))
return;
memset ((char *)csv, 0, sizeof(CSV_Type));
if ((-1 == SLang_pop_int (&csv->flags))
||(-1 == SLang_pop_char (&csv->quotechar))
|| (-1 == SLang_pop_char (&csv->delimchar))
|| (NULL == (mmt = SLang_create_mmt (CSV_Type_Id, (VOID_STAR)csv))))
{
free_csv_type (csv);
return;
}
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
static void sl_ssl_connect (void){
int fd;
SLFile_FD_Type *slfd;
SLsslctx_Type *ctx;
SLssl_Type *slssl;
SSL *ssl;
SLang_MMT_Type *sslmmt;
SLang_MMT_Type *sslmmto;
if (SLfile_pop_fd(&slfd) == -1)
return;
if (NULL==(sslmmt=SLang_pop_mmt(SLsslctx_Type_Id)))
return;
SLfile_get_fd(slfd,&fd);
SLfile_free_fd(slfd);
ctx = (SLsslctx_Type *)SLang_object_from_mmt(sslmmt);
// create the ssl object
ssl = SSL_new((SSL_CTX *)ctx->ctx);
// set the file descriptor for input/output
if (0==SSL_set_fd(ssl,fd)){
return;
}
// fprintf(stderr,"Set client socket fd to %d\n",fd);
slssl = (SLssl_Type *)malloc(sizeof(SLssl_Type));
slssl->ssl = (void *) ssl;
slssl->is_server = ctx->is_server;
sslmmt = SLang_create_mmt(SLssl_Type_Id, (VOID_STAR) slssl);
if (0==SLang_push_mmt(sslmmt))
return;
SLang_free_mmt(sslmmt);
}
static int slfe_optimize (Isis_Fit_Type *ift, void *clientdata, /*{{{*/
double *x, double *y, double *weights, unsigned int npts,
double *pars, unsigned int npars)
{
Isis_Fit_Engine_Type *e;
SLang_Array_Type *sl_pars=NULL, *sl_pars_min=NULL, *sl_pars_max=NULL;
SLang_Array_Type *sl_new_pars=NULL;
SLindex_Type n;
int status = -1;
(void) clientdata; (void) x; (void) y; (void) weights; (void) npts;
if ((ift == NULL) || (pars == NULL) || (npars <= 0)
|| (Current_Fit_Object_MMT == NULL))
return -1;
e = ift->engine;
n = (SLindex_Type) npars;
sl_pars = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_min = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_max = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
if ((NULL == sl_pars) || (NULL == sl_pars_min) || (NULL == sl_pars_max))
return -1;
memcpy ((char *)sl_pars->data, (char *)pars, npars * sizeof(double));
memcpy ((char *)sl_pars_min->data, (char *)e->par_min, npars * sizeof(double));
memcpy ((char *)sl_pars_max->data, (char *)e->par_max, npars * sizeof(double));
/* FIXME: Increment the reference count to prevent a segv.
* There must be a better way.
*/
SLang_inc_mmt (Current_Fit_Object_MMT);
SLang_start_arg_list ();
if ((-1 == SLang_push_mmt (Current_Fit_Object_MMT))
|| (-1 == SLang_push_array (sl_pars, 1))
|| (-1 == SLang_push_array (sl_pars_min, 1))
|| (-1 == SLang_push_array (sl_pars_max, 1)))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"calling user-defined optimization method '%s'",
e->engine_name);
goto return_error;
}
SLang_end_arg_list ();
if (-1 == SLexecute_function (e->sl_optimize))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"executing optimization method '%s'",
e->engine_name);
goto return_error;
}
if (-1 == SLang_pop_array_of_type (&sl_new_pars, SLANG_DOUBLE_TYPE))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"returning results from optimization method '%s'",
e->engine_name);
goto return_error;
}
if ((sl_new_pars == NULL) || (sl_new_pars->num_elements != npars))
{
isis_vmesg (FAIL, I_ERROR, __FILE__, __LINE__,
"corrupted parameter array returned from optimization method '%s'",
e->engine_name);
goto return_error;
}
memcpy ((char *)pars, (char *)sl_new_pars->data, npars * sizeof(double));
status = 0;
return_error:
SLang_free_array (sl_new_pars);
if (SLang_get_error())
{
isis_throw_exception (SLang_get_error());
return -1;
}
return status;
}
static void sl_ssl_server (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
//
// this is the server, so it also needs the certfile and private key
SSL_CTX *ctx;
SSL *ssl;
int proto, pkey_type, cert_type;
SLang_MMT_Type *sslmmt;
SLFile_FD_Type *slfd;
SLsslctx_Type *slctx;
char *pkey=NULL, *cert=NULL;
if (SLang_pop_slstring(&pkey) == -1 ||
SLang_pop_slstring(&cert) == -1 ||
SLang_pop_integer(&proto) == -1){
goto free;
return;
}
if (proto==SSL_PROTO_SSL2)
ctx = SSL_CTX_new(SSLv23_server_method());
else if (proto==SSL_PROTO_SSL3)
ctx = SSL_CTX_new(SSLv3_server_method());
else if (proto==SSL_PROTO_TLS1)
ctx = SSL_CTX_new(TLSv1_server_method());
else if (proto==SSL_PROTO_ANY)
ctx = SSL_CTX_new(SSLv23_server_method());
// now add the cert file an private key
if (1!=SSL_CTX_use_certificate_file(ctx,cert,SSL_FILETYPE_PEM))
if (1!=SSL_CTX_use_certificate_file(ctx,cert,SSL_FILETYPE_ASN1)){
SLang_verror(0,"Could not load certificate file");
goto free;
}
if (1!=SSL_CTX_use_PrivateKey_file(ctx,pkey,SSL_FILETYPE_PEM))
if (1!=SSL_CTX_use_PrivateKey_file(ctx,pkey,SSL_FILETYPE_ASN1)){
SLang_verror(0,"Could not load private key");
goto free;
}
if (1!=SSL_CTX_check_private_key(ctx)){
SLang_verror(0,"Certificate and private keys do not match");
goto free;
}
slctx = (SLsslctx_Type *)malloc(sizeof(SLsslctx_Type));
slctx->is_server = 1;
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!=pkey)
SLang_free_slstring(pkey);
if (NULL!=cert)
SLang_free_slstring(cert);
}