Entirely possible.

The package that a subroutine was compiled in can have very little to do with the class that the method ends up being a part of.

True, but I'm not too worried about that. It doesn't happen often in practice and is usually just done for convenience and can be avoided. But yes, it's something a user would have to be warned about. I am indeed assuming that the code for method Foo::meth was compiled with package Foo in force.

The correct "class" is the package part of the subroutine name that was used to find the subroutine when the method was looked up (looking in symbol tables and following @ISA). Unfortunately, I have yet to see a way to get this information.

You mean, when a method is called qualified, as in $obj->Foo::meth? Two things can happen: The method is actually found in class Foo, in which case I assume its code was also compiled there, so that's okay. Or Foo itself inherits the method from Bar, in which case the Bar's incarnation of the object is used. That is also how it's supposed to work.

That is why you'd need to provide a way to override how the class name is determined.

You haven't quite convinced me with the specific argument, but general experience shows that for all caller-sensitive functions there comes a time when you want to override the caller. Run-time compiling code in the right package (sometimes the only way out) is too ugly. I guess I'll provide a way to specify a class different from your own just in case.

I have appended the XS code for Alter::ego, it isn't that much.

Anno

/* id-key for ext magic */
#define ALT_EXT_ALTER 6693

MODULE = Alter          PACKAGE = Alter

SV*
ego(...)
PROTOTYPE: $@
CODE:
    SV* obj = ST(0);
    SV* given = items > 1 ? ST(1) : NULL;
    HV* alt_tab;
    SV** alt_ptr;
    if (SvROK(obj)) {
        char* class = CopSTASHPV(PL_curcop);
        SV* self = SvRV(obj);
        MAGIC* mg;
        if (SvTYPE(self) < SVt_PVMG)
            SvUPGRADE(self, SVt_PVMG);
        for (mg = SvMAGIC(self); mg; mg = mg->mg_moremagic) {
            if ((mg->mg_type == PERL_MAGIC_ext) &&
                (mg->mg_private == ALT_EXT_ALTER)
           ) break;
        }
        if (!mg) {
            alt_tab = newHV();
            mg = sv_magicext(self, (SV*)alt_tab, PERL_MAGIC_ext, NULL,
+ NULL, 0);
            mg->mg_private = ALT_EXT_ALTER;
        } else {
            alt_tab = (HV*)mg->mg_obj;
        }
        if (alt_ptr = hv_fetch(alt_tab, class, strlen(class), 0)) {
            RETVAL = newRV_inc(SvRV( *alt_ptr));
        } else {
            if (!given) { /* should probably croak, but we decree a ha
+sh */
                given = newRV_inc((SV*)newHV());
            } else {
                /* need a non-mortal ref */
                given = newRV_inc(SvRV(given));
            }
            hv_store(alt_tab, class, strlen(class), SvREFCNT_inc(given
+), 0);
            RETVAL = given;
        }
    } else {
        RETVAL = NULL;
    }
OUTPUT: RETVAL
[download]