File Coverage

blib/lib/Object/InsideOut/Autoload.pm
Criterion Covered Total %
statement 82 89 92.1
branch 44 54 81.4
condition 14 27 51.8
subroutine 4 4 100.0
pod n/a
total 144 174 82.7


line stmt bran cond sub pod time code
1             package Object::InsideOut; {
2              
3 9     9   80 use strict;
  9         20  
  9         317  
4 9     9   48 use warnings;
  9         19  
  9         270  
5 9     9   43 no warnings 'redefine';
  9         18  
  9         10602  
6              
7             # Handles :Automethods and foreign inheritance
8             sub AUTOLOAD
9             {
10             my ($GBL, @args) = @_;
11             push(@{$$GBL{'export'}}, 'AUTOLOAD');
12             $$GBL{'init'} = 1;
13              
14             *Object::InsideOut::AUTOLOAD = sub
15             {
16 35     35   5611 my $thing = $_[0];
17              
18             # Extract the class and method names from the fully-qualified name
19 35         248 my ($class, $method) = our $AUTOLOAD =~ /(.*)::(.*)/;
20              
21             # Handle superclass calls
22 35         72 my $super;
23 35 100       98 if ($class =~ /::SUPER$/) {
24 2         7 $class =~ s/::SUPER//;
25 2         4 $super = 1;
26             }
27              
28 35         73 my $heritage = $$GBL{'heritage'};
29 35         66 my $automethods = $$GBL{'sub'}{'auto'};
30              
31             # Find a something to handle the method call
32 35         62 my ($code_type, $code_dir, %code_refs);
33 35         54 foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) {
  35         117  
34             # Skip self's class if SUPER
35 73 100 100     294 if ($super && $class eq $pkg) {
36 2         4 next;
37             }
38              
39             # Check with heritage objects/classes
40 71 100       147 if (exists($$heritage{$pkg})) {
41 9         15 my $objects = $$heritage{$pkg}{'obj'};
42 9         15 my $classes = $$heritage{$pkg}{'cl'};
43 9 100       35 if (Scalar::Util::blessed($thing)) {
44 8 100       21 if (exists($$objects{$$thing})) {
45             # Check objects
46 4         6 foreach my $obj (@{$$objects{$$thing}}) {
  4         9  
47 4 50       16 if (my $code = $obj->can($method)) {
48 4         5 shift;
49 4         8 unshift(@_, $obj);
50 4         18 goto $code;
51             }
52             }
53             } else {
54             # Check classes
55 4         7 foreach my $pkg (keys(%{$classes})) {
  4         35  
56 4 50       36 if (my $code = $pkg->can($method)) {
57 4         12 @_ = @_; # Perl 5.8.5 bug workaround
58 4         22 goto $code;
59             }
60             }
61             }
62             } else {
63             # Check classes
64 1         2 foreach my $pkg (keys(%{$classes})) {
  1         4  
65 1 50       8 if (my $code = $pkg->can($method)) {
66 1         2 shift;
67 1         3 unshift(@_, $pkg);
68 1         6 goto $code;
69             }
70             }
71             }
72             }
73              
74             # Check with Automethod
75 62 100       152 if (my $automethod = $$automethods{$pkg}) {
76             # Call the Automethod to get a code ref
77 41         62 local $CALLER::_ = $_;
78 41         72 local $_ = $method;
79 41         138 local $SIG{'__DIE__'} = 'OIO::trap';
80 41 100       128 if (my ($code, $ctype) = $automethod->(@_)) {
81 31 100       395 if (ref($code) ne 'CODE') {
82             # Delete defective automethod
83 1         3 delete($$automethods{$pkg});
84             # Not a code ref
85 1         20 OIO::Code->die(
86             'message' => ':Automethod did not return a code ref',
87             'Info' => "NOTICE: The defective :Automethod in package '$pkg' has been DELETED!",
88             'Code' => ":Automethod in package '$pkg' invoked for method '$method'");
89             }
90              
91 30 100       63 if (defined($ctype)) {
92 15         83 my ($type, $dir) = $ctype =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
93 15 100 66     76 if ($type && $type =~ /CUM/i) {
94 9 100       19 if ($code_type) {
95 5         8 $type = ':Cumulative';
96 5 100 66     25 $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
97 5 50 33     21 if ($code_type ne $type || $code_dir ne $dir) {
98             # Mixed types
99 0         0 my ($pkg2) = keys(%code_refs);
100 0         0 OIO::Code->die(
101             'message' => 'Inconsistent code types returned by :Automethods',
102             'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
103             }
104             } else {
105 4         8 $code_type = ':Cumulative';
106 4 100 66     13 $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
107             }
108 9         19 $code_refs{$pkg} = $code;
109 9         36 next;
110             }
111 6 50 33     26 if ($type && $type =~ /CHA/i) {
112 6 100       14 if ($code_type) {
113 3         6 $type = ':Chained';
114 3 50 33     14 $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
115 3 50 33     13 if ($code_type ne $type || $code_dir ne $dir) {
116             # Mixed types
117 0         0 my ($pkg2) = keys(%code_refs);
118 0         0 OIO::Code->die(
119             'message' => 'Inconsistent code types returned by :Automethods',
120             'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
121             }
122             } else {
123 3         5 $code_type = ':Chained';
124 3 50 33     13 $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
125             }
126 6         14 $code_refs{$pkg} = $code;
127 6         21 next;
128             }
129              
130             # Unknown automethod code type
131             OIO::Code->die(
132 0         0 'message' => "Unknown :Automethod code type: $ctype",
133             'Info' => ":Automethod in package '$pkg' invoked for method '$method'");
134             }
135              
136 15 50       31 if ($code_type) {
137             # Mixed types
138 0         0 my ($pkg2) = keys(%code_refs);
139 0         0 OIO::Code->die(
140             'message' => 'Inconsistent code types returned by :Automethods',
141             'Info' => "Class '$pkg' returned an 'execute immediately' type, and class '$pkg2' returned type $code_type($code_dir)");
142             }
143              
144             # Just a one-shot - execute it
145 15         33 @_ = @_; # Perl 5.8.5 bug workaround
146 15         97 goto $code;
147             }
148             }
149             }
150              
151 10 100       47 if ($code_type) {
152 7 100       19 my $tree = ($code_dir eq 'bottom up') ? $$GBL{'tree'}{'bu'} : $$GBL{'tree'}{'td'};
153 7 100       29 my $code = ($code_type eq ':Cumulative')
154             ? create_CUMULATIVE($method, $tree, \%code_refs)
155             : create_CHAINED($method, $tree, \%code_refs);
156 7         31 @_ = @_; # Perl 5.8.5 bug workaround
157 7         25 goto $code;
158             }
159              
160             # Failed to AUTOLOAD
161 3 50       12 my $type = ref($thing) ? 'object' : 'class';
162 3         38 OIO::Method->die('message' => qq/Can't locate $type method "$method" via package "$class"/);
163             };
164              
165              
166             # Do the original call
167             @_ = @args;
168             goto &Object::InsideOut::AUTOLOAD;
169             }
170              
171             } # End of package's lexical scope
172              
173              
174             # Ensure correct versioning
175             ($Object::InsideOut::VERSION eq '4.05')
176             or die("Version mismatch\n");
177              
178             # EOF