view release on metacpan or  search on metacpan

Damn.xs  view on Meta::CPAN

#endif

  /* we need to clear the magic flag on the given RV */
  SvAMAGIC_off( rv );
  /* as of Perl 5.8.0 we need to clear more magic */
  SvUNMAGIC( sv );

  return  rv;
} /* __damn() */


MODULE = Acme::Damn   PACKAGE = Acme::Damn    

PROTOTYPES: ENABLE

SV *
damn( rv , ... )
    SV * rv;

  PROTOTYPE: $;$$$

  PREINIT:
    SV    * sv;

  CODE:
    /* if we don't have a blessed reference, then raise an error */
    if ( ! sv_isobject( rv ) ) {
      /*
      ** if we have more than one parameter, then pull the name from
      ** the stack ... otherwise, use the method[] array
      */
      if ( items > 1 ) {
        char  *name  = (char *)SvPV_nolen( ST(1) );
        char  *file  = (char *)SvPV_nolen( ST(2) );
        int    line  = (int)SvIV( ST(3) );

        croak( "Expected blessed reference; can only %s the programmer "
               "now at %s line %d.\n" , name , file , line );
      } else {
        croak( "Expected blessed reference; can only damn the programmer now" );
      }
    }

    rv  = __damn( rv );

  OUTPUT:
    rv


SV *
bless( rv , ... )
  SV * rv;

  PROTOTYPE: $;$

  CODE:
    /*
    ** how many arguments do we have?
    **    - if we have two arguments, with the second being 'undef'
    **      then we call damn()
    **    - otherwise, we default to CORE::bless()
    */
    if ( items == 2 && ! SvOK( ST(1) ) )
      rv  = __damn(rv);
    else {
      HV          *stash;
      STRLEN       len;
      const char  *ptr;
      SV          *sv;

      /* have we been called as a two-argument bless? */
      if ( items == 2 ) {
        /*
        ** here we replicate Perl_pp_bless()
        **    - see pp.c
        */

        /* ensure we have a package name, not a reference as argument #2 */
        sv    = ST(1);
        if ( ! SvGMAGICAL( sv ) && ! SvAMAGIC( sv ) && SvROK( sv ) )
          croak( "Attempt to bless into a reference" );

        /* extract the name of the target package */
        ptr   = SvPV_const( sv , len );
        if ( len == 0 )
          WARNER(WARN_MISC, "Explicit blessing to '' (assuming package main)");

        /* extract the named stash (creating it if needed) */
        stash = gv_stashpvn( ptr , len , GV_ADD | SvUTF8(sv) );
      } else {

        /* if no package name as been given, then use the current package */
        stash = CopSTASH( PL_curcop );
      }

      /* bless the target reference */
      (void)sv_bless( rv , stash );
    }

  OUTPUT:
    rv