Acme-Damn
view release on metacpan or search on metacpan
Revision history for Perl extension Acme::Damn.
0.06 Sun Oct 26 20:50:12 2014
- support for Perl >= v5.18
0.05 Tue Feb 14 12:10:59 2012
- added support for modified bless() behaviour as suggested by
Bo Lindbergh <blgl@cpan.org>
- 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
use warnings;
use Exporter;
use DynaLoader qw( AUTOLOAD );
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
$VERSION = '0.08';
@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'
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<Acme::Damn> provides a single routine, B<damn()>, which takes a blessed
reference (a Perl object), and I<unblesses> it, to return the original
reference.
=head2 EXPORT
By default, B<Acme::Damn> exports the method B<damn()> into the current
namespace. Aliases for B<damn()> (see below) may be imported upon request.
=head2 Methods
=over 4
=item B<damn> I<object>
B<damn()> accepts a single blessed reference as its argument, and returns
that reference unblessed. If I<object> is not a blessed reference, then
B<damn()> will C<die> with an error.
=item B<bless> I<reference>
=item B<bless> I<reference> [ , I<package> ]
=item B<bless> I<reference> [ , undef ]
Optionally, B<Acme::Damn> will modify the behaviour of C<bless> to
allow the passing of an explicit C<undef> as the target package to invoke
B<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;
B<NOTE:> The modification of C<bless> is lexically scoped to the current
package, and is I<not> global.
=back
=head2 Method Aliases
Not everyone likes to damn the same way or in the same language, so
B<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 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<damn()>.
=head1 WARNING
Just as C<bless> doesn't call an object's initialisation code, C<damn> doesn't
invoke an object's C<DESTROY> method. For objects that need to be C<DESTROY>ed,
either don't C<damn> them, or call C<DESTROY> before judgement is passed.
=head1 ACKNOWLEDGEMENTS
Thanks to Claes Jacobsson E<lt>claes@surfar.nuE<gt> for suggesting the use of
aliases, and Bo Lindbergh E<lt>blgl@cpan.orgE<gt> for the suggested
modification of C<bless>.
=head1 SEE ALSO
L<bless|perlfunc/bless>, L<perlboot>, L<perltoot>, L<perltooc>, L<perlbot>,
L<perlobj>.
=head1 AUTHOR
Ian Brayshaw, E<lt>ibb@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
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
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)
META.json Module JSON meta-data (added by MakeMaker)
{
"abstract" : "'Unbless' Perl objects.",
"author" : [
"Ian Brayshaw <ibb@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
---
abstract: "'Unbless' Perl objects."
author:
- 'Ian Brayshaw <ibb@cpan.org>'
build_requires:
ExtUtils::MakeMaker: '0'
Test::Exception: '0'
Test::More: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690'
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 <claesjac@cpan.org> for suggesting the use of
aliases, and Bo Lindbergh <blgl@cpan.org> for the suggested modification
of "bless".
SEE ALSO
bless, perlboot, perltoot, perltooc, perlbot, perlobj.
AUTHOR
Ian Brayshaw, <ibb@cpan.org>
COPYRIGHT AND LICENSE
Copyright 2003-2016 Ian Brayshaw
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
# 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 @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;
t/3aliases.t view on Meta::CPAN
#
# 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";
}
#
# 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";
}
#!/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
);
}
}
( run in 2.210 seconds using v1.01-cache-2.11-cpan-de7293f3b23 )