Esempio n. 1
0
/*
=for apidoc mro_get_linear_isa_dfs

Returns the Depth-First Search linearization of @ISA
the given stash.  The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).

You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).

=cut
*/
static AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
    AV* retval;
    GV** gvp;
    GV* gv;
    AV* av;
    const HEK* stashhek;
    struct mro_meta* meta;
    SV *our_name;
    HV *stored;

    PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
    assert(HvAUX(stash));

    stashhek = HvNAME_HEK(stash);
    if (!stashhek)
      Perl_croak(aTHX_ "Can't linearize anonymous symbol table");

    if (level > 100)
        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
		   HEK_KEY(stashhek));

    meta = HvMROMETA(stash);

    /* return cache if valid */
    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
        return retval;
    }

    /* not in cache, make a new one */

    retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
    /* We use this later in this function, but don't need a reference to it
       beyond the end of this function, so reference count is fine.  */
    our_name = newSVhek(stashhek);
    av_push(retval, our_name); /* add ourselves at the top */

    /* fetch our @ISA */
    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;

    /* "stored" is used to keep track of all of the classnames we have added to
       the MRO so far, so we can do a quick exists check and avoid adding
       duplicate classnames to the MRO as we go.
       It's then retained to be re-used as a fast lookup for ->isa(), by adding
       our own name and "UNIVERSAL" to it.  */

    stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));

    if(av && AvFILLp(av) >= 0) {

        SV **svp = AvARRAY(av);
        I32 items = AvFILLp(av) + 1;

        /* foreach(@ISA) */
        while (items--) {
            SV* const sv = *svp++;
            HV* const basestash = gv_stashsv(sv, 0);
	    SV *const *subrv_p;
	    I32 subrv_items;

            if (!basestash) {
                /* if no stash exists for this @ISA member,
                   simply add it to the MRO and move on */
		subrv_p = &sv;
		subrv_items = 1;
            }
            else {
                /* otherwise, recurse into ourselves for the MRO
                   of this @ISA member, and append their MRO to ours.
		   The recursive call could throw an exception, which
		   has memory management implications here, hence the use of
		   the mortal.  */
		const AV *const subrv
		    = mro_get_linear_isa_dfs(basestash, level + 1);

		subrv_p = AvARRAY(subrv);
		subrv_items = AvFILLp(subrv) + 1;
	    }
	    while(subrv_items--) {
		SV *const subsv = *subrv_p++;
		/* LVALUE fetch will create a new undefined SV if necessary
		 */
		HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
		assert(he);
		if(HeVAL(he) != &PL_sv_undef) {
		    /* It was newly created.  Steal it for our new SV, and
		       replace it in the hash with the "real" thing.  */
		    SV *const val = HeVAL(he);
		    HEK *const key = HeKEY_hek(he);

		    HeVAL(he) = &PL_sv_undef;
		    /* Save copying by making a shared hash key scalar. We
		       inline this here rather than calling Perl_newSVpvn_share
		       because we already have the scalar, and we already have
		       the hash key.  */
		    assert(SvTYPE(val) == SVt_NULL);
		    sv_upgrade(val, SVt_PV);
		    SvPV_set(val, HEK_KEY(share_hek_hek(key)));
		    SvCUR_set(val, HEK_LEN(key));
		    SvREADONLY_on(val);
		    SvFAKE_on(val);
		    SvPOK_on(val);
		    if (HEK_UTF8(key))
			SvUTF8_on(val);

		    av_push(retval, val);
		}
            }
        }
    }

    (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
    (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);

    SvREFCNT_inc_simple_void_NN(stored);
    SvTEMP_off(stored);
    SvREADONLY_on(stored);

    meta->isa = stored;

    /* now that we're past the exception dangers, grab our own reference to
       the AV we're about to use for the result. The reference owned by the
       mortals' stack will be released soon, so everything will balance.  */
    SvREFCNT_inc_simple_void_NN(retval);
    SvTEMP_off(retval);

    /* we don't want anyone modifying the cache entry but us,
       and we do so by replacing it completely */
    SvREADONLY_on(retval);

    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
						MUTABLE_SV(retval)));
}
Esempio n. 2
0
/*
=for apidoc mro_get_linear_isa_dfs

Returns the Depth-First Search linearization of C<@ISA>
the given stash.  The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).

You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).

=cut
*/
static AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
    AV* retval;
    GV** gvp;
    GV* gv;
    AV* av;
    const HEK* stashhek;
    struct mro_meta* meta;
    SV *our_name;
    HV *stored = NULL;

    PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
    assert(HvAUX(stash));

    stashhek
        = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
          ? HvENAME_HEK_NN(stash)
          : HvNAME_HEK(stash);

    if (!stashhek)
        Perl_croak(aTHX_ "Can't linearize anonymous symbol table");

    if (level > 100)
        Perl_croak(aTHX_
                   "Recursive inheritance detected in package '%"HEKf"'",
                   HEKfARG(stashhek));

    meta = HvMROMETA(stash);

    /* return cache if valid */
    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
        return retval;
    }

    /* not in cache, make a new one */

    retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
    /* We use this later in this function, but don't need a reference to it
       beyond the end of this function, so reference count is fine.  */
    our_name = newSVhek(stashhek);
    av_push(retval, our_name); /* add ourselves at the top */

    /* fetch our @ISA */
    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;

    /* "stored" is used to keep track of all of the classnames we have added to
       the MRO so far, so we can do a quick exists check and avoid adding
       duplicate classnames to the MRO as we go.
       It's then retained to be re-used as a fast lookup for ->isa(), by adding
       our own name and "UNIVERSAL" to it.  */

    if(av && AvFILLp(av) >= 0) {

        SV **svp = AvARRAY(av);
        I32 items = AvFILLp(av) + 1;

        /* foreach(@ISA) */
        while (items--) {
            SV* const sv = *svp ? *svp : &PL_sv_undef;
            HV* const basestash = gv_stashsv(sv, 0);
            SV *const *subrv_p;
            I32 subrv_items;
            svp++;

            if (!basestash) {
                /* if no stash exists for this @ISA member,
                   simply add it to the MRO and move on */
                subrv_p = &sv;
                subrv_items = 1;
            }
            else {
                /* otherwise, recurse into ourselves for the MRO
                   of this @ISA member, and append their MRO to ours.
                The recursive call could throw an exception, which
                   has memory management implications here, hence the use of
                   the mortal.  */
                const AV *const subrv
                    = mro_get_linear_isa_dfs(basestash, level + 1);

                subrv_p = AvARRAY(subrv);
                subrv_items = AvFILLp(subrv) + 1;
            }
            if (stored) {
                while(subrv_items--) {
                    SV *const subsv = *subrv_p++;
                    /* LVALUE fetch will create a new undefined SV if necessary
                     */
                    HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
                    assert(he);
                    if(HeVAL(he) != &PL_sv_undef) {
                        /* It was newly created.  Steal it for our new SV, and
                           replace it in the hash with the "real" thing.  */
                        SV *const val = HeVAL(he);
                        HEK *const key = HeKEY_hek(he);

                        HeVAL(he) = &PL_sv_undef;
                        sv_sethek(val, key);
                        av_push(retval, val);
                    }
                }
            } else {
                /* We are the first (or only) parent. We can short cut the
                   complexity above, because our @ISA is simply us prepended
                   to our parent's @ISA, and our ->isa cache is simply our
                   parent's, with our name added.  */
                /* newSVsv() is slow. This code is only faster if we can avoid
                   it by ensuring that SVs in the arrays are shared hash key
                   scalar SVs, because we can "copy" them very efficiently.
                   Although to be fair, we can't *ensure* this, as a reference
                   to the internal array is returned by mro::get_linear_isa(),
                   so we'll have to be defensive just in case someone faffed
                   with it.  */
                if (basestash) {
                    SV **svp;
                    stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
                    av_extend(retval, subrv_items);
                    AvFILLp(retval) = subrv_items;
                    svp = AvARRAY(retval);
                    while(subrv_items--) {
                        SV *const val = *subrv_p++;
                        *++svp = SvIsCOW_shared_hash(val)
                                 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
                                 : newSVsv(val);
                    }
                } else {
                    /* They have no stash.  So create ourselves an ->isa cache
                       as if we'd copied it from what theirs should be.  */
                    stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
                    (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
                    av_push(retval,
                            newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
                                                            &PL_sv_undef, 0))));
                }
            }
        }
    } else {
        /* We have no parents.  */
        stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
        (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
    }

    (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);

    SvREFCNT_inc_simple_void_NN(stored);
    SvTEMP_off(stored);
    SvREADONLY_on(stored);

    meta->isa = stored;

    /* now that we're past the exception dangers, grab our own reference to
       the AV we're about to use for the result. The reference owned by the
       mortals' stack will be released soon, so everything will balance.  */
    SvREFCNT_inc_simple_void_NN(retval);
    SvTEMP_off(retval);

    /* we don't want anyone modifying the cache entry but us,
       and we do so by replacing it completely */
    SvREADONLY_on(retval);

    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
                      MUTABLE_SV(retval)));
}