int modperl_require_module(pTHX_ const char *pv, int logfailure) { SV *sv; dSP; PUSHSTACKi(PERLSI_REQUIRE); ENTER;SAVETMPS; PUTBACK; sv = sv_newmortal(); sv_setpv(sv, "require "); sv_catpv(sv, pv); eval_sv(sv, G_DISCARD); SPAGAIN; POPSTACK; FREETMPS;LEAVE; if (SvTRUE(ERRSV)) { if (logfailure) { (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR, NULL, NULL); } return FALSE; } return TRUE; }
static int set_record(struct _std_event *ev_ptr, char *response,struct _firewall_info *fw_info){ if(fw_info){ /* equals to NULL means its a key value firewall * else a regular expression firewall */ if(fw_info->fw_regex == NULL) { //printf(" key value type log \n"); if(parse_keyvalue(ev_ptr,response,fw_info->un.kv)<0){ //printf("Not able to parse kv_pair\n"); return -1; } }else{ #ifdef REGEX if( regex_event_count++ < MAX_REGEX_EVENTS ){ char logid[50]; //int i_log_id; struct _log_info *found_log_info=NULL; //printf(" regex type log $log=%s\n",response); sv_setpvf(sv , "$log='%s'" , response); eval_sv(sv , G_SCALAR); /* Apply fw_info->regex and get log id * use that log id to get log_info struct from log_info_hash */ if(SvIV(eval_pv(fw_info->fw_regex,TRUE))){ strncpy(logid,SvPV(get_sv("logtype" , FALSE) , n_a), sizeof(logid)-1); //printf(" logtype = -%s-\n" , logid); //i_log_id=atoi(logid); HASH_FIND_STR(fw_info->un.log_hash, logid , found_log_info); if(found_log_info==NULL){ printf(" no log info found for logid %s\n",logid); return -1; } if( parse_regex( ev_ptr, response, found_log_info )<0 ){ printf(" parsing regex error %s\n",logid); return -1; } }else{ printf("fw_regex did not work \n"); } }else{ regex_event_count=0; perl_reset(); } #endif } }else{ printf("fw_info for given ip address is blank.%s\n",response); return -1; } return 1; }
static int proxenet_perl_load_file(plugin_t* plugin) { char *pathname = NULL; size_t pathlen = 0; SV* sv = NULL; int nb_res = -1; SV* package_sv = NULL; char *required = NULL; char *package_name = NULL; size_t package_len, len = 0; int ret = -1; pathlen = strlen(cfg->plugins_path) + 1 + strlen(plugin->filename) + 1; pathname = (char*) alloca(pathlen+1); proxenet_xzero(pathname, pathlen+1); snprintf(pathname, pathlen, "%s/%s", cfg->plugins_path, plugin->filename); #ifdef DEBUG xlog(LOG_DEBUG, "[Perl] Loading '%s'\n", pathname); #endif /* Load the file through perl's require mechanism */ dSP; ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; sv = newSVpvf("$package = require q%c%s%c", 0, pathname, 0); nb_res = eval_sv(sv_2mortal(sv), G_EVAL); if (nb_res != 1) { xlog(LOG_ERROR, "[Perl] Invalid number of response returned while loading '%s' (got %d, expected 1)\n", pathname, nb_res); } else if (SvTRUE(ERRSV)) { xlog(LOG_ERROR, "[Perl] Eval error for '%s': %s\n", pathname, SvPV_nolen(ERRSV)); } else { /* Get the package name from the package (which should follow the convention...) */ package_sv = get_sv("package", 0); /* Check if the SV* stores a string */ if (!SvPOK(package_sv)) { xlog(LOG_ERROR, "[Perl] Invalid convention for '%s': the package should return a string\n", pathname); } else { required = (char*) SvPV_nolen(package_sv); package_len = strlen(required); package_name = (char*) alloca(package_len+1); proxenet_xzero(package_name, package_len+1); memcpy(package_name, required, package_len); #ifdef DEBUG xlog(LOG_DEBUG, "[Perl] Package of name '%s' loaded\n", package_name); #endif /* Save the functions' full name to call them later */ len = package_len + 2 + strlen(CFG_REQUEST_PLUGIN_FUNCTION); plugin->pre_function = proxenet_xmalloc(len + 1); snprintf(plugin->pre_function, len+1, "%s::%s", package_name, CFG_REQUEST_PLUGIN_FUNCTION); len = package_len + 2 + strlen(CFG_RESPONSE_PLUGIN_FUNCTION); plugin->post_function = proxenet_xmalloc(len + 1); snprintf(plugin->post_function, len+1, "%s::%s", package_name, CFG_RESPONSE_PLUGIN_FUNCTION); ret = 0; } } SPAGAIN; PUTBACK; FREETMPS; LEAVE; return ret; }
static int load_indexed_hash_module_ex(pTHX_ CBC *THIS, const char **modlist, int num) { const char *p = NULL; int i; if (THIS->ixhash != NULL) { /* a module has already been loaded */ return 1; } for (i = 0; i < num; i++) { if (modlist[i]) { SV *sv = newSVpvn("require ", 8); sv_catpv(sv, CONST_CHAR(modlist[i])); CT_DEBUG(MAIN, ("trying to require \"%s\"", modlist[i])); (void) eval_sv(sv, G_DISCARD); SvREFCNT_dec(sv); if ((sv = get_sv("@", 0)) != NULL && strEQ(SvPV_nolen(sv), "")) { p = modlist[i]; break; } if (i == 0) { Perl_warn(aTHX_ "Couldn't load %s for member ordering, " "trying default modules", modlist[i]); } CT_DEBUG(MAIN, ("failed: \"%s\"", sv ? SvPV_nolen(sv) : "[NULL]")); } } if (p == NULL) { SV *sv = newSVpvn("", 0); for (i = 1; i < num; i++) { if (i > 1) { if (i == num-1) sv_catpvn(sv, " or ", 4); else sv_catpvn(sv, ", ", 2); } sv_catpv(sv, CONST_CHAR(modlist[i])); } Perl_warn(aTHX_ "Couldn't load a module for member ordering " "(consider installing %s)", SvPV_nolen(sv)); return 0; } CT_DEBUG(MAIN, ("using \"%s\" for member ordering", p)); THIS->ixhash = p; return 1; }
const Array::Temp Call_stack::eval_list(SV* string) { const int count = eval_sv(string, G_ARRAY); finish_call(); return Array::Temp(interp, pop_array(count), true); }
const Scalar::Temp Call_stack::eval_scalar(SV* string) { eval_sv(string, G_SCALAR); finish_call(); return Scalar::Temp(interp, pop(), true); }
/* Wrap a JS value to export into perl * Returns a new SV, REFCNT_dec is caller's responsability */ JSBool PJS_ReflectJS2Perl( pTHX_ JSContext *cx, jsval value, SV** sv, int full ) { if(JSVAL_IS_PRIMITIVE(value)) { *sv = PrimJSVALToSV(aTHX_ cx, value); if(*sv) return JS_TRUE; } else if(JSVAL_IS_OBJECT(value)) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *object = JSVAL_TO_OBJECT(value); JSClass *clasp = PJS_GET_CLASS(cx, object); const char *classname = clasp->name; JSObject *passport; SV *wrapper; SV *box; char hkey[32]; jsval temp = JSVAL_VOID; snprintf(hkey, 32, "%p", (void *)object); PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey); if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) { jsval src; char *str; if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) && (str = JS_GetStringBytes(JS_ValueToString(cx, src))) ) { dSP; SV *tmp = newSVpvf("qr%s", str); eval_sv(tmp, G_SCALAR); sv_free(tmp); // Don't leak SPAGAIN; tmp = POPs; PUTBACK; if(!SvTRUE(ERRSV)) { *sv = SvREFCNT_inc_simple_NN(tmp); return JS_TRUE; } } return JS_FALSE; } if(IS_PERL_CLASS(clasp)) { /* IS_PERL_CLASS means actual perl object is there */ SV *priv = (SV *)JS_GetPrivate(cx, object); if(priv && SvOK(priv) && SvROK(priv)) { *sv = SvREFCNT_inc_simple_NN(priv); return JS_TRUE; } croak("A private %s?!\n", classname); return JS_FALSE; } /* Common JSObject case */ /* Check registered perl visitors */ JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp); if(temp != JSVAL_VOID) { /* Already registered, so exits a reference in perl space * _must_ hold a PASSPORT */ assert(JSVAL_TO_OBJECT(temp) == object); box = PJS_GetPassport(aTHX_ cx, object); SvREFCNT_inc_void_NN(box); /* In perl should be one more */ PJS_DEBUG1("Cached!: %s\n", hkey); } else { /* Check if with a PASSPORT */ JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp); if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) && PJS_GET_CLASS(cx, passport) == &passport_class && JS_GetReservedSlot(cx, passport, 0, &temp) && object == (JSObject *)JSVAL_TO_PRIVATE(temp) ) { /* Yes, reentering perl */ box = (SV *)JS_GetPrivate(cx, passport); /* Here we don't increment refcount, the ownership in passport is * transferred to perl land. */ PJS_DEBUG1("Reenter: %s\n", hkey); } else { /* No, first time, must wrap the object */ SV *boxref; const char *package; SV *robj = newSV(0); SV *rjsv = newSV(0); if (JS_ObjectIsFunction(cx, object)) package = PJS_FUNCTION_PACKAGE; else if(JS_IsArrayObject(cx, object)) package = PJS_ARRAY_PACKAGE; else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME)) package = PJS_STASH_PACKAGE; #if JS_HAS_XML_SUPPORT else if(strEQ(classname, "XML")) package = PJS_XMLOBJ_PACKAGE; #endif else if(strEQ(classname, "Error")) package = PJS_ERROR_PACKAGE; else { SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname, strlen(classname), 0); if(sv) package = SvPV_nolen(*sv); else package = PJS_OBJECT_PACKAGE; } sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object); sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value); boxref = PJS_CallPerlMethod(aTHX_ cx, "__new", sv_2mortal(newSVpv(package, 0)), // package sv_2mortal(robj), // content sv_2mortal(rjsv), // jsval NULL ); if(!boxref) return JS_FALSE; if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE)) croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed"); /* Create a new PASSPORT */ passport = JS_NewObject(cx, &passport_class, NULL, object); if(!passport || !JS_DefineProperty(cx, object, PJS_PASSPORT_PROP, OBJECT_TO_JSVAL(passport), NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT)) return JS_FALSE; box = SvRV(boxref); /* boxref is mortal, so we need to increment its rc, at end of * scope, PASSPORT owns created box */ JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box)); JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object)); PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box)); } /* Root object adding it to pvisitors list, will be unrooted by * jsc_free_root at Boxed DESTROY time */ JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0); } /* Here the RC of box in PASSPORT reflects wrapper's ownership */ if(full && PJS_getFlag(pcx, "AutoTie") && (strEQ(classname, "Object") || strEQ(classname, "Array")) ) { /* Return tied */ AV *avbox = (AV *)SvRV(box); SV **last; SV *tied; SV *tier; if(strEQ(classname, "Array")) { last = av_fetch(avbox, 6, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newAV(); } else { // Object last = av_fetch(avbox, 5, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newHV(); } /* hv_magic below own a reference to box, we use an explicit path, * to make clear that to perl land only one reference is given */ tier = newRV_inc(box); hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied); sv_free(tier); wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */ /* Save in cache a weaken copy, the cache itself dosn't hold a reference */ sv_setsv(*last, wrapper); sv_rvweaken(*last); PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier)); } else { wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */ #if PERL_VERSION < 9 sv_bless(wrapper, SvSTASH(box)); #endif } *sv = wrapper; return JS_TRUE; } return JS_FALSE; }