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 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);
}
/* This function gets called when the fclose intrinsic is called on an fdopen
* derived object.
*/
void _pSLfclose_fdopen_fp (SLang_MMT_Type *mmt)
{
SLFile_FD_Type *f;
f = FD_Type_List;
while (f != NULL)
{
Stdio_MMT_List_Type *prev, *curr;
prev = NULL;
curr = f->stdio_mmt_list;
while (curr != NULL)
{
if (curr->stdio_mmt != mmt)
{
prev = curr;
curr = curr->next;
continue;
}
if (prev == NULL)
f->stdio_mmt_list = curr->next;
else
prev->next = curr->next;
SLang_free_mmt (mmt);
SLfree ((char *) curr);
return;
}
f = f->next;
}
}
static void cl_foreach_close (SLtype type, SLang_Foreach_Context_Type *c)
{
(void) type;
if (c == NULL) return;
SLang_free_mmt (c->mmt);
SLfree ((char *) c);
}
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 int posix_fileno_int (void)
{
int fd;
SLFile_FD_Type *f;
if (SLang_peek_at_stack () == SLANG_FILE_PTR_TYPE)
{
SLang_MMT_Type *mmt;
FILE *fp;
if (-1 == SLang_pop_fileptr (&mmt, &fp))
return -1;
fd = fileno (fp);
SLang_free_mmt (mmt);
return fd;
}
if (-1 == SLfile_pop_fd (&f))
return -1;
if (-1 == get_fd (f, &fd))
fd = -1;
SLfile_free_fd (f);
return fd;
}
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;
}
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 void encode_csv_row_intrin (void)
{
SLang_Array_Type *at;
CSV_Type *csv;
SLang_MMT_Type *mmt;
int flags;
int has_flags;
char *str;
if (SLang_Num_Function_Args == 3)
{
if (-1 == SLang_pop_int (&flags))
return;
has_flags = 1;
}
else has_flags = 0;
if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
return;
if (NULL == (csv = pop_csv_type (&mmt)))
{
SLang_free_array (at);
return;
}
if (0 == has_flags)
flags = csv->flags;
str = csv_encode (csv, (char **)at->data, at->num_elements, flags);
SLang_free_mmt (mmt);
SLang_free_array (at);
(void) SLang_push_malloced_string (str);
}
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 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 SLang_MMT_Type *pop_sri_type (Slsh_Readline_Type **srip)
{
SLang_MMT_Type *mmt;
if (NULL == (mmt = SLang_pop_mmt (Rline_Type_Id)))
return NULL;
if (NULL == (*srip = (Slsh_Readline_Type *)SLang_object_from_mmt (mmt)))
{
SLang_free_mmt (mmt);
return NULL;
}
return mmt;
}
static void free_cb_info (Rline_CB_Type *cb)
{
if (cb == NULL)
return;
if (cb->mmt != NULL) SLang_free_mmt (cb->mmt);
if (cb->update_hook != NULL) SLang_free_function (cb->update_hook);
if (cb->clear_cb != NULL) SLang_free_function (cb->clear_cb);
if (cb->preread_cb != NULL) SLang_free_function (cb->preread_cb);
if (cb->postread_cb != NULL) SLang_free_function (cb->postread_cb);
if (cb->width_cb != NULL) SLang_free_function (cb->width_cb);
if (cb->cd != NULL) SLang_free_anytype (cb->cd);
SLfree ((char *)cb);
}
static SLang_MMT_Type *pop_rli_type (SLang_RLine_Info_Type **rlip)
{
SLang_MMT_Type *mmt;
if (NULL == (mmt = SLang_pop_mmt (Rline_Type_Id)))
return NULL;
if (NULL == (*rlip = (SLang_RLine_Info_Type *)SLang_object_from_mmt (mmt)))
{
SLang_free_mmt (mmt);
return NULL;
}
return mmt;
}
static void free_stdio_mmts (SLFile_FD_Type *f)
{
Stdio_MMT_List_Type *curr = f->stdio_mmt_list;
while (curr != NULL)
{
Stdio_MMT_List_Type *next = curr->next;
SLang_free_mmt (curr->stdio_mmt);
SLfree ((char *) curr);
curr = next;
}
f->stdio_mmt_list = NULL;
}
static void readline_noecho_intrinsic (char *prompt)
{
Slsh_Readline_Type *sri = NULL;
SLang_MMT_Type *mmt = NULL;
if (SLang_Num_Function_Args == 2)
{
if (NULL == (mmt = pop_sri_type (&sri)))
return;
}
(void) readline_intrinsic_internal (sri, prompt, 1);
if (mmt != NULL)
SLang_free_mmt (mmt);
}
static void readline_noecho_intrinsic (char *prompt)
{
SLang_RLine_Info_Type *rli = NULL;
SLang_MMT_Type *mmt = NULL;
if (SLang_Num_Function_Args == 2)
{
if (NULL == (mmt = pop_rli_type (&rli)))
return;
}
(void) readline_intrinsic_internal (rli, prompt, 1);
if (mmt != NULL)
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 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);
}
int _pSLassoc_aget (SLtype type, unsigned int num_indices)
{
unsigned long hash;
SLang_MMT_Type *mmt;
SLstr_Type *str;
_pSLAssoc_Array_Element_Type *e;
SLang_Assoc_Array_Type *a;
SLang_Object_Type *obj;
int ret;
(void) type;
if (-1 == pop_index (num_indices, &mmt, &a, &str, &hash))
return -1;
e = find_element (a, str, hash);
if (e == NULL)
{
if (a->flags & HAS_DEFAULT_VALUE)
obj = &a->default_value;
else
{
ret = -1;
_pSLang_verror (SL_INTRINSIC_ERROR,
"No such element in Assoc Array: %s", str);
goto free_and_return;
}
}
else obj = &e->value;
#if SLANG_OPTIMIZE_FOR_SPEED
if (a->is_scalar_type)
ret = SLang_push (obj);
else
#endif
ret = _pSLpush_slang_obj (obj);
free_and_return:
_pSLang_free_slstring (str);
SLang_free_mmt (mmt);
return ret;
}
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 posix_isatty (void)
{
int ret;
SLFile_FD_Type *f;
SLang_MMT_Type *mmt;
int fd;
if (-1 == pop_fd (&fd, &f, &mmt))
return 0; /* invalid descriptor */
if (0 == (ret = isatty (fd)))
_pSLerrno_errno = errno;
if (mmt != NULL) SLang_free_mmt (mmt);
if (f != NULL) SLfile_free_fd (f);
return ret;
}
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 void decode_csv_row_intrin (void)
{
CSV_Type *csv;
SLang_MMT_Type *mmt;
int flags = 0;
int has_flags = 0;
if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_int (&flags))
return;
has_flags = 1;
}
if (NULL == (csv = pop_csv_type (&mmt)))
return;
if (has_flags == 0)
flags = csv->flags;
(void) decode_csv_row (csv, flags);
SLang_free_mmt (mmt);
}
int _pSLassoc_aput (SLtype type, unsigned int num_indices)
{
SLang_MMT_Type *mmt;
SLstr_Type *str;
SLang_Assoc_Array_Type *a;
int ret;
unsigned long hash;
(void) type;
if (-1 == pop_index (num_indices, &mmt, &a, &str, &hash))
return -1;
if (NULL == assoc_aput (a, NULL, str, hash))
ret = -1;
else
ret = 0;
_pSLang_free_slstring (str);
SLang_free_mmt (mmt);
return ret;
}
