Ejemplo n.º 1
0
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);
}
Ejemplo n.º 2
0
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);
    }
}
Ejemplo n.º 3
0
/*
=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;
}
Ejemplo n.º 4
0
/*
=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);
        }
    }
}
Ejemplo n.º 5
0
/*
 * 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));
}
Ejemplo n.º 6
0
/*
=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);
            }
        }
    }
}
Ejemplo n.º 7
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));
}
Ejemplo n.º 8
0
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);
}
Ejemplo n.º 9
0
/*
 * 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));
}
Ejemplo n.º 10
0
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"));
}