Acme-Damn-0.05/000755 000765 000024 00000000000 11716501601 013070 5ustar00ianstaff000000 000000 Acme-Damn-0.05/Changes000644 000765 000024 00000001277 11716467221 014403 0ustar00ianstaff000000 000000 Revision history for Perl extension Acme::Damn. $Id: Changes 2308 2012-02-14 14:24:17Z ian $ 0.05 Tue Feb 14 12:10:59 2012 - added support for modified bless() behaviour as suggested by Bo Lindbergh - see https://rt.cpan.org/Ticket/Display.html?id=74899 0.04 Sat May 16 10:42:00 2009 - changed handling of PL_no_modify to comply with GCC's -Wformat and -Werror=format-security 0.03 Sat Feb 5 00:09:32 2006 - added support for any alias, not just the ones defined in v0.02 0.02 Tue Jun 10 18:13:31 2003 - added support for aliases for damn() as suggested by Claes Jacobsson 0.01 Sun Jun 8 13:40:03 2003 - initial Acme::Damn release Acme-Damn-0.05/Damn.pm000644 000765 000024 00000012504 11716501472 014315 0ustar00ianstaff000000 000000 package Acme::Damn; use 5.000; use strict; use warnings; use Exporter; use DynaLoader qw( AUTOLOAD ); use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK ); $VERSION = '0.05'; @ISA = qw( Exporter DynaLoader ); @EXPORT = qw( damn ); @EXPORT_OK = qw( bless ); # ensure we aren't exposed to changes in inherited AUTOLOAD behaviour *Acme::Damn::AUTOLOAD = *DynaLoader::AUTOLOAD; sub import { my $class = shift; # check the unknown symbols to ensure they are 'safe' my @bad = grep { /\W/o } @_; if ( @bad ) { # throw an error message informing the user where the problem is my ( undef, $file , $line ) = caller 0; die sprintf( "Bad choice of symbol name%s %s for import at %s line %s\n" , ( @bad == 1 ) ? '' : 's' , join( ', ' , map { qq|'$_'| } @bad ) , $file , $line ); } # remove duplicates from the list of aliases, as well as those symbol # names listed in @EXPORT # - we keep @EXPORT_OK in a separate list since they are optionally # requested at use() time my @aliases = do { local %_; @_{ @_ } = undef; delete @_{ @EXPORT }; keys %_ }; # 'import' the symbols into the host package # - ensure 'EXPORT_OK' is correctly honoured my %reserved = map { $_ => 1 } @EXPORT , @EXPORT_OK; my @reserved = (); my ( $pkg ) = caller 1; foreach my $alias ( @aliases ) { # if this alias is a reserved symbol as defined by @EXPORT et al. # then add it to the list of symbols to export $reserved{ $alias } and push @reserved , $alias and next; # otherwise, create an alias for 'damn' no strict 'refs'; *{ $pkg . '::' . $alias } = sub { my $ref = shift; my ( undef , $file , $line ) = caller 1; # call damn() with the location of where this method was # originally called &{ __PACKAGE__ . '::damn' }( $ref , $alias , $file , $line ); # NB: wanted to do something like # goto \&{ __PACKAGE__ . '::damn' }; # having set the @_ array appropriately, but this caused a # "Attempt to free unrefernced SV" error that I couldn't solve # - I think it was to do with the @_ array }; } # add the known symbols to @_ splice @_ , 0; push @_ , $class , @reserved; # run the "proper" import() routine goto \&Exporter::import; } # import() bootstrap Acme::Damn $VERSION; 1; # end of module __END__ =pod =head1 NAME Acme::Damn - 'Unbless' Perl objects. =head1 SYNOPSIS use Acme::Damn; my $ref = ... some reference ... my $obj = bless $ref , 'Some::Class'; ... do something with your object ... $ref = damn $obj; # recover the original reference (unblessed) ... neither $ref nor $obj are Some::Class objects ... =head1 DESCRIPTION B provides a single routine, B, which takes a blessed reference (a Perl object), and I it, to return the original reference. =head2 EXPORT By default, B exports the method B into the current namespace. Aliases for B (see below) may be imported upon request. =head2 Methods =over 4 =item B I B accepts a single blessed reference as its argument, and returns that reference unblessed. If I is not a blessed reference, then B will C with an error. =item B I =item B I [ , I ] =item B I [ , undef ] Optionally, B will modify the behaviour of C to allow the passing of an explicit C as the target package to invoke B: use Acme::Damn qw( bless ); my $obj = ... some blessed reference ...; # the following statements are equivalent my $ref = bless $obj , undef; my $ref = damn $obj; B The modification of C is lexically scoped to the current package, and is I global. =back =head2 Method Aliases Not everyone likes to damn the same way or in the same language, so B offers the ability to specify any alias on import, provided that alias is a valid Perl subroutine name (i.e. all characters match C<\w>). use Acme::Damn qw( unbless ); use Acme::Damn qw( foo ); use Acme::Damn qw( unblessthyself ); use Acme::Damn qw( recant ); Version 0.02 supported a defined list of aliases, and this has been replaced in v0.03 by the ability to import any alias for C. =head1 WARNING Just as C doesn't call an object's initialisation code, C doesn't invoke an object's C method. For objects that need to be Ced, either don't C them, or call C before judgement is passed. =head1 ACKNOWLEDGEMENTS Thanks to Claes Jacobsson Eclaes@surfar.nuE for suggesting the use of aliases, and Bo Lindbergh Eblgl@cpan.orgE for the suggested modification of C. =head1 SEE ALSO L, L, L, L, L, L. =head1 AUTHOR Ian Brayshaw, Eian@onemore.orgE =head1 COPYRIGHT AND LICENSE Copyright 2003-2012 Ian Brayshaw This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Acme-Damn-0.05/Damn.xs000644 000765 000024 00000010546 11716501110 014324 0ustar00ianstaff000000 000000 /* ** Damn.xs ** ** Define the damn() method of Acme::Damn. ** ** Author: I. Brayshaw ** Last modified: $Date: 2012-02-14 15:48:24 +0000 (Tue, 14 Feb 2012) $ */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* for Perl > 5.6, additional magic must be handled */ #if ( PERL_REVISION == 5 ) && ( PERL_VERSION > 6 ) /* if there's magic set - Perl extension magic - then unset it */ # define SvUNMAGIC( sv ) if ( SvSMAGICAL( sv ) ) \ if ( mg_find( sv , PERL_MAGIC_ext ) \ || mg_find( sv , PERL_MAGIC_uvar ) ) \ mg_clear( sv ) #else /* for Perl <= 5.6 this becomes a no-op */ # define SvUNMAGIC( sv ) #endif /* ensure SvPV_const is declared */ #ifndef SvPV_const # define SvPV_const(s,l) ((const char *)SvPV(s,l)) #endif /* handle the evolution of Perl_warner and Perl_ck_warner */ #ifdef packWARN # ifdef ckWARN # define WARNER(t,s) if (ckWARN(t)) { Perl_warner( aTHX_ packWARN(t) , s ); } # else # define WARNER(t,s) Perl_ck_warner( aTHX_ packWARN(t) , s ) # endif #else # define WARNER(t,s) if (ckWARN(t)) { Perl_warner( aTHX_ t , s ); } #endif static SV * __damn( rv ) SV * rv; { /* need to dereference the RV to get the SV */ SV *sv = SvRV( rv ); /* ** if this is read-only, then we should do the right thing and slap ** the programmer's wrist; who know's what might happen otherwise */ if ( SvREADONLY( sv ) ) /* ** use "%s" rather than just PL_no_modify to satisfy gcc's -Wformat ** see https://rt.cpan.org/Ticket/Display.html?id=45778 */ croak( "%s" , PL_no_modify ); SvREFCNT_dec( SvSTASH( sv ) ); /* remove the reference to the stash */ SvSTASH( sv ) = NULL; SvOBJECT_off( sv ); /* unset the object flag */ if ( SvTYPE( sv ) != SVt_PVIO ) /* if we don't have an IO stream, we */ PL_sv_objcount--; /* should decrement the object count */ /* 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 Acme-Damn-0.05/Makefile.PL000644 000765 000024 00000001356 11673360406 015057 0ustar00ianstaff000000 000000 # $Id: Makefile.PL,v 1.3 2003-06-08 13:20:59 ian Exp $ # Makefile.PL for Acme::Damn # # Author: I. Brayshaw onemore.org> # Revision: $Revision: 1.3 $ # Last modified: $Date: 2003-06-08 13:20:59 $ use 5.000; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Acme::Damn' , 'VERSION_FROM' => 'Damn.pm' , 'PREREQ_PM' => { 'Test::More' => 0 , 'Test::Exception' => 0 } , ($] >= 5.005 ? ( AUTHOR => 'Ian Brayshaw ') : ()) , 'LIBS' => [''] , 'DEFINE' => '' , 'INC' => '-I.' ); Acme-Damn-0.05/MANIFEST000644 000765 000024 00000000305 11716501601 014217 0ustar00ianstaff000000 000000 Changes Damn.pm Damn.xs Makefile.PL MANIFEST README t/1compile.t t/2damn.t t/3aliases.t t/4name.t t/5bad.t t/6bless.t META.yml Module meta-data (added by MakeMaker) Acme-Damn-0.05/META.yml000644 000765 000024 00000001040 11716501601 014334 0ustar00ianstaff000000 000000 --- #YAML:1.0 name: Acme-Damn version: 0.05 abstract: ~ author: - Ian Brayshaw license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Test::Exception: 0 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Acme-Damn-0.05/README000644 000765 000024 00000006126 11716467702 013772 0ustar00ianstaff000000 000000 $Id: README 2309 2012-02-14 14:29:22Z ian $ NAME Acme::Damn - 'Unbless' Perl objects. SYNOPSIS use Acme::Damn; my $ref = ... some reference ... my $obj = bless $ref , 'Some::Class'; ... do something with your object ... $ref = damn $obj; # recover the original reference (unblessed) ... neither $ref nor $obj are Some::Class objects ... INSTALLATION To install this module type the following: perl Makefile.PL make make test make install Acme::Damn uses XS to access the internals of Perl for it's magic, and therefore must be compiled to be installed. Also, for testing, Acme::Damn relies on Test::More and Test::Exception. DESCRIPTION Acme::Damn provides a single routine, damn(), which takes a blessed reference (a Perl object), and *unblesses* it, to return the original reference. EXPORT By default, Acme::Damn exports the method damn() into the current namespace. Aliases for damn() (see below) may be imported upon request. Methods damn *object* damn() accepts a single blessed reference as its argument, and returns that reference unblessed. If *object* is not a blessed reference, then damn() will "die" with an error. bless *reference* bless *reference* [ , *package* ] bless *reference* [ , undef ] Optionally, Acme::Damn will modify the behaviour of "bless" to allow the passing of an explicit "undef" as the target package to invoke damn(): use Acme::Damn qw( bless ); my $obj = ... some blessed reference ...; # the following statements are equivalent my $ref = bless $obj , undef; my $ref = damn $obj; NOTE: The modification of "bless" is lexically scoped to the current package, and is *not* global. Method Aliases Not everyone likes to damn the same way or in the same language, so Acme::Damn offers the ability to specify any alias on import, provided that alias is a valid Perl subroutine name (i.e. all characters match "\w"). use Acme::Damn qw( unbless ); use Acme::Damn qw( foo ); use Acme::Damn qw( unblessthyself ); use Acme::Damn qw( recant ); Version 0.02 supported a defined list of aliases, and this has been replaced in v0.03 by the ability to import any alias for "damn()". WARNING Just as "bless" doesn't call an object's initialisation code, "damn" doesn't invoke an object's "DESTROY" method. For objects that need to be "DESTROY"ed, either don't "damn" them, or call "DESTROY" before judgement is passed. ACKNOWLEDGEMENTS Thanks to Claes Jacobsson for suggesting the use of aliases, and Bo Lindbergh for the suggested modification of "bless". SEE ALSO bless, perlboot, perltoot, perltooc, perlbot, perlobj. AUTHOR Ian Brayshaw, COPYRIGHT AND LICENSE Copyright 2003-2012 Ian Brayshaw This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Acme-Damn-0.05/t/000755 000765 000024 00000000000 11716501601 013333 5ustar00ianstaff000000 000000 Acme-Damn-0.05/t/1compile.t000644 000765 000024 00000000543 11673360406 015243 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 1compile.t,v 1.1 2003-06-08 13:20:13 ian Exp $ # compile.t # # Ensure the module compiles. use strict; use Test::More tests => 2; # make sure the module compiles BEGIN { use_ok( 'Acme::Damn' ) } # make sure damn() is in the current namespace { no strict 'refs'; ok( ref( *{ 'main::damn' }{ CODE } ) eq 'CODE' , "Yep" ); } Acme-Damn-0.05/t/2damn.t000644 000765 000024 00000005414 11673360406 014535 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 2damn.t,v 1.1 2003-06-08 13:20:14 ian Exp $ # damn.t # # Ensure damn "does the right thing" use strict; use Test::More tests => 26; use Test::Exception; # load Acme::Damn use Acme::Damn; # # make sure damn dies if not given a blessed reference # # define some argument types for damn my @array = (); my %hash = (); my $scalar = 0; dies_ok { eval "damn" or die } "damn() dies with no arguments"; dies_ok { eval "damn()" or die } "damn() dies with no arguments"; dies_ok { damn 1 } "damn() dies with numerical argument"; dies_ok { damn '2' } "damn() dies with string argument"; dies_ok { damn *STDOUT } "damn() dies with glob argument"; dies_ok { damn \1 } "damn() dies with scalar reference argument"; dies_ok { damn [] } "damn() dies with array reference argument"; dies_ok { damn {} } "damn() dies with hash reference argument"; dies_ok { damn sub {} } "damn() dies with code reference argument"; dies_ok { damn @array } "damn() dies with array argument"; dies_ok { damn %hash } "damn() dies with hash argument"; dies_ok { damn $scalar } "damn() dies with scalar argument"; dies_ok { damn undef } "damn() dies with undefined argument"; dies_ok { damn \*STDOUT } "damn() dies with glob reference argument"; # # make sure damn lives when passed an object # # define blessed references for testing my $number = 1; $number = bless \$number; my $string = '2'; $string = bless \$string; @array = (); my $array = bless \@array; %hash = (); my $hash = bless \%hash; my $code = sub {}; $code = bless $code; my $glob = \*STDOUT; $glob = bless $glob; lives_ok { damn $number } "damn() lives with numerical object argument"; lives_ok { damn $string } "damn() lives with string object argument" ; lives_ok { damn $array } "damn() lives with array object argument" ; lives_ok { damn $hash } "damn() lives with hash object argument" ; lives_ok { damn $code } "damn() lives with code object argument" ; lives_ok { damn $glob } "damn() lives with glob object argument" ; # # make sure damn unblesses the objects # # define a routine for performing the comparison my $cmp = sub { my $ref = shift; my $string = "$ref"; damn bless $ref; # make sure the stringification is the same return $string eq "$ref"; }; # $cmp() $number = 1; $string = '2'; $code = sub {}; $glob = \*STDOUT; ok( $cmp->( \$number ) , "damned numerical references" ); ok( $cmp->( \$string ) , "damned string references" ); ok( $cmp->( \@array ) , "damned array references" ); ok( $cmp->( \%hash ) , "damned hash references" ); ok( $cmp->( $code ) , "damned code references" ); ok( $cmp->( $glob ) , "damned glob references" ); Acme-Damn-0.05/t/3aliases.t000644 000765 000024 00000001734 11673360406 015241 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 3aliases.t,v 1.3 2006-02-05 00:04:59 ian Exp $ # aliase.t # # Ensure the damn aliases damn-well work ;) use strict; use Test::More tests => 33; use Test::Exception; # load Acme::Damn and the aliases (as defined in v0.02) my @aliases; BEGIN { @aliases = qw( abjure anathematize condemn curse damn excommunicate expel proscribe recant renounce unbless ); } # load Acme::Damn use Acme::Damn @aliases; foreach my $alias ( @aliases ) { no strict 'refs'; # create a reference, and strify it my $ref = []; my $string = "$ref"; # bless the reference and the "unbless" it bless $ref; lives_ok { $alias->( $ref ) } "$alias executes successfully"; # make sure the stringification is correct ok( $ref eq $string , "$alias executes correctly" ); # make sure the error message correctly reports the alias throws_ok { $alias->( $ref ) } "/can only $alias/" , "$alias exception thrown successfully"; } Acme-Damn-0.05/t/4name.t000644 000765 000024 00000001307 11673360406 014535 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 4name.t,v 1.2 2003-06-10 18:08:34 ian Exp $ # name.t # # Ensure the damn reports the correct alias name in error messages. use strict; use Test::More tests => 11; use Test::Exception; # load Acme::Damn and the aliases my @aliases; BEGIN { @aliases = qw( abjure anathematize condemn curse damn excommunicate expel proscribe recant renounce unbless ); } # load Acme::Damn use Acme::Damn @aliases; foreach my $alias ( @aliases ) { no strict 'refs'; # attempt to unbless a normal reference so that we can test the error # messages throws_ok { $alias->( [] ) } "/can only $alias/" , "$alias exception thrown successfully"; } Acme-Damn-0.05/t/5bad.t000644 000765 000024 00000001071 11673360406 014342 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 5bad.t,v 1.2 2006-02-05 00:06:42 ian Exp $ # bad.t # # Ensure Acme::Damn dies when an invalid alias name is given for import. use strict; use Test::More tests => 3; use Test::Exception; # load Acme::Damn use Acme::Damn; # make sure Acme::Damn::import() dies if the unknown symbol has "bad" # characters in it (i.e. non-word characters, such as ':') foreach my $name ( qw( foo::bar foo-bar foo.bar ) ) { throws_ok { Acme::Damn->import( $name ) } "/Bad choice of symbol/" , "$name exception thrown successfully"; } Acme-Damn-0.05/t/6bless.t000644 000765 000024 00000007154 11716501110 014720 0ustar00ianstaff000000 000000 #!/usr/bin/perl -w # $Id: 6bless.t 2311 2012-02-14 15:48:24Z ian $ # bless.t # # Ensure the replacement bless "does the right thing" use strict; use Test::More tests => 113; use Test::Exception; # load Acme::Damn, importing the replacement 'bless' use Acme::Damn qw( bless ); # # make sure bless displays the appropriate behaviour # - if called with two arguments, with the second argument explicitly set # set to 'undef', then default to damn() # - otherwise fall back to CORE::bless() # # define some argument types for damn my @array = (); my %hash = (); my $scalar = 0; # set the patterns for matching bless exceptions my $x = qr/Can't bless non-reference value/; my $c = qr/Modification of a read-only value attempted/; # ensure the new bless() exhibits the same live/die behaviour as the # built-in function dies_ok { eval "bless" or die } "bless() dies with no arguments"; dies_ok { eval "bless()" or die } "bless() dies with no arguments"; throws_ok { bless 1 } $x , "bless() dies with numerical argument"; throws_ok { bless '2' } $x , "bless() dies with string argument"; throws_ok { bless *STDOUT } $x , "bless() dies with glob argument"; throws_ok { bless undef } $x , "bless() dies with undefined argument"; throws_ok { bless \1 } $c , "bless() dies with constant reference"; throws_ok { bless \'2' } $c , "bless() dies with constant reference"; throws_ok { bless @array } $x , "bless() dies with array variable"; throws_ok { bless %hash } $x , "bless() dies with hash variable"; throws_ok { bless $scalar } $x , "bless() dies with scalar variable"; lives_ok { bless [] } "bless() lives with array reference"; lives_ok { bless {} } "bless() lives with hash reference"; lives_ok { bless sub {} } "bless() lives with code reference"; lives_ok { bless qr/./ } "bless() lives with regex reference"; lives_ok { bless \*STDOUT } "bless() lives with glob reference"; # ensure we can't bless into a reference throws_ok { bless [] , [] } qr/Attempt to bless into a reference/ , "bless() throws correct error with reference argument"; # ensure bless() works with a named package # - if the package name is '' then we default to 'main' my %try = ( '' => 'main' , 'main' => 'main' , 'foo' => 'foo' , 'foo::bar' => 'foo::bar' ); my @try = ( \$scalar , [] , {} , sub {} , qr/./ , \*STDERR ); foreach my $try ( @try ) { my $type = ref $try; # for Perl earlier than v5.11, a blessed regex is modified to type SCALAR # - $type records the reference type we expect after the 'unbless' $type = 'SCALAR' if ( $type =~ /Regex/ && $] < 5.011 ); while ( my ( $pkg , $expect ) = each %try ) { no warnings; # suppress 'excplict bless warning' my $rtn; undef $rtn; # ensure bless() with a package behaves as expected lives_ok { $rtn = bless $try , $pkg } "bless() lives with named package and " . $type . " reference"; is( ref( $rtn ) => $expect , "bless() returns " . $type . " reference in package " . $expect ); # ensure bless() with an undef package unblesses the reference lives_ok { $rtn = bless $rtn , undef } "bless() lives with undef package and " . $type . " reference"; is( uc ref( $rtn ) => uc $type , "bless() returns " . $type . " reference in package " . $expect ); } }