File Coverage

blib/lib/OO/InsideOut.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

#!/usr/bin/perl
package OO::InsideOut;

use 5.008;

use strict;
use warnings;

use Exporter 'import';
use Carp qw(croak);
use Class::ISA ();
use Scalar::Util 1.09 qw(weaken refaddr);

our $VERSION   = '0.03';
our @EXPORT    = qw();
our @EXPORT_OK = qw(Dumper id register);

my (%Hash, %Object, %Method);

my $Dumper = eval {
    use Data::Dumper ();
    return \&Data::Dumper::Dumper;
};

### Internal Functions ###

my $classes = sub {
    my $self = shift;

    # no point in returning classes that dont use OO::InsideOut
    return
        grep { exists $Object{ $_ } }
            Class::ISA::self_and_super_path( ref $self || $self );
};

my $register_object = sub {
    my $self = shift;
    my $id   = id( $self );

    for my $class ( $self->$classes ) {
        my $obj = $Object{ $class };

        # object allready registered, skip
        exists $obj->{ $id }
            && next;

        # to allow object destruction
        weaken( $obj->{ $id } = $self );
    }

    return $self;
};

my $unregister_object = sub {
    my $self = shift;
    my $id   = id( $self );

    for my $class ( $self->$classes ) {
        # Even if there's no new, there can be stored values
        map { delete $_->{ $id } }
            @{ $Hash{ $class } };

        my $obj = $Object{ $class };

        # object may allready been destroyed, skip
        exists $obj->{ $id }
            || next;

        delete $obj->{ $id };

        # force cleanup on classes with no active objects
        unless ( keys %{ $Object{ $class } } ) {
            delete $Hash{ $class };
            delete $Object{ $class };
        }
    }

    return $self;
};

my $register_new = sub {
    my $class = shift;

    my $new = $class->can('new');

    # no new defined, no object registration needed
    defined $new
        || return;

    # we allready wrapped new
    exists $Method{ refaddr $new }
        && return;

    my $method = sub {
        return shift->$new( @_ )->$register_object;
    };

    no strict 'refs';
    no warnings 'redefine';
    *{ $class . '::new' } = $method;

    return ++$Method{ refaddr $method };
};

my $register_destroy = sub {
    my $class = shift;

    my $DESTROY = $class->can('DESTROY');

    # allready exists a DESTROY method and we allready wrapped it, skip
    $DESTROY
        && exists $Method{ refaddr $DESTROY }
        && return;

    my $method  = sub {
        my $self = shift;

        $DESTROY
            && $self->$DESTROY();

        $self->$unregister_object;

        return 1;
    };

    no strict 'refs';
    no warnings 'redefine';
    *{ $class . '::DESTROY' } = $method;

    $Method{ refaddr $method }++;

    return 1;
};

my $register_hashes = sub {
    my $class  = shift;
    my @hashes = @_;

    # no hashes, no joy, skip
    scalar @hashes
        or return;

    # we may allready registered this class, skip if so
    unless ( exists $Hash{ $class } ) {
        $class->$register_new;
        $class->$register_destroy;
    }

    # register this class to avoid re-registering
    $Object{ $class } ||= {};
    push @{ $Hash{ $class } }, @hashes;

    # if they ask for it, return this class's object registry
    return defined wantarray ? $Object{ $class } : 1;
};

### Exportable Functions ###

sub Dumper {
    my $object = shift;
    my $id     = id( $object );

    my %dump;
    for my $class ( $object->$classes ) {
        exists $Hash{ $class }
            || next;

        push @{ $dump{ $class } },
            map { $_->{ $id } }
                grep { exists $_->{ $id } }
                     @{ $Hash{ $class } };
    }

    return $Dumper->( \%dump );
}

sub id { return refaddr shift; }

sub register {
    my @args   = @_;

    my @hashes = grep { ref eq 'HASH' } @args;

    scalar @hashes
        or croak 'must provide, at least, one hash ref!';

    my $caller = caller(0);
    return $caller->$register_hashes( @hashes );
}

### Methods ###

sub CLONE {
    my $class = shift;

    for my $class ( keys %Object ) {
        my $obj = $Object{ $class };

        for my $old ( keys %{ $obj } ) {
            my $new = delete $obj->{ $old };

            map { $_->{ id $new } = delete $_->{ $old } }
                @{ $Hash{ $class } };

            $new->$register_object;
        }

        return ;
    }
}

1; # End of OO::InsideOut

__END__