71f3a21998-11-22Fredrik Hübinette (Hubbe) #include <global.h> #include <svalue.h> #include <array.h> #include <stralloc.h> #include <interpret.h> #include <module_support.h> #include <threads.h> #include <mapping.h>
5a2b431998-11-22Fredrik Hübinette (Hubbe) #include <perl_machine.h> #ifdef HAVE_PERL
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #include <EXTERN.h> #include <perl.h> static int num_perl_interpreters=0; DEFINE_MUTEX(perl_running); #ifdef MULTIPLICITY #endif struct perlmod_storage { char **argv; char **env; char *env_block; struct array *argv_strings;
5a2b431998-11-22Fredrik Hübinette (Hubbe)  int parsed;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  PerlInterpreter *my_perl; }; #define THIS ((struct perlmod_storage *)(fp->current_storage)) #define PERL THIS->my_perl static void init_perl_glue(struct object *o) { PerlInterpreter *p; THIS->argv=0; THIS->env=0; THIS->env_block=0; THIS->argv_strings=0;
5a2b431998-11-22Fredrik Hübinette (Hubbe)  THIS->parsed=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #ifndef MULTIPLICITY if(num_perl_interpreters>0) { PERL=0; fprintf(stderr,"num_perl_interpreters=%d\n",num_perl_interpreters); /* error("Perl: There can be only one!\n"); */ return; } #endif THREADS_ALLOW(); mt_lock(&perl_running); p=perl_alloc(); mt_unlock(&perl_running); THREADS_DISALLOW(); PERL=p; if(p) num_perl_interpreters++; } static void exit_perl_glue(struct object *o) { if(PERL) {
5a2b431998-11-22Fredrik Hübinette (Hubbe)  struct perlmod_storage *storage=THIS;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  THREADS_ALLOW(); mt_lock(&perl_running);
5a2b431998-11-22Fredrik Hübinette (Hubbe)  if(storage->parsed) { perl_destruct(storage->my_perl); storage->parsed=0; } perl_free(storage->my_perl);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  mt_unlock(&perl_running); THREADS_DISALLOW(); num_perl_interpreters--; } if(THIS->argv) { free((char *)THIS->argv); THIS->argv=0; } if(THIS->argv_strings) { free_array(THIS->argv_strings); THIS->argv_strings=0; } if(THIS->env) { free((char *)THIS->env); THIS->env=0; } if(THIS->env_block) { free((char *)THIS->env_block); THIS->env_block=0; } } static void perlmod_run(INT32 args) { INT32 i; PerlInterpreter *p=PERL; if(!p) error("No perl interpreter available.\n"); pop_n_elems(args);
5a2b431998-11-22Fredrik Hübinette (Hubbe)  if(!THIS->argv_strings) error("Perl->create() must be called first.\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  THREADS_ALLOW(); mt_lock(&perl_running); i=perl_run(p); mt_unlock(&perl_running); THREADS_DISALLOW(); push_int(i); }
5a2b431998-11-22Fredrik Hübinette (Hubbe) static void perlmod_create(INT32 args)
71f3a21998-11-22Fredrik Hübinette (Hubbe) { extern void xs_init(void); int e; struct mapping *env_mapping=0; PerlInterpreter *p=PERL; struct perlmod_storage *storage=THIS;
5a2b431998-11-22Fredrik Hübinette (Hubbe)  check_all_args("Perl->create",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(!p) error("No perl interpreter available.\n"); if(THIS->argv_strings)
5a2b431998-11-22Fredrik Hübinette (Hubbe)  error("Perl->create() can only be called once.\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  switch(args) { default: env_mapping=sp[1-args].u.mapping; mapping_fix_type_field(env_mapping); if(m_ind_types(env_mapping) & ~BIT_STRING)
5a2b431998-11-22Fredrik Hübinette (Hubbe)  error("Bad argument 2 to Perl->create().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(m_val_types(env_mapping) & ~BIT_STRING)
5a2b431998-11-22Fredrik Hübinette (Hubbe)  error("Bad argument 2 to Perl->create().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  case 1: THIS->argv_strings=sp[-args].u.array; add_ref(THIS->argv_strings); array_fix_type_field(THIS->argv_strings);
5a2b431998-11-22Fredrik Hübinette (Hubbe)  if(THIS->argv_strings->size<2) error("Perl: Too few elements in argv array.\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(THIS->argv_strings->type_field & ~BIT_STRING)
08e6af1999-01-24Fredrik Hübinette (Hubbe)  error("Bad argument 1 to Perl->create().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  } THIS->argv=(char **)xalloc(sizeof(char *)*THIS->argv_strings->size); for(e=0;e<THIS->argv_strings->size;e++) THIS->argv[e]=ITEM(THIS->argv_strings)[e].u.string->str; if(env_mapping) { INT32 d; int env_block_size=0; char *env_blockp; struct keypair *k; MAPPING_LOOP(env_mapping) env_block_size+=k->ind.u.string->len+k->val.u.string->len+2; THIS->env_block=xalloc(env_block_size); THIS->env=(char **)xalloc(m_sizeof(env_mapping)+1); env_blockp=THIS->env_block; d=0; MAPPING_LOOP(env_mapping) { THIS->env[d++]=env_blockp; MEMCPY(env_blockp,k->ind.u.string->str,k->ind.u.string->len); env_blockp+=k->ind.u.string->len; *(env_blockp++)='='; MEMCPY(env_blockp,k->val.u.string->str,k->ind.u.string->len); env_blockp+=k->val.u.string->len; *(env_blockp++)='0'; } THIS->env[d]=0; } THREADS_ALLOW(); mt_lock(&perl_running);
5a2b431998-11-22Fredrik Hübinette (Hubbe)  if(!storage->parsed) { perl_construct(p); storage->parsed++; }
71f3a21998-11-22Fredrik Hübinette (Hubbe)  e=perl_parse(p, xs_init, storage->argv_strings->size, storage->argv, storage->env); mt_unlock(&perl_running); THREADS_DISALLOW(); pop_n_elems(args); push_int(e); } static void perlmod_eval(INT32 args) { error("Perl->eval not yet implemented.\n"); } static void perlmod_call(INT32 args) { error("Perl->call not yet implemented.\n"); } void pike_module_init(void) {
5a2b431998-11-22Fredrik Hübinette (Hubbe)  perl_destruct_level=2;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  start_new_program(); add_storage(sizeof(struct perlmod_storage));
5a2b431998-11-22Fredrik Hübinette (Hubbe)  add_function("create",perlmod_create,"function(array(string),void|mapping(string:string):int)",0);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  add_function("run",perlmod_run,"function(:int)",0); add_function("eval",perlmod_eval,"function(string:int)",0); add_function("call",perlmod_call,"function(string,mixed...:int)",0); set_init_callback(init_perl_glue); set_exit_callback(exit_perl_glue); end_class("Perl",0); add_integer_constant("MULTIPLICITY", #ifdef MULTIPLICITY 1, #else 0, #endif 0); } void pike_module_exit(void) { }
5a2b431998-11-22Fredrik Hübinette (Hubbe)  #else /* HAVE_PERL */ void pike_module_init(void) {} void pike_module_exit(void) {} #endif