File Coverage

blib/lib/Object/Deadly.pm

Criterion	Covered	Total	%
statement	84	143	58.7
branch	13	44	29.5
condition			n/a
subroutine	22	34	64.7
pod	18	21	85.7
total	137	242	56.6

## no critic (PodSections,UseWarnings,RcsKeywords)
package Object::Deadly;

use strict;

use Devel::Symdump ();
use Scalar::Util qw(refaddr blessed);
use English '$EVAL_ERROR';    ## no critic Interpolation
use Carp::Clan 5.4;

use vars '$VERSION';          ## no critic Interpolation
$VERSION = '0.09';

sub new_with {

    # Public, overridable class method. Returns an _unsafe
    # object. Accepts a single reference which will be blessed.
    my ( $class, $self ) = @_;
    my $implementation_class = "$class\::_unsafe";

    return bless $self, $implementation_class;
}

sub new {

    # Public, overridable class method. Returns an ${class}::_unsafe
    # object.

    my $class                = shift @_;
    my $implementation_class = "$class\::_unsafe";

    my $data;
    if (@_) {
        $data = shift @_;
    }
    else {

        # No sense in loading this unless we actually use it.
        require Devel::StackTrace;

        $data = Devel::StackTrace->new( ignore_package => $class )->as_string;
        $data =~ s/\AT/Object::Deadly t/xm;

    }

    my $self = bless \$data, $implementation_class;
    no strict 'refs';    ## no critic strict
    ${"${implementation_class}::SIMPLE_OBJECTS"}{ refaddr $self} = undef;

    return $self;
}

sub kill_function {

    # Public, overridable class method. Creates a deadly function in
    # the ${class}::_unsafe class.

    my ( $class, $func, $death ) = @_;
    my $implementation_class = "$class\::_unsafe";
    my $function_name        = "$implementation_class\::$func";
    no strict 'refs';    ## no critic Strict

    if ( defined &$function_name ) {    ## no critic Sigil
        return;
    }

    # Get a default death if our caller hasn't given us something
    # special.
    if ( not defined $death ) {
        $death = $class->get_death;
    }

    my $src = <<"PROXY_FOR_DEATH";
#line @{[__LINE__+2]} "@{[__FILE__]}"
        package $implementation_class;
        \$death = \$death;
        sub $func {
            if ( defined Object::Deadly::blessed \$_[0] ) {

                # Object method calls are fatal.
                \$death->( \$_[0], "Function $func" );
            }
            else {
                my \$class = shift \@_;
                return \$class->SUPER::$func( \@_ );
            }
        }
PROXY_FOR_DEATH
    eval $src;    ## no critic eval
    if ($EVAL_ERROR) {
        croak "$src\n$EVAL_ERROR";
    }

    return 1;
}

# A dictionary of stuff that can show up in UNIVERSAL.
our @UNIVERSAL_METHODS = (

    # core perl
    qw( isa can VERSION ),

    # core perl 5.9.4+
    'DOES',

    # UNIVERSAL.pm
    'import',

    # UNIVERSAL/require.pm
    qw( require use ),

    # UNIVERSAL/dump.pm
    qw( blessed dump peek refaddr ),

    # UNIVERSAL/exports.pm
    'exports',

    # UNIVERSAL/moniker.pm
    qw( moniker plural_moniker ),

    # UNIVERSAL/which.pm
    'which',

    # SUPER.pm
    qw( super SUPER ),
);

sub kill_UNIVERSAL {

    # Public, overridable method call. Creates deadly functions in
    # ${class}::_unsafe to mask all UNIVERSAL methods.

    my $class = shift @_;
    for my $fqf_function (
        @UNIVERSAL_METHODS,

        # Anything else we happen to find
        Devel::Symdump->rnew('UNIVERSAL')->functions
        )
    {
        my $function = $fqf_function;
        $function =~ s/\AUNIVERSAL:://mx;

        $class->kill_function($function);
    }

    return 1;
}

sub get_death {

    # Public, overridable method call. Returns the _death function
    my $class = shift @_;

    no strict 'refs';    ## no critic Strict
    return \&{"${class}::_unsafe::death"};
}

# Compile and load our implementing classes.
use Object::Deadly::_safe   ();
use Object::Deadly::_unsafe ();

## no critic EndWithOne
'For the SAKE... of the FUTURE of ALL... mankind... I WILL have
a... SMALL sprite!';

__END__