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


line stmt bran cond sub pod time code
1             package ogd;
2             require 5.008001; # must have a good B in the core
3              
4             # Make sure we have version info for this module
5             # Make sure we do everything by the book from now on
6              
7             $VERSION = '0.04';
8 1     1   620 use strict;
  1         2  
  1         118  
9              
10             # At compile time
11             # Create boolean for debug state
12             # Create constant with that boolean
13             # Create value for cleanup check
14             # Create constant with that value
15              
16             BEGIN {
17 1 50 50 1   16 my $debug = ($ENV{OGD_DEBUG} || '') =~ m#^(\d+)$# ? $1 : '';
18 1     1 0 40 eval "sub DEBUG () { $debug }";
19 1 50 50     8 my $cleanup = ($ENV{OGD_CLEANUP} || '') =~ m#^(\d+)$# ? $1 : 10;
20 1         51 eval "sub CLEANUP () { $cleanup }";
21             } #BEGIN
22              
23             # Make sure we can find out the blessing of an object and to weaken it
24              
25 1     1   5 use Scalar::Util qw(blessed weaken);
  1         1  
  1         60  
26              
27             # Initialize counter for number of objects registered
28             # List with objects that should be destroyed (first is a dummy object)
29              
30             my $registered = 0;
31             my @object;
32              
33             # Make sure we do this before anything else
34             # Allow for dirty tricks
35             # Obtain current setting
36             # See if we can call it
37             # Use the core one if it was an empty subroutine reference
38              
39             BEGIN {
40 1     1   4 no strict 'refs'; no warnings 'redefine';
  1     1   2  
  1         35  
  1         5  
  1         1  
  1         143  
41 1     1   4 my $old = \&CORE::GLOBAL::bless;
42 1         1 eval {$old->()};
  1         11  
43 1 50       5 $old = undef if $@ =~ m#CORE::GLOBAL::bless#;
44              
45             # Steal the system bless with a sub
46             # Obtain the class
47             # Create the object with the given parameters
48             # Register object
49             # Return the blessed object
50              
51             *CORE::GLOBAL::bless = sub {
52 0   0 0   0 my $class = $_[1] || caller();
53 0 0       0 my $object = $old ? $old->( $_[0],$class ) : CORE::bless $_[0],$class;
54 0         0 __PACKAGE__->register( $object );
55 0         0 $object;
56 1         340 };
57             } #BEGIN
58              
59             # When Perl is shutting down
60             # Make sure we can do the nifty internal stuff
61             # Push the shutting down sequence as the very last thing we'll do
62              
63             END {
64 1     1   794 require B;
65 1         2 push @{B::end_av()->object_2svref},\&_shutting_down;
  1         14  
66 1 50       21 print STDERR "*\n" if DEBUG;
67             } #END
68              
69             # Satisfy -require-
70              
71             1;
72              
73             #---------------------------------------------------------------------------
74             #
75             # Class methods
76             #
77             #---------------------------------------------------------------------------
78             # register
79             #
80             # Register one or more objects with ogd. Also used internally.
81             #
82             # IN: 1 class (ignored)
83             # 2..N objects to register
84              
85             sub register {
86              
87             # Lose the class
88             # Store weakened references to the object in the global list
89              
90 0     0 1   shift;
91 0 0         print STDERR "+".(@_)."\n" if DEBUG;
92 0           weaken( $object[@object] = $_ ) foreach @_;
93              
94             # Remember current number of objects registered (ever)
95             # Increment for number of objects registered
96             # If a cleanup is needed
97             # Remember the number of objects before cleanup started
98             # For all of the elements in reverse order (must access by index!)
99             # Remove the entry if it is not defined
100              
101 0           my $old = $registered;
102 0           $registered += @_;
103 0 0         if (($registered >> CLEANUP) > ($old >> CLEANUP)) {
104 0           my $before = @object;
105 0           foreach (reverse 0..$#object) {
106 0 0         splice @object,$_,1 unless defined $object[$_];
107             }
108 0 0 0       print STDERR "-$before->".(@object)."\n" if DEBUG and $before > @object;
109             }
110             } #register
111              
112             #---------------------------------------------------------------------------
113             #
114             # Internal methods
115             #
116             #---------------------------------------------------------------------------
117             # _shutting_down
118             #
119             # The subroutine that will be called at the very, very end
120              
121             sub _shutting_down {
122              
123             # Initialize hash with packages handled
124             # Initialize counter of how many done
125             # While there are objects to process
126             # Obtain newest object, reloop if it is already dead
127             # Mark the package as used
128             # Execute the DESTROY method on it (let it know it's being forced)
129              
130 0     0     my %package;
131 0           my $done = 0;
132 0           foreach (reverse 0..$#object) {
133 0 0         next unless defined $object[$_];
134 0           $package{blessed $object[$_]}++;
135 0           $object[$_]->DESTROY( 1 );
136 0 0         $done++ if DEBUG;
137             }
138 0 0         print STDERR "!$done\n" if DEBUG;
139              
140             # Make sure we'll be silent about the dirty stuff
141             # Replace DESTROY subs of all packages found with an empty stub
142              
143 1     1   6 no strict 'refs'; no warnings 'redefine';
  1     1   1  
  1         22  
  1         4  
  1         1  
  1         151  
144 0 0         print STDERR qq{x@{[map { "$_($package{$_})" } sort keys %package]}\n} if DEBUG;
  0            
  0            
145 0           *{$_.'::DESTROY'} = \&_destroy foreach keys %package;
  0            
146             } #_shutting_down
147              
148             #---------------------------------------------------------------------------
149             # _destroy
150             #
151             # IN: 1 instantiated object (ignored)
152             #
153             # This is the empty DESTROY stub that replaces any actual DESTROY subs
154             # after all objects have been destroyed.
155              
156       0     sub _destroy { } #_destroy
157              
158             #---------------------------------------------------------------------------
159              
160             __END__