USER_OBJECT_ RS_PerlClear(USER_OBJECT_ obj) { SV *sv; int n; USER_OBJECT_ ans; dTHX; ans = NEW_LOGICAL(1); sv = RS_PerlGetSV(obj); if(sv == NULL) return(ans); switch(SvTYPE(sv)) { case SVt_PVHV: hv_clear((HV*) sv); break; case SVt_PVAV: av_clear((AV*) sv); break; default: n = 1; break; } LOGICAL_DATA(ans)[0] = TRUE; return(ans); }
void Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) { const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name); PERL_ARGS_ASSERT_MRO_SET_MRO; if (!which) Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name); if(meta->mro_which != which) { if (meta->mro_linear_c3 && !meta->mro_linear_dfs) { /* If we were storing something directly, put it in the hash before we lose it. */ Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, MUTABLE_SV(meta->mro_linear_c3)); } meta->mro_which = which; /* Scrub our cached pointer to the private data. */ meta->mro_linear_c3 = NULL; /* Only affects local method cache, not even child classes */ meta->cache_gen++; if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); } }
/* =for apidoc mro_method_changed_in Invalidates method caching on any child classes of the given stash, so that they might notice the changes in this one. Ideally, all instances of C<PL_sub_generation++> in perl source outside of F<mro.c> should be replaced by calls to this. Perl automatically handles most of the common ways a method might be redefined. However, there are a few ways you could change a method in a stash without the cache code noticing, in which case you need to call this method afterwards: 1) Directly manipulating the stash HV entries from XS code. 2) Assigning a reference to a readonly scalar constant into a stash entry in order to create a constant subroutine (like F<constant.pm> does). This same method is available from pure perl via, C<mro::method_changed_in(classname)>. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* mrometa; if(!revstash) continue; mrometa = HvMROMETA(revstash); mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; } } /* The method change may be due to *{$package . "::()"} = \&nil; in overload.pm. */ HvAMAGIC_on(stash); /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; }
/* =for apidoc mro_method_changed_in Invalidates method caching on any child classes of the given stash, so that they might notice the changes in this one. Ideally, all instances of C<PL_sub_generation++> in perl source outside of C<mro.c> should be replaced by calls to this. Perl automatically handles most of the common ways a method might be redefined. However, there are a few ways you could change a method in a stash without the cache code noticing, in which case you need to call this method afterwards: 1) Directly manipulating the stash HV entries from XS code. 2) Assigning a reference to a readonly scalar constant into a stash entry in order to create a constant subroutine (like constant.pm does). This same method is available from pure perl via, C<mro::method_changed_in(classname)>. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvNAME_get(stash); const STRLEN stashname_len = HvNAMELEN_get(stash); SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 len; const char* const revkey = hv_iterkey(iter, &len); HV* const revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* mrometa; if(!revstash) continue; mrometa = HvMROMETA(revstash); mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); } } }
/* * This is the main Load function. * It takes a yaml stream and turns it into 0 or more Perl objects. */ void Load(SV *yaml_sv) { dXSARGS; perl_yaml_loader_t loader; SV *node; char *yaml_str; STRLEN yaml_len; /* If UTF8, make copy and downgrade */ if (SvPV_nolen(yaml_sv) && SvUTF8(yaml_sv)) { yaml_sv = sv_mortalcopy(yaml_sv); } yaml_str = SvPVbyte(yaml_sv, yaml_len); sp = mark; if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */ yaml_parser_initialize(&loader.parser); loader.document = 0; yaml_parser_set_input_string( &loader.parser, (unsigned char *)yaml_str, yaml_len ); /* Get the first event. Must be a STREAM_START */ if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_STREAM_START_EVENT) croak(ERRMSG "Expected STREAM_START_EVENT; Got: %d != %d", loader.event.type, YAML_STREAM_START_EVENT ); loader.anchors = newHV(); sv_2mortal((SV*)loader.anchors); /* Keep calling load_node until end of stream */ while (1) { loader.document++; if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type == YAML_STREAM_END_EVENT) break; node = load_node(&loader); hv_clear(loader.anchors); if (! node) break; XPUSHs(sv_2mortal(node)); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_DOCUMENT_END_EVENT) croak(ERRMSG "Expected DOCUMENT_END_EVENT"); } /* Make sure the last event is a STREAM_END */ if (loader.event.type != YAML_STREAM_END_EVENT) croak(ERRMSG "Expected STREAM_END_EVENT; Got: %d != %d", loader.event.type, YAML_STREAM_END_EVENT ); yaml_parser_delete(&loader.parser); PUTBACK; return; load_error: croak(loader_error_msg(&loader, NULL)); }
/* =for apidoc mro_isa_changed_in Takes the necessary steps (cache invalidations, mostly) when the @ISA of the given package has changed. Invoked by the C<setisa> magic, should not need to invoke directly. =cut */ void Perl_mro_isa_changed_in(pTHX_ HV* stash) { dVAR; HV* isarev; AV* linear_mro; HE* iter; SV** svp; I32 items; bool is_universal; struct mro_meta * meta; const char * const stashname = HvNAME_get(stash); const STRLEN stashname_len = HvNAMELEN_get(stash); PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); if (meta->mro_linear_dfs) { SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs)); meta->mro_linear_dfs = NULL; /* This is just acting as a shortcut pointer. */ meta->mro_linear_c3 = NULL; } else if (meta->mro_linear_c3) { /* Only the current MRO is stored, so this owns the data. */ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3)); meta->mro_linear_c3 = NULL; } if (meta->isa) { SvREFCNT_dec(meta->isa); meta->isa = NULL; } /* Inc the package generation, since our @ISA changed */ meta->pkg_gen++; /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; is_universal = TRUE; } else { /* Wipe the local method cache otherwise */ meta->cache_gen++; is_universal = FALSE; } /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); /* Iterate the isarev (classes that are our children), wiping out their linearization, method and isa caches */ if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 len; const char* const revkey = hv_iterkey(iter, &len); HV* revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* revmeta; if(!revstash) continue; revmeta = HvMROMETA(revstash); if (revmeta->mro_linear_dfs) { SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs)); revmeta->mro_linear_dfs = NULL; /* This is just acting as a shortcut pointer. */ revmeta->mro_linear_c3 = NULL; } else if (revmeta->mro_linear_c3) { /* Only the current MRO is stored, so this owns the data. */ SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3)); revmeta->mro_linear_c3 = NULL; } if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); if (revmeta->isa) { SvREFCNT_dec(revmeta->isa); revmeta->isa = NULL; } } } /* Now iterate our MRO (parents), and do a few things: 1) instantiate with the "fake" flag if they don't exist 2) flag them as universal if we are universal 3) Add everything from our isarev to their isarev */ /* We're starting at the 2nd element, skipping ourselves here */ linear_mro = mro_get_linear_isa(stash); svp = AvARRAY(linear_mro) + 1; items = AvFILLp(linear_mro); while (items--) { SV* const sv = *svp++; HV* mroisarev; HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); /* That fetch should not fail. But if it had to create a new SV for us, then we can detect it, because it will not be the correct type. Probably faster and cleaner for us to free that scalar [very little code actually executed to free it] and create a new HV than to copy&paste [SIN!] the code from newHV() to allow us to upgrade the new SV from SVt_NULL. */ mroisarev = MUTABLE_HV(HeVAL(he)); if(SvTYPE(mroisarev) != SVt_PVHV) { SvREFCNT_dec(mroisarev); mroisarev = newHV(); HeVAL(he) = MUTABLE_SV(mroisarev); } /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 revkeylen; char* const revkey = hv_iterkey(iter, &revkeylen); (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } }
void Perl_mro_isa_changed_in(pTHX_ HV* stash) { HV* isarev; AV* linear_mro; HE* iter; SV** svp; I32 items; bool is_universal; struct mro_meta * meta; HV *isa = NULL; const HEK * const stashhek = HvENAME_HEK(stash); const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); CLEAR_LINEAR(meta); if (meta->isa) { /* Steal it for our own purposes. */ isa = (HV *)sv_2mortal((SV *)meta->isa); meta->isa = NULL; } /* Inc the package generation, since our @ISA changed */ meta->pkg_gen++; /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ svp = hv_fetchhek(PL_isarev, stashhek, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; is_universal = TRUE; } else { /* Wipe the local method cache otherwise */ meta->cache_gen++; is_universal = FALSE; } /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); /* Changes to @ISA might turn overloading on */ HvAMAGIC_on(stash); /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; /* Iterate the isarev (classes that are our children), wiping out their linearization, method and isa caches and upating PL_isarev. */ if(isarev) { HV *isa_hashes = NULL; /* We have to iterate through isarev twice to avoid a chicken and * egg problem: if A inherits from B and both are in isarev, A might * be processed before B and use B's previous linearisation. */ /* First iteration: Wipe everything, but stash away the isa hashes * since we still need them for updating PL_isarev. */ if(hv_iterinit(isarev)) { /* Only create the hash if we need it; i.e., if isarev has any elements. */ isa_hashes = (HV *)sv_2mortal((SV *)newHV()); } while((iter = hv_iternext(isarev))) { HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* revmeta; if(!revstash) continue; revmeta = HvMROMETA(revstash); CLEAR_LINEAR(revmeta); if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; (void) hv_store( isa_hashes, (const char*)&revstash, sizeof(HV *), revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 ); revmeta->isa = NULL; } /* Second pass: Update PL_isarev. We can just use isa_hashes to * avoid another round of stash lookups. */ /* isarev might be deleted from PL_isarev during this loop, so hang * on to it. */ SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev)); if(isa_hashes) { hv_iterinit(isa_hashes); while((iter = hv_iternext(isa_hashes))) { HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter)); HV * const isa = (HV *)HeVAL(iter); const HEK *namehek; /* We're starting at the 2nd element, skipping revstash */ linear_mro = mro_get_linear_isa(revstash); svp = AvARRAY(linear_mro) + 1; items = AvFILLp(linear_mro); namehek = HvENAME_HEK(revstash); if (!namehek) namehek = HvNAME_HEK(revstash); while (items--) { SV* const sv = *svp++; HV* mroisarev; HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); /* That fetch should not fail. But if it had to create a new SV for us, then will need to upgrade it to an HV (which sv_upgrade() can now do for us). */ mroisarev = MUTABLE_HV(HeVAL(he)); SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ (void) hv_storehek(mroisarev, namehek, &PL_sv_yes); } if ((SV *)isa != &PL_sv_undef) { assert(namehek); mro_clean_isarev( isa, HEK_KEY(namehek), HEK_LEN(namehek), HvMROMETA(revstash)->isa, HEK_HASH(namehek), HEK_UTF8(namehek) ); } } } } /* Now iterate our MRO (parents), adding ourselves and everything from our isarev to their isarev. */ /* We're starting at the 2nd element, skipping ourselves here */ linear_mro = mro_get_linear_isa(stash); svp = AvARRAY(linear_mro) + 1; items = AvFILLp(linear_mro); while (items--) { SV* const sv = *svp++; HV* mroisarev; HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); /* That fetch should not fail. But if it had to create a new SV for us, then will need to upgrade it to an HV (which sv_upgrade() can now do for us. */ mroisarev = MUTABLE_HV(HeVAL(he)); SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } /* Delete our name from our former parents' isarevs. */ if(isa && HvARRAY(isa)) mro_clean_isarev(isa, stashname, stashname_len, meta->isa, HEK_HASH(stashhek), HEK_UTF8(stashhek)); }
void Application_init( Handle self, HV * profile) { dPROFILE; int hintPause = pget_i( hintPause); Color hintColor = pget_i( hintColor), hintBackColor = pget_i( hintBackColor); SV * hintFont = pget_sv( hintFont); SV * sv; char * hintClass = pget_c( hintClass); if ( application != nilHandle) croak( "Attempt to create more than one application instance"); CDrawable-> init( self, profile); list_create( &var-> widgets, 16, 16); list_create( &var-> modalHorizons, 0, 8); application = self; if ( !apc_application_create( self)) croak( "Error creating application"); /* Widget init */ SvHV_Font( pget_sv( font), &Font_buffer, "Application::init"); my-> set_font( self, Font_buffer); SvHV_Font( pget_sv( popupFont), &Font_buffer, "Application::init"); my-> set_popup_font( self, Font_buffer); { AV * av = ( AV *) SvRV( pget_sv( designScale)); SV ** holder = av_fetch( av, 0, 0); if ( holder) var-> designScale. x = SvNV( *holder); else warn("Array panic on 'designScale'"); holder = av_fetch( av, 1, 0); if ( holder) var-> designScale. y = SvNV( *holder); else warn("Array panic on 'designScale'"); pdelete( designScale); } var-> text = duplicate_string(""); opt_set( optModalHorizon); /* store extra info */ { HV * hv = ( HV *) SvRV( var-> mate); (void) hv_store( hv, "PrinterClass", 12, newSVpv( pget_c( printerClass), 0), 0); (void) hv_store( hv, "PrinterModule", 13, newSVpv( pget_c( printerModule), 0), 0); (void) hv_store( hv, "HelpClass", 9, newSVpv( pget_c( helpClass), 0), 0); (void) hv_store( hv, "HelpModule", 10, newSVpv( pget_c( helpModule), 0), 0); } { HV * profile = newHV(); static Timer_vmt HintTimerVmt; pset_H( owner, self); pset_i( timeout, hintPause); pset_c( name, "HintTimer"); var-> hintTimer = create_instance( "Prima::Timer"); protect_object( var-> hintTimer); hv_clear( profile); memcpy( &HintTimerVmt, CTimer, sizeof( HintTimerVmt)); HintTimerVmt. handle_event = Application_HintTimer_handle_event; (( PTimer) var-> hintTimer)-> self = &HintTimerVmt; pset_H( owner, self); pset_i( color, hintColor); pset_i( backColor, hintBackColor); pset_i( visible, 0); pset_i( selectable, 0); pset_i( showHint, 0); pset_c( name, "HintWidget"); pset_sv( font, hintFont); var-> hintWidget = create_instance( hintClass); protect_object( var-> hintWidget); sv_free(( SV *) profile); } if ( SvTYPE( sv = pget_sv( accelItems)) != SVt_NULL) my-> set_accelItems( self, sv); if ( SvTYPE( sv = pget_sv( popupItems)) != SVt_NULL) my-> set_popupItems( self, sv); pdelete( accelTable); pdelete( accelItems); pdelete( popupItems); my-> set( self, profile); CORE_INIT_TRANSIENT(Application); }
/* * This is the main Load function. * It takes a yaml stream and turns it into 0 or more Perl objects. */ void Load(SV *yaml_sv) { dXSARGS; perl_yaml_loader_t loader; SV *node; const unsigned char *yaml_str; STRLEN yaml_len; yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len); if (DO_UTF8(yaml_sv)) { yaml_sv = sv_mortalcopy(yaml_sv); if (!sv_utf8_downgrade(yaml_sv, TRUE)) croak("%s", "Wide character in YAML::XS::Load()"); yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len); } sp = mark; if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */ yaml_parser_initialize(&loader.parser); loader.document = 0; yaml_parser_set_input_string( &loader.parser, yaml_str, yaml_len ); /* Get the first event. Must be a STREAM_START */ if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_STREAM_START_EVENT) croak("%sExpected STREAM_START_EVENT; Got: %d != %d", ERRMSG, loader.event.type, YAML_STREAM_START_EVENT ); loader.anchors = newHV(); sv_2mortal((SV *)loader.anchors); /* Keep calling load_node until end of stream */ while (1) { loader.document++; /* We are through with the previous event - delete it! */ yaml_event_delete(&loader.event); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type == YAML_STREAM_END_EVENT) break; node = load_node(&loader); /* We are through with the previous event - delete it! */ yaml_event_delete(&loader.event); hv_clear(loader.anchors); if (! node) break; XPUSHs(sv_2mortal(node)); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_DOCUMENT_END_EVENT) croak("%sExpected DOCUMENT_END_EVENT", ERRMSG); } /* Make sure the last event is a STREAM_END */ if (loader.event.type != YAML_STREAM_END_EVENT) croak("%sExpected STREAM_END_EVENT; Got: %d != %d", ERRMSG, loader.event.type, YAML_STREAM_END_EVENT ); yaml_parser_delete(&loader.parser); PUTBACK; return; load_error: croak("%s", loader_error_msg(&loader, NULL)); }
STATIC SV * S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) { AV* av; GV* gv; GV** gvp; HV* hv = Nullhv; SV* subgen = Nullsv; if (!stash) return &PL_sv_undef; if (strEQ(HvNAME(stash), name)) return &PL_sv_yes; if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) && (hv = GvHV(gv))) { if (SvIV(subgen) == PL_sub_generation) { SV* sv; SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", name, HvNAME(stash)) ); return sv; } } else { DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", HvNAME(stash)) ); hv_clear(hv); sv_setiv(subgen, PL_sub_generation); } } gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { if (!hv || !subgen) { gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); gv = *gvp; if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); if (!hv) hv = GvHVn(gv); if (!subgen) { subgen = newSViv(PL_sub_generation); GvSV(gv) = subgen; } } if (hv) { SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_SYNTAX, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { (void)hv_store(hv,name,len,&PL_sv_yes,0); return &PL_sv_yes; } } (void)hv_store(hv,name,len,&PL_sv_no,0); } } return boolSV(strEQ(name, "UNIVERSAL")); }