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;
}
