File Coverage

blib/lib/Class/AutoClass/Root.pm
Criterion Covered Total %
statement 67 93 72.0
branch 13 32 40.6
condition 5 14 35.7
subroutine 13 16 81.2
pod 0 7 0.0
total 98 162 60.4


line stmt bran cond sub pod time code
1             package Class::AutoClass::Root;
2 38     38   39310 use strict;
  38         79  
  38         1824  
3              
4             # NG 09-11-02: This class is deprecated and will go away in a future release
5              
6 38     38   202 use vars qw(@ISA $DEBUG $ID $Revision $VERSION $VERBOSITY $ERRORLOADED @EXPORT);
  38         77  
  38         4749  
7 38     38   250 use strict;
  38         71  
  38         2981  
8              
9             BEGIN {
10              
11 38     38   92 $ID = 'Class::AutoClass::Root';
12 38         72 $VERSION = 1.0;
13 38         76 $Revision = '';
14 38         91 $DEBUG = 0;
15 38         82 $VERBOSITY = 0;
16 38         73715 $ERRORLOADED = 0;
17             }
18              
19              
20              
21             sub new {
22 1     1 0 14 my $class = shift;
23 1         3 my $self = {};
24 1   33     10 bless $self, ref($class) || $class;
25              
26 1 50       5 if(@_ > 1) {
27             # if the number of arguments is odd but at least 3, we'll give
28             # it a try to find -verbose
29 0 0       0 shift if @_ % 2;
30 0         0 my %param = @_;
31 0   0     0 $self->verbose($param{'-VERBOSE'} || $param{'-verbose'});
32             }
33 1         3 return $self;
34             }
35            
36             sub verbose {
37 3     3 0 239 my ($self,$value) = @_;
38             # allow one to set global verbosity flag
39 3 50       15 return $DEBUG if $DEBUG;
40 3 50       11 return $VERBOSITY unless ref $self;
41            
42 3 100 66     24 if (defined $value || ! defined $self->{'_root_verbose'}) {
43 1   50     8 $self->{'_root_verbose'} = $value || 0;
44             }
45 3         11 return $self->{'_root_verbose'};
46             }
47              
48             sub _register_for_cleanup {
49 0     0   0 my ($self,$method) = @_;
50 0 0       0 if($method) {
51 0 0       0 if(! exists($self->{'_root_cleanup_methods'})) {
52 0         0 $self->{'_root_cleanup_methods'} = [];
53             }
54 0         0 push(@{$self->{'_root_cleanup_methods'}},$method);
  0         0  
55             }
56             }
57              
58             sub _unregister_for_cleanup {
59 0     0   0 my ($self,$method) = @_;
60 0         0 my @methods = grep {$_ ne $method} $self->_cleanup_methods;
  0         0  
61 0         0 $self->{'_root_cleanup_methods'} = \@methods;
62             }
63              
64              
65             sub _cleanup_methods {
66 612     612   734 my $self = shift;
67 612 50 33     6992 return unless ref $self && $self->isa('HASH');
68 612 50       15439 my $methods = $self->{'_root_cleanup_methods'} or return;
69 0         0 @$methods;
70              
71             }
72              
73             sub throw{
74 1     1 0 457 my ($self,$string) = @_;
75              
76 1         3 my $std = $self->_stack_trace_dump();
77              
78 1         3 my $out = "\n-------------------- EXCEPTION --------------------\n".
79             "MSG: ".$string."\n".$std."-------------------------------------------\n";
80 1         6 die $out;
81              
82             }
83              
84             sub stack_trace{
85 3     3 0 525 my ($self) = @_;
86              
87 3         4 my $i = 0;
88 3         4 my @out;
89             my $prev;
90 3         28 while( my @call = caller($i++)) {
91             # major annoyance that caller puts caller context as
92             # function name. Hence some monkeying around...
93 9         17 $prev->[3] = $call[3];
94 9         10 push(@out,$prev);
95 9         59 $prev = \@call;
96             }
97 3         5 $prev->[3] = 'toplevel';
98 3         3 push(@out,$prev);
99 3         11 return @out;
100             }
101              
102             sub _stack_trace_dump{
103 2     2   5 my ($self) = @_;
104              
105 2         7 my @stack = $self->stack_trace();
106              
107 2         6 shift @stack;
108 2         4 shift @stack;
109 2         5 shift @stack;
110              
111 2         4 my $out;
112 2         3 my ($module,$function,$file,$position);
113            
114              
115 2         5 foreach my $stack ( @stack) {
116 4         3 ($module,$file,$position,$function) = @{$stack};
  4         12  
117 4         14 $out .= "STACK $function $file:$position\n";
118             }
119              
120 2         13 return $out;
121             }
122              
123             sub deprecated{
124 1     1 0 1157 my ($self,$msg) = @_;
125 1 50       4 if( $self->verbose >= 0 ) {
126 1         7 print STDERR $msg, "\n", $self->_stack_trace_dump;
127             }
128             }
129              
130             sub warn{
131 2     2 0 1282 my ($self,$string) = @_;
132            
133 2         4 my $verbose;
134 2 50       46 if( $self->can('verbose') ) {
135 2         7 $verbose = $self->verbose;
136             } else {
137 0         0 $verbose = 0;
138             }
139              
140 2 50       11 if( $verbose == 2 ) {
    50          
    50          
141 0         0 $self->throw($string);
142             } elsif( $verbose == -1 ) {
143 0         0 return;
144             } elsif( $verbose == 1 ) {
145 0         0 my $out = "\n-------------------- WARNING ---------------------\n".
146             "MSG: ".$string."\n";
147 0         0 $out .= $self->_stack_trace_dump;
148            
149 0         0 print STDERR $out;
150 0         0 return;
151             }
152              
153 2         6 my $out = "\n-------------------- WARNING ---------------------\n".
154             "MSG: ".$string."\n".
155             "---------------------------------------------------\n";
156 2         7 print STDERR $out;
157             }
158              
159             sub debug{
160 0     0 0 0 my ($self,@msgs) = @_;
161            
162 0 0       0 if( $self->verbose > 0 ) {
163 0         0 print STDERR join("", @msgs);
164             }
165             }
166              
167             sub DESTROY {
168 612     612   196505 my $self = shift;
169 612 50       4221 my @cleanup_methods = $self->_cleanup_methods or return;
170 0           for my $method (@cleanup_methods) {
171 0           $method->($self);
172             }
173             }
174              
175              
176              
177             1;
178