| 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 |