File Coverage

blib/lib/ogd.pm

Criterion	Covered	Total	%
statement	31	58	53.4
branch	4	26	15.3
condition	2	10	20.0
subroutine	10	14	71.4
pod	1	2	50.0
total	48	110	43.6

package ogd;
require 5.008001; # must have a good B in the core

# Make sure we have version info for this module
# Make sure we do everything by the book from now on

$VERSION = '0.04';
use strict;

# At compile time
#  Create boolean for debug state
#  Create constant with that boolean
#  Create value for cleanup check
#  Create constant with that value

BEGIN {
    my $debug = ($ENV{OGD_DEBUG} || '') =~ m#^(\d+)$# ? $1 : '';
    eval "sub DEBUG () { $debug }";
    my $cleanup = ($ENV{OGD_CLEANUP} || '') =~ m#^(\d+)$# ? $1 : 10;
    eval "sub CLEANUP () { $cleanup }";
} #BEGIN

# Make sure we can find out the blessing of an object and to weaken it

use Scalar::Util qw(blessed weaken);

# Initialize counter for number of objects registered
# List with objects that should be destroyed (first is a dummy object)

my $registered = 0;
my @object;

# Make sure we do this before anything else
#  Allow for dirty tricks
#  Obtain current setting
#  See if we can call it
#  Use the core one if it was an empty subroutine reference

BEGIN {
    no strict 'refs'; no warnings 'redefine';
    my $old = \&CORE::GLOBAL::bless;
    eval {$old->()};
    $old = undef if $@ =~ m#CORE::GLOBAL::bless#;

#  Steal the system bless with a sub
#   Obtain the class
#   Create the object with the given parameters
#   Register object
#   Return the blessed object

    *CORE::GLOBAL::bless = sub {
        my $class = $_[1] || caller();
        my $object = $old ? $old->( $_[0],$class ) : CORE::bless $_[0],$class;
        __PACKAGE__->register( $object );
        $object;
    };
} #BEGIN

# When Perl is shutting down
#  Make sure we can do the nifty internal stuff
#  Push the shutting down sequence as the very last thing we'll do

END {
    require B;
    push @{B::end_av()->object_2svref},\&_shutting_down;
print STDERR "*\n" if DEBUG;
} #END

# Satisfy -require-

1;

#---------------------------------------------------------------------------
#
# Class methods
#
#---------------------------------------------------------------------------
# register
#
# Register one or more objects with ogd.  Also used internally.
#
#  IN: 1 class (ignored)
#      2..N objects to register

sub register {

# Lose the class
# Store weakened references to the object in the global list

    shift;
print STDERR "+".(@_)."\n" if DEBUG;
    weaken( $object[@object] = $_ ) foreach @_;

# Remember current number of objects registered (ever)
# Increment for number of objects registered
# If a cleanup is needed
#  Remember the number of objects before cleanup started
#  For all of the elements in reverse order (must access by index!)
#   Remove the entry if it is not defined

    my $old = $registered;
    $registered += @_;
    if (($registered >> CLEANUP) > ($old >> CLEANUP)) {
        my $before = @object;
        foreach (reverse 0..$#object) {
            splice @object,$_,1 unless defined $object[$_];
        }
print STDERR "-$before->".(@object)."\n" if DEBUG and $before > @object;
    }
} #register

#---------------------------------------------------------------------------
#
# Internal methods
#
#---------------------------------------------------------------------------
# _shutting_down
#
# The subroutine that will be called at the very, very end

sub _shutting_down {

# Initialize hash with packages handled
# Initialize counter of how many done
# While there are objects to process
#  Obtain newest object, reloop if it is already dead
#  Mark the package as used
#  Execute the DESTROY method on it (let it know it's being forced)

    my %package;
    my $done = 0;
    foreach (reverse 0..$#object) {
        next unless defined $object[$_];
        $package{blessed $object[$_]}++;
        $object[$_]->DESTROY( 1 );
$done++ if DEBUG;
    }
print STDERR "!$done\n" if DEBUG;

# Make sure we'll be silent about the dirty stuff
# Replace DESTROY subs of all packages found with an empty stub

    no strict 'refs'; no warnings 'redefine';
print STDERR qq{x@{[map { "$_($package{$_})" } sort keys %package]}\n} if DEBUG;
    *{$_.'::DESTROY'} = \&_destroy foreach keys %package;
} #_shutting_down

#---------------------------------------------------------------------------
# _destroy
#
#  IN: 1 instantiated object (ignored)
#
# This is the empty DESTROY stub that replaces any actual DESTROY subs
# after all objects have been destroyed.

sub _destroy { } #_destroy

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

__END__