line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# (X)Emacs mode: -*- cperl -*- |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Class::MethodMaker::Engine; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Class::MethodMaker::Engine - The parameter passing, method installation & |
8
|
|
|
|
|
|
|
non-data-structure methods of Class::MethodMaker. |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
This class is for internal implementation only. It is not a public API. |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
The non-data-structure methods do form part of the public API, but not called |
15
|
|
|
|
|
|
|
directly: rather, called through the C |
16
|
|
|
|
|
|
|
data-structure methods. |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=cut |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# Pragmas ----------------------------- |
21
|
|
|
|
|
|
|
|
22
|
8
|
|
|
8
|
|
125
|
use 5.006; |
|
8
|
|
|
|
|
23
|
|
|
8
|
|
|
|
|
442
|
|
23
|
8
|
|
|
8
|
|
35
|
use strict; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
292
|
|
24
|
8
|
|
|
8
|
|
36
|
use warnings; |
|
8
|
|
|
|
|
8
|
|
|
8
|
|
|
|
|
234
|
|
25
|
|
|
|
|
|
|
|
26
|
8
|
|
|
8
|
|
48
|
use warnings::register; |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
1577
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# Inheritance ------------------------- |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
our @ISA = qw( AutoLoader ); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Utility ----------------------------- |
33
|
|
|
|
|
|
|
|
34
|
8
|
|
|
8
|
|
4741
|
use AutoLoader qw( AUTOLOAD ); |
|
8
|
|
|
|
|
10818
|
|
|
8
|
|
|
|
|
55
|
|
35
|
8
|
|
|
8
|
|
291
|
use Carp qw( carp croak cluck ); |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
645
|
|
36
|
8
|
|
|
8
|
|
2471
|
use Class::MethodMaker::OptExt qw( OPTEXT ); |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
502
|
|
37
|
8
|
|
|
8
|
|
2956
|
use Class::MethodMaker::V1Compat qw( V1COMPAT ); |
|
8
|
|
|
|
|
12
|
|
|
8
|
|
|
|
|
649
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# ---------------------------------------------------------------------------- |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# CLASS METHODS -------------------------------------------------------------- |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# ------------------------------------- |
44
|
|
|
|
|
|
|
# CLASS CONSTANTS |
45
|
|
|
|
|
|
|
# ------------------------------------- |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# Weird "useless use of a constant in void context" without the ?: |
48
|
8
|
50
|
|
8
|
|
40
|
use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0; |
|
8
|
|
|
|
|
10
|
|
|
8
|
|
|
|
|
789
|
|
49
|
|
|
|
|
|
|
BEGIN { |
50
|
8
|
|
|
8
|
|
6380
|
if ( DEBUG ) { |
51
|
|
|
|
|
|
|
require B::Deparse; |
52
|
|
|
|
|
|
|
require Data::Dumper; |
53
|
|
|
|
|
|
|
Data::Dumper->import('Dumper'); |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# ------------------------------------- |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
our $PACKAGE = 'Class-MethodMaker'; |
60
|
|
|
|
|
|
|
our $VERSION = '2.23'; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# ------------------------------------- |
63
|
|
|
|
|
|
|
# CLASS CONSTRUCTION |
64
|
|
|
|
|
|
|
# ------------------------------------- |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# ------------------------------------- |
67
|
|
|
|
|
|
|
# CLASS COMPONENTS |
68
|
|
|
|
|
|
|
# ------------------------------------- |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# A starter for introspective information |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# For each class, a list of the components installed for that class (as a |
73
|
|
|
|
|
|
|
# hashref from name to hashref. Keys of latter hashref: |
74
|
|
|
|
|
|
|
# 'type' name of component type, e.g., scalar, array, hash |
75
|
|
|
|
|
|
|
# 'assign' name of method to perform assignment. This is used by new with |
76
|
|
|
|
|
|
|
# hash_init. This level of indirection is to cater for the |
77
|
|
|
|
|
|
|
# possibility of an assignment function named other than '*' |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my %class_comps; |
80
|
|
|
|
|
|
|
sub _class_comp_assign { |
81
|
6
|
50
|
|
6
|
|
4452
|
exists $class_comps{$_[1]}->{$_[2]} ? |
82
|
|
|
|
|
|
|
$class_comps{$_[1]}->{$_[2]}->{assign} : undef; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub _class_comp_options { |
86
|
0
|
0
|
|
0
|
|
0
|
exists $class_comps{$_[1]}->{$_[2]} ? |
87
|
|
|
|
|
|
|
$class_comps{$_[1]}->{$_[2]}->{options} : undef; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# ------------------------------------- |
91
|
|
|
|
|
|
|
# CLASS HIGHER-LEVEL FUNCTIONS |
92
|
|
|
|
|
|
|
# ------------------------------------- |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# ------------------------------------- |
95
|
|
|
|
|
|
|
# CLASS HIGHER-LEVEL PROCEDURES |
96
|
|
|
|
|
|
|
# ------------------------------------- |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=head1 The Class::MethodMaker Method Installation Engine |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
Z<> |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=cut |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# ------------------------------------- |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=head2 import |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
This performs argument parsing ready for calling create_methods. In |
109
|
|
|
|
|
|
|
particular, this is the point at which v1 & v2 calls are distinguished. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
This is implicitly called as part of a C |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
use Class::MethodMaker |
114
|
|
|
|
|
|
|
[ scalar => [qw/ foo bar baz /], |
115
|
|
|
|
|
|
|
new => [qw/ new /] , |
116
|
|
|
|
|
|
|
]; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
is equivalent to |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
Class::MethodMaker->import([scalar => [qw/ foo bar baz /], |
121
|
|
|
|
|
|
|
new => [qw/ new /] , |
122
|
|
|
|
|
|
|
]); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
See L for details of this equivalence. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
The methods created are installed into the class calling the import - or more |
127
|
|
|
|
|
|
|
accurately, the first class up the calling stack that is not |
128
|
|
|
|
|
|
|
C or a subclass thereof. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=over 4 |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item SYNOPSIS |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Class::MethodMaker->import([scalar => [+{ -type => 'File::Stat', |
135
|
|
|
|
|
|
|
-forward => [qw/ mode size /], |
136
|
|
|
|
|
|
|
'*_foo' => '*_fig', |
137
|
|
|
|
|
|
|
'*_gop' => undef, |
138
|
|
|
|
|
|
|
'*_bar' => '*_bar', |
139
|
|
|
|
|
|
|
'*_hal' => '*_sal', |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
qw/ -static bob /, |
142
|
|
|
|
|
|
|
] |
143
|
|
|
|
|
|
|
]); |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=back |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=cut |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub import { |
150
|
40
|
|
|
40
|
|
73
|
my $class = shift; |
151
|
40
|
|
|
|
|
107
|
my $target = $class->_find_target_class; |
152
|
|
|
|
|
|
|
|
153
|
40
|
|
|
|
|
50
|
my (@args); |
154
|
40
|
|
|
|
|
42
|
my $mode = 2; |
155
|
|
|
|
|
|
|
|
156
|
40
|
100
|
|
|
|
194
|
return unless @_; |
157
|
|
|
|
|
|
|
|
158
|
38
|
0
|
|
|
|
90
|
if ( @_ == 1 ) { |
159
|
37
|
50
|
|
|
|
135
|
croak "import requires an arrayref" |
160
|
|
|
|
|
|
|
unless UNIVERSAL::isa($_[0], 'ARRAY'); |
161
|
37
|
|
|
|
|
37
|
@args = @{$_[0]}; |
|
37
|
|
|
|
|
87
|
|
162
|
|
|
|
|
|
|
} else { |
163
|
1
|
50
|
|
|
|
3
|
croak("import requires an even number of arguments in v1 compatibility ". |
164
|
|
|
|
|
|
|
"mode") |
165
|
|
|
|
|
|
|
unless @_ % 2 == 0; |
166
|
|
|
|
|
|
|
|
167
|
1
|
|
|
|
|
2
|
@args = @_; |
168
|
|
|
|
|
|
|
# -1 on $#args ensures that no range is generated when $#args is 0. |
169
|
|
|
|
|
|
|
# check above ensures that scalar(@args) is even, so $#args is odd, |
170
|
|
|
|
|
|
|
# so $#args-1 is even and ($#args-1)/2 == int ($#args/2). .. provides an |
171
|
|
|
|
|
|
|
# integer context to its operands. |
172
|
|
|
|
|
|
|
$mode = 1 |
173
|
1
|
|
|
|
|
9
|
for grep exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2; |
174
|
0
|
0
|
|
|
|
0
|
if ( $mode == 1 ) { |
175
|
|
|
|
|
|
|
croak("meta-method type $_ not recognized as a V1 compatibility type\n" . |
176
|
|
|
|
|
|
|
"(cannot mix v1 & v2 options)\n") |
177
|
0
|
|
|
|
|
0
|
for grep ! exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2; |
178
|
|
|
|
|
|
|
} else { |
179
|
0
|
0
|
|
|
|
0
|
croak('meta-method' . (($#args/2>1) ? 's' : '') . ' ' . |
180
|
|
|
|
|
|
|
join(', ', map qq'"$args[$_*2]"', 0..($#args-1)/2) . |
181
|
|
|
|
|
|
|
" found in v1 compatibility mode, but not recognized as v1.\n" . |
182
|
|
|
|
|
|
|
"please update to v2, presenting your arguments to use/import\n" . |
183
|
|
|
|
|
|
|
"as a single arrayref (wrap them with [...])\n"); |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
0
|
0
|
|
|
|
0
|
if ( $mode == 1 ) { |
188
|
0
|
|
|
|
|
0
|
$class->parse_v1_options($target, \@args); |
189
|
|
|
|
|
|
|
} else { |
190
|
0
|
|
|
|
|
0
|
$class->parse_options($target, \@args); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
# ------------------------------------- |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=head2 parse_options |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
Parse the arguments given to import and call L |
199
|
|
|
|
|
|
|
appropriately. See main text for options syntax. |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
=over 4 |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
=item SYNOPSIS |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
Class::MethodMaker->parse_options('TargetClass', |
206
|
|
|
|
|
|
|
[scalar => |
207
|
|
|
|
|
|
|
[{ -type => 'File::stat', |
208
|
|
|
|
|
|
|
-forward => [qw/ mode |
209
|
|
|
|
|
|
|
size /], |
210
|
|
|
|
|
|
|
'*_foo' => '*_fig', |
211
|
|
|
|
|
|
|
'*_gop' => undef, |
212
|
|
|
|
|
|
|
'*_bar' => '*_bar', |
213
|
|
|
|
|
|
|
'*_hal' => '*_sal', |
214
|
|
|
|
|
|
|
}, |
215
|
|
|
|
|
|
|
qw( -static bob ), |
216
|
|
|
|
|
|
|
]])}, |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
Class::MethodMaker->parse_options('TargetClass2', |
219
|
|
|
|
|
|
|
[scalar => |
220
|
|
|
|
|
|
|
['baz', |
221
|
|
|
|
|
|
|
{ -type => 'File::stat', |
222
|
|
|
|
|
|
|
-forward => [qw/ mode |
223
|
|
|
|
|
|
|
size /], |
224
|
|
|
|
|
|
|
'*_foo' => '*_fog', |
225
|
|
|
|
|
|
|
'*_bar' => '*_bar', |
226
|
|
|
|
|
|
|
'*_hal' => '*_sal', |
227
|
|
|
|
|
|
|
}, |
228
|
|
|
|
|
|
|
qw( -static bob ), |
229
|
|
|
|
|
|
|
]], |
230
|
|
|
|
|
|
|
+{ -type => 'Math::BigInt', }, |
231
|
|
|
|
|
|
|
+{'*_foo' => '*_fig', |
232
|
|
|
|
|
|
|
'*_gop' => undef,}, |
233
|
|
|
|
|
|
|
)}, |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=item ARGUMENTS |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
=over 4 |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=item target_class |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
The class into which to install components |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=item args |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
The arguments to parse, as a single arrayref. |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=item options |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
A hashref of options to apply to all components created by this call (subject |
252
|
|
|
|
|
|
|
to overriding by explicit option calls). |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=item renames |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
A hashref of renames to apply to all components created by this call (subject |
257
|
|
|
|
|
|
|
to overriding by explicit rename calls). |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=back |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=back |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=cut |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub parse_options { |
266
|
0
|
|
|
39
|
1
|
0
|
my $class = shift; |
267
|
0
|
|
|
|
|
0
|
my ($target_class, $args, $options, $renames) = @_; |
268
|
|
|
|
|
|
|
|
269
|
0
|
|
|
|
|
0
|
print STDERR ("Parsing Options: ", |
270
|
|
|
|
|
|
|
Data::Dumper->Dump([$args, $options, $renames], |
271
|
|
|
|
|
|
|
[qw( args options renames )])) |
272
|
|
|
|
|
|
|
if DEBUG; |
273
|
|
|
|
|
|
|
|
274
|
0
|
|
|
|
|
0
|
my (%options, %renames); |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# It is important that components are created in the specified order, so |
277
|
|
|
|
|
|
|
# that e.g., forwarding works as expected (lest the forward method applies |
278
|
|
|
|
|
|
|
# to the wrong component). |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
0
|
for (my $i = 0; $i < @$args; $i++) { |
281
|
0
|
0
|
|
|
|
0
|
if ( ! ref $args->[$i] ) { |
282
|
0
|
|
|
|
|
0
|
my $type = $args->[$i]; |
283
|
|
|
|
|
|
|
|
284
|
0
|
0
|
|
|
|
0
|
if ( substr($type, 0, 1) eq '-' ) { |
285
|
0
|
|
|
|
|
0
|
my $option = substr($type, 1); |
286
|
0
|
0
|
|
|
|
0
|
if ( $option eq 'target_class' ) { |
287
|
0
|
0
|
|
|
|
0
|
croak "No argument found for -target_class\n" |
288
|
|
|
|
|
|
|
if $i == $#$args; |
289
|
0
|
|
|
|
|
0
|
$target_class = $args->[++$i]; |
290
|
0
|
0
|
|
|
|
0
|
croak "-target_class takes a simple scalar argument\n" |
291
|
|
|
|
|
|
|
if ref $target_class; |
292
|
|
|
|
|
|
|
} else { |
293
|
0
|
|
|
|
|
0
|
croak "Unrecognized option: $type\n"; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
} else { |
296
|
|
|
|
|
|
|
# Reset options, renames to input global settings |
297
|
0
|
0
|
|
|
|
0
|
%options = defined $options ? %$options : (); |
298
|
0
|
0
|
|
|
|
0
|
%renames = defined $renames ? %$renames : (); |
299
|
0
|
|
|
|
|
0
|
my $created = 0; |
300
|
0
|
0
|
|
|
|
0
|
croak("No arguments found for $type while creating methods for ", |
301
|
|
|
|
|
|
|
$target_class, "\n") |
302
|
|
|
|
|
|
|
if $i == $#$args; |
303
|
0
|
|
|
|
|
0
|
my $opts = $args->[++$i]; |
304
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa($opts, 'SCALAR') ) { |
|
|
0
|
|
|
|
|
|
305
|
0
|
|
|
|
|
0
|
$class->create_methods ($target_class, $type, $opts, |
306
|
|
|
|
|
|
|
\%options, \%renames); |
307
|
0
|
|
|
|
|
0
|
$created = 1; |
308
|
|
|
|
|
|
|
} elsif ( UNIVERSAL::isa($opts, 'ARRAY') ) { |
309
|
0
|
|
|
|
|
0
|
for (@$opts) { |
310
|
0
|
0
|
|
|
|
0
|
if ( ! ref $_ ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
311
|
0
|
0
|
|
|
|
0
|
if ( $_ =~ /^[A-Za-z_][0-9A-Za-z_]*$/ ) { |
|
|
0
|
|
|
|
|
|
312
|
0
|
|
|
|
|
0
|
$class->create_methods ($target_class, $type, $_, |
313
|
|
|
|
|
|
|
\%options, \%renames); |
314
|
0
|
|
|
|
|
0
|
$created = 1; |
315
|
|
|
|
|
|
|
} elsif ( $_ =~ /^([-!])([0-9A-Za-z_]+)$/ ) { |
316
|
0
|
0
|
|
|
|
0
|
$options{$2} = ($1 eq '!' ? 0 : 1); |
317
|
|
|
|
|
|
|
} else { |
318
|
0
|
|
|
|
|
0
|
croak "Argument $_ for type $type not understood\n"; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} elsif ( UNIVERSAL::isa($_, 'HASH') ) { |
321
|
0
|
|
|
|
|
0
|
while ( my ($k, $v) = each %$_ ) { |
322
|
8
|
0
|
|
8
|
|
4588
|
if ( index($k, '*') > $[-1 ) { |
|
8
|
|
|
|
|
2830
|
|
|
8
|
|
|
|
|
6610
|
|
|
0
|
|
|
|
|
0
|
|
323
|
0
|
|
|
|
|
0
|
$renames{$k} = $v; |
324
|
|
|
|
|
|
|
} else { |
325
|
0
|
|
|
|
|
0
|
$k =~ s/^-//; |
326
|
0
|
|
|
|
|
0
|
$options{$k} = $v; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
} elsif ( UNIVERSAL::isa($_, 'ARRAY') ) { |
330
|
0
|
|
|
|
|
0
|
$class->parse_options($target_class, [$type, $_], |
331
|
|
|
|
|
|
|
\%options, \%renames); |
332
|
|
|
|
|
|
|
} else { |
333
|
0
|
|
|
|
|
0
|
croak("Argument type " . ref($_) . |
334
|
|
|
|
|
|
|
" to type $type not handled\n"); |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
} else { |
338
|
0
|
|
|
|
|
0
|
$class->create_methods ($target_class, $type, $opts, |
339
|
|
|
|
|
|
|
$options, $renames); |
340
|
0
|
|
|
|
|
0
|
$created = 1; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
0
|
0
|
|
|
|
0
|
warnif("No attributes found for type $type\n") |
344
|
|
|
|
|
|
|
unless $created; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
} else { |
347
|
0
|
|
|
|
|
0
|
croak "Argument not handled: ", $args->[$i], "\n"; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
0
|
|
|
|
|
0
|
return; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# ------------------------------------- |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# V1 compatibility is purposely not documented. |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub parse_v1_options { |
359
|
0
|
|
|
0
|
0
|
0
|
my $class = shift; |
360
|
0
|
|
|
|
|
0
|
my ($target_class, $args) = @_; |
361
|
|
|
|
|
|
|
|
362
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (1) : ", Data::Dumper->Dump([$args], |
363
|
|
|
|
|
|
|
[qw( args )]) |
364
|
|
|
|
|
|
|
if DEBUG; |
365
|
|
|
|
|
|
|
|
366
|
0
|
|
|
|
|
0
|
while (my ($v1type, $names) = splice @$args, 0, 2 ) { |
367
|
0
|
|
|
|
|
0
|
my %options = (v1_compat => 1); |
368
|
|
|
|
|
|
|
|
369
|
0
|
0
|
|
|
|
0
|
croak("No argument found for $v1type while creating methods for ", |
370
|
|
|
|
|
|
|
$target_class, "\n") |
371
|
|
|
|
|
|
|
unless defined $names; |
372
|
|
|
|
|
|
|
|
373
|
0
|
|
|
|
|
0
|
my $v2type = $v1type; |
374
|
|
|
|
|
|
|
|
375
|
0
|
|
|
|
|
0
|
my ($rename, $opt_handler, $rephrase); |
376
|
0
|
0
|
|
|
|
0
|
if ( exists V1COMPAT->{$v1type} ) { |
377
|
0
|
|
|
|
|
0
|
my $v1compat = V1COMPAT->{$v1type}; |
378
|
0
|
0
|
|
|
|
0
|
$v2type = $v1compat->{v2name} |
379
|
|
|
|
|
|
|
if exists $v1compat->{v2name}; |
380
|
0
|
|
|
|
|
0
|
($rename, $opt_handler, $rephrase) = |
381
|
0
|
|
|
|
|
0
|
@{$v1compat}{qw(rename option rephrase)}; |
382
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (2) : ", |
383
|
|
|
|
|
|
|
Data::Dumper->Dump([$v1type, $v2type, $v1compat, |
384
|
|
|
|
|
|
|
$rename, $opt_handler, $rephrase,], |
385
|
|
|
|
|
|
|
[qw(v1type v2type v1compat |
386
|
|
|
|
|
|
|
rename opt_handler rephrase)]) |
387
|
|
|
|
|
|
|
if DEBUG; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (3) : ", |
391
|
|
|
|
|
|
|
Data::Dumper->Dump([$names],[qw(inames)]) |
392
|
|
|
|
|
|
|
if DEBUG; |
393
|
0
|
0
|
|
|
|
0
|
if ( defined $rephrase ) { |
394
|
0
|
|
|
|
|
0
|
$names = $rephrase->($names); |
395
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (3.5) : ", |
396
|
|
|
|
|
|
|
Data::Dumper->Dump([$names],[qw(rephrased)]) |
397
|
|
|
|
|
|
|
if DEBUG; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# warnif("Class::MethodMaker V1 compatibility mode enabled for $type\n"); |
401
|
|
|
|
|
|
|
|
402
|
0
|
0
|
|
|
|
0
|
my @names = UNIVERSAL::isa($names, 'ARRAY') ? @$names : $names; |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
0
|
for (@names) { |
405
|
0
|
0
|
0
|
|
|
0
|
if ( ref($_) or substr($_, 0, 1) eq '-' ) { |
406
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (4) : ", |
407
|
|
|
|
|
|
|
Data::Dumper->Dump([\%options, $_],[qw(options name)]) |
408
|
|
|
|
|
|
|
if DEBUG; |
409
|
0
|
0
|
|
|
|
0
|
if ( defined $opt_handler ) { |
410
|
0
|
|
|
|
|
0
|
$opt_handler->($v1type, $_, $rename, \%options, $target_class); |
411
|
|
|
|
|
|
|
} else { |
412
|
0
|
|
|
|
|
0
|
croak "Options not handled for v1 type $v1type\n"; |
413
|
|
|
|
|
|
|
} |
414
|
0
|
|
|
|
|
0
|
print STDERR "V1 Parser (4.5) : ", |
415
|
|
|
|
|
|
|
Data::Dumper->Dump([\%options],[qw(options)]) |
416
|
|
|
|
|
|
|
if DEBUG; |
417
|
|
|
|
|
|
|
} else { |
418
|
0
|
|
|
|
|
0
|
$class->create_methods($target_class, $v2type, $_, |
419
|
|
|
|
|
|
|
\%options, $rename); |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# ------------------------------------- |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
=head2 create_methods |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
Add methods to a class. Methods for multiple components may be added this |
430
|
|
|
|
|
|
|
way, but create_methods handles only one set of options. |
431
|
|
|
|
|
|
|
L is responsible for sorting which options to |
432
|
|
|
|
|
|
|
apply to which components, and calling create_methods appropriately. |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=over 4 |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=item SYNOPSIS |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
Class::MethodMaker->create_methods($target_class, |
439
|
|
|
|
|
|
|
scalar => bob, |
440
|
|
|
|
|
|
|
+{ static => 1, |
441
|
|
|
|
|
|
|
type => 'File::Stat', |
442
|
|
|
|
|
|
|
forward => [qw/ mode size /], }, |
443
|
|
|
|
|
|
|
+{ '*_foo' => '*_fig', |
444
|
|
|
|
|
|
|
'*_gop' => undef, |
445
|
|
|
|
|
|
|
'*_bar' => '*_bar', |
446
|
|
|
|
|
|
|
'*_hal' => '*_sal', } |
447
|
|
|
|
|
|
|
); |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
=item ARGUMENTS |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
=over 4 |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=item targetclass |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
The class to add methods to. |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
=item type |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
The basic data structure to use for the component, e.g., C. |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=item compname |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
Component name. The name must be a valid identifier, i.e., a continuous |
464
|
|
|
|
|
|
|
non-empty string of word (C<\w>) characters, of which the first may not be a |
465
|
|
|
|
|
|
|
digit. |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
=item options |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
A hashref. Some options (C, C, C, C) are |
470
|
|
|
|
|
|
|
handled by the auto-extender. These will be invoked if the name is present as |
471
|
|
|
|
|
|
|
a key and the value is true. Any other options are passed through to the |
472
|
|
|
|
|
|
|
method in question. The options should be named as-is; no leading hyphen |
473
|
|
|
|
|
|
|
should be applied (i.e., use C<< {static => 1} >> not C<< {-static => 1} >>). |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=item renames |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
A list of customer renames. It is a hashref from method name to rename. The |
478
|
|
|
|
|
|
|
method name is the generic name (i.e., featuring a C<*> to replace with the |
479
|
|
|
|
|
|
|
component name). The rename is the value to rename with. It may itself |
480
|
|
|
|
|
|
|
contain a C<*> to replace with the component name. If rename is undef, the |
481
|
|
|
|
|
|
|
method is I installed. For methods that would not be installed by default, use a rename value that is the same as the method name. |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
So, if a type would normally install methods |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
'*_foo', '*_gop', '*_tom' |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
and optionally installs (but not by default) |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
'*_bar', '*_wiz', '*_hal' |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
using a renames value of |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
{ '*_foo' => '*_fig', |
494
|
|
|
|
|
|
|
'*_gop' => undef, |
495
|
|
|
|
|
|
|
'*_bar' => '*_bar', |
496
|
|
|
|
|
|
|
'*_hal' => '*_sal', |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
with a component name of C, then C<*_foo> is installed as C, |
500
|
|
|
|
|
|
|
C<*_bar> is installed as C, C<*_wiz> is not installed, C<*_hal> is |
501
|
|
|
|
|
|
|
installed as C, C<*_gop> is not installed, and C<*_tom> is installed |
502
|
|
|
|
|
|
|
as C. |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
The value may actually be an arrayref, in which case the function may be |
505
|
|
|
|
|
|
|
called by any of the multiple names specified. |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
=back |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
=back |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
=cut |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# This is the bit that does the actual creation. For options-handling |
514
|
|
|
|
|
|
|
# excitement, see import. |
515
|
|
|
|
|
|
|
sub create_methods { |
516
|
0
|
|
|
60
|
1
|
0
|
my $class = shift; |
517
|
0
|
|
|
|
|
0
|
my ($targetclass, $type, $compname, $options, $renames) = @_; |
518
|
|
|
|
|
|
|
|
519
|
0
|
0
|
|
|
|
0
|
if ( exists $class_comps{$targetclass}->{$compname} ) { |
520
|
0
|
|
|
|
|
0
|
croak("The component '$compname' has already been installed in class " . |
521
|
|
|
|
|
|
|
"-->$targetclass<-- as a $class_comps{$targetclass}->{$compname}\n" . |
522
|
|
|
|
|
|
|
" (this time a $type)\n"); |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
0
|
|
|
|
|
0
|
print STDERR "Create methods (1) : ", |
526
|
|
|
|
|
|
|
Data::Dumper->Dump |
527
|
|
|
|
|
|
|
([ $type, $compname, $options, $renames], |
528
|
|
|
|
|
|
|
[qw(type compname options renames)] |
529
|
|
|
|
|
|
|
) |
530
|
|
|
|
|
|
|
if DEBUG; |
531
|
|
|
|
|
|
|
|
532
|
0
|
0
|
|
|
|
0
|
my (%options) = defined $options ? %$options : (); |
533
|
0
|
0
|
0
|
|
|
0
|
if ( exists $options{type} and substr($options{type}, 0, 1) eq '+' ) { |
534
|
0
|
|
|
|
|
0
|
$options{typex} = substr(delete $options{type}, 1); |
535
|
8
|
|
0
|
8
|
|
50
|
my $coerce = sub { no warnings 'numeric'; int($_[1]||0) }; |
|
8
|
|
|
20
|
|
9
|
|
|
8
|
|
|
|
|
9878
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
536
|
0
|
|
|
|
|
0
|
for my $optname (qw( store_cb read_cb )) { |
537
|
0
|
0
|
|
|
|
0
|
if ( exists $options{$optname} ) { |
538
|
0
|
0
|
|
|
|
0
|
$options{$optname} = [$options{$optname}] |
539
|
|
|
|
|
|
|
unless ref($options{$optname}) eq 'ARRAY'; |
540
|
0
|
|
|
|
|
0
|
push @{$options{$optname}}, $coerce; |
|
0
|
|
|
|
|
0
|
|
541
|
|
|
|
|
|
|
} else { |
542
|
0
|
|
|
|
|
0
|
$options{$optname} = $coerce; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
} |
546
|
0
|
0
|
|
|
|
0
|
croak("Illegal attribute name -->$compname<--" . |
547
|
|
|
|
|
|
|
" (must be a legal perl identifier)\n") |
548
|
|
|
|
|
|
|
unless $compname =~ /^(?!\d)\w+$/; |
549
|
|
|
|
|
|
|
|
550
|
0
|
|
|
|
|
0
|
my ($opts, $creator); |
551
|
|
|
|
|
|
|
# Some options are handled by the cmmg.pl auto-extender. |
552
|
|
|
|
|
|
|
# Find the method-name extension & options this represents |
553
|
0
|
|
|
|
|
0
|
(my ($ext), $opts) = |
554
|
|
|
|
|
|
|
Class::MethodMaker::OptExt->encode($type, |
555
|
|
|
|
|
|
|
[grep $options{$_}, keys %options]); |
556
|
0
|
0
|
|
|
|
0
|
croak "Illegal combination of options: ", join(',', keys %options), "\n" |
557
|
|
|
|
|
|
|
if ( ! defined $ext ); |
558
|
0
|
0
|
|
|
|
0
|
$creator = length $ext ? join('', substr($type, 0, 4), $ext) : $type; |
559
|
0
|
|
|
|
|
0
|
my $create_class = $class; |
560
|
0
|
50
|
|
|
|
0
|
if ( length $ext ) { |
561
|
0
|
|
|
|
|
0
|
require "Class/MethodMaker/${type}.pm"; |
562
|
0
|
|
|
|
|
0
|
$create_class = "Class::MethodMaker::${type}"; |
563
|
|
|
|
|
|
|
} |
564
|
0
|
|
|
|
|
0
|
print STDERR "Create methods (2) : ", |
565
|
|
|
|
|
|
|
Data::Dumper->Dump |
566
|
|
|
|
|
|
|
([ $create_class, $creator, $ext, $opts], |
567
|
|
|
|
|
|
|
[qw( create_class creator ext opts)] |
568
|
|
|
|
|
|
|
) |
569
|
|
|
|
|
|
|
if DEBUG; |
570
|
0
|
|
|
|
|
0
|
my ($methods, $names); |
571
|
|
|
|
|
|
|
|
572
|
0
|
|
|
|
|
0
|
eval { |
573
|
0
|
|
|
|
|
0
|
($methods, $names) = |
574
|
|
|
|
|
|
|
$create_class->$creator($targetclass, $compname, \%options); |
575
|
0
|
50
|
|
|
|
0
|
}; if ( $@ ) { |
576
|
0
|
100
|
|
|
|
0
|
if ( $@ =~ m"^Can't locate auto/Class/MethodMaker/(\S*)" ) { |
577
|
0
|
|
|
|
|
0
|
my $message = "Couldn't find meta-method for type $type"; |
578
|
0
|
50
|
|
|
|
0
|
$message .= " with options -->" . join(', ', @$opts) . "<--" |
579
|
|
|
|
|
|
|
if @$opts; |
580
|
0
|
|
|
|
|
0
|
croak("$message ($creator [$create_class])\n"); |
581
|
|
|
|
|
|
|
} else { |
582
|
0
|
|
|
|
|
0
|
die $@; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
0
|
|
|
|
|
0
|
print STDERR "Create methods (3) : ", |
587
|
|
|
|
|
|
|
Data::Dumper->Dump([$methods, $names], [qw(methods names)]) |
588
|
|
|
|
|
|
|
if DEBUG; |
589
|
|
|
|
|
|
|
|
590
|
0
|
50
|
|
|
|
0
|
my $assign_name = exists $names->{'='} ? delete $names->{'='} : '*'; |
591
|
|
|
|
|
|
|
|
592
|
0
|
50
|
|
|
|
0
|
if ( defined $names ) { |
593
|
|
|
|
|
|
|
croak "Names value for key $_ should not be defined ($names->{$_})\n" |
594
|
0
|
|
|
|
|
0
|
for grep defined $names->{$_}, keys %$names; |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
1
|
|
|
|
|
3
|
my %methods; |
598
|
|
|
|
|
|
|
my %realname; |
599
|
|
|
|
|
|
|
METHNAME: |
600
|
0
|
|
|
|
|
0
|
while ( my ($methname, $code) = each %$methods ) { |
601
|
|
|
|
|
|
|
# If a method's raw name is preceded by a '!', don't install it unless |
602
|
|
|
|
|
|
|
# explicitly requested (exists in customer renames) |
603
|
1
|
|
|
|
|
202
|
print STDERR "CREATE: Considering method $methname\n" |
604
|
|
|
|
|
|
|
if DEBUG; |
605
|
|
|
|
|
|
|
|
606
|
37
|
100
|
|
|
|
92
|
if ( index($methname, ':') > -1 ) { |
607
|
|
|
|
|
|
|
# Some typed method. Only install if the appropriate type is specified. |
608
|
0
|
|
|
|
|
0
|
$methname =~ s/(\w+)://; |
609
|
37
|
|
|
|
|
126
|
my $type = $1; |
610
|
|
|
|
|
|
|
next METHNAME |
611
|
39
|
50
|
0
|
|
|
51
|
unless exists $options{typex} and $type eq $options{typex}; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
39
|
100
|
0
|
|
|
58
|
unless ( substr($methname, 0, 1) eq '!' and |
615
|
|
|
|
|
|
|
! exists $renames->{substr($methname, 1)} ) { |
616
|
39
|
|
|
|
|
31
|
$methname =~ s/^!//; |
617
|
39
|
100
|
|
|
|
47
|
my $realname = exists $renames->{$methname} ? |
618
|
|
|
|
|
|
|
$renames->{$methname} : |
619
|
|
|
|
|
|
|
$methname; |
620
|
|
|
|
|
|
|
# If the subr is required (because it's used by other subrs of the |
621
|
|
|
|
|
|
|
# attribute) but isn't wanted by the user (renamed to undef), sneak it |
622
|
|
|
|
|
|
|
# into the symbol table prefixed by a space, so it's not normally |
623
|
|
|
|
|
|
|
# accessible. |
624
|
39
|
50
|
0
|
|
|
109
|
if ( ! defined $realname and exists $names->{$methname} ) { |
625
|
45
|
|
|
|
|
82
|
$realname = " $methname"; |
626
|
|
|
|
|
|
|
} |
627
|
45
|
|
|
|
|
60
|
print STDERR ("CREATE: Using realname ", |
628
|
|
|
|
|
|
|
(defined $realname ? |
629
|
|
|
|
|
|
|
(ref $realname ? |
630
|
|
|
|
|
|
|
"[" . join (',', map "'$_'", @$realname) . "]" : |
631
|
|
|
|
|
|
|
"'$realname'") : |
632
|
|
|
|
|
|
|
'*undef*' |
633
|
|
|
|
|
|
|
), |
634
|
|
|
|
|
|
|
"\n") |
635
|
|
|
|
|
|
|
if DEBUG; |
636
|
45
|
50
|
|
|
|
127
|
if ( defined $realname ) { |
637
|
2
|
100
|
|
|
|
2
|
for my $rn (ref $realname ? @$realname : $realname) { |
638
|
2
|
|
|
|
|
3
|
my $copy = $rn; # Copy to avoid clobbering the original array |
639
|
2
|
|
|
|
|
4
|
$copy =~ s/\*/$compname/g; |
640
|
2
|
|
|
|
|
3
|
print STDERR "CREATE: Installing $copy\n" |
641
|
|
|
|
|
|
|
if DEBUG; |
642
|
2
|
|
|
|
|
5
|
$methods{$copy} = $code; |
643
|
0
|
100
|
|
|
|
0
|
$names->{$methname} = $copy |
644
|
|
|
|
|
|
|
if defined $names; |
645
|
|
|
|
|
|
|
# It's okay if this gets assigned multiple times (because $realname |
646
|
|
|
|
|
|
|
# is an arrayref); each assignment gives it a valid name, we care |
647
|
|
|
|
|
|
|
# not which is used. |
648
|
43
|
|
|
|
|
96
|
$realname{$methname} = $copy; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
} else { |
651
|
43
|
|
|
|
|
85
|
$realname{$methname} = undef; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
|
656
|
43
|
|
|
|
|
56
|
print STDERR "Create methods (4) : ", |
657
|
|
|
|
|
|
|
Data::Dumper->Dump([\%methods, \%realname], [qw(*methods *realname)]) |
658
|
|
|
|
|
|
|
if DEBUG; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# Now, I want some installed methods to be able to call some others. |
661
|
|
|
|
|
|
|
# However, I also want to be able to rename methods on the fly to the |
662
|
|
|
|
|
|
|
# users' specification. |
663
|
|
|
|
|
|
|
# I can't pass a set of renames into the component creator without the |
664
|
|
|
|
|
|
|
# caller knowing the set of names for the component to rename --- only the |
665
|
|
|
|
|
|
|
# component knows the names of the methods to create, and they may be |
666
|
|
|
|
|
|
|
# affected by arguments. I don't want to duplicate that knowledge elsewhere. |
667
|
|
|
|
|
|
|
# I can't have the methods call each other via names in the symbol table, |
668
|
|
|
|
|
|
|
# lest the method called gets renamed. |
669
|
|
|
|
|
|
|
# If we have the sub called directly (without the symbol table), we get |
670
|
|
|
|
|
|
|
# burnt when users replace the method (expecting it to get called) |
671
|
|
|
|
|
|
|
# or override it from a subclass. |
672
|
|
|
|
|
|
|
# If we don't call methods from one to another, but instead 'inline' the |
673
|
|
|
|
|
|
|
# relevant code, then we're liable to introduce more bugs (esp. as updates |
674
|
|
|
|
|
|
|
# are made) in addition to the same problem set as calling the methods |
675
|
|
|
|
|
|
|
# without the symbol table. Therefore, we have the 'names' hash, |
676
|
|
|
|
|
|
|
# returned above. This hash specifies a set of methods to be installed |
677
|
|
|
|
|
|
|
# whatever (i.e., even if they're not visible to the user), so that they |
678
|
|
|
|
|
|
|
# may be called by other methods. The hash keys are the default name of |
679
|
|
|
|
|
|
|
# the method, the values are set (by this subroutine, 'create_methods') to |
680
|
|
|
|
|
|
|
# the actual code, whatever name it gets installed as. |
681
|
43
|
|
|
|
|
101
|
$class->install_methods($targetclass, \%methods); |
682
|
|
|
|
|
|
|
|
683
|
43
|
|
|
|
|
59
|
$class_comps{$targetclass}->{$compname} = |
684
|
|
|
|
|
|
|
+{ type => $type , |
685
|
|
|
|
|
|
|
assign => $realname{$assign_name}, |
686
|
|
|
|
|
|
|
options => \%options, |
687
|
|
|
|
|
|
|
}; |
688
|
|
|
|
|
|
|
|
689
|
43
|
|
|
|
|
179
|
return; |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
# ------------------------------------- |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# Find the class to add the methods to. I'm assuming that it would be the |
695
|
|
|
|
|
|
|
# first class in the caller() stack that's not a subclass of MethodMaker. If |
696
|
|
|
|
|
|
|
# you want something more sophisticated implement it --- and call |
697
|
|
|
|
|
|
|
# create_methods, specifying exactly the target class. If you can think of a |
698
|
|
|
|
|
|
|
# better way of determining the target class, let me know! |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
sub _find_target_class { |
701
|
0
|
|
|
40
|
|
0
|
my $class = shift; |
702
|
|
|
|
|
|
|
|
703
|
0
|
|
|
|
|
0
|
my $target; |
704
|
40
|
|
|
|
|
71
|
my $i = 0; |
705
|
|
|
|
|
|
|
do { |
706
|
68
|
|
|
|
|
286
|
$target = (caller($i))[0]; |
707
|
57
|
|
|
|
|
158
|
$i++; |
708
|
|
|
|
|
|
|
} while ( ( $target->isa('Class::MethodMaker::Engine') |
709
|
|
|
|
|
|
|
or |
710
|
|
|
|
|
|
|
$target->isa('Class::MethodMaker') ) and |
711
|
|
|
|
|
|
|
# This is "supported" for v1 compatibility only. Direct calling |
712
|
|
|
|
|
|
|
# of create_methods is the preferred way of using |
713
|
|
|
|
|
|
|
# Class::MethodMaker to build C::MM subclasses |
714
|
|
|
|
|
|
|
(! $target->can ('ima_method_maker') or |
715
|
|
|
|
|
|
|
( warnif("Class::MethodMaker::ima_method_maker deprecated\n"), |
716
|
102
|
|
0
|
|
|
264
|
&{$target->can ('ima_method_maker')} ) |
|
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
717
|
|
|
|
|
|
|
) |
718
|
|
|
|
|
|
|
); |
719
|
|
|
|
|
|
|
|
720
|
57
|
|
|
|
|
158
|
return $target; |
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
# ------------------------------------- |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
=head2 install_methods |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
=over 4 |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=item SYNOPSIS |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
Class::MethodMaker->install_methods |
732
|
|
|
|
|
|
|
($classname, { incr => sub { $i++ }, |
733
|
|
|
|
|
|
|
decr => sub { $i-- }, |
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
); |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
=item ARGUMENTS |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
=over 4 |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=item target |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
The class into which the methods are to be installed |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=item methods |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
The methods to install, as a hashref. Keys are the method names; values are |
748
|
|
|
|
|
|
|
the methods themselves, as code refs. |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=back |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
=back |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
=cut |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
sub install_methods { |
757
|
11
|
|
|
60
|
1
|
45
|
my $class = shift; |
758
|
0
|
|
|
|
|
0
|
my ($target, $methods) = @_; |
759
|
|
|
|
|
|
|
|
760
|
32
|
|
|
|
|
147
|
while ( my ($name, $code) = each %$methods ) { |
761
|
57
|
|
|
|
|
279
|
if ( DEBUG ) { |
762
|
|
|
|
|
|
|
print STDERR "Installing method '$name' into $target\n"; |
763
|
|
|
|
|
|
|
eval { |
764
|
|
|
|
|
|
|
my @opts = qw( -sC -i2); |
765
|
|
|
|
|
|
|
push @opts, '-l' |
766
|
|
|
|
|
|
|
if DEBUG > 1; |
767
|
|
|
|
|
|
|
print STDERR |
768
|
|
|
|
|
|
|
B::Deparse->new(@opts)->coderef2text($code), "\n"; |
769
|
|
|
|
|
|
|
}; if ($@) { |
770
|
|
|
|
|
|
|
print STDERR "Couldn't deparse '$name': $@\n"; |
771
|
|
|
|
|
|
|
} |
772
|
|
|
|
|
|
|
} |
773
|
3
|
|
|
|
|
12
|
my $reftype = ref $code; |
774
|
54
|
50
|
|
|
|
179
|
if ( $reftype eq 'CODE' ) { |
775
|
54
|
|
|
|
|
248
|
my $methname = join '::', $target, $name; |
776
|
8
|
|
|
8
|
|
47
|
no strict 'refs'; |
|
8
|
|
|
|
|
10
|
|
|
8
|
|
|
|
|
1958
|
|
777
|
2
|
100
|
|
|
|
17
|
if ( ! defined *{$methname}{CODE} ) { |
|
0
|
|
|
|
|
0
|
|
778
|
3
|
|
|
|
|
8
|
*{$methname} = $code; |
|
3
|
|
|
|
|
5
|
|
779
|
|
|
|
|
|
|
# Generate a unique stash name for the sub. Use a preceding space |
780
|
|
|
|
|
|
|
# to avoid collisions with anything in the Perl space. |
781
|
43
|
100
|
|
|
|
210
|
croak "Could not create stash name for '$name'" |
782
|
|
|
|
|
|
|
unless Class::MethodMaker::set_sub_name($code, $target, $name, "${target}::${name}"); |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
} else { |
785
|
0
|
|
|
|
|
0
|
croak "What do you expect me to do with this?: $code\n"; |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
} |
788
|
|
|
|
|
|
|
} |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
# ------------------------------------- |
791
|
|
|
|
|
|
|
# CLASS UTILITY FUNCTIONS |
792
|
|
|
|
|
|
|
# ------------------------------------- |
793
|
|
|
|
|
|
|
|
794
|
39
|
|
|
0
|
0
|
32752
|
sub warnif { warnings::warnif (@_) }; |
795
|
|
|
|
|
|
|
# sub warnif { warnings::warn (@_) if (warnings::enabled()) }; |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub check_opts { |
798
|
0
|
|
|
37
|
0
|
0
|
my ($known_opts, $options) = @_; |
799
|
|
|
|
|
|
|
|
800
|
0
|
50
|
|
|
|
0
|
$known_opts = +{ map {;$_=>1} @$known_opts } |
|
0
|
|
|
|
|
0
|
|
801
|
|
|
|
|
|
|
if ref $known_opts eq 'ARRAY'; |
802
|
|
|
|
|
|
|
|
803
|
0
|
50
|
|
|
|
0
|
if ( my @bad_opt = grep ! exists $known_opts->{$_}, keys %$options ) { |
804
|
0
|
100
|
|
|
|
0
|
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); |
805
|
0
|
|
|
|
|
0
|
croak("$prefix not recognized for attribute type scalar: ", |
806
|
|
|
|
|
|
|
join(', ', @bad_opt), "\n"); |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
# ------------------------------------- |
811
|
|
|
|
|
|
|
# META-METHODS |
812
|
|
|
|
|
|
|
# ------------------------------------- |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
1; # keep require happy |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
__END__ |