Ejemplo n.º 1
0
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;
}
Ejemplo n.º 2
0
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);
}
Ejemplo n.º 3
0
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;
    }
}
Ejemplo n.º 4
0
/* 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;
}
Ejemplo n.º 5
0
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;
}
Ejemplo n.º 6
0
Archivo: pyo.c Proyecto: ByReaL/pyperl
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;
}
Ejemplo n.º 7
0
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;
    }
}
Ejemplo n.º 8
0
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);
    }
}
Ejemplo n.º 9
0
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;
}
Ejemplo n.º 10
0
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);
}
Ejemplo n.º 11
0
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
    );
}
Ejemplo n.º 12
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;
}
Ejemplo n.º 13
0
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);
}
Ejemplo n.º 14
0
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;
}
Ejemplo n.º 15
0
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;
}
Ejemplo n.º 16
0
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);
}
Ejemplo n.º 17
0
Archivo: pyo.c Proyecto: ByReaL/pyperl
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);
        }
Ejemplo n.º 18
0
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;
}
Ejemplo n.º 19
0
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;
}
Ejemplo n.º 20
0
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;
}
Ejemplo n.º 21
0
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;
}
Ejemplo n.º 22
0
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);
    }    
}
Ejemplo n.º 23
0
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));
}
Ejemplo n.º 24
0
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;
}
Ejemplo n.º 25
0
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);
	}
    }
}
Ejemplo n.º 26
0
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);
        }
    }
}
Ejemplo n.º 27
0
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);
	}
    }
}
Ejemplo n.º 28
0
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;
}
Ejemplo n.º 29
0
/****************************
 * 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)) {
Ejemplo n.º 30
0
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;
}