line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# This module is part of DA, Don Armstrong's Modules, and is released |
2
|
|
|
|
|
|
|
# under the terms of the GPL version 2, or any later version. See the |
3
|
|
|
|
|
|
|
# file README and COPYING for more information. |
4
|
|
|
|
|
|
|
# Copyright 2003,2005 by Don Armstrong . |
5
|
|
|
|
|
|
|
# $Id: Modular.pm 45 2006-11-17 22:30:15Z don $ |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package Class::Modular; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 NAME |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
Class::Modular -- Modular class generation superclass |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 SYNOPSIS |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
package Foo; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
use base qw(Class::Modular); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
use vars (@METHODS); |
20
|
|
|
|
|
|
|
BEGIN{@METHODS=qw(blah)}; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub blah{ |
23
|
|
|
|
|
|
|
my $self = shift; |
24
|
|
|
|
|
|
|
return 1; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
[...] |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
package Bar; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub method_that_bar_provides{ |
32
|
|
|
|
|
|
|
print qq(Hello World!\n); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub _methods($$){ |
36
|
|
|
|
|
|
|
return qw(method_that_bar_provides); |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
[...] |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
use Foo; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$foo = new Foo; |
44
|
|
|
|
|
|
|
$foo->load('Bar'); |
45
|
|
|
|
|
|
|
$foo->blah && $foo->method_that_bar_provides; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=head1 DESCRIPTION |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
Class::Modular is a superclass for generating modular classes, where |
51
|
|
|
|
|
|
|
methods can be added into the class from the perspective of the |
52
|
|
|
|
|
|
|
object, rather than the perspective of the class. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
That is, you can create a class which has a set of generic common |
55
|
|
|
|
|
|
|
functions. Less generic functions can be included or overridden |
56
|
|
|
|
|
|
|
without modifying the base classes. This allows for code to be more |
57
|
|
|
|
|
|
|
modular, and reduces code duplication. |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
This module attempts to fill the middle ground between |
60
|
|
|
|
|
|
|
L and true classless OOP, like L. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head1 FUNCTIONS |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=cut |
65
|
|
|
|
|
|
|
|
66
|
1
|
|
|
1
|
|
52766
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
54
|
|
67
|
1
|
|
|
1
|
|
6
|
use vars qw($VERSION $DEBUG $REVISION $USE_SAFE); |
|
1
|
|
|
|
|
17
|
|
|
1
|
|
|
|
|
91
|
|
68
|
|
|
|
|
|
|
|
69
|
1
|
|
|
1
|
|
7
|
use Carp; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
112
|
|
70
|
|
|
|
|
|
|
|
71
|
1
|
|
|
1
|
|
40976
|
use Storable qw(dclone); # Used for deep copying objects |
|
1
|
|
|
|
|
9055
|
|
|
1
|
|
|
|
|
109
|
|
72
|
1
|
|
|
1
|
|
2705
|
use Safe; # Use Safe when we are dealing with coderefs |
|
1
|
|
|
|
|
65725
|
|
|
1
|
|
|
|
|
23
|
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
BEGIN{ |
75
|
1
|
|
|
1
|
|
183
|
$VERSION = q$0.05$; |
76
|
1
|
|
|
|
|
3
|
($REVISION) = q$LastChangedRevision: 45 $ =~ /\$LastChangedRevision:\s+([^\s+])/; |
77
|
1
|
50
|
|
|
|
6
|
$DEBUG = 0 unless defined $DEBUG; |
78
|
1
|
50
|
|
|
|
114
|
$USE_SAFE = 1 unless defined $USE_SAFE; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# This is the class_modular namespace, so we don't muck up the |
82
|
|
|
|
|
|
|
# subclass(es) by accident. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
my $cm = q(__class_modular); |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
our $AUTOLOAD; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head2 load |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
$cm->load('Subclass'); |
92
|
|
|
|
|
|
|
# or |
93
|
|
|
|
|
|
|
$cm->load('Subclass',$options); |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
Loads the named Subclass into this object if the named Subclass has |
96
|
|
|
|
|
|
|
not been loaded. |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
If debugging is enabled, will warn about loading already loaded |
99
|
|
|
|
|
|
|
subclasses. Use C<$cm->is_loaded('Subclass')> to avoid these warnings. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=head3 Methods |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
If the subclass has a C<_methods> function (or at least, |
104
|
|
|
|
|
|
|
UNIVERSAL::can thinks it does), C<_methods> is called to return a LIST |
105
|
|
|
|
|
|
|
of methods that the subclass wishes to handle. The L |
106
|
|
|
|
|
|
|
object and the options SCALAR are passed to the _methods function. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
If the subclass does not have a C<_methods> function, then the array |
109
|
|
|
|
|
|
|
C<@{"${subclass}::METHODS"}> is used to determine the methods that the |
110
|
|
|
|
|
|
|
subclass will handle. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=head3 _init and required submodules |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
If the subclass has a C<_init> function (or at least, UNIVERSAL::can |
115
|
|
|
|
|
|
|
thinks it does), C<_init> is called right after the module is |
116
|
|
|
|
|
|
|
loaded. The L object and the options SCALAR are passed |
117
|
|
|
|
|
|
|
to the _methods function. Typical uses for this call are to load other |
118
|
|
|
|
|
|
|
required submodules. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
As this is the most common thing to do in C<_init>, if a subclass |
121
|
|
|
|
|
|
|
doesn't have one, then the array C<@{"${subclass}::SUB_MODULES"}> is |
122
|
|
|
|
|
|
|
used to determine the subclass that need to be loaded: |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
for my $module (@{"${subclass}::SUB_MODULES"}) { |
125
|
|
|
|
|
|
|
$self->is_loaded($module) || $self->load($module); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=cut |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub load($$;$) { |
131
|
1
|
|
|
1
|
1
|
3
|
my ($self,$subclass,$options) = @_; |
132
|
|
|
|
|
|
|
|
133
|
1
|
|
50
|
|
|
7
|
$options ||= {}; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# check to see if the subclass has already been loaded. |
136
|
|
|
|
|
|
|
|
137
|
1
|
50
|
|
|
|
39
|
if (not defined $self->{$cm}{_subclasses}{$subclass}){ |
138
|
1
|
|
|
|
|
3
|
eval { |
139
|
1
|
|
|
1
|
|
13
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
43
|
|
140
|
|
|
|
|
|
|
# Yeah, I don't care if calling an inherited AUTOLOAD |
141
|
|
|
|
|
|
|
# for a non method is deprecated. Bite me. |
142
|
1
|
|
|
1
|
|
8
|
no warnings 'deprecated'; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
602
|
|
143
|
1
|
50
|
|
|
|
69
|
eval "require $subclass" or die $@; |
144
|
|
|
|
|
|
|
# We should read @METHODS and @SUB_MODULES and just do |
145
|
|
|
|
|
|
|
# the right thing if at all possible. |
146
|
1
|
|
|
|
|
7
|
my $methods = can($subclass,"_methods"); |
147
|
1
|
50
|
|
|
|
4
|
if (defined $methods) { |
148
|
0
|
|
|
|
|
0
|
$self->_addmethods($subclass,&$methods($self,$options)); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
else { |
151
|
1
|
|
|
|
|
1
|
$self->_addmethods($subclass,@{"${subclass}::METHODS"}) |
|
1
|
|
|
|
|
37
|
|
152
|
|
|
|
|
|
|
} |
153
|
1
|
|
|
|
|
5
|
my $init = can($subclass,"_init"); |
154
|
1
|
50
|
|
|
|
4
|
if (defined $init) { |
155
|
1
|
|
|
|
|
3
|
&$init($self,$options); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
else { |
158
|
0
|
|
|
|
|
0
|
for my $module (@{"${subclass}::SUB_MODULES"}) { |
|
0
|
|
|
|
|
0
|
|
159
|
0
|
0
|
|
|
|
0
|
$self->is_loaded($module) || $self->load($module); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
}; |
163
|
1
|
50
|
|
|
|
4
|
die $@ if $@; |
164
|
1
|
|
50
|
|
|
7
|
$self->{$cm}{_subclasses}{$subclass} ||= {}; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
else { |
167
|
0
|
0
|
|
|
|
0
|
carp "Not reloading subclass $subclass" if $DEBUG; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=head2 is_loaded |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
if ($cm->is_loaded('Subclass')) { |
174
|
|
|
|
|
|
|
# do something |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
Tests to see if the named subclass is loaded. |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
Returns 1 if the subclass has been loaded, 0 otherwise. |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=cut |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub is_loaded($$){ |
184
|
1
|
|
|
1
|
1
|
276
|
my ($self,$subclass) = @_; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# An entry will exist in the _subclasses hashref only if |
187
|
1
|
50
|
33
|
|
|
12
|
return 1 if exists $self->{$cm}{_subclasses}{$subclass} |
188
|
|
|
|
|
|
|
and defined $self->{$cm}{_subclasses}{$subclass}; |
189
|
0
|
|
|
|
|
0
|
return 0; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=head2 override |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
$obj->override('methodname', $code_ref) |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
Allows you to override utility functions that are called internally to |
197
|
|
|
|
|
|
|
provide a different default function. It's superficially similar to |
198
|
|
|
|
|
|
|
_addmethods, which is called by load, but it deals with code |
199
|
|
|
|
|
|
|
references, and requires the method name to be known. |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
Methods overridden here are _NOT_ overrideable in _addmethods. This |
202
|
|
|
|
|
|
|
may need to be changed. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
=cut |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub override { |
207
|
1
|
|
|
1
|
1
|
224
|
my ($self, $method_name, $function_reference) = @_; |
208
|
|
|
|
|
|
|
|
209
|
1
|
|
|
|
|
3
|
$self->{$cm}{_methodhash}{$method_name}{reference} = $function_reference; |
210
|
1
|
|
|
|
|
5
|
$self->{$cm}{_methodhash}{$method_name}{overridden} = 1; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=head2 clone |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
my $clone = $obj->clone |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
Produces a clone of the object with duplicates of all data and/or new |
219
|
|
|
|
|
|
|
connections as appropriate. |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
Calls _clone on all loaded subclasses. |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
Warns if debugging is on for classes which don't have a _clone method. |
224
|
|
|
|
|
|
|
Dies on other errors. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
clone uses L to allow L to deparse code references |
227
|
|
|
|
|
|
|
sanely. Set C<$Class::Modular::USE_SAFE = 0> to disable this. [Doing |
228
|
|
|
|
|
|
|
this may cause errors from Storable about CODE references.] |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=cut |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub clone { |
233
|
1
|
|
|
1
|
1
|
3
|
my ($self) = @_; |
234
|
|
|
|
|
|
|
|
235
|
1
|
|
|
|
|
2
|
my $clone = {}; |
236
|
1
|
|
|
|
|
3
|
bless $clone, ref($self); |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# copy data structures at this level |
239
|
1
|
50
|
|
|
|
5
|
if ($self->{$cm}{use_safe}) { |
240
|
1
|
|
|
|
|
9
|
my $safe = new Safe; |
241
|
1
|
|
|
|
|
1390
|
$safe->permit(qw(:default require)); |
242
|
1
|
|
|
|
|
11
|
local $Storable::Deparse = 1; |
243
|
1
|
|
|
1
|
|
6
|
local $Storable::Eval = sub { $safe->reval($_[0]) }; |
|
1
|
|
|
|
|
9
|
|
244
|
1
|
|
|
1
|
|
11
|
$clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash}); |
|
1
|
|
|
|
|
41
|
|
|
1
|
|
|
|
|
982
|
|
|
1
|
|
|
|
|
344
|
|
245
|
0
|
|
|
|
|
0
|
$clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses}); |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
else { |
248
|
0
|
|
|
|
|
0
|
$clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash}); |
249
|
0
|
|
|
|
|
0
|
$clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses}); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
0
|
|
|
|
|
0
|
foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) { |
|
0
|
|
|
|
|
0
|
|
253
|
|
|
|
|
|
|
# Find out if the subclass has a clone method. |
254
|
|
|
|
|
|
|
# If it does, call it, die on errors. |
255
|
0
|
|
|
|
|
0
|
my $function = UNIVERSAL::can($subclass, '_clone'); |
256
|
0
|
|
|
|
|
0
|
eval { |
257
|
1
|
|
|
1
|
|
8
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
31
|
|
258
|
|
|
|
|
|
|
# No, I could care less that AUTOLOAD is |
259
|
|
|
|
|
|
|
# deprecated. Eat me. |
260
|
1
|
|
|
1
|
|
5
|
no warnings 'deprecated'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
506
|
|
261
|
0
|
|
|
|
|
0
|
&{"${subclass}::_clone"}($self,$clone); |
|
0
|
|
|
|
|
0
|
|
262
|
|
|
|
|
|
|
}; |
263
|
0
|
0
|
|
|
|
0
|
if ($@) { |
264
|
|
|
|
|
|
|
# Die unless we've hit an undefined subroutine. |
265
|
0
|
0
|
|
|
|
0
|
if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){ |
266
|
0
|
|
|
|
|
0
|
die "Failed while trying to clone: $@"; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
else { |
269
|
0
|
0
|
|
|
|
0
|
carp "No _clone method defined for $subclass" if $DEBUG; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
=head2 can |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
$obj->can('METHOD'); |
279
|
|
|
|
|
|
|
Class::Modular->can('METHOD'); |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Replaces UNIVERSAL's can method so that handled methods are reported |
282
|
|
|
|
|
|
|
correctly. Calls UNIVERSAL::can in the places where we don't know |
283
|
|
|
|
|
|
|
anything it doesn't. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
Returns a coderef to the method if the method is supported, undef |
286
|
|
|
|
|
|
|
otherwise. |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=cut |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub can{ |
291
|
3
|
|
|
3
|
1
|
218
|
my ($self,$method,$vars) = @_; |
292
|
|
|
|
|
|
|
|
293
|
3
|
50
|
|
|
|
10
|
croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method; |
294
|
|
|
|
|
|
|
|
295
|
3
|
100
|
66
|
|
|
16
|
if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) { |
296
|
|
|
|
|
|
|
# If the method is defined, return a reference to the |
297
|
|
|
|
|
|
|
# method. |
298
|
1
|
|
|
|
|
8
|
return $self->{$cm}{_methodhash}{$method}{reference}; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
else { |
301
|
|
|
|
|
|
|
# Otherwise, let UNIVERSAL::can deal with the method |
302
|
|
|
|
|
|
|
# appropriately. |
303
|
2
|
|
|
|
|
17
|
return UNIVERSAL::can($self,$method); |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
=head2 isa |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
$obj->isa('TYPE'); |
310
|
|
|
|
|
|
|
Class::Modular->isa('TYPE'); |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
Replaces UNIVERSAL's isa method with one that knows which modules have |
313
|
|
|
|
|
|
|
been loaded into this object. Calls C with the type passed, |
314
|
|
|
|
|
|
|
then calls UNIVERSAL::isa if the type isn't loaded. |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
=cut |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub isa{ |
319
|
0
|
|
|
0
|
1
|
0
|
my ($self,$type) = @_; |
320
|
|
|
|
|
|
|
|
321
|
0
|
0
|
|
|
|
0
|
croak "Usage: isa(object-ref, type);\n" if not defined $type; |
322
|
|
|
|
|
|
|
|
323
|
0
|
|
0
|
|
|
0
|
return $self->is_loaded($type) || UNIVERSAL::isa($self,$type); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=head2 handledby |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
$obj->handledby('methodname'); |
331
|
|
|
|
|
|
|
$obj->handledby('Class::Method::methodname'); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
Returns the subclass that handles the method methodname. |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
=cut |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub handledby{ |
338
|
0
|
|
|
0
|
1
|
0
|
my ($self,$method_name) = @_; |
339
|
|
|
|
|
|
|
|
340
|
0
|
|
|
|
|
0
|
$method_name =~ s/.*\://; |
341
|
|
|
|
|
|
|
|
342
|
0
|
0
|
|
|
|
0
|
if (exists $self->{$cm}{_methodhash}{$method_name}) { |
343
|
0
|
|
|
|
|
0
|
return $self->{$cm}{_methodhash}{$method_name}{subclass}; |
344
|
|
|
|
|
|
|
} |
345
|
0
|
|
|
|
|
0
|
return undef; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
=head2 new |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
$obj = Foo::Bar->new(qw(baz quux)); |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
Creates a new Foo::Bar object |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
Aditional arguments can be passed to this creator, and they are stored |
356
|
|
|
|
|
|
|
in $self->{creation_args} (and $self->{$cm}{creation_args} by |
357
|
|
|
|
|
|
|
_init. |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
This new function creates an object of Class::Modular, and calls the |
360
|
|
|
|
|
|
|
C<$self->load(Foo::Bar)>, which will typically do what you want. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
If you override this method in your subclasses, you will not be able |
363
|
|
|
|
|
|
|
to use override to override methods defined within those |
364
|
|
|
|
|
|
|
subclasses. This may or may not be a feature. You must also call |
365
|
|
|
|
|
|
|
C<$self->SUPER::_init(@_)> if you override new. |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
=cut |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub new { |
370
|
1
|
|
|
1
|
1
|
625
|
my ($class,@args) = @_; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# We shouldn't be called $me->new, but just in case |
373
|
1
|
|
33
|
|
|
9
|
$class = ref($class) || $class; |
374
|
|
|
|
|
|
|
|
375
|
1
|
|
|
|
|
2
|
my $self = {}; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# But why, Don, are you being evil and not using the two argument |
378
|
|
|
|
|
|
|
# bless properly? |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
# My child, we always want to go to Class::Modular first, |
381
|
|
|
|
|
|
|
# otherwise we will be unable to override methods in subclasses. |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# But doesn't this mean that subclasses won't be able to override |
384
|
|
|
|
|
|
|
# us? |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Only if they don't also override new! |
387
|
|
|
|
|
|
|
|
388
|
1
|
|
|
|
|
3
|
bless $self, 'Class::Modular'; |
389
|
|
|
|
|
|
|
|
390
|
1
|
|
|
|
|
5
|
$self->_init(@args); |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# Now we call our subclass's load routine so that our evil deeds |
393
|
|
|
|
|
|
|
# are masked |
394
|
|
|
|
|
|
|
|
395
|
1
|
|
|
|
|
6
|
$self->load($class); |
396
|
|
|
|
|
|
|
|
397
|
1
|
|
|
|
|
10
|
return $self; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
=head1 FUNCTIONS YOU PROBABLY DON'T CARE ABOUT |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=head2 DESTROY |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
undef $foo; |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
Calls all subclass _destroy methods. |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
Subclasses need only implement a _destroy method if they have |
410
|
|
|
|
|
|
|
references that need to be uncircularized, or things that should be |
411
|
|
|
|
|
|
|
disconnected or closed. |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
=cut |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
sub DESTROY{ |
416
|
1
|
|
|
1
|
|
785
|
my $self = shift; |
417
|
1
|
|
|
|
|
3
|
foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) { |
|
1
|
|
|
|
|
125
|
|
418
|
|
|
|
|
|
|
# use eval to try and call the subclasses _destroy method. |
419
|
|
|
|
|
|
|
# Ignore no such function errors, but trap other types of |
420
|
|
|
|
|
|
|
# errors. |
421
|
0
|
|
|
|
|
0
|
eval { |
422
|
1
|
|
|
1
|
|
7
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
423
|
|
|
|
|
|
|
# Shove off, deprecated AUTOLOAD warning! |
424
|
1
|
|
|
1
|
|
6
|
no warnings 'deprecated'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
2993
|
|
425
|
0
|
|
|
|
|
0
|
&{"${subclass}::_destroy"}($self); |
|
0
|
|
|
|
|
0
|
|
426
|
|
|
|
|
|
|
}; |
427
|
0
|
0
|
|
|
|
0
|
if ($@) { |
428
|
0
|
0
|
|
|
|
0
|
if ($@ !~ /^Undefined (function|subroutine) \&?${subclass}::_destroy (|called )at [^\n]*$/){ |
429
|
0
|
|
|
|
|
0
|
die "Failed while trying to destroy: $@"; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
else { |
432
|
0
|
0
|
|
|
|
0
|
carp "No _destroy method defined for $subclass" if $DEBUG; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
=head2 AUTOLOAD |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
The AUTOLOAD function is responsible for calling child methods which |
442
|
|
|
|
|
|
|
have been installed into the current Class::Modular handle. |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
Subclasses that have a new function as well as an AUTOLOAD function |
445
|
|
|
|
|
|
|
must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
$Class::Modular::AUTOLOAD = $AUTOLOAD; |
448
|
|
|
|
|
|
|
goto &Class::Modular::AUTOLOAD; |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
Failure to do the above will break Class::Modular utterly. |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
=cut |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
sub AUTOLOAD{ |
455
|
2
|
|
|
2
|
|
7
|
my $method = $AUTOLOAD; |
456
|
|
|
|
|
|
|
|
457
|
2
|
|
|
|
|
8
|
$method =~ s/.*\://; |
458
|
|
|
|
|
|
|
|
459
|
2
|
|
|
|
|
4
|
my ($self) = @_; |
460
|
|
|
|
|
|
|
|
461
|
2
|
50
|
|
|
|
7
|
if (not ref($self)) { |
462
|
0
|
|
|
|
|
0
|
carp "Not a reference in AUTOLOAD."; |
463
|
0
|
|
|
|
|
0
|
return; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
2
|
50
|
33
|
|
|
16
|
if (exists $self->{$cm}{_methodhash}{$method} and |
467
|
|
|
|
|
|
|
defined $self->{$cm}{_methodhash}{$method}{reference}) { |
468
|
|
|
|
|
|
|
{ |
469
|
2
|
|
|
|
|
2
|
my $method = \&{$self->{$cm}{_methodhash}{$method}{reference}}; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
7
|
|
470
|
2
|
|
|
|
|
8
|
goto &$method; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
else { |
474
|
0
|
|
|
|
|
0
|
croak "Undefined function $AUTOLOAD"; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
=head2 _init |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
$self->_init(@args); |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
Stores the arguments used at new so modules that are loaded later can |
483
|
|
|
|
|
|
|
read them from B |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
You can also override this method, but if you do so, you should call |
486
|
|
|
|
|
|
|
Class::Modular::_init($self,@_) if you don't set creation_args. |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=cut |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
sub _init { |
491
|
2
|
|
|
2
|
|
5
|
my ($self,@creation_args) = @_; |
492
|
|
|
|
|
|
|
|
493
|
2
|
|
|
|
|
4
|
my $creation_args = [@_]; |
494
|
2
|
100
|
|
|
|
12
|
$self->{creation_args} = $creation_args if not exists $self->{creation_args}; |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# Make another reference to this, so we can get it if a subclass |
497
|
|
|
|
|
|
|
# overwrites it, or if it was already set for some reason |
498
|
2
|
|
|
|
|
67
|
$self->{$cm}->{creation_args} = $creation_args; |
499
|
2
|
|
|
|
|
7
|
$self->{$cm}->{use_safe} = $USE_SAFE; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
=head2 _addmethods |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
$self->_addmethods() |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
Given an array of methods, adds the methods into the _methodhash |
508
|
|
|
|
|
|
|
calling table. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
Methods that have previously been overridden by override are _NOT_ |
511
|
|
|
|
|
|
|
overridden again. This may need to be adjusted in load. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
=cut |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub _addmethods($@) { |
516
|
1
|
|
|
1
|
|
4
|
my ($self,$subclass,@methods) = @_; |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
# stick the method into the table |
519
|
|
|
|
|
|
|
# DLA: Make with the munchies! |
520
|
|
|
|
|
|
|
|
521
|
1
|
|
|
|
|
3
|
foreach my $method (@methods) { |
522
|
1
|
50
|
|
|
|
23
|
if (not $method =~ /^$subclass/) { |
523
|
1
|
|
|
|
|
3
|
$method = $subclass.'::'.$method; |
524
|
|
|
|
|
|
|
} |
525
|
1
|
|
|
|
|
9
|
my ($method_name) = $method =~ /\:*([^\:]+)\s*$/; |
526
|
1
|
50
|
|
|
|
41
|
if (exists $self->{$cm}{_methodhash}{$method_name}) { |
527
|
0
|
0
|
|
|
|
0
|
if ($self->{$cm}{_methodhash}{$method_name}{overridden}) { |
528
|
0
|
0
|
|
|
|
0
|
carp "Not overriding already overriden method $method_name\n" if $DEBUG; |
529
|
0
|
|
|
|
|
0
|
next; |
530
|
|
|
|
|
|
|
} |
531
|
0
|
|
|
|
|
0
|
carp "Overriding $method_name $self->{$cm}{_methodhash}{$method_name}{reference} with $method\n"; |
532
|
|
|
|
|
|
|
} |
533
|
1
|
|
|
|
|
6
|
$self->{$cm}{_methodhash}{$method_name}{reference} = $method; |
534
|
1
|
|
|
|
|
5
|
$self->{$cm}{_methodhash}{$method_name}{subclass} = $subclass; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
1; |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
__END__ |