File Coverage

blib/lib/OOB.pm

Criterion	Covered	Total	%
statement	148	148	100.0
branch	68	68	100.0
condition	11	11	100.0
subroutine	30	30	100.0
pod			n/a
total	257	257	100.0

package OOB;            # fool various source parsers
package OOB::function;  # keep OOB namespace as clean as possible

# be as strict and verbose as possible
use strict;
use warnings;

# version
$OOB::VERSION = '1.00';

# modules that we need
use Scalar::Util qw( blessed refaddr reftype );
use Sub::Identify qw( sub_fullname );

# the actual out-of-band data
my %data;

# set DEBUG constant if appropriate
BEGIN {
    my $debug = 0 + ( $ENV{OOB_DEBUG} || 0 );
    eval "sub DEBUG () { $debug }";

    # we're debugging
    if ($debug) {
        warn "OOB debugging enabled\n";

        # create OOB::dump
        no warnings 'once';
        *OOB::dump = sub {
            require Data::Dumper;
            if ( defined wantarray ) {
                return wantarray ? %data : \%data;
            }
            warn Data::Dumper::Dumper( \%data );
        }
    }

    # can't use __PACKAGE__, so we use __OOB__
    eval "sub __OOB__ () { 'OOB' }";
}    #BEGIN

# coderefs of stolen DESTROY methods by class
my %stolen = ( __OOB__ . '' => \&DESTROY );

# install cloaking functions
BEGIN {
    no warnings 'redefine';

    # cloak ourselves from "blessed"
    *Scalar::Util::blessed = sub ($) {
        my $blessed = blessed $_[0];
        return if !$blessed;
        return $blessed->isa(__OOB__) ? undef : $blessed;
    };

    # determine whether someone else already stole ref()
    my $old_ref = \&CORE::GLOBAL::ref;
    eval { $old_ref->() };
    $old_ref = undef if $@ =~ m#CORE::GLOBAL::ref#;
    warn "CORE::ref function was already stolen\n"
      if DEBUG and $old_ref;

    # cloak ourselves from "ref"
    *CORE::GLOBAL::ref = sub {
        my $blessed = blessed $_[0];
        return reftype $_[0] if $blessed and $blessed->isa(__OOB__);
        return $old_ref ? $old_ref->( $_[0] ) : CORE::ref $_[0];
    };

    # determine whether someone else already stole blessed()
    my $old_bless = \&CORE::GLOBAL::bless;
    eval { $old_bless->() };
    $old_bless = undef if $@ =~ m#CORE::GLOBAL::bless#;
    warn "CORE::bless function was already stolen\n"
      if DEBUG and $old_bless;

    # make sure reblessing OOB objects does the right thing
    *CORE::GLOBAL::bless = sub {
        my $blessed = blessed $_[0];
        my $class   = $_[1] ? $_[1] : caller();

        # make sure we can DESTROY if a new class
        _register_DESTROY($class) if $blessed and $stolen{$blessed};

        return $old_bless
          ? $old_bless->( $_[0], $class )
          : CORE::bless $_[0], $class;
    };
}    #BEGIN

# what we may export
my %export_ok;
@export_ok{ qw(
  OOB_get
  OOB_reset
  OOB_set
) } = ();

# enable final debugger if necessary
END {
    if (DEBUG) {
        require Data::Dumper;
        warn "Final state of OOB data:\n";
        warn Data::Dumper::Dumper( \%data );
    }
}

# satisfy -require-
1;

#-------------------------------------------------------------------------------
#
# Functional Interface
#
#-------------------------------------------------------------------------------
# OOB_get
#
#  IN: 1 reference to value
#      2 key to fetch
#      3 package in which key lives (optional)
# OUT: 1 value or undef

sub OOB_get {

    # we're debugging
    if ( DEBUG > 1 ) {
        my $id  = _unique_id( $_[0] );
        my $key = _generate_key( $_[1], $_[2] );
        warn "OOB_get with @_: $id -> $key\n";
    }

    # return value without autovivifying
    if ( my $values = $data{ _generate_key( $_[1], $_[2] ) } ) {
        return $values->{ _unique_id( $_[0] ) };
    }

    return;
}    #OOB_get

#-------------------------------------------------------------------------------
# OOB_reset
#
#  IN: 1 reference to value
#      2 package in which key lives (optional)
# OUT: 1 hash ref with all values

sub OOB_reset {

    # we're debugging
    if ( DEBUG > 1 ) {
        my $id  = _unique_id( $_[0] );
        warn "OOB_reset with @_: $id\n";
    }

    # which values to remove?
    my $id = _unique_id( $_[0] );

    # need to tell the world what we removed
    if ( defined wantarray ) {
        my %removed =
          map  { $_ => delete $data{$_}->{$id} }
          grep { exists $data{$_}->{$id} }
          keys %data;
          return \%removed;
    }

    # no need to tell what we deleted
    delete $_->{$id} foreach values %data;

    return;
}    #OOB_reset

#-------------------------------------------------------------------------------
# OOB_set
#
#  IN: 1 reference to value
#      2 key to set
#      3 value to set
#      4 package in which key lives (optional)
# OUT: 1 any old value
#      2 id of value (optional, refaddr derived)

sub OOB_set {

    # scalar specified
    if ( !reftype $_[0] ) {
        CORE::bless \$_[0], __OOB__;
    }

    # already blessed and not seen before
    elsif ( my $blessed = blessed $_[0] ) {
        _register_DESTROY($blessed);
    }

    # not blessed yet, so bless it now
    else {
        CORE::bless $_[0], __OOB__;
    }

    # we're debugging
    if ( DEBUG > 1 ) {
        my $id  = _unique_id( $_[0] );
        my $key = _generate_key( $_[1], $_[3] );
        warn "OOB_set with @_: $id -> $key\n";
    }

    # want to know old value
    if ( defined wantarray ) {
        my $id  = _unique_id( $_[0] );
        my $key = _generate_key( $_[1], $_[3] );
        my $old = $data{$key}->{$id};
        $data{$key}->{$id} = $_[2];
        return wantarray ? ( $old, $id ) : $old;
    }

    # just set it
    $data{ _generate_key( $_[1], $_[3] ) }->{ _unique_id( $_[0] ) } = $_[2];

    return;
}    #OOB_set

#-------------------------------------------------------------------------------
#
# Standard Perl features
#
#-------------------------------------------------------------------------------
# import
#
# Export any constants requested
#
#  IN: 1 class (ignored)
#      2..N constants to be exported / attributes to be defined

sub OOB::import {
    my $class = shift;

    # nothing to export / defined
    if (!@_) {
        return;
    }

    # we want all constants
    elsif ( @_ == 1 and $_[0] eq ':all' ) {
        @_ = keys %export_ok;
    }

    # assume none exportables are attributes
    elsif ( my @attributes = grep { !exists $export_ok{$_} } @_ ) {
        _register_attribute( $class, $_ ) foreach @attributes;

        # reduce to real exportables
        @_ = grep { exists $export_ok{$_} } @_;
    }

    # something to export
    if (@_) {

        # determine namespace to export to
        my $namespace = caller() . '::';
        warn "Exporting @_ to $namespace\n" if DEBUG;

        # export requested constants
        no strict 'refs';
        *{$namespace.$_} = \&$_ foreach @_;
    }

    return;
}    #OOB::import

#-------------------------------------------------------------------------------
# AUTOLOAD
#
# Manage auto-creation of missing methods
#
#  IN: 1 class
#      2 key
#      3 value to set

sub OOB::AUTOLOAD {

    # attempting to call debug when not debugging
    return if $OOB::AUTOLOAD eq 'OOB::dump';

    # don't know what to do with it
    my $class = shift;
    if ( !$class->isa(__OOB__) ) {
        require Carp;
        Carp::croak( "Undefined subroutine $OOB::AUTOLOAD" );
    }

    # seems to be an attribute we don't know about
    if ( @_ == 2 ) {
        require Carp;
        $OOB::AUTOLOAD =~ m#::(\w+)$#;
        Carp::croak( "Attempt to set unregistered OOB attribute '$1'" );
    }

    # registration
    elsif ( !@_ ) {
        _register_attribute( $OOB::AUTOLOAD =~ m#^(.*)::(\w+)$# );
    }

    return;
}    #OOB::AUTOLOAD

#-------------------------------------------------------------------------------
# DESTROY
#
#  IN: 1 instantiated object

sub OOB::DESTROY {

    # what is the id?
    my $id  = _unique_id( $_[0] );

    # we're debugging
    if (DEBUG) {
        warn "OOB::DESTROY with @_: $id\n";
    }

    # perform the deletion
    delete $_->{$id} foreach values %data;

    return;
}    #OOB::DESTROY

#-------------------------------------------------------------------------------
#
# Internal methods
#
#-------------------------------------------------------------------------------
# _generate_key
#
# Return the key of the given parameters
#
#  IN: 1 basic key value
#      2 any package specification (default: 2 levels up)
# OUT: 1 key to be used in internal hash

sub _generate_key {

    # fetch the namespace
    my $namespace = defined $_[1]
      ? ( "$_[1]" ? "$_[1]--" : '' )
      : ( caller(1) )[0] . '--';

    return $namespace . $_[0];
}    #_generate_key

#-------------------------------------------------------------------------------
# _register_attribute
#
# Register a new class method
#
#  IN: 1 namespace
#      2 key

sub _register_attribute {
    my ( $namespace, $key ) = @_;

    # install a method to handle it
    no strict 'refs';
    *{ $namespace . '::' . $key } = sub {
        return if @_ < 2; # another registration and huh?
        return @_ == 3
         ? OOB_set( $_[1], $key => $_[2], $namespace )
         : OOB_get( $_[1], $key, $namespace );
    };
}    #_register_attribute

#-------------------------------------------------------------------------------
# _register_DESTROY
#
#  IN: 1 class to register DESTROY method for

sub _register_DESTROY {
    my $blessed = shift;

    # already has DESTROY method installed
    return if $stolen{$blessed};

    # there is a DESTROY method, need to insert ours
    if ( my $destroy = $blessed->can('DESTROY') ) {
        $stolen{$blessed} = $destroy;
        my $fullname = sub_fullname($destroy);
        no strict 'refs';
        no warnings 'redefine';
       *$fullname = sub { $destroy->( $_[0] ); &OOB::DESTROY( $_[0] ) };
    }

    # no DESTROY method yet, to set one
    else {
        no strict 'refs';
        *{ $blessed . '::DESTROY' } = $stolen{$blessed} = \&OOB::DESTROY;
    }
}     #_register_DESTROY

#-------------------------------------------------------------------------------
# _unique_id
#
# Return the key of the given parameters
#
#  IN: 1 reference to value to work with
# OUT: 1 id to be used in internal hash

sub _unique_id {
    # no ref, make it!
    my $reftype = reftype $_[0];
    if ( !$reftype ) {
        return refaddr \$_[0];
    }

    # special handling for refs to refs
    elsif ( $reftype eq 'REF' ) {
        my $ref = ${$_[0]};
        $ref = ${$ref} while reftype $ref eq 'REF';
        return refaddr $ref;
    }

    # just use the refaddr
    return refaddr $_[0];
}    #_unique_id


#-------------------------------------------------------------------------------

__END__