Acme-Damn
view release on metacpan or search on metacpan
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 ) {
# 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
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
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;
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").
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;
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";
, \*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 1.560 second using v1.01-cache-2.11-cpan-d80b1682f3f )