line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Class::Generate; |
2
|
|
|
|
|
|
|
$Class::Generate::VERSION = '1.18'; |
3
|
22
|
|
|
22
|
|
109648
|
use 5.010; |
|
22
|
|
|
|
|
3244
|
|
4
|
22
|
|
|
20
|
|
539
|
use strict; |
|
20
|
|
|
|
|
547
|
|
|
20
|
|
|
|
|
1081
|
|
5
|
20
|
|
|
17
|
|
526
|
use Carp; |
|
17
|
|
|
|
|
53
|
|
|
17
|
|
|
|
|
1197
|
|
6
|
17
|
|
|
18
|
|
222
|
use warnings::register; |
|
18
|
|
|
|
|
73
|
|
|
18
|
|
|
|
|
2320
|
|
7
|
18
|
|
|
21
|
|
6666
|
use Symbol qw(&delete_package); |
|
21
|
|
|
|
|
9741
|
|
|
21
|
|
|
|
|
1553
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
BEGIN |
10
|
|
|
|
|
|
|
{ |
11
|
21
|
|
|
21
|
|
601
|
use vars qw(@ISA @EXPORT_OK); |
|
21
|
|
|
|
|
88
|
|
|
21
|
|
|
|
|
661
|
|
12
|
|
|
|
|
|
|
use vars |
13
|
21
|
|
|
17
|
|
926
|
qw($save $accept_refs $strict $allow_redefine $class_var $instance_var $check_params $check_code $check_default $nfi $warnings); |
|
17
|
|
|
|
|
61
|
|
|
17
|
|
|
|
|
1735
|
|
14
|
|
|
|
|
|
|
|
15
|
17
|
|
|
17
|
|
842
|
require Exporter; |
16
|
17
|
|
|
|
|
231
|
@ISA = qw(Exporter); |
17
|
17
|
|
|
|
|
89
|
@EXPORT_OK = ( |
18
|
|
|
|
|
|
|
qw(&class &subclass &delete_class), |
19
|
|
|
|
|
|
|
qw($save $accept_refs $strict $allow_redefine $class_var $instance_var $check_params $check_code $check_default $nfi $warnings) |
20
|
|
|
|
|
|
|
); |
21
|
|
|
|
|
|
|
|
22
|
17
|
|
|
|
|
3506
|
$accept_refs = 1; |
23
|
15
|
|
|
|
|
55
|
$strict = 1; |
24
|
15
|
|
|
|
|
29
|
$allow_redefine = 0; |
25
|
15
|
|
|
|
|
163
|
$class_var = 'class'; |
26
|
15
|
|
|
|
|
34
|
$instance_var = 'self'; |
27
|
15
|
|
|
|
|
26
|
$check_params = 1; |
28
|
15
|
|
|
|
|
416
|
$check_code = 1; |
29
|
15
|
|
|
|
|
40
|
$check_default = 1; |
30
|
15
|
|
|
|
|
23
|
$nfi = 0; |
31
|
15
|
|
|
|
|
1806
|
$warnings = 1; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
15
|
|
|
15
|
|
103
|
use vars qw(@_initial_values); # Holds all initial values passed as references. |
|
15
|
|
|
|
|
27
|
|
|
15
|
|
|
|
|
61741
|
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
my ( $class_name, $class ); |
37
|
|
|
|
|
|
|
my ( |
38
|
|
|
|
|
|
|
$class_vars, $use_packages, $excluded_methods, |
39
|
|
|
|
|
|
|
$param_style_spec, $default_pss |
40
|
|
|
|
|
|
|
); |
41
|
|
|
|
|
|
|
my %class_options; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my $cm; # These variables are for error messages. |
44
|
|
|
|
|
|
|
my $sa_needed = 'must be string or array reference'; |
45
|
|
|
|
|
|
|
my $sh_needed = 'must be string or hash reference'; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
my $allow_redefine_for_class; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my ( |
50
|
|
|
|
|
|
|
$initialize, # These variables all hold |
51
|
|
|
|
|
|
|
$parse_any_flags, # references to package-local |
52
|
|
|
|
|
|
|
$set_class_type, # subs that other packages |
53
|
|
|
|
|
|
|
$parse_class_specification, # shouldn't call. |
54
|
|
|
|
|
|
|
$parse_method_specification, |
55
|
|
|
|
|
|
|
$parse_member_specification, |
56
|
|
|
|
|
|
|
$set_attributes, |
57
|
|
|
|
|
|
|
$class_defined, |
58
|
|
|
|
|
|
|
$process_class, |
59
|
|
|
|
|
|
|
$store_initial_value_reference, |
60
|
|
|
|
|
|
|
$check_for_invalid_parameter_names, |
61
|
|
|
|
|
|
|
$constructor_parameter_passing_style, |
62
|
|
|
|
|
|
|
$verify_class_type, |
63
|
|
|
|
|
|
|
$croak_if_duplicate_names, |
64
|
|
|
|
|
|
|
$invalid_spec_message |
65
|
|
|
|
|
|
|
); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my %valid_option = |
68
|
|
|
|
|
|
|
map( substr( $_, 0, 1 ) eq '$' ? ( substr( $_, 1 ) => 1 ) : (), |
69
|
|
|
|
|
|
|
@EXPORT_OK ); |
70
|
|
|
|
|
|
|
my %class_to_ref_map = ( |
71
|
|
|
|
|
|
|
'Class::Generate::Array_Class' => 'ARRAY', |
72
|
|
|
|
|
|
|
'Class::Generate::Hash_Class' => 'HASH' |
73
|
|
|
|
|
|
|
); |
74
|
|
|
|
|
|
|
my %warnings_keys = map( ( $_ => 1 ), qw(use no register) ); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub class(%) |
77
|
|
|
|
|
|
|
{ # One of the three interface |
78
|
54
|
|
|
54
|
1
|
1902
|
my %params = @_; # routines to the package. |
79
|
54
|
100
|
|
|
|
211
|
if ( defined $params{-parent} ) |
80
|
|
|
|
|
|
|
{ # Defines a class or a |
81
|
7
|
|
|
|
|
54
|
subclass(@_); # subclass. |
82
|
7
|
|
|
|
|
31
|
return; |
83
|
|
|
|
|
|
|
} |
84
|
48
|
|
|
|
|
166
|
&$initialize(); |
85
|
48
|
|
|
|
|
259
|
&$parse_any_flags( \%params ); |
86
|
48
|
50
|
|
|
|
202
|
croak "Missing/extra arguments to class()" if scalar( keys %params ) != 1; |
87
|
48
|
|
|
|
|
133
|
( $class_name, undef ) = %params; |
88
|
48
|
|
|
|
|
345
|
$cm = qq|Class "$class_name"|; |
89
|
47
|
|
|
|
|
180
|
&$verify_class_type( $params{$class_name} ); |
90
|
47
|
50
|
33
|
|
|
202
|
croak "$cm: A package of this name already exists" |
91
|
|
|
|
|
|
|
if !$allow_redefine_for_class && &$class_defined($class_name); |
92
|
47
|
|
|
|
|
211
|
&$set_class_type( $params{$class_name} ); |
93
|
47
|
|
|
|
|
139
|
&$process_class( $params{$class_name} ); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub subclass(%) |
97
|
|
|
|
|
|
|
{ # One of the three interface |
98
|
15
|
|
|
16
|
1
|
235
|
my %params = @_; # routines to the package. |
99
|
15
|
|
|
|
|
64
|
&$initialize(); # Defines a subclass. |
100
|
15
|
|
|
|
|
30
|
my ( $p_spec, $parent ); |
101
|
15
|
50
|
|
|
|
55
|
if ( defined( $p_spec = $params{-parent} ) ) |
102
|
|
|
|
|
|
|
{ |
103
|
15
|
|
|
|
|
34
|
delete $params{-parent}; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
else |
106
|
|
|
|
|
|
|
{ |
107
|
0
|
|
|
|
|
0
|
croak "Missing subclass parent"; |
108
|
|
|
|
|
|
|
} |
109
|
15
|
|
|
|
|
26
|
eval { $parent = Class::Generate::Array->new($p_spec) }; |
|
15
|
|
|
|
|
46
|
|
110
|
15
|
50
|
33
|
|
|
66
|
croak qq|Invalid parent specification ($sa_needed)| |
111
|
|
|
|
|
|
|
if $@ || scalar( $parent->values ) == 0; |
112
|
15
|
|
|
|
|
50
|
&$parse_any_flags( \%params ); |
113
|
15
|
50
|
|
|
|
43
|
croak "Missing/extra arguments to subclass()" |
114
|
|
|
|
|
|
|
if scalar( keys %params ) != 1; |
115
|
15
|
|
|
|
|
40
|
( $class_name, undef ) = %params; |
116
|
15
|
|
|
|
|
61
|
$cm = qq|Subclass "$class_name"|; |
117
|
15
|
|
|
|
|
47
|
&$verify_class_type( $params{$class_name} ); |
118
|
15
|
50
|
33
|
|
|
83
|
croak "$cm: A package of this name already exists" |
119
|
|
|
|
|
|
|
if !$allow_redefine_for_class && &$class_defined($class_name); |
120
|
|
|
|
|
|
|
my $assumed_type = |
121
|
15
|
100
|
|
|
|
78
|
UNIVERSAL::isa( $params{$class_name}, 'ARRAY' ) ? 'ARRAY' : 'HASH'; |
122
|
15
|
|
|
|
|
44
|
my $child_type = lc($assumed_type); |
123
|
|
|
|
|
|
|
|
124
|
15
|
|
|
|
|
45
|
for my $p ( $parent->values ) |
125
|
|
|
|
|
|
|
{ |
126
|
15
|
|
|
|
|
46
|
my $c = Class::Generate::Class_Holder::get( $p, $assumed_type ); |
127
|
15
|
50
|
|
|
|
42
|
croak qq|$cm: Parent package "$p" does not exist| if !defined $c; |
128
|
15
|
|
|
|
|
49
|
my $parent_type = lc( $class_to_ref_map{ ref $c } ); |
129
|
|
|
|
|
|
|
croak |
130
|
|
|
|
|
|
|
"$cm: $child_type-based class must have $child_type-based parent ($p is $parent_type-based)" |
131
|
|
|
|
|
|
|
if !UNIVERSAL::isa( $params{$class_name}, |
132
|
15
|
50
|
|
|
|
54
|
$class_to_ref_map{ ref $c } ); |
133
|
15
|
50
|
33
|
|
|
1983
|
warnings::warn( |
134
|
|
|
|
|
|
|
qq{$cm: Parent class "$p" was not defined using class() or subclass(); $child_type reference assumed} |
135
|
|
|
|
|
|
|
) if warnings::enabled() && eval "! exists \$" . $p . '::{_cginfo}'; |
136
|
|
|
|
|
|
|
} |
137
|
15
|
|
|
|
|
67
|
&$set_class_type( $params{$class_name}, $parent ); |
138
|
15
|
|
|
|
|
40
|
for my $p ( $parent->values ) |
139
|
|
|
|
|
|
|
{ |
140
|
15
|
|
|
|
|
40
|
$class->add_parents( Class::Generate::Class_Holder::get($p) ); |
141
|
|
|
|
|
|
|
} |
142
|
15
|
|
|
|
|
46
|
&$process_class( $params{$class_name} ); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub delete_class(@) |
146
|
|
|
|
|
|
|
{ # One of the three interface routines |
147
|
0
|
|
|
1
|
1
|
0
|
for my $class (@_) |
148
|
|
|
|
|
|
|
{ # to the package. Deletes a class |
149
|
0
|
0
|
|
|
|
0
|
next if !eval '%' . $class . '::'; # declared using Class::Generate. |
150
|
0
|
0
|
|
|
|
0
|
if ( !eval '%' . $class . '::_cginfo' ) |
151
|
|
|
|
|
|
|
{ |
152
|
0
|
|
|
|
|
0
|
croak $class, ': Class was not declared using ', __PACKAGE__; |
153
|
|
|
|
|
|
|
} |
154
|
0
|
|
|
|
|
0
|
delete_package($class); |
155
|
0
|
|
|
|
|
0
|
Class::Generate::Class_Holder::remove($class); |
156
|
0
|
|
|
|
|
0
|
my $code_checking_package = |
157
|
|
|
|
|
|
|
__PACKAGE__ . '::Code_Checker::check::' . $class . '::'; |
158
|
0
|
0
|
|
|
|
0
|
if ( eval '%' . $code_checking_package ) |
159
|
|
|
|
|
|
|
{ |
160
|
0
|
|
|
|
|
0
|
delete_package($code_checking_package); |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
$default_pss = Class::Generate::Array->new('key_value'); |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
$initialize = sub { # Reset certain variables, and set |
168
|
|
|
|
|
|
|
undef $class_vars; # options to their default values. |
169
|
|
|
|
|
|
|
undef $use_packages; |
170
|
|
|
|
|
|
|
undef $excluded_methods; |
171
|
|
|
|
|
|
|
$param_style_spec = $default_pss; |
172
|
|
|
|
|
|
|
%class_options = ( |
173
|
|
|
|
|
|
|
virtual => 0, |
174
|
|
|
|
|
|
|
strict => $strict, |
175
|
|
|
|
|
|
|
save => $save, |
176
|
|
|
|
|
|
|
accept_refs => $accept_refs, |
177
|
|
|
|
|
|
|
class_var => $class_var, |
178
|
|
|
|
|
|
|
instance_var => $instance_var, |
179
|
|
|
|
|
|
|
check_params => $check_params, |
180
|
|
|
|
|
|
|
check_code => $check_code, |
181
|
|
|
|
|
|
|
check_default => $check_default, |
182
|
|
|
|
|
|
|
nfi => $nfi, |
183
|
|
|
|
|
|
|
warnings => $warnings |
184
|
|
|
|
|
|
|
); |
185
|
|
|
|
|
|
|
$allow_redefine_for_class = $allow_redefine; |
186
|
|
|
|
|
|
|
}; |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
$verify_class_type = sub { # Ensure that the class specification |
189
|
|
|
|
|
|
|
my $spec = $_[0]; # is a hash or array reference. |
190
|
|
|
|
|
|
|
return |
191
|
|
|
|
|
|
|
if UNIVERSAL::isa( $spec, 'HASH' ) || UNIVERSAL::isa( $spec, 'ARRAY' ); |
192
|
|
|
|
|
|
|
croak qq|$cm: Elements must be in array or hash reference|; |
193
|
|
|
|
|
|
|
}; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
$set_class_type = sub { # Set $class to the type (array or |
196
|
|
|
|
|
|
|
my ( $class_spec, $parent ) = @_; # hash) appropriate to its declaration. |
197
|
|
|
|
|
|
|
my @params = ( $class_name, %class_options ); |
198
|
|
|
|
|
|
|
if ( UNIVERSAL::isa( $class_spec, 'ARRAY' ) ) |
199
|
|
|
|
|
|
|
{ |
200
|
|
|
|
|
|
|
if ( defined $parent ) |
201
|
|
|
|
|
|
|
{ |
202
|
|
|
|
|
|
|
my ( $parent_name, @other_array_values ) = $parent->values; |
203
|
|
|
|
|
|
|
croak |
204
|
|
|
|
|
|
|
qq|$cm: An array reference based subclass must have exactly one parent| |
205
|
|
|
|
|
|
|
if @other_array_values; |
206
|
|
|
|
|
|
|
$parent = |
207
|
|
|
|
|
|
|
Class::Generate::Class_Holder::get( $parent_name, 'ARRAY' ); |
208
|
|
|
|
|
|
|
push @params, ( base_index => $parent->last + 1 ); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
$class = Class::Generate::Array_Class->new(@params); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
else |
213
|
|
|
|
|
|
|
{ |
214
|
|
|
|
|
|
|
$class = Class::Generate::Hash_Class->new(@params); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
}; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
my $class_name_regexp = '[A-Za-z_]\w*(::[A-Za-z_]\w*)*'; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
$parse_class_specification = sub { # Parse the class' specification, |
221
|
|
|
|
|
|
|
my %specs = @_; # checking for errors and amalgamating |
222
|
|
|
|
|
|
|
my %required; # class data. |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
if ( defined $specs{new} ) |
225
|
|
|
|
|
|
|
{ |
226
|
|
|
|
|
|
|
croak qq|$cm: Specification for "new" must be hash reference| |
227
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $specs{new}, 'HASH' ); |
228
|
|
|
|
|
|
|
my %new_spec = |
229
|
|
|
|
|
|
|
%{ $specs{new} }; # Modify %new_spec, not parameter passed |
230
|
|
|
|
|
|
|
my $required_items; # to class() or subclass(). |
231
|
|
|
|
|
|
|
if ( defined $new_spec{required} ) |
232
|
|
|
|
|
|
|
{ |
233
|
|
|
|
|
|
|
eval { |
234
|
|
|
|
|
|
|
$required_items = |
235
|
|
|
|
|
|
|
Class::Generate::Array->new( $new_spec{required} ); |
236
|
|
|
|
|
|
|
}; |
237
|
|
|
|
|
|
|
croak |
238
|
|
|
|
|
|
|
qq|$cm: Invalid specification for required constructor parameters ($sa_needed)| |
239
|
|
|
|
|
|
|
if $@; |
240
|
|
|
|
|
|
|
delete $new_spec{required}; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
if ( defined $new_spec{style} ) |
243
|
|
|
|
|
|
|
{ |
244
|
|
|
|
|
|
|
eval { |
245
|
|
|
|
|
|
|
$param_style_spec = |
246
|
|
|
|
|
|
|
Class::Generate::Array->new( $new_spec{style} ); |
247
|
|
|
|
|
|
|
}; |
248
|
|
|
|
|
|
|
croak qq|$cm: Invalid parameter-passing style ($sa_needed)| if $@; |
249
|
|
|
|
|
|
|
delete $new_spec{style}; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
$class->constructor( Class::Generate::Constructor->new(%new_spec) ); |
252
|
|
|
|
|
|
|
if ( defined $required_items ) |
253
|
|
|
|
|
|
|
{ |
254
|
|
|
|
|
|
|
for ( $required_items->values ) |
255
|
|
|
|
|
|
|
{ |
256
|
|
|
|
|
|
|
if (/^\w+$/) |
257
|
|
|
|
|
|
|
{ |
258
|
|
|
|
|
|
|
croak |
259
|
|
|
|
|
|
|
qq|$cm: Required params list for constructor contains unknown member "$_"| |
260
|
|
|
|
|
|
|
if !defined $specs{$_}; |
261
|
|
|
|
|
|
|
$required{$_} = 1; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
else |
264
|
|
|
|
|
|
|
{ |
265
|
|
|
|
|
|
|
$class->constructor->add_constraints($_); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
else |
271
|
|
|
|
|
|
|
{ |
272
|
|
|
|
|
|
|
$class->constructor( Class::Generate::Constructor->new ); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
my $actual_name; |
276
|
|
|
|
|
|
|
for my $member_name ( grep $_ ne 'new', keys %specs ) |
277
|
|
|
|
|
|
|
{ |
278
|
|
|
|
|
|
|
$actual_name = $member_name; |
279
|
|
|
|
|
|
|
$actual_name =~ s/^&//; |
280
|
|
|
|
|
|
|
croak qq|$cm: Invalid member/method name "$actual_name"| |
281
|
|
|
|
|
|
|
unless $actual_name =~ /^[A-Za-z_]\w*$/; |
282
|
|
|
|
|
|
|
croak qq|$cm: "$instance_var" is reserved| |
283
|
|
|
|
|
|
|
unless $actual_name ne $class_options{instance_var}; |
284
|
|
|
|
|
|
|
if ( substr( $member_name, 0, 1 ) eq '&' ) |
285
|
|
|
|
|
|
|
{ |
286
|
|
|
|
|
|
|
&$parse_method_specification( $member_name, $actual_name, \%specs ); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
else |
289
|
|
|
|
|
|
|
{ |
290
|
|
|
|
|
|
|
&$parse_member_specification( $member_name, \%specs, \%required ); |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
$class->constructor->style(&$constructor_parameter_passing_style); |
294
|
|
|
|
|
|
|
}; |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
$parse_method_specification = sub { |
297
|
|
|
|
|
|
|
my ( $member_name, $actual_name, $specs ) = @_; |
298
|
|
|
|
|
|
|
my ( %spec, $method ); |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
eval { |
301
|
|
|
|
|
|
|
%spec = %{ Class::Generate::Hash->new( $$specs{$member_name} || die, |
302
|
|
|
|
|
|
|
'body' ) }; |
303
|
|
|
|
|
|
|
}; |
304
|
|
|
|
|
|
|
croak &$invalid_spec_message( 'method', $actual_name, 'body' ) if $@; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
if ( $spec{class_method} ) |
307
|
|
|
|
|
|
|
{ |
308
|
|
|
|
|
|
|
croak qq|$cm: Method "$actual_name": A class method cannot be protected| |
309
|
|
|
|
|
|
|
if $spec{protected}; |
310
|
|
|
|
|
|
|
$method = |
311
|
|
|
|
|
|
|
Class::Generate::Class_Method->new( $actual_name, $spec{body} ); |
312
|
|
|
|
|
|
|
if ( $spec{objects} ) |
313
|
|
|
|
|
|
|
{ |
314
|
|
|
|
|
|
|
eval { |
315
|
|
|
|
|
|
|
$method->add_objects( |
316
|
|
|
|
|
|
|
( Class::Generate::Array->new( $spec{objects} ) )->values ); |
317
|
|
|
|
|
|
|
}; |
318
|
|
|
|
|
|
|
croak |
319
|
|
|
|
|
|
|
qq|$cm: Invalid specification for objects of "$actual_name" ($sa_needed)| |
320
|
|
|
|
|
|
|
if $@; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
delete $spec{objects} if exists $spec{objects}; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
else |
325
|
|
|
|
|
|
|
{ |
326
|
|
|
|
|
|
|
$method = Class::Generate::Method->new( $actual_name, $spec{body} ); |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
delete $spec{class_method} if exists $spec{class_method}; |
329
|
|
|
|
|
|
|
$class->user_defined_methods( $actual_name, $method ); |
330
|
|
|
|
|
|
|
&$set_attributes( $actual_name, $method, 'Method', 'body', \%spec ); |
331
|
|
|
|
|
|
|
}; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
$parse_member_specification = sub { |
334
|
|
|
|
|
|
|
my ( $member_name, $specs, $required ) = @_; |
335
|
|
|
|
|
|
|
my ( %spec, $member, %member_params ); |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
eval { |
338
|
|
|
|
|
|
|
%spec = %{ Class::Generate::Hash->new( $$specs{$member_name} || die, |
339
|
|
|
|
|
|
|
'type' ) }; |
340
|
|
|
|
|
|
|
}; |
341
|
|
|
|
|
|
|
croak &$invalid_spec_message( 'member', $member_name, 'type' ) if $@; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
$spec{required} = 1 if $$required{$member_name}; |
344
|
|
|
|
|
|
|
if ( exists $spec{default} ) |
345
|
|
|
|
|
|
|
{ |
346
|
|
|
|
|
|
|
if ( warnings::enabled() && $class_options{check_default} ) |
347
|
|
|
|
|
|
|
{ |
348
|
|
|
|
|
|
|
eval { |
349
|
|
|
|
|
|
|
Class::Generate::Support::verify_value( $spec{default}, |
350
|
|
|
|
|
|
|
$spec{type} ); |
351
|
|
|
|
|
|
|
}; |
352
|
|
|
|
|
|
|
warnings::warn( |
353
|
|
|
|
|
|
|
qq|$cm: Default value for "$member_name" is not correctly typed| |
354
|
|
|
|
|
|
|
) if $@; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
&$store_initial_value_reference( \$spec{default}, $member_name ) |
357
|
|
|
|
|
|
|
if ref $spec{default}; |
358
|
|
|
|
|
|
|
$member_params{default} = $spec{default}; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
%member_params = map defined $spec{$_} ? ( $_ => $spec{$_} ) : (), |
361
|
|
|
|
|
|
|
qw(post pre assert); |
362
|
|
|
|
|
|
|
if ( $spec{type} =~ m/^[\$@%]?($class_name_regexp)$/o ) |
363
|
|
|
|
|
|
|
{ |
364
|
|
|
|
|
|
|
$member_params{base} = $1; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
elsif ( $spec{type} !~ m/^[\$\@\%]$/ ) |
367
|
|
|
|
|
|
|
{ |
368
|
|
|
|
|
|
|
croak qq|$cm: Member "$member_name": "$spec{type}" is not a valid type|; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
if ( $spec{required} && ( $spec{private} || $spec{protected} ) ) |
371
|
|
|
|
|
|
|
{ |
372
|
|
|
|
|
|
|
warnings::warn( |
373
|
|
|
|
|
|
|
qq|$cm: "required" attribute ignored for private/protected member "$member_name"| |
374
|
|
|
|
|
|
|
) if warnings::enabled(); |
375
|
|
|
|
|
|
|
delete $spec{required}; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
if ( $spec{private} && $spec{protected} ) |
378
|
|
|
|
|
|
|
{ |
379
|
|
|
|
|
|
|
warnings::warn( |
380
|
|
|
|
|
|
|
qq|$cm: Member "$member_name" declared both private and protected (protected assumed)| |
381
|
|
|
|
|
|
|
) if warnings::enabled(); |
382
|
|
|
|
|
|
|
delete $spec{private}; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
delete @member_params{ grep !defined $member_params{$_}, |
385
|
|
|
|
|
|
|
keys %member_params }; |
386
|
|
|
|
|
|
|
if ( substr( $spec{type}, 0, 1 ) eq '@' ) |
387
|
|
|
|
|
|
|
{ |
388
|
|
|
|
|
|
|
$member = |
389
|
|
|
|
|
|
|
Class::Generate::Array_Member->new( $member_name, %member_params ); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
elsif ( substr( $spec{type}, 0, 1 ) eq '%' ) |
392
|
|
|
|
|
|
|
{ |
393
|
|
|
|
|
|
|
$member = |
394
|
|
|
|
|
|
|
Class::Generate::Hash_Member->new( $member_name, %member_params ); |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
else |
397
|
|
|
|
|
|
|
{ |
398
|
|
|
|
|
|
|
$member = |
399
|
|
|
|
|
|
|
Class::Generate::Scalar_Member->new( $member_name, %member_params ); |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
delete $spec{type}; |
402
|
|
|
|
|
|
|
$class->members( $member_name, $member ); |
403
|
|
|
|
|
|
|
&$set_attributes( $member_name, $member, 'Member', undef, \%spec ); |
404
|
|
|
|
|
|
|
}; |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
$parse_any_flags = sub { |
407
|
|
|
|
|
|
|
my $params = $_[0]; |
408
|
|
|
|
|
|
|
my %flags = map substr( $_, 0, 1 ) eq '-' ? ( $_ => $$params{$_} ) : (), |
409
|
|
|
|
|
|
|
keys %$params; |
410
|
|
|
|
|
|
|
return if !%flags; |
411
|
|
|
|
|
|
|
flag: |
412
|
|
|
|
|
|
|
while ( my ( $flag, $value ) = each %flags ) |
413
|
|
|
|
|
|
|
{ |
414
|
|
|
|
|
|
|
$flag eq '-use' and do |
415
|
|
|
|
|
|
|
{ |
416
|
|
|
|
|
|
|
eval { $use_packages = Class::Generate::Array->new($value) }; |
417
|
|
|
|
|
|
|
croak qq|"-use" flag $sa_needed| if $@; |
418
|
|
|
|
|
|
|
next flag; |
419
|
|
|
|
|
|
|
}; |
420
|
|
|
|
|
|
|
$flag eq '-class_vars' and do |
421
|
|
|
|
|
|
|
{ |
422
|
|
|
|
|
|
|
eval { $class_vars = Class::Generate::Array->new($value) }; |
423
|
|
|
|
|
|
|
croak qq|"-class_vars" flag $sa_needed| if $@; |
424
|
|
|
|
|
|
|
for my $var_spec ( grep ref($_), $class_vars->values ) |
425
|
|
|
|
|
|
|
{ |
426
|
|
|
|
|
|
|
croak 'Each class variable must be scalar or hash reference' |
427
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $var_spec, 'HASH' ); |
428
|
|
|
|
|
|
|
for my $var ( grep ref( $$var_spec{$_} ), keys %$var_spec ) |
429
|
|
|
|
|
|
|
{ |
430
|
|
|
|
|
|
|
&$store_initial_value_reference( \$$var_spec{$var}, $var ); |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
next flag; |
434
|
|
|
|
|
|
|
}; |
435
|
|
|
|
|
|
|
$flag eq '-virtual' and do |
436
|
|
|
|
|
|
|
{ |
437
|
|
|
|
|
|
|
$class_options{virtual} = $value; |
438
|
|
|
|
|
|
|
next flag; |
439
|
|
|
|
|
|
|
}; |
440
|
|
|
|
|
|
|
$flag eq '-exclude' and do |
441
|
|
|
|
|
|
|
{ |
442
|
|
|
|
|
|
|
eval { $excluded_methods = Class::Generate::Array->new($value) }; |
443
|
|
|
|
|
|
|
croak qq|"-exclude" flag $sa_needed| if $@; |
444
|
|
|
|
|
|
|
next flag; |
445
|
|
|
|
|
|
|
}; |
446
|
|
|
|
|
|
|
$flag eq '-comment' and do |
447
|
|
|
|
|
|
|
{ |
448
|
|
|
|
|
|
|
$class_options{comment} = $value; |
449
|
|
|
|
|
|
|
next flag; |
450
|
|
|
|
|
|
|
}; |
451
|
|
|
|
|
|
|
$flag eq '-options' and do |
452
|
|
|
|
|
|
|
{ |
453
|
|
|
|
|
|
|
croak qq|Options must be in hash reference| |
454
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $value, 'HASH' ); |
455
|
|
|
|
|
|
|
if ( exists $$value{allow_redefine} ) |
456
|
|
|
|
|
|
|
{ |
457
|
|
|
|
|
|
|
$allow_redefine_for_class = $$value{allow_redefine}; |
458
|
|
|
|
|
|
|
delete $$value{allow_redefine}; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
option: |
461
|
|
|
|
|
|
|
while ( my ( $o, $o_value ) = each %$value ) |
462
|
|
|
|
|
|
|
{ |
463
|
|
|
|
|
|
|
if ( !$valid_option{$o} ) |
464
|
|
|
|
|
|
|
{ |
465
|
|
|
|
|
|
|
warnings::warn(qq|Unknown option "$o" ignored|) |
466
|
|
|
|
|
|
|
if warnings::enabled(); |
467
|
|
|
|
|
|
|
next option; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
$class_options{$o} = $o_value; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
if ( exists $class_options{warnings} ) |
473
|
|
|
|
|
|
|
{ |
474
|
|
|
|
|
|
|
my $w = $class_options{warnings}; |
475
|
|
|
|
|
|
|
if ( ref $w ) |
476
|
|
|
|
|
|
|
{ |
477
|
|
|
|
|
|
|
croak 'Warnings must be scalar value or array reference' |
478
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $w, 'ARRAY' ); |
479
|
|
|
|
|
|
|
croak |
480
|
|
|
|
|
|
|
'Warnings array reference must have even number of elements' |
481
|
|
|
|
|
|
|
unless $#$w % 2 == 1; |
482
|
|
|
|
|
|
|
for ( my $i = 0 ; $i <= $#$w ; $i += 2 ) |
483
|
|
|
|
|
|
|
{ |
484
|
|
|
|
|
|
|
croak qq|Warnings array: Unknown key "$$w[$i]"| |
485
|
|
|
|
|
|
|
unless exists $warnings_keys{ $$w[$i] }; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
next flag; |
491
|
|
|
|
|
|
|
}; |
492
|
|
|
|
|
|
|
warnings::warn(qq|Unknown flag "$flag" ignored|) if warnings::enabled(); |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
delete @$params{ keys %flags }; |
495
|
|
|
|
|
|
|
}; |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# Set the appropriate attributes of |
498
|
|
|
|
|
|
|
$set_attributes = sub { # a member or method w.r.t. a class. |
499
|
|
|
|
|
|
|
my ( $name, $m, $type, $exclusion, $spec ) = @_; |
500
|
|
|
|
|
|
|
for my $attr ( |
501
|
|
|
|
|
|
|
defined $exclusion |
502
|
|
|
|
|
|
|
? grep( $_ ne $exclusion, keys %$spec ) |
503
|
|
|
|
|
|
|
: keys %$spec |
504
|
|
|
|
|
|
|
) |
505
|
|
|
|
|
|
|
{ |
506
|
|
|
|
|
|
|
if ( $m->can($attr) ) |
507
|
|
|
|
|
|
|
{ |
508
|
|
|
|
|
|
|
$m->$attr( $$spec{$attr} ); |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
elsif ( $class->can($attr) ) |
511
|
|
|
|
|
|
|
{ |
512
|
|
|
|
|
|
|
$class->$attr( $name, $$spec{$attr} ); |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
else |
515
|
|
|
|
|
|
|
{ |
516
|
|
|
|
|
|
|
warnings::warn(qq|$cm: $type "$name": Unknown attribute "$attr"|) |
517
|
|
|
|
|
|
|
if warnings::enabled(); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
}; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
my $containing_package = __PACKAGE__ . '::'; |
523
|
|
|
|
|
|
|
my $initial_value_form = $containing_package . '_initial_values'; |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
$store_initial_value_reference = sub { # Store initial values that are |
526
|
|
|
|
|
|
|
my ( $default_value, $var_name ) = @_; # references in an accessible |
527
|
|
|
|
|
|
|
push @_initial_values, $$default_value; # place. |
528
|
|
|
|
|
|
|
$$default_value = "\$$initial_value_form" . "[$#_initial_values]"; |
529
|
|
|
|
|
|
|
warnings::warn(qq|Cannot save reference as initial value for "$var_name"|) |
530
|
|
|
|
|
|
|
if $class_options{save} && warnings::enabled(); |
531
|
|
|
|
|
|
|
}; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
$class_defined = sub { # Return TRUE if the argument |
534
|
|
|
|
|
|
|
my $class_name = $_[0]; # is the name of a Perl package. |
535
|
|
|
|
|
|
|
return eval '%' . $class_name . '::'; |
536
|
|
|
|
|
|
|
}; |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# Do the main work of processing a class. |
539
|
|
|
|
|
|
|
$process_class = sub { # Parse its specification, generate a |
540
|
|
|
|
|
|
|
my $class_spec = $_[0]; # form, and evaluate that form. |
541
|
|
|
|
|
|
|
my ( @warnings, $errors ); |
542
|
|
|
|
|
|
|
&$croak_if_duplicate_names($class_spec); |
543
|
|
|
|
|
|
|
for my $var ( grep defined $class_options{$_}, qw(instance_var class_var) ) |
544
|
|
|
|
|
|
|
{ |
545
|
|
|
|
|
|
|
croak |
546
|
|
|
|
|
|
|
qq|$cm: Value of $var option must be an identifier (without a "\$")| |
547
|
|
|
|
|
|
|
unless $class_options{$var} =~ /^[A-Za-z_]\w*$/; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
&$parse_class_specification( |
550
|
|
|
|
|
|
|
UNIVERSAL::isa( $class_spec, 'ARRAY' ) ? @$class_spec : %$class_spec ); |
551
|
|
|
|
|
|
|
Class::Generate::Member_Names::set_element_regexps(); |
552
|
|
|
|
|
|
|
$class->add_class_vars( $class_vars->values ) if $class_vars; |
553
|
|
|
|
|
|
|
$class->add_use_packages( $use_packages->values ) if $use_packages; |
554
|
|
|
|
|
|
|
$class->warnings( $class_options{warnings} ) if $class_options{warnings}; |
555
|
|
|
|
|
|
|
$class->check_params( $class_options{check_params} ) |
556
|
|
|
|
|
|
|
if $class_options{check_params}; |
557
|
|
|
|
|
|
|
$class->excluded_methods_regexp( join '|', map "(?:$_)", |
558
|
|
|
|
|
|
|
$excluded_methods->values ) |
559
|
|
|
|
|
|
|
if $excluded_methods; |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
if ( warnings::enabled() && $class_options{check_code} ) |
562
|
|
|
|
|
|
|
{ |
563
|
|
|
|
|
|
|
Class::Generate::Code_Checker::check_user_defined_code( $class, $cm, |
564
|
|
|
|
|
|
|
\@warnings, \$errors ); |
565
|
|
|
|
|
|
|
for my $warning (@warnings) |
566
|
|
|
|
|
|
|
{ |
567
|
|
|
|
|
|
|
warnings::warn($warning); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
warnings::warn($errors) if $errors; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
my $form = $class->form; |
573
|
|
|
|
|
|
|
if ( $class_options{save} ) |
574
|
|
|
|
|
|
|
{ |
575
|
|
|
|
|
|
|
my ( $class_file, $ob, $cb ); |
576
|
|
|
|
|
|
|
if ( $class_options{save} =~ /\.p[ml]$/ ) |
577
|
|
|
|
|
|
|
{ |
578
|
|
|
|
|
|
|
$class_file = $class_options{save}; |
579
|
|
|
|
|
|
|
open CLASS_FILE, ">>$class_file" |
580
|
|
|
|
|
|
|
or croak qq|$cm: Cannot append to "$class_file": $!|; |
581
|
|
|
|
|
|
|
$ob = "{\n"; # The form is enclosed in braces to prevent |
582
|
|
|
|
|
|
|
$cb = "}\n"; # renaming duplicate "my" variables. |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
else |
585
|
|
|
|
|
|
|
{ |
586
|
|
|
|
|
|
|
$class_file = $class_name . '.pm'; |
587
|
|
|
|
|
|
|
$class_file =~ s|::|/|g; |
588
|
|
|
|
|
|
|
open CLASS_FILE, ">$class_file" |
589
|
|
|
|
|
|
|
or croak qq|$cm: Cannot save to "$class_file": $!|; |
590
|
|
|
|
|
|
|
$ob = $cb = ''; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
$form =~ |
593
|
|
|
|
|
|
|
s/^(my [%@\$]\w+) = ([%@]\{)?\$$initial_value_form\[\d+\]\}?;/$1;/mgo; |
594
|
|
|
|
|
|
|
print CLASS_FILE $ob, $form, $cb, "\n1;\n"; |
595
|
|
|
|
|
|
|
close CLASS_FILE; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
croak "$cm: Cannot continue after errors" if $errors; |
598
|
|
|
|
|
|
|
{ |
599
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { }; # Warnings have been reported during |
600
|
13
|
100
|
100
|
13
|
|
100
|
eval $form; # user-defined code analysis. |
|
13
|
100
|
100
|
13
|
|
36
|
|
|
13
|
50
|
33
|
13
|
|
400
|
|
|
13
|
100
|
33
|
13
|
|
88
|
|
|
13
|
100
|
33
|
12
|
|
35
|
|
|
13
|
100
|
33
|
12
|
|
801
|
|
|
13
|
50
|
0
|
12
|
|
88
|
|
|
13
|
100
|
0
|
12
|
|
27
|
|
|
13
|
50
|
0
|
12
|
|
571
|
|
|
13
|
0
|
0
|
10
|
|
86
|
|
|
13
|
0
|
|
9
|
|
84
|
|
|
13
|
0
|
|
9
|
|
12303
|
|
|
12
|
0
|
|
9
|
|
85
|
|
|
12
|
0
|
|
9
|
|
28
|
|
|
12
|
50
|
|
8
|
|
2755
|
|
|
12
|
100
|
|
8
|
|
72
|
|
|
12
|
100
|
|
8
|
|
26
|
|
|
12
|
100
|
|
8
|
|
739
|
|
|
12
|
50
|
|
8
|
|
86
|
|
|
12
|
100
|
|
7
|
|
32
|
|
|
12
|
100
|
|
1
|
|
525
|
|
|
12
|
100
|
|
10
|
|
70
|
|
|
12
|
100
|
|
6
|
|
29
|
|
|
12
|
100
|
|
11
|
|
11354
|
|
|
12
|
100
|
|
5
|
|
92
|
|
|
12
|
100
|
|
0
|
|
27
|
|
|
12
|
100
|
|
0
|
|
1532
|
|
|
10
|
100
|
|
14
|
|
59
|
|
|
10
|
100
|
|
7
|
|
21
|
|
|
10
|
100
|
|
11
|
|
1035
|
|
|
9
|
100
|
|
7
|
|
58
|
|
|
9
|
100
|
|
3
|
|
27
|
|
|
9
|
50
|
|
1
|
|
448
|
|
|
9
|
50
|
|
2
|
|
60
|
|
|
9
|
100
|
|
0
|
|
20
|
|
|
9
|
50
|
|
9
|
|
10288
|
|
|
8
|
100
|
|
6
|
|
60
|
|
|
8
|
100
|
|
2
|
|
33
|
|
|
8
|
100
|
|
1
|
|
230
|
|
|
8
|
50
|
|
7
|
|
45
|
|
|
8
|
100
|
|
3
|
|
16
|
|
|
8
|
50
|
|
3
|
|
1317
|
|
|
8
|
50
|
|
2
|
|
50
|
|
|
8
|
100
|
|
3
|
|
25
|
|
|
8
|
100
|
|
39
|
|
310
|
|
|
8
|
100
|
|
41
|
|
48
|
|
|
8
|
0
|
|
28
|
|
17
|
|
|
8
|
0
|
|
37
|
|
7858
|
|
|
8
|
100
|
|
15
|
|
72
|
|
|
8
|
100
|
|
14
|
|
16
|
|
|
8
|
100
|
|
9
|
|
682
|
|
|
8
|
100
|
|
11
|
|
65
|
|
|
8
|
100
|
|
2
|
|
20
|
|
|
8
|
100
|
|
4
|
|
487
|
|
|
8
|
100
|
|
2
|
|
51
|
|
|
8
|
100
|
|
2
|
|
17
|
|
|
8
|
100
|
|
0
|
|
706
|
|
|
7
|
100
|
|
9
|
|
41
|
|
|
7
|
100
|
|
2
|
|
15
|
|
|
7
|
100
|
|
11
|
|
4091
|
|
|
1
|
100
|
|
4
|
|
3
|
|
|
1
|
100
|
|
0
|
|
5
|
|
|
0
|
100
|
|
4
|
|
0
|
|
|
10
|
100
|
|
0
|
|
25
|
|
|
10
|
100
|
|
1
|
|
13
|
|
|
10
|
100
|
|
0
|
|
19
|
|
|
10
|
100
|
|
6
|
|
34
|
|
|
10
|
100
|
|
3
|
|
28
|
|
|
16
|
100
|
|
3
|
|
69
|
|
|
16
|
100
|
|
0
|
|
32
|
|
|
16
|
100
|
|
0
|
|
237
|
|
|
6
|
50
|
|
0
|
|
14
|
|
|
6
|
100
|
|
0
|
|
109
|
|
|
11
|
50
|
|
|
|
20
|
|
|
12
|
100
|
|
|
|
54
|
|
|
11
|
100
|
|
|
|
361
|
|
|
10
|
0
|
|
|
|
37
|
|
|
2
|
50
|
|
|
|
6
|
|
|
11
|
50
|
|
|
|
63
|
|
|
3
|
50
|
|
|
|
10
|
|
|
11
|
0
|
|
|
|
19
|
|
|
3
|
100
|
|
|
|
51
|
|
|
11
|
100
|
|
|
|
92
|
|
|
11
|
50
|
|
|
|
38
|
|
|
11
|
100
|
|
|
|
25
|
|
|
3
|
50
|
|
|
|
6
|
|
|
3
|
100
|
|
|
|
11
|
|
|
6
|
50
|
|
|
|
133
|
|
|
9
|
50
|
|
|
|
36
|
|
|
11
|
50
|
|
|
|
23
|
|
|
11
|
100
|
|
|
|
45
|
|
|
5
|
0
|
|
|
|
244
|
|
|
5
|
100
|
|
|
|
19
|
|
|
5
|
100
|
|
|
|
17
|
|
|
1
|
50
|
|
|
|
2
|
|
|
15
|
100
|
|
|
|
81
|
|
|
14
|
50
|
|
|
|
26
|
|
|
14
|
50
|
|
|
|
23
|
|
|
14
|
0
|
|
|
|
39
|
|
|
14
|
0
|
|
|
|
31
|
|
|
14
|
50
|
|
|
|
55
|
|
|
13
|
0
|
|
|
|
169
|
|
|
5
|
0
|
|
|
|
13
|
|
|
5
|
0
|
|
|
|
11
|
|
|
6
|
50
|
|
|
|
20
|
|
|
5
|
50
|
|
|
|
108
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
100
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
100
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
100
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
50
|
|
|
|
0
|
|
|
7
|
0
|
|
|
|
96
|
|
|
7
|
50
|
|
|
|
13
|
|
|
7
|
0
|
|
|
|
11
|
|
|
7
|
100
|
|
|
|
19
|
|
|
7
|
50
|
|
|
|
17
|
|
|
7
|
100
|
|
|
|
19
|
|
|
6
|
50
|
|
|
|
18
|
|
|
15
|
50
|
|
|
|
22
|
|
|
15
|
0
|
|
|
|
28
|
|
|
15
|
0
|
|
|
|
35
|
|
|
19
|
0
|
|
|
|
58
|
|
|
13
|
0
|
|
|
|
32
|
|
|
11
|
0
|
|
|
|
19
|
|
|
11
|
0
|
|
|
|
26
|
|
|
12
|
|
|
|
|
28
|
|
|
12
|
|
|
|
|
31
|
|
|
15
|
|
|
|
|
138
|
|
|
14
|
|
|
|
|
56
|
|
|
15
|
|
|
|
|
106
|
|
|
13
|
|
|
|
|
27
|
|
|
23
|
|
|
|
|
58
|
|
|
11
|
|
|
|
|
42
|
|
|
9
|
|
|
|
|
31
|
|
|
12
|
|
|
|
|
38
|
|
|
9
|
|
|
|
|
27
|
|
|
8
|
|
|
|
|
58
|
|
|
5
|
|
|
|
|
67
|
|
|
5
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
39
|
|
|
6
|
|
|
|
|
31
|
|
|
4
|
|
|
|
|
66
|
|
|
3
|
|
|
|
|
19
|
|
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
62
|
|
|
13
|
|
|
|
|
55
|
|
|
13
|
|
|
|
|
44
|
|
|
11
|
|
|
|
|
52
|
|
|
10
|
|
|
|
|
50
|
|
|
5
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
14
|
|
|
9
|
|
|
|
|
92
|
|
|
7
|
|
|
|
|
30
|
|
|
7
|
|
|
|
|
53
|
|
|
2
|
|
|
|
|
14
|
|
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
15
|
|
|
5
|
|
|
|
|
24
|
|
|
6
|
|
|
|
|
58
|
|
|
4
|
|
|
|
|
16
|
|
|
2
|
|
|
|
|
69
|
|
|
2
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
24
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
44
|
|
|
2
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
19
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
38
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
6
|
|
|
|
|
391
|
|
|
6
|
|
|
|
|
20
|
|
|
5
|
|
|
|
|
27
|
|
|
39
|
|
|
|
|
1487
|
|
|
38
|
|
|
|
|
126
|
|
|
38
|
|
|
|
|
108
|
|
|
38
|
|
|
|
|
196
|
|
|
40
|
|
|
|
|
379
|
|
|
40
|
|
|
|
|
175
|
|
|
38
|
|
|
|
|
203
|
|
|
32
|
|
|
|
|
113
|
|
|
21
|
|
|
|
|
88
|
|
|
29
|
|
|
|
|
78
|
|
|
8
|
|
|
|
|
67
|
|
|
27
|
|
|
|
|
212
|
|
|
60
|
|
|
|
|
1329
|
|
|
49
|
|
|
|
|
336
|
|
|
57
|
|
|
|
|
276
|
|
|
56
|
|
|
|
|
110
|
|
|
56
|
|
|
|
|
279
|
|
|
55
|
|
|
|
|
154
|
|
|
57
|
|
|
|
|
343
|
|
|
57
|
|
|
|
|
797
|
|
|
39
|
|
|
|
|
312
|
|
|
31
|
|
|
|
|
165
|
|
|
62
|
|
|
|
|
1166
|
|
|
30
|
|
|
|
|
169
|
|
|
34
|
|
|
|
|
202
|
|
|
36
|
|
|
|
|
342
|
|
|
35
|
|
|
|
|
104
|
|
|
29
|
|
|
|
|
113
|
|
|
24
|
|
|
|
|
82
|
|
|
22
|
|
|
|
|
498
|
|
|
18
|
|
|
|
|
253
|
|
|
16
|
|
|
|
|
42
|
|
|
17
|
|
|
|
|
135
|
|
|
42
|
|
|
|
|
1045
|
|
|
48
|
|
|
|
|
180
|
|
|
37
|
|
|
|
|
98
|
|
|
43
|
|
|
|
|
139
|
|
|
42
|
|
|
|
|
129
|
|
|
39
|
|
|
|
|
127
|
|
|
44
|
|
|
|
|
744
|
|
|
24
|
|
|
|
|
96
|
|
|
21
|
|
|
|
|
86
|
|
|
20
|
|
|
|
|
282
|
|
|
20
|
|
|
|
|
273
|
|
|
13
|
|
|
|
|
75
|
|
|
6
|
|
|
|
|
86
|
|
|
6
|
|
|
|
|
97
|
|
|
19
|
|
|
|
|
406
|
|
|
19
|
|
|
|
|
136
|
|
|
14
|
|
|
|
|
71
|
|
|
13
|
|
|
|
|
35
|
|
|
12
|
|
|
|
|
91
|
|
|
12
|
|
|
|
|
40
|
|
|
11
|
|
|
|
|
299
|
|
|
10
|
|
|
|
|
95
|
|
|
10
|
|
|
|
|
56
|
|
|
10
|
|
|
|
|
41
|
|
|
9
|
|
|
|
|
76
|
|
|
6
|
|
|
|
|
263
|
|
|
5
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
84
|
|
|
7
|
|
|
|
|
104
|
|
|
4
|
|
|
|
|
21
|
|
|
3
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
306
|
|
|
7
|
|
|
|
|
35
|
|
|
7
|
|
|
|
|
64
|
|
|
7
|
|
|
|
|
149
|
|
|
8
|
|
|
|
|
112
|
|
|
4
|
|
|
|
|
20
|
|
|
4
|
|
|
|
|
14
|
|
|
1
|
|
|
|
|
2
|
|
|
3
|
|
|
|
|
45
|
|
|
3
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
1
|
|
|
5
|
|
|
|
|
32
|
|
|
5
|
|
|
|
|
20
|
|
|
5
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
13
|
|
|
0
|
|
|
|
|
0
|
|
|
8
|
|
|
|
|
207
|
|
|
8
|
|
|
|
|
19
|
|
|
3
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
47
|
|
|
2
|
|
|
|
|
20
|
|
|
2
|
|
|
|
|
31
|
|
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
23
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
39
|
|
|
2
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
9
|
|
|
|
|
236
|
|
|
9
|
|
|
|
|
22
|
|
|
4
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
20
|
|
|
3
|
|
|
|
|
12
|
|
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
10
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
58
|
|
|
2
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
5
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
11
|
|
|
|
|
311
|
|
|
11
|
|
|
|
|
29
|
|
|
1
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
0
|
|
|
10
|
|
|
|
|
24
|
|
|
9
|
|
|
|
|
132
|
|
|
2
|
|
|
|
|
20
|
|
|
2
|
|
|
|
|
30
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
94
|
|
|
4
|
|
|
|
|
18
|
|
|
4
|
|
|
|
|
38
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
96
|
|
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
37
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
38
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
6
|
|
|
|
|
164
|
|
|
6
|
|
|
|
|
18
|
|
|
4
|
|
|
|
|
20
|
|
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
31
|
|
|
3
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
24
|
|
|
1
|
|
|
|
|
17
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
125
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
9
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
if ($@) |
602
|
|
|
|
|
|
|
{ |
603
|
|
|
|
|
|
|
my @lines = split( "\n", $form ); |
604
|
|
|
|
|
|
|
my ($l) = ( $@ =~ /(\d+)\.$/ ); |
605
|
|
|
|
|
|
|
$@ =~ s/\(eval \d+\) //; |
606
|
|
|
|
|
|
|
croak "$cm: Evaluation failed (problem in ", __PACKAGE__, "?)\n", |
607
|
|
|
|
|
|
|
$@, "\n", join( "\n", @lines[ $l - 1 .. $l + 1 ] ), "\n"; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
Class::Generate::Class_Holder::store($class); |
611
|
|
|
|
|
|
|
}; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
$constructor_parameter_passing_style = |
614
|
|
|
|
|
|
|
sub { # Establish the parameter-passing style |
615
|
|
|
|
|
|
|
my ( |
616
|
|
|
|
|
|
|
$style, # for a class' constructor, meanwhile |
617
|
|
|
|
|
|
|
@values, # checking for mismatches w.r.t. the |
618
|
|
|
|
|
|
|
$parent_with_constructor, # class' superclass. Return an |
619
|
|
|
|
|
|
|
$parent_constructor_package_name |
620
|
|
|
|
|
|
|
); # appropriate style. |
621
|
|
|
|
|
|
|
if ( defined $class->parents ) |
622
|
|
|
|
|
|
|
{ |
623
|
|
|
|
|
|
|
$parent_with_constructor = |
624
|
|
|
|
|
|
|
Class::Generate::Support::class_containing_method( 'new', $class ); |
625
|
|
|
|
|
|
|
$parent_constructor_package_name = ( |
626
|
|
|
|
|
|
|
ref $parent_with_constructor |
627
|
|
|
|
|
|
|
? $parent_with_constructor->name |
628
|
|
|
|
|
|
|
: $parent_with_constructor |
629
|
|
|
|
|
|
|
); |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
( ( $style, @values ) = $param_style_spec->values )[0] eq 'key_value' |
632
|
|
|
|
|
|
|
and do |
633
|
|
|
|
|
|
|
{ |
634
|
|
|
|
|
|
|
if ( defined $parent_with_constructor |
635
|
|
|
|
|
|
|
&& ref $parent_with_constructor |
636
|
|
|
|
|
|
|
&& index( ref $parent_with_constructor, $containing_package ) == 0 ) |
637
|
|
|
|
|
|
|
{ |
638
|
|
|
|
|
|
|
my $invoked_constructor_style = |
639
|
|
|
|
|
|
|
$parent_with_constructor->constructor->style; |
640
|
|
|
|
|
|
|
unless ( |
641
|
|
|
|
|
|
|
$invoked_constructor_style->isa( |
642
|
|
|
|
|
|
|
$containing_package . 'Key_Value' |
643
|
|
|
|
|
|
|
) |
644
|
|
|
|
|
|
|
|| $invoked_constructor_style->isa( |
645
|
|
|
|
|
|
|
$containing_package . 'Own' ) |
646
|
|
|
|
|
|
|
) |
647
|
|
|
|
|
|
|
{ |
648
|
|
|
|
|
|
|
warnings::warn( |
649
|
|
|
|
|
|
|
qq{$cm: Probable mismatch calling constructor in superclass "$parent_constructor_package_name"} |
650
|
|
|
|
|
|
|
) if warnings::enabled(); |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
return Class::Generate::Key_Value->new( 'params', |
654
|
|
|
|
|
|
|
$class->public_member_names ); |
655
|
|
|
|
|
|
|
}; |
656
|
|
|
|
|
|
|
$style eq 'positional' and do |
657
|
|
|
|
|
|
|
{ |
658
|
|
|
|
|
|
|
&$check_for_invalid_parameter_names(@values); |
659
|
|
|
|
|
|
|
my @member_names = $class->public_member_names; |
660
|
|
|
|
|
|
|
croak "$cm: Missing/extra members in style" |
661
|
|
|
|
|
|
|
unless $#values == $#member_names; |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
return Class::Generate::Positional->new(@values); |
664
|
|
|
|
|
|
|
}; |
665
|
|
|
|
|
|
|
$style eq 'mix' and do |
666
|
|
|
|
|
|
|
{ |
667
|
|
|
|
|
|
|
&$check_for_invalid_parameter_names(@values); |
668
|
|
|
|
|
|
|
my @member_names = $class->public_member_names; |
669
|
|
|
|
|
|
|
croak "$cm: Extra parameters in style specifier" |
670
|
|
|
|
|
|
|
unless $#values <= $#member_names; |
671
|
|
|
|
|
|
|
my %kv_members = map( ( $_ => 1 ), @member_names ); |
672
|
|
|
|
|
|
|
delete @kv_members{@values}; |
673
|
|
|
|
|
|
|
return Class::Generate::Mix->new( 'params', [@values], |
674
|
|
|
|
|
|
|
keys %kv_members ); |
675
|
|
|
|
|
|
|
}; |
676
|
|
|
|
|
|
|
$style eq 'own' and do |
677
|
|
|
|
|
|
|
{ |
678
|
|
|
|
|
|
|
for ( my $i = 0 ; $i <= $#values ; $i++ ) |
679
|
|
|
|
|
|
|
{ |
680
|
|
|
|
|
|
|
&$store_initial_value_reference( \$values[$i], |
681
|
|
|
|
|
|
|
$parent_constructor_package_name . '::new' ) |
682
|
|
|
|
|
|
|
if ref $values[$i]; |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
return Class::Generate::Own->new( [@values] ); |
685
|
|
|
|
|
|
|
}; |
686
|
|
|
|
|
|
|
croak qq|$cm: Invalid parameter passing style "$style"|; |
687
|
|
|
|
|
|
|
}; |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
$check_for_invalid_parameter_names = sub { |
690
|
|
|
|
|
|
|
my @param_names = @_; |
691
|
|
|
|
|
|
|
my $i = 0; |
692
|
|
|
|
|
|
|
for my $param (@param_names) |
693
|
|
|
|
|
|
|
{ |
694
|
|
|
|
|
|
|
croak |
695
|
|
|
|
|
|
|
qq|$cm: Error in new => { style => '... $param' }: $param is not a member| |
696
|
|
|
|
|
|
|
if !defined $class->members($param); |
697
|
|
|
|
|
|
|
croak |
698
|
|
|
|
|
|
|
qq|$cm: Error in new => { style => '... $param' }: $param is not a public member| |
699
|
|
|
|
|
|
|
if $class->private($param) || $class->protected($param); |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
my %uses; |
702
|
|
|
|
|
|
|
for my $param (@param_names) |
703
|
|
|
|
|
|
|
{ |
704
|
|
|
|
|
|
|
$uses{$param}++; |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
%uses = map( ( $uses{$_} > 1 ? ( $_ => $uses{$_} ) : () ), keys %uses ); |
707
|
|
|
|
|
|
|
if (%uses) |
708
|
|
|
|
|
|
|
{ |
709
|
|
|
|
|
|
|
croak "$cm: Error in new => { style => '...' }: ", |
710
|
|
|
|
|
|
|
join( '; ', map qq|Name "$_" used $uses{$_} times|, keys %uses ); |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
}; |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
$croak_if_duplicate_names = sub { |
715
|
|
|
|
|
|
|
my $class_spec = $_[0]; |
716
|
|
|
|
|
|
|
my ( @names, %uses ); |
717
|
|
|
|
|
|
|
if ( UNIVERSAL::isa( $class_spec, 'ARRAY' ) ) |
718
|
|
|
|
|
|
|
{ |
719
|
|
|
|
|
|
|
for ( my $i = 0 ; $i <= $#$class_spec ; $i += 2 ) |
720
|
|
|
|
|
|
|
{ |
721
|
|
|
|
|
|
|
push @names, $$class_spec[$i]; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
else |
725
|
|
|
|
|
|
|
{ |
726
|
|
|
|
|
|
|
@names = keys %$class_spec; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
for (@names) |
729
|
|
|
|
|
|
|
{ |
730
|
|
|
|
|
|
|
$uses{ substr( $_, 0, 1 ) eq '&' ? substr( $_, 1 ) : $_ }++; |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
%uses = map( ( $uses{$_} > 1 ? ( $_ => $uses{$_} ) : () ), keys %uses ); |
733
|
|
|
|
|
|
|
if (%uses) |
734
|
|
|
|
|
|
|
{ |
735
|
|
|
|
|
|
|
croak "$cm: ", |
736
|
|
|
|
|
|
|
join( '; ', map qq|Name "$_" used $uses{$_} times|, keys %uses ); |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
}; |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
$invalid_spec_message = sub { |
741
|
|
|
|
|
|
|
return |
742
|
|
|
|
|
|
|
sprintf |
743
|
|
|
|
|
|
|
qq|$cm: Invalid specification of %s "%s" ($sh_needed with "%s" key)|, |
744
|
|
|
|
|
|
|
@_; |
745
|
|
|
|
|
|
|
}; |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
package Class::Generate::Class_Holder; # This package encapsulates functions |
748
|
|
|
|
|
|
|
$Class::Generate::Class_Holder::VERSION = '1.18'; |
749
|
15
|
|
|
15
|
|
163
|
use strict; # related to storing and retrieving |
|
15
|
|
|
|
|
38
|
|
|
15
|
|
|
|
|
21136
|
|
750
|
|
|
|
|
|
|
# information on classes. It lets classes |
751
|
|
|
|
|
|
|
# saved in files be reused transparently. |
752
|
|
|
|
|
|
|
my %classes; |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
sub store($) |
755
|
|
|
|
|
|
|
{ # Given a class, store it so it's |
756
|
69
|
|
|
64
|
|
224
|
my $class = $_[0]; # accessible in future invocations of |
757
|
68
|
|
|
|
|
308
|
$classes{ $class->name } = $class; # class() and subclass(). |
758
|
|
|
|
|
|
|
} |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
# Given a class name, try to return an instance of Class::Generate::Class |
761
|
|
|
|
|
|
|
# that models the class. The instance comes from one of 3 places. We |
762
|
|
|
|
|
|
|
# first try to get it from wherever store() puts it. If that fails, |
763
|
|
|
|
|
|
|
# we check to see if the variable %::_cginfo exists (see |
764
|
|
|
|
|
|
|
# form(), below); if it does, we use the information it contains to |
765
|
|
|
|
|
|
|
# create an instance of Class::Generate::Class. If %::_cginfo |
766
|
|
|
|
|
|
|
# doesn't exist, the package wasn't created by Class::Generate. We try |
767
|
|
|
|
|
|
|
# to infer some characteristics of the class. |
768
|
|
|
|
|
|
|
sub get($;$) |
769
|
|
|
|
|
|
|
{ |
770
|
38
|
|
|
35
|
|
99
|
my ( $class_name, $default_type ) = @_; |
771
|
40
|
100
|
|
|
|
201
|
return $classes{$class_name} if exists $classes{$class_name}; |
772
|
|
|
|
|
|
|
|
773
|
6
|
100
|
|
|
|
64
|
return undef if !eval '%' . $class_name . '::'; # Package doesn't exist. |
774
|
|
|
|
|
|
|
|
775
|
7
|
|
|
|
|
13
|
my ( $class, %info ); |
776
|
5
|
100
|
|
|
|
43
|
if ( !eval "exists \$" . $class_name . '::{_cginfo}' ) |
777
|
|
|
|
|
|
|
{ # Package exists but is |
778
|
5
|
100
|
|
|
|
27
|
return undef if !defined $default_type; # not a class generated |
779
|
5
|
100
|
|
|
|
25
|
if ( $default_type eq 'ARRAY' ) |
780
|
|
|
|
|
|
|
{ # by Class::Generate. |
781
|
5
|
|
|
|
|
52
|
$class = new Class::Generate::Array_Class $class_name; |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
else |
784
|
|
|
|
|
|
|
{ |
785
|
7
|
|
|
|
|
108
|
$class = new Class::Generate::Hash_Class $class_name; |
786
|
|
|
|
|
|
|
} |
787
|
4
|
|
|
|
|
47
|
$class->constructor( new Class::Generate::Constructor ); |
788
|
4
|
|
|
|
|
32
|
$class->constructor->style( new Class::Generate::Own ); |
789
|
4
|
|
|
|
|
10
|
$classes{$class_name} = $class; |
790
|
7
|
|
|
|
|
196
|
return $class; |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
7
|
|
|
|
|
42
|
eval '%info = %' . $class_name . '::_cginfo'; |
794
|
7
|
100
|
|
|
|
35
|
if ( $info{base} eq 'ARRAY' ) |
795
|
|
|
|
|
|
|
{ |
796
|
|
|
|
|
|
|
$class = Class::Generate::Array_Class->new( $class_name, |
797
|
3
|
|
|
|
|
24
|
last => $info{last} ); |
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
else |
800
|
|
|
|
|
|
|
{ |
801
|
3
|
|
|
|
|
30
|
$class = Class::Generate::Hash_Class->new($class_name); |
802
|
|
|
|
|
|
|
} |
803
|
3
|
0
|
|
|
|
38
|
if ( exists $info{members} ) |
804
|
|
|
|
|
|
|
{ # Add members ... |
805
|
3
|
|
|
|
|
29
|
while ( my ( $name, $mem_info_ref ) = each %{ $info{members} } ) |
|
8
|
|
|
|
|
19
|
|
806
|
|
|
|
|
|
|
{ |
807
|
3
|
|
|
|
|
8
|
my ( $member, %mem_info ); |
808
|
2
|
|
|
|
|
5
|
%mem_info = %$mem_info_ref; |
809
|
|
|
|
|
|
|
DEFN: |
810
|
|
|
|
|
|
|
{ |
811
|
2
|
|
|
|
|
10
|
$mem_info{type} eq "\$" and do |
812
|
2
|
100
|
|
|
|
4
|
{ |
813
|
10
|
|
|
|
|
328
|
$member = Class::Generate::Scalar_Member->new($name); |
814
|
10
|
|
|
|
|
63
|
last DEFN; |
815
|
|
|
|
|
|
|
}; |
816
|
|
|
|
|
|
|
$mem_info{type} eq '@' and do |
817
|
8
|
50
|
|
|
|
26
|
{ |
818
|
8
|
|
|
|
|
15
|
$member = Class::Generate::Array_Member->new($name); |
819
|
10
|
|
|
|
|
139
|
last DEFN; |
820
|
|
|
|
|
|
|
}; |
821
|
|
|
|
|
|
|
$mem_info{type} eq '%' and do |
822
|
10
|
50
|
|
|
|
32
|
{ |
823
|
10
|
|
|
|
|
39
|
$member = Class::Generate::Hash_Member->new($name); |
824
|
8
|
|
|
|
|
26
|
last DEFN; |
825
|
|
|
|
|
|
|
}; |
826
|
|
|
|
|
|
|
} |
827
|
8
|
100
|
|
|
|
22
|
$member->base( $mem_info{base} ) if exists $mem_info{base}; |
828
|
8
|
|
|
|
|
17
|
$class->members( $name, $member ); |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
} |
831
|
8
|
0
|
|
|
|
16
|
if ( exists $info{class_methods} ) |
832
|
|
|
|
|
|
|
{ # Add methods... |
833
|
8
|
|
|
|
|
16
|
for my $name ( @{ $info{class_methods} } ) |
|
8
|
|
|
|
|
16
|
|
834
|
|
|
|
|
|
|
{ |
835
|
8
|
|
|
|
|
66
|
$class->user_defined_methods( $name, |
836
|
|
|
|
|
|
|
Class::Generate::Class_Method->new($name) ); |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
} |
839
|
4
|
50
|
|
|
|
40
|
if ( exists $info{instance_methods} ) |
840
|
|
|
|
|
|
|
{ |
841
|
4
|
|
|
|
|
28
|
for my $name ( @{ $info{instance_methods} } ) |
|
4
|
|
|
|
|
14
|
|
842
|
|
|
|
|
|
|
{ |
843
|
4
|
|
|
|
|
37
|
$class->user_defined_methods( $name, |
844
|
|
|
|
|
|
|
Class::Generate::Method->new($name) ); |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
} |
847
|
5
|
50
|
|
|
|
296
|
if ( exists $info{protected} ) |
848
|
|
|
|
|
|
|
{ # Set access ... |
849
|
5
|
|
|
|
|
24
|
for my $protected_member ( @{ $info{protected} } ) |
|
5
|
|
|
|
|
33
|
|
850
|
|
|
|
|
|
|
{ |
851
|
2
|
|
|
|
|
195
|
$class->protected( $protected_member, 1 ); |
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
} |
854
|
1
|
50
|
|
|
|
22
|
if ( exists $info{private} ) |
855
|
|
|
|
|
|
|
{ |
856
|
1
|
|
|
|
|
3
|
for my $private_member ( @{ $info{private} } ) |
|
1
|
|
|
|
|
5
|
|
857
|
|
|
|
|
|
|
{ |
858
|
1
|
|
|
|
|
33
|
$class->private( $private_member, 1 ); |
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
} |
861
|
1
|
50
|
|
|
|
30
|
$class->excluded_methods_regexp( $info{emr} ) if exists $info{emr}; |
862
|
1
|
|
|
|
|
23
|
$class->constructor( new Class::Generate::Constructor ); |
863
|
|
|
|
|
|
|
CONSTRUCTOR_STYLE: |
864
|
|
|
|
|
|
|
{ |
865
|
1
|
|
|
|
|
54
|
exists $info{kv_style} and do |
866
|
1
|
100
|
|
|
|
9
|
{ |
867
|
|
|
|
|
|
|
$class->constructor->style( new Class::Generate::Key_Value 'params', |
868
|
1
|
|
|
|
|
36
|
@{ $info{kv_style} } ); |
|
1
|
|
|
|
|
6
|
|
869
|
1
|
|
|
|
|
3
|
last CONSTRUCTOR_STYLE; |
870
|
|
|
|
|
|
|
}; |
871
|
|
|
|
|
|
|
exists $info{pos_style} and do |
872
|
2
|
50
|
|
|
|
52
|
{ |
873
|
|
|
|
|
|
|
$class->constructor->style( |
874
|
2
|
|
|
|
|
8
|
new Class::Generate::Positional( @{ $info{pos_style} } ) ); |
|
2
|
|
|
|
|
5
|
|
875
|
1
|
|
|
|
|
5
|
last CONSTRUCTOR_STYLE; |
876
|
|
|
|
|
|
|
}; |
877
|
|
|
|
|
|
|
exists $info{mix_style} and do |
878
|
1
|
100
|
|
|
|
32
|
{ |
879
|
|
|
|
|
|
|
$class->constructor->style( |
880
|
|
|
|
|
|
|
new Class::Generate::Mix( |
881
|
|
|
|
|
|
|
'params', |
882
|
1
|
|
|
|
|
5
|
[ @{ $info{mix_style}{keyed} } ], |
883
|
1
|
|
|
|
|
22
|
@{ $info{mix_style}{pos} } |
|
1
|
|
|
|
|
55
|
|
884
|
|
|
|
|
|
|
) |
885
|
|
|
|
|
|
|
); |
886
|
1
|
|
|
|
|
2
|
last CONSTRUCTOR_STYLE; |
887
|
|
|
|
|
|
|
}; |
888
|
|
|
|
|
|
|
exists $info{own_style} and do |
889
|
1
|
100
|
|
|
|
3
|
{ |
890
|
|
|
|
|
|
|
$class->constructor->style( |
891
|
1
|
|
|
|
|
6
|
new Class::Generate::Own( @{ $info{own_style} } ) ); |
|
1
|
|
|
|
|
2
|
|
892
|
1
|
|
|
|
|
4
|
last CONSTRUCTOR_STYLE; |
893
|
|
|
|
|
|
|
}; |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
|
896
|
0
|
|
|
|
|
0
|
$classes{$class_name} = $class; |
897
|
0
|
|
|
|
|
0
|
return $class; |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
sub remove($) |
901
|
|
|
|
|
|
|
{ |
902
|
1
|
|
|
7
|
|
2
|
delete $classes{ $_[0] }; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
sub form($) |
906
|
|
|
|
|
|
|
{ |
907
|
62
|
|
|
65
|
|
123
|
my $class = $_[0]; |
908
|
62
|
|
|
|
|
176
|
my $form = qq|use vars qw(\%_cginfo);\n| . '%_cginfo = ('; |
909
|
66
|
100
|
|
|
|
675
|
if ( $class->isa('Class::Generate::Array_Class') ) |
910
|
|
|
|
|
|
|
{ |
911
|
24
|
|
|
|
|
82
|
$form .= q|base => 'ARRAY', last => | . $class->last; |
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
else |
914
|
|
|
|
|
|
|
{ |
915
|
44
|
|
|
|
|
109
|
$form .= q|base => 'HASH'|; |
916
|
|
|
|
|
|
|
} |
917
|
|
|
|
|
|
|
|
918
|
61
|
100
|
|
|
|
154
|
if ( my @members = $class->members_values ) |
919
|
|
|
|
|
|
|
{ |
920
|
55
|
|
|
|
|
207
|
$form .= ', members => { ' |
921
|
|
|
|
|
|
|
. join( ', ', map( member($_), @members ) ) . ' }'; |
922
|
|
|
|
|
|
|
} |
923
|
63
|
|
|
|
|
193
|
my ( @class_methods, @instance_methods ); |
924
|
62
|
|
|
|
|
214
|
for my $m ( $class->user_defined_methods_values ) |
925
|
|
|
|
|
|
|
{ |
926
|
29
|
100
|
|
|
|
163
|
if ( $m->isa('Class::Generate::Class_Method') ) |
927
|
|
|
|
|
|
|
{ |
928
|
2
|
|
|
|
|
6
|
push @class_methods, $m->name; |
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
else |
931
|
|
|
|
|
|
|
{ |
932
|
26
|
|
|
|
|
59
|
push @instance_methods, $m->name; |
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
} |
935
|
61
|
|
|
|
|
189
|
$form .= comma_prefixed_list_of_values( 'class_methods', @class_methods ); |
936
|
61
|
|
|
|
|
140
|
$form .= |
937
|
|
|
|
|
|
|
comma_prefixed_list_of_values( 'instance_methods', @instance_methods ); |
938
|
|
|
|
|
|
|
$form .= comma_prefixed_list_of_values( |
939
|
|
|
|
|
|
|
'protected', |
940
|
61
|
|
|
|
|
118
|
do { my %p = $class->protected; keys %p } |
|
61
|
|
|
|
|
166
|
|
|
61
|
|
|
|
|
176
|
|
941
|
|
|
|
|
|
|
); |
942
|
|
|
|
|
|
|
$form .= comma_prefixed_list_of_values( |
943
|
|
|
|
|
|
|
'private', |
944
|
64
|
|
|
|
|
284
|
do { my %p = $class->private; keys %p } |
|
64
|
|
|
|
|
153
|
|
|
64
|
|
|
|
|
394
|
|
945
|
|
|
|
|
|
|
); |
946
|
|
|
|
|
|
|
|
947
|
61
|
100
|
|
|
|
173
|
if ( my $emr = $class->excluded_methods_regexp ) |
948
|
|
|
|
|
|
|
{ |
949
|
7
|
|
|
|
|
21
|
$emr =~ s/\'/\\\'/g; |
950
|
7
|
|
|
|
|
19
|
$form .= ", emr => '$emr'"; |
951
|
|
|
|
|
|
|
} |
952
|
61
|
100
|
|
|
|
145
|
if ( ( my $constructor = $class->constructor ) ) |
953
|
|
|
|
|
|
|
{ |
954
|
61
|
|
|
|
|
160
|
my $style = $constructor->style; |
955
|
|
|
|
|
|
|
STYLE: |
956
|
|
|
|
|
|
|
{ |
957
|
61
|
|
|
|
|
104
|
$style->isa('Class::Generate::Key_Value') and do |
958
|
61
|
100
|
|
|
|
369
|
{ |
959
|
41
|
|
|
|
|
131
|
my @kpn = $style->keyed_param_names; |
960
|
41
|
100
|
|
|
|
113
|
if (@kpn) |
961
|
|
|
|
|
|
|
{ |
962
|
33
|
|
|
|
|
88
|
$form .= comma_prefixed_list_of_values( 'kv_style', |
963
|
|
|
|
|
|
|
$style->keyed_param_names ); |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
else |
966
|
|
|
|
|
|
|
{ |
967
|
8
|
|
|
|
|
20
|
$form .= ', kv_style => []'; |
968
|
|
|
|
|
|
|
} |
969
|
41
|
|
|
|
|
134
|
last STYLE; |
970
|
|
|
|
|
|
|
}; |
971
|
|
|
|
|
|
|
$style->isa('Class::Generate::Positional') and do |
972
|
24
|
100
|
|
|
|
269
|
{ |
973
|
9
|
|
|
|
|
44
|
my @members = sort { $style->order($a) <=> $style->order($b) } |
974
|
14
|
|
|
|
|
42
|
do { my %m = $style->order; keys %m }; |
|
10
|
|
|
|
|
44
|
|
|
11
|
|
|
|
|
50
|
|
975
|
11
|
100
|
|
|
|
47
|
if (@members) |
976
|
|
|
|
|
|
|
{ |
977
|
9
|
|
|
|
|
26
|
$form .= |
978
|
|
|
|
|
|
|
comma_prefixed_list_of_values( 'pos_style', @members ); |
979
|
|
|
|
|
|
|
} |
980
|
|
|
|
|
|
|
else |
981
|
|
|
|
|
|
|
{ |
982
|
1
|
|
|
|
|
3
|
$form .= ', pos_style => []'; |
983
|
|
|
|
|
|
|
} |
984
|
11
|
|
|
|
|
39
|
last STYLE; |
985
|
|
|
|
|
|
|
}; |
986
|
|
|
|
|
|
|
$style->isa('Class::Generate::Mix') and do |
987
|
11
|
100
|
|
|
|
35
|
{ |
988
|
6
|
|
|
|
|
18
|
my @keyed_members = $style->keyed_param_names; |
989
|
|
|
|
|
|
|
my @pos_members = |
990
|
1
|
|
|
|
|
4
|
sort { $style->order($a) <=> $style->order($b) } |
991
|
5
|
|
|
|
|
11
|
do { my %m = $style->order; keys %m }; |
|
5
|
|
|
|
|
26
|
|
|
5
|
|
|
|
|
17
|
|
992
|
7
|
100
|
100
|
|
|
134
|
if ( @keyed_members || @pos_members ) |
993
|
|
|
|
|
|
|
{ |
994
|
6
|
|
|
|
|
24
|
my $km_form = list_of_values( 'keyed', @keyed_members ); |
995
|
6
|
|
|
|
|
22
|
my $pm_form = list_of_values( 'pos', @pos_members ); |
996
|
4
|
|
|
|
|
22
|
$form .= |
997
|
|
|
|
|
|
|
', mix_style => {' |
998
|
|
|
|
|
|
|
. join( ', ', |
999
|
|
|
|
|
|
|
grep( length > 0, ( $km_form, $pm_form ) ) ) |
1000
|
|
|
|
|
|
|
. '}'; |
1001
|
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
|
else |
1003
|
|
|
|
|
|
|
{ |
1004
|
2
|
|
|
|
|
62
|
$form .= ', mix_style => {}'; |
1005
|
|
|
|
|
|
|
} |
1006
|
6
|
|
|
|
|
20
|
last STYLE; |
1007
|
|
|
|
|
|
|
}; |
1008
|
|
|
|
|
|
|
$style->isa('Class::Generate::Own') and do |
1009
|
6
|
100
|
|
|
|
23
|
{ |
1010
|
5
|
|
|
|
|
14
|
my @super_values = $style->super_values; |
1011
|
8
|
100
|
|
|
|
177
|
if (@super_values) |
1012
|
|
|
|
|
|
|
{ |
1013
|
6
|
|
|
|
|
17
|
for my $sv (@super_values) |
1014
|
|
|
|
|
|
|
{ |
1015
|
8
|
|
|
|
|
35
|
$sv =~ s/\'/\\\'/g; |
1016
|
|
|
|
|
|
|
} |
1017
|
3
|
|
|
|
|
8
|
$form .= comma_prefixed_list_of_values( 'own_style', |
1018
|
|
|
|
|
|
|
@super_values ); |
1019
|
|
|
|
|
|
|
} |
1020
|
|
|
|
|
|
|
else |
1021
|
|
|
|
|
|
|
{ |
1022
|
3
|
|
|
|
|
61
|
$form .= ', own_style => []'; |
1023
|
|
|
|
|
|
|
} |
1024
|
6
|
|
|
|
|
18
|
last STYLE; |
1025
|
|
|
|
|
|
|
}; |
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
} |
1028
|
62
|
|
|
|
|
138
|
$form .= ');' . "\n"; |
1029
|
61
|
|
|
|
|
203
|
return $form; |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
sub member($) |
1033
|
|
|
|
|
|
|
{ |
1034
|
134
|
|
|
138
|
|
257
|
my $member = $_[0]; |
1035
|
135
|
|
|
|
|
176
|
my $base; |
1036
|
135
|
|
|
|
|
257
|
my $form = $member->name . ' => {'; |
1037
|
133
|
100
|
|
|
|
692
|
$form .= " type => '" |
|
|
100
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
. ( |
1039
|
|
|
|
|
|
|
$member->isa('Class::Generate::Scalar_Member') ? "\$" |
1040
|
|
|
|
|
|
|
: $member->isa('Class::Generate::Array_Member') ? '@' |
1041
|
|
|
|
|
|
|
: '%' |
1042
|
|
|
|
|
|
|
) . "'"; |
1043
|
134
|
100
|
|
|
|
404
|
if ( defined( $base = $member->base ) ) |
1044
|
|
|
|
|
|
|
{ |
1045
|
17
|
|
|
|
|
38
|
$form .= ", base => '$base'"; |
1046
|
|
|
|
|
|
|
} |
1047
|
134
|
|
|
|
|
509
|
return $form . '}'; |
1048
|
|
|
|
|
|
|
} |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
sub list_of_values($@) |
1051
|
|
|
|
|
|
|
{ |
1052
|
76
|
|
|
78
|
|
217
|
my ( $key, @list ) = @_; |
1053
|
77
|
100
|
|
|
|
262
|
return '' if !@list; |
1054
|
76
|
|
|
|
|
599
|
return "$key => [" . join( ', ', map( "'$_'", @list ) ) . ']'; |
1055
|
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
sub comma_prefixed_list_of_values($@) |
1058
|
|
|
|
|
|
|
{ |
1059
|
290
|
100
|
|
290
|
|
819
|
return $#_ > 0 ? ', ' . list_of_values( $_[0], @_[ 1 .. $#_ ] ) : ''; |
1060
|
|
|
|
|
|
|
} |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
package Class::Generate::Member_Names; # This package encapsulates functions |
1063
|
|
|
|
|
|
|
$Class::Generate::Member_Names::VERSION = '1.18'; |
1064
|
15
|
|
|
15
|
|
136
|
use strict; # to handle name substitution in |
|
15
|
|
|
|
|
35
|
|
|
15
|
|
|
|
|
25230
|
|
1065
|
|
|
|
|
|
|
# user-defined code. |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
my ( |
1068
|
|
|
|
|
|
|
$member_regexp, # Regexp of accessible members. |
1069
|
|
|
|
|
|
|
$accessor_regexp, # Regexp of accessible member accessors (x_size, etc.). |
1070
|
|
|
|
|
|
|
$user_defined_methods_regexp |
1071
|
|
|
|
|
|
|
, # Regexp of accessible user-defined instance methods. |
1072
|
|
|
|
|
|
|
$nonpublic_member_regexp |
1073
|
|
|
|
|
|
|
, # (For class methods) Regexp of accessors for protected and private members. |
1074
|
|
|
|
|
|
|
$private_class_methods_regexp |
1075
|
|
|
|
|
|
|
); # (Ditto) Regexp of private class methods. |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
sub accessible_member_regexps($;$); |
1078
|
|
|
|
|
|
|
sub accessible_members($;$); |
1079
|
|
|
|
|
|
|
sub accessible_accessor_regexps($;$); |
1080
|
|
|
|
|
|
|
sub accessible_user_defined_method_regexps($;$); |
1081
|
|
|
|
|
|
|
sub class_of($$;$); |
1082
|
|
|
|
|
|
|
sub member_index($$); |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
sub set_element_regexps() |
1085
|
|
|
|
|
|
|
{ # Establish the regexps for |
1086
|
61
|
|
|
64
|
|
102
|
my @names; # name substitution. |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# First for members... |
1089
|
61
|
|
|
|
|
161
|
@names = accessible_member_regexps($class); |
1090
|
61
|
100
|
|
|
|
163
|
if ( !@names ) |
1091
|
|
|
|
|
|
|
{ |
1092
|
2
|
|
|
|
|
5
|
undef $member_regexp; |
1093
|
|
|
|
|
|
|
} |
1094
|
|
|
|
|
|
|
else |
1095
|
|
|
|
|
|
|
{ |
1096
|
|
|
|
|
|
|
$member_regexp = '(?:\b(?:my|local)\b[^=;()]+)?(' |
1097
|
59
|
|
|
|
|
271
|
. join( '|', sort { length $b <=> length $a } @names ) . ')\b'; |
|
243
|
|
|
|
|
608
|
|
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
# Next for accessors (e.g., x_size)... |
1101
|
61
|
|
|
|
|
292
|
@names = accessible_accessor_regexps($class); |
1102
|
61
|
100
|
|
|
|
214
|
if ( !@names ) |
1103
|
|
|
|
|
|
|
{ |
1104
|
2
|
|
|
|
|
4
|
undef $accessor_regexp; |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
else |
1107
|
|
|
|
|
|
|
{ |
1108
|
|
|
|
|
|
|
$accessor_regexp = '&(' |
1109
|
59
|
|
|
|
|
225
|
. join( '|', sort { length $b <=> length $a } @names ) |
|
1145
|
|
|
|
|
1752
|
|
1110
|
|
|
|
|
|
|
. ')\b(?:\s*\()?'; |
1111
|
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
# Next for user-defined instance methods... |
1114
|
61
|
|
|
|
|
242
|
@names = accessible_user_defined_method_regexps($class); |
1115
|
62
|
100
|
|
|
|
160
|
if ( !@names ) |
1116
|
|
|
|
|
|
|
{ |
1117
|
48
|
|
|
|
|
87
|
undef $user_defined_methods_regexp; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
else |
1120
|
|
|
|
|
|
|
{ |
1121
|
|
|
|
|
|
|
$user_defined_methods_regexp = '&(' |
1122
|
14
|
|
|
|
|
51
|
. join( '|', sort { length $b <=> length $a } @names ) |
|
40
|
|
|
|
|
112
|
|
1123
|
|
|
|
|
|
|
. ')\b(?:\s*\()?'; |
1124
|
|
|
|
|
|
|
} |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
# Next for protected and private members, and instance methods in class methods... |
1127
|
61
|
100
|
|
|
|
213
|
if ( $class->class_methods ) |
1128
|
|
|
|
|
|
|
{ |
1129
|
2
|
|
100
|
|
|
8
|
@names = ( |
|
|
|
100
|
|
|
|
|
1130
|
|
|
|
|
|
|
map( $_->accessor_names( $class, $_->name ), |
1131
|
|
|
|
|
|
|
grep $class->protected( $_->name ) |
1132
|
|
|
|
|
|
|
|| $class->private( $_->name ), |
1133
|
|
|
|
|
|
|
$class->members_values ), |
1134
|
|
|
|
|
|
|
grep( $class->private($_) || $class->protected($_), |
1135
|
|
|
|
|
|
|
map( $_->name, $class->instance_methods ) ) |
1136
|
|
|
|
|
|
|
); |
1137
|
2
|
100
|
|
|
|
9
|
if ( !@names ) |
1138
|
|
|
|
|
|
|
{ |
1139
|
1
|
|
|
|
|
2
|
undef $nonpublic_member_regexp; |
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
else |
1142
|
|
|
|
|
|
|
{ |
1143
|
|
|
|
|
|
|
$nonpublic_member_regexp = |
1144
|
1
|
|
|
|
|
5
|
join( '|', sort { length $b <=> length $a } @names ); |
|
0
|
|
|
|
|
0
|
|
1145
|
|
|
|
|
|
|
} |
1146
|
|
|
|
|
|
|
} |
1147
|
|
|
|
|
|
|
else |
1148
|
|
|
|
|
|
|
{ |
1149
|
59
|
|
|
|
|
165
|
undef $nonpublic_member_regexp; |
1150
|
|
|
|
|
|
|
} |
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
# Finally for private class methods invoked from class and instance methods. |
1153
|
61
|
50
|
100
|
|
|
184
|
if ( |
1154
|
|
|
|
|
|
|
my @private_class_methods = |
1155
|
|
|
|
|
|
|
grep $_->isa('Class::Generate::Class_Method') |
1156
|
|
|
|
|
|
|
&& $class->private( $_->name ), $class->user_defined_methods |
1157
|
|
|
|
|
|
|
) |
1158
|
|
|
|
|
|
|
{ |
1159
|
1
|
|
|
|
|
3
|
$private_class_methods_regexp = |
1160
|
|
|
|
|
|
|
$class->name |
1161
|
|
|
|
|
|
|
. '\s*->\s*(' |
1162
|
|
|
|
|
|
|
. join( '|', map $_->name, @private_class_methods ) . ')' |
1163
|
|
|
|
|
|
|
. '(\s*\((?:\s*\))?)?'; |
1164
|
|
|
|
|
|
|
} |
1165
|
|
|
|
|
|
|
else |
1166
|
|
|
|
|
|
|
{ |
1167
|
62
|
|
|
|
|
137
|
undef $private_class_methods_regexp; |
1168
|
|
|
|
|
|
|
} |
1169
|
|
|
|
|
|
|
} |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
sub substituted($) |
1172
|
|
|
|
|
|
|
{ # Within a code fragment, replace |
1173
|
47
|
|
|
47
|
|
81
|
my $code = $_[0]; # member names and accessors with the |
1174
|
|
|
|
|
|
|
# appropriate forms. |
1175
|
46
|
100
|
|
|
|
1253
|
$code =~ s/$member_regexp/member_invocation($1, $&)/eg |
|
91
|
|
|
|
|
242
|
|
1176
|
|
|
|
|
|
|
if defined $member_regexp; |
1177
|
46
|
100
|
|
|
|
713
|
$code =~ s/$accessor_regexp/accessor_invocation($1, $+, $&)/eg |
|
26
|
|
|
|
|
73
|
|
1178
|
|
|
|
|
|
|
if defined $accessor_regexp; |
1179
|
46
|
100
|
|
|
|
574
|
$code =~ s/$user_defined_methods_regexp/accessor_invocation($1, $1, $&)/eg |
|
7
|
|
|
|
|
21
|
|
1180
|
|
|
|
|
|
|
if defined $user_defined_methods_regexp; |
1181
|
46
|
50
|
|
|
|
128
|
$code =~ |
1182
|
0
|
|
|
|
|
0
|
s/$private_class_methods_regexp/nonpublic_method_invocation("'" . $class->name . "'", $1, $2)/eg |
1183
|
|
|
|
|
|
|
if defined $private_class_methods_regexp; |
1184
|
46
|
|
|
|
|
163
|
return $code; |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
# Perform the actual substitution |
1188
|
|
|
|
|
|
|
sub member_invocation($$) |
1189
|
|
|
|
|
|
|
{ # for member references. |
1190
|
91
|
|
|
92
|
|
306
|
my ( $member_reference, $match ) = @_; |
1191
|
91
|
|
|
|
|
172
|
my ( $name, $type, $form, $index ); |
1192
|
91
|
50
|
|
|
|
1849
|
return $member_reference |
1193
|
|
|
|
|
|
|
if $match =~ /\A(?:my|local)\b[^=;()]+$member_reference$/s; |
1194
|
91
|
|
|
|
|
392
|
$member_reference =~ /^(\W+)(\w+)$/; |
1195
|
91
|
|
|
|
|
201
|
$name = $2; |
1196
|
91
|
100
|
|
|
|
192
|
return $member_reference |
1197
|
|
|
|
|
|
|
if !defined( $index = member_index( $class, $name ) ); |
1198
|
91
|
|
|
|
|
185
|
$type = $1; |
1199
|
91
|
|
|
|
|
181
|
$form = $class->instance_var . '->' . $index; |
1200
|
91
|
100
|
|
|
|
963
|
return $type eq '$' ? $form : $type . '{' . $form . '}'; |
1201
|
|
|
|
|
|
|
} |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
# Perform the actual substitution for |
1204
|
|
|
|
|
|
|
sub accessor_invocation($$$) |
1205
|
|
|
|
|
|
|
{ # accessor and user-defined method references. |
1206
|
33
|
|
|
35
|
|
119
|
my ( $accessor_name, $element_name, $match ) = @_; |
1207
|
33
|
|
|
|
|
75
|
my $prefix = $class->instance_var . '->'; |
1208
|
33
|
|
|
|
|
86
|
my $c = class_of( $element_name, $class ); |
1209
|
33
|
100
|
100
|
|
|
78
|
if ( !( $c->protected($element_name) || $c->private($element_name) ) ) |
1210
|
|
|
|
|
|
|
{ |
1211
|
|
|
|
|
|
|
return |
1212
|
2
|
50
|
|
|
|
30
|
$prefix |
1213
|
|
|
|
|
|
|
. $accessor_name |
1214
|
|
|
|
|
|
|
. ( substr( $match, -1 ) eq '(' ? '(' : '' ); |
1215
|
|
|
|
|
|
|
} |
1216
|
31
|
100
|
100
|
|
|
61
|
if ( $c->private($element_name) || $c->name eq $class->name ) |
1217
|
|
|
|
|
|
|
{ |
1218
|
25
|
100
|
|
|
|
112
|
return "$prefix\$$accessor_name(" if substr( $match, -1 ) eq '('; |
1219
|
18
|
|
|
|
|
135
|
return "$prefix\$$accessor_name()"; |
1220
|
|
|
|
|
|
|
} |
1221
|
6
|
|
|
|
|
20
|
my $form = |
1222
|
|
|
|
|
|
|
"&{$prefix" |
1223
|
|
|
|
|
|
|
. $class->protected_members_info_index |
1224
|
|
|
|
|
|
|
. qq|->{'$accessor_name'}}(|; |
1225
|
6
|
|
|
|
|
14
|
$form .= $class->instance_var . ','; |
1226
|
6
|
100
|
|
|
|
38
|
return substr( $match, -1 ) eq '(' ? $form : $form . ')'; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
sub substituted_in_class_method |
1230
|
|
|
|
|
|
|
{ |
1231
|
2
|
|
|
4
|
|
5
|
my $method = $_[0]; |
1232
|
2
|
|
|
|
|
5
|
my ( @objs, $code, @private_class_methods ); |
1233
|
2
|
|
|
|
|
5
|
$code = $method->body; |
1234
|
2
|
50
|
66
|
|
|
15
|
if ( defined $nonpublic_member_regexp && ( @objs = $method->objects ) ) |
1235
|
|
|
|
|
|
|
{ |
1236
|
0
|
|
|
|
|
0
|
my $nonpublic_member_invocation_regexp = '(' |
1237
|
|
|
|
|
|
|
. join( '|', map( quotemeta($_), @objs ) ) . ')' |
1238
|
|
|
|
|
|
|
. '\s*->\s*(' |
1239
|
|
|
|
|
|
|
. $nonpublic_member_regexp . ')' |
1240
|
|
|
|
|
|
|
. '(\s*\((?:\s*\))?)?'; |
1241
|
0
|
|
|
|
|
0
|
$code =~ |
1242
|
0
|
|
|
|
|
0
|
s/$nonpublic_member_invocation_regexp/nonpublic_method_invocation($1, $2, $3)/ge; |
1243
|
|
|
|
|
|
|
} |
1244
|
2
|
100
|
|
|
|
7
|
if ( defined $private_class_methods_regexp ) |
1245
|
|
|
|
|
|
|
{ |
1246
|
0
|
|
|
|
|
0
|
$code =~ |
1247
|
0
|
|
|
|
|
0
|
s/$private_class_methods_regexp/nonpublic_method_invocation("'" . $class->name . "'", $1, $2)/ge; |
1248
|
|
|
|
|
|
|
} |
1249
|
2
|
|
|
|
|
16
|
return $code; |
1250
|
|
|
|
|
|
|
} |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
sub nonpublic_method_invocation |
1253
|
|
|
|
|
|
|
{ # Perform the actual |
1254
|
0
|
|
|
0
|
|
0
|
my ( $object, $nonpublic_member, $paren_matter ) = @_; # substitution for |
1255
|
0
|
|
|
|
|
0
|
my $form = '&$' . $nonpublic_member . '(' . $object; # nonpublic method and |
1256
|
0
|
0
|
|
|
|
0
|
if ( defined $paren_matter ) |
1257
|
|
|
|
|
|
|
{ # member references. |
1258
|
0
|
0
|
|
|
|
0
|
if ( index( $paren_matter, ')' ) != -1 ) |
1259
|
|
|
|
|
|
|
{ |
1260
|
0
|
|
|
|
|
0
|
$form .= ')'; |
1261
|
|
|
|
|
|
|
} |
1262
|
|
|
|
|
|
|
else |
1263
|
|
|
|
|
|
|
{ |
1264
|
0
|
|
|
|
|
0
|
$form .= ', '; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
} |
1267
|
|
|
|
|
|
|
else |
1268
|
|
|
|
|
|
|
{ |
1269
|
0
|
|
|
|
|
0
|
$form .= ')'; |
1270
|
|
|
|
|
|
|
} |
1271
|
0
|
|
|
|
|
0
|
return $form; |
1272
|
|
|
|
|
|
|
} |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
sub member_index($$) |
1275
|
|
|
|
|
|
|
{ |
1276
|
103
|
|
|
103
|
|
186
|
my ( $class, $member_name ) = @_; |
1277
|
103
|
100
|
|
|
|
214
|
return $class->index($member_name) if defined $class->members($member_name); |
1278
|
12
|
|
|
|
|
32
|
for my $parent ( grep ref $_, $class->parents ) |
1279
|
|
|
|
|
|
|
{ |
1280
|
12
|
|
|
|
|
27
|
my $index = member_index( $parent, $member_name ); |
1281
|
12
|
50
|
|
|
|
49
|
return $index if defined $index; |
1282
|
|
|
|
|
|
|
} |
1283
|
0
|
|
|
|
|
0
|
return undef; |
1284
|
|
|
|
|
|
|
} |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
sub accessible_member_regexps($;$) |
1287
|
|
|
|
|
|
|
{ |
1288
|
76
|
|
|
76
|
|
179
|
my ( $class, $disallow_private_members ) = @_; |
1289
|
76
|
|
|
|
|
112
|
my @members; |
1290
|
76
|
100
|
|
|
|
169
|
if ($disallow_private_members) |
1291
|
|
|
|
|
|
|
{ |
1292
|
15
|
|
|
|
|
37
|
@members = grep !$class->private( $_->name ), $class->members_values; |
1293
|
|
|
|
|
|
|
} |
1294
|
|
|
|
|
|
|
else |
1295
|
|
|
|
|
|
|
{ |
1296
|
61
|
|
|
|
|
205
|
@members = $class->members_values; |
1297
|
|
|
|
|
|
|
} |
1298
|
|
|
|
|
|
|
return ( |
1299
|
76
|
|
|
|
|
298
|
map( $_->method_regexp($class), @members ), |
1300
|
|
|
|
|
|
|
map( accessible_member_regexps( $_, 1 ), |
1301
|
|
|
|
|
|
|
grep( ref $_, $class->parents ) ) |
1302
|
|
|
|
|
|
|
); |
1303
|
|
|
|
|
|
|
} |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
sub accessible_members($;$) |
1306
|
|
|
|
|
|
|
{ |
1307
|
76
|
|
|
76
|
|
186
|
my ( $class, $disallow_private_members ) = @_; |
1308
|
76
|
|
|
|
|
119
|
my @members; |
1309
|
76
|
100
|
|
|
|
182
|
if ($disallow_private_members) |
1310
|
|
|
|
|
|
|
{ |
1311
|
15
|
|
|
|
|
34
|
@members = grep !$class->private( $_->name ), $class->members_values; |
1312
|
|
|
|
|
|
|
} |
1313
|
|
|
|
|
|
|
else |
1314
|
|
|
|
|
|
|
{ |
1315
|
61
|
|
|
|
|
136
|
@members = $class->members_values; |
1316
|
|
|
|
|
|
|
} |
1317
|
76
|
|
|
|
|
204
|
return ( @members, |
1318
|
|
|
|
|
|
|
map( accessible_members( $_, 1 ), grep( ref $_, $class->parents ) ) ); |
1319
|
|
|
|
|
|
|
} |
1320
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
sub accessible_accessor_regexps($;$) |
1322
|
|
|
|
|
|
|
{ |
1323
|
76
|
|
|
76
|
|
176
|
my ( $class, $disallow_private_members ) = @_; |
1324
|
76
|
|
|
|
|
132
|
my ( $member_name, @accessor_names ); |
1325
|
76
|
|
|
|
|
169
|
for my $member ( $class->members_values ) |
1326
|
|
|
|
|
|
|
{ |
1327
|
|
|
|
|
|
|
next |
1328
|
166
|
100
|
100
|
|
|
421
|
if $class->private( $member_name = $member->name ) |
1329
|
|
|
|
|
|
|
&& $disallow_private_members; |
1330
|
165
|
|
|
|
|
500
|
for my $accessor_name ( grep $class->include_method($_), |
1331
|
|
|
|
|
|
|
$member->accessor_names( $class, $member_name ) ) |
1332
|
|
|
|
|
|
|
{ |
1333
|
466
|
|
|
|
|
3514
|
$accessor_name =~ s/$member_name/($&)/; |
1334
|
466
|
|
|
|
|
1321
|
push @accessor_names, $accessor_name; |
1335
|
|
|
|
|
|
|
} |
1336
|
|
|
|
|
|
|
} |
1337
|
|
|
|
|
|
|
return ( |
1338
|
76
|
|
|
|
|
267
|
@accessor_names, |
1339
|
|
|
|
|
|
|
map( accessible_accessor_regexps( $_, 1 ), |
1340
|
|
|
|
|
|
|
grep( ref $_, $class->parents ) ) |
1341
|
|
|
|
|
|
|
); |
1342
|
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
sub accessible_user_defined_method_regexps($;$) |
1345
|
|
|
|
|
|
|
{ |
1346
|
76
|
|
|
76
|
|
168
|
my ( $class, $disallow_private_methods ) = @_; |
1347
|
|
|
|
|
|
|
return ( |
1348
|
|
|
|
|
|
|
( |
1349
|
76
|
100
|
|
|
|
426
|
$disallow_private_methods |
1350
|
|
|
|
|
|
|
? grep !$class->private($_), |
1351
|
|
|
|
|
|
|
$class->user_defined_methods_keys |
1352
|
|
|
|
|
|
|
: $class->user_defined_methods_keys |
1353
|
|
|
|
|
|
|
), |
1354
|
|
|
|
|
|
|
map( accessible_user_defined_method_regexps( $_, 1 ), |
1355
|
|
|
|
|
|
|
grep( ref $_, $class->parents ) ) |
1356
|
|
|
|
|
|
|
); |
1357
|
|
|
|
|
|
|
} |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
# Given element E and class C, return C if E is an |
1360
|
|
|
|
|
|
|
sub class_of($$;$) |
1361
|
|
|
|
|
|
|
{ # element of C; if not, search parents recursively. |
1362
|
39
|
|
|
39
|
|
85
|
my ( $element_name, $class, $disallow_private_members ) = @_; |
1363
|
39
|
100
|
100
|
|
|
75
|
return $class |
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1364
|
|
|
|
|
|
|
if ( defined $class->members($element_name) |
1365
|
|
|
|
|
|
|
|| defined $class->user_defined_methods($element_name) ) |
1366
|
|
|
|
|
|
|
&& ( !$disallow_private_members || !$class->private($element_name) ); |
1367
|
6
|
|
|
|
|
15
|
for my $parent ( grep ref $_, $class->parents ) |
1368
|
|
|
|
|
|
|
{ |
1369
|
6
|
|
|
|
|
16
|
my $c = class_of( $element_name, $parent, 1 ); |
1370
|
6
|
50
|
|
|
|
20
|
return $c if defined $c; |
1371
|
|
|
|
|
|
|
} |
1372
|
0
|
|
|
|
|
0
|
return undef; |
1373
|
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
package Class::Generate::Code_Checker; # This package encapsulates |
1376
|
|
|
|
|
|
|
$Class::Generate::Code_Checker::VERSION = '1.18'; |
1377
|
14
|
|
|
15
|
|
130
|
use strict; # checking for warnings and |
|
14
|
|
|
|
|
63
|
|
|
14
|
|
|
|
|
470
|
|
1378
|
14
|
|
|
15
|
|
97
|
use Carp; # errors in user-defined code. |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
13395
|
|
1379
|
|
|
|
|
|
|
|
1380
|
|
|
|
|
|
|
my $package_decl; |
1381
|
|
|
|
|
|
|
my $member_error_message = '%s, member "%s": In "%s" code: %s'; |
1382
|
|
|
|
|
|
|
my $method_error_message = '%s, method "%s": %s'; |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
sub create_code_checking_package($); |
1385
|
|
|
|
|
|
|
sub fragment_as_sub($$\@;\@); |
1386
|
|
|
|
|
|
|
sub collect_code_problems($$$$@); |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
# Check each user-defined code fragment in $class for errors. This includes |
1389
|
|
|
|
|
|
|
# pre, post, and assert code, as well as user-defined methods. Set |
1390
|
|
|
|
|
|
|
# $errors_found according to whether errors (not warnings) were found. |
1391
|
|
|
|
|
|
|
sub check_user_defined_code($$$$) |
1392
|
|
|
|
|
|
|
{ |
1393
|
61
|
|
|
61
|
|
169
|
my ( $class, $class_name_label, $warnings, $errors ) = @_; |
1394
|
61
|
|
|
|
|
143
|
my ( $code, $instance_var, @valid_variables, @class_vars, $w, $e, @members, |
1395
|
|
|
|
|
|
|
$problems_in_pre, %seen ); |
1396
|
61
|
|
|
|
|
189
|
create_code_checking_package $class; |
1397
|
|
|
|
|
|
|
@valid_variables = map { |
1398
|
61
|
100
|
|
|
|
299
|
$seen{ $_->name } ? () : do { $seen{ $_->name } = 1; $_->as_var } |
|
298
|
|
|
|
|
527
|
|
|
165
|
|
|
|
|
293
|
|
|
165
|
|
|
|
|
447
|
|
1399
|
|
|
|
|
|
|
} ( |
1400
|
|
|
|
|
|
|
( @members = $class->members_values ), |
1401
|
|
|
|
|
|
|
Class::Generate::Member_Names::accessible_members($class) |
1402
|
|
|
|
|
|
|
); |
1403
|
61
|
|
|
|
|
243
|
@class_vars = $class->class_vars; |
1404
|
61
|
|
|
|
|
196
|
$instance_var = $class->instance_var; |
1405
|
61
|
|
|
|
|
146
|
@$warnings = (); |
1406
|
61
|
|
|
|
|
113
|
undef $$errors; |
1407
|
|
|
|
|
|
|
|
1408
|
61
|
|
|
|
|
165
|
for my $member ( $class->constructor, @members ) |
1409
|
|
|
|
|
|
|
{ |
1410
|
194
|
100
|
|
|
|
473
|
if ( defined( $code = $member->pre ) ) |
1411
|
|
|
|
|
|
|
{ |
1412
|
0
|
|
|
|
|
0
|
$code = fragment_as_sub $code, $instance_var, @class_vars, |
1413
|
|
|
|
|
|
|
@valid_variables; |
1414
|
0
|
|
|
|
|
0
|
collect_code_problems $code, |
1415
|
|
|
|
|
|
|
$warnings, $errors, |
1416
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, 'pre'; |
1417
|
0
|
|
33
|
|
|
0
|
$problems_in_pre = @$warnings || $$errors; |
1418
|
|
|
|
|
|
|
} |
1419
|
|
|
|
|
|
|
|
1420
|
|
|
|
|
|
|
# Because post shares pre's scope, check post with pre prepended. |
1421
|
|
|
|
|
|
|
# Strip newlines in pre to preserve line numbers in post. |
1422
|
194
|
100
|
|
|
|
463
|
if ( defined( $code = $member->post ) ) |
1423
|
|
|
|
|
|
|
{ |
1424
|
13
|
|
|
|
|
36
|
my $pre = $member->pre; |
1425
|
13
|
50
|
66
|
|
|
50
|
if ( defined $pre && !$problems_in_pre ) |
1426
|
|
|
|
|
|
|
{ # Don't report errors |
1427
|
0
|
|
|
|
|
0
|
$pre =~ s/\n+/ /g; # in pre again. |
1428
|
0
|
|
|
|
|
0
|
$code = $pre . $code; |
1429
|
|
|
|
|
|
|
} |
1430
|
13
|
|
|
|
|
46
|
$code = fragment_as_sub $code, $instance_var, @class_vars, |
1431
|
|
|
|
|
|
|
@valid_variables; |
1432
|
13
|
|
|
|
|
46
|
collect_code_problems $code, |
1433
|
|
|
|
|
|
|
$warnings, $errors, |
1434
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, 'post'; |
1435
|
|
|
|
|
|
|
} |
1436
|
194
|
100
|
|
|
|
444
|
if ( defined( $code = $member->assert ) ) |
1437
|
|
|
|
|
|
|
{ |
1438
|
5
|
|
|
|
|
32
|
$code = fragment_as_sub "unless($code){die}", $instance_var, |
1439
|
|
|
|
|
|
|
@class_vars, @valid_variables; |
1440
|
5
|
|
|
|
|
19
|
collect_code_problems $code, |
1441
|
|
|
|
|
|
|
$warnings, $errors, |
1442
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, |
1443
|
|
|
|
|
|
|
'assert'; |
1444
|
|
|
|
|
|
|
} |
1445
|
|
|
|
|
|
|
} |
1446
|
61
|
|
|
|
|
187
|
for my $method ( $class->user_defined_methods_values ) |
1447
|
|
|
|
|
|
|
{ |
1448
|
28
|
100
|
|
|
|
215
|
if ( $method->isa('Class::Generate::Class_Method') ) |
1449
|
|
|
|
|
|
|
{ |
1450
|
2
|
|
|
|
|
13
|
$code = fragment_as_sub $method->body, $class->class_var, |
1451
|
|
|
|
|
|
|
@class_vars; |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
else |
1454
|
|
|
|
|
|
|
{ |
1455
|
26
|
|
|
|
|
71
|
$code = fragment_as_sub $method->body, $instance_var, @class_vars, |
1456
|
|
|
|
|
|
|
@valid_variables; |
1457
|
|
|
|
|
|
|
} |
1458
|
28
|
|
|
|
|
89
|
collect_code_problems $code, $warnings, $errors, $method_error_message, |
1459
|
|
|
|
|
|
|
$class_name_label, $method->name; |
1460
|
|
|
|
|
|
|
} |
1461
|
|
|
|
|
|
|
} |
1462
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
sub create_code_checking_package($) |
1464
|
|
|
|
|
|
|
{ # Each class with user-defined code gets |
1465
|
61
|
|
|
61
|
|
152
|
my $class = $_[0]; # its own package in which that code is |
1466
|
|
|
|
|
|
|
# evaluated. Create said package. |
1467
|
61
|
|
|
|
|
225
|
$package_decl = 'package ' . __PACKAGE__ . '::check::' . $class->name . ";"; |
1468
|
61
|
50
|
|
|
|
229
|
$package_decl .= 'use strict;' if $class->strict; |
1469
|
61
|
|
|
|
|
135
|
my $packages = ''; |
1470
|
61
|
50
|
|
|
|
136
|
if ( $class->check_params ) |
1471
|
|
|
|
|
|
|
{ |
1472
|
61
|
|
|
|
|
103
|
$packages .= 'use Carp;'; |
1473
|
61
|
|
|
|
|
217
|
$packages .= join( ';', $class->warnings_pragmas ); |
1474
|
|
|
|
|
|
|
} |
1475
|
61
|
|
|
|
|
287
|
$packages .= join( '', map( 'use ' . $_ . ';', $class->use_packages ) ); |
1476
|
61
|
100
|
|
|
|
160
|
$packages .= 'use vars qw(@ISA);' if $class->parents; |
1477
|
13
|
|
|
13
|
|
100
|
eval $package_decl . $packages; |
|
13
|
|
|
13
|
|
21
|
|
|
13
|
|
|
13
|
|
417
|
|
|
13
|
|
|
12
|
|
70
|
|
|
13
|
|
|
12
|
|
26
|
|
|
13
|
|
|
12
|
|
969
|
|
|
13
|
|
|
12
|
|
89
|
|
|
13
|
|
|
10
|
|
22
|
|
|
13
|
|
|
9
|
|
765
|
|
|
12
|
|
|
8
|
|
89
|
|
|
12
|
|
|
8
|
|
27
|
|
|
12
|
|
|
8
|
|
475
|
|
|
12
|
|
|
7
|
|
82
|
|
|
12
|
|
|
7
|
|
25
|
|
|
12
|
|
|
7
|
|
661
|
|
|
12
|
|
|
15
|
|
77
|
|
|
12
|
|
|
5
|
|
29
|
|
|
12
|
|
|
8
|
|
398
|
|
|
12
|
|
|
|
|
101
|
|
|
12
|
|
|
|
|
36
|
|
|
12
|
|
|
|
|
437
|
|
|
10
|
|
|
|
|
63
|
|
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
629
|
|
|
9
|
|
|
|
|
64
|
|
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
233
|
|
|
8
|
|
|
|
|
67
|
|
|
8
|
|
|
|
|
21
|
|
|
8
|
|
|
|
|
323
|
|
|
8
|
|
|
|
|
49
|
|
|
8
|
|
|
|
|
22
|
|
|
8
|
|
|
|
|
445
|
|
|
8
|
|
|
|
|
58
|
|
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
249
|
|
|
7
|
|
|
|
|
45
|
|
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
595
|
|
|
7
|
|
|
|
|
55
|
|
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
315
|
|
|
7
|
|
|
|
|
41
|
|
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
284
|
|
|
61
|
|
|
|
|
5783
|
|
|
15
|
|
|
|
|
420
|
|
|
15
|
|
|
|
|
42
|
|
|
4
|
|
|
|
|
28
|
|
|
4
|
|
|
|
|
22
|
|
|
11
|
|
|
|
|
27
|
|
|
8
|
|
|
|
|
23
|
|
|
4
|
|
|
|
|
88
|
|
|
3
|
|
|
|
|
38
|
|
|
3
|
|
|
|
|
72
|
|
1478
|
|
|
|
|
|
|
} |
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
# Evaluate a code fragment, passing on |
1481
|
|
|
|
|
|
|
sub collect_code_problems($$$$@) |
1482
|
|
|
|
|
|
|
{ # warnings and errors. |
1483
|
46
|
|
|
46
|
|
148
|
my ( $code_form, $warnings, $errors, $error_message, @params ) = @_; |
1484
|
46
|
|
|
|
|
83
|
my @warnings; |
1485
|
46
|
|
|
1
|
|
351
|
local $SIG{__WARN__} = sub { push @warnings, $_[0] }; |
|
0
|
|
|
|
|
0
|
|
1486
|
46
|
|
|
|
|
141
|
local $SIG{__DIE__}; |
1487
|
10
|
|
|
10
|
|
66
|
eval $package_decl . $code_form; |
|
10
|
|
|
10
|
|
23
|
|
|
10
|
|
|
5
|
|
761
|
|
|
9
|
|
|
|
|
68
|
|
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
682
|
|
|
46
|
|
|
|
|
3435
|
|
|
5
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
12
|
|
1488
|
46
|
|
|
|
|
256
|
push @$warnings, |
1489
|
|
|
|
|
|
|
map( filtered_message( $error_message, $_, @params ), @warnings ); |
1490
|
46
|
100
|
|
|
|
420
|
$$errors .= filtered_message( $error_message, $@, @params ) if $@; |
1491
|
|
|
|
|
|
|
} |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
sub filtered_message |
1494
|
|
|
|
|
|
|
{ # Clean up errors and messages |
1495
|
0
|
|
|
0
|
|
0
|
my ( $message, $error, @params ) = @_; # a little by removing the |
1496
|
0
|
|
|
|
|
0
|
$error =~ s/\(eval \d+\) //g; # "(eval N)" forms that perl |
1497
|
0
|
|
|
|
|
0
|
return sprintf( $message, @params, $error ); # inserts. |
1498
|
|
|
|
|
|
|
} |
1499
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
sub fragment_as_sub($$\@;\@) |
1501
|
|
|
|
|
|
|
{ |
1502
|
46
|
|
|
46
|
|
137
|
my ( $code, $id_var, $class_vars, $valid_vars ) = @_; |
1503
|
46
|
|
|
|
|
78
|
my $form; |
1504
|
46
|
|
|
|
|
165
|
$form = "sub{my $id_var;"; |
1505
|
46
|
100
|
|
|
|
137
|
if ( $#$class_vars >= 0 ) |
1506
|
|
|
|
|
|
|
{ |
1507
|
4
|
50
|
|
|
|
19
|
$form .= 'my(' |
1508
|
|
|
|
|
|
|
. join( ',', map( ( ref $_ ? keys %$_ : $_ ), @$class_vars ) ) |
1509
|
|
|
|
|
|
|
. ');'; |
1510
|
|
|
|
|
|
|
} |
1511
|
46
|
100
|
100
|
|
|
224
|
if ( $valid_vars && $#$valid_vars >= 0 ) |
1512
|
|
|
|
|
|
|
{ |
1513
|
42
|
|
|
|
|
158
|
$form .= 'my(' . join( ',', @$valid_vars ) . ');'; |
1514
|
|
|
|
|
|
|
} |
1515
|
46
|
|
|
|
|
172
|
$form .= '{' . $code . '}};'; |
1516
|
|
|
|
|
|
|
} |
1517
|
|
|
|
|
|
|
|
1518
|
|
|
|
|
|
|
package Class::Generate::Array; # Given a string or an ARRAY, return an |
1519
|
|
|
|
|
|
|
$Class::Generate::Array::VERSION = '1.18'; |
1520
|
16
|
|
|
15
|
|
131
|
use strict; # object that is either the ARRAY or |
|
16
|
|
|
|
|
40
|
|
|
16
|
|
|
|
|
591
|
|
1521
|
15
|
|
|
14
|
|
86
|
use Carp; # the string made into an ARRAY by |
|
15
|
|
|
|
|
29
|
|
|
15
|
|
|
|
|
3037
|
|
1522
|
|
|
|
|
|
|
# splitting the string on white space. |
1523
|
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
|
sub new |
1525
|
|
|
|
|
|
|
{ |
1526
|
63
|
|
|
63
|
|
139
|
my $class = shift; |
1527
|
63
|
|
|
|
|
99
|
my $self; |
1528
|
63
|
100
|
|
|
|
199
|
if ( !ref $_[0] ) |
|
|
50
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
{ |
1530
|
60
|
|
|
|
|
336
|
$self = [ split /\s+/, $_[0] ]; |
1531
|
|
|
|
|
|
|
} |
1532
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa( $_[0], 'ARRAY' ) ) |
1533
|
|
|
|
|
|
|
{ |
1534
|
3
|
|
|
|
|
10
|
$self = $_[0]; |
1535
|
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
|
else |
1537
|
|
|
|
|
|
|
{ |
1538
|
0
|
|
|
|
|
0
|
croak 'Expected string or array reference'; |
1539
|
|
|
|
|
|
|
} |
1540
|
63
|
|
|
|
|
156
|
bless $self, $class; |
1541
|
63
|
|
|
|
|
147
|
return $self; |
1542
|
|
|
|
|
|
|
} |
1543
|
|
|
|
|
|
|
|
1544
|
|
|
|
|
|
|
sub values |
1545
|
|
|
|
|
|
|
{ |
1546
|
125
|
|
|
125
|
|
201
|
my $self = shift; |
1547
|
125
|
|
|
|
|
573
|
return @$self; |
1548
|
|
|
|
|
|
|
} |
1549
|
|
|
|
|
|
|
|
1550
|
|
|
|
|
|
|
package Class::Generate::Hash; # Given a string or a HASH and a key |
1551
|
|
|
|
|
|
|
$Class::Generate::Hash::VERSION = '1.18'; |
1552
|
14
|
|
|
14
|
|
112
|
use strict; # name, return an object that is either |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
456
|
|
1553
|
14
|
|
|
16
|
|
87
|
use Carp; # the HASH or a HASH of the form |
|
14
|
|
|
|
|
44
|
|
|
14
|
|
|
|
|
2615
|
|
1554
|
|
|
|
|
|
|
# (key => string). Also, if the object |
1555
|
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
|
sub new |
1557
|
|
|
|
|
|
|
{ # is a HASH, it *must* contain the key. |
1558
|
162
|
|
|
162
|
|
259
|
my $class = shift; |
1559
|
162
|
|
|
|
|
217
|
my $self; |
1560
|
162
|
|
|
|
|
312
|
my ( $value, $key ) = @_; |
1561
|
162
|
100
|
|
|
|
324
|
if ( !ref $value ) |
1562
|
|
|
|
|
|
|
{ |
1563
|
104
|
|
|
|
|
244
|
$self = { $key => $value }; |
1564
|
|
|
|
|
|
|
} |
1565
|
|
|
|
|
|
|
else |
1566
|
|
|
|
|
|
|
{ |
1567
|
58
|
50
|
|
|
|
170
|
croak 'Expected string or hash reference' |
1568
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $value, 'HASH' ); |
1569
|
58
|
100
|
|
|
|
313
|
croak qq|Missing "$key"| unless exists $value->{$key}; |
1570
|
57
|
|
|
|
|
90
|
$self = $value; |
1571
|
|
|
|
|
|
|
} |
1572
|
161
|
|
|
|
|
277
|
bless $self, $class; |
1573
|
161
|
|
|
|
|
681
|
return $self; |
1574
|
|
|
|
|
|
|
} |
1575
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
package Class::Generate::Support; # Miscellaneous support routines. |
1577
|
|
|
|
|
|
|
$Class::Generate::Support::VERSION = '1.18'; |
1578
|
15
|
|
|
15
|
|
113
|
no strict; # Definitely NOT strict! |
|
15
|
|
|
|
|
37
|
|
|
15
|
|
|
|
|
4136
|
|
1579
|
|
|
|
|
|
|
# Return the superclass of $class that |
1580
|
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
|
sub class_containing_method |
1582
|
|
|
|
|
|
|
{ # contains the method that the form |
1583
|
46
|
|
|
46
|
|
104
|
my ( $method, $class ) = @_; # (new $class)->$method would invoke. |
1584
|
46
|
|
|
|
|
111
|
for my $parent ( $class->parents ) |
1585
|
|
|
|
|
|
|
{ # Return undef if no such class exists. |
1586
|
15
|
50
|
|
|
|
71
|
local *stab = |
1587
|
|
|
|
|
|
|
eval( '*' . ( ref $parent ? $parent->name : $parent ) . '::' ); |
1588
|
15
|
50
|
33
|
|
|
93
|
if ( |
1589
|
|
|
|
|
|
|
exists $stab{$method} |
1590
|
15
|
|
|
|
|
45
|
&& do { local *method_entry = $stab{$method}; defined &method_entry } |
|
15
|
|
|
|
|
70
|
|
1591
|
|
|
|
|
|
|
) |
1592
|
|
|
|
|
|
|
{ |
1593
|
15
|
|
|
|
|
49
|
return $parent; |
1594
|
|
|
|
|
|
|
} |
1595
|
0
|
|
|
|
|
0
|
return class_containing_method( $method, $parent ); |
1596
|
|
|
|
|
|
|
} |
1597
|
31
|
|
|
|
|
86
|
return undef; |
1598
|
|
|
|
|
|
|
} |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
my %map = ( '@' => 'ARRAY', '%' => 'HASH' ); |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
sub verify_value($$) |
1603
|
|
|
|
|
|
|
{ # Die if a given value (ref or string) |
1604
|
1
|
|
|
1
|
|
3
|
my ( $value, $type ) = @_; # is not the specified type. |
1605
|
|
|
|
|
|
|
# The following code is not wrong, but it could be smarter. |
1606
|
1
|
50
|
|
|
|
6
|
if ( $type =~ /^\w/ ) |
1607
|
|
|
|
|
|
|
{ |
1608
|
0
|
|
|
|
|
0
|
$map{$type} = $type; |
1609
|
|
|
|
|
|
|
} |
1610
|
|
|
|
|
|
|
else |
1611
|
|
|
|
|
|
|
{ |
1612
|
1
|
|
|
|
|
3
|
$type = substr $type, 0, 1; |
1613
|
|
|
|
|
|
|
} |
1614
|
1
|
50
|
|
|
|
5
|
return if $type eq '$'; |
1615
|
0
|
|
|
0
|
|
0
|
local $SIG{__WARN__} = sub { }; |
1616
|
0
|
|
|
|
|
0
|
my $result; |
1617
|
0
|
0
|
|
|
|
0
|
$result = ref $value ? $value : eval $value; |
1618
|
0
|
0
|
|
|
|
0
|
die "Wrong type" if !UNIVERSAL::isa( $result, $map{$type} ); |
1619
|
|
|
|
|
|
|
} |
1620
|
|
|
|
|
|
|
|
1621
|
14
|
|
|
14
|
|
106
|
use strict; |
|
14
|
|
|
|
|
261
|
|
|
14
|
|
|
|
|
2499
|
|
1622
|
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
|
sub comment_form |
1624
|
|
|
|
|
|
|
{ # Given arbitrary text, return a form that |
1625
|
1
|
|
|
1
|
|
2
|
my $comment = $_[0]; # is a valid Perl comment of that text. |
1626
|
1
|
|
|
|
|
7
|
$comment =~ s/^/# /mg; |
1627
|
1
|
50
|
|
|
|
6
|
$comment .= "\n" if substr( $comment, -1, 1 ) ne "\n"; |
1628
|
1
|
|
|
|
|
3
|
return $comment; |
1629
|
|
|
|
|
|
|
} |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
sub my_decl_form |
1632
|
|
|
|
|
|
|
{ # Given a non-empty set of variable names, |
1633
|
8
|
|
|
8
|
|
23
|
my @vars = @_; # return a form declaring them as "my" variables. |
1634
|
|
|
|
|
|
|
return |
1635
|
8
|
100
|
|
|
|
71
|
'my ' |
1636
|
|
|
|
|
|
|
. ( $#vars == 0 ? $vars[0] : '(' . join( ', ', @vars ) . ')' ) . ";\n"; |
1637
|
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
package Class::Generate::Member; # A virtual class describing class |
1640
|
|
|
|
|
|
|
$Class::Generate::Member::VERSION = '1.18'; |
1641
|
14
|
|
|
14
|
|
101
|
use strict; # members. |
|
14
|
|
|
|
|
56
|
|
|
14
|
|
|
|
|
26474
|
|
1642
|
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
|
sub new |
1644
|
|
|
|
|
|
|
{ |
1645
|
195
|
|
|
195
|
|
340
|
my $class = shift; |
1646
|
195
|
|
|
|
|
617
|
my $self = { name => $_[0], @_[ 1 .. $#_ ] }; |
1647
|
195
|
|
|
|
|
374
|
bless $self, $class; |
1648
|
195
|
|
|
|
|
360
|
return $self; |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
|
sub name |
1652
|
|
|
|
|
|
|
{ |
1653
|
3120
|
|
|
3120
|
|
4309
|
my $self = shift; |
1654
|
3120
|
|
|
|
|
7515
|
return $self->{'name'}; |
1655
|
|
|
|
|
|
|
} |
1656
|
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
|
sub default |
1658
|
|
|
|
|
|
|
{ |
1659
|
228
|
|
|
228
|
|
340
|
my $self = shift; |
1660
|
228
|
100
|
|
|
|
766
|
return $self->{'default'} if $#_ == -1; |
1661
|
1
|
|
|
|
|
4
|
$self->{'default'} = $_[0]; |
1662
|
|
|
|
|
|
|
} |
1663
|
|
|
|
|
|
|
|
1664
|
|
|
|
|
|
|
sub base |
1665
|
|
|
|
|
|
|
{ |
1666
|
880
|
|
|
880
|
|
1211
|
my $self = shift; |
1667
|
880
|
50
|
|
|
|
3124
|
return $self->{'base'} if $#_ == -1; |
1668
|
0
|
|
|
|
|
0
|
$self->{'base'} = $_[0]; |
1669
|
|
|
|
|
|
|
} |
1670
|
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
sub assert |
1672
|
|
|
|
|
|
|
{ |
1673
|
556
|
|
|
556
|
|
803
|
my $self = shift; |
1674
|
556
|
100
|
|
|
|
1896
|
return $self->{'assert'} if $#_ == -1; |
1675
|
3
|
|
|
|
|
19
|
$self->{'assert'} = $_[0]; |
1676
|
|
|
|
|
|
|
} |
1677
|
|
|
|
|
|
|
|
1678
|
|
|
|
|
|
|
sub post |
1679
|
|
|
|
|
|
|
{ |
1680
|
497
|
|
|
497
|
|
700
|
my $self = shift; |
1681
|
497
|
100
|
|
|
|
1619
|
return $self->{'post'} if $#_ == -1; |
1682
|
4
|
|
|
|
|
10
|
$self->{'post'} = possibly_append_semicolon_to( $_[0] ); |
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
|
1685
|
|
|
|
|
|
|
sub pre |
1686
|
|
|
|
|
|
|
{ |
1687
|
420
|
|
|
420
|
|
600
|
my $self = shift; |
1688
|
420
|
50
|
|
|
|
1302
|
return $self->{'pre'} if $#_ == -1; |
1689
|
0
|
|
|
|
|
0
|
$self->{'pre'} = possibly_append_semicolon_to( $_[0] ); |
1690
|
|
|
|
|
|
|
} |
1691
|
|
|
|
|
|
|
|
1692
|
|
|
|
|
|
|
sub possibly_append_semicolon_to |
1693
|
|
|
|
|
|
|
{ # If user omits a trailing semicolon |
1694
|
4
|
|
|
4
|
|
6
|
my $code = $_[0]; # (or doesn't use braces), add one. |
1695
|
4
|
50
|
|
|
|
20
|
if ( $code !~ /[;\}]\s*\Z/s ) |
1696
|
|
|
|
|
|
|
{ |
1697
|
0
|
|
|
|
|
0
|
$code =~ s/\s*\Z/;$&/s; |
1698
|
|
|
|
|
|
|
} |
1699
|
4
|
|
|
|
|
37
|
return $code; |
1700
|
|
|
|
|
|
|
} |
1701
|
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
|
sub comment |
1703
|
|
|
|
|
|
|
{ |
1704
|
132
|
|
|
132
|
|
207
|
my $self = shift; |
1705
|
132
|
|
|
|
|
373
|
return $self->{'comment'}; |
1706
|
|
|
|
|
|
|
} |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
sub key |
1709
|
|
|
|
|
|
|
{ |
1710
|
134
|
|
|
134
|
|
214
|
my $self = shift; |
1711
|
134
|
100
|
|
|
|
562
|
return $self->{'key'} if $#_ == -1; |
1712
|
3
|
|
|
|
|
16
|
$self->{'key'} = $_[0]; |
1713
|
|
|
|
|
|
|
} |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
sub nocopy |
1716
|
|
|
|
|
|
|
{ |
1717
|
98
|
|
|
98
|
|
150
|
my $self = shift; |
1718
|
98
|
100
|
|
|
|
389
|
return $self->{'nocopy'} if $#_ == -1; |
1719
|
2
|
|
|
|
|
9
|
$self->{'nocopy'} = $_[0]; |
1720
|
|
|
|
|
|
|
} |
1721
|
|
|
|
|
|
|
|
1722
|
|
|
|
|
|
|
sub assertion |
1723
|
|
|
|
|
|
|
{ # Return a form that croaks if |
1724
|
7
|
|
|
7
|
|
12
|
my $self = shift; # the member's assertion fails. |
1725
|
7
|
|
|
|
|
14
|
my $class = $_[0]; |
1726
|
7
|
|
|
|
|
13
|
my $assertion = $self->{'assert'}; |
1727
|
7
|
50
|
|
|
|
20
|
return undef if !defined $assertion; |
1728
|
7
|
|
|
|
|
15
|
my $quoted_form = $assertion; |
1729
|
7
|
|
|
|
|
18
|
$quoted_form =~ s/'/\\'/g; |
1730
|
7
|
|
|
|
|
20
|
$assertion = Class::Generate::Member_Names::substituted($assertion); |
1731
|
|
|
|
|
|
|
return |
1732
|
7
|
|
|
|
|
33
|
qq|unless ( $assertion ) { croak '| |
1733
|
|
|
|
|
|
|
. $self->name_form($class) |
1734
|
|
|
|
|
|
|
. qq|Failed assertion: $quoted_form' }|; |
1735
|
|
|
|
|
|
|
} |
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
sub param_message |
1738
|
|
|
|
|
|
|
{ # Encapsulate the messages for |
1739
|
84
|
|
|
84
|
|
130
|
my $self = shift; # incorrect parameters. |
1740
|
84
|
|
|
|
|
112
|
my $class = $_[0]; |
1741
|
84
|
|
|
|
|
144
|
my $name = $self->name; |
1742
|
84
|
|
|
|
|
178
|
my $prefix_form = q|croak '| . $class->name . '::new' . ': '; |
1743
|
|
|
|
|
|
|
$class->required($name) && !$self->default and do |
1744
|
84
|
100
|
66
|
|
|
159
|
{ |
1745
|
31
|
100
|
|
|
|
82
|
return $prefix_form . qq|Missing or invalid value for $name'| |
1746
|
|
|
|
|
|
|
if $self->can_be_invalid; |
1747
|
25
|
|
|
|
|
114
|
return $prefix_form . qq|Missing value for required member $name'|; |
1748
|
|
|
|
|
|
|
}; |
1749
|
|
|
|
|
|
|
$self->can_be_invalid and do |
1750
|
53
|
50
|
|
|
|
115
|
{ |
1751
|
53
|
|
|
|
|
283
|
return $prefix_form . qq|Invalid value for $name'|; |
1752
|
|
|
|
|
|
|
}; |
1753
|
|
|
|
|
|
|
} |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
sub param_test |
1756
|
|
|
|
|
|
|
{ # Return a form that dies if a constructor |
1757
|
84
|
|
|
84
|
|
147
|
my $self = shift; # parameter is not correctly passed. |
1758
|
84
|
|
|
|
|
129
|
my $class = $_[0]; |
1759
|
84
|
|
|
|
|
251
|
my $name = $self->name; |
1760
|
84
|
|
|
|
|
179
|
my $param = $class->constructor->style->ref($name); |
1761
|
84
|
|
|
|
|
260
|
my $exists = |
1762
|
|
|
|
|
|
|
$class->constructor->style->existence_test($name) . ' ' . $param; |
1763
|
|
|
|
|
|
|
|
1764
|
84
|
|
|
|
|
213
|
my $form = ''; |
1765
|
84
|
100
|
66
|
|
|
173
|
if ( $class->required($name) && !$self->default ) |
|
|
50
|
|
|
|
|
|
1766
|
|
|
|
|
|
|
{ |
1767
|
31
|
|
|
|
|
81
|
$form .= $self->param_message($class) . ' unless ' . $exists; |
1768
|
31
|
100
|
|
|
|
63
|
$form .= ' && ' . $self->valid_value_form($param) |
1769
|
|
|
|
|
|
|
if $self->can_be_invalid; |
1770
|
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
elsif ( $self->can_be_invalid ) |
1772
|
|
|
|
|
|
|
{ |
1773
|
53
|
|
|
|
|
155
|
$form .= |
1774
|
|
|
|
|
|
|
$self->param_message($class) |
1775
|
|
|
|
|
|
|
. ' unless ! ' |
1776
|
|
|
|
|
|
|
. $exists . ' || ' |
1777
|
|
|
|
|
|
|
. $self->valid_value_form($param); |
1778
|
|
|
|
|
|
|
} |
1779
|
84
|
|
|
|
|
366
|
return $form . ';'; |
1780
|
|
|
|
|
|
|
} |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
sub form |
1783
|
|
|
|
|
|
|
{ # Return a form for a member and all |
1784
|
132
|
|
|
132
|
|
229
|
my $self = shift; # its relevant associated accessors. |
1785
|
132
|
|
|
|
|
183
|
my $class = $_[0]; |
1786
|
132
|
|
|
|
|
243
|
my ( $element, $exists, $lvalue, $values, $form, $body, $member_name ); |
1787
|
132
|
|
|
|
|
249
|
$element = $class->instance_var . '->' |
1788
|
|
|
|
|
|
|
. $class->index( $member_name = $self->name ); |
1789
|
132
|
|
|
|
|
359
|
$exists = $class->existence_test . ' ' . $element; |
1790
|
132
|
100
|
|
|
|
644
|
$lvalue = $self->lvalue('$_[0]') if $self->can('lvalue'); |
1791
|
132
|
100
|
|
|
|
473
|
$values = $self->values('$_[0]') if $self->can('values'); |
1792
|
|
|
|
|
|
|
|
1793
|
132
|
|
|
|
|
228
|
$form = ''; |
1794
|
132
|
50
|
|
|
|
387
|
$form .= Class::Generate::Support::comment_form( $self->comment ) |
1795
|
|
|
|
|
|
|
if defined $self->comment; |
1796
|
|
|
|
|
|
|
|
1797
|
132
|
50
|
|
|
|
298
|
if ( $class->include_method($member_name) ) |
1798
|
|
|
|
|
|
|
{ |
1799
|
132
|
|
|
|
|
234
|
$body = ''; |
1800
|
132
|
|
|
|
|
398
|
for my $param_form ( $self->member_forms($class) ) |
1801
|
|
|
|
|
|
|
{ |
1802
|
299
|
|
|
|
|
912
|
$body .= $self->$param_form( $class, $element, $exists, $lvalue, |
1803
|
|
|
|
|
|
|
$values ); |
1804
|
|
|
|
|
|
|
} |
1805
|
132
|
50
|
|
|
|
330
|
$body .= ' ' . $self->param_count_error_form($class) . ";\n" |
1806
|
|
|
|
|
|
|
if $class->check_params; |
1807
|
132
|
|
|
|
|
393
|
$form .= $class->sub_form( $member_name, $member_name, $body ); |
1808
|
|
|
|
|
|
|
} |
1809
|
132
|
|
|
|
|
436
|
for my $a ( grep $_ ne $member_name, |
1810
|
|
|
|
|
|
|
$self->accessor_names( $class, $member_name ) ) |
1811
|
|
|
|
|
|
|
{ |
1812
|
268
|
100
|
|
|
|
5174
|
$a =~ s/^([a-z]+)_$member_name$/$1_form/ |
1813
|
|
|
|
|
|
|
|| $a =~ s/^${member_name}_([a-z]+)$/$1_form/; |
1814
|
268
|
|
|
|
|
1177
|
$form .= $self->$a( $class, $element, $member_name, $exists ); |
1815
|
|
|
|
|
|
|
} |
1816
|
132
|
|
|
|
|
734
|
return $form; |
1817
|
|
|
|
|
|
|
} |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
sub invalid_value_assignment_message |
1820
|
|
|
|
|
|
|
{ # Return a form that dies, reporting |
1821
|
78
|
|
|
78
|
|
124
|
my $self = shift; # a parameter that's not of the |
1822
|
78
|
|
|
|
|
114
|
my $class = $_[0]; # correct type for its element. |
1823
|
|
|
|
|
|
|
return |
1824
|
78
|
|
|
|
|
227
|
'croak \'' |
1825
|
|
|
|
|
|
|
. $self->name_form($class) |
1826
|
|
|
|
|
|
|
. 'Invalid parameter value (expected ' |
1827
|
|
|
|
|
|
|
. $self->expected_type_form . ')\''; |
1828
|
|
|
|
|
|
|
} |
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
sub valid_value_test_form |
1831
|
|
|
|
|
|
|
{ # Return a form that dies unless |
1832
|
63
|
|
|
63
|
|
121
|
my $self = shift; # a value is of the correct type |
1833
|
63
|
|
|
|
|
90
|
my $class = shift; # for the member. |
1834
|
|
|
|
|
|
|
return |
1835
|
63
|
|
|
|
|
206
|
$self->invalid_value_assignment_message($class) |
1836
|
|
|
|
|
|
|
. ' unless ' |
1837
|
|
|
|
|
|
|
. $self->valid_value_form(@_) . ';'; |
1838
|
|
|
|
|
|
|
} |
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
sub param_must_be_checked |
1841
|
|
|
|
|
|
|
{ |
1842
|
118
|
|
|
118
|
|
200
|
my $self = shift; |
1843
|
118
|
|
|
|
|
170
|
my $class = $_[0]; |
1844
|
118
|
|
100
|
|
|
253
|
return ( $class->required( $self->name ) && !defined $self->default ) |
1845
|
|
|
|
|
|
|
|| $self->can_be_invalid; |
1846
|
|
|
|
|
|
|
} |
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
sub maybe_guarded |
1849
|
|
|
|
|
|
|
{ # If parameter checking is enabled, guard a |
1850
|
106
|
|
|
106
|
|
173
|
my $self = shift; # form to check against a parameter |
1851
|
106
|
|
|
|
|
226
|
my ( $form, $param_no, $class ) = @_; # count. In any case, format the form |
1852
|
106
|
50
|
|
|
|
201
|
if ( $class->check_params ) |
1853
|
|
|
|
|
|
|
{ # a little. |
1854
|
106
|
|
|
|
|
656
|
$form =~ s/^/\t/mg; |
1855
|
106
|
|
|
|
|
512
|
return " \$#_ == $param_no\tand do {\n$form };\n"; |
1856
|
|
|
|
|
|
|
} |
1857
|
|
|
|
|
|
|
else |
1858
|
|
|
|
|
|
|
{ |
1859
|
0
|
|
|
|
|
0
|
$form =~ s/^/ /mg; |
1860
|
0
|
|
|
|
|
0
|
return $form; |
1861
|
|
|
|
|
|
|
} |
1862
|
|
|
|
|
|
|
} |
1863
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
sub accessor_names |
1865
|
|
|
|
|
|
|
{ |
1866
|
315
|
|
|
315
|
|
474
|
my $self = shift; |
1867
|
315
|
|
|
|
|
502
|
my ( $class, $name ) = @_; |
1868
|
315
|
100
|
100
|
|
|
644
|
return !( $class->readonly($name) || $class->required($name) ) |
1869
|
|
|
|
|
|
|
? ("undef_$name") |
1870
|
|
|
|
|
|
|
: (); |
1871
|
|
|
|
|
|
|
} |
1872
|
|
|
|
|
|
|
|
1873
|
|
|
|
|
|
|
sub undef_form |
1874
|
|
|
|
|
|
|
{ # Return the form to undefine |
1875
|
88
|
|
|
88
|
|
154
|
my $self = shift; # a member. |
1876
|
88
|
|
|
|
|
279
|
my ( $class, $element, $member_name ) = @_[ 0 .. 2 ]; |
1877
|
88
|
|
|
|
|
263
|
return $class->sub_form( |
1878
|
|
|
|
|
|
|
$member_name, |
1879
|
|
|
|
|
|
|
'undef_' . $member_name, |
1880
|
|
|
|
|
|
|
' ' . $class->undef_form . " $element;\n" |
1881
|
|
|
|
|
|
|
); |
1882
|
|
|
|
|
|
|
} |
1883
|
|
|
|
|
|
|
|
1884
|
|
|
|
|
|
|
sub param_count_error_form |
1885
|
|
|
|
|
|
|
{ # Return a form that standardizes |
1886
|
132
|
|
|
132
|
|
216
|
my $self = shift; # the message for dieing because |
1887
|
132
|
|
|
|
|
211
|
my $class = $_[0]; # of an incorrect parameter count. |
1888
|
|
|
|
|
|
|
return |
1889
|
132
|
|
|
|
|
313
|
q|croak '| |
1890
|
|
|
|
|
|
|
. $self->name_form($class) |
1891
|
|
|
|
|
|
|
. q|Invalid number of parameters (', ($#_+1), ')'|; |
1892
|
|
|
|
|
|
|
} |
1893
|
|
|
|
|
|
|
|
1894
|
|
|
|
|
|
|
sub name_form |
1895
|
|
|
|
|
|
|
{ # Standardize a method name |
1896
|
310
|
|
|
310
|
|
476
|
my $self = shift; # for error messages. |
1897
|
310
|
|
|
|
|
457
|
my $class = $_[0]; |
1898
|
310
|
|
|
|
|
567
|
return $class->name . '::' . $self->name . ': '; |
1899
|
|
|
|
|
|
|
} |
1900
|
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
|
sub param_assignment_form |
1902
|
|
|
|
|
|
|
{ # Return a form that assigns a parameter |
1903
|
118
|
|
|
118
|
|
189
|
my $self = shift; # value to the member. |
1904
|
118
|
|
|
|
|
224
|
my ( $class, $style ) = @_; |
1905
|
118
|
|
|
|
|
183
|
my ( $name, $element, $param, $default, $exists ); |
1906
|
118
|
|
|
|
|
224
|
$name = $self->name; |
1907
|
118
|
|
|
|
|
249
|
$element = $class->instance_var . '->' . $class->index($name); |
1908
|
118
|
|
|
|
|
292
|
$param = $style->ref($name); |
1909
|
118
|
|
|
|
|
306
|
$default = $self->default; |
1910
|
118
|
|
|
|
|
275
|
$exists = $style->existence_test($name) . ' ' . $param; |
1911
|
118
|
|
|
|
|
236
|
my $form = " $element = "; |
1912
|
|
|
|
|
|
|
|
1913
|
118
|
50
|
66
|
|
|
336
|
if ( defined $default ) |
|
|
100
|
|
|
|
|
|
1914
|
|
|
|
|
|
|
{ |
1915
|
0
|
|
|
|
|
0
|
$form .= "$exists ? $param : $default"; |
1916
|
|
|
|
|
|
|
} |
1917
|
|
|
|
|
|
|
elsif ( $class->check_params && $class->required($name) ) |
1918
|
|
|
|
|
|
|
{ |
1919
|
31
|
|
|
|
|
69
|
$form .= $param; |
1920
|
|
|
|
|
|
|
} |
1921
|
|
|
|
|
|
|
else |
1922
|
|
|
|
|
|
|
{ |
1923
|
87
|
|
|
|
|
200
|
$form .= "$param if $exists"; |
1924
|
|
|
|
|
|
|
} |
1925
|
118
|
|
|
|
|
380
|
return $form . ";\n"; |
1926
|
|
|
|
|
|
|
} |
1927
|
|
|
|
|
|
|
|
1928
|
|
|
|
|
|
|
sub default_assignment_form |
1929
|
|
|
|
|
|
|
{ # Return a form that assigns a default value |
1930
|
1
|
|
|
1
|
|
14
|
my $self = shift; # to a member. |
1931
|
1
|
|
|
|
|
4
|
my $class = $_[0]; |
1932
|
1
|
|
|
|
|
2
|
my $element; |
1933
|
1
|
|
|
|
|
4
|
$element = $class->instance_var . '->' . $class->index( $self->name ); |
1934
|
1
|
|
|
|
|
5
|
return " $element = " . $self->default . ";\n"; |
1935
|
|
|
|
|
|
|
} |
1936
|
|
|
|
|
|
|
|
1937
|
|
|
|
|
|
|
package Class::Generate::Scalar_Member; # A Member subclass for |
1938
|
|
|
|
|
|
|
$Class::Generate::Scalar_Member::VERSION = '1.18'; |
1939
|
14
|
|
|
15
|
|
158
|
use strict; # scalar class members. |
|
14
|
|
|
|
|
40
|
|
|
14
|
|
|
|
|
1221
|
|
1940
|
14
|
|
|
14
|
|
96
|
use vars qw(@ISA); # accessor accepts 0 or 1 parameters. |
|
14
|
|
|
|
|
58
|
|
|
14
|
|
|
|
|
10462
|
|
1941
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
sub member_forms |
1944
|
|
|
|
|
|
|
{ |
1945
|
71
|
|
|
71
|
|
113
|
my $self = shift; |
1946
|
71
|
|
|
|
|
109
|
my $class = $_[0]; |
1947
|
71
|
100
|
|
|
|
159
|
return $class->readonly( $self->name ) |
1948
|
|
|
|
|
|
|
? 'no_params' |
1949
|
|
|
|
|
|
|
: ( 'no_params', 'one_param' ); |
1950
|
|
|
|
|
|
|
} |
1951
|
|
|
|
|
|
|
|
1952
|
|
|
|
|
|
|
sub no_params |
1953
|
|
|
|
|
|
|
{ |
1954
|
71
|
|
|
71
|
|
115
|
my $self = shift; |
1955
|
71
|
|
|
|
|
159
|
my ( $class, $element ) = @_; |
1956
|
71
|
50
|
66
|
|
|
149
|
if ( $class->readonly( $self->name ) && !$class->check_params ) |
1957
|
|
|
|
|
|
|
{ |
1958
|
0
|
|
|
|
|
0
|
return " return $element;\n"; |
1959
|
|
|
|
|
|
|
} |
1960
|
71
|
|
|
|
|
239
|
return " \$#_ == -1\tand do { return $element };\n"; |
1961
|
|
|
|
|
|
|
} |
1962
|
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
|
sub one_param |
1964
|
|
|
|
|
|
|
{ |
1965
|
47
|
|
|
47
|
|
95
|
my $self = shift; |
1966
|
47
|
|
|
|
|
101
|
my ( $class, $element ) = @_; |
1967
|
47
|
|
|
|
|
106
|
my $form = ''; |
1968
|
47
|
50
|
|
|
|
107
|
$form .= Class::Generate::Member_Names::substituted( $self->pre ) |
1969
|
|
|
|
|
|
|
if defined $self->pre; |
1970
|
47
|
100
|
66
|
|
|
121
|
$form .= $self->valid_value_test_form( $class, '$_[0]' ) . "\n" |
1971
|
|
|
|
|
|
|
if $class->check_params && defined $self->base; |
1972
|
47
|
|
|
|
|
127
|
$form .= "$element = \$_[0];\n"; |
1973
|
47
|
100
|
|
|
|
107
|
$form .= Class::Generate::Member_Names::substituted( $self->post ) |
1974
|
|
|
|
|
|
|
if defined $self->post; |
1975
|
47
|
100
|
66
|
|
|
117
|
$form .= $self->assertion($class) . "\n" |
1976
|
|
|
|
|
|
|
if defined $class->check_params && defined $self->assert; |
1977
|
47
|
|
|
|
|
110
|
$form .= "return;\n"; |
1978
|
47
|
|
|
|
|
155
|
return $self->maybe_guarded( $form, 0, $class ); |
1979
|
|
|
|
|
|
|
} |
1980
|
|
|
|
|
|
|
|
1981
|
|
|
|
|
|
|
sub valid_value_form |
1982
|
|
|
|
|
|
|
{ # Return a form that tests if |
1983
|
12
|
|
|
12
|
|
20
|
my $self = shift; # a ref is of the correct |
1984
|
12
|
|
|
|
|
26
|
my ($param) = @_; # base type. |
1985
|
12
|
|
|
|
|
30
|
return qq|UNIVERSAL::isa($param, '| . $self->base . qq|')|; |
1986
|
|
|
|
|
|
|
} |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
sub can_be_invalid |
1989
|
|
|
|
|
|
|
{ # Validity for a scalar member |
1990
|
102
|
|
|
102
|
|
160
|
my $self = shift; # is testable only if the member |
1991
|
102
|
|
|
|
|
179
|
return defined $self->base; # is supposed to be a class. |
1992
|
|
|
|
|
|
|
} |
1993
|
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
sub as_var |
1995
|
|
|
|
|
|
|
{ |
1996
|
99
|
|
|
99
|
|
149
|
my $self = shift; |
1997
|
99
|
|
|
|
|
172
|
return '$' . $self->name; |
1998
|
|
|
|
|
|
|
} |
1999
|
|
|
|
|
|
|
|
2000
|
|
|
|
|
|
|
sub method_regexp |
2001
|
|
|
|
|
|
|
{ |
2002
|
99
|
|
|
99
|
|
181
|
my $self = shift; |
2003
|
99
|
|
|
|
|
147
|
my $class = $_[0]; |
2004
|
99
|
50
|
|
|
|
246
|
return $class->include_method( $self->name ) ? ( '\$' . $self->name ) : (); |
2005
|
|
|
|
|
|
|
} |
2006
|
|
|
|
|
|
|
|
2007
|
|
|
|
|
|
|
sub accessor_names |
2008
|
|
|
|
|
|
|
{ |
2009
|
175
|
|
|
175
|
|
276
|
my $self = shift; |
2010
|
175
|
|
|
|
|
408
|
my ( $class, $name ) = @_; |
2011
|
175
|
|
|
|
|
502
|
return grep $class->include_method($_), |
2012
|
|
|
|
|
|
|
( $name, $self->SUPER::accessor_names( $class, $name ) ); |
2013
|
|
|
|
|
|
|
} |
2014
|
|
|
|
|
|
|
|
2015
|
|
|
|
|
|
|
sub expected_type_form |
2016
|
|
|
|
|
|
|
{ |
2017
|
6
|
|
|
6
|
|
11
|
my $self = shift; |
2018
|
6
|
|
|
|
|
14
|
return $self->base; |
2019
|
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
|
sub copy_form |
2022
|
|
|
|
|
|
|
{ |
2023
|
37
|
|
|
37
|
|
70
|
my $self = shift; |
2024
|
37
|
|
|
|
|
96
|
my ( $from, $to ) = @_; |
2025
|
37
|
|
|
|
|
158
|
my $form = " $to = $from"; |
2026
|
37
|
50
|
|
|
|
113
|
if ( !$self->nocopy ) |
2027
|
|
|
|
|
|
|
{ |
2028
|
37
|
100
|
|
|
|
120
|
$form .= '->copy' if $self->base; |
2029
|
|
|
|
|
|
|
} |
2030
|
37
|
|
|
|
|
119
|
$form .= " if defined $from;\n"; |
2031
|
37
|
|
|
|
|
113
|
return $form; |
2032
|
|
|
|
|
|
|
} |
2033
|
|
|
|
|
|
|
|
2034
|
|
|
|
|
|
|
sub equals |
2035
|
|
|
|
|
|
|
{ |
2036
|
70
|
|
|
70
|
|
117
|
my $self = shift; |
2037
|
70
|
|
|
|
|
150
|
my ( $index, $existence_test ) = @_; |
2038
|
70
|
|
|
|
|
188
|
my ( $sr, $or ) = ( '$self->' . $index, '$o->' . $index ); |
2039
|
70
|
|
|
|
|
304
|
my $form = |
2040
|
|
|
|
|
|
|
" return undef if $existence_test $sr ^ $existence_test $or;\n" |
2041
|
|
|
|
|
|
|
. " if ( $existence_test $sr ) { return undef unless $sr"; |
2042
|
70
|
100
|
|
|
|
153
|
if ( $self->base ) |
2043
|
|
|
|
|
|
|
{ |
2044
|
5
|
|
|
|
|
16
|
$form .= "->equals($or)"; |
2045
|
|
|
|
|
|
|
} |
2046
|
|
|
|
|
|
|
else |
2047
|
|
|
|
|
|
|
{ |
2048
|
65
|
|
|
|
|
168
|
$form .= " eq $or"; |
2049
|
|
|
|
|
|
|
} |
2050
|
70
|
|
|
|
|
382
|
return $form . " }\n"; |
2051
|
|
|
|
|
|
|
} |
2052
|
|
|
|
|
|
|
|
2053
|
|
|
|
|
|
|
package Class::Generate::List_Member; # A Member subclass for list |
2054
|
|
|
|
|
|
|
$Class::Generate::List_Member::VERSION = '1.18'; |
2055
|
14
|
|
|
14
|
|
119
|
use strict; # (array and hash) members. |
|
14
|
|
|
|
|
39
|
|
|
14
|
|
|
|
|
678
|
|
2056
|
14
|
|
|
14
|
|
84
|
use vars qw(@ISA); # accessor accepts 0-2 parameters. |
|
14
|
|
|
|
|
29
|
|
|
14
|
|
|
|
|
12188
|
|
2057
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
2058
|
|
|
|
|
|
|
|
2059
|
|
|
|
|
|
|
sub member_forms |
2060
|
|
|
|
|
|
|
{ |
2061
|
61
|
|
|
61
|
|
99
|
my $self = shift; |
2062
|
61
|
|
|
|
|
88
|
my $class = $_[0]; |
2063
|
61
|
100
|
|
|
|
128
|
return $class->readonly( $self->name ) |
2064
|
|
|
|
|
|
|
? ( 'no_params', 'one_param' ) |
2065
|
|
|
|
|
|
|
: ( 'no_params', 'one_param', 'two_params' ); |
2066
|
|
|
|
|
|
|
} |
2067
|
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
|
sub no_params |
2069
|
|
|
|
|
|
|
{ |
2070
|
61
|
|
|
61
|
|
98
|
my $self = shift; |
2071
|
61
|
|
|
|
|
149
|
my ( $class, $element, $exists, $lvalue, $values ) = @_; |
2072
|
|
|
|
|
|
|
return |
2073
|
61
|
|
|
|
|
201
|
" \$#_ == -1\tand do { return $exists ? " |
2074
|
|
|
|
|
|
|
. $self->whole_lvalue($element) |
2075
|
|
|
|
|
|
|
. " : () };\n"; |
2076
|
|
|
|
|
|
|
} |
2077
|
|
|
|
|
|
|
|
2078
|
|
|
|
|
|
|
sub one_param |
2079
|
|
|
|
|
|
|
{ |
2080
|
61
|
|
|
61
|
|
113
|
my $self = shift; |
2081
|
61
|
|
|
|
|
133
|
my ( $class, $element, $exists, $lvalue, $values ) = @_; |
2082
|
61
|
|
|
|
|
96
|
my $form; |
2083
|
61
|
100
|
|
|
|
159
|
if ( $class->accept_refs ) |
2084
|
|
|
|
|
|
|
{ |
2085
|
59
|
|
|
|
|
207
|
$form = " \$#_ == 0\tand do {\n" . "\t" |
2086
|
|
|
|
|
|
|
. "return ($exists ? ${element}->$lvalue : undef) if ! ref \$_[0];\n"; |
2087
|
59
|
100
|
66
|
|
|
141
|
if ( $class->check_params && $class->readonly( $self->name ) ) |
2088
|
|
|
|
|
|
|
{ |
2089
|
2
|
|
|
|
|
11
|
$form .= |
2090
|
|
|
|
|
|
|
"croak '" |
2091
|
|
|
|
|
|
|
. $self->name_form($class) |
2092
|
|
|
|
|
|
|
. "Member is read-only';\n"; |
2093
|
|
|
|
|
|
|
} |
2094
|
|
|
|
|
|
|
else |
2095
|
|
|
|
|
|
|
{ |
2096
|
57
|
50
|
|
|
|
171
|
$form .= |
2097
|
|
|
|
|
|
|
"\t" . Class::Generate::Member_Names::substituted( $self->pre ) |
2098
|
|
|
|
|
|
|
if defined $self->pre; |
2099
|
57
|
50
|
|
|
|
115
|
$form .= |
2100
|
|
|
|
|
|
|
"\t" . $self->valid_value_test_form( $class, '$_[0]' ) . "\n" |
2101
|
|
|
|
|
|
|
if $class->check_params; |
2102
|
57
|
|
|
|
|
151
|
$form .= "\t" |
2103
|
|
|
|
|
|
|
. $self->whole_lvalue($element) . ' = ' |
2104
|
|
|
|
|
|
|
. $self->whole_lvalue('$_[0]') . ";\n"; |
2105
|
57
|
50
|
|
|
|
142
|
$form .= |
2106
|
|
|
|
|
|
|
"\t" . Class::Generate::Member_Names::substituted( $self->post ) |
2107
|
|
|
|
|
|
|
if defined $self->post; |
2108
|
57
|
50
|
33
|
|
|
127
|
$form .= "\t" . $self->assertion($class) . "\n" |
2109
|
|
|
|
|
|
|
if defined $class->check_params && defined $self->assert; |
2110
|
57
|
|
|
|
|
112
|
$form .= "\t" . "return;\n"; |
2111
|
|
|
|
|
|
|
} |
2112
|
59
|
|
|
|
|
107
|
$form .= " };\n"; |
2113
|
|
|
|
|
|
|
} |
2114
|
|
|
|
|
|
|
else |
2115
|
|
|
|
|
|
|
{ |
2116
|
2
|
|
|
|
|
8
|
$form = |
2117
|
|
|
|
|
|
|
" \$#_ == 0\tand do { return $exists ? ${element}->$lvalue : undef };\n"; |
2118
|
|
|
|
|
|
|
} |
2119
|
61
|
|
|
|
|
197
|
return $form; |
2120
|
|
|
|
|
|
|
} |
2121
|
|
|
|
|
|
|
|
2122
|
|
|
|
|
|
|
sub two_params |
2123
|
|
|
|
|
|
|
{ |
2124
|
59
|
|
|
59
|
|
97
|
my $self = shift; |
2125
|
59
|
|
|
|
|
140
|
my ( $class, $element, $exists, $lvalue, $values ) = @_; |
2126
|
59
|
|
|
|
|
101
|
my $form = ''; |
2127
|
59
|
50
|
|
|
|
125
|
$form .= Class::Generate::Member_Names::substituted( $self->pre ) |
2128
|
|
|
|
|
|
|
if defined $self->pre; |
2129
|
59
|
100
|
66
|
|
|
130
|
$form .= $self->valid_element_test( $class, '$_[1]' ) . "\n" |
2130
|
|
|
|
|
|
|
if $class->check_params && defined $self->base; |
2131
|
59
|
|
|
|
|
158
|
$form .= "${element}->$lvalue = \$_[1];\n"; |
2132
|
59
|
50
|
|
|
|
127
|
$form .= Class::Generate::Member_Names::substituted( $self->post ) |
2133
|
|
|
|
|
|
|
if defined $self->post; |
2134
|
59
|
|
|
|
|
112
|
$form .= "return;\n"; |
2135
|
59
|
|
|
|
|
184
|
return $self->maybe_guarded( $form, 1, $class ); |
2136
|
|
|
|
|
|
|
} |
2137
|
|
|
|
|
|
|
|
2138
|
|
|
|
|
|
|
sub valid_value_form |
2139
|
|
|
|
|
|
|
{ # Return a form that tests if a |
2140
|
110
|
|
|
110
|
|
176
|
my $self = shift; # parameter is a correct list reference |
2141
|
110
|
|
|
|
|
172
|
my $param = $_[0]; # and (if relevant) if all of its |
2142
|
110
|
|
|
|
|
217
|
my $base = $self->base; # elements have the correct base type. |
2143
|
110
|
|
|
|
|
673
|
ref($self) =~ /::(\w+)_Member$/; |
2144
|
110
|
|
|
|
|
442
|
my $form = "UNIVERSAL::isa($param, '" . uc($1) . "')"; |
2145
|
110
|
100
|
|
|
|
279
|
if ( defined $base ) |
2146
|
|
|
|
|
|
|
{ |
2147
|
20
|
|
|
|
|
56
|
$form .= |
2148
|
|
|
|
|
|
|
qq| && ! grep ! (defined \$_ && UNIVERSAL::isa(\$_, '$base')), | |
2149
|
|
|
|
|
|
|
. $self->values($param); |
2150
|
|
|
|
|
|
|
} |
2151
|
110
|
|
|
|
|
423
|
return $form; |
2152
|
|
|
|
|
|
|
} |
2153
|
|
|
|
|
|
|
|
2154
|
|
|
|
|
|
|
sub valid_element_test |
2155
|
|
|
|
|
|
|
{ # Return a form that dies unless an |
2156
|
10
|
|
|
10
|
|
19
|
my $self = shift; # element has the correct base type. |
2157
|
10
|
|
|
|
|
20
|
my ( $class, $param ) = @_; |
2158
|
|
|
|
|
|
|
return |
2159
|
10
|
|
|
|
|
20
|
$self->invalid_value_assignment_message($class) |
2160
|
|
|
|
|
|
|
. qq| unless UNIVERSAL::isa($param, '| |
2161
|
|
|
|
|
|
|
. $self->base . q|');|; |
2162
|
|
|
|
|
|
|
} |
2163
|
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
|
sub valid_elements_test |
2165
|
|
|
|
|
|
|
{ # Return a form that dies unless all |
2166
|
5
|
|
|
5
|
|
11
|
my $self = shift; # elements of a list are validly typed. |
2167
|
5
|
|
|
|
|
11
|
my ( $class, $values ) = @_; |
2168
|
5
|
|
|
|
|
12
|
my $base = $self->base; |
2169
|
|
|
|
|
|
|
return |
2170
|
5
|
|
|
|
|
14
|
$self->invalid_value_assignment_message($class) |
2171
|
|
|
|
|
|
|
. q| unless ! grep ! UNIVERSAL::isa($_, '| |
2172
|
|
|
|
|
|
|
. $self->base |
2173
|
|
|
|
|
|
|
. qq|'), $values;|; |
2174
|
|
|
|
|
|
|
} |
2175
|
|
|
|
|
|
|
|
2176
|
|
|
|
|
|
|
sub can_be_invalid |
2177
|
|
|
|
|
|
|
{ # A value for a list member can |
2178
|
153
|
|
|
153
|
|
506
|
return 1; # always be invalid: the wrong |
2179
|
|
|
|
|
|
|
} # type of list can be given. |
2180
|
|
|
|
|
|
|
|
2181
|
|
|
|
|
|
|
package Class::Generate::Array_Member; # A List subclass for array |
2182
|
|
|
|
|
|
|
$Class::Generate::Array_Member::VERSION = '1.18'; |
2183
|
14
|
|
|
14
|
|
130
|
use strict; # members. Provides the |
|
14
|
|
|
|
|
53
|
|
|
14
|
|
|
|
|
553
|
|
2184
|
14
|
|
|
14
|
|
85
|
use vars qw(@ISA); # of accessing array members. |
|
14
|
|
|
|
|
41
|
|
|
14
|
|
|
|
|
12050
|
|
2185
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::List_Member); |
2186
|
|
|
|
|
|
|
|
2187
|
|
|
|
|
|
|
sub lvalue |
2188
|
|
|
|
|
|
|
{ |
2189
|
31
|
|
|
31
|
|
60
|
my $self = shift; |
2190
|
31
|
|
|
|
|
74
|
return '[' . $_[0] . ']'; |
2191
|
|
|
|
|
|
|
} |
2192
|
|
|
|
|
|
|
|
2193
|
|
|
|
|
|
|
sub whole_lvalue |
2194
|
|
|
|
|
|
|
{ |
2195
|
89
|
|
|
89
|
|
123
|
my $self = shift; |
2196
|
89
|
|
|
|
|
303
|
return '@{' . $_[0] . '}'; |
2197
|
|
|
|
|
|
|
} |
2198
|
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
|
sub values |
2200
|
|
|
|
|
|
|
{ |
2201
|
41
|
|
|
41
|
|
64
|
my $self = shift; |
2202
|
41
|
|
|
|
|
112
|
return '@{' . $_[0] . '}'; |
2203
|
|
|
|
|
|
|
} |
2204
|
|
|
|
|
|
|
|
2205
|
|
|
|
|
|
|
sub size_form |
2206
|
|
|
|
|
|
|
{ |
2207
|
31
|
|
|
31
|
|
66
|
my $self = shift; |
2208
|
31
|
|
|
|
|
95
|
my ( $class, $element, $member_name, $exists ) = @_; |
2209
|
31
|
|
|
|
|
153
|
return $class->sub_form( |
2210
|
|
|
|
|
|
|
$member_name, |
2211
|
|
|
|
|
|
|
$member_name . '_size', |
2212
|
|
|
|
|
|
|
" return $exists ? \$#{$element} : -1;\n" |
2213
|
|
|
|
|
|
|
); |
2214
|
|
|
|
|
|
|
} |
2215
|
|
|
|
|
|
|
|
2216
|
|
|
|
|
|
|
sub last_form |
2217
|
|
|
|
|
|
|
{ |
2218
|
31
|
|
|
31
|
|
64
|
my $self = shift; |
2219
|
31
|
|
|
|
|
81
|
my ( $class, $element, $member_name, $exists ) = @_; |
2220
|
31
|
|
|
|
|
162
|
return $class->sub_form( |
2221
|
|
|
|
|
|
|
$member_name, |
2222
|
|
|
|
|
|
|
'last_' . $member_name, |
2223
|
|
|
|
|
|
|
" return $exists ? $element" . "[\$#{$element}] : undef;\n" |
2224
|
|
|
|
|
|
|
); |
2225
|
|
|
|
|
|
|
} |
2226
|
|
|
|
|
|
|
|
2227
|
|
|
|
|
|
|
sub add_form |
2228
|
|
|
|
|
|
|
{ |
2229
|
30
|
|
|
30
|
|
60
|
my $self = shift; |
2230
|
30
|
|
|
|
|
74
|
my ( $class, $element, $member_name, $exists ) = @_; |
2231
|
30
|
|
|
|
|
52
|
my $body = ''; |
2232
|
30
|
100
|
66
|
|
|
99
|
$body .= ' ' . $self->valid_elements_test( $class, '@_' ) . "\n" |
2233
|
|
|
|
|
|
|
if $class->check_params && defined $self->base; |
2234
|
30
|
50
|
|
|
|
104
|
$body .= Class::Generate::Member_Names::substituted( $self->pre ) |
2235
|
|
|
|
|
|
|
if defined $self->pre; |
2236
|
30
|
|
|
|
|
101
|
$body .= ' push @{' . $element . '}, @_;' . "\n"; |
2237
|
30
|
50
|
|
|
|
80
|
$body .= Class::Generate::Member_Names::substituted( $self->post ) |
2238
|
|
|
|
|
|
|
if defined $self->post; |
2239
|
30
|
50
|
33
|
|
|
77
|
$body .= ' ' . $self->assertion($class) . "\n" |
2240
|
|
|
|
|
|
|
if defined $class->check_params && defined $self->assert; |
2241
|
30
|
|
|
|
|
186
|
return $class->sub_form( $member_name, 'add_' . $member_name, $body ); |
2242
|
|
|
|
|
|
|
} |
2243
|
|
|
|
|
|
|
|
2244
|
|
|
|
|
|
|
sub as_var |
2245
|
|
|
|
|
|
|
{ |
2246
|
34
|
|
|
34
|
|
66
|
my $self = shift; |
2247
|
34
|
|
|
|
|
76
|
return '@' . $self->name; |
2248
|
|
|
|
|
|
|
} |
2249
|
|
|
|
|
|
|
|
2250
|
|
|
|
|
|
|
sub method_regexp |
2251
|
|
|
|
|
|
|
{ |
2252
|
34
|
|
|
34
|
|
93
|
my $self = shift; |
2253
|
34
|
|
|
|
|
61
|
my $class = $_[0]; |
2254
|
34
|
50
|
|
|
|
103
|
return $class->include_method( $self->name ) |
2255
|
|
|
|
|
|
|
? ( '@' . $self->name, '\$#?' . $self->name ) |
2256
|
|
|
|
|
|
|
: (); |
2257
|
|
|
|
|
|
|
} |
2258
|
|
|
|
|
|
|
|
2259
|
|
|
|
|
|
|
sub accessor_names |
2260
|
|
|
|
|
|
|
{ |
2261
|
72
|
|
|
72
|
|
123
|
my $self = shift; |
2262
|
72
|
|
|
|
|
152
|
my ( $class, $name ) = @_; |
2263
|
72
|
|
|
|
|
282
|
my @names = ( |
2264
|
|
|
|
|
|
|
$name, "${name}_size", "last_$name", |
2265
|
|
|
|
|
|
|
$self->SUPER::accessor_names( $class, $name ) |
2266
|
|
|
|
|
|
|
); |
2267
|
72
|
100
|
|
|
|
179
|
push @names, "add_$name" if !$class->readonly($name); |
2268
|
72
|
|
|
|
|
228
|
return grep $class->include_method($_), @names; |
2269
|
|
|
|
|
|
|
} |
2270
|
|
|
|
|
|
|
|
2271
|
|
|
|
|
|
|
sub expected_type_form |
2272
|
|
|
|
|
|
|
{ |
2273
|
39
|
|
|
39
|
|
69
|
my $self = shift; |
2274
|
39
|
100
|
|
|
|
76
|
if ( defined $self->base ) |
2275
|
|
|
|
|
|
|
{ |
2276
|
15
|
|
|
|
|
31
|
return 'reference to array of ' . $self->base; |
2277
|
|
|
|
|
|
|
} |
2278
|
|
|
|
|
|
|
else |
2279
|
|
|
|
|
|
|
{ |
2280
|
24
|
|
|
|
|
134
|
return 'array reference'; |
2281
|
|
|
|
|
|
|
} |
2282
|
|
|
|
|
|
|
} |
2283
|
|
|
|
|
|
|
|
2284
|
|
|
|
|
|
|
sub copy_form |
2285
|
|
|
|
|
|
|
{ |
2286
|
30
|
|
|
30
|
|
58
|
my $self = shift; |
2287
|
30
|
|
|
|
|
70
|
my ( $from, $to ) = @_; |
2288
|
30
|
|
|
|
|
73
|
my $form = " $to = "; |
2289
|
30
|
100
|
|
|
|
129
|
if ( !$self->nocopy ) |
2290
|
|
|
|
|
|
|
{ |
2291
|
29
|
|
|
|
|
70
|
$form .= '[ '; |
2292
|
29
|
100
|
|
|
|
67
|
$form .= 'map defined $_ ? $_->copy : undef, ' if $self->base; |
2293
|
29
|
|
|
|
|
85
|
$form .= "\@{$from} ]"; |
2294
|
|
|
|
|
|
|
} |
2295
|
|
|
|
|
|
|
else |
2296
|
|
|
|
|
|
|
{ |
2297
|
1
|
|
|
|
|
3
|
$form .= $from; |
2298
|
|
|
|
|
|
|
} |
2299
|
30
|
|
|
|
|
88
|
$form .= " if defined $from;\n"; |
2300
|
30
|
|
|
|
|
116
|
return $form; |
2301
|
|
|
|
|
|
|
} |
2302
|
|
|
|
|
|
|
|
2303
|
|
|
|
|
|
|
sub equals |
2304
|
|
|
|
|
|
|
{ |
2305
|
27
|
|
|
27
|
|
49
|
my $self = shift; |
2306
|
27
|
|
|
|
|
69
|
my ( $index, $existence_test ) = @_; |
2307
|
27
|
|
|
|
|
89
|
my ( $sr, $or ) = ( '$self->' . $index, '$o->' . $index ); |
2308
|
27
|
|
|
|
|
196
|
my $form = |
2309
|
|
|
|
|
|
|
" return undef if $existence_test($sr) ^ $existence_test($or);\n" |
2310
|
|
|
|
|
|
|
. " if ( $existence_test $sr ) {\n" |
2311
|
|
|
|
|
|
|
. " return undef unless (\$ub = \$#{$sr}) == \$#{$or};\n" |
2312
|
|
|
|
|
|
|
. " for ( my \$i = 0; \$i <= \$ub; \$i++ ) {\n" |
2313
|
|
|
|
|
|
|
. " return undef unless $sr" . '[$i]'; |
2314
|
27
|
100
|
|
|
|
67
|
if ( $self->base ) |
2315
|
|
|
|
|
|
|
{ |
2316
|
3
|
|
|
|
|
12
|
$form .= '->equals(' . $or . '[$i])'; |
2317
|
|
|
|
|
|
|
} |
2318
|
|
|
|
|
|
|
else |
2319
|
|
|
|
|
|
|
{ |
2320
|
24
|
|
|
|
|
84
|
$form .= ' eq ' . $or . '[$i]'; |
2321
|
|
|
|
|
|
|
} |
2322
|
27
|
|
|
|
|
186
|
return $form . ";\n\t}\n }\n"; |
2323
|
|
|
|
|
|
|
} |
2324
|
|
|
|
|
|
|
|
2325
|
|
|
|
|
|
|
package Class::Generate::Hash_Member; # A List subclass for Hash |
2326
|
|
|
|
|
|
|
$Class::Generate::Hash_Member::VERSION = '1.18'; |
2327
|
14
|
|
|
14
|
|
164
|
use strict; # members. Provides the n_keys |
|
14
|
|
|
|
|
28
|
|
|
14
|
|
|
|
|
430
|
|
2328
|
14
|
|
|
14
|
|
77
|
use vars qw(@ISA); # specifics of accessing |
|
14
|
|
|
|
|
47
|
|
|
14
|
|
|
|
|
11505
|
|
2329
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::List_Member); # hash members. |
2330
|
|
|
|
|
|
|
|
2331
|
|
|
|
|
|
|
sub lvalue |
2332
|
|
|
|
|
|
|
{ |
2333
|
30
|
|
|
30
|
|
59
|
my $self = shift; |
2334
|
30
|
|
|
|
|
155
|
return '{' . $_[0] . '}'; |
2335
|
|
|
|
|
|
|
} |
2336
|
|
|
|
|
|
|
|
2337
|
|
|
|
|
|
|
sub whole_lvalue |
2338
|
|
|
|
|
|
|
{ |
2339
|
86
|
|
|
86
|
|
202
|
my $self = shift; |
2340
|
86
|
|
|
|
|
257
|
return '%{' . $_[0] . '}'; |
2341
|
|
|
|
|
|
|
} |
2342
|
|
|
|
|
|
|
|
2343
|
|
|
|
|
|
|
sub values |
2344
|
|
|
|
|
|
|
{ |
2345
|
40
|
|
|
40
|
|
138
|
my $self = shift; |
2346
|
40
|
|
|
|
|
111
|
return 'values %{' . $_[0] . '}'; |
2347
|
|
|
|
|
|
|
} |
2348
|
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
|
sub delete_form |
2350
|
|
|
|
|
|
|
{ |
2351
|
29
|
|
|
29
|
|
58
|
my $self = shift; |
2352
|
29
|
|
|
|
|
69
|
my ( $class, $element, $member_name, $exists ) = @_; |
2353
|
29
|
|
|
|
|
125
|
return $class->sub_form( |
2354
|
|
|
|
|
|
|
$member_name, |
2355
|
|
|
|
|
|
|
'delete_' . $member_name, |
2356
|
|
|
|
|
|
|
" delete \@{$element}{\@_} if $exists;\n" |
2357
|
|
|
|
|
|
|
); |
2358
|
|
|
|
|
|
|
} |
2359
|
|
|
|
|
|
|
|
2360
|
|
|
|
|
|
|
sub keys_form |
2361
|
|
|
|
|
|
|
{ |
2362
|
29
|
|
|
29
|
|
72
|
my $self = shift; |
2363
|
29
|
|
|
|
|
86
|
my ( $class, $element, $member_name, $exists ) = @_; |
2364
|
29
|
|
|
|
|
148
|
return $class->sub_form( |
2365
|
|
|
|
|
|
|
$member_name, |
2366
|
|
|
|
|
|
|
$member_name . '_keys', |
2367
|
|
|
|
|
|
|
" return $exists ? keys \%{$element} : ();\n" |
2368
|
|
|
|
|
|
|
); |
2369
|
|
|
|
|
|
|
} |
2370
|
|
|
|
|
|
|
|
2371
|
|
|
|
|
|
|
sub values_form |
2372
|
|
|
|
|
|
|
{ |
2373
|
30
|
|
|
30
|
|
59
|
my $self = shift; |
2374
|
30
|
|
|
|
|
79
|
my ( $class, $element, $member_name, $exists ) = @_; |
2375
|
30
|
|
|
|
|
134
|
return $class->sub_form( |
2376
|
|
|
|
|
|
|
$member_name, |
2377
|
|
|
|
|
|
|
$member_name . '_values', |
2378
|
|
|
|
|
|
|
" return $exists ? values \%{$element} : ();\n" |
2379
|
|
|
|
|
|
|
); |
2380
|
|
|
|
|
|
|
} |
2381
|
|
|
|
|
|
|
|
2382
|
|
|
|
|
|
|
sub as_var |
2383
|
|
|
|
|
|
|
{ |
2384
|
32
|
|
|
32
|
|
57
|
my $self = shift; |
2385
|
32
|
|
|
|
|
70
|
return '%' . $self->name; |
2386
|
|
|
|
|
|
|
} |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
sub method_regexp |
2389
|
|
|
|
|
|
|
{ |
2390
|
32
|
|
|
32
|
|
102
|
my $self = shift; |
2391
|
32
|
|
|
|
|
58
|
my $class = $_[0]; |
2392
|
32
|
50
|
|
|
|
82
|
return $class->include_method( $self->name ) |
2393
|
|
|
|
|
|
|
? ( '[%$]' . $self->name ) |
2394
|
|
|
|
|
|
|
: (); |
2395
|
|
|
|
|
|
|
} |
2396
|
|
|
|
|
|
|
|
2397
|
|
|
|
|
|
|
sub accessor_names |
2398
|
|
|
|
|
|
|
{ |
2399
|
68
|
|
|
68
|
|
109
|
my $self = shift; |
2400
|
68
|
|
|
|
|
133
|
my ( $class, $name ) = @_; |
2401
|
68
|
|
|
|
|
314
|
my @names = ( |
2402
|
|
|
|
|
|
|
$name, "${name}_keys", "${name}_values", |
2403
|
|
|
|
|
|
|
$self->SUPER::accessor_names( $class, $name ) |
2404
|
|
|
|
|
|
|
); |
2405
|
68
|
100
|
|
|
|
155
|
push @names, "delete_$name" if !$class->readonly($name); |
2406
|
68
|
|
|
|
|
190
|
return grep $class->include_method($_), @names; |
2407
|
|
|
|
|
|
|
} |
2408
|
|
|
|
|
|
|
|
2409
|
|
|
|
|
|
|
sub expected_type_form |
2410
|
|
|
|
|
|
|
{ |
2411
|
33
|
|
|
33
|
|
56
|
my $self = shift; |
2412
|
33
|
100
|
|
|
|
71
|
if ( defined $self->base ) |
2413
|
|
|
|
|
|
|
{ |
2414
|
10
|
|
|
|
|
21
|
return 'reference to hash of ' . $self->base; |
2415
|
|
|
|
|
|
|
} |
2416
|
|
|
|
|
|
|
else |
2417
|
|
|
|
|
|
|
{ |
2418
|
23
|
|
|
|
|
107
|
return 'hash reference'; |
2419
|
|
|
|
|
|
|
} |
2420
|
|
|
|
|
|
|
} |
2421
|
|
|
|
|
|
|
|
2422
|
|
|
|
|
|
|
sub copy_form |
2423
|
|
|
|
|
|
|
{ |
2424
|
29
|
|
|
29
|
|
51
|
my $self = shift; |
2425
|
29
|
|
|
|
|
73
|
my ( $from, $to ) = @_; |
2426
|
29
|
100
|
|
|
|
108
|
if ( !$self->nocopy ) |
2427
|
|
|
|
|
|
|
{ |
2428
|
28
|
100
|
|
|
|
67
|
if ( $self->base ) |
2429
|
|
|
|
|
|
|
{ |
2430
|
|
|
|
|
|
|
return |
2431
|
5
|
|
|
|
|
43
|
" if ( defined $from ) {\n" |
2432
|
|
|
|
|
|
|
. "\t$to = {};\n" |
2433
|
|
|
|
|
|
|
. "\twhile ( my (\$key, \$value) = each \%{$from} ) {\n" |
2434
|
|
|
|
|
|
|
. "\t $to" |
2435
|
|
|
|
|
|
|
. '->{$key} = defined $value ? $value->copy : undef;' . "\n" |
2436
|
|
|
|
|
|
|
. "\t}\n" |
2437
|
|
|
|
|
|
|
. " }\n"; |
2438
|
|
|
|
|
|
|
} |
2439
|
|
|
|
|
|
|
else |
2440
|
|
|
|
|
|
|
{ |
2441
|
23
|
|
|
|
|
127
|
return " $to = { \%{$from} } if defined $from;\n"; |
2442
|
|
|
|
|
|
|
} |
2443
|
|
|
|
|
|
|
} |
2444
|
|
|
|
|
|
|
else |
2445
|
|
|
|
|
|
|
{ |
2446
|
1
|
|
|
|
|
7
|
return " $to = $from if defined $from;\n"; |
2447
|
|
|
|
|
|
|
} |
2448
|
|
|
|
|
|
|
} |
2449
|
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
|
sub equals |
2451
|
|
|
|
|
|
|
{ |
2452
|
25
|
|
|
25
|
|
47
|
my $self = shift; |
2453
|
25
|
|
|
|
|
58
|
my ( $index, $existence_test ) = @_; |
2454
|
25
|
|
|
|
|
93
|
my ( $sr, $or ) = ( '$self->' . $index, '$o->' . $index ); |
2455
|
25
|
|
|
|
|
237
|
my $form = |
2456
|
|
|
|
|
|
|
" return undef if $existence_test $sr ^ $existence_test $or;\n" |
2457
|
|
|
|
|
|
|
. " if ( $existence_test $sr ) {\n" |
2458
|
|
|
|
|
|
|
. ' @self_keys = keys %{' |
2459
|
|
|
|
|
|
|
. $sr . '};' . "\n" |
2460
|
|
|
|
|
|
|
. ' return undef unless $#self_keys == scalar(keys %{' |
2461
|
|
|
|
|
|
|
. $or |
2462
|
|
|
|
|
|
|
. '}) - 1;' . "\n" |
2463
|
|
|
|
|
|
|
. ' for my $k ( @self_keys ) {' . "\n" |
2464
|
|
|
|
|
|
|
. " return undef unless exists $or" . '{$k};' . "\n" |
2465
|
|
|
|
|
|
|
. ' return undef if ($self_value_defined = defined ' |
2466
|
|
|
|
|
|
|
. $sr |
2467
|
|
|
|
|
|
|
. '{$k}) ^ defined ' |
2468
|
|
|
|
|
|
|
. $or . '{$k};' . "\n" |
2469
|
|
|
|
|
|
|
. ' if ( $self_value_defined ) { return undef unless '; |
2470
|
25
|
100
|
|
|
|
59
|
if ( $self->base ) |
2471
|
|
|
|
|
|
|
{ |
2472
|
3
|
|
|
|
|
12
|
$form .= $sr . '{$k}->equals(' . $or . '{$k})'; |
2473
|
|
|
|
|
|
|
} |
2474
|
|
|
|
|
|
|
else |
2475
|
|
|
|
|
|
|
{ |
2476
|
22
|
|
|
|
|
80
|
$form .= $sr . '{$k} eq ' . $or . '{$k}'; |
2477
|
|
|
|
|
|
|
} |
2478
|
25
|
|
|
|
|
54
|
$form .= " }\n\t}\n }\n"; |
2479
|
25
|
|
|
|
|
123
|
return $form; |
2480
|
|
|
|
|
|
|
} |
2481
|
|
|
|
|
|
|
|
2482
|
|
|
|
|
|
|
package Class::Generate::Constructor; # The constructor is treated as a |
2483
|
|
|
|
|
|
|
$Class::Generate::Constructor::VERSION = '1.18'; |
2484
|
14
|
|
|
14
|
|
108
|
use strict; # special type of member. It includes |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
587
|
|
2485
|
14
|
|
|
14
|
|
79
|
use vars qw(@ISA); # constraints on required members. |
|
14
|
|
|
|
|
29
|
|
|
14
|
|
|
|
|
18579
|
|
2486
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
2487
|
|
|
|
|
|
|
|
2488
|
|
|
|
|
|
|
sub new |
2489
|
|
|
|
|
|
|
{ |
2490
|
62
|
|
|
62
|
|
111
|
my $class = shift; |
2491
|
62
|
|
|
|
|
259
|
my $self = $class->SUPER::new( 'new', @_ ); |
2492
|
62
|
|
|
|
|
256
|
return $self; |
2493
|
|
|
|
|
|
|
} |
2494
|
|
|
|
|
|
|
|
2495
|
|
|
|
|
|
|
sub style |
2496
|
|
|
|
|
|
|
{ |
2497
|
358
|
|
|
358
|
|
513
|
my $self = shift; |
2498
|
358
|
100
|
|
|
|
944
|
return $self->{'style'} if $#_ == -1; |
2499
|
61
|
|
|
|
|
229
|
$self->{'style'} = $_[0]; |
2500
|
|
|
|
|
|
|
} |
2501
|
|
|
|
|
|
|
|
2502
|
|
|
|
|
|
|
sub constraints |
2503
|
|
|
|
|
|
|
{ |
2504
|
52
|
|
|
52
|
|
110
|
my $self = shift; |
2505
|
52
|
100
|
|
|
|
261
|
return exists $self->{'constraints'} ? @{ $self->{'constraints'} } : () |
|
1
|
50
|
|
|
|
15
|
|
2506
|
|
|
|
|
|
|
if $#_ == -1; |
2507
|
|
|
|
|
|
|
return exists $self->{'constraints'} |
2508
|
0
|
0
|
|
|
|
0
|
? $self->{'constraints'}->[ $_[0] ] |
|
|
0
|
|
|
|
|
|
2509
|
|
|
|
|
|
|
: undef |
2510
|
|
|
|
|
|
|
if $#_ == 0; |
2511
|
0
|
|
|
|
|
0
|
$self->{'constraints'}->[ $_[0] ] = $_[1]; |
2512
|
|
|
|
|
|
|
} |
2513
|
|
|
|
|
|
|
|
2514
|
|
|
|
|
|
|
sub add_constraints |
2515
|
|
|
|
|
|
|
{ |
2516
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
2517
|
1
|
|
|
|
|
2
|
push @{ $self->{'constraints'} }, @_; |
|
1
|
|
|
|
|
7
|
|
2518
|
|
|
|
|
|
|
} |
2519
|
|
|
|
|
|
|
|
2520
|
|
|
|
|
|
|
sub constraints_size |
2521
|
|
|
|
|
|
|
{ |
2522
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2523
|
0
|
0
|
|
|
|
0
|
return exists $self->{'constraints'} ? $#{ $self->{'constraints'} } : -1; |
|
0
|
|
|
|
|
0
|
|
2524
|
|
|
|
|
|
|
} |
2525
|
|
|
|
|
|
|
|
2526
|
|
|
|
|
|
|
sub constraint_form |
2527
|
|
|
|
|
|
|
{ |
2528
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
2529
|
1
|
|
|
|
|
3
|
my ( $class, $style, $constraint ) = @_; |
2530
|
1
|
|
|
|
|
3
|
my $param_given = $constraint; |
2531
|
1
|
|
|
|
|
7
|
$param_given =~ s/\w+/$style->existence_test($&) . ' ' . $style->ref($&)/eg; |
|
2
|
|
|
|
|
5
|
|
2532
|
1
|
|
|
|
|
3
|
$constraint =~ s/'/\\'/g; |
2533
|
|
|
|
|
|
|
return |
2534
|
1
|
|
|
|
|
4
|
q|croak '| |
2535
|
|
|
|
|
|
|
. $self->name_form($class) |
2536
|
|
|
|
|
|
|
. qq|Parameter constraint "$constraint" failed' unless $param_given;|; |
2537
|
|
|
|
|
|
|
} |
2538
|
|
|
|
|
|
|
|
2539
|
|
|
|
|
|
|
sub param_tests_form |
2540
|
|
|
|
|
|
|
{ |
2541
|
57
|
|
|
57
|
|
109
|
my $self = shift; |
2542
|
57
|
|
|
|
|
124
|
my ( $class, $style ) = @_; |
2543
|
57
|
|
|
|
|
132
|
my $form = ''; |
2544
|
57
|
100
|
100
|
|
|
132
|
if ( !$class->parents && $style->can('params_check_form') ) |
2545
|
|
|
|
|
|
|
{ |
2546
|
45
|
|
|
|
|
149
|
$form .= $style->params_check_form( $class, $self ); |
2547
|
|
|
|
|
|
|
} |
2548
|
57
|
100
|
|
|
|
359
|
if ( !$style->isa('Class::Generate::Own') ) |
2549
|
|
|
|
|
|
|
{ |
2550
|
52
|
|
|
|
|
150
|
my @public_members = map $class->members($_), |
2551
|
|
|
|
|
|
|
$class->public_member_names; |
2552
|
52
|
100
|
|
|
|
268
|
for my $param_test ( |
2553
|
|
|
|
|
|
|
map $_->param_must_be_checked($class) ? $_->param_test($class) : (), |
2554
|
|
|
|
|
|
|
@public_members |
2555
|
|
|
|
|
|
|
) |
2556
|
|
|
|
|
|
|
{ |
2557
|
84
|
|
|
|
|
283
|
$form .= ' ' . $param_test . "\n"; |
2558
|
|
|
|
|
|
|
} |
2559
|
52
|
|
|
|
|
167
|
for my $constraint ( $self->constraints ) |
2560
|
|
|
|
|
|
|
{ |
2561
|
1
|
|
|
|
|
7
|
$form .= ' ' |
2562
|
|
|
|
|
|
|
. $self->constraint_form( $class, $style, $constraint ) . "\n"; |
2563
|
|
|
|
|
|
|
} |
2564
|
|
|
|
|
|
|
} |
2565
|
57
|
|
|
|
|
198
|
return $form; |
2566
|
|
|
|
|
|
|
} |
2567
|
|
|
|
|
|
|
|
2568
|
|
|
|
|
|
|
sub assertions_form |
2569
|
|
|
|
|
|
|
{ |
2570
|
57
|
|
|
57
|
|
112
|
my $self = shift; |
2571
|
57
|
|
|
|
|
95
|
my $class = $_[0]; |
2572
|
57
|
|
|
|
|
95
|
my $form = ''; |
2573
|
57
|
100
|
66
|
|
|
115
|
$form .= ' ' . $self->assertion($class) . "\n" |
2574
|
|
|
|
|
|
|
if defined $class->check_params && defined $self->assert; |
2575
|
57
|
|
|
|
|
154
|
for my $member ( grep defined $_->assert, $class->members_values ) |
2576
|
|
|
|
|
|
|
{ |
2577
|
3
|
|
|
|
|
20
|
$form .= ' ' . $member->assertion($class) . "\n"; |
2578
|
|
|
|
|
|
|
} |
2579
|
57
|
|
|
|
|
156
|
return $form; |
2580
|
|
|
|
|
|
|
} |
2581
|
|
|
|
|
|
|
|
2582
|
|
|
|
|
|
|
sub form |
2583
|
|
|
|
|
|
|
{ |
2584
|
57
|
|
|
57
|
|
123
|
my $self = shift; |
2585
|
57
|
|
|
|
|
101
|
my $class = $_[0]; |
2586
|
57
|
|
|
|
|
128
|
my $style = $self->style; |
2587
|
57
|
|
|
|
|
153
|
my ( $iv, $cv ) = ( $class->instance_var, $class->class_var ); |
2588
|
57
|
|
|
|
|
106
|
my $form; |
2589
|
57
|
100
|
|
|
|
261
|
$form = |
2590
|
|
|
|
|
|
|
"sub new {\n" |
2591
|
|
|
|
|
|
|
. " my $cv = " |
2592
|
|
|
|
|
|
|
. ( |
2593
|
|
|
|
|
|
|
$class->nfi |
2594
|
|
|
|
|
|
|
? 'do { my $proto = shift; ref $proto || $proto }' |
2595
|
|
|
|
|
|
|
: 'shift' |
2596
|
|
|
|
|
|
|
) . ";\n"; |
2597
|
57
|
100
|
66
|
|
|
142
|
if ( $class->check_params && $class->virtual ) |
2598
|
|
|
|
|
|
|
{ |
2599
|
1
|
|
|
|
|
5
|
$form .= |
2600
|
|
|
|
|
|
|
q| croak '| |
2601
|
|
|
|
|
|
|
. $self->name_form($class) |
2602
|
|
|
|
|
|
|
. q|Virtual class' unless $class ne '| |
2603
|
|
|
|
|
|
|
. $class->name |
2604
|
|
|
|
|
|
|
. qq|';\n|; |
2605
|
|
|
|
|
|
|
} |
2606
|
57
|
100
|
66
|
|
|
175
|
$form .= $style->init_form( $class, $self ) |
2607
|
|
|
|
|
|
|
if !$class->can_assign_all_params |
2608
|
|
|
|
|
|
|
&& $style->can('init_form'); |
2609
|
57
|
50
|
|
|
|
154
|
$form .= $self->param_tests_form( $class, $style ) if $class->check_params; |
2610
|
57
|
100
|
|
|
|
158
|
if ( defined $class->parents ) |
2611
|
|
|
|
|
|
|
{ |
2612
|
11
|
|
|
|
|
40
|
$form .= $style->self_from_super_form($class); |
2613
|
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
|
else |
2615
|
|
|
|
|
|
|
{ |
2616
|
46
|
|
|
|
|
205
|
$form .= |
2617
|
|
|
|
|
|
|
' my ' |
2618
|
|
|
|
|
|
|
. $iv . ' = ' |
2619
|
|
|
|
|
|
|
. $class->base . ";\n" |
2620
|
|
|
|
|
|
|
. ' bless ' |
2621
|
|
|
|
|
|
|
. $iv . ', ' |
2622
|
|
|
|
|
|
|
. $cv . ";\n"; |
2623
|
|
|
|
|
|
|
} |
2624
|
57
|
50
|
|
|
|
159
|
if ( !$class->can_assign_all_params ) |
2625
|
|
|
|
|
|
|
{ |
2626
|
57
|
100
|
|
|
|
365
|
$form .= $class->size_establishment($iv) |
2627
|
|
|
|
|
|
|
if $class->can('size_establishment'); |
2628
|
57
|
100
|
|
|
|
289
|
if ( !$style->isa('Class::Generate::Own') ) |
2629
|
|
|
|
|
|
|
{ |
2630
|
52
|
|
|
|
|
137
|
for my $name ( $class->public_member_names ) |
2631
|
|
|
|
|
|
|
{ |
2632
|
118
|
|
|
|
|
300
|
$form .= $class->members($name) |
2633
|
|
|
|
|
|
|
->param_assignment_form( $class, $style ); |
2634
|
|
|
|
|
|
|
} |
2635
|
|
|
|
|
|
|
} |
2636
|
|
|
|
|
|
|
} |
2637
|
57
|
|
|
|
|
240
|
$form .= $class->protected_members_info_form; |
2638
|
57
|
|
100
|
|
|
150
|
for my $member ( |
2639
|
|
|
|
|
|
|
grep( ( |
2640
|
|
|
|
|
|
|
$style->isa('Class::Generate::Own') |
2641
|
|
|
|
|
|
|
|| $class->protected( $_->name ) |
2642
|
|
|
|
|
|
|
|| $class->private( $_->name ) |
2643
|
|
|
|
|
|
|
) |
2644
|
|
|
|
|
|
|
&& defined $_->default, |
2645
|
|
|
|
|
|
|
$class->members_values ) |
2646
|
|
|
|
|
|
|
) |
2647
|
|
|
|
|
|
|
{ |
2648
|
1
|
|
|
|
|
8
|
$form .= $member->default_assignment_form($class); |
2649
|
|
|
|
|
|
|
} |
2650
|
57
|
100
|
|
|
|
174
|
$form .= Class::Generate::Member_Names::substituted( $self->post ) |
2651
|
|
|
|
|
|
|
if defined $self->post; |
2652
|
57
|
50
|
|
|
|
163
|
$form .= $self->assertions_form($class) if $class->check_params; |
2653
|
57
|
|
|
|
|
171
|
$form .= ' return ' . $iv . ";\n" . "}\n"; |
2654
|
57
|
|
|
|
|
335
|
return $form; |
2655
|
|
|
|
|
|
|
} |
2656
|
|
|
|
|
|
|
|
2657
|
|
|
|
|
|
|
package Class::Generate::Method; # A user-defined method, |
2658
|
|
|
|
|
|
|
$Class::Generate::Method::VERSION = '1.18'; |
2659
|
|
|
|
|
|
|
# with a name and body. |
2660
|
|
|
|
|
|
|
sub new |
2661
|
|
|
|
|
|
|
{ |
2662
|
28
|
|
|
28
|
|
48
|
my $class = shift; |
2663
|
28
|
|
|
|
|
77
|
my $self = { name => $_[0], body => $_[1] }; |
2664
|
28
|
|
|
|
|
51
|
bless $self, $class; |
2665
|
28
|
|
|
|
|
55
|
return $self; |
2666
|
|
|
|
|
|
|
} |
2667
|
|
|
|
|
|
|
|
2668
|
|
|
|
|
|
|
sub name |
2669
|
|
|
|
|
|
|
{ |
2670
|
139
|
|
|
139
|
|
198
|
my $self = shift; |
2671
|
139
|
|
|
|
|
349
|
return $self->{'name'}; |
2672
|
|
|
|
|
|
|
} |
2673
|
|
|
|
|
|
|
|
2674
|
|
|
|
|
|
|
sub body |
2675
|
|
|
|
|
|
|
{ |
2676
|
77
|
|
|
77
|
|
118
|
my $self = shift; |
2677
|
77
|
|
|
|
|
231
|
return $self->{'body'}; |
2678
|
|
|
|
|
|
|
} |
2679
|
|
|
|
|
|
|
|
2680
|
|
|
|
|
|
|
sub comment |
2681
|
|
|
|
|
|
|
{ |
2682
|
26
|
|
|
26
|
|
40
|
my $self = shift; |
2683
|
26
|
50
|
|
|
|
102
|
return $self->{'comment'} if $#_ == -1; |
2684
|
0
|
|
|
|
|
0
|
$self->{'comment'} = $_[0]; |
2685
|
|
|
|
|
|
|
} |
2686
|
|
|
|
|
|
|
|
2687
|
|
|
|
|
|
|
sub form |
2688
|
|
|
|
|
|
|
{ |
2689
|
26
|
|
|
26
|
|
46
|
my $self = shift; |
2690
|
26
|
|
|
|
|
41
|
my $class = $_[0]; |
2691
|
26
|
|
|
|
|
41
|
my $form = ''; |
2692
|
26
|
50
|
|
|
|
60
|
$form .= Class::Generate::Support::comment_form( $self->comment ) |
2693
|
|
|
|
|
|
|
if defined $self->comment; |
2694
|
26
|
|
|
|
|
68
|
$form .= $class->sub_form( $self->name, $self->name, |
2695
|
|
|
|
|
|
|
Class::Generate::Member_Names::substituted( $self->body ) ); |
2696
|
26
|
|
|
|
|
111
|
return $form; |
2697
|
|
|
|
|
|
|
} |
2698
|
|
|
|
|
|
|
|
2699
|
|
|
|
|
|
|
package Class::Generate::Class_Method; # A user-defined class method, |
2700
|
|
|
|
|
|
|
$Class::Generate::Class_Method::VERSION = '1.18'; |
2701
|
14
|
|
|
14
|
|
147
|
use strict; # which may specify objects |
|
14
|
|
|
|
|
40
|
|
|
14
|
|
|
|
|
2075
|
|
2702
|
14
|
|
|
14
|
|
80
|
use vars qw(@ISA); # of the class used within its |
|
14
|
|
|
|
|
38
|
|
|
14
|
|
|
|
|
3440
|
|
2703
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Method); # body. |
2704
|
|
|
|
|
|
|
|
2705
|
|
|
|
|
|
|
sub objects |
2706
|
|
|
|
|
|
|
{ |
2707
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
2708
|
1
|
50
|
|
|
|
7
|
return exists $self->{'objects'} ? @{ $self->{'objects'} } : () |
|
0
|
50
|
|
|
|
0
|
|
2709
|
|
|
|
|
|
|
if $#_ == -1; |
2710
|
0
|
0
|
|
|
|
0
|
return exists $self->{'objects'} ? $self->{'objects'}->[ $_[0] ] : undef |
|
|
0
|
|
|
|
|
|
2711
|
|
|
|
|
|
|
if $#_ == 0; |
2712
|
0
|
|
|
|
|
0
|
$self->{'objects'}->[ $_[0] ] = $_[1]; |
2713
|
|
|
|
|
|
|
} |
2714
|
|
|
|
|
|
|
|
2715
|
|
|
|
|
|
|
sub add_objects |
2716
|
|
|
|
|
|
|
{ |
2717
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2718
|
0
|
|
|
|
|
0
|
push @{ $self->{'objects'} }, @_; |
|
0
|
|
|
|
|
0
|
|
2719
|
|
|
|
|
|
|
} |
2720
|
|
|
|
|
|
|
|
2721
|
|
|
|
|
|
|
sub form |
2722
|
|
|
|
|
|
|
{ |
2723
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
2724
|
2
|
|
|
|
|
4
|
my $class = $_[0]; |
2725
|
2
|
|
|
|
|
7
|
return $class->class_sub_form( $self->name, |
2726
|
|
|
|
|
|
|
Class::Generate::Member_Names::substituted_in_class_method($self) ); |
2727
|
|
|
|
|
|
|
} |
2728
|
|
|
|
|
|
|
|
2729
|
|
|
|
|
|
|
package Class::Generate::Class; # A virtual class describing |
2730
|
|
|
|
|
|
|
$Class::Generate::Class::VERSION = '1.18'; |
2731
|
14
|
|
|
14
|
|
122
|
use strict; # a user-specified class. |
|
14
|
|
|
|
|
50
|
|
|
14
|
|
|
|
|
58223
|
|
2732
|
|
|
|
|
|
|
|
2733
|
|
|
|
|
|
|
sub new |
2734
|
|
|
|
|
|
|
{ |
2735
|
62
|
|
|
62
|
|
123
|
my $class = shift; |
2736
|
62
|
|
|
|
|
388
|
my $self = { name => shift, @_ }; |
2737
|
62
|
|
|
|
|
144
|
bless $self, $class; |
2738
|
62
|
|
|
|
|
183
|
return $self; |
2739
|
|
|
|
|
|
|
} |
2740
|
|
|
|
|
|
|
|
2741
|
|
|
|
|
|
|
sub name |
2742
|
|
|
|
|
|
|
{ |
2743
|
684
|
|
|
684
|
|
950
|
my $self = shift; |
2744
|
684
|
|
|
|
|
2931
|
return $self->{'name'}; |
2745
|
|
|
|
|
|
|
} |
2746
|
|
|
|
|
|
|
|
2747
|
|
|
|
|
|
|
sub parents |
2748
|
|
|
|
|
|
|
{ |
2749
|
815
|
|
|
815
|
|
1182
|
my $self = shift; |
2750
|
815
|
100
|
|
|
|
3282
|
return exists $self->{'parents'} ? @{ $self->{'parents'} } : () |
|
213
|
50
|
|
|
|
919
|
|
2751
|
|
|
|
|
|
|
if $#_ == -1; |
2752
|
0
|
0
|
|
|
|
0
|
return exists $self->{'parents'} ? $self->{'parents'}->[ $_[0] ] : undef |
|
|
0
|
|
|
|
|
|
2753
|
|
|
|
|
|
|
if $#_ == 0; |
2754
|
0
|
|
|
|
|
0
|
$self->{'parents'}->[ $_[0] ] = $_[1]; |
2755
|
|
|
|
|
|
|
} |
2756
|
|
|
|
|
|
|
|
2757
|
|
|
|
|
|
|
sub add_parents |
2758
|
|
|
|
|
|
|
{ |
2759
|
15
|
|
|
15
|
|
31
|
my $self = shift; |
2760
|
15
|
|
|
|
|
26
|
push @{ $self->{'parents'} }, @_; |
|
15
|
|
|
|
|
58
|
|
2761
|
|
|
|
|
|
|
} |
2762
|
|
|
|
|
|
|
|
2763
|
|
|
|
|
|
|
sub members |
2764
|
|
|
|
|
|
|
{ |
2765
|
725
|
|
|
725
|
|
1113
|
my $self = shift; |
2766
|
725
|
100
|
|
|
|
1720
|
return exists $self->{'members'} ? %{ $self->{'members'} } : () |
|
52
|
100
|
|
|
|
319
|
|
2767
|
|
|
|
|
|
|
if $#_ == -1; |
2768
|
664
|
100
|
|
|
|
2780
|
return exists $self->{'members'} ? $self->{'members'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2769
|
|
|
|
|
|
|
if $#_ == 0; |
2770
|
133
|
|
|
|
|
369
|
$self->{'members'}->{ $_[0] } = $_[1]; |
2771
|
|
|
|
|
|
|
} |
2772
|
|
|
|
|
|
|
|
2773
|
|
|
|
|
|
|
sub members_keys |
2774
|
|
|
|
|
|
|
{ |
2775
|
490
|
|
|
490
|
|
673
|
my $self = shift; |
2776
|
490
|
100
|
|
|
|
914
|
return exists $self->{'members'} ? keys %{ $self->{'members'} } : (); |
|
434
|
|
|
|
|
1475
|
|
2777
|
|
|
|
|
|
|
} |
2778
|
|
|
|
|
|
|
|
2779
|
|
|
|
|
|
|
sub members_values |
2780
|
|
|
|
|
|
|
{ |
2781
|
653
|
|
|
653
|
|
951
|
my $self = shift; |
2782
|
653
|
100
|
|
|
|
1622
|
return exists $self->{'members'} ? values %{ $self->{'members'} } : (); |
|
574
|
|
|
|
|
2200
|
|
2783
|
|
|
|
|
|
|
} |
2784
|
|
|
|
|
|
|
|
2785
|
|
|
|
|
|
|
sub user_defined_methods |
2786
|
|
|
|
|
|
|
{ |
2787
|
161
|
|
|
161
|
|
273
|
my $self = shift; |
2788
|
161
|
100
|
|
|
|
569
|
return exists $self->{'udm'} ? %{ $self->{'udm'} } : () if $#_ == -1; |
|
13
|
100
|
|
|
|
265
|
|
2789
|
100
|
100
|
|
|
|
594
|
return exists $self->{'udm'} ? $self->{'udm'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2790
|
|
|
|
|
|
|
if $#_ == 0; |
2791
|
28
|
|
|
|
|
86
|
$self->{'udm'}->{ $_[0] } = $_[1]; |
2792
|
|
|
|
|
|
|
} |
2793
|
|
|
|
|
|
|
|
2794
|
|
|
|
|
|
|
sub user_defined_methods_keys |
2795
|
|
|
|
|
|
|
{ |
2796
|
200
|
|
|
200
|
|
385
|
my $self = shift; |
2797
|
200
|
100
|
|
|
|
558
|
return exists $self->{'udm'} ? keys %{ $self->{'udm'} } : (); |
|
46
|
|
|
|
|
205
|
|
2798
|
|
|
|
|
|
|
} |
2799
|
|
|
|
|
|
|
|
2800
|
|
|
|
|
|
|
sub user_defined_methods_values |
2801
|
|
|
|
|
|
|
{ |
2802
|
311
|
|
|
311
|
|
447
|
my $self = shift; |
2803
|
311
|
100
|
|
|
|
992
|
return exists $self->{'udm'} ? values %{ $self->{'udm'} } : (); |
|
70
|
|
|
|
|
375
|
|
2804
|
|
|
|
|
|
|
} |
2805
|
|
|
|
|
|
|
|
2806
|
|
|
|
|
|
|
sub class_vars |
2807
|
|
|
|
|
|
|
{ |
2808
|
123
|
|
|
123
|
|
236
|
my $self = shift; |
2809
|
123
|
100
|
|
|
|
459
|
return exists $self->{'class_vars'} ? @{ $self->{'class_vars'} } : () |
|
3
|
50
|
|
|
|
10
|
|
2810
|
|
|
|
|
|
|
if $#_ == -1; |
2811
|
|
|
|
|
|
|
return |
2812
|
0
|
0
|
|
|
|
0
|
exists $self->{'class_vars'} ? $self->{'class_vars'}->[ $_[0] ] : undef |
|
|
0
|
|
|
|
|
|
2813
|
|
|
|
|
|
|
if $#_ == 0; |
2814
|
0
|
|
|
|
|
0
|
$self->{'class_vars'}->[ $_[0] ] = $_[1]; |
2815
|
|
|
|
|
|
|
} |
2816
|
|
|
|
|
|
|
|
2817
|
|
|
|
|
|
|
sub add_class_vars |
2818
|
|
|
|
|
|
|
{ |
2819
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
2820
|
1
|
|
|
|
|
2
|
push @{ $self->{'class_vars'} }, @_; |
|
1
|
|
|
|
|
4
|
|
2821
|
|
|
|
|
|
|
} |
2822
|
|
|
|
|
|
|
|
2823
|
|
|
|
|
|
|
sub use_packages |
2824
|
|
|
|
|
|
|
{ |
2825
|
126
|
|
|
126
|
|
198
|
my $self = shift; |
2826
|
126
|
100
|
|
|
|
547
|
return exists $self->{'use_packages'} ? @{ $self->{'use_packages'} } : () |
|
12
|
50
|
|
|
|
80
|
|
2827
|
|
|
|
|
|
|
if $#_ == -1; |
2828
|
|
|
|
|
|
|
return exists $self->{'use_packages'} |
2829
|
0
|
0
|
|
|
|
0
|
? $self->{'use_packages'}->[ $_[0] ] |
|
|
0
|
|
|
|
|
|
2830
|
|
|
|
|
|
|
: undef |
2831
|
|
|
|
|
|
|
if $#_ == 0; |
2832
|
0
|
|
|
|
|
0
|
$self->{'use_packages'}->[ $_[0] ] = $_[1]; |
2833
|
|
|
|
|
|
|
} |
2834
|
|
|
|
|
|
|
|
2835
|
|
|
|
|
|
|
sub add_use_packages |
2836
|
|
|
|
|
|
|
{ |
2837
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
2838
|
4
|
|
|
|
|
9
|
push @{ $self->{'use_packages'} }, @_; |
|
4
|
|
|
|
|
15
|
|
2839
|
|
|
|
|
|
|
} |
2840
|
|
|
|
|
|
|
|
2841
|
|
|
|
|
|
|
sub excluded_methods_regexp |
2842
|
|
|
|
|
|
|
{ |
2843
|
1843
|
|
|
1843
|
|
2349
|
my $self = shift; |
2844
|
1843
|
100
|
|
|
|
4188
|
return $self->{'em'} if $#_ == -1; |
2845
|
7
|
|
|
|
|
19
|
$self->{'em'} = $_[0]; |
2846
|
|
|
|
|
|
|
} |
2847
|
|
|
|
|
|
|
|
2848
|
|
|
|
|
|
|
sub private |
2849
|
|
|
|
|
|
|
{ |
2850
|
2244
|
|
|
2244
|
|
3075
|
my $self = shift; |
2851
|
2244
|
100
|
|
|
|
4389
|
return exists $self->{'private'} ? %{ $self->{'private'} } : () |
|
4
|
100
|
|
|
|
16
|
|
2852
|
|
|
|
|
|
|
if $#_ == -1; |
2853
|
2183
|
100
|
|
|
|
8455
|
return exists $self->{'private'} ? $self->{'private'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2854
|
|
|
|
|
|
|
if $#_ == 0; |
2855
|
6
|
|
|
|
|
31
|
$self->{'private'}->{ $_[0] } = $_[1]; |
2856
|
|
|
|
|
|
|
} |
2857
|
|
|
|
|
|
|
|
2858
|
|
|
|
|
|
|
sub protected |
2859
|
|
|
|
|
|
|
{ |
2860
|
1675
|
|
|
1675
|
|
2386
|
my $self = shift; |
2861
|
1675
|
100
|
|
|
|
3252
|
return exists $self->{'protected'} ? %{ $self->{'protected'} } : () |
|
4
|
100
|
|
|
|
21
|
|
2862
|
|
|
|
|
|
|
if $#_ == -1; |
2863
|
|
|
|
|
|
|
return |
2864
|
1614
|
100
|
|
|
|
6020
|
exists $self->{'protected'} ? $self->{'protected'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2865
|
|
|
|
|
|
|
if $#_ == 0; |
2866
|
9
|
|
|
|
|
56
|
$self->{'protected'}->{ $_[0] } = $_[1]; |
2867
|
|
|
|
|
|
|
} |
2868
|
|
|
|
|
|
|
|
2869
|
|
|
|
|
|
|
sub required |
2870
|
|
|
|
|
|
|
{ |
2871
|
681
|
|
|
681
|
|
982
|
my $self = shift; |
2872
|
681
|
0
|
|
|
|
1348
|
return exists $self->{'required'} ? %{ $self->{'required'} } : () |
|
0
|
50
|
|
|
|
0
|
|
2873
|
|
|
|
|
|
|
if $#_ == -1; |
2874
|
681
|
100
|
|
|
|
3236
|
return exists $self->{'required'} ? $self->{'required'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2875
|
|
|
|
|
|
|
if $#_ == 0; |
2876
|
34
|
|
|
|
|
140
|
$self->{'required'}->{ $_[0] } = $_[1]; |
2877
|
|
|
|
|
|
|
} |
2878
|
|
|
|
|
|
|
|
2879
|
|
|
|
|
|
|
sub readonly |
2880
|
|
|
|
|
|
|
{ |
2881
|
743
|
|
|
743
|
|
1092
|
my $self = shift; |
2882
|
743
|
0
|
|
|
|
1470
|
return exists $self->{'readonly'} ? %{ $self->{'readonly'} } : () |
|
0
|
50
|
|
|
|
0
|
|
2883
|
|
|
|
|
|
|
if $#_ == -1; |
2884
|
743
|
100
|
|
|
|
3193
|
return exists $self->{'readonly'} ? $self->{'readonly'}->{ $_[0] } : undef |
|
|
100
|
|
|
|
|
|
2885
|
|
|
|
|
|
|
if $#_ == 0; |
2886
|
26
|
|
|
|
|
149
|
$self->{'readonly'}->{ $_[0] } = $_[1]; |
2887
|
|
|
|
|
|
|
} |
2888
|
|
|
|
|
|
|
|
2889
|
|
|
|
|
|
|
sub constructor |
2890
|
|
|
|
|
|
|
{ |
2891
|
491
|
|
|
491
|
|
722
|
my $self = shift; |
2892
|
491
|
100
|
|
|
|
1584
|
return $self->{'constructor'} if $#_ == -1; |
2893
|
62
|
|
|
|
|
176
|
$self->{'constructor'} = $_[0]; |
2894
|
|
|
|
|
|
|
} |
2895
|
|
|
|
|
|
|
|
2896
|
|
|
|
|
|
|
sub virtual |
2897
|
|
|
|
|
|
|
{ |
2898
|
66
|
|
|
66
|
|
129
|
my $self = shift; |
2899
|
66
|
50
|
|
|
|
331
|
return $self->{'virtual'} if $#_ == -1; |
2900
|
0
|
|
|
|
|
0
|
$self->{'virtual'} = $_[0]; |
2901
|
|
|
|
|
|
|
} |
2902
|
|
|
|
|
|
|
|
2903
|
|
|
|
|
|
|
sub comment |
2904
|
|
|
|
|
|
|
{ |
2905
|
62
|
|
|
62
|
|
100
|
my $self = shift; |
2906
|
62
|
50
|
|
|
|
274
|
return $self->{'comment'} if $#_ == -1; |
2907
|
0
|
|
|
|
|
0
|
$self->{'comment'} = $_[0]; |
2908
|
|
|
|
|
|
|
} |
2909
|
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
|
sub accept_refs |
2911
|
|
|
|
|
|
|
{ |
2912
|
61
|
|
|
61
|
|
95
|
my $self = shift; |
2913
|
61
|
|
|
|
|
164
|
return $self->{'accept_refs'}; |
2914
|
|
|
|
|
|
|
} |
2915
|
|
|
|
|
|
|
|
2916
|
|
|
|
|
|
|
sub strict |
2917
|
|
|
|
|
|
|
{ |
2918
|
122
|
|
|
122
|
|
234
|
my $self = shift; |
2919
|
122
|
|
|
|
|
425
|
return $self->{'strict'}; |
2920
|
|
|
|
|
|
|
} |
2921
|
|
|
|
|
|
|
|
2922
|
|
|
|
|
|
|
sub nfi |
2923
|
|
|
|
|
|
|
{ |
2924
|
57
|
|
|
57
|
|
112
|
my $self = shift; |
2925
|
57
|
|
|
|
|
221
|
return $self->{'nfi'}; |
2926
|
|
|
|
|
|
|
} |
2927
|
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
|
sub warnings |
2929
|
|
|
|
|
|
|
{ |
2930
|
61
|
|
|
61
|
|
113
|
my $self = shift; |
2931
|
61
|
50
|
|
|
|
154
|
return $self->{'warnings'} if $#_ == -1; |
2932
|
61
|
|
|
|
|
132
|
$self->{'warnings'} = $_[0]; |
2933
|
|
|
|
|
|
|
} |
2934
|
|
|
|
|
|
|
|
2935
|
|
|
|
|
|
|
sub check_params |
2936
|
|
|
|
|
|
|
{ |
2937
|
1318
|
|
|
1318
|
|
1810
|
my $self = shift; |
2938
|
1318
|
100
|
|
|
|
6320
|
return $self->{'check_params'} if $#_ == -1; |
2939
|
61
|
|
|
|
|
127
|
$self->{'check_params'} = $_[0]; |
2940
|
|
|
|
|
|
|
} |
2941
|
|
|
|
|
|
|
|
2942
|
|
|
|
|
|
|
sub instance_methods |
2943
|
|
|
|
|
|
|
{ |
2944
|
2
|
|
|
2
|
|
6
|
my $self = shift; |
2945
|
2
|
|
|
|
|
6
|
return grep !$_->isa('Class::Generate::Class_Method'), |
2946
|
|
|
|
|
|
|
$self->user_defined_methods_values; |
2947
|
|
|
|
|
|
|
} |
2948
|
|
|
|
|
|
|
|
2949
|
|
|
|
|
|
|
sub class_methods |
2950
|
|
|
|
|
|
|
{ |
2951
|
61
|
|
|
61
|
|
108
|
my $self = shift; |
2952
|
61
|
|
|
|
|
179
|
return grep $_->isa('Class::Generate::Class_Method'), |
2953
|
|
|
|
|
|
|
$self->user_defined_methods_values; |
2954
|
|
|
|
|
|
|
} |
2955
|
|
|
|
|
|
|
|
2956
|
|
|
|
|
|
|
sub include_method |
2957
|
|
|
|
|
|
|
{ |
2958
|
1714
|
|
|
1714
|
|
2377
|
my $self = shift; |
2959
|
1714
|
|
|
|
|
2260
|
my $method_name = $_[0]; |
2960
|
1714
|
|
|
|
|
2601
|
my $r = $self->excluded_methods_regexp; |
2961
|
1714
|
|
100
|
|
|
5948
|
return !defined $r || $method_name !~ m/$r/; |
2962
|
|
|
|
|
|
|
} |
2963
|
|
|
|
|
|
|
|
2964
|
|
|
|
|
|
|
sub member_methods_form |
2965
|
|
|
|
|
|
|
{ # Return a form containing methods for all |
2966
|
61
|
|
|
61
|
|
109
|
my $self = shift; # non-private members in the class, plus |
2967
|
61
|
|
|
|
|
103
|
my $form = ''; # private members used in class methods. |
2968
|
61
|
|
|
|
|
186
|
for my $element ( |
2969
|
|
|
|
|
|
|
$self->public_member_names, |
2970
|
|
|
|
|
|
|
$self->protected_member_names, |
2971
|
|
|
|
|
|
|
$self->private_members_used_in_user_defined_code |
2972
|
|
|
|
|
|
|
) |
2973
|
|
|
|
|
|
|
{ |
2974
|
132
|
|
|
|
|
340
|
$form .= $self->members($element)->form($self); |
2975
|
|
|
|
|
|
|
} |
2976
|
61
|
100
|
|
|
|
207
|
$form .= "\n" if $form ne ''; |
2977
|
61
|
|
|
|
|
400
|
return $form; |
2978
|
|
|
|
|
|
|
} |
2979
|
|
|
|
|
|
|
|
2980
|
|
|
|
|
|
|
sub user_defined_methods_form |
2981
|
|
|
|
|
|
|
{ # Return a form containing all |
2982
|
61
|
|
|
61
|
|
120
|
my $self = shift; # user-defined methods. |
2983
|
61
|
|
|
|
|
160
|
my $form = |
2984
|
|
|
|
|
|
|
join( '', map( $_->form($self), $self->user_defined_methods_values ) ); |
2985
|
61
|
100
|
|
|
|
298
|
return length $form > 0 ? $form . "\n" : ''; |
2986
|
|
|
|
|
|
|
} |
2987
|
|
|
|
|
|
|
|
2988
|
|
|
|
|
|
|
sub warnings_pragmas |
2989
|
|
|
|
|
|
|
{ # Return an array containing the |
2990
|
122
|
|
|
122
|
|
207
|
my $self = shift; # warnings pragmas for the class. |
2991
|
122
|
|
|
|
|
244
|
my $w = $self->{'warnings'}; |
2992
|
122
|
50
|
|
|
|
302
|
return () if !defined $w; |
2993
|
122
|
50
|
|
|
|
254
|
return ('no warnings;') if !$w; |
2994
|
122
|
50
|
|
|
|
926
|
return ('use warnings;') if $w =~ /^\d+$/; |
2995
|
0
|
0
|
|
|
|
0
|
return ("use warnings $w;") if !ref $w; |
2996
|
|
|
|
|
|
|
|
2997
|
0
|
|
|
|
|
0
|
my @pragmas; |
2998
|
0
|
|
|
|
|
0
|
for ( my $i = 0 ; $i <= $#$w ; $i += 2 ) |
2999
|
|
|
|
|
|
|
{ |
3000
|
0
|
|
|
|
|
0
|
my ( $key, $value ) = ( $$w[$i], $$w[ $i + 1 ] ); |
3001
|
0
|
0
|
0
|
|
|
0
|
if ( $key eq 'register' ) |
|
|
0
|
|
|
|
|
|
3002
|
|
|
|
|
|
|
{ |
3003
|
0
|
0
|
|
|
|
0
|
push @pragmas, 'use warnings::register;' if $value; |
3004
|
|
|
|
|
|
|
} |
3005
|
|
|
|
|
|
|
elsif ( defined $value && $value ) |
3006
|
|
|
|
|
|
|
{ |
3007
|
0
|
0
|
|
|
|
0
|
if ( $value =~ /^\d+$/ ) |
3008
|
|
|
|
|
|
|
{ |
3009
|
0
|
|
|
|
|
0
|
push @pragmas, $key . ' warnings;'; |
3010
|
|
|
|
|
|
|
} |
3011
|
|
|
|
|
|
|
else |
3012
|
|
|
|
|
|
|
{ |
3013
|
0
|
|
|
|
|
0
|
push @pragmas, $key . ' warnings ' . $value . ';'; |
3014
|
|
|
|
|
|
|
} |
3015
|
|
|
|
|
|
|
} |
3016
|
|
|
|
|
|
|
} |
3017
|
0
|
|
|
|
|
0
|
return @pragmas; |
3018
|
|
|
|
|
|
|
} |
3019
|
|
|
|
|
|
|
|
3020
|
|
|
|
|
|
|
sub warnings_form |
3021
|
|
|
|
|
|
|
{ # Return a form representing the |
3022
|
61
|
|
|
61
|
|
114
|
my $self = shift; # warnings pragmas for a class. |
3023
|
61
|
|
|
|
|
134
|
my @warnings_pragmas = $self->warnings_pragmas; |
3024
|
61
|
50
|
|
|
|
321
|
return @warnings_pragmas ? join( "\n", @warnings_pragmas ) . "\n" : ''; |
3025
|
|
|
|
|
|
|
} |
3026
|
|
|
|
|
|
|
|
3027
|
|
|
|
|
|
|
sub form |
3028
|
|
|
|
|
|
|
{ # Return a form representing |
3029
|
61
|
|
|
61
|
|
121
|
my $self = shift; # a class. |
3030
|
61
|
|
|
|
|
94
|
my $form; |
3031
|
61
|
|
|
|
|
151
|
$form = 'package ' . $self->name . ";\n"; |
3032
|
61
|
50
|
|
|
|
157
|
$form .= "use strict;\n" if $self->strict; |
3033
|
61
|
100
|
|
|
|
167
|
$form .= join( "\n", map( "use $_;", $self->use_packages ) ) . "\n" |
3034
|
|
|
|
|
|
|
if $self->use_packages; |
3035
|
61
|
50
|
|
|
|
208
|
$form .= "use Carp;\n" if defined $self->{'check_params'}; |
3036
|
61
|
|
|
|
|
217
|
$form .= $self->warnings_form; |
3037
|
61
|
|
|
|
|
198
|
$form .= Class::Generate::Class_Holder::form($self); |
3038
|
61
|
|
|
|
|
128
|
$form .= "\n"; |
3039
|
61
|
100
|
|
|
|
218
|
$form .= Class::Generate::Support::comment_form( $self->comment ) |
3040
|
|
|
|
|
|
|
if defined $self->comment; |
3041
|
61
|
100
|
|
|
|
207
|
$form .= $self->isa_decl_form if $self->parents; |
3042
|
61
|
100
|
|
|
|
182
|
$form .= $self->private_methods_decl_form |
3043
|
|
|
|
|
|
|
if grep $self->private($_), $self->user_defined_methods_keys; |
3044
|
61
|
100
|
|
|
|
257
|
$form .= $self->private_members_decl_form |
3045
|
|
|
|
|
|
|
if $self->private_members_used_in_user_defined_code; |
3046
|
61
|
100
|
|
|
|
143
|
$form .= $self->protected_methods_decl_form |
3047
|
|
|
|
|
|
|
if grep $self->protected($_), $self->user_defined_methods_keys; |
3048
|
61
|
100
|
|
|
|
144
|
$form .= $self->protected_members_decl_form |
3049
|
|
|
|
|
|
|
if grep $self->protected($_), $self->members_keys; |
3050
|
61
|
100
|
|
|
|
201
|
$form .= join( "\n", map( class_var_form($_), $self->class_vars ) ) . "\n\n" |
3051
|
|
|
|
|
|
|
if $self->class_vars; |
3052
|
61
|
100
|
|
|
|
212
|
$form .= $self->constructor->form($self) if $self->needs_constructor; |
3053
|
61
|
|
|
|
|
264
|
$form .= $self->member_methods_form; |
3054
|
61
|
|
|
|
|
274
|
$form .= $self->user_defined_methods_form; |
3055
|
61
|
|
|
|
|
164
|
my $emr = $self->excluded_methods_regexp; |
3056
|
61
|
100
|
100
|
|
|
405
|
$form .= $self->copy_form if !defined $emr || 'copy' !~ m/$emr/; |
3057
|
61
|
50
|
100
|
|
|
412
|
$form .= $self->equals_form |
|
|
|
66
|
|
|
|
|
3058
|
|
|
|
|
|
|
if ( !defined $emr || 'equals' !~ m/$emr/ ) |
3059
|
|
|
|
|
|
|
&& !defined $self->user_defined_methods('equals'); |
3060
|
61
|
|
|
|
|
228
|
return $form; |
3061
|
|
|
|
|
|
|
} |
3062
|
|
|
|
|
|
|
|
3063
|
|
|
|
|
|
|
sub class_var_form |
3064
|
|
|
|
|
|
|
{ # Return a form for declaring a class |
3065
|
1
|
|
|
1
|
|
2
|
my $var_spec = $_[0]; # variable. Account for an initial value. |
3066
|
1
|
50
|
|
|
|
7
|
return "my $var_spec;" if !ref $var_spec; |
3067
|
|
|
|
|
|
|
return map { |
3068
|
0
|
|
|
|
|
0
|
my $value = $$var_spec{$_}; |
|
0
|
|
|
|
|
0
|
|
3069
|
0
|
0
|
|
|
|
0
|
"my $_ = " |
3070
|
|
|
|
|
|
|
. ( ref $value ? substr( $_, 0, 1 ) . "{$value}" : $value ) . ';' |
3071
|
|
|
|
|
|
|
} keys %$var_spec; |
3072
|
|
|
|
|
|
|
} |
3073
|
|
|
|
|
|
|
|
3074
|
|
|
|
|
|
|
sub isa_decl_form |
3075
|
|
|
|
|
|
|
{ |
3076
|
15
|
|
|
15
|
|
42
|
my $self = shift; |
3077
|
15
|
50
|
|
|
|
37
|
my @parent_names = map !ref $_ ? $_ : $_->name, $self->parents; |
3078
|
|
|
|
|
|
|
return |
3079
|
15
|
|
|
|
|
60
|
"use vars qw(\@ISA);\n" |
3080
|
|
|
|
|
|
|
. '@ISA = qw(' |
3081
|
|
|
|
|
|
|
. join( ' ', @parent_names ) . ");\n"; |
3082
|
|
|
|
|
|
|
} |
3083
|
|
|
|
|
|
|
|
3084
|
|
|
|
|
|
|
sub sub_form |
3085
|
|
|
|
|
|
|
{ # Return a declaration for a sub, as an |
3086
|
426
|
|
|
426
|
|
640
|
my $self = shift; # assignment to a variable if not public. |
3087
|
426
|
|
|
|
|
860
|
my ( $element_name, $sub_name, $body ) = @_; |
3088
|
426
|
|
|
|
|
601
|
my ( $form, $not_public ); |
3089
|
426
|
|
100
|
|
|
860
|
$not_public = |
3090
|
|
|
|
|
|
|
$self->private($element_name) || $self->protected($element_name); |
3091
|
426
|
100
|
|
|
|
1337
|
$form = |
3092
|
|
|
|
|
|
|
( $not_public ? "\$$sub_name = sub" : "sub $sub_name" ) . " {\n" |
3093
|
|
|
|
|
|
|
. ' my ' |
3094
|
|
|
|
|
|
|
. $self->instance_var |
3095
|
|
|
|
|
|
|
. " = shift;\n" |
3096
|
|
|
|
|
|
|
. $body . '}'; |
3097
|
426
|
100
|
|
|
|
948
|
$form .= ';' if $not_public; |
3098
|
426
|
|
|
|
|
1579
|
return $form . "\n"; |
3099
|
|
|
|
|
|
|
} |
3100
|
|
|
|
|
|
|
|
3101
|
|
|
|
|
|
|
sub class_sub_form |
3102
|
|
|
|
|
|
|
{ # Ditto, but for a class method. |
3103
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
3104
|
2
|
|
|
|
|
6
|
my ( $method_name, $body ) = @_; |
3105
|
2
|
|
|
|
|
4
|
my ( $form, $not_public ); |
3106
|
2
|
|
33
|
|
|
6
|
$not_public = |
3107
|
|
|
|
|
|
|
$self->private($method_name) || $self->protected($method_name); |
3108
|
2
|
50
|
|
|
|
26
|
$form = |
3109
|
|
|
|
|
|
|
( $not_public ? "\$$method_name = sub" : "sub $method_name" ) . " {\n" |
3110
|
|
|
|
|
|
|
. ' my ' |
3111
|
|
|
|
|
|
|
. $self->class_var |
3112
|
|
|
|
|
|
|
. " = shift;\n" |
3113
|
|
|
|
|
|
|
. $body . '}'; |
3114
|
2
|
50
|
|
|
|
20
|
$form .= ';' if $not_public; |
3115
|
2
|
|
|
|
|
15
|
return $form . "\n"; |
3116
|
|
|
|
|
|
|
} |
3117
|
|
|
|
|
|
|
|
3118
|
|
|
|
|
|
|
sub private_methods_decl_form |
3119
|
|
|
|
|
|
|
{ # Private methods are implemented as CODE refs. |
3120
|
1
|
|
|
1
|
|
3
|
my $self = shift; # Return a form declaring the variables to hold them. |
3121
|
1
|
|
|
|
|
2
|
my @private_methods = grep $self->private($_), |
3122
|
|
|
|
|
|
|
$self->user_defined_methods_keys; |
3123
|
1
|
|
|
|
|
6
|
return Class::Generate::Support::my_decl_form( map "\$$_", |
3124
|
|
|
|
|
|
|
@private_methods ); |
3125
|
|
|
|
|
|
|
} |
3126
|
|
|
|
|
|
|
|
3127
|
|
|
|
|
|
|
sub private_members_used_in_user_defined_code |
3128
|
|
|
|
|
|
|
{ # Return the names of all private |
3129
|
124
|
|
|
124
|
|
219
|
my $self = shift; # members that appear in user-defined code. |
3130
|
124
|
|
|
|
|
279
|
my @private_members = grep $self->private($_), $self->members_keys; |
3131
|
124
|
100
|
|
|
|
416
|
return () if !@private_members; |
3132
|
8
|
|
|
|
|
19
|
my $member_regexp = join '|', @private_members; |
3133
|
8
|
|
|
|
|
15
|
my %private_members; |
3134
|
8
|
|
|
|
|
17
|
for my $code ( |
3135
|
|
|
|
|
|
|
map( $_->body, $self->user_defined_methods_values ), |
3136
|
|
|
|
|
|
|
grep( defined $_, |
3137
|
|
|
|
|
|
|
( |
3138
|
|
|
|
|
|
|
map( ( $_->pre, $_->post, $_->assert ), $self->members_values ), |
3139
|
|
|
|
|
|
|
map( ( $_->post, $_->assert ), $self->constructor ) |
3140
|
|
|
|
|
|
|
) ) |
3141
|
|
|
|
|
|
|
) |
3142
|
|
|
|
|
|
|
{ |
3143
|
21
|
|
|
|
|
157
|
while ( $code =~ /($member_regexp)/g ) |
3144
|
|
|
|
|
|
|
{ |
3145
|
66
|
|
|
|
|
277
|
$private_members{$1}++; |
3146
|
|
|
|
|
|
|
} |
3147
|
|
|
|
|
|
|
} |
3148
|
8
|
|
|
|
|
53
|
return keys %private_members; |
3149
|
|
|
|
|
|
|
} |
3150
|
|
|
|
|
|
|
|
3151
|
|
|
|
|
|
|
sub nonpublic_members_decl_form |
3152
|
|
|
|
|
|
|
{ |
3153
|
6
|
|
|
6
|
|
17
|
my $self = shift; |
3154
|
6
|
|
|
|
|
14
|
my @members = @_; |
3155
|
6
|
|
|
|
|
29
|
my @accessor_names = map( $_->accessor_names( $self, $_->name ), @members ); |
3156
|
6
|
|
|
|
|
58
|
return Class::Generate::Support::my_decl_form( map "\$$_", |
3157
|
|
|
|
|
|
|
@accessor_names ); |
3158
|
|
|
|
|
|
|
} |
3159
|
|
|
|
|
|
|
|
3160
|
|
|
|
|
|
|
sub private_members_decl_form |
3161
|
|
|
|
|
|
|
{ |
3162
|
2
|
|
|
2
|
|
6
|
my $self = shift; |
3163
|
2
|
|
|
|
|
6
|
return $self->nonpublic_members_decl_form( map $self->members($_), |
3164
|
|
|
|
|
|
|
$self->private_members_used_in_user_defined_code ); |
3165
|
|
|
|
|
|
|
} |
3166
|
|
|
|
|
|
|
|
3167
|
|
|
|
|
|
|
sub protected_methods_decl_form |
3168
|
|
|
|
|
|
|
{ |
3169
|
1
|
|
|
1
|
|
5
|
my $self = shift; |
3170
|
1
|
100
|
|
|
|
3
|
return Class::Generate::Support::my_decl_form( |
3171
|
|
|
|
|
|
|
map $self->protected($_) ? "\$$_" : (), |
3172
|
|
|
|
|
|
|
$self->user_defined_methods_keys |
3173
|
|
|
|
|
|
|
); |
3174
|
|
|
|
|
|
|
} |
3175
|
|
|
|
|
|
|
|
3176
|
|
|
|
|
|
|
sub protected_members_decl_form |
3177
|
|
|
|
|
|
|
{ |
3178
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
3179
|
4
|
|
|
|
|
11
|
return $self->nonpublic_members_decl_form( |
3180
|
|
|
|
|
|
|
grep $self->protected( $_->name ), |
3181
|
|
|
|
|
|
|
$self->members_values ); |
3182
|
|
|
|
|
|
|
} |
3183
|
|
|
|
|
|
|
|
3184
|
|
|
|
|
|
|
sub protected_members_info_form |
3185
|
|
|
|
|
|
|
{ |
3186
|
57
|
|
|
57
|
|
100
|
my $self = shift; |
3187
|
57
|
|
|
|
|
144
|
my @protected_members = grep $self->protected( $_->name ), |
3188
|
|
|
|
|
|
|
$self->members_values; |
3189
|
57
|
|
|
|
|
162
|
my @protected_methods = grep $self->protected( $_->name ), |
3190
|
|
|
|
|
|
|
$self->user_defined_methods_values; |
3191
|
57
|
100
|
66
|
|
|
338
|
return '' if !( @protected_members || @protected_methods ); |
3192
|
4
|
|
|
|
|
12
|
my $info_index_lvalue = |
3193
|
|
|
|
|
|
|
$self->instance_var . '->' . $self->protected_members_info_index; |
3194
|
4
|
|
|
|
|
15
|
my @protected_element_names = ( |
3195
|
|
|
|
|
|
|
map( $_->accessor_names( $class, $_->name ), @protected_members ), |
3196
|
|
|
|
|
|
|
map( $_->name, @protected_methods ) |
3197
|
|
|
|
|
|
|
); |
3198
|
4
|
50
|
|
|
|
12
|
if ( $self->parents ) |
3199
|
|
|
|
|
|
|
{ |
3200
|
0
|
|
|
|
|
0
|
my $form = ''; |
3201
|
0
|
|
|
|
|
0
|
for my $element_name (@protected_element_names) |
3202
|
|
|
|
|
|
|
{ |
3203
|
0
|
|
|
|
|
0
|
$form .= |
3204
|
|
|
|
|
|
|
" ${info_index_lvalue}->{'$element_name'} = \$$element_name;\n"; |
3205
|
|
|
|
|
|
|
} |
3206
|
0
|
|
|
|
|
0
|
return $form; |
3207
|
|
|
|
|
|
|
} |
3208
|
|
|
|
|
|
|
else |
3209
|
|
|
|
|
|
|
{ |
3210
|
|
|
|
|
|
|
return |
3211
|
4
|
|
|
|
|
60
|
" $info_index_lvalue = { " |
3212
|
|
|
|
|
|
|
. join( ', ', map "$_ => \$$_", @protected_element_names ) |
3213
|
|
|
|
|
|
|
. " };\n"; |
3214
|
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
|
} |
3216
|
|
|
|
|
|
|
|
3217
|
|
|
|
|
|
|
sub copy_form |
3218
|
|
|
|
|
|
|
{ |
3219
|
59
|
|
|
59
|
|
104
|
my $self = shift; |
3220
|
59
|
|
|
|
|
114
|
my ( $form, @members, $has_parents ); |
3221
|
59
|
|
|
|
|
132
|
@members = $self->members_values; |
3222
|
59
|
|
|
|
|
154
|
$has_parents = defined $self->parents; |
3223
|
59
|
|
|
|
|
127
|
$form = "sub copy {\n" . " my \$self = shift;\n" . " my \$copy;\n"; |
3224
|
59
|
100
|
100
|
|
|
101
|
if ( |
3225
|
|
|
|
|
|
|
!( |
3226
|
|
|
|
|
|
|
do |
3227
|
|
|
|
|
|
|
{ |
3228
|
|
|
|
|
|
|
my $has_complex_mems; |
3229
|
|
|
|
|
|
|
for my $m (@members) |
3230
|
|
|
|
|
|
|
{ |
3231
|
|
|
|
|
|
|
if ( $m->isa('Class::Generate::List_Member') |
3232
|
|
|
|
|
|
|
|| defined $m->base ) |
3233
|
|
|
|
|
|
|
{ |
3234
|
|
|
|
|
|
|
$has_complex_mems = 1; |
3235
|
|
|
|
|
|
|
last; |
3236
|
|
|
|
|
|
|
} |
3237
|
|
|
|
|
|
|
} |
3238
|
|
|
|
|
|
|
$has_complex_mems; |
3239
|
|
|
|
|
|
|
} |
3240
|
|
|
|
|
|
|
|| $has_parents |
3241
|
|
|
|
|
|
|
) |
3242
|
|
|
|
|
|
|
) |
3243
|
|
|
|
|
|
|
{ |
3244
|
20
|
|
|
|
|
64
|
$form .= ' $copy = ' . $self->wholesale_copy . ";\n"; |
3245
|
|
|
|
|
|
|
} |
3246
|
|
|
|
|
|
|
else |
3247
|
|
|
|
|
|
|
{ |
3248
|
39
|
100
|
|
|
|
224
|
$form .= |
3249
|
|
|
|
|
|
|
' $copy = ' |
3250
|
|
|
|
|
|
|
. ( $has_parents ? '$self->SUPER::copy' : $self->empty_form ) |
3251
|
|
|
|
|
|
|
. ";\n"; |
3252
|
39
|
100
|
|
|
|
201
|
$form .= $self->size_establishment('$copy') |
3253
|
|
|
|
|
|
|
if $self->can('size_establishment'); |
3254
|
39
|
|
|
|
|
108
|
for my $m (@members) |
3255
|
|
|
|
|
|
|
{ |
3256
|
96
|
|
|
|
|
220
|
my $index = $self->index( $m->name ); |
3257
|
96
|
|
|
|
|
442
|
$form .= $m->copy_form( '$self->' . $index, '$copy->' . $index ); |
3258
|
|
|
|
|
|
|
} |
3259
|
|
|
|
|
|
|
} |
3260
|
59
|
|
|
|
|
149
|
$form .= " bless \$copy, ref \$self;\n" . " return \$copy;\n" . "}\n"; |
3261
|
59
|
|
|
|
|
346
|
return $form; |
3262
|
|
|
|
|
|
|
} |
3263
|
|
|
|
|
|
|
|
3264
|
|
|
|
|
|
|
sub equals_form |
3265
|
|
|
|
|
|
|
{ |
3266
|
59
|
|
|
59
|
|
170
|
my $self = shift; |
3267
|
59
|
|
|
|
|
114
|
my ( $form, @parents, @members, $existence_test, @local_vars, |
3268
|
|
|
|
|
|
|
@key_members ); |
3269
|
59
|
|
|
|
|
131
|
@parents = $self->parents; |
3270
|
59
|
|
|
|
|
136
|
@members = $self->members_values; |
3271
|
59
|
100
|
|
|
|
246
|
if ( @key_members = grep $_->key, @members ) |
3272
|
|
|
|
|
|
|
{ |
3273
|
2
|
|
|
|
|
5
|
@members = @key_members; |
3274
|
|
|
|
|
|
|
} |
3275
|
59
|
|
|
|
|
145
|
$existence_test = $self->existence_test; |
3276
|
59
|
|
|
|
|
135
|
$form = |
3277
|
|
|
|
|
|
|
"sub equals {\n" |
3278
|
|
|
|
|
|
|
. " my \$self = shift;\n" |
3279
|
|
|
|
|
|
|
. " my \$o = \$_[0];\n"; |
3280
|
59
|
|
|
|
|
183
|
for my $m (@members) |
3281
|
|
|
|
|
|
|
{ |
3282
|
51
|
50
|
|
|
|
317
|
if ( $m->isa('Class::Generate::Hash_Member'), @members ) |
3283
|
|
|
|
|
|
|
{ |
3284
|
51
|
|
|
|
|
115
|
push @local_vars, qw($self_value_defined @self_keys); |
3285
|
51
|
|
|
|
|
105
|
last; |
3286
|
|
|
|
|
|
|
} |
3287
|
|
|
|
|
|
|
} |
3288
|
59
|
|
|
|
|
125
|
for my $m (@members) |
3289
|
|
|
|
|
|
|
{ |
3290
|
51
|
50
|
|
|
|
229
|
if ( $m->isa('Class::Generate::Array_Member'), @members ) |
3291
|
|
|
|
|
|
|
{ |
3292
|
51
|
|
|
|
|
98
|
push @local_vars, qw($ub); |
3293
|
51
|
|
|
|
|
76
|
last; |
3294
|
|
|
|
|
|
|
} |
3295
|
|
|
|
|
|
|
} |
3296
|
59
|
100
|
|
|
|
133
|
if (@local_vars) |
3297
|
|
|
|
|
|
|
{ |
3298
|
51
|
|
|
|
|
225
|
$form .= ' my (' . join( ', ', @local_vars ) . ");\n"; |
3299
|
|
|
|
|
|
|
} |
3300
|
59
|
100
|
|
|
|
145
|
if (@parents) |
3301
|
|
|
|
|
|
|
{ |
3302
|
14
|
|
|
|
|
31
|
$form .= " return undef unless \$self->SUPER::equals(\$o);\n"; |
3303
|
|
|
|
|
|
|
} |
3304
|
59
|
|
|
|
|
201
|
$form .= join( "\n", |
3305
|
|
|
|
|
|
|
map $_->equals( $self->index( $_->name ), $existence_test ), @members ) |
3306
|
|
|
|
|
|
|
. " return 1;\n" . "}\n"; |
3307
|
59
|
|
|
|
|
390
|
return $form; |
3308
|
|
|
|
|
|
|
} |
3309
|
|
|
|
|
|
|
|
3310
|
|
|
|
|
|
|
sub all_members_required |
3311
|
|
|
|
|
|
|
{ |
3312
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3313
|
0
|
|
|
|
|
0
|
for my $m ( $self->members_keys ) |
3314
|
|
|
|
|
|
|
{ |
3315
|
0
|
0
|
0
|
|
|
0
|
return 0 if !( $self->private($m) || $self->required($m) ); |
3316
|
|
|
|
|
|
|
} |
3317
|
0
|
|
|
|
|
0
|
return 1; |
3318
|
|
|
|
|
|
|
} |
3319
|
|
|
|
|
|
|
|
3320
|
|
|
|
|
|
|
sub private_member_names |
3321
|
|
|
|
|
|
|
{ |
3322
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3323
|
0
|
|
|
|
|
0
|
return grep $self->private($_), $self->members_keys; |
3324
|
|
|
|
|
|
|
} |
3325
|
|
|
|
|
|
|
|
3326
|
|
|
|
|
|
|
sub protected_member_names |
3327
|
|
|
|
|
|
|
{ |
3328
|
61
|
|
|
61
|
|
130
|
my $self = shift; |
3329
|
61
|
|
|
|
|
130
|
return grep $self->protected($_), $self->members_keys; |
3330
|
|
|
|
|
|
|
} |
3331
|
|
|
|
|
|
|
|
3332
|
|
|
|
|
|
|
sub public_member_names |
3333
|
|
|
|
|
|
|
{ |
3334
|
244
|
|
|
244
|
|
366
|
my $self = shift; |
3335
|
244
|
|
100
|
|
|
516
|
return grep !( $self->private($_) || $self->protected($_) ), |
3336
|
|
|
|
|
|
|
$self->members_keys; |
3337
|
|
|
|
|
|
|
} |
3338
|
|
|
|
|
|
|
|
3339
|
|
|
|
|
|
|
sub class_var |
3340
|
|
|
|
|
|
|
{ |
3341
|
72
|
|
|
72
|
|
117
|
my $self = shift; |
3342
|
72
|
|
|
|
|
270
|
return '$' . $self->{'class_var'}; |
3343
|
|
|
|
|
|
|
} |
3344
|
|
|
|
|
|
|
|
3345
|
|
|
|
|
|
|
sub instance_var |
3346
|
|
|
|
|
|
|
{ |
3347
|
940
|
|
|
940
|
|
1303
|
my $self = shift; |
3348
|
940
|
|
|
|
|
2770
|
return '$' . $self->{'instance_var'}; |
3349
|
|
|
|
|
|
|
} |
3350
|
|
|
|
|
|
|
|
3351
|
|
|
|
|
|
|
sub needs_constructor |
3352
|
|
|
|
|
|
|
{ |
3353
|
61
|
|
|
61
|
|
117
|
my $self = shift; |
3354
|
|
|
|
|
|
|
return ( |
3355
|
|
|
|
|
|
|
defined $self->members |
3356
|
|
|
|
|
|
|
|| ( $self->virtual && $self->check_params ) |
3357
|
|
|
|
|
|
|
|| !$self->parents |
3358
|
|
|
|
|
|
|
|| do |
3359
|
61
|
|
66
|
|
|
161
|
{ |
3360
|
|
|
|
|
|
|
my $c = $self->constructor; |
3361
|
|
|
|
|
|
|
( defined $c->post |
3362
|
|
|
|
|
|
|
|| defined $c->assert |
3363
|
|
|
|
|
|
|
|| $c->style->isa('Class::Generate::Own') ); |
3364
|
|
|
|
|
|
|
} |
3365
|
|
|
|
|
|
|
); |
3366
|
|
|
|
|
|
|
} |
3367
|
|
|
|
|
|
|
|
3368
|
|
|
|
|
|
|
package Class::Generate::Array_Class; # A subclass of Class defining |
3369
|
|
|
|
|
|
|
$Class::Generate::Array_Class::VERSION = '1.18'; |
3370
|
14
|
|
|
14
|
|
4198
|
use strict; # array-based classes. |
|
14
|
|
|
|
|
2098
|
|
|
14
|
|
|
|
|
440
|
|
3371
|
14
|
|
|
14
|
|
1976
|
use vars qw(@ISA); |
|
14
|
|
|
|
|
1973
|
|
|
14
|
|
|
|
|
13478
|
|
3372
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Class); |
3373
|
|
|
|
|
|
|
|
3374
|
|
|
|
|
|
|
sub new |
3375
|
|
|
|
|
|
|
{ |
3376
|
20
|
|
|
20
|
|
43
|
my $class = shift; |
3377
|
20
|
|
|
|
|
39
|
my $name = shift; |
3378
|
20
|
|
|
|
|
102
|
my %params = @_; |
3379
|
20
|
|
|
|
|
126
|
my %super_params = %params; |
3380
|
20
|
|
|
|
|
74
|
delete @super_params{qw(base_index member_index)}; |
3381
|
20
|
|
|
|
|
151
|
my $self = $class->SUPER::new( $name, %super_params ); |
3382
|
|
|
|
|
|
|
$self->{'base_index'} = |
3383
|
20
|
100
|
|
|
|
107
|
defined $params{'base_index'} ? $params{'base_index'} : 1; |
3384
|
20
|
|
|
|
|
65
|
$self->{'next_index'} = $self->base_index - 1; |
3385
|
20
|
|
|
|
|
114
|
return $self; |
3386
|
|
|
|
|
|
|
} |
3387
|
|
|
|
|
|
|
|
3388
|
|
|
|
|
|
|
sub base_index |
3389
|
|
|
|
|
|
|
{ |
3390
|
20
|
|
|
20
|
|
36
|
my $self = shift; |
3391
|
20
|
|
|
|
|
57
|
return $self->{'base_index'}; |
3392
|
|
|
|
|
|
|
} |
3393
|
|
|
|
|
|
|
|
3394
|
|
|
|
|
|
|
sub base |
3395
|
|
|
|
|
|
|
{ |
3396
|
17
|
|
|
17
|
|
35
|
my $self = shift; |
3397
|
17
|
50
|
|
|
|
52
|
return '[]' if !$self->can_assign_all_params; |
3398
|
|
|
|
|
|
|
my @sorted_members = |
3399
|
0
|
|
|
|
|
0
|
sort { $$self{member_index}{$a} <=> $$self{member_index}{$b} } |
|
0
|
|
|
|
|
0
|
|
3400
|
|
|
|
|
|
|
$self->members_keys; |
3401
|
0
|
|
|
|
|
0
|
my %param_indices = map( ( $_, $self->constructor->style->order($_) ), |
3402
|
|
|
|
|
|
|
$self->members_keys ); |
3403
|
0
|
|
|
|
|
0
|
for ( my $i = 0 ; $i <= $#sorted_members ; $i++ ) |
3404
|
|
|
|
|
|
|
{ |
3405
|
0
|
0
|
|
|
|
0
|
next if $param_indices{ $sorted_members[$i] } == $i; |
3406
|
|
|
|
|
|
|
return '[ undef, ' |
3407
|
|
|
|
|
|
|
. join( ', ', |
3408
|
0
|
|
|
|
|
0
|
map { '$_[' . $param_indices{$_} . ']' } @sorted_members ) |
|
0
|
|
|
|
|
0
|
|
3409
|
|
|
|
|
|
|
. ' ]'; |
3410
|
|
|
|
|
|
|
} |
3411
|
0
|
|
|
|
|
0
|
return '[ undef, @_ ]'; |
3412
|
|
|
|
|
|
|
} |
3413
|
|
|
|
|
|
|
|
3414
|
|
|
|
|
|
|
sub base_type |
3415
|
|
|
|
|
|
|
{ |
3416
|
0
|
|
|
0
|
|
0
|
return 'ARRAY'; |
3417
|
|
|
|
|
|
|
} |
3418
|
|
|
|
|
|
|
|
3419
|
|
|
|
|
|
|
sub members |
3420
|
|
|
|
|
|
|
{ |
3421
|
158
|
|
|
158
|
|
248
|
my $self = shift; |
3422
|
158
|
100
|
|
|
|
473
|
return $self->SUPER::members(@_) if $#_ != 1; |
3423
|
31
|
|
|
|
|
112
|
$self->SUPER::members(@_); |
3424
|
31
|
|
|
|
|
45
|
my $overridden_class; |
3425
|
31
|
50
|
|
|
|
84
|
if ( |
3426
|
|
|
|
|
|
|
defined( |
3427
|
|
|
|
|
|
|
$overridden_class = |
3428
|
|
|
|
|
|
|
Class::Generate::Support::class_containing_method( |
3429
|
|
|
|
|
|
|
$_[0], $self |
3430
|
|
|
|
|
|
|
) |
3431
|
|
|
|
|
|
|
) |
3432
|
|
|
|
|
|
|
) |
3433
|
|
|
|
|
|
|
{ |
3434
|
|
|
|
|
|
|
$self->{'member_index'}{ $_[0] } = |
3435
|
0
|
|
|
|
|
0
|
$overridden_class->{'member_index'}->{ $_[0] }; |
3436
|
|
|
|
|
|
|
} |
3437
|
|
|
|
|
|
|
else |
3438
|
|
|
|
|
|
|
{ |
3439
|
31
|
|
|
|
|
85
|
$self->{'member_index'}{ $_[0] } = ++$self->{'next_index'}; |
3440
|
|
|
|
|
|
|
} |
3441
|
|
|
|
|
|
|
} |
3442
|
|
|
|
|
|
|
|
3443
|
|
|
|
|
|
|
sub index |
3444
|
|
|
|
|
|
|
{ |
3445
|
122
|
|
|
122
|
|
170
|
my $self = shift; |
3446
|
122
|
|
|
|
|
357
|
return '[' . $self->{'member_index'}{ $_[0] } . ']'; |
3447
|
|
|
|
|
|
|
} |
3448
|
|
|
|
|
|
|
|
3449
|
|
|
|
|
|
|
sub last |
3450
|
|
|
|
|
|
|
{ |
3451
|
47
|
|
|
47
|
|
75
|
my $self = shift; |
3452
|
47
|
|
|
|
|
161
|
return $self->{'next_index'}; |
3453
|
|
|
|
|
|
|
} |
3454
|
|
|
|
|
|
|
|
3455
|
|
|
|
|
|
|
sub existence_test |
3456
|
|
|
|
|
|
|
{ |
3457
|
47
|
|
|
47
|
|
91
|
my $self = shift; |
3458
|
47
|
|
|
|
|
116
|
return 'defined'; |
3459
|
|
|
|
|
|
|
} |
3460
|
|
|
|
|
|
|
|
3461
|
|
|
|
|
|
|
sub size_establishment |
3462
|
|
|
|
|
|
|
{ |
3463
|
26
|
|
|
26
|
|
58
|
my $self = shift; |
3464
|
26
|
|
|
|
|
48
|
my $instance_var = $_[0]; |
3465
|
26
|
|
|
|
|
81
|
return ' $#' . $instance_var . ' = ' . $self->last . ";\n"; |
3466
|
|
|
|
|
|
|
} |
3467
|
|
|
|
|
|
|
|
3468
|
|
|
|
|
|
|
sub can_assign_all_params |
3469
|
|
|
|
|
|
|
{ |
3470
|
51
|
|
|
51
|
|
76
|
my $self = shift; |
3471
|
|
|
|
|
|
|
return |
3472
|
51
|
|
0
|
|
|
96
|
!$self->check_params |
3473
|
|
|
|
|
|
|
&& $self->all_members_required |
3474
|
|
|
|
|
|
|
&& $self->constructor->style->isa('Class::Generate::Positional') |
3475
|
|
|
|
|
|
|
&& !defined $self->parents; |
3476
|
|
|
|
|
|
|
} |
3477
|
|
|
|
|
|
|
|
3478
|
|
|
|
|
|
|
sub undef_form |
3479
|
|
|
|
|
|
|
{ |
3480
|
15
|
|
|
15
|
|
63
|
return 'undef'; |
3481
|
|
|
|
|
|
|
} |
3482
|
|
|
|
|
|
|
|
3483
|
|
|
|
|
|
|
sub wholesale_copy |
3484
|
|
|
|
|
|
|
{ |
3485
|
8
|
|
|
8
|
|
26
|
return '[ @$self ]'; |
3486
|
|
|
|
|
|
|
} |
3487
|
|
|
|
|
|
|
|
3488
|
|
|
|
|
|
|
sub empty_form |
3489
|
|
|
|
|
|
|
{ |
3490
|
8
|
|
|
8
|
|
34
|
return '[]'; |
3491
|
|
|
|
|
|
|
} |
3492
|
|
|
|
|
|
|
|
3493
|
|
|
|
|
|
|
sub protected_members_info_index |
3494
|
|
|
|
|
|
|
{ |
3495
|
1
|
|
|
1
|
|
2
|
return q|[0]|; |
3496
|
|
|
|
|
|
|
} |
3497
|
|
|
|
|
|
|
|
3498
|
|
|
|
|
|
|
package Class::Generate::Hash_Class; # A subclass of Class defining |
3499
|
|
|
|
|
|
|
$Class::Generate::Hash_Class::VERSION = '1.18'; |
3500
|
14
|
|
|
14
|
|
2073
|
use vars qw(@ISA); # hash-based classes. |
|
14
|
|
|
|
|
2121
|
|
|
14
|
|
|
|
|
7346
|
|
3501
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Class); |
3502
|
|
|
|
|
|
|
|
3503
|
|
|
|
|
|
|
sub index |
3504
|
|
|
|
|
|
|
{ |
3505
|
438
|
|
|
438
|
|
620
|
my $self = shift; |
3506
|
|
|
|
|
|
|
return |
3507
|
438
|
100
|
|
|
|
837
|
"{'" |
3508
|
|
|
|
|
|
|
. ( $self->private( $_[0] ) ? '*' . $self->name . '_' . $_[0] : $_[0] ) |
3509
|
|
|
|
|
|
|
. "'}"; |
3510
|
|
|
|
|
|
|
} |
3511
|
|
|
|
|
|
|
|
3512
|
|
|
|
|
|
|
sub base |
3513
|
|
|
|
|
|
|
{ |
3514
|
29
|
|
|
29
|
|
57
|
my $self = shift; |
3515
|
29
|
50
|
|
|
|
72
|
return '{}' if !$self->can_assign_all_params; |
3516
|
0
|
|
|
|
|
0
|
my $style = $self->constructor->style; |
3517
|
0
|
0
|
|
|
|
0
|
return '{ @_ }' if $style->isa('Class::Generate::Key_Value'); |
3518
|
0
|
|
|
|
|
0
|
my %order = $style->order; |
3519
|
0
|
|
|
|
|
0
|
my $form = '{ ' . join( ', ', map( "$_ => \$_[$order{$_}]", keys %order ) ); |
3520
|
0
|
0
|
|
|
|
0
|
if ( $style->isa('Class::Generate::Mix') ) |
3521
|
|
|
|
|
|
|
{ |
3522
|
0
|
|
|
|
|
0
|
$form .= ', @_[' . $style->pcount . '..$#_]'; |
3523
|
|
|
|
|
|
|
} |
3524
|
0
|
|
|
|
|
0
|
return $form . ' }'; |
3525
|
|
|
|
|
|
|
} |
3526
|
|
|
|
|
|
|
|
3527
|
|
|
|
|
|
|
sub base_type |
3528
|
|
|
|
|
|
|
{ |
3529
|
0
|
|
|
0
|
|
0
|
return 'HASH'; |
3530
|
|
|
|
|
|
|
} |
3531
|
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
|
sub existence_test |
3533
|
|
|
|
|
|
|
{ |
3534
|
144
|
|
|
144
|
|
313
|
return 'exists'; |
3535
|
|
|
|
|
|
|
} |
3536
|
|
|
|
|
|
|
|
3537
|
|
|
|
|
|
|
sub can_assign_all_params |
3538
|
|
|
|
|
|
|
{ |
3539
|
109
|
|
|
109
|
|
158
|
my $self = shift; |
3540
|
|
|
|
|
|
|
return |
3541
|
109
|
|
0
|
|
|
213
|
!$self->check_params |
3542
|
|
|
|
|
|
|
&& $self->all_members_required |
3543
|
|
|
|
|
|
|
&& !$self->constructor->style->isa('Class::Generate::Own') |
3544
|
|
|
|
|
|
|
&& !defined $self->parents; |
3545
|
|
|
|
|
|
|
} |
3546
|
|
|
|
|
|
|
|
3547
|
|
|
|
|
|
|
sub undef_form |
3548
|
|
|
|
|
|
|
{ |
3549
|
73
|
|
|
73
|
|
247
|
return 'delete'; |
3550
|
|
|
|
|
|
|
} |
3551
|
|
|
|
|
|
|
|
3552
|
|
|
|
|
|
|
sub wholesale_copy |
3553
|
|
|
|
|
|
|
{ |
3554
|
12
|
|
|
12
|
|
40
|
return '{ %$self }'; |
3555
|
|
|
|
|
|
|
} |
3556
|
|
|
|
|
|
|
|
3557
|
|
|
|
|
|
|
sub empty_form |
3558
|
|
|
|
|
|
|
{ |
3559
|
17
|
|
|
17
|
|
58
|
return '{}'; |
3560
|
|
|
|
|
|
|
} |
3561
|
|
|
|
|
|
|
|
3562
|
|
|
|
|
|
|
sub protected_members_info_index |
3563
|
|
|
|
|
|
|
{ |
3564
|
9
|
|
|
9
|
|
38
|
return q|{'*protected*'}|; |
3565
|
|
|
|
|
|
|
} |
3566
|
|
|
|
|
|
|
|
3567
|
|
|
|
|
|
|
package Class::Generate::Param_Style; # A virtual class encompassing |
3568
|
|
|
|
|
|
|
$Class::Generate::Param_Style::VERSION = '1.18'; |
3569
|
14
|
|
|
14
|
|
105
|
use strict; # parameter-passing styles for |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
4020
|
|
3570
|
|
|
|
|
|
|
|
3571
|
|
|
|
|
|
|
sub new |
3572
|
|
|
|
|
|
|
{ |
3573
|
71
|
|
|
71
|
|
120
|
my $class = shift; |
3574
|
71
|
|
|
|
|
198
|
return bless {}, $class; |
3575
|
|
|
|
|
|
|
} |
3576
|
|
|
|
|
|
|
|
3577
|
|
|
|
|
|
|
sub keyed_param_names |
3578
|
|
|
|
|
|
|
{ |
3579
|
0
|
|
|
0
|
|
0
|
return (); |
3580
|
|
|
|
|
|
|
} |
3581
|
|
|
|
|
|
|
|
3582
|
|
|
|
|
|
|
sub delete_self_members_form |
3583
|
|
|
|
|
|
|
{ |
3584
|
1
|
|
|
1
|
|
2
|
shift; |
3585
|
1
|
|
|
|
|
4
|
my @self_members = @_; |
3586
|
1
|
50
|
|
|
|
4
|
if ( $#self_members == 0 ) |
|
|
0
|
|
|
|
|
|
3587
|
|
|
|
|
|
|
{ |
3588
|
1
|
|
|
|
|
9
|
return q|delete $super_params{'| . $self_members[0] . q|'};|; |
3589
|
|
|
|
|
|
|
} |
3590
|
|
|
|
|
|
|
elsif ( $#self_members > 0 ) |
3591
|
|
|
|
|
|
|
{ |
3592
|
|
|
|
|
|
|
return |
3593
|
0
|
|
|
|
|
0
|
q|delete @super_params{qw(| . join( ' ', @self_members ) . q|)};|; |
3594
|
|
|
|
|
|
|
} |
3595
|
|
|
|
|
|
|
} |
3596
|
|
|
|
|
|
|
|
3597
|
|
|
|
|
|
|
sub odd_params_check_form |
3598
|
|
|
|
|
|
|
{ |
3599
|
42
|
|
|
42
|
|
87
|
my $self = shift; |
3600
|
42
|
|
|
|
|
104
|
my ( $class, $constructor ) = @_; |
3601
|
|
|
|
|
|
|
return |
3602
|
42
|
|
|
|
|
178
|
q| croak '| |
3603
|
|
|
|
|
|
|
. $constructor->name_form($class) |
3604
|
|
|
|
|
|
|
. q|Odd number of parameters' if | |
3605
|
|
|
|
|
|
|
. $self->odd_params_test($class) . ";\n"; |
3606
|
|
|
|
|
|
|
} |
3607
|
|
|
|
|
|
|
|
3608
|
|
|
|
|
|
|
sub my_decl_form |
3609
|
|
|
|
|
|
|
{ |
3610
|
11
|
|
|
11
|
|
23
|
my $self = shift; |
3611
|
11
|
|
|
|
|
25
|
my $class = $_[0]; |
3612
|
|
|
|
|
|
|
return |
3613
|
11
|
|
|
|
|
82
|
' my ' |
3614
|
|
|
|
|
|
|
. $class->instance_var . ' = ' |
3615
|
|
|
|
|
|
|
. $class->class_var |
3616
|
|
|
|
|
|
|
. '->SUPER::new'; |
3617
|
|
|
|
|
|
|
} |
3618
|
|
|
|
|
|
|
|
3619
|
|
|
|
|
|
|
package Class::Generate::Key_Value; # The key/value parameter- |
3620
|
|
|
|
|
|
|
$Class::Generate::Key_Value::VERSION = '1.18'; |
3621
|
15
|
|
|
14
|
|
111
|
use strict; # passing style. It adds |
|
15
|
|
|
|
|
30
|
|
|
15
|
|
|
|
|
2113
|
|
3622
|
14
|
|
|
14
|
|
84
|
use vars qw(@ISA); # the name of the variable |
|
14
|
|
|
|
|
25
|
|
|
14
|
|
|
|
|
7814
|
|
3623
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); # that holds the parameters. |
3624
|
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
|
sub new |
3626
|
|
|
|
|
|
|
{ |
3627
|
46
|
|
|
46
|
|
87
|
my $class = shift; |
3628
|
46
|
|
|
|
|
170
|
my $self = $class->SUPER::new; |
3629
|
46
|
|
|
|
|
137
|
$self->{'holder'} = $_[0]; |
3630
|
46
|
|
|
|
|
187
|
$self->{'keyed_param_names'} = [ @_[ 1 .. $#_ ] ]; |
3631
|
46
|
|
|
|
|
194
|
return $self; |
3632
|
|
|
|
|
|
|
} |
3633
|
|
|
|
|
|
|
|
3634
|
|
|
|
|
|
|
sub holder |
3635
|
|
|
|
|
|
|
{ |
3636
|
176
|
|
|
176
|
|
238
|
my $self = shift; |
3637
|
176
|
|
|
|
|
583
|
return $self->{'holder'}; |
3638
|
|
|
|
|
|
|
} |
3639
|
|
|
|
|
|
|
|
3640
|
|
|
|
|
|
|
sub ref |
3641
|
|
|
|
|
|
|
{ |
3642
|
176
|
|
|
176
|
|
264
|
my $self = shift; |
3643
|
176
|
|
|
|
|
383
|
return '$' . $self->holder . "{'" . $_[0] . "'}"; |
3644
|
|
|
|
|
|
|
} |
3645
|
|
|
|
|
|
|
|
3646
|
|
|
|
|
|
|
sub keyed_param_names |
3647
|
|
|
|
|
|
|
{ |
3648
|
118
|
|
|
118
|
|
193
|
my $self = shift; |
3649
|
118
|
|
|
|
|
151
|
return @{ $self->{'keyed_param_names'} }; |
|
118
|
|
|
|
|
345
|
|
3650
|
|
|
|
|
|
|
} |
3651
|
|
|
|
|
|
|
|
3652
|
|
|
|
|
|
|
sub existence_test |
3653
|
|
|
|
|
|
|
{ |
3654
|
176
|
|
|
176
|
|
395
|
return 'exists'; |
3655
|
|
|
|
|
|
|
} |
3656
|
|
|
|
|
|
|
|
3657
|
|
|
|
|
|
|
sub init_form |
3658
|
|
|
|
|
|
|
{ |
3659
|
38
|
|
|
38
|
|
85
|
my $self = shift; |
3660
|
38
|
|
|
|
|
91
|
my ( $class, $constructor ) = @_; |
3661
|
38
|
|
|
|
|
65
|
my ( $form, $cn ); |
3662
|
38
|
|
|
|
|
70
|
$form = ''; |
3663
|
38
|
50
|
|
|
|
85
|
$form .= $self->odd_params_check_form( $class, $constructor ) |
3664
|
|
|
|
|
|
|
if $class->check_params; |
3665
|
38
|
|
|
|
|
92
|
$form .= " my \%params = \@_;\n"; |
3666
|
38
|
|
|
|
|
101
|
return $form; |
3667
|
|
|
|
|
|
|
} |
3668
|
|
|
|
|
|
|
|
3669
|
|
|
|
|
|
|
sub odd_params_test |
3670
|
|
|
|
|
|
|
{ |
3671
|
38
|
|
|
38
|
|
142
|
return '$#_%2 == 0'; |
3672
|
|
|
|
|
|
|
} |
3673
|
|
|
|
|
|
|
|
3674
|
|
|
|
|
|
|
sub self_from_super_form |
3675
|
|
|
|
|
|
|
{ |
3676
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
3677
|
1
|
|
|
|
|
2
|
my $class = $_[0]; |
3678
|
|
|
|
|
|
|
return |
3679
|
1
|
|
|
|
|
4
|
' my %super_params = %params;' . "\n" . ' ' |
3680
|
|
|
|
|
|
|
. $self->delete_self_members_form( $class->public_member_names ) . "\n" |
3681
|
|
|
|
|
|
|
. $self->my_decl_form($class) |
3682
|
|
|
|
|
|
|
. "(\%super_params);\n"; |
3683
|
|
|
|
|
|
|
} |
3684
|
|
|
|
|
|
|
|
3685
|
|
|
|
|
|
|
sub params_check_form |
3686
|
|
|
|
|
|
|
{ |
3687
|
39
|
|
|
39
|
|
64
|
my $self = shift; |
3688
|
39
|
|
|
|
|
84
|
my ( $class, $constructor ) = @_; |
3689
|
39
|
|
|
|
|
77
|
my ( $cn, @valid_names, $form ); |
3690
|
39
|
|
|
|
|
122
|
@valid_names = $self->keyed_param_names; |
3691
|
39
|
|
|
|
|
113
|
$cn = $constructor->name_form($class); |
3692
|
39
|
100
|
|
|
|
126
|
if ( !@valid_names ) |
3693
|
|
|
|
|
|
|
{ |
3694
|
5
|
|
|
|
|
19
|
$form = |
3695
|
|
|
|
|
|
|
" croak '$cn', join(', ', keys %params), ': Not a member' if keys \%params;\n"; |
3696
|
|
|
|
|
|
|
} |
3697
|
|
|
|
|
|
|
else |
3698
|
|
|
|
|
|
|
{ |
3699
|
34
|
|
|
|
|
77
|
$form = " {\n"; |
3700
|
34
|
100
|
|
|
|
83
|
if ( $#valid_names == 0 ) |
3701
|
|
|
|
|
|
|
{ |
3702
|
8
|
|
|
|
|
24
|
$form .= |
3703
|
|
|
|
|
|
|
"\tmy \@unknown_params = grep \$_ ne '$valid_names[0]', keys \%params;\n"; |
3704
|
|
|
|
|
|
|
} |
3705
|
|
|
|
|
|
|
else |
3706
|
|
|
|
|
|
|
{ |
3707
|
26
|
|
|
|
|
195
|
$form .= |
3708
|
|
|
|
|
|
|
"\tmy %valid_param = (" |
3709
|
|
|
|
|
|
|
. join( ', ', map( "'$_' => 1", @valid_names ) ) . ");\n" |
3710
|
|
|
|
|
|
|
. "\tmy \@unknown_params = grep ! defined \$valid_param{\$_}, keys \%params;\n"; |
3711
|
|
|
|
|
|
|
} |
3712
|
34
|
|
|
|
|
138
|
$form .= |
3713
|
|
|
|
|
|
|
"\tcroak '$cn', join(', ', \@unknown_params), ': Not a member' if \@unknown_params;\n" |
3714
|
|
|
|
|
|
|
. " }\n"; |
3715
|
|
|
|
|
|
|
} |
3716
|
39
|
|
|
|
|
134
|
return $form; |
3717
|
|
|
|
|
|
|
} |
3718
|
|
|
|
|
|
|
|
3719
|
|
|
|
|
|
|
package Class::Generate::Positional; # The positional parameter- |
3720
|
|
|
|
|
|
|
$Class::Generate::Positional::VERSION = '1.18'; |
3721
|
14
|
|
|
14
|
|
113
|
use strict; # passing style. It adds |
|
14
|
|
|
|
|
44
|
|
|
14
|
|
|
|
|
463
|
|
3722
|
13
|
|
|
15
|
|
82
|
use vars qw(@ISA); # an ordering of parameters. |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
6420
|
|
3723
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
3724
|
|
|
|
|
|
|
|
3725
|
|
|
|
|
|
|
sub new |
3726
|
|
|
|
|
|
|
{ |
3727
|
15
|
|
|
15
|
|
49
|
my $class = shift; |
3728
|
15
|
|
|
|
|
74
|
my $self = $class->SUPER::new; |
3729
|
15
|
|
|
|
|
57
|
for ( my $i = 0 ; $i <= $#_ ; $i++ ) |
3730
|
|
|
|
|
|
|
{ |
3731
|
17
|
|
|
|
|
88
|
$self->{'order'}->{ $_[$i] } = $i; |
3732
|
|
|
|
|
|
|
} |
3733
|
15
|
|
|
|
|
65
|
return $self; |
3734
|
|
|
|
|
|
|
} |
3735
|
|
|
|
|
|
|
|
3736
|
|
|
|
|
|
|
sub order |
3737
|
|
|
|
|
|
|
{ |
3738
|
29
|
|
|
29
|
|
48
|
my $self = shift; |
3739
|
29
|
100
|
|
|
|
106
|
return exists $self->{'order'} ? %{ $self->{'order'} } : () if $#_ == -1; |
|
12
|
100
|
|
|
|
58
|
|
3740
|
14
|
50
|
|
|
|
120
|
return exists $self->{'order'} ? $self->{'order'}->{ $_[0] } : undef |
|
|
50
|
|
|
|
|
|
3741
|
|
|
|
|
|
|
if $#_ == 0; |
3742
|
0
|
|
|
|
|
0
|
$self->{'order'}->{ $_[0] } = $_[1]; |
3743
|
|
|
|
|
|
|
} |
3744
|
|
|
|
|
|
|
|
3745
|
|
|
|
|
|
|
sub ref |
3746
|
|
|
|
|
|
|
{ |
3747
|
28
|
|
|
28
|
|
44
|
my $self = shift; |
3748
|
28
|
|
|
|
|
87
|
return '$_[' . $self->{'order'}->{ $_[0] } . ']'; |
3749
|
|
|
|
|
|
|
} |
3750
|
|
|
|
|
|
|
|
3751
|
|
|
|
|
|
|
sub existence_test |
3752
|
|
|
|
|
|
|
{ |
3753
|
28
|
|
|
28
|
|
68
|
return 'defined'; |
3754
|
|
|
|
|
|
|
} |
3755
|
|
|
|
|
|
|
|
3756
|
|
|
|
|
|
|
sub self_from_super_form |
3757
|
|
|
|
|
|
|
{ |
3758
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
3759
|
4
|
|
|
|
|
9
|
my $class = $_[0]; |
3760
|
4
|
|
100
|
|
|
11
|
my $lb = scalar( $class->public_member_names ) || 0; |
3761
|
|
|
|
|
|
|
return |
3762
|
4
|
|
|
|
|
53
|
' my @super_params = @_[' |
3763
|
|
|
|
|
|
|
. $lb |
3764
|
|
|
|
|
|
|
. '..$#_];' . "\n" |
3765
|
|
|
|
|
|
|
. $self->my_decl_form($class) |
3766
|
|
|
|
|
|
|
. "(\@super_params);\n"; |
3767
|
|
|
|
|
|
|
} |
3768
|
|
|
|
|
|
|
|
3769
|
|
|
|
|
|
|
sub params_check_form |
3770
|
|
|
|
|
|
|
{ |
3771
|
6
|
|
|
6
|
|
14
|
my $self = shift; |
3772
|
6
|
|
|
|
|
15
|
my ( $class, $constructor ) = @_; |
3773
|
6
|
|
|
|
|
64
|
my $cn = $constructor->name_form($class); |
3774
|
6
|
|
50
|
|
|
20
|
my $max_params = scalar( $class->public_member_names ) || 0; |
3775
|
|
|
|
|
|
|
return |
3776
|
6
|
|
|
|
|
59
|
qq| croak '$cn| |
3777
|
|
|
|
|
|
|
. qq|Only $max_params parameter(s) allowed (', \$#_+1, ' given)'| |
3778
|
|
|
|
|
|
|
. " unless \$#_ < $max_params;\n"; |
3779
|
|
|
|
|
|
|
} |
3780
|
|
|
|
|
|
|
|
3781
|
|
|
|
|
|
|
package Class::Generate::Mix; # The mix parameter-passing |
3782
|
|
|
|
|
|
|
$Class::Generate::Mix::VERSION = '1.18'; |
3783
|
13
|
|
|
14
|
|
94
|
use strict; # style. It combines key/value |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
421
|
|
3784
|
13
|
|
|
14
|
|
73
|
use vars qw(@ISA); # and positional. |
|
13
|
|
|
|
|
23
|
|
|
13
|
|
|
|
|
12390
|
|
3785
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
3786
|
|
|
|
|
|
|
|
3787
|
|
|
|
|
|
|
sub new |
3788
|
|
|
|
|
|
|
{ |
3789
|
5
|
|
|
5
|
|
10
|
my $class = shift; |
3790
|
5
|
|
|
|
|
18
|
my $self = $class->SUPER::new; |
3791
|
5
|
|
|
|
|
8
|
$self->{'pp'} = Class::Generate::Positional->new( @{ $_[1] } ); |
|
5
|
|
|
|
|
15
|
|
3792
|
5
|
|
|
|
|
21
|
$self->{'kv'} = Class::Generate::Key_Value->new( $_[0], @_[ 2 .. $#_ ] ); |
3793
|
5
|
|
|
|
|
8
|
$self->{'pnames'} = { map( ( $_ => 1 ), @{ $_[1] } ) }; |
|
5
|
|
|
|
|
16
|
|
3794
|
5
|
|
|
|
|
25
|
return $self; |
3795
|
|
|
|
|
|
|
} |
3796
|
|
|
|
|
|
|
|
3797
|
|
|
|
|
|
|
sub keyed_param_names |
3798
|
|
|
|
|
|
|
{ |
3799
|
5
|
|
|
5
|
|
10
|
my $self = shift; |
3800
|
5
|
|
|
|
|
11
|
return $self->{'kv'}->keyed_param_names; |
3801
|
|
|
|
|
|
|
} |
3802
|
|
|
|
|
|
|
|
3803
|
|
|
|
|
|
|
sub order |
3804
|
|
|
|
|
|
|
{ |
3805
|
7
|
|
|
7
|
|
11
|
my $self = shift; |
3806
|
7
|
50
|
|
|
|
28
|
return $self->{'pp'}->order(@_) if $#_ <= 0; |
3807
|
0
|
|
|
|
|
0
|
$self->{'pp'}->order(@_); |
3808
|
0
|
|
|
|
|
0
|
$self->{'pnames'}{ $_[0] } = 1; |
3809
|
|
|
|
|
|
|
} |
3810
|
|
|
|
|
|
|
|
3811
|
|
|
|
|
|
|
sub ref |
3812
|
|
|
|
|
|
|
{ |
3813
|
20
|
|
|
20
|
|
30
|
my $self = shift; |
3814
|
|
|
|
|
|
|
return $self->{'pnames'}->{ $_[0] } |
3815
|
|
|
|
|
|
|
? $self->{'pp'}->ref( $_[0] ) |
3816
|
20
|
100
|
|
|
|
58
|
: $self->{'kv'}->ref( $_[0] ); |
3817
|
|
|
|
|
|
|
} |
3818
|
|
|
|
|
|
|
|
3819
|
|
|
|
|
|
|
sub existence_test |
3820
|
|
|
|
|
|
|
{ |
3821
|
20
|
|
|
20
|
|
27
|
my $self = shift; |
3822
|
|
|
|
|
|
|
return $self->{'pnames'}->{ $_[0] } |
3823
|
|
|
|
|
|
|
? $self->{'pp'}->existence_test |
3824
|
20
|
100
|
|
|
|
57
|
: $self->{'kv'}->existence_test; |
3825
|
|
|
|
|
|
|
} |
3826
|
|
|
|
|
|
|
|
3827
|
|
|
|
|
|
|
sub pcount |
3828
|
|
|
|
|
|
|
{ |
3829
|
22
|
|
|
22
|
|
28
|
my $self = shift; |
3830
|
22
|
50
|
|
|
|
41
|
return exists $self->{'pnames'} ? scalar( keys %{ $self->{'pnames'} } ) : 0; |
|
22
|
|
|
|
|
68
|
|
3831
|
|
|
|
|
|
|
} |
3832
|
|
|
|
|
|
|
|
3833
|
|
|
|
|
|
|
sub init_form |
3834
|
|
|
|
|
|
|
{ |
3835
|
4
|
|
|
4
|
|
96
|
my $self = shift; |
3836
|
4
|
|
|
|
|
23
|
my ( $class, $constructor ) = @_; |
3837
|
4
|
|
|
|
|
15
|
my ( $form, $m ) = ( '', $self->max_possible_params($class) ); |
3838
|
4
|
50
|
|
|
|
13
|
$form .= |
3839
|
|
|
|
|
|
|
$self->odd_params_check_form( $class, $constructor, $self->pcount, $m ) |
3840
|
|
|
|
|
|
|
if $class->check_params; |
3841
|
4
|
|
|
|
|
15
|
$form .= ' my %params = ' . $self->kv_params_form($m) . ";\n"; |
3842
|
4
|
|
|
|
|
10
|
return $form; |
3843
|
|
|
|
|
|
|
} |
3844
|
|
|
|
|
|
|
|
3845
|
|
|
|
|
|
|
sub odd_params_test |
3846
|
|
|
|
|
|
|
{ |
3847
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
3848
|
4
|
|
|
|
|
7
|
my $class = $_[0]; |
3849
|
4
|
|
|
|
|
6
|
my ( $p, $test ); |
3850
|
4
|
|
|
|
|
9
|
$p = $self->pcount; |
3851
|
4
|
|
|
|
|
10
|
$test = '$#_>=' . $p; |
3852
|
4
|
100
|
|
|
|
17
|
$test .= ' && $#_<=' . $self->max_possible_params($class) |
3853
|
|
|
|
|
|
|
if $class->parents; |
3854
|
4
|
100
|
|
|
|
17
|
$test .= ' && $#_%2 == ' . ( $p % 2 == 0 ? '0' : '1' ); |
3855
|
4
|
|
|
|
|
17
|
return $test; |
3856
|
|
|
|
|
|
|
} |
3857
|
|
|
|
|
|
|
|
3858
|
|
|
|
|
|
|
sub self_from_super_form |
3859
|
|
|
|
|
|
|
{ |
3860
|
2
|
|
|
2
|
|
5
|
my $self = shift; |
3861
|
2
|
|
|
|
|
4
|
my $class = $_[0]; |
3862
|
2
|
|
|
|
|
4
|
my @positional_members = keys %{ $self->{'pnames'} }; |
|
2
|
|
|
|
|
5
|
|
3863
|
2
|
|
|
|
|
9
|
my %self_members = map { ( $_ => 1 ) } $class->public_member_names; |
|
3
|
|
|
|
|
9
|
|
3864
|
2
|
|
|
|
|
7
|
delete @self_members{@positional_members}; |
3865
|
2
|
|
|
|
|
6
|
my $m = $self->max_possible_params($class); |
3866
|
|
|
|
|
|
|
return |
3867
|
2
|
|
|
|
|
11
|
$self->my_decl_form($class) . '(@_[' |
3868
|
|
|
|
|
|
|
. ( $m + 1 ) |
3869
|
|
|
|
|
|
|
. '..$#_]);' . "\n"; |
3870
|
|
|
|
|
|
|
} |
3871
|
|
|
|
|
|
|
|
3872
|
|
|
|
|
|
|
sub max_possible_params |
3873
|
|
|
|
|
|
|
{ |
3874
|
10
|
|
|
10
|
|
73
|
my $self = shift; |
3875
|
10
|
|
|
|
|
16
|
my $class = $_[0]; |
3876
|
10
|
|
|
|
|
22
|
my $p = $self->pcount; |
3877
|
10
|
|
|
|
|
21
|
return $p + 2 * ( scalar( $class->public_member_names ) - $p ) - 1; |
3878
|
|
|
|
|
|
|
} |
3879
|
|
|
|
|
|
|
|
3880
|
|
|
|
|
|
|
sub params_check_form |
3881
|
|
|
|
|
|
|
{ |
3882
|
2
|
|
|
2
|
|
12
|
my $self = shift; |
3883
|
2
|
|
|
|
|
6
|
my ( $class, $constructor ) = @_; |
3884
|
2
|
|
|
|
|
4
|
my ( $form, $cn ); |
3885
|
2
|
|
|
|
|
6
|
$cn = $constructor->name_form($class); |
3886
|
2
|
|
|
|
|
8
|
$form = $self->{'kv'}->params_check_form(@_); |
3887
|
2
|
|
|
|
|
5
|
my $max_params = $self->max_possible_params($class) + 1; |
3888
|
2
|
|
|
|
|
29
|
$form .= |
3889
|
|
|
|
|
|
|
qq| croak '$cn| |
3890
|
|
|
|
|
|
|
. qq|Only $max_params parameter(s) allowed (', \$#_+1, ' given)'| |
3891
|
|
|
|
|
|
|
. " unless \$#_ < $max_params;\n"; |
3892
|
2
|
|
|
|
|
6
|
return $form; |
3893
|
|
|
|
|
|
|
} |
3894
|
|
|
|
|
|
|
|
3895
|
|
|
|
|
|
|
sub kv_params_form |
3896
|
|
|
|
|
|
|
{ |
3897
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
3898
|
4
|
|
|
|
|
5
|
my $max_params = $_[0]; |
3899
|
|
|
|
|
|
|
return |
3900
|
4
|
|
|
|
|
10
|
'@_[' |
3901
|
|
|
|
|
|
|
. $self->pcount |
3902
|
|
|
|
|
|
|
. "..(\$#_ < $max_params ? \$#_ : $max_params)]"; |
3903
|
|
|
|
|
|
|
} |
3904
|
|
|
|
|
|
|
|
3905
|
|
|
|
|
|
|
package Class::Generate::Own; # The "own" parameter-passing |
3906
|
|
|
|
|
|
|
$Class::Generate::Own::VERSION = '1.18'; |
3907
|
13
|
|
|
13
|
|
109
|
use strict; # style. |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
382
|
|
3908
|
13
|
|
|
13
|
|
68
|
use vars qw(@ISA); |
|
13
|
|
|
|
|
34
|
|
|
13
|
|
|
|
|
7674
|
|
3909
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
3910
|
|
|
|
|
|
|
|
3911
|
|
|
|
|
|
|
sub new |
3912
|
|
|
|
|
|
|
{ |
3913
|
5
|
|
|
5
|
|
8
|
my $class = shift; |
3914
|
5
|
|
|
|
|
17
|
my $self = $class->SUPER::new; |
3915
|
5
|
50
|
|
|
|
21
|
$self->{'super_values'} = $_[0] if defined $_[0]; |
3916
|
5
|
|
|
|
|
18
|
return $self; |
3917
|
|
|
|
|
|
|
} |
3918
|
|
|
|
|
|
|
|
3919
|
|
|
|
|
|
|
sub super_values |
3920
|
|
|
|
|
|
|
{ |
3921
|
9
|
|
|
9
|
|
13
|
my $self = shift; |
3922
|
9
|
50
|
|
|
|
19
|
return defined $self->{'super_values'} ? @{ $self->{'super_values'} } : (); |
|
9
|
|
|
|
|
23
|
|
3923
|
|
|
|
|
|
|
} |
3924
|
|
|
|
|
|
|
|
3925
|
|
|
|
|
|
|
sub can_assign_all_params |
3926
|
|
|
|
|
|
|
{ |
3927
|
0
|
|
|
0
|
|
0
|
return 0; |
3928
|
|
|
|
|
|
|
} |
3929
|
|
|
|
|
|
|
|
3930
|
|
|
|
|
|
|
sub self_from_super_form |
3931
|
|
|
|
|
|
|
{ |
3932
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
3933
|
4
|
|
|
|
|
7
|
my $class = $_[0]; |
3934
|
4
|
|
|
|
|
6
|
my ( $form, @sv ); |
3935
|
4
|
|
|
|
|
13
|
$form = $self->my_decl_form($class); |
3936
|
4
|
100
|
|
|
|
11
|
if ( @sv = $self->super_values ) |
3937
|
|
|
|
|
|
|
{ |
3938
|
3
|
|
|
|
|
13
|
$form .= '(' . join( ',', @sv ) . ')'; |
3939
|
|
|
|
|
|
|
} |
3940
|
4
|
|
|
|
|
7
|
$form .= ";\n"; |
3941
|
4
|
|
|
|
|
10
|
return $form; |
3942
|
|
|
|
|
|
|
} |
3943
|
|
|
|
|
|
|
|
3944
|
|
|
|
|
|
|
1; |
3945
|
|
|
|
|
|
|
|
3946
|
|
|
|
|
|
|
=pod |
3947
|
|
|
|
|
|
|
|
3948
|
|
|
|
|
|
|
=encoding UTF-8 |
3949
|
|
|
|
|
|
|
|
3950
|
|
|
|
|
|
|
=head1 NAME |
3951
|
|
|
|
|
|
|
|
3952
|
|
|
|
|
|
|
Class::Generate - Generate Perl class hierarchies |
3953
|
|
|
|
|
|
|
|
3954
|
|
|
|
|
|
|
=head1 VERSION |
3955
|
|
|
|
|
|
|
|
3956
|
|
|
|
|
|
|
version 1.18 |
3957
|
|
|
|
|
|
|
|
3958
|
|
|
|
|
|
|
=head1 SYNOPSIS |
3959
|
|
|
|
|
|
|
|
3960
|
|
|
|
|
|
|
use Class::Generate qw(class subclass delete_class); |
3961
|
|
|
|
|
|
|
|
3962
|
|
|
|
|
|
|
# Declare class Class_Name, with the following types of members: |
3963
|
|
|
|
|
|
|
class |
3964
|
|
|
|
|
|
|
Class_Name => [ |
3965
|
|
|
|
|
|
|
s => '$', # scalar |
3966
|
|
|
|
|
|
|
a => '@', # array |
3967
|
|
|
|
|
|
|
h => '%', # hash |
3968
|
|
|
|
|
|
|
c => 'Class', # Class |
3969
|
|
|
|
|
|
|
c_a => '@Class', # array of Class |
3970
|
|
|
|
|
|
|
c_h => '%Class', # hash of Class |
3971
|
|
|
|
|
|
|
'&m' => 'body', # method |
3972
|
|
|
|
|
|
|
]; |
3973
|
|
|
|
|
|
|
|
3974
|
|
|
|
|
|
|
# Allocate an instance of class_name, with members initialized to the |
3975
|
|
|
|
|
|
|
# given values (pass arrays and hashes using references). |
3976
|
|
|
|
|
|
|
$obj = Class_Name->new ( s => scalar, |
3977
|
|
|
|
|
|
|
a => [ values ], |
3978
|
|
|
|
|
|
|
h => { key1 => v1, ... }, |
3979
|
|
|
|
|
|
|
c => Class->new, |
3980
|
|
|
|
|
|
|
c_a => [ Class->new, ... ], |
3981
|
|
|
|
|
|
|
c_h => [ key1 => Class->new, ... ] ); |
3982
|
|
|
|
|
|
|
|
3983
|
|
|
|
|
|
|
# Scalar type accessor: |
3984
|
|
|
|
|
|
|
$obj->s($value); # Assign $value to member s. |
3985
|
|
|
|
|
|
|
$member_value = $obj->s; # Access member's value. |
3986
|
|
|
|
|
|
|
|
3987
|
|
|
|
|
|
|
# (Class) Array type accessor: |
3988
|
|
|
|
|
|
|
$obj->a([value1, value2, ...]); # Assign whole array to member. |
3989
|
|
|
|
|
|
|
$obj->a(2, $value); # Assign $value to array member 2. |
3990
|
|
|
|
|
|
|
$obj->add_a($value); # Append $value to end of array. |
3991
|
|
|
|
|
|
|
@a = $obj->a; # Access whole array. |
3992
|
|
|
|
|
|
|
$ary_member_value = $obj->a(2); # Access array member 2. |
3993
|
|
|
|
|
|
|
$s = $obj->a_size; # Return size of array. |
3994
|
|
|
|
|
|
|
$value = $obj->last_a; # Return last element of array. |
3995
|
|
|
|
|
|
|
|
3996
|
|
|
|
|
|
|
# (Class) Hash type accessor: |
3997
|
|
|
|
|
|
|
$obj->h({ k_1=>v1, ..., k_n=>v_n }) # Assign whole hash to member. |
3998
|
|
|
|
|
|
|
$obj->h($key, $value); # Assign $value to hash member $key. |
3999
|
|
|
|
|
|
|
%hash = $obj->h; # Access whole hash. |
4000
|
|
|
|
|
|
|
$hash_member_value = $obj->h($key); # Access hash member value $key. |
4001
|
|
|
|
|
|
|
$obj->delete_h($key); # Delete slot occupied by $key. |
4002
|
|
|
|
|
|
|
@keys = $obj->h_keys; # Access keys of member h. |
4003
|
|
|
|
|
|
|
@values = $obj->h_values; # Access values of member h. |
4004
|
|
|
|
|
|
|
|
4005
|
|
|
|
|
|
|
$another = $obj->copy; # Copy an object. |
4006
|
|
|
|
|
|
|
if ( $obj->equals($another) ) { ... } # Test equality. |
4007
|
|
|
|
|
|
|
|
4008
|
|
|
|
|
|
|
subclass s => [ ], -parent => 'class_name'; |
4009
|
|
|
|
|
|
|
|
4010
|
|
|
|
|
|
|
=head1 DESCRIPTION |
4011
|
|
|
|
|
|
|
|
4012
|
|
|
|
|
|
|
The C package exports functions that take as arguments |
4013
|
|
|
|
|
|
|
a class specification and create from these specifications a Perl 5 class. |
4014
|
|
|
|
|
|
|
The specification language allows many object-oriented constructs: |
4015
|
|
|
|
|
|
|
typed members, inheritance, private members, required members, |
4016
|
|
|
|
|
|
|
default values, object methods, class methods, class variables, and more. |
4017
|
|
|
|
|
|
|
|
4018
|
|
|
|
|
|
|
CPAN contains similar packages. |
4019
|
|
|
|
|
|
|
Why another? |
4020
|
|
|
|
|
|
|
Because object-oriented programming, |
4021
|
|
|
|
|
|
|
especially in a dynamic language like Perl, |
4022
|
|
|
|
|
|
|
is a complicated endeavor. |
4023
|
|
|
|
|
|
|
I wanted a package that would work very hard to catch the errors you |
4024
|
|
|
|
|
|
|
(well, I anyway) commonly make. |
4025
|
|
|
|
|
|
|
I wanted a package that could help me |
4026
|
|
|
|
|
|
|
enforce the contract of object-oriented programming. |
4027
|
|
|
|
|
|
|
I also wanted it to get out of my way when I asked. |
4028
|
|
|
|
|
|
|
|
4029
|
|
|
|
|
|
|
=head1 THE CLASS FUNCTION |
4030
|
|
|
|
|
|
|
|
4031
|
|
|
|
|
|
|
You create classes by invoking the C function. |
4032
|
|
|
|
|
|
|
The C function has two forms: |
4033
|
|
|
|
|
|
|
|
4034
|
|
|
|
|
|
|
class Class_Name => [ specification ]; # Objects are array-based. |
4035
|
|
|
|
|
|
|
class Class_Name => { specification }; # Objects are hash-based. |
4036
|
|
|
|
|
|
|
|
4037
|
|
|
|
|
|
|
The result is a Perl 5 class, in a package C. |
4038
|
|
|
|
|
|
|
This package must not exist when C is invoked. |
4039
|
|
|
|
|
|
|
|
4040
|
|
|
|
|
|
|
An array-based object is faster and smaller. |
4041
|
|
|
|
|
|
|
A hash-based object is more flexible. |
4042
|
|
|
|
|
|
|
Subsequent sections explain where and why flexibility matters. |
4043
|
|
|
|
|
|
|
|
4044
|
|
|
|
|
|
|
The specification consists of zero or more name/value pairs. |
4045
|
|
|
|
|
|
|
Each pair declares one member of the class, |
4046
|
|
|
|
|
|
|
with the given name, and with attributes specified by the given value. |
4047
|
|
|
|
|
|
|
|
4048
|
|
|
|
|
|
|
=head1 MEMBER TYPES |
4049
|
|
|
|
|
|
|
|
4050
|
|
|
|
|
|
|
In the simplest name/value form, |
4051
|
|
|
|
|
|
|
the value you give is a string that defines the member's type. |
4052
|
|
|
|
|
|
|
A C<'$'> denotes a scalar member type. |
4053
|
|
|
|
|
|
|
A C<'@'> denotes an array type. |
4054
|
|
|
|
|
|
|
A C<'%'> denotes a hash type. |
4055
|
|
|
|
|
|
|
Thus: |
4056
|
|
|
|
|
|
|
|
4057
|
|
|
|
|
|
|
class Person => [ name => '$', age => '$' ]; |
4058
|
|
|
|
|
|
|
|
4059
|
|
|
|
|
|
|
creates a class named C with two scalar members, |
4060
|
|
|
|
|
|
|
C and C. |
4061
|
|
|
|
|
|
|
|
4062
|
|
|
|
|
|
|
If the type is followed by an identifier, |
4063
|
|
|
|
|
|
|
the identifier is assumed to be a class name, |
4064
|
|
|
|
|
|
|
and the member is restricted to a blessed reference of the class |
4065
|
|
|
|
|
|
|
(or one of its subclasses), |
4066
|
|
|
|
|
|
|
an array whose elements are blessed references of the class, |
4067
|
|
|
|
|
|
|
or a hash whose keys are strings |
4068
|
|
|
|
|
|
|
and whose values are blessed references of the class. |
4069
|
|
|
|
|
|
|
For scalars, the C<$> may be omitted; |
4070
|
|
|
|
|
|
|
i.e., C and C<$Class_Name> are equivalent. |
4071
|
|
|
|
|
|
|
The class need not be declared using the C package. |
4072
|
|
|
|
|
|
|
|
4073
|
|
|
|
|
|
|
=head1 CREATING INSTANCES |
4074
|
|
|
|
|
|
|
|
4075
|
|
|
|
|
|
|
Each class that you generate has a constructor named C. |
4076
|
|
|
|
|
|
|
Invoking the constructor creates an instance of the class. |
4077
|
|
|
|
|
|
|
You may provide C with parameters to set the values of members: |
4078
|
|
|
|
|
|
|
|
4079
|
|
|
|
|
|
|
class Person => [ name => '$', age => '$' ]; |
4080
|
|
|
|
|
|
|
$p = Person->new; # Neither name nor age is defined. |
4081
|
|
|
|
|
|
|
$q = Person->new( name => 'Jim' ); # Only name is defined. |
4082
|
|
|
|
|
|
|
$r = Person->new( age => 32 ); # Only age is defined. |
4083
|
|
|
|
|
|
|
|
4084
|
|
|
|
|
|
|
=head1 ACCESSOR METHODS |
4085
|
|
|
|
|
|
|
|
4086
|
|
|
|
|
|
|
A class has a standard set of accessor methods for each member you specify. |
4087
|
|
|
|
|
|
|
The accessor methods depend on a member's type. |
4088
|
|
|
|
|
|
|
|
4089
|
|
|
|
|
|
|
=head2 Scalar (name => '$', name => 'Class_Name', or name => '$Class_Name') |
4090
|
|
|
|
|
|
|
|
4091
|
|
|
|
|
|
|
The member is a scalar. |
4092
|
|
|
|
|
|
|
The member has a single method C. |
4093
|
|
|
|
|
|
|
If called with no arguments, it returns the member's current value. |
4094
|
|
|
|
|
|
|
If called with arguments, it sets the member to the first value: |
4095
|
|
|
|
|
|
|
|
4096
|
|
|
|
|
|
|
$p = Person->new; |
4097
|
|
|
|
|
|
|
$p->age(32); # Sets age member to 32. |
4098
|
|
|
|
|
|
|
print $p->age; # Prints 32. |
4099
|
|
|
|
|
|
|
|
4100
|
|
|
|
|
|
|
If the C form is used, the member must be a reference blessed |
4101
|
|
|
|
|
|
|
to the named class or to one of its subclasses. |
4102
|
|
|
|
|
|
|
The method will C (see L) if the argument is not |
4103
|
|
|
|
|
|
|
a blessed reference to an instance of C or one of its subclasses. |
4104
|
|
|
|
|
|
|
|
4105
|
|
|
|
|
|
|
class Person => [ |
4106
|
|
|
|
|
|
|
name => '$', |
4107
|
|
|
|
|
|
|
spouse => 'Person' # Works, even though Person |
4108
|
|
|
|
|
|
|
]; # isn't yet defined. |
4109
|
|
|
|
|
|
|
$p = Person->new(name => 'Simon Bar-Sinister'); |
4110
|
|
|
|
|
|
|
$q = Person->new(name => 'Polly Purebred'); |
4111
|
|
|
|
|
|
|
$r = Person->new(name => 'Underdog'); |
4112
|
|
|
|
|
|
|
$r->spouse($q); # Underdog marries Polly. |
4113
|
|
|
|
|
|
|
print $r->spouse->name; # Prints 'Polly Purebred'. |
4114
|
|
|
|
|
|
|
print "He's married" if defined $p->spouse; # Prints nothing. |
4115
|
|
|
|
|
|
|
$p->spouse('Natasha Fatale'); # Croaks. |
4116
|
|
|
|
|
|
|
|
4117
|
|
|
|
|
|
|
=head2 Array (name => '@' or name => '@Class') |
4118
|
|
|
|
|
|
|
|
4119
|
|
|
|
|
|
|
The member is an array. |
4120
|
|
|
|
|
|
|
If the C<@Class> form is used, all members of the array must be |
4121
|
|
|
|
|
|
|
a blessed reference to C or one of its subclasses. |
4122
|
|
|
|
|
|
|
An array member has four associated methods: |
4123
|
|
|
|
|
|
|
|
4124
|
|
|
|
|
|
|
=over 4 |
4125
|
|
|
|
|
|
|
|
4126
|
|
|
|
|
|
|
=item C |
4127
|
|
|
|
|
|
|
|
4128
|
|
|
|
|
|
|
With no argument, C returns the member's whole array. |
4129
|
|
|
|
|
|
|
|
4130
|
|
|
|
|
|
|
With one argument, C's behavior depends on |
4131
|
|
|
|
|
|
|
whether the argument is an array reference. |
4132
|
|
|
|
|
|
|
If it is not, then the argument must be an integer I, |
4133
|
|
|
|
|
|
|
and C returns element I of the member. |
4134
|
|
|
|
|
|
|
If no such element exists, C returns C. |
4135
|
|
|
|
|
|
|
If the argument is an array reference, |
4136
|
|
|
|
|
|
|
it is cast into an array and assigned to the member. |
4137
|
|
|
|
|
|
|
|
4138
|
|
|
|
|
|
|
With two arguments, the first argument must be an integer I. |
4139
|
|
|
|
|
|
|
The second argument is assigned to element I of the member. |
4140
|
|
|
|
|
|
|
|
4141
|
|
|
|
|
|
|
=item C |
4142
|
|
|
|
|
|
|
|
4143
|
|
|
|
|
|
|
This method appends its arguments to the member's array. |
4144
|
|
|
|
|
|
|
|
4145
|
|
|
|
|
|
|
=item C |
4146
|
|
|
|
|
|
|
|
4147
|
|
|
|
|
|
|
This method returns the index of the last element in the array. |
4148
|
|
|
|
|
|
|
|
4149
|
|
|
|
|
|
|
=item C |
4150
|
|
|
|
|
|
|
|
4151
|
|
|
|
|
|
|
This method returns the last element of C, |
4152
|
|
|
|
|
|
|
or C if C has no elements. |
4153
|
|
|
|
|
|
|
It's a shorthand for C<$o-Earray_mem($o-Earray_mem_size)>. |
4154
|
|
|
|
|
|
|
|
4155
|
|
|
|
|
|
|
=back |
4156
|
|
|
|
|
|
|
|
4157
|
|
|
|
|
|
|
For example: |
4158
|
|
|
|
|
|
|
|
4159
|
|
|
|
|
|
|
class Person => [ name => '$', kids => '@Person' ]; |
4160
|
|
|
|
|
|
|
$p = Person->new; |
4161
|
|
|
|
|
|
|
$p->add_kids(Person->new(name => 'Heckle'), |
4162
|
|
|
|
|
|
|
Person->new(name => 'Jeckle')); |
4163
|
|
|
|
|
|
|
print $p->kids_size; # Prints 1. |
4164
|
|
|
|
|
|
|
$p->kids([Person->new(name => 'Bugs Bunny'), |
4165
|
|
|
|
|
|
|
Person->new(name => 'Daffy Duck')]); |
4166
|
|
|
|
|
|
|
$p->add_kids(Person->new(name => 'Yosemite Sam'), |
4167
|
|
|
|
|
|
|
Person->new(name => 'Porky Pig')); |
4168
|
|
|
|
|
|
|
print $p->kids_size; # Prints 3. |
4169
|
|
|
|
|
|
|
$p->kids(2, Person->new(name => 'Elmer Fudd')); |
4170
|
|
|
|
|
|
|
print $p->kids(2)->name; # Prints 'Elmer Fudd'. |
4171
|
|
|
|
|
|
|
@kids = $p->kids; # Get all the kids. |
4172
|
|
|
|
|
|
|
print $p->kids($p->kids_size)->name; # Prints 'Porky Pig'. |
4173
|
|
|
|
|
|
|
print $p->last_kids->name; # So does this. |
4174
|
|
|
|
|
|
|
|
4175
|
|
|
|
|
|
|
=head2 Hash (name => '%' or name => '%Class') |
4176
|
|
|
|
|
|
|
|
4177
|
|
|
|
|
|
|
The member is a hash. |
4178
|
|
|
|
|
|
|
If the C<%Class> form is used, all values in the hash |
4179
|
|
|
|
|
|
|
must be a blessed reference to C or one of its subclasses. |
4180
|
|
|
|
|
|
|
A hash member has four associated methods: |
4181
|
|
|
|
|
|
|
|
4182
|
|
|
|
|
|
|
=over 4 |
4183
|
|
|
|
|
|
|
|
4184
|
|
|
|
|
|
|
=item C |
4185
|
|
|
|
|
|
|
|
4186
|
|
|
|
|
|
|
With no arguments, C returns the member's whole hash. |
4187
|
|
|
|
|
|
|
|
4188
|
|
|
|
|
|
|
With one argument that is a hash reference, |
4189
|
|
|
|
|
|
|
the member's value becomes the key/value pairs in that reference. |
4190
|
|
|
|
|
|
|
With one argument that is a string, |
4191
|
|
|
|
|
|
|
the element of the hash keyed by that string is returned. |
4192
|
|
|
|
|
|
|
If no such element exists, C returns C. |
4193
|
|
|
|
|
|
|
|
4194
|
|
|
|
|
|
|
With two arguments, the second argument is assigned to the hash, |
4195
|
|
|
|
|
|
|
keyed by the string representation of the first argument. |
4196
|
|
|
|
|
|
|
|
4197
|
|
|
|
|
|
|
=item C |
4198
|
|
|
|
|
|
|
|
4199
|
|
|
|
|
|
|
The C method returns all keys associated with the member. |
4200
|
|
|
|
|
|
|
|
4201
|
|
|
|
|
|
|
=item C |
4202
|
|
|
|
|
|
|
|
4203
|
|
|
|
|
|
|
The C method returns all values associated with the member. |
4204
|
|
|
|
|
|
|
|
4205
|
|
|
|
|
|
|
=item C |
4206
|
|
|
|
|
|
|
|
4207
|
|
|
|
|
|
|
The C method takes one or more arguments. |
4208
|
|
|
|
|
|
|
It deletes from C's hash all elements matching the arguments. |
4209
|
|
|
|
|
|
|
|
4210
|
|
|
|
|
|
|
=back |
4211
|
|
|
|
|
|
|
|
4212
|
|
|
|
|
|
|
For example: |
4213
|
|
|
|
|
|
|
|
4214
|
|
|
|
|
|
|
class Person => [ name => '$', kids => '%Kid_Info' ]; |
4215
|
|
|
|
|
|
|
class Kid_Info => [ |
4216
|
|
|
|
|
|
|
grade => '$', |
4217
|
|
|
|
|
|
|
skills => '@' |
4218
|
|
|
|
|
|
|
]; |
4219
|
|
|
|
|
|
|
$f = new Person( |
4220
|
|
|
|
|
|
|
name => 'Fred Flintstone', |
4221
|
|
|
|
|
|
|
kids => { Pebbles => new Kid_Info(grade => 1, |
4222
|
|
|
|
|
|
|
skills => ['Programs VCR']) } |
4223
|
|
|
|
|
|
|
); |
4224
|
|
|
|
|
|
|
print $f->kids('Pebbles')->grade; # Prints 1. |
4225
|
|
|
|
|
|
|
$b = new Kid_Info; |
4226
|
|
|
|
|
|
|
$b->grade('Kindergarten'); |
4227
|
|
|
|
|
|
|
$b->skills(['Knows Perl', 'Phreaks']); |
4228
|
|
|
|
|
|
|
$f->kids('BamBam', $b); |
4229
|
|
|
|
|
|
|
print join ', ', $f->kids_keys; # Prints "Pebbles, BamBam", |
4230
|
|
|
|
|
|
|
# though maybe not in that order. |
4231
|
|
|
|
|
|
|
|
4232
|
|
|
|
|
|
|
=head1 COMMON METHODS |
4233
|
|
|
|
|
|
|
|
4234
|
|
|
|
|
|
|
All members also have a method C. |
4235
|
|
|
|
|
|
|
This method undefines a member C. |
4236
|
|
|
|
|
|
|
|
4237
|
|
|
|
|
|
|
=head1 OBJECT INSTANCE METHODS |
4238
|
|
|
|
|
|
|
|
4239
|
|
|
|
|
|
|
C also generates methods |
4240
|
|
|
|
|
|
|
that you can invoke on an object instance. |
4241
|
|
|
|
|
|
|
These are as follows: |
4242
|
|
|
|
|
|
|
|
4243
|
|
|
|
|
|
|
=head2 Copy |
4244
|
|
|
|
|
|
|
|
4245
|
|
|
|
|
|
|
Use the C method to copy the value of an object. |
4246
|
|
|
|
|
|
|
The expression: |
4247
|
|
|
|
|
|
|
|
4248
|
|
|
|
|
|
|
$p = $o->copy; |
4249
|
|
|
|
|
|
|
|
4250
|
|
|
|
|
|
|
assigns to C<$p> a copy of C<$o>. |
4251
|
|
|
|
|
|
|
Members of C<$o> that are classes (or arrays or hashes of classes) |
4252
|
|
|
|
|
|
|
are copied using their own C method. |
4253
|
|
|
|
|
|
|
|
4254
|
|
|
|
|
|
|
=head2 Equals |
4255
|
|
|
|
|
|
|
|
4256
|
|
|
|
|
|
|
Use the C method to test the equality of two object instances: |
4257
|
|
|
|
|
|
|
|
4258
|
|
|
|
|
|
|
if ( $o1->equals($o2) ) { ... } |
4259
|
|
|
|
|
|
|
|
4260
|
|
|
|
|
|
|
The two object instances are equal if |
4261
|
|
|
|
|
|
|
members that have values in C<$o1> have equal values in C<$o2>, and vice versa. |
4262
|
|
|
|
|
|
|
Equality is tested as you would expect: |
4263
|
|
|
|
|
|
|
two scalar members are equal if they have the same value; |
4264
|
|
|
|
|
|
|
two array members are equal if they have the same elements; |
4265
|
|
|
|
|
|
|
two hash members are equal if they have the same key/value pairs. |
4266
|
|
|
|
|
|
|
|
4267
|
|
|
|
|
|
|
If a member's value is restricted to a class, |
4268
|
|
|
|
|
|
|
then equality is tested using that class' C method. |
4269
|
|
|
|
|
|
|
Otherwise, it is tested using the C operator. |
4270
|
|
|
|
|
|
|
|
4271
|
|
|
|
|
|
|
By default, all members participate in the equality test. |
4272
|
|
|
|
|
|
|
If one or more members possess true values for the C attribute, |
4273
|
|
|
|
|
|
|
then only those members participate in the equality test. |
4274
|
|
|
|
|
|
|
|
4275
|
|
|
|
|
|
|
You can override this definition of equality. |
4276
|
|
|
|
|
|
|
See L. |
4277
|
|
|
|
|
|
|
|
4278
|
|
|
|
|
|
|
=head1 ADVANCED MEMBER SPECIFICATIONS |
4279
|
|
|
|
|
|
|
|
4280
|
|
|
|
|
|
|
As shown, you specify each member as a Cvalue> pair. |
4281
|
|
|
|
|
|
|
If the C is a string, it specifies the member's type. |
4282
|
|
|
|
|
|
|
The value may also be a hash reference. |
4283
|
|
|
|
|
|
|
You use hash references to specify additional member attributes. |
4284
|
|
|
|
|
|
|
The following is a complete list of the attributes you may specify for a member: |
4285
|
|
|
|
|
|
|
|
4286
|
|
|
|
|
|
|
=over 4 |
4287
|
|
|
|
|
|
|
|
4288
|
|
|
|
|
|
|
=item type=>string |
4289
|
|
|
|
|
|
|
|
4290
|
|
|
|
|
|
|
If you use a hash reference for a member's value, |
4291
|
|
|
|
|
|
|
you I use the C attribute to specify its type: |
4292
|
|
|
|
|
|
|
|
4293
|
|
|
|
|
|
|
scalar_member => { type => '$' } |
4294
|
|
|
|
|
|
|
|
4295
|
|
|
|
|
|
|
=item required=>boolean |
4296
|
|
|
|
|
|
|
|
4297
|
|
|
|
|
|
|
If the C attribute is true, |
4298
|
|
|
|
|
|
|
the member must be passed each time the class' constructor is invoked: |
4299
|
|
|
|
|
|
|
|
4300
|
|
|
|
|
|
|
class Person => [ name => { type => '$', required => 1 } ]; |
4301
|
|
|
|
|
|
|
Person->new ( name => 'Wilma' ); # Valid |
4302
|
|
|
|
|
|
|
Person->new; # Invalid |
4303
|
|
|
|
|
|
|
|
4304
|
|
|
|
|
|
|
Also, you may not call C for the member. |
4305
|
|
|
|
|
|
|
|
4306
|
|
|
|
|
|
|
=item default=>value |
4307
|
|
|
|
|
|
|
|
4308
|
|
|
|
|
|
|
The C attribute provides a default value for a member |
4309
|
|
|
|
|
|
|
if none is passed to the constructor: |
4310
|
|
|
|
|
|
|
|
4311
|
|
|
|
|
|
|
class Person => [ name => '$', |
4312
|
|
|
|
|
|
|
job => { type => '$', |
4313
|
|
|
|
|
|
|
default => "'Perl programmer'" } ]; |
4314
|
|
|
|
|
|
|
$p = Person->new(name => 'Larry'); |
4315
|
|
|
|
|
|
|
print $p->job; # Prints 'Perl programmer'. |
4316
|
|
|
|
|
|
|
$q = Person->new(name => 'Bjourne', job => 'C++ programmer'); |
4317
|
|
|
|
|
|
|
print $q->job; # Unprintable. |
4318
|
|
|
|
|
|
|
|
4319
|
|
|
|
|
|
|
The value is treated as a string that is evaluated |
4320
|
|
|
|
|
|
|
when the constructor is invoked. |
4321
|
|
|
|
|
|
|
|
4322
|
|
|
|
|
|
|
For array members, use a string that looks like a Perl expression |
4323
|
|
|
|
|
|
|
that evaluates to an array reference: |
4324
|
|
|
|
|
|
|
|
4325
|
|
|
|
|
|
|
class Person => { |
4326
|
|
|
|
|
|
|
name => '$', |
4327
|
|
|
|
|
|
|
lucky_numbers => { type => '@', default => '[42, 17]' } |
4328
|
|
|
|
|
|
|
}; |
4329
|
|
|
|
|
|
|
class Silly => { |
4330
|
|
|
|
|
|
|
UIDs => { # Default value is all UIDs |
4331
|
|
|
|
|
|
|
type => '@', # currently in /etc/passwd. |
4332
|
|
|
|
|
|
|
default => 'do { |
4333
|
|
|
|
|
|
|
local $/ = undef; |
4334
|
|
|
|
|
|
|
open PASSWD, "/etc/passwd"; |
4335
|
|
|
|
|
|
|
[ map {(split(/:/))[2]} split /\n/, ] |
4336
|
|
|
|
|
|
|
}' |
4337
|
|
|
|
|
|
|
} |
4338
|
|
|
|
|
|
|
}; |
4339
|
|
|
|
|
|
|
|
4340
|
|
|
|
|
|
|
Specify hash members analogously. |
4341
|
|
|
|
|
|
|
|
4342
|
|
|
|
|
|
|
The value is evaluated each time the constructor is invoked. |
4343
|
|
|
|
|
|
|
In C, the default value for C can change between invocations. |
4344
|
|
|
|
|
|
|
If the default value is a reference rather than a string, |
4345
|
|
|
|
|
|
|
it is not re-evaluated. |
4346
|
|
|
|
|
|
|
In the following, default values for C and C |
4347
|
|
|
|
|
|
|
are based on the members of C<@default_value> |
4348
|
|
|
|
|
|
|
each time Cnew> is invoked, |
4349
|
|
|
|
|
|
|
whereas C's default value is set when the C function is invoked |
4350
|
|
|
|
|
|
|
to define C: |
4351
|
|
|
|
|
|
|
|
4352
|
|
|
|
|
|
|
@default_value = (1, 2, 3); |
4353
|
|
|
|
|
|
|
$var_name = '@' . __PACKAGE__ . '::default_value'; |
4354
|
|
|
|
|
|
|
class Example => { |
4355
|
|
|
|
|
|
|
e1 => { type => '@', default => "[$var_name]" }, |
4356
|
|
|
|
|
|
|
e2 => { type => '@', default => \@default_value }, |
4357
|
|
|
|
|
|
|
e3 => { type => '@', default => [ @default_value ] } |
4358
|
|
|
|
|
|
|
}; |
4359
|
|
|
|
|
|
|
Example->new; # e1, e2, and e3 are all identical. |
4360
|
|
|
|
|
|
|
@default_value = (10, 20, 30); |
4361
|
|
|
|
|
|
|
Example->new; # Now only e3 is (1, 2, 3). |
4362
|
|
|
|
|
|
|
|
4363
|
|
|
|
|
|
|
There are two more things to know about default values that are strings. |
4364
|
|
|
|
|
|
|
First, if a member is typed, |
4365
|
|
|
|
|
|
|
the C function evaluates its (string-based) |
4366
|
|
|
|
|
|
|
default value to ensure that it |
4367
|
|
|
|
|
|
|
is of the correct type for the member. |
4368
|
|
|
|
|
|
|
Be aware of this if your default value has side effects |
4369
|
|
|
|
|
|
|
(and see L). |
4370
|
|
|
|
|
|
|
|
4371
|
|
|
|
|
|
|
Second, the context of the default value is the C method |
4372
|
|
|
|
|
|
|
of the package generated to implement your class. |
4373
|
|
|
|
|
|
|
That's why C in C, above, |
4374
|
|
|
|
|
|
|
needs the name of the current package in its default value. |
4375
|
|
|
|
|
|
|
|
4376
|
|
|
|
|
|
|
=item post=>code |
4377
|
|
|
|
|
|
|
|
4378
|
|
|
|
|
|
|
The value of this attribute is a string of Perl code. |
4379
|
|
|
|
|
|
|
It is executed immediately after the member's value is modified through its accessor. |
4380
|
|
|
|
|
|
|
Within C code, you can refer to members as if they were Perl identifiers. |
4381
|
|
|
|
|
|
|
For instance: |
4382
|
|
|
|
|
|
|
|
4383
|
|
|
|
|
|
|
class Person => [ age => { type => '$', |
4384
|
|
|
|
|
|
|
post => '$age *= 2;' } ]; |
4385
|
|
|
|
|
|
|
$p = Person->new(age => 30); |
4386
|
|
|
|
|
|
|
print $p->age; # Prints 30. |
4387
|
|
|
|
|
|
|
$p->age(15); |
4388
|
|
|
|
|
|
|
print $p->age; # Prints 30 again. |
4389
|
|
|
|
|
|
|
|
4390
|
|
|
|
|
|
|
The trailing semicolon used to be required, but everyone forgot it. |
4391
|
|
|
|
|
|
|
As of version 1.06 it's optional: |
4392
|
|
|
|
|
|
|
C<'$age*=2'> is accepted and equivalent to C<'$age*=2;'> |
4393
|
|
|
|
|
|
|
(but see L<"BUGS">). |
4394
|
|
|
|
|
|
|
|
4395
|
|
|
|
|
|
|
You reference array and hash members as usual |
4396
|
|
|
|
|
|
|
(except for testing for definition; see L<"BUGS">). |
4397
|
|
|
|
|
|
|
You can reference individual elements, or the whole list: |
4398
|
|
|
|
|
|
|
|
4399
|
|
|
|
|
|
|
class Foo => [ |
4400
|
|
|
|
|
|
|
m1 => { type => '@', post => '$m1[$#m1/2] = $m2{xxx};' }, |
4401
|
|
|
|
|
|
|
m2 => { type => '%', post => '@m1 = keys %m2;' } |
4402
|
|
|
|
|
|
|
]; |
4403
|
|
|
|
|
|
|
|
4404
|
|
|
|
|
|
|
You can also invoke accessors. |
4405
|
|
|
|
|
|
|
Prefix them with a C<&>: |
4406
|
|
|
|
|
|
|
|
4407
|
|
|
|
|
|
|
class Bar => [ |
4408
|
|
|
|
|
|
|
m1 => { type => '@', post => '&undef_m1;' }, |
4409
|
|
|
|
|
|
|
m2 => { type => '%', post => '@m1 = &m2_keys;' } |
4410
|
|
|
|
|
|
|
]; |
4411
|
|
|
|
|
|
|
$o = new Bar; |
4412
|
|
|
|
|
|
|
$o->m1([1, 2, 3]); # m1 is still undefined. |
4413
|
|
|
|
|
|
|
$o->m2({a => 1, b => 2}); # Now m1 is qw(a b). |
4414
|
|
|
|
|
|
|
|
4415
|
|
|
|
|
|
|
=item pre=>code |
4416
|
|
|
|
|
|
|
|
4417
|
|
|
|
|
|
|
The C key is similar to the C key, |
4418
|
|
|
|
|
|
|
but it is executed just before an member is changed. |
4419
|
|
|
|
|
|
|
It is I executed if the member is only accessed. |
4420
|
|
|
|
|
|
|
The C and C code have the same scope, |
4421
|
|
|
|
|
|
|
which lets you share variables. |
4422
|
|
|
|
|
|
|
For instance: |
4423
|
|
|
|
|
|
|
|
4424
|
|
|
|
|
|
|
class Foo => [ |
4425
|
|
|
|
|
|
|
mem => { type => '$', pre => 'my $v = $mem;', post => 'return $v;' } |
4426
|
|
|
|
|
|
|
]; |
4427
|
|
|
|
|
|
|
$o = new Foo; |
4428
|
|
|
|
|
|
|
$p = $o->mem(1); # Sets $p to undef. |
4429
|
|
|
|
|
|
|
$q = $o->mem(2); # Sets $q to 1. |
4430
|
|
|
|
|
|
|
|
4431
|
|
|
|
|
|
|
is a way to return the previous value of C any time it's modified |
4432
|
|
|
|
|
|
|
(but see L<"NOTES">). |
4433
|
|
|
|
|
|
|
|
4434
|
|
|
|
|
|
|
=item assert=>expression |
4435
|
|
|
|
|
|
|
|
4436
|
|
|
|
|
|
|
The value of this key should be a Perl expression |
4437
|
|
|
|
|
|
|
that evaluates to true or false. |
4438
|
|
|
|
|
|
|
Use member names in the expression, as with C. |
4439
|
|
|
|
|
|
|
The expression will be tested any time |
4440
|
|
|
|
|
|
|
the member is modified through its accessors. |
4441
|
|
|
|
|
|
|
Your code will C if the expression evaluates to false. |
4442
|
|
|
|
|
|
|
For instance, |
4443
|
|
|
|
|
|
|
|
4444
|
|
|
|
|
|
|
class Person => [ |
4445
|
|
|
|
|
|
|
name => '$', |
4446
|
|
|
|
|
|
|
age => { type => '$', |
4447
|
|
|
|
|
|
|
assert => '$age =~ /^\d+$/ && $age < 200' } ]; |
4448
|
|
|
|
|
|
|
|
4449
|
|
|
|
|
|
|
ensures the age is reasonable. |
4450
|
|
|
|
|
|
|
|
4451
|
|
|
|
|
|
|
The assertion is executed after any C code associated with the member. |
4452
|
|
|
|
|
|
|
|
4453
|
|
|
|
|
|
|
=item private=>boolean |
4454
|
|
|
|
|
|
|
|
4455
|
|
|
|
|
|
|
If the C attribute is true, |
4456
|
|
|
|
|
|
|
the member cannot be accessed outside the class; |
4457
|
|
|
|
|
|
|
that is, it has no accessor functions that can be called |
4458
|
|
|
|
|
|
|
outside the scope of the package defined by C. |
4459
|
|
|
|
|
|
|
A private member can, however, be accessed in C, C, and C |
4460
|
|
|
|
|
|
|
code of other members of the class. |
4461
|
|
|
|
|
|
|
|
4462
|
|
|
|
|
|
|
=item protected=>boolean |
4463
|
|
|
|
|
|
|
|
4464
|
|
|
|
|
|
|
If the C attribute is true, |
4465
|
|
|
|
|
|
|
the member cannot be accessed outside the class or any of its subclasses. |
4466
|
|
|
|
|
|
|
A protected member can, however, be accessed in C, C, and C |
4467
|
|
|
|
|
|
|
code of other members of the class or its subclasses. |
4468
|
|
|
|
|
|
|
|
4469
|
|
|
|
|
|
|
=item readonly=>boolean |
4470
|
|
|
|
|
|
|
|
4471
|
|
|
|
|
|
|
If this attribute is true, then the member cannot be modified |
4472
|
|
|
|
|
|
|
through its accessors. |
4473
|
|
|
|
|
|
|
Users can set the member only by using the class constructor. |
4474
|
|
|
|
|
|
|
The member's accessor that is its name can retrieve but not set the member. |
4475
|
|
|
|
|
|
|
The CI accessor is not defined for the member, |
4476
|
|
|
|
|
|
|
nor are other accessors that might modify the member. |
4477
|
|
|
|
|
|
|
(Code in C can set it, however.) |
4478
|
|
|
|
|
|
|
|
4479
|
|
|
|
|
|
|
=item key=>boolean |
4480
|
|
|
|
|
|
|
|
4481
|
|
|
|
|
|
|
If this attribute is true, then the member participates in equality tests. |
4482
|
|
|
|
|
|
|
See L<"Equals">. |
4483
|
|
|
|
|
|
|
|
4484
|
|
|
|
|
|
|
=item nocopy=>value |
4485
|
|
|
|
|
|
|
|
4486
|
|
|
|
|
|
|
The C attribute gives you some per-member control |
4487
|
|
|
|
|
|
|
over how the C method. |
4488
|
|
|
|
|
|
|
If C is false (the default), |
4489
|
|
|
|
|
|
|
the original's value is copied as described in L<"Copy">. |
4490
|
|
|
|
|
|
|
If C is true, |
4491
|
|
|
|
|
|
|
the original's value is assigned rather than copied; |
4492
|
|
|
|
|
|
|
in other words, the copy and the original will have the same value |
4493
|
|
|
|
|
|
|
if the original's value is a reference. |
4494
|
|
|
|
|
|
|
|
4495
|
|
|
|
|
|
|
=back |
4496
|
|
|
|
|
|
|
|
4497
|
|
|
|
|
|
|
=head1 AFFECTING THE CONSTRUCTOR |
4498
|
|
|
|
|
|
|
|
4499
|
|
|
|
|
|
|
You may include a C attribute in the specification to affect the constructor. |
4500
|
|
|
|
|
|
|
Its value must be a hash reference. |
4501
|
|
|
|
|
|
|
Its attributes are: |
4502
|
|
|
|
|
|
|
|
4503
|
|
|
|
|
|
|
=over 4 |
4504
|
|
|
|
|
|
|
|
4505
|
|
|
|
|
|
|
=item required=>list of constraints |
4506
|
|
|
|
|
|
|
|
4507
|
|
|
|
|
|
|
This is another (and more general) way to require that |
4508
|
|
|
|
|
|
|
parameters be passed to the constructor. |
4509
|
|
|
|
|
|
|
Its value is a reference to an array of constraints. |
4510
|
|
|
|
|
|
|
Each constraint is a string that must be an expression |
4511
|
|
|
|
|
|
|
composed of Perl logical operators and member names. |
4512
|
|
|
|
|
|
|
For example: |
4513
|
|
|
|
|
|
|
|
4514
|
|
|
|
|
|
|
class Person => { |
4515
|
|
|
|
|
|
|
name => '$', |
4516
|
|
|
|
|
|
|
age => '$', |
4517
|
|
|
|
|
|
|
height => '$', |
4518
|
|
|
|
|
|
|
weight => '$', |
4519
|
|
|
|
|
|
|
new => { required => ['name', 'height^weight'] } |
4520
|
|
|
|
|
|
|
}; |
4521
|
|
|
|
|
|
|
|
4522
|
|
|
|
|
|
|
requires member C, and exactly one of C or C. |
4523
|
|
|
|
|
|
|
Note that the names are I prefixed with C<$>, C<@>, or C<%>. |
4524
|
|
|
|
|
|
|
|
4525
|
|
|
|
|
|
|
Specifying a list of constraints as an array reference can be clunky. |
4526
|
|
|
|
|
|
|
The C function also lets you specify the list as a string, |
4527
|
|
|
|
|
|
|
with individual constraints separated by spaces. |
4528
|
|
|
|
|
|
|
The following two strings are equivalent to the above C attribute: |
4529
|
|
|
|
|
|
|
|
4530
|
|
|
|
|
|
|
'name height^weight' |
4531
|
|
|
|
|
|
|
'name&(height^weight)' |
4532
|
|
|
|
|
|
|
|
4533
|
|
|
|
|
|
|
However, C<'name & (height ^ weight)'> would not work. |
4534
|
|
|
|
|
|
|
The C function interprets it as a five-member list, |
4535
|
|
|
|
|
|
|
four members of which are not valid expressions. |
4536
|
|
|
|
|
|
|
|
4537
|
|
|
|
|
|
|
This equivalence between a reference to array of strings |
4538
|
|
|
|
|
|
|
and a string of space-separated items is used throughout C. |
4539
|
|
|
|
|
|
|
Use whichever form works best for you. |
4540
|
|
|
|
|
|
|
|
4541
|
|
|
|
|
|
|
=item post=>string of code |
4542
|
|
|
|
|
|
|
|
4543
|
|
|
|
|
|
|
The C key is similar to the C key for members. |
4544
|
|
|
|
|
|
|
Its value is code that is inserted into the constructor |
4545
|
|
|
|
|
|
|
after parameter values have been assigned to members. |
4546
|
|
|
|
|
|
|
The C function performs variable substitution. |
4547
|
|
|
|
|
|
|
|
4548
|
|
|
|
|
|
|
The C key is I recognized in C. |
4549
|
|
|
|
|
|
|
|
4550
|
|
|
|
|
|
|
=item assert=>expression |
4551
|
|
|
|
|
|
|
|
4552
|
|
|
|
|
|
|
The C key's value is inserted |
4553
|
|
|
|
|
|
|
just after the C key's value (if any). |
4554
|
|
|
|
|
|
|
Assertions for members are inserted after the constructor's assertion. |
4555
|
|
|
|
|
|
|
|
4556
|
|
|
|
|
|
|
=item comment=>string |
4557
|
|
|
|
|
|
|
|
4558
|
|
|
|
|
|
|
This attribute's value can be any string. |
4559
|
|
|
|
|
|
|
If you save the class to a file |
4560
|
|
|
|
|
|
|
(see L), |
4561
|
|
|
|
|
|
|
the string is included as a comment just before |
4562
|
|
|
|
|
|
|
the member's methods. |
4563
|
|
|
|
|
|
|
|
4564
|
|
|
|
|
|
|
=item style=>style definition |
4565
|
|
|
|
|
|
|
|
4566
|
|
|
|
|
|
|
The C |