MAGIC *find_shadow_magic(SV *p6cb, SV *static_class, SV *obj) {
SV * const obj_deref = SvRV(obj);
MAGIC * mg = mg_find(obj_deref, '~');
if (mg == NULL || ((_perl6_magic*)(mg->mg_ptr))->key != PERL6_EXTENSION_MAGIC_KEY) {
/* need to create the shadow object here */
AV * method_args = newAV();
SV * method_args_rv = newRV_noinc((SV *) method_args);
av_extend(method_args, 1);
SvREFCNT_inc(obj);
av_store(method_args, 0, obj);
AV * args = newAV();
av_extend(args, 3);
SvREFCNT_inc(static_class);
av_store(args, 0, static_class);
av_store(args, 1, newSVpvs("new_shadow_of_p5_object"));
av_store(args, 2, method_args_rv);
MAGIC * const p6cb_mg = mg_find(SvRV(p6cb), '~');
_perl6_magic* const p6cb_p6mg = (_perl6_magic*)(p6cb_mg->mg_ptr);
SV *err = NULL;
SV * const args_rv = newRV_noinc((SV *) args);
declare_cbs;
cbs->call_p6_method(p6cb_p6mg->index, "invoke", 1, args_rv, &err);
SvREFCNT_dec(args_rv);
handle_p6_error(err);
mg = mg_find(obj_deref, '~');
}
return mg;
}
static SV *make_env(request_rec *r, psgi_dir_config *c)
{
dTHX;
HV *env;
AV *version;
char *url_scheme, *script_name, *vpath, *path_info;
SV *input, *errors;
env = newHV();
ap_add_cgi_vars(r);
ap_add_common_vars(r);
/* fix SCRIPT_NAME & PATH_INFO */
if (c->location == NULL || strcmp(c->location, "/") == 0) {
script_name = "";
} else {
script_name = c->location;
}
vpath = apr_pstrcat(r->pool,
apr_table_get(r->subprocess_env, "SCRIPT_NAME"),
apr_table_get(r->subprocess_env, "PATH_INFO"),
NULL);
path_info = &vpath[strlen(script_name)];
apr_table_set(r->subprocess_env, "PATH_INFO", path_info);
apr_table_set(r->subprocess_env, "SCRIPT_NAME", script_name);
apr_table_do(copy_env, env, r->subprocess_env, NULL);
version = newAV();
av_push(version, newSViv(1));
av_push(version, newSViv(0));
(void) hv_store(env, "psgi.version", 12, newRV_noinc((SV *) version), 0);
url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
(void) hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
input = newRV_noinc(newSV(0));
sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
(void) hv_store(env, "psgi.input", 10, input, 0);
errors = newRV_noinc(newSV(0));
sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
(void) hv_store(env, "psgi.errors", 11, errors, 0);
(void) hv_store(env, "psgi.multithread", 16, newSViv(psgi_multithread), 0);
(void) hv_store(env, "psgi.multiprocess", 17, newSViv(psgi_multiprocess), 0);
(void) hv_store(env, "psgi.run_once", 13, newSViv(0), 0);
(void) hv_store(env, "psgi.nonblocking", 16, newSViv(0), 0);
return newRV_inc((SV *) env);
}
IV p5_unwrap_p6_hash(PerlInterpreter *my_perl, SV *obj) {
PERL_SET_CONTEXT(my_perl);
{
MAGIC * const tie_mg = mg_find(SvRV(obj), PERL_MAGIC_tied);
SV * const hash = tie_mg->mg_obj;
SV * const p6hashobj = *(av_fetch((AV *) SvRV(hash), 0, 0));
MAGIC * const mg = mg_find(SvRV(p6hashobj), '~');
return ((_perl6_hash_magic*)(mg->mg_ptr))->index;
}
}
/* eval "package Foo; \&init_handler" */
int modperl_filter_resolve_init_handler(pTHX_ modperl_handler_t *handler,
apr_pool_t *p)
{
char *init_handler_pv_code = NULL;
if (handler->mgv_cv) {
GV *gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv);
if (gv) {
CV *cv = modperl_mgv_cv(gv);
if (cv && SvMAGICAL(cv)) {
MAGIC *mg = mg_find((SV*)(cv), PERL_MAGIC_ext);
init_handler_pv_code = mg ? mg->mg_ptr : NULL;
}
else {
/* XXX: should we complain in such a case? */
return 0;
}
}
}
if (init_handler_pv_code) {
char *package_name =
modperl_mgv_as_string(aTHX_ handler->mgv_cv, p, 1);
/* fprintf(stderr, "PACKAGE: %s\n", package_name ); */
/* eval the code in the parent handler's package's context */
char *code = apr_pstrcat(p, "package ", package_name, ";",
init_handler_pv_code, NULL);
SV *sv;
modperl_handler_t *init_handler;
ENTER;SAVETMPS;
sv = eval_pv(code, TRUE);
/* fprintf(stderr, "code: %s\n", code); */
init_handler = modperl_handler_new_from_sv(aTHX_ p, sv);
FREETMPS;LEAVE;
if (init_handler) {
modperl_mgv_resolve(aTHX_ init_handler, p, init_handler->name, 1);
MP_TRACE_h(MP_FUNC, "found init handler %s",
modperl_handler_name(init_handler));
if (!(init_handler->attrs & MP_FILTER_INIT_HANDLER)) {
Perl_croak(aTHX_ "handler %s doesn't have "
"the FilterInitHandler attribute set",
modperl_handler_name(init_handler));
}
handler->next = init_handler;
return 1;
}
else {
Perl_croak(aTHX_ "failed to eval code: %s", code);
}
}
return 1;
}
SV *p5_wrap_p6_callable(PerlInterpreter *my_perl, IV i, SV *p5obj, SV *(*call)(IV, SV *, SV **), void (*free_p6_object)(IV)) {
SV * inst;
SV * inst_ptr;
if (p5obj == NULL) {
inst_ptr = newSViv(0);
inst = newSVrv(inst_ptr, "Perl6::Callable");
}
else {
inst_ptr = p5obj;
inst = SvRV(inst_ptr);
SvREFCNT_inc(inst_ptr);
}
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
priv.call_p6_callable = call;
priv.free_p6_object = free_p6_object;
sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
mg->mg_virtual = &p5_inline_mg_vtbl;
return inst_ptr;
}
SV*
newPerlPyObject_noinc(PyObject *pyo)
{
SV* rv;
SV* sv;
MAGIC *mg;
dCTXP;
ASSERT_LOCK_PERL;
if (!pyo)
croak("Missing pyo reference argument");
rv = newSV(0);
sv = newSVrv(rv, "Python::Object");
sv_setiv(sv, (IV)pyo);
sv_magic(sv, 0, '~', 0, 0);
mg = mg_find(sv, '~');
if (!mg) {
SvREFCNT_dec(rv);
croak("Can't assign magic to Python::Object");
}
mg->mg_virtual = &vtbl_free_pyo;
SvREADONLY(sv);
#ifdef REF_TRACE
printf("Bind pyo %p\n", pyo);
#endif
ASSERT_LOCK_PERL;
return rv;
}
IV p5_unwrap_p6_object(PerlInterpreter *my_perl, SV *obj) {
PERL_SET_CONTEXT(my_perl);
{
SV * const obj_deref = SvRV(obj);
MAGIC * const mg = mg_find(obj_deref, '~');
return ((_perl6_magic*)(mg->mg_ptr))->index;
}
}
int p5_is_wrapped_p6_object(PerlInterpreter *my_perl, SV *obj) {
PERL_SET_CONTEXT(my_perl);
{
SV * const obj_deref = SvRV(obj);
/* check for magic! */
MAGIC * const mg = mg_find(obj_deref, '~');
return (mg && mg->mg_ptr && ((_perl6_magic*)(mg->mg_ptr))->key == PERL6_MAGIC_KEY);
}
}
static bool
sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
return TRUE;
}
return FALSE;
}
U16 *modperl_code_attrs(pTHX_ CV *cv) {
MAGIC *mg;
if (!SvMAGICAL(cv)) {
sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1);
}
mg = mg_find((SV*)cv, PERL_MAGIC_ext);
return &(mg->mg_private);
}
int p5_is_hash(PerlInterpreter *my_perl, SV* sv) {
MAGIC *mg;
PERL_SET_CONTEXT(my_perl);
return (
(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)
? ((mg = mg_find(SvRV(sv), PERL_MAGIC_tied)) && sv_isa(mg->mg_obj, "Perl6::Hash"))
? 2
: 1
: 0
);
}
SV *newSV_magic_c_int(int *addr) {
static struct ufuncs magic_c_int = {magic_c_int_get, magic_c_int_set, 0};
SV *var = newSViv(*addr);
MAGIC *mg = NULL;
sv_magic(var, newSViv((int)addr), (int)'U', NULL, 0);
mg = mg_find(var, (int)'U');
mg->mg_ptr = (char *)&magic_c_int;
return var;
}
MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle)
{
#ifdef MP_TRACE
if (mg_find(TIEHANDLE_SV(handle), PERL_MAGIC_tiedscalar)) {
MP_TRACE_r(MP_FUNC, "untie *%s(0x%lx), REFCNT=%d",
GvNAME(handle), (unsigned long)handle,
SvREFCNT(TIEHANDLE_SV(handle)));
}
#endif
sv_unmagic(TIEHANDLE_SV(handle), PERL_MAGIC_tiedscalar);
}
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
SV *sv = (SV *)NULL;
MAGIC *mg;
if (SvROK(in)) {
SV *rv = (SV*)SvRV(in);
switch (SvTYPE(rv)) {
case SVt_PVMG:
sv = rv;
break;
case SVt_PVHV:
sv = modperl_hv_request_find(aTHX_ in, classname, cv);
break;
default:
Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
(int)SvTYPE(rv));
}
}
/* might be Apache2::ServerRec::warn method */
if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
request_rec *r = NULL;
(void)modperl_tls_get_request_rec(&r);
if (!r) {
Perl_croak(aTHX_
"Apache2->%s called without setting Apache2->request!",
cv ? GvNAME(CvGV(cv)) : "unknown");
}
return r;
}
/* there could be pool magic attached to custom $r object, so make
* sure that mg->mg_ptr is set */
if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
return (request_rec *)mg->mg_ptr;
}
else {
if (classname && !sv_derived_from(in, classname)) {
/* XXX: find something faster than sv_derived_from */
return NULL;
}
return INT2PTR(request_rec *, SvIV(sv));
}
return NULL;
}
lucy_RegexTokenizer*
lucy_RegexTokenizer_init(lucy_RegexTokenizer *self,
cfish_String *pattern) {
lucy_Analyzer_init((lucy_Analyzer*)self);
lucy_RegexTokenizerIVARS *const ivars = lucy_RegexTokenizer_IVARS(self);
#define DEFAULT_PATTERN "\\w+(?:['\\x{2019}]\\w+)*"
if (pattern) {
if (CFISH_Str_Contains_Utf8(pattern, "\\p", 2)
|| CFISH_Str_Contains_Utf8(pattern, "\\P", 2)
) {
CFISH_DECREF(self);
THROW(CFISH_ERR, "\\p and \\P constructs forbidden");
}
ivars->pattern = CFISH_Str_Clone(pattern);
}
else {
ivars->pattern = cfish_Str_new_from_trusted_utf8(
DEFAULT_PATTERN, sizeof(DEFAULT_PATTERN) - 1);
}
// Acquire a compiled regex engine for matching one token.
dTHX;
SV *token_re = S_compile_token_re(aTHX_ ivars->pattern);
#if (PERL_VERSION > 10)
REGEXP *rx = SvRX((SV*)token_re);
#else
if (!SvROK(token_re)) {
THROW(CFISH_ERR, "token_re is not a qr// entity");
}
SV *inner = SvRV(token_re);
MAGIC *magic = NULL;
if (SvMAGICAL((SV*)inner)) {
magic = mg_find((SV*)inner, PERL_MAGIC_qr);
}
if (!magic) {
THROW(CFISH_ERR, "token_re is not a qr// entity");
}
REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
if (rx == NULL) {
THROW(CFISH_ERR, "Failed to extract REGEXP from token_re '%s'",
SvPV_nolen((SV*)token_re));
}
ivars->token_re = rx;
(void)ReREFCNT_inc(((REGEXP*)ivars->token_re));
SvREFCNT_dec(token_re);
return self;
}
void t ()
{
MAGIC *m;
/* Create a variable*/
char *var = "main::foo";
SV *sv = perl_get_sv(var,TRUE);
/* Upgrade the sv to a magical variable*/
sv_magic(sv, NULL, '~', var, strlen(var));
/* sv_magic adds a MAGIC structure (of type '~') to the SV.
Get it and set the virtual table pointer */
m = mg_find(sv, '~');
m->mg_virtual = &foo_accessors;
SvMAGICAL_on(sv);
sv_dump(sv);
}
PyObject*
PerlPyObject_pyo_or_null(SV* sv)
{
MAGIC *mg;
dCTXP;
ASSERT_LOCK_PERL;
if (SvROK(sv) && sv_derived_from(sv, "Python::Object")) {
sv = SvRV(sv);
mg = mg_find(sv, '~');
if (SvIOK(sv) && mg && mg->mg_virtual == &vtbl_free_pyo) {
IV ival = SvIV(sv);
return INT2PTR(PyObject *, ival);
}
MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
{
MAGIC *mg;
SV *sv = TIEHANDLE_SV(handle);
if (SvMAGICAL(sv) && (mg = mg_find(sv, PERL_MAGIC_tiedscalar))) {
char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
if (!strEQ(package, classname)) {
MP_TRACE_r(MP_FUNC, "%s tied to %s", GvNAME(handle), package);
return TRUE;
}
}
return FALSE;
}
object_link_data* get_link_data(SV* perl_obj) {
SV* underlying_hash;
MAGIC* mg;
// get the underlying hash that the perl_obj is a reference to
// (we can leave it an SV* because we're just using it to find magic)
underlying_hash = SvRV(perl_obj);
// get the data linked to the underlying hash
mg = mg_find(underlying_hash, PERL_MAGIC_ext);
if (mg == NULL)
return NULL;
// check this object
DUMPME(1,perl_obj);
return (object_link_data*)mg->mg_ptr;
}
GtkWidget *
purple_perl_gtk_get_plugin_frame(PurplePlugin *plugin)
{
SV * sv;
int count;
MAGIC *mg;
GtkWidget *ret;
PurplePerlScript *gps;
dSP;
gps = plugin->info->extra_info;
ENTER;
SAVETMPS;
count = call_pv(gps->gtk_prefs_sub, G_EVAL | G_SCALAR | G_NOARGS);
if (count != 1)
croak("call_pv: Did not return the correct number of values.\n");
/* the frame was created in a perl sub and is returned */
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl gtk plugin frame init exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
/* We have a Gtk2::Frame on top of the stack */
sv = POPs;
/* The magic field hides the pointer to the actual GtkWidget */
mg = mg_find(SvRV(sv), PERL_MAGIC_ext);
ret = (GtkWidget *)mg->mg_ptr;
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
SV *p5_wrap_p6_callable(PerlInterpreter *my_perl, IV i, SV *p5obj) {
SV * inst;
SV * inst_ptr;
PERL_SET_CONTEXT(my_perl);
if (p5obj == NULL) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_pv("Perl6::Callable::new", G_SCALAR);
SPAGAIN;
inst_ptr = POPs;
inst = SvRV(inst_ptr);
SvREFCNT_inc(inst_ptr);
PUTBACK;
FREETMPS;
LEAVE;
}
else {
inst_ptr = p5obj;
inst = SvRV(inst_ptr);
SvREFCNT_inc(inst_ptr);
}
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
mg->mg_virtual = &p5_inline_mg_vtbl;
return inst_ptr;
}
HR_INLINE void
free_our_magic(SV* target)
{
MAGIC *mg_last = mg_find(target, PERL_MAGIC_ext);
MAGIC *mg_cur = mg_last;
HR_Action *action;
for(;mg_cur; mg_last = mg_cur, mg_cur = mg_cur->mg_moremagic
) {
if(mg_cur->mg_virtual == &vtbl) {
break;
}
}
if(!mg_cur) {
return;
}
action = _mg_action_list(mg_cur);
if(action) {
HR_DEBUG("Found action=%p", action);
while((action = HR_free_action(action)));
}
/*Check if this is the last magic on the variable*/
GT_FREE_MAGIC:
mg_cur->mg_virtual = NULL;
if(mg_cur == mg_last) {
/*First magic entry*/
HR_DEBUG("Calling sv_unmagic(%p)", mg_cur->mg_obj);
sv_unmagic(mg_cur->mg_obj, PERL_MAGIC_ext);
HR_DEBUG("Done!");
} else {
mg_last->mg_moremagic = mg_cur->mg_moremagic;
HR_DEBUG("About to Safefree(mg_cur=%p)", mg_cur);
HR_DEBUG("Free=%p", mg_cur);
Safefree(mg_cur);
}
}
static void
S_set_token_re_but_not_pattern(lucy_RegexTokenizer *self, void *token_re) {
#if (PERL_VERSION > 10)
REGEXP *rx = SvRX((SV*)token_re);
#else
MAGIC *magic = NULL;
if (SvMAGICAL((SV*)token_re)) {
magic = mg_find((SV*)token_re, PERL_MAGIC_qr);
}
if (!magic) {
THROW(LUCY_ERR, "token_re is not a qr// entity");
}
REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
if (rx == NULL) {
THROW(LUCY_ERR, "Failed to extract REGEXP from token_re '%s'",
SvPV_nolen((SV*)token_re));
}
if (self->token_re) {
ReREFCNT_dec(((REGEXP*)self->token_re));
}
self->token_re = rx;
(void)ReREFCNT_inc(((REGEXP*)self->token_re));
}
HR_INLINE MAGIC*
get_our_magic(SV* objref, int create)
{
MAGIC *mg;
HR_Action *action_list;
SV *target;
if(!SvROK(objref)) {
die("Value=%p must be a reference type", objref);
}
target = SvRV(objref);
objref = NULL; /*Don't use this anymore*/
if(SvTYPE(target) < SVt_PVMG) {
HR_DEBUG("Object=%p is not yet magical!", target);
if(create) {
goto GT_NEW_MAGIC;
} else {
HR_DEBUG("No magic found, but creation not requested");
return NULL;
}
}
HR_DEBUG("Will try to locate existing magic");
mg = mg_find(target, PERL_MAGIC_ext);
if(mg) {
HR_DEBUG("Found initial mg=%p", mg);
} else {
HR_DEBUG("Can't find existing magic!");
}
for(; mg; mg = mg->mg_moremagic) {
HR_DEBUG("Checking mg=%p", mg);
if(mg->mg_virtual == &vtbl) {
return mg;
}
}
if(!create) {
return NULL;
}
GT_NEW_MAGIC:
HR_DEBUG("Creating new magic for %p", target);
Newxz_Action(action_list);
mg = sv_magicext(target, target, PERL_MAGIC_ext, &vtbl,
(const char*)action_list, 0);
mg->mg_flags |= MGf_DUP;
OURMAGIC_infree(mg) = 0;
if(!mg) {
die("Couldn't create magic!");
} else {
HR_DEBUG("Created mg=%p, alist=%p", mg, action_list);
}
return mg;
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
char** e;
static char* misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
NULL
};
if (!PL_envgv)
return;
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
while (1) {
if (i)
(void)sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, strlen(name), FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN n_a;
bool was_tainted = PL_tainted;
char *t = SvPV(*svp, n_a);
char *e = t + n_a;
PL_tainted = was_tainted;
if (t < e && isALNUM(*t))
t++;
while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
const char* const *e;
static const char* const misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
#ifdef WIN32
"PERL5SHELL", /* used for system() on Windows */
#endif
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash or if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
const bool was_tainted = TAINT_get;
const char * const name = GvENAME(PL_envgv);
TAINT;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
STRLEN len = 8; /* strlen(name) */
while (1) {
if (i)
len = my_sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN len;
const bool was_tainted = TAINT_get;
const char *t = SvPV_const(*svp, len);
const char * const e = t + len;
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
if (t < e && isWORDCHAR(*t))
t++;
while (t < e && (isWORDCHAR(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
char** e;
static char* misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash of if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((SV*)GvHV(PL_envgv), PERL_MAGIC_env))) {
bool was_tainted = PL_tainted;
char *name = GvENAME(PL_envgv);
PL_tainted = TRUE;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
PL_tainted = was_tainted;
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
while (1) {
if (i)
(void)sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, strlen(name), FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN n_a;
bool was_tainted = PL_tainted;
char *t = SvPV(*svp, n_a);
char *e = t + n_a;
PL_tainted = was_tainted;
if (t < e && isALNUM(*t))
t++;
while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
I32 magic_c_int_set(IV num, SV *sv) {
MAGIC *mg = mg_find(sv, (int)'U');
*((int *)(SvIV(mg->mg_obj))) = SvIV(sv);
return 1;
}
/****************************
* SV* Py2Pl(PyObject *obj)
*
* Converts arbitrary Python data structures to Perl data structures
* Note on references: does not Py_DECREF(obj).
*
* Modifications by Eric Wilhelm 2004-07-11 marked as elw
*
****************************/
SV *Py2Pl(PyObject * const obj) {
/* elw: see what python says things are */
#if PY_MAJOR_VERSION >= 3
int const is_string = PyBytes_Check(obj) || PyUnicode_Check(obj);
#else
int const is_string = PyString_Check(obj) || PyUnicode_Check(obj);
#endif
#ifdef I_PY_DEBUG
PyObject *this_type = PyObject_Type(obj); /* new reference */
PyObject *t_string = PyObject_Str(this_type); /* new reference */
#if PY_MAJOR_VERSION >= 3
PyObject *type_str_bytes = PyUnicode_AsUTF8String(t_string); /* new reference */
char *type_str = PyBytes_AsString(type_str_bytes);
#else
char *type_str = PyString_AsString(t_string);
#endif
Printf(("type is %s\n", type_str));
printf("Py2Pl object:\n\t");
PyObject_Print(obj, stdout, Py_PRINT_RAW);
printf("\ntype:\n\t");
PyObject_Print(this_type, stdout, Py_PRINT_RAW);
printf("\n");
Printf(("String check: %i\n", is_string));
Printf(("Number check: %i\n", PyNumber_Check(obj)));
Printf(("Int check: %i\n", PyInt_Check(obj)));
Printf(("Long check: %i\n", PyLong_Check(obj)));
Printf(("Float check: %i\n", PyFloat_Check(obj)));
Printf(("Type check: %i\n", PyType_Check(obj)));
#if PY_MAJOR_VERSION < 3
Printf(("Class check: %i\n", PyClass_Check(obj)));
Printf(("Instance check: %i\n", PyInstance_Check(obj)));
#endif
Printf(("Dict check: %i\n", PyDict_Check(obj)));
Printf(("Mapping check: %i\n", PyMapping_Check(obj)));
Printf(("Sequence check: %i\n", PySequence_Check(obj)));
Printf(("Iter check: %i\n", PyIter_Check(obj)));
Printf(("Function check: %i\n", PyFunction_Check(obj)));
Printf(("Module check: %i\n", PyModule_Check(obj)));
Printf(("Method check: %i\n", PyMethod_Check(obj)));
#if PY_MAJOR_VERSION < 3
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE))
printf("heaptype true\n");
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HAVE_CLASS))
printf("has class\n");
#else
Py_DECREF(type_str_bytes);
#endif
Py_DECREF(t_string);
Py_DECREF(this_type);
#endif
/* elw: this needs to be early */
/* None (like undef) */
if (!obj || obj == Py_None) {
Printf(("Py2Pl: Py_None\n"));
return &PL_sv_undef;
}
else
#ifdef EXPOSE_PERL
/* unwrap Perl objects */
if (PerlObjObject_Check(obj)) {
Printf(("Py2Pl: Obj_object\n"));
return ((PerlObj_object *) obj)->obj;
}
/* unwrap Perl code refs */
else if (PerlSubObject_Check(obj)) {
Printf(("Py2Pl: Sub_object\n"));
SV * ref = ((PerlSub_object *) obj)->ref;
if (! ref) { /* probably an inherited method */
if (! ((PerlSub_object *) obj)->obj)
croak("Error: could not find a code reference or object method for PerlSub");
SV * const sub_obj = (SV*)SvRV(((PerlSub_object *) obj)->obj);
HV * const pkg = SvSTASH(sub_obj);
#if PY_MAJOR_VERSION >= 3
char * const sub = PyBytes_AsString(((PerlSub_object *) obj)->sub);
#else
PyObject *obj_sub_str = PyObject_Str(((PerlSub_object *) obj)->sub); /* new ref. */
char * const sub = PyString_AsString(obj_sub_str);
#endif
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, sub, TRUE);
if (gv && isGV(gv)) {
ref = (SV *)GvCV(gv);
}
#if PY_MAJOR_VERSION < 3
Py_DECREF(obj_sub_str);
#endif
}
return newRV_inc((SV *) ref);
}
else
#endif
/* wrap an instance of a Python class */
/* elw: here we need to make these look like instances: */
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE)
#if PY_MAJOR_VERSION < 3
|| PyInstance_Check(obj)
#endif
) {
/* This is a Python class instance -- bless it into an
* Inline::Python::Object. If we're being called from an
* Inline::Python class, it will be re-blessed into whatever
* class that is.
*/
SV * const inst_ptr = newSViv(0);
SV * const inst = newSVrv(inst_ptr, "Inline::Python::Object");;
_inline_magic priv;
/* set up magic */
priv.key = INLINE_MAGIC_KEY;
sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
mg->mg_virtual = &inline_mg_vtbl;
sv_setiv(inst, (IV) obj);
/*SvREADONLY_on(inst); */ /* to uncomment this means I can't
re-bless it */
Py_INCREF(obj);
Printf(("Py2Pl: Instance. Obj: %p, inst_ptr: %p\n", obj, inst_ptr));
sv_2mortal(inst_ptr);
return inst_ptr;
}
/* a tuple or a list */
else if (PySequence_Check(obj) && !is_string) {
AV * const retval = newAV();
int i;
int const sz = PySequence_Length(obj);
Printf(("sequence (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const tmp = PySequence_GetItem(obj, i); /* new reference */
SV * const next = Py2Pl(tmp);
av_push(retval, next);
if (sv_isobject(next)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(next);
Py_DECREF(tmp);
}
if (PyTuple_Check(obj)) {
_inline_magic priv;
priv.key = TUPLE_MAGIC_KEY;
sv_magic((SV * const)retval, (SV * const)NULL, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
}
return newRV_noinc((SV *) retval);
}
/* a dictionary or fake Mapping object */
/* elw: PyMapping_Check() now returns true for strings */
else if (! is_string && PyMapping_Check(obj)) {
HV * const retval = newHV();
int i;
int const sz = PyMapping_Length(obj);
PyObject * const keys = PyMapping_Keys(obj); /* new reference */
PyObject * const vals = PyMapping_Values(obj); /* new reference */
Printf(("Py2Pl: dict/map\n"));
Printf(("mapping (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const key = PySequence_GetItem(keys, i), /* new reference */
* const val = PySequence_GetItem(vals, i); /* new reference */
SV * const sv_val = Py2Pl(val);
char * key_val;
if (PyUnicode_Check(key)) {
PyObject * const utf8_string = PyUnicode_AsUTF8String(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
key_val = PyBytes_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyBytes_Size(utf8_string));
#else
key_val = PyString_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyString_Size(utf8_string));
#endif
SvUTF8_on(utf8_key);
hv_store_ent(retval, utf8_key, sv_val, 0);
Py_DECREF(utf8_string);
}
else {
PyObject * s = NULL;
#if PY_MAJOR_VERSION >= 3
PyObject * s_bytes = NULL;
if (PyBytes_Check(key)) {
key_val = PyBytes_AsString(key);
#else
if (PyString_Check(key)) {
key_val = PyString_AsString(key);
#endif
}
else {
/* Warning -- encountered a non-string key value while converting a
* Python dictionary into a Perl hash. Perl can only use strings as
* key values. Using Python's string representation of the key as
* Perl's key value.
*/
s = PyObject_Str(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
s_bytes = PyUnicode_AsUTF8String(s); /* new reference */
key_val = PyBytes_AsString(s_bytes);
#else
key_val = PyString_AsString(s);
#endif
Py_DECREF(s);
if (PL_dowarn)
warn("Stringifying non-string hash key value: '%s'",
key_val);
}
if (!key_val) {
croak("Invalid key on key %i of mapping\n", i);
}
hv_store(retval, key_val, strlen(key_val), sv_val, 0);
#if PY_MAJOR_VERSION >= 3
Py_XDECREF(s_bytes);
#endif
Py_XDECREF(s);
}
if (sv_isobject(sv_val)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(sv_val);
Py_DECREF(key);
Py_DECREF(val);
}
Py_DECREF(keys);
Py_DECREF(vals);
return newRV_noinc((SV *) retval);
}
/* a boolean */
else if (PyBool_Check(obj)) {
modperl_filter_t *modperl_filter_mg_get(pTHX_ SV *obj)
{
MAGIC *mg = mg_find(SvRV(obj), PERL_MAGIC_ext);
return mg ? (modperl_filter_t *)mg->mg_ptr : NULL;
}