line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Class::Autouse; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# See POD at end of file for documentation |
4
|
|
|
|
|
|
|
|
5
|
14
|
|
|
14
|
|
356534
|
use 5.006; |
|
14
|
|
|
|
|
48
|
|
6
|
14
|
|
|
14
|
|
72
|
use strict; |
|
14
|
|
|
|
|
22
|
|
|
14
|
|
|
|
|
400
|
|
7
|
14
|
|
|
14
|
|
75
|
no strict 'refs'; # We _really_ abuse refs :) |
|
14
|
|
|
|
|
24
|
|
|
14
|
|
|
|
|
505
|
|
8
|
14
|
|
|
14
|
|
8952
|
use UNIVERSAL (); |
|
14
|
|
|
|
|
127
|
|
|
14
|
|
|
|
|
325
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# Load required modules |
11
|
|
|
|
|
|
|
# Luckily, these are so common they are basically free |
12
|
14
|
|
|
14
|
|
65
|
use Carp (); |
|
14
|
|
|
|
|
17
|
|
|
14
|
|
|
|
|
204
|
|
13
|
14
|
|
|
14
|
|
55
|
use Exporter (); |
|
14
|
|
|
|
|
17
|
|
|
14
|
|
|
|
|
298
|
|
14
|
14
|
|
|
14
|
|
61
|
use File::Spec 0.80 (); |
|
14
|
|
|
|
|
344
|
|
|
14
|
|
|
|
|
485
|
|
15
|
14
|
|
|
14
|
|
65
|
use List::Util 1.18 (); |
|
14
|
|
|
|
|
348
|
|
|
14
|
|
|
|
|
287
|
|
16
|
14
|
|
|
14
|
|
66
|
use Scalar::Util (); |
|
14
|
|
|
|
|
21
|
|
|
14
|
|
|
|
|
1110
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Handle optimisation switches via constants to allow debugging and |
19
|
|
|
|
|
|
|
# similar functions to be optimised out at compile time if not in use. |
20
|
|
|
|
|
|
|
our ($DB, $DEBUG); |
21
|
|
|
|
|
|
|
BEGIN { |
22
|
14
|
50
|
|
14
|
|
175
|
$DB = 0 unless defined &DB::DB; |
23
|
14
|
100
|
|
|
|
441
|
$DEBUG = 0 unless defined $DEBUG; |
24
|
|
|
|
|
|
|
} |
25
|
14
|
|
|
14
|
|
69
|
use constant DB => !! $DB; |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
1366
|
|
26
|
14
|
|
|
14
|
|
67
|
use constant DEBUG => !! $DEBUG; |
|
14
|
|
|
|
|
18
|
|
|
14
|
|
|
|
|
1055
|
|
27
|
|
|
|
|
|
|
print "Class::Autouse -> Debugging Activated.\n" if DEBUG; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# Globals |
30
|
14
|
|
|
14
|
|
73
|
use vars qw{ $VERSION @ISA }; |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
1043
|
|
31
|
14
|
|
|
14
|
|
74
|
use vars qw{ $DEVEL $SUPERLOAD $NOSTAT $NOPREBLESS $STATICISA }; # Load environment |
|
14
|
|
|
|
|
19
|
|
|
14
|
|
|
|
|
1002
|
|
32
|
14
|
|
|
14
|
|
66
|
use vars qw{ %SPECIAL %LOADED %BAD %TRIED_CLASS %TRIED_METHOD }; # Special cases |
|
14
|
|
|
|
|
18
|
|
|
14
|
|
|
|
|
1431
|
|
33
|
14
|
|
|
14
|
|
65
|
use vars qw{ @LOADERS @SUGAR $HOOKS $ORIGINAL_CAN $ORIGINAL_ISA }; # Working information |
|
14
|
|
|
|
|
27
|
|
|
14
|
|
|
|
|
3083
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# Compile-time Initialisation and Optimisation |
36
|
|
|
|
|
|
|
BEGIN { |
37
|
14
|
|
|
14
|
|
46
|
$VERSION = '1.99_04'; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# Become an exporter so we don't get complaints when we act as a pragma. |
40
|
|
|
|
|
|
|
# I don't fully understand the reason for this, but it works and I can't |
41
|
|
|
|
|
|
|
# recall how to replicate the problem, so leaving it in to avoid any |
42
|
|
|
|
|
|
|
# possible reversion. Besides, so many things use Exporter it should |
43
|
|
|
|
|
|
|
# be practically free to do this. |
44
|
14
|
|
|
|
|
165
|
@ISA = qw{ Exporter }; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# We always start with the superloader off |
47
|
14
|
|
|
|
|
22
|
$SUPERLOAD = 0; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# When set, disables $obj->isa/can where $obj is blessed before its class is loaded |
50
|
|
|
|
|
|
|
# Things will operate more quickly when set, but this breaks things if you're |
51
|
|
|
|
|
|
|
# unserializing objects from Data::Dumper, etc., and relying on this module to |
52
|
|
|
|
|
|
|
# load the related classes on demand. |
53
|
14
|
|
|
|
|
15
|
$NOPREBLESS = 0; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# Disable stating for situations where modules are on remote disks |
56
|
14
|
|
|
|
|
16
|
$NOSTAT = 0; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# AUTOLOAD hook counter |
59
|
14
|
|
|
|
|
21
|
$HOOKS = 0; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# ERRATA |
62
|
|
|
|
|
|
|
# Special classes are internal and should be left alone. |
63
|
|
|
|
|
|
|
# Loaded modules are those already loaded by us. |
64
|
|
|
|
|
|
|
# Bad classes are those that are incompatible with us. |
65
|
14
|
|
|
|
|
23
|
%BAD = map { $_ => 1 } qw{ |
|
14
|
|
|
|
|
63
|
|
66
|
|
|
|
|
|
|
IO::File |
67
|
|
|
|
|
|
|
}; |
68
|
|
|
|
|
|
|
|
69
|
14
|
|
|
|
|
26
|
%SPECIAL = map { $_ => 1 } qw{ |
|
112
|
|
|
|
|
249
|
|
70
|
|
|
|
|
|
|
CORE main UNIVERSAL |
71
|
|
|
|
|
|
|
ARRAY HASH SCALAR REF GLOB |
72
|
|
|
|
|
|
|
}; |
73
|
|
|
|
|
|
|
|
74
|
14
|
|
|
|
|
38
|
%LOADED = map { $_ => 1 } qw{ |
|
98
|
|
|
|
|
163
|
|
75
|
|
|
|
|
|
|
UNIVERSAL |
76
|
|
|
|
|
|
|
Carp |
77
|
|
|
|
|
|
|
Exporter |
78
|
|
|
|
|
|
|
File::Spec |
79
|
|
|
|
|
|
|
List::Util |
80
|
|
|
|
|
|
|
Scalar::Util |
81
|
|
|
|
|
|
|
Class::Autouse |
82
|
|
|
|
|
|
|
}; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# "Have we tried to autoload a class before?" |
85
|
|
|
|
|
|
|
# Per-class loop protection and improved shortcutting. |
86
|
|
|
|
|
|
|
# Defaults to specials+preloaded to prevent attempting them. |
87
|
14
|
|
|
|
|
116
|
%TRIED_CLASS = ( %SPECIAL, %LOADED ); |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# "Have we tried to autoload a method before?" |
90
|
|
|
|
|
|
|
# Per-method loop protection and improved shortcutting |
91
|
14
|
|
|
|
|
30
|
%TRIED_METHOD = (); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Storage for dynamic loaders (regular and sugar) |
94
|
14
|
|
|
|
|
19
|
@LOADERS = (); |
95
|
14
|
|
|
|
|
22
|
@SUGAR = (); |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# We play with UNIVERSAL:: functions, so save backup copies |
98
|
14
|
|
|
|
|
25
|
$ORIGINAL_CAN = \&UNIVERSAL::can; |
99
|
14
|
|
|
|
|
38207
|
$ORIGINAL_ISA = \&UNIVERSAL::isa; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
##################################################################### |
107
|
|
|
|
|
|
|
# Configuration and Setting up |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Developer mode flag. |
110
|
|
|
|
|
|
|
# Cannot be turned off once turned on. |
111
|
|
|
|
|
|
|
sub devel { |
112
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# Enable if not already |
115
|
0
|
0
|
|
|
|
|
return 1 if $DEVEL++; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# Load any unloaded modules. |
118
|
|
|
|
|
|
|
# Most of the time there should be nothing here. |
119
|
0
|
|
|
|
|
|
foreach my $class ( grep { $INC{$_} eq 'Class::Autouse' } keys %INC ) { |
|
0
|
|
|
|
|
|
|
120
|
0
|
|
|
|
|
|
$class =~ s/\//::/; |
121
|
0
|
|
|
|
|
|
$class =~ s/\.pm$//i; |
122
|
0
|
|
|
|
|
|
Class::Autouse->load($class); |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# Happy Fun Super Loader! |
127
|
|
|
|
|
|
|
# The process here is to replace the &UNIVERSAL::AUTOLOAD sub |
128
|
|
|
|
|
|
|
# ( which is just a dummy by default ) with a flexible class loader. |
129
|
|
|
|
|
|
|
sub superloader { |
130
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Shortcut if needed |
133
|
0
|
0
|
|
|
|
|
return 1 if $SUPERLOAD++; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Enable the global hooks |
136
|
0
|
|
|
|
|
|
_GLOBAL_HOOKS(); |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
|
|
|
return 1; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub sugar { |
142
|
|
|
|
|
|
|
# Operate as a function or a method |
143
|
0
|
0
|
|
0
|
|
|
shift if $_[0] eq 'Class::Autouse'; |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# Ignore calls with no arguments |
146
|
0
|
0
|
|
|
|
|
return 1 unless @_; |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
|
|
|
_debug(\@_) if DEBUG; |
149
|
|
|
|
|
|
|
|
150
|
0
|
|
|
|
|
|
foreach my $callback ( grep { $_ } @_ ) { |
|
0
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# Handle a callback or regex |
152
|
0
|
0
|
|
|
|
|
unless ( ref $callback eq 'CODE' ) { |
153
|
0
|
|
|
|
|
|
die( |
154
|
|
|
|
|
|
|
__PACKAGE__ |
155
|
|
|
|
|
|
|
. ' takes a code reference for syntactic sugar handlers' |
156
|
|
|
|
|
|
|
. ": unexpected value $callback has type " |
157
|
|
|
|
|
|
|
. ref($callback) |
158
|
|
|
|
|
|
|
); |
159
|
|
|
|
|
|
|
} |
160
|
0
|
|
|
|
|
|
push @SUGAR, $callback; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# Enable global hooking |
163
|
0
|
|
|
|
|
|
_GLOBAL_HOOKS(); |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
0
|
|
|
|
|
|
return 1; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# The main autouse sub |
170
|
|
|
|
|
|
|
sub autouse { |
171
|
|
|
|
|
|
|
# Operate as a function or a method |
172
|
0
|
0
|
|
0
|
|
|
shift if $_[0] eq 'Class::Autouse'; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# Ignore calls with no arguments |
175
|
0
|
0
|
|
|
|
|
return 1 unless @_; |
176
|
|
|
|
|
|
|
|
177
|
0
|
|
|
|
|
|
_debug(\@_) if DEBUG; |
178
|
|
|
|
|
|
|
|
179
|
0
|
|
|
|
|
|
foreach my $class ( grep { $_ } @_ ) { |
|
0
|
|
|
|
|
|
|
180
|
0
|
0
|
|
|
|
|
if ( ref $class ) { |
181
|
0
|
0
|
0
|
|
|
|
unless ( ref $class eq 'Regexp' or ref $class eq 'CODE') { |
182
|
0
|
|
|
|
|
|
die( __PACKAGE__ |
183
|
|
|
|
|
|
|
. ' can autouse explicit class names, or take a regex or subroutine reference' |
184
|
|
|
|
|
|
|
. ": unexpected value $class has type " |
185
|
|
|
|
|
|
|
. ref($class) |
186
|
|
|
|
|
|
|
); |
187
|
|
|
|
|
|
|
} |
188
|
0
|
|
|
|
|
|
push @LOADERS, $class; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# Enable the global hooks |
191
|
0
|
|
|
|
|
|
_GLOBAL_HOOKS(); |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# Reset shortcut cache, since we may have previously |
194
|
|
|
|
|
|
|
# tried a class and failed, which could now work |
195
|
0
|
|
|
|
|
|
%TRIED_CLASS = ( %SPECIAL, %LOADED ); |
196
|
0
|
|
|
|
|
|
next; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
# Control flag handling |
200
|
0
|
0
|
|
|
|
|
if ( substr($class, 0, 1) eq ':' ) { |
201
|
0
|
0
|
|
|
|
|
if ( $class eq ':superloader' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# Turn on the superloader |
203
|
0
|
|
|
|
|
|
Class::Autouse->superloader; |
204
|
|
|
|
|
|
|
} elsif ( $class eq ':devel' ) { |
205
|
|
|
|
|
|
|
# Turn on devel mode |
206
|
0
|
|
|
|
|
|
Class::Autouse->devel(1); |
207
|
|
|
|
|
|
|
} elsif ( $class eq ':nostat' ) { |
208
|
|
|
|
|
|
|
# Disable stat checks |
209
|
0
|
|
|
|
|
|
$NOSTAT = 1; |
210
|
|
|
|
|
|
|
} elsif ( $class eq ':noprebless') { |
211
|
|
|
|
|
|
|
# Disable support for objects blessed before their class module is loaded |
212
|
0
|
|
|
|
|
|
$NOPREBLESS = 1; |
213
|
|
|
|
|
|
|
} elsif ( $class eq ':staticisa') { |
214
|
|
|
|
|
|
|
# Expect that @ISA won't change after loading |
215
|
|
|
|
|
|
|
# This allows some performance tweaks |
216
|
0
|
|
|
|
|
|
$STATICISA = 1; |
217
|
|
|
|
|
|
|
} |
218
|
0
|
|
|
|
|
|
next; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# Load now if in devel mode, or if its a bad class |
222
|
0
|
0
|
0
|
|
|
|
if ( $DEVEL || $BAD{$class} ) { |
223
|
0
|
|
|
|
|
|
Class::Autouse->load($class); |
224
|
0
|
|
|
|
|
|
next; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# Does the file for the class exist? |
228
|
0
|
|
|
|
|
|
my $file = _class_file($class); |
229
|
0
|
0
|
|
|
|
|
next if exists $INC{$file}; |
230
|
0
|
0
|
0
|
|
|
|
unless ( $NOSTAT or _file_exists($file) ) { |
231
|
0
|
|
|
|
|
|
my $inc = join ', ', @INC; |
232
|
0
|
|
|
|
|
|
_cry("Can't locate $file in \@INC (\@INC contains: $inc)"); |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# Don't actually do anything if the superloader is on. |
236
|
|
|
|
|
|
|
# It will catch all AUTOLOAD calls. |
237
|
0
|
0
|
|
|
|
|
next if $SUPERLOAD; |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# Add the AUTOLOAD hook and %INC lock to prevent 'use'ing |
240
|
0
|
|
|
|
|
|
*{"${class}::AUTOLOAD"} = \&_AUTOLOAD; |
|
0
|
|
|
|
|
|
|
241
|
0
|
|
|
|
|
|
$INC{$file} = 'Class::Autouse'; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# When we add the first hook, hijack UNIVERSAL::can/isa |
244
|
0
|
0
|
|
|
|
|
_UPDATE_HOOKS() unless $HOOKS++; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
0
|
|
|
|
|
|
return 1; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# Import behaves the same as autouse |
251
|
|
|
|
|
|
|
sub import { |
252
|
0
|
|
|
0
|
|
|
shift->autouse(@_); |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
##################################################################### |
260
|
|
|
|
|
|
|
# Explicit Actions |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# Completely load a class ( The class and all its dependencies ). |
263
|
|
|
|
|
|
|
sub load { |
264
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
265
|
|
|
|
|
|
|
|
266
|
0
|
0
|
|
|
|
|
my $class = $_[1] or _cry('No class name specified to load'); |
267
|
0
|
0
|
|
|
|
|
return 1 if $LOADED{$class}; |
268
|
|
|
|
|
|
|
|
269
|
0
|
|
|
|
|
|
my @search = _super( $class, \&_load ); |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# If called an an array context, return the ISA tree. |
272
|
|
|
|
|
|
|
# In scalar context, just return true. |
273
|
0
|
0
|
|
|
|
|
wantarray ? @search : 1; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# Is a particular class installed in out @INC somewhere |
277
|
|
|
|
|
|
|
# OR is it loaded in our program already |
278
|
|
|
|
|
|
|
sub class_exists { |
279
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
280
|
0
|
0
|
|
|
|
|
_namespace_occupied($_[1]) or _file_exists($_[1]); |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# A more general method to answer the question |
284
|
|
|
|
|
|
|
# "Can I call a method on this class and expect it to work" |
285
|
|
|
|
|
|
|
# Returns undef if the class does not exist |
286
|
|
|
|
|
|
|
# Returns 0 if the class is not loaded ( or autouse'd ) |
287
|
|
|
|
|
|
|
# Returns 1 if the class can be used. |
288
|
|
|
|
|
|
|
sub can_call_methods { |
289
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
290
|
0
|
0
|
|
|
|
|
_namespace_occupied($_[1]) or exists $INC{_class_file($_[1])}; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# Recursive methods currently only work withing the scope of the single @INC |
294
|
|
|
|
|
|
|
# entry containing the "top" module, and will probably stay this way |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# Autouse not only a class, but all others below it. |
297
|
|
|
|
|
|
|
sub autouse_recursive { |
298
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# Just load if in devel mode |
301
|
0
|
0
|
|
|
|
|
return Class::Autouse->load_recursive($_[1]) if $DEVEL; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# Don't need to do anything if the super loader is on |
304
|
0
|
0
|
|
|
|
|
return 1 if $SUPERLOAD; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# Find all the child classes, and hand them to the autouse method |
307
|
0
|
|
|
|
|
|
Class::Autouse->autouse( $_[1], _children($_[1]) ); |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# Load not only a class and all others below it |
311
|
|
|
|
|
|
|
sub load_recursive { |
312
|
0
|
|
|
0
|
|
|
_debug(\@_, 1) if DEBUG; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# Load the parent class, and its children |
315
|
0
|
|
|
|
|
|
foreach ( $_[1], _children($_[1]) ) { |
316
|
0
|
|
|
|
|
|
Class::Autouse->load($_); |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
0
|
|
|
|
|
|
return 1; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
##################################################################### |
327
|
|
|
|
|
|
|
# Symbol Table Hooks |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# These get hooked to various places on the symbol table, |
330
|
|
|
|
|
|
|
# to enable the autoload functionality |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
# Linked to each individual class via the symbol table |
333
|
|
|
|
|
|
|
sub _AUTOLOAD { |
334
|
0
|
|
|
0
|
|
|
_debug(\@_, 0, ", AUTOLOAD = '$Class::Autouse::AUTOLOAD'") if DEBUG; |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Loop detection (just in case) |
337
|
0
|
0
|
|
|
|
|
my $method = $Class::Autouse::AUTOLOAD or _cry('Missing method name'); |
338
|
0
|
0
|
|
|
|
|
_cry("Undefined subroutine &$method called") if ++$TRIED_METHOD{$method} > 10; |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# Don't bother with special classes |
341
|
0
|
|
|
|
|
|
my ($class, $function) = $method =~ m/^(.*)::(.*)\z/s; |
342
|
0
|
0
|
|
|
|
|
_cry("Undefined subroutine &$method called") if $SPECIAL{$class}; |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
# Load the class and it's dependancies, and get the search path |
345
|
0
|
|
|
|
|
|
my @search = Class::Autouse->load($class); |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
# Find and go to the named method |
348
|
|
|
|
|
|
|
my $found = List::Util::first { |
349
|
0
|
|
|
|
|
|
defined *{"${_}::$function"}{CODE} |
350
|
0
|
|
|
0
|
|
|
} @search; |
|
0
|
|
|
|
|
|
|
351
|
0
|
0
|
|
|
|
|
goto &{"${found}::$function"} if $found; |
|
0
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# Check for package AUTOLOADs |
354
|
0
|
|
|
|
|
|
foreach my $c ( @search ) { |
355
|
0
|
0
|
|
|
|
|
if ( defined *{"${c}::AUTOLOAD"}{CODE} ) { |
|
0
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Simulate a normal autoload call |
357
|
0
|
|
|
|
|
|
${"${c}::AUTOLOAD"} = $method; |
|
0
|
|
|
|
|
|
|
358
|
0
|
|
|
|
|
|
goto &{"${c}::AUTOLOAD"}; |
|
0
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# Can't find the method anywhere. Throw the same error Perl does. |
363
|
0
|
|
|
|
|
|
_cry("Can't locate object method \"$function\" via package \"$class\""); |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# This is a special version of the above for use in UNIVERSAL |
367
|
|
|
|
|
|
|
# It does the :superloader, and/or also any regex or callback (code ref) loaders |
368
|
|
|
|
|
|
|
sub _UNIVERSAL_AUTOLOAD { |
369
|
0
|
|
|
0
|
|
|
_debug(\@_, 0, ", \$AUTOLOAD = '$Class::Autouse::AUTOLOAD'") if DEBUG; |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# Loop detection ( Just in case ) |
372
|
0
|
0
|
|
|
|
|
my $method = $Class::Autouse::AUTOLOAD or _cry('Missing method name'); |
373
|
0
|
0
|
|
|
|
|
_cry("Undefined subroutine &$method called") if ++$TRIED_METHOD{ $method } > 10; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# Don't bother with special classes |
376
|
0
|
|
|
|
|
|
my ($class, $function) = $method =~ m/^(.*)::(.*)\z/s; |
377
|
0
|
0
|
|
|
|
|
_cry("Undefined subroutine &$method called") if $SPECIAL{$class}; |
378
|
|
|
|
|
|
|
|
379
|
0
|
|
|
|
|
|
my @search; |
380
|
0
|
0
|
|
|
|
|
if ( $SUPERLOAD ) { |
381
|
|
|
|
|
|
|
# Only try direct loading of the class if the superloader is active. |
382
|
|
|
|
|
|
|
# This might be installed in universal for either the superloader, special loaders, or both. |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# Load the class and it's dependancies, and get the search path |
385
|
0
|
|
|
|
|
|
@search = Class::Autouse->load($class); |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
0
|
0
|
|
|
|
|
unless ( @search ) { |
389
|
|
|
|
|
|
|
# The special loaders will attempt to dynamically instantiate the class. |
390
|
|
|
|
|
|
|
# They will not fire if the superloader is turned on and has already loaded the class. |
391
|
0
|
0
|
|
|
|
|
if ( _try_loaders($class, $function, @_) ) { |
392
|
0
|
|
|
|
|
|
my $fref = $ORIGINAL_CAN->($class, $function); |
393
|
0
|
0
|
|
|
|
|
if ( $fref ) { |
394
|
0
|
|
|
|
|
|
goto $fref; |
395
|
|
|
|
|
|
|
} else { |
396
|
0
|
|
|
|
|
|
@search = _super($class); |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
# Find and go to the named method |
402
|
0
|
|
|
0
|
|
|
my $found = List::Util::first { defined *{"${_}::$function"}{CODE} } @search; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
403
|
0
|
0
|
|
|
|
|
goto &{"${found}::$function"} if $found; |
|
0
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
# Check for package AUTOLOADs |
406
|
0
|
|
|
|
|
|
foreach my $c ( @search ) { |
407
|
0
|
0
|
|
|
|
|
if ( defined *{"${c}::AUTOLOAD"}{CODE} ) { |
|
0
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Simulate a normal autoload call |
409
|
0
|
|
|
|
|
|
${"${c}::AUTOLOAD"} = $method; |
|
0
|
|
|
|
|
|
|
410
|
0
|
|
|
|
|
|
goto &{"${c}::AUTOLOAD"}; |
|
0
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
|
for my $callback ( @SUGAR ) { |
415
|
0
|
|
|
|
|
|
my $rv = $callback->( $class, $function, @_ ); |
416
|
0
|
0
|
|
|
|
|
goto $rv if $rv; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# Can't find the method anywhere. Throw the same error Perl does. |
420
|
0
|
|
|
|
|
|
_cry("Can't locate object method \"$function\" via package \"$class\""); |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# This just handles the call and does nothing. |
424
|
|
|
|
|
|
|
# It prevents destroy calls going through to the AUTOLOAD hooks. |
425
|
|
|
|
|
|
|
sub _UNIVERSAL_DESTROY { |
426
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub _isa { |
430
|
|
|
|
|
|
|
# Optional performance hack |
431
|
0
|
0
|
0
|
0
|
|
|
goto $ORIGINAL_ISA if ref $_[0] and $NOPREBLESS; |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# Load the class, unless we are sure it is already |
434
|
0
|
|
0
|
|
|
|
my $class = ref $_[0] || $_[0] || return undef; |
435
|
0
|
0
|
0
|
|
|
|
unless ( $TRIED_CLASS{$class} or $LOADED{$class} ) { |
436
|
0
|
|
|
|
|
|
_preload($_[0]); |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
|
goto &{$ORIGINAL_ISA}; |
|
0
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# This is the replacement for UNIVERSAL::can |
443
|
|
|
|
|
|
|
sub _can { |
444
|
|
|
|
|
|
|
# Optional performance hack |
445
|
0
|
0
|
0
|
0
|
|
|
goto $ORIGINAL_CAN if ref $_[0] and $NOPREBLESS; |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# Load the class, unless we are sure it is already |
448
|
0
|
|
0
|
|
|
|
my $class = ref $_[0] || $_[0] || return undef; |
449
|
0
|
0
|
0
|
|
|
|
unless ( $TRIED_CLASS{$class} or $LOADED{$class} ) { |
450
|
0
|
|
|
|
|
|
_preload($_[0]); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
0
|
|
|
|
|
|
goto &{$ORIGINAL_CAN}; |
|
0
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
##################################################################### |
461
|
|
|
|
|
|
|
# Support Functions |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
sub _preload { |
464
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# Does it look like a package? |
467
|
0
|
|
0
|
|
|
|
my $class = ref $_[0] || $_[0]; |
468
|
0
|
0
|
0
|
|
|
|
unless ( $class and $class =~ /^[^\W\d]\w*(?:(?:\'|::)[^\W]\w*)*$/o ) { |
469
|
0
|
|
|
|
|
|
return $LOADED{$class} = 1; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
# Do we try to load the class |
473
|
0
|
|
|
|
|
|
my $load = 0; |
474
|
0
|
|
|
|
|
|
my $file = _class_file($class); |
475
|
0
|
0
|
0
|
|
|
|
if ( defined $INC{$file} and $INC{$file} eq 'Class::Autouse' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# It's an autoused class |
477
|
0
|
|
|
|
|
|
$load = 1; |
478
|
|
|
|
|
|
|
} elsif ( ! $SUPERLOAD ) { |
479
|
|
|
|
|
|
|
# Superloader isn't on, don't load |
480
|
0
|
|
|
|
|
|
$load = 0; |
481
|
|
|
|
|
|
|
} elsif ( _namespace_occupied($class) ) { |
482
|
|
|
|
|
|
|
# Superloader is on, but there is something already in the class |
483
|
|
|
|
|
|
|
# This can't be the autouse loader, because we would have caught |
484
|
|
|
|
|
|
|
# that case already. |
485
|
0
|
|
|
|
|
|
$load = 0; |
486
|
|
|
|
|
|
|
} else { |
487
|
|
|
|
|
|
|
# The rules of the superloader say we assume loaded unless we can |
488
|
|
|
|
|
|
|
# tell otherwise. Thus, we have to have a go at loading. |
489
|
0
|
|
|
|
|
|
$load = 1; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# If needed, load the class and all its dependencies. |
493
|
0
|
0
|
|
|
|
|
Class::Autouse->load($class) if $load; |
494
|
|
|
|
|
|
|
|
495
|
0
|
0
|
|
|
|
|
unless ( $LOADED{$class} ) { |
496
|
0
|
|
|
|
|
|
_try_loaders($class); |
497
|
0
|
0
|
|
|
|
|
unless ( $LOADED{$class} ) { |
498
|
0
|
0
|
|
|
|
|
if ( _namespace_occupied($class) ) { |
499
|
|
|
|
|
|
|
# The class is not flagged as loaded by autouse, but exists |
500
|
|
|
|
|
|
|
# to ensure its ancestry is loaded before calling $orig |
501
|
0
|
|
|
|
|
|
$LOADED{$class} = 1; |
502
|
0
|
|
|
|
|
|
_load_ancestors($class); |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
|
507
|
0
|
|
|
|
|
|
return 1; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
sub _try_loaders { |
511
|
0
|
|
|
0
|
|
|
_debug(\@_, 0) if DEBUG; |
512
|
0
|
|
|
|
|
|
my ($class, $function, @optional_args) = @_; |
513
|
|
|
|
|
|
|
# The function and args are only present to help callbacks whose main goal is to |
514
|
|
|
|
|
|
|
# do "syntactic sugar" instead of really writing a class |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
# This allows us to shortcut out of re-checking a class |
517
|
0
|
|
|
|
|
|
$TRIED_CLASS{$class}++; |
518
|
|
|
|
|
|
|
|
519
|
0
|
0
|
|
|
|
|
if ( _namespace_occupied($class) ) { |
520
|
0
|
|
|
|
|
|
$LOADED{$class} = 1; |
521
|
0
|
|
|
|
|
|
_load_ancestors($class); |
522
|
0
|
|
|
|
|
|
return 1; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
# Try each of the special loaders, if there are any. |
526
|
0
|
|
|
|
|
|
for my $loader ( @LOADERS ) { |
527
|
0
|
|
|
|
|
|
my $ref = ref($loader); |
528
|
0
|
0
|
|
|
|
|
if ( $ref ) { |
529
|
0
|
0
|
|
|
|
|
if ( $ref eq "Regexp" ) { |
|
|
0
|
|
|
|
|
|
530
|
0
|
0
|
|
|
|
|
next unless $class =~ $loader; |
531
|
0
|
|
|
|
|
|
my $file = _class_file($class); |
532
|
0
|
0
|
|
|
|
|
next unless grep { -e $_ . '/' . $file } @INC; |
|
0
|
|
|
|
|
|
|
533
|
0
|
|
|
|
|
|
local $^W = 0; |
534
|
0
|
|
|
|
|
|
local $@; |
535
|
0
|
|
|
|
|
|
eval "use $class"; |
536
|
0
|
0
|
|
|
|
|
die "Class::Autouse found module $file for class $class matching regex '$loader'," |
537
|
|
|
|
|
|
|
. " but it failed to compile with the following error: $@" if $@; |
538
|
|
|
|
|
|
|
} elsif ( $ref eq "CODE" ) { |
539
|
0
|
0
|
|
|
|
|
unless ( $loader->( $class,$function,@optional_args ) ) { |
540
|
0
|
|
|
|
|
|
next; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
} else { |
543
|
0
|
|
|
|
|
|
die "Unexpected loader. Expected qr//, sub{}, or class name string." |
544
|
|
|
|
|
|
|
} |
545
|
0
|
|
|
|
|
|
$LOADED{$class} = 1; |
546
|
0
|
|
|
|
|
|
_load_ancestors($class); |
547
|
0
|
|
|
|
|
|
return 1; |
548
|
|
|
|
|
|
|
} else { |
549
|
0
|
|
|
|
|
|
die "Odd loader $loader passed to " . __PACKAGE__; |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
0
|
|
|
|
|
|
return; |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
# This is called after any class is hit by load/preload to ensure that parent classes are also loaded |
557
|
|
|
|
|
|
|
sub _load_ancestors { |
558
|
0
|
|
|
0
|
|
|
_debug(\@_, 0) if DEBUG; |
559
|
0
|
|
|
|
|
|
my $class = $_[0]; |
560
|
0
|
|
|
|
|
|
my ($this_class,@ancestors) = _super($class); |
561
|
0
|
|
|
|
|
|
for my $ancestor ( @ancestors ) { |
562
|
|
|
|
|
|
|
# this is a bit ugly, _preload presumes either isa or can is being called, |
563
|
|
|
|
|
|
|
# and does a goto at the end of it, we just want the core logic, not the redirection |
564
|
|
|
|
|
|
|
# so we pass undef as the subref parameter |
565
|
0
|
|
|
|
|
|
_preload($ancestor); |
566
|
|
|
|
|
|
|
} |
567
|
0
|
0
|
|
|
|
|
if ( $STATICISA ) { |
568
|
|
|
|
|
|
|
# Optional performance optimization. |
569
|
|
|
|
|
|
|
# After we have the entire ancestry, |
570
|
|
|
|
|
|
|
# set the greatest grandparent's can/isa to the originals. |
571
|
|
|
|
|
|
|
# This keeps the versions in this module from being used where they're not needed. |
572
|
0
|
|
0
|
|
|
|
my $final_parent = $ancestors[-1] || $this_class; |
573
|
14
|
|
|
14
|
|
118
|
no strict 'refs'; |
|
14
|
|
|
|
|
19
|
|
|
14
|
|
|
|
|
28210
|
|
574
|
0
|
|
|
|
|
|
*{ $final_parent . '::can'} = $ORIGINAL_CAN; |
|
0
|
|
|
|
|
|
|
575
|
0
|
|
|
|
|
|
*{ $final_parent . '::isa'} = $ORIGINAL_ISA; |
|
0
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
} |
577
|
0
|
|
|
|
|
|
return 1; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
# This walks the @ISA tree, optionally calling a subref on each class |
581
|
|
|
|
|
|
|
# and returns the inherited classes in a list, including $class itself. |
582
|
|
|
|
|
|
|
sub _super { |
583
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
584
|
0
|
|
|
|
|
|
my $class = shift; |
585
|
0
|
|
|
|
|
|
my $load = shift; |
586
|
0
|
|
|
|
|
|
my @stack = ( $class ); |
587
|
0
|
|
|
|
|
|
my %seen = ( UNIVERSAL => 1 ); |
588
|
0
|
|
|
|
|
|
my @search = (); |
589
|
|
|
|
|
|
|
|
590
|
0
|
|
|
|
|
|
while ( my $c = shift @stack ) { |
591
|
0
|
0
|
|
|
|
|
next if $seen{$c}++; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# This may load the class in question, so |
594
|
|
|
|
|
|
|
# we call it before checking @ISA. |
595
|
0
|
0
|
0
|
|
|
|
if ( $load and not $LOADED{$c} ) { |
596
|
0
|
|
|
|
|
|
$load->($c); |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# Add the class to the search list, |
600
|
|
|
|
|
|
|
# and add the @ISA to the load stack. |
601
|
0
|
|
|
|
|
|
push @search, $c; |
602
|
0
|
|
|
|
|
|
unshift @stack, @{"${c}::ISA"}; |
|
0
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
0
|
|
|
|
|
|
return @search; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
# Load a single class |
609
|
|
|
|
|
|
|
sub _load ($) { |
610
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# Don't attempt to load special classes |
613
|
0
|
0
|
|
|
|
|
my $class = shift or _cry('Did not specify a class to load'); |
614
|
0
|
|
|
|
|
|
$TRIED_CLASS{$class}++; |
615
|
|
|
|
|
|
|
|
616
|
0
|
0
|
|
|
|
|
return 1 if $SPECIAL{$class}; |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# Run some checks |
619
|
0
|
|
|
|
|
|
my $file = _class_file($class); |
620
|
0
|
0
|
|
|
|
|
if ( defined $INC{$file} ) { |
|
|
0
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# If the %INC lock is set to any other value, the file is |
622
|
|
|
|
|
|
|
# already loaded. We do not need to do anything. |
623
|
0
|
0
|
|
|
|
|
if ( $INC{$file} ne 'Class::Autouse') { |
624
|
0
|
|
|
|
|
|
return $LOADED{$class} = 1; |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
# Because we autoused it earlier, we know the file for this |
628
|
|
|
|
|
|
|
# class MUST exist. |
629
|
|
|
|
|
|
|
# Removing the AUTOLOAD hook and %INC lock is all we have to do |
630
|
0
|
|
|
|
|
|
delete ${"${class}::"}{'AUTOLOAD'}; |
|
0
|
|
|
|
|
|
|
631
|
0
|
|
|
|
|
|
delete $INC{$file}; |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
} elsif ( not _file_exists($file) ) { |
634
|
|
|
|
|
|
|
# We might still be loaded, if the class was defined |
635
|
|
|
|
|
|
|
# in some other module without it's own file. |
636
|
0
|
0
|
|
|
|
|
if ( _namespace_occupied($class) ) { |
637
|
0
|
|
|
|
|
|
return $LOADED{$class} = 1; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
# Not loaded and no file either. |
641
|
|
|
|
|
|
|
# Try to generate the class instead. |
642
|
0
|
0
|
|
|
|
|
if ( _try_loaders($class) ) { |
643
|
0
|
|
|
|
|
|
return 1; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# We've run out of options, it just doesn't exist |
647
|
0
|
|
|
|
|
|
my $inc = join ', ', @INC; |
648
|
0
|
|
|
|
|
|
_cry("Can't locate $file in \@INC (\@INC contains: $inc)"); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# Load the file for this class |
652
|
0
|
|
|
|
|
|
print _depth(1) . " Class::Autouse::load -> Loading in $file\n" if DEBUG; |
653
|
0
|
|
|
|
|
|
eval { |
654
|
0
|
|
|
|
|
|
CORE::require($file); |
655
|
|
|
|
|
|
|
}; |
656
|
0
|
0
|
|
|
|
|
_cry($@) if $@; |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
# Give back UNIVERSAL::can/isa if there are no other hooks |
659
|
0
|
0
|
|
|
|
|
--$HOOKS or _UPDATE_HOOKS(); |
660
|
|
|
|
|
|
|
|
661
|
0
|
|
|
|
|
|
$LOADED{$class} = 1; |
662
|
0
|
|
|
|
|
|
_load_ancestors($class); |
663
|
0
|
|
|
|
|
|
return 1; |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
# Find all the child classes for a parent class. |
667
|
|
|
|
|
|
|
# Returns in the list context. |
668
|
|
|
|
|
|
|
sub _children ($) { |
669
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# Find where it is in @INC |
672
|
0
|
|
|
|
|
|
my $base_file = _class_file(shift); |
673
|
|
|
|
|
|
|
my $inc_path = List::Util::first { |
674
|
0
|
|
|
0
|
|
|
-f File::Spec->catfile($_, $base_file) |
675
|
0
|
0
|
|
|
|
|
} @INC or return; |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# Does the file have a subdirectory |
678
|
|
|
|
|
|
|
# i.e. Are there child classes |
679
|
0
|
|
|
|
|
|
my $child_path = substr( $base_file, 0, length($base_file) - 3 ); |
680
|
0
|
|
|
|
|
|
my $child_path_full = File::Spec->catdir( $inc_path, $child_path ); |
681
|
0
|
0
|
0
|
|
|
|
return 0 unless -d $child_path_full and -r _; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# Main scan loop |
684
|
0
|
|
|
|
|
|
local *FILELIST; |
685
|
0
|
|
|
|
|
|
my ($dir, @files, @modules) = (); |
686
|
0
|
|
|
|
|
|
my @queue = ( $child_path ); |
687
|
0
|
|
|
|
|
|
while ( $dir = pop @queue ) { |
688
|
0
|
|
|
|
|
|
my $full_dir = File::Spec->catdir($inc_path, $dir); |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# Read in the raw file list |
691
|
|
|
|
|
|
|
# Skip directories we can't open |
692
|
0
|
0
|
|
|
|
|
opendir( FILELIST, $full_dir ) or next; |
693
|
0
|
|
|
|
|
|
@files = readdir FILELIST; |
694
|
0
|
|
|
|
|
|
closedir FILELIST; |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
# Iterate over them |
697
|
0
|
|
|
|
|
|
@files = map { File::Spec->catfile($dir, $_) } # Full relative path |
698
|
0
|
|
|
|
|
|
grep { ! /^\./ } @files; # Ignore hidden files |
|
0
|
|
|
|
|
|
|
699
|
0
|
|
|
|
|
|
foreach my $file ( @files ) { |
700
|
0
|
|
|
|
|
|
my $full_file = File::Spec->catfile($inc_path, $file); |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# Add to the queue if its a directory we can descend |
703
|
0
|
0
|
0
|
|
|
|
if ( -d $full_file and -r _ ) { |
704
|
0
|
|
|
|
|
|
push @queue, $file; |
705
|
0
|
|
|
|
|
|
next; |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# We only want .pm files we can read |
709
|
0
|
0
|
|
|
|
|
next unless substr( $file, length($file) - 3 ) eq '.pm'; |
710
|
0
|
0
|
|
|
|
|
next unless -f _; |
711
|
|
|
|
|
|
|
|
712
|
0
|
|
|
|
|
|
push @modules, $file; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
# Convert the file names into modules |
717
|
0
|
|
|
|
|
|
map { join '::', File::Spec->splitdir($_) } |
718
|
0
|
|
|
|
|
|
map { substr($_, 0, length($_) - 3) } @modules; |
|
0
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
##################################################################### |
726
|
|
|
|
|
|
|
# Private support methods |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
# Does a class or file exists somewhere in our include path. For |
729
|
|
|
|
|
|
|
# convenience, returns the unresolved file name ( even if passed a class ) |
730
|
|
|
|
|
|
|
sub _file_exists ($) { |
731
|
0
|
|
|
0
|
|
|
_debug(\@_) if DEBUG; |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
# What are we looking for? |
734
|
0
|
0
|
|
|
|
|
my $file = shift or return undef; |
735
|
0
|
0
|
|
|
|
|
return undef if $file =~ m/(?:\012|\015)/o; |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
# If provided a class name, convert it |
738
|
0
|
0
|
|
|
|
|
$file = _class_file($file) if $file =~ /::/o; |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
# Scan @INC for the file |
741
|
0
|
|
|
|
|
|
foreach ( @INC ) { |
742
|
0
|
0
|
|
|
|
|
next if ref $_ eq 'CODE'; |
743
|
0
|
0
|
|
|
|
|
return $file if -f File::Spec->catfile($_, $file); |
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
|
|
|
undef; |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# Is a namespace occupied by anything significant |
750
|
|
|
|
|
|
|
sub _namespace_occupied ($) { |
751
|
|
|
|
|
|
|
_debug(\@_) if DEBUG; |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# Handle the most likely case |
754
|
|
|
|
|
|
|
my $class = shift or return undef; |
755
|
|
|
|
|
|
|
return 1 if defined @{"${class}::ISA"}; |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
# Get the list of glob names, ignoring namespaces |
758
|
|
|
|
|
|
|
foreach ( keys %{"${class}::"} ) { |
759
|
|
|
|
|
|
|
next if substr($_, -2) eq '::'; |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# Only check for methods, since that's all that's reliable |
762
|
|
|
|
|
|
|
if (defined *{"${class}::$_"}{CODE}) { |
763
|
|
|
|
|
|
|
if ($_ eq 'AUTOLOAD' and \&{"${class}::$_"} == \&_AUTOLOAD) { |
764
|
|
|
|
|
|
|
# This is a Class::Autouse hook. Ignore. |
765
|
|
|
|
|
|
|
next; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
else { |
768
|
|
|
|
|
|
|
return 1; |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
} |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
''; |
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# For a given class, get the file name |
777
|
|
|
|
|
|
|
sub _class_file ($) { |
778
|
|
|
|
|
|
|
join( '/', split /(?:\'|::)/, shift ) . '.pm'; |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
# Establish our call depth |
782
|
|
|
|
|
|
|
sub _depth { |
783
|
|
|
|
|
|
|
my $spaces = shift; |
784
|
|
|
|
|
|
|
if ( DEBUG and ! $spaces ) { |
785
|
|
|
|
|
|
|
_debug(\@_); |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
# Search up the caller stack to find the first call that isn't us. |
789
|
|
|
|
|
|
|
my $level = 0; |
790
|
|
|
|
|
|
|
while( $level++ < 1000 ) { |
791
|
|
|
|
|
|
|
my @call = caller($level); |
792
|
|
|
|
|
|
|
if ( @call ) { |
793
|
|
|
|
|
|
|
next if $call[3] eq '(eval)'; |
794
|
|
|
|
|
|
|
next if $call[3] =~ /^Class::Autouse::\w+\z/; |
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
# Subtract 1 for this sub's call |
798
|
|
|
|
|
|
|
$level -= 1; |
799
|
|
|
|
|
|
|
return $spaces ? join( '', (' ') x ($level - 2)) : $level; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
Carp::croak('Infinite loop trying to find call depth'); |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
# Die gracefully |
806
|
|
|
|
|
|
|
sub _cry { |
807
|
|
|
|
|
|
|
_debug() if DEBUG; |
808
|
|
|
|
|
|
|
local $Carp::CarpLevel = $Carp::CarpLevel; |
809
|
|
|
|
|
|
|
$Carp::CarpLevel += _depth(); |
810
|
|
|
|
|
|
|
$_[0] =~ s/\s+at\s+\S+Autouse\.pm line \d+\.$//; |
811
|
|
|
|
|
|
|
Carp::croak($_[0]); |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# Adaptive debug print generation |
815
|
|
|
|
|
|
|
BEGIN { |
816
|
|
|
|
|
|
|
eval <<'END_DEBUG' if DEBUG; |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
sub _debug { |
819
|
|
|
|
|
|
|
my $args = shift; |
820
|
|
|
|
|
|
|
my $method = !! shift; |
821
|
|
|
|
|
|
|
my $message = shift || ''; |
822
|
|
|
|
|
|
|
my @c = caller(1); |
823
|
|
|
|
|
|
|
my $msg = _depth(1) . $c[3]; |
824
|
|
|
|
|
|
|
if ( ref $args ) { |
825
|
|
|
|
|
|
|
my @mapped = map { defined $_ ? "'$_'" : 'undef' } @$args; |
826
|
|
|
|
|
|
|
shift @mapped if $method; |
827
|
|
|
|
|
|
|
$msg .= @mapped ? '( ' . ( join ', ', @mapped ) . ' )' : '()'; |
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
print "$msg$message\n"; |
830
|
|
|
|
|
|
|
} |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
END_DEBUG |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
##################################################################### |
840
|
|
|
|
|
|
|
# Final Initialisation |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
# The _UPDATE_HOOKS function is intended to turn our hijacking of UNIVERSAL::can |
843
|
|
|
|
|
|
|
# on or off, depending on whether we have any live hooks. The idea being, if we |
844
|
|
|
|
|
|
|
# don't have any live hooks, why bother intercepting UNIVERSAL::can calls? |
845
|
|
|
|
|
|
|
sub _UPDATE_HOOKS () { |
846
|
|
|
|
|
|
|
local $^W = 0; |
847
|
|
|
|
|
|
|
*UNIVERSAL::can = $HOOKS ? \&_can : $ORIGINAL_CAN; |
848
|
|
|
|
|
|
|
*UNIVERSAL::isa = $HOOKS ? \&_isa : $ORIGINAL_ISA; |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# The _GLOBAL_HOOKS function turns on the universal autoloader hooks |
852
|
|
|
|
|
|
|
sub _GLOBAL_HOOKS () { |
853
|
|
|
|
|
|
|
return if \&UNIVERSAL::AUTOLOAD == \&_UNIVERSAL_AUTOLOAD; |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# Overwrite UNIVERSAL::AUTOLOAD and catch any |
856
|
|
|
|
|
|
|
# UNIVERSAL::DESTROY calls so they don't trigger |
857
|
|
|
|
|
|
|
# UNIVERSAL::AUTOLOAD. Anyone handling DESTROY calls |
858
|
|
|
|
|
|
|
# via an AUTOLOAD should be summarily shot. |
859
|
|
|
|
|
|
|
*UNIVERSAL::AUTOLOAD = \&_UNIVERSAL_AUTOLOAD; |
860
|
|
|
|
|
|
|
*UNIVERSAL::DESTROY = \&_UNIVERSAL_DESTROY; |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
# Because this will never go away, we increment $HOOKS such |
863
|
|
|
|
|
|
|
# that it will never be decremented, and thus the |
864
|
|
|
|
|
|
|
# UNIVERSAL::can/isa hijack will never be removed. |
865
|
|
|
|
|
|
|
_UPDATE_HOOKS() unless $HOOKS++; |
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
BEGIN { |
869
|
|
|
|
|
|
|
# Optional integration with prefork.pm (if installed) |
870
|
|
|
|
|
|
|
local $@; |
871
|
|
|
|
|
|
|
eval { require prefork }; |
872
|
|
|
|
|
|
|
if ( $@ ) { |
873
|
|
|
|
|
|
|
# prefork is not installed. |
874
|
|
|
|
|
|
|
# Do manual detection of mod_perl |
875
|
|
|
|
|
|
|
$DEVEL = 1 if $ENV{MOD_PERL}; |
876
|
|
|
|
|
|
|
} else { |
877
|
|
|
|
|
|
|
# Go into devel mode when prefork is enabled |
878
|
|
|
|
|
|
|
$LOADED{prefork} = 1; |
879
|
|
|
|
|
|
|
local $@; |
880
|
|
|
|
|
|
|
eval "prefork::notify( sub { Class::Autouse->devel(1) } )"; |
881
|
|
|
|
|
|
|
die $@ if $@; |
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
1; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
__END__ |