line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Class::Generate; |
2
|
|
|
|
|
|
|
$Class::Generate::VERSION = '1.17'; |
3
|
22
|
|
|
22
|
|
94709
|
use 5.010; |
|
22
|
|
|
|
|
2578
|
|
4
|
22
|
|
|
20
|
|
505
|
use strict; |
|
20
|
|
|
|
|
484
|
|
|
20
|
|
|
|
|
958
|
|
5
|
20
|
|
|
17
|
|
442
|
use Carp; |
|
17
|
|
|
|
|
45
|
|
|
17
|
|
|
|
|
1092
|
|
6
|
17
|
|
|
18
|
|
201
|
use warnings::register; |
|
18
|
|
|
|
|
58
|
|
|
18
|
|
|
|
|
2156
|
|
7
|
18
|
|
|
21
|
|
5853
|
use Symbol qw(&delete_package); |
|
21
|
|
|
|
|
8981
|
|
|
21
|
|
|
|
|
1383
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
BEGIN { |
10
|
21
|
|
|
21
|
|
497
|
use vars qw(@ISA @EXPORT_OK); |
|
21
|
|
|
|
|
80
|
|
|
21
|
|
|
|
|
643
|
|
11
|
21
|
|
|
17
|
|
885
|
use vars qw($save $accept_refs $strict $allow_redefine $class_var $instance_var $check_params $check_code $check_default $nfi $warnings); |
|
17
|
|
|
|
|
48
|
|
|
17
|
|
|
|
|
1728
|
|
12
|
|
|
|
|
|
|
|
13
|
17
|
|
|
17
|
|
647
|
require Exporter; |
14
|
17
|
|
|
|
|
260
|
@ISA = qw(Exporter); |
15
|
17
|
|
|
|
|
72
|
@EXPORT_OK = (qw(&class &subclass &delete_class), qw($save $accept_refs $strict $allow_redefine $class_var $instance_var $check_params $check_code $check_default $nfi $warnings)); |
16
|
|
|
|
|
|
|
|
17
|
17
|
|
|
|
|
3077
|
$accept_refs = 1; |
18
|
15
|
|
|
|
|
40
|
$strict = 1; |
19
|
15
|
|
|
|
|
28
|
$allow_redefine = 0; |
20
|
15
|
|
|
|
|
139
|
$class_var = 'class'; |
21
|
15
|
|
|
|
|
38
|
$instance_var = 'self'; |
22
|
15
|
|
|
|
|
24
|
$check_params = 1; |
23
|
15
|
|
|
|
|
354
|
$check_code = 1; |
24
|
15
|
|
|
|
|
39
|
$check_default = 1; |
25
|
15
|
|
|
|
|
30
|
$nfi = 0; |
26
|
15
|
|
|
|
|
1691
|
$warnings = 1; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
15
|
|
|
15
|
|
88
|
use vars qw(@_initial_values); # Holds all initial values passed as references. |
|
15
|
|
|
|
|
28
|
|
|
15
|
|
|
|
|
55982
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my ($class_name, $class); |
32
|
|
|
|
|
|
|
my ($class_vars, $use_packages, $excluded_methods, $param_style_spec, $default_pss); |
33
|
|
|
|
|
|
|
my %class_options; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my $cm; # These variables are for error messages. |
36
|
|
|
|
|
|
|
my $sa_needed = 'must be string or array reference'; |
37
|
|
|
|
|
|
|
my $sh_needed = 'must be string or hash reference'; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my $allow_redefine_for_class; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my ($initialize, # These variables all hold |
42
|
|
|
|
|
|
|
$parse_any_flags, # references to package-local |
43
|
|
|
|
|
|
|
$set_class_type, # subs that other packages |
44
|
|
|
|
|
|
|
$parse_class_specification, # shouldn't call. |
45
|
|
|
|
|
|
|
$parse_method_specification, |
46
|
|
|
|
|
|
|
$parse_member_specification, |
47
|
|
|
|
|
|
|
$set_attributes, |
48
|
|
|
|
|
|
|
$class_defined, |
49
|
|
|
|
|
|
|
$process_class, |
50
|
|
|
|
|
|
|
$store_initial_value_reference, |
51
|
|
|
|
|
|
|
$check_for_invalid_parameter_names, |
52
|
|
|
|
|
|
|
$constructor_parameter_passing_style, |
53
|
|
|
|
|
|
|
$verify_class_type, |
54
|
|
|
|
|
|
|
$croak_if_duplicate_names, |
55
|
|
|
|
|
|
|
$invalid_spec_message); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
my %valid_option = map(substr($_, 0, 1) eq '$' ? (substr($_,1) => 1) : (), @EXPORT_OK); |
58
|
|
|
|
|
|
|
my %class_to_ref_map = ( |
59
|
|
|
|
|
|
|
'Class::Generate::Array_Class' => 'ARRAY', |
60
|
|
|
|
|
|
|
'Class::Generate::Hash_Class' => 'HASH' |
61
|
|
|
|
|
|
|
); |
62
|
|
|
|
|
|
|
my %warnings_keys = map(($_ => 1), qw(use no register)); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
sub class(%) { # One of the three interface |
65
|
54
|
|
|
54
|
1
|
1742
|
my %params = @_; # routines to the package. |
66
|
54
|
100
|
|
|
|
202
|
if ( defined $params{-parent} ) { # Defines a class or a |
67
|
7
|
|
|
|
|
52
|
subclass(@_); # subclass. |
68
|
7
|
|
|
|
|
37
|
return; |
69
|
|
|
|
|
|
|
} |
70
|
48
|
|
|
|
|
172
|
&$initialize(); |
71
|
48
|
|
|
|
|
222
|
&$parse_any_flags(\%params); |
72
|
48
|
50
|
|
|
|
164
|
croak "Missing/extra arguments to class()" if scalar(keys %params) != 1; |
73
|
48
|
|
|
|
|
144
|
($class_name, undef) = %params; |
74
|
48
|
|
|
|
|
366
|
$cm = qq|Class "$class_name"|; |
75
|
47
|
|
|
|
|
181
|
&$verify_class_type($params{$class_name}); |
76
|
47
|
50
|
33
|
|
|
205
|
croak "$cm: A package of this name already exists" if ! $allow_redefine_for_class && &$class_defined($class_name); |
77
|
47
|
|
|
|
|
220
|
&$set_class_type($params{$class_name}); |
78
|
47
|
|
|
|
|
143
|
&$process_class($params{$class_name}); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub subclass(%) { # One of the three interface |
82
|
15
|
|
|
16
|
1
|
281
|
my %params = @_; # routines to the package. |
83
|
15
|
|
|
|
|
75
|
&$initialize(); # Defines a subclass. |
84
|
15
|
|
|
|
|
35
|
my ($p_spec, $parent); |
85
|
15
|
50
|
|
|
|
72
|
if ( defined ($p_spec = $params{-parent}) ) { |
86
|
15
|
|
|
|
|
48
|
delete $params{-parent}; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
else { |
89
|
0
|
|
|
|
|
0
|
croak "Missing subclass parent"; |
90
|
|
|
|
|
|
|
} |
91
|
15
|
|
|
|
|
35
|
eval { $parent = Class::Generate::Array->new($p_spec) }; |
|
15
|
|
|
|
|
69
|
|
92
|
15
|
50
|
33
|
|
|
98
|
croak qq|Invalid parent specification ($sa_needed)| if $@ || scalar($parent->values) == 0; |
93
|
15
|
|
|
|
|
75
|
&$parse_any_flags(\%params); |
94
|
15
|
50
|
|
|
|
68
|
croak "Missing/extra arguments to subclass()" if scalar(keys %params) != 1; |
95
|
15
|
|
|
|
|
54
|
($class_name, undef) = %params; |
96
|
15
|
|
|
|
|
61
|
$cm = qq|Subclass "$class_name"|; |
97
|
15
|
|
|
|
|
85
|
&$verify_class_type($params{$class_name}); |
98
|
15
|
50
|
33
|
|
|
91
|
croak "$cm: A package of this name already exists" if ! $allow_redefine_for_class && &$class_defined($class_name); |
99
|
15
|
100
|
|
|
|
102
|
my $assumed_type = UNIVERSAL::isa($params{$class_name}, 'ARRAY') ? 'ARRAY' : 'HASH'; |
100
|
15
|
|
|
|
|
52
|
my $child_type = lc($assumed_type); |
101
|
15
|
|
|
|
|
51
|
for my $p ( $parent->values ) { |
102
|
15
|
|
|
|
|
65
|
my $c = Class::Generate::Class_Holder::get($p, $assumed_type); |
103
|
15
|
50
|
|
|
|
49
|
croak qq|$cm: Parent package "$p" does not exist| if ! defined $c; |
104
|
15
|
|
|
|
|
69
|
my $parent_type = lc($class_to_ref_map{ref $c}); |
105
|
|
|
|
|
|
|
croak "$cm: $child_type-based class must have $child_type-based parent ($p is $parent_type-based)" |
106
|
15
|
50
|
|
|
|
82
|
if ! UNIVERSAL::isa($params{$class_name}, $class_to_ref_map{ref $c}); |
107
|
15
|
50
|
33
|
|
|
2323
|
warnings::warn(qq{$cm: Parent class "$p" was not defined using class() or subclass(); $child_type reference assumed}) |
108
|
|
|
|
|
|
|
if warnings::enabled() && eval "! exists \$" . $p . '::{_cginfo}'; |
109
|
|
|
|
|
|
|
} |
110
|
15
|
|
|
|
|
96
|
&$set_class_type($params{$class_name}, $parent); |
111
|
15
|
|
|
|
|
55
|
for my $p ( $parent->values ) { |
112
|
15
|
|
|
|
|
55
|
$class->add_parents(Class::Generate::Class_Holder::get($p)); |
113
|
|
|
|
|
|
|
} |
114
|
15
|
|
|
|
|
58
|
&$process_class($params{$class_name}); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub delete_class(@) { # One of the three interface routines |
118
|
0
|
|
|
1
|
1
|
0
|
for my $class ( @_ ) { # to the package. Deletes a class |
119
|
0
|
0
|
|
|
|
0
|
next if ! eval '%' . $class . '::'; # declared using Class::Generate. |
120
|
0
|
0
|
|
|
|
0
|
if ( ! eval '%' . $class . '::_cginfo' ) { |
121
|
0
|
|
|
|
|
0
|
croak $class, ': Class was not declared using ', __PACKAGE__; |
122
|
|
|
|
|
|
|
} |
123
|
0
|
|
|
|
|
0
|
delete_package($class); |
124
|
0
|
|
|
|
|
0
|
Class::Generate::Class_Holder::remove($class); |
125
|
0
|
|
|
|
|
0
|
my $code_checking_package = __PACKAGE__ . '::Code_Checker::check::' . $class . '::'; |
126
|
0
|
0
|
|
|
|
0
|
if ( eval '%' . $code_checking_package ) { |
127
|
0
|
|
|
|
|
0
|
delete_package($code_checking_package); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
$default_pss = Class::Generate::Array->new('key_value'); |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
$initialize = sub { # Reset certain variables, and set |
135
|
|
|
|
|
|
|
undef $class_vars; # options to their default values. |
136
|
|
|
|
|
|
|
undef $use_packages; |
137
|
|
|
|
|
|
|
undef $excluded_methods; |
138
|
|
|
|
|
|
|
$param_style_spec = $default_pss; |
139
|
|
|
|
|
|
|
%class_options = ( virtual => 0, |
140
|
|
|
|
|
|
|
strict => $strict, |
141
|
|
|
|
|
|
|
save => $save, |
142
|
|
|
|
|
|
|
accept_refs => $accept_refs, |
143
|
|
|
|
|
|
|
class_var => $class_var, |
144
|
|
|
|
|
|
|
instance_var => $instance_var, |
145
|
|
|
|
|
|
|
check_params => $check_params, |
146
|
|
|
|
|
|
|
check_code => $check_code, |
147
|
|
|
|
|
|
|
check_default=> $check_default, |
148
|
|
|
|
|
|
|
nfi => $nfi, |
149
|
|
|
|
|
|
|
warnings => $warnings ); |
150
|
|
|
|
|
|
|
$allow_redefine_for_class = $allow_redefine; |
151
|
|
|
|
|
|
|
}; |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
$verify_class_type = sub { # Ensure that the class specification |
154
|
|
|
|
|
|
|
my $spec = $_[0]; # is a hash or array reference. |
155
|
|
|
|
|
|
|
return if UNIVERSAL::isa($spec, 'HASH') || UNIVERSAL::isa($spec, 'ARRAY'); |
156
|
|
|
|
|
|
|
croak qq|$cm: Elements must be in array or hash reference|; |
157
|
|
|
|
|
|
|
}; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
$set_class_type = sub { # Set $class to the type (array or |
160
|
|
|
|
|
|
|
my ($class_spec, $parent) = @_; # hash) appropriate to its declaration. |
161
|
|
|
|
|
|
|
my @params = ($class_name, %class_options); |
162
|
|
|
|
|
|
|
if ( UNIVERSAL::isa($class_spec, 'ARRAY') ) { |
163
|
|
|
|
|
|
|
if ( defined $parent ) { |
164
|
|
|
|
|
|
|
my ($parent_name, @other_array_values) = $parent->values; |
165
|
|
|
|
|
|
|
croak qq|$cm: An array reference based subclass must have exactly one parent| |
166
|
|
|
|
|
|
|
if @other_array_values; |
167
|
|
|
|
|
|
|
$parent = Class::Generate::Class_Holder::get($parent_name, 'ARRAY'); |
168
|
|
|
|
|
|
|
push @params, ( base_index => $parent->last + 1 ); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
$class = Class::Generate::Array_Class->new(@params); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
|
|
|
|
|
|
$class = Class::Generate::Hash_Class->new(@params); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
}; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
my $class_name_regexp = '[A-Za-z_]\w*(::[A-Za-z_]\w*)*'; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
$parse_class_specification = sub { # Parse the class' specification, |
180
|
|
|
|
|
|
|
my %specs = @_; # checking for errors and amalgamating |
181
|
|
|
|
|
|
|
my %required; # class data. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
if ( defined $specs{new} ) { |
184
|
|
|
|
|
|
|
croak qq|$cm: Specification for "new" must be hash reference| |
185
|
|
|
|
|
|
|
unless UNIVERSAL::isa($specs{new}, 'HASH'); |
186
|
|
|
|
|
|
|
my %new_spec = %{$specs{new}}; # Modify %new_spec, not parameter passed |
187
|
|
|
|
|
|
|
my $required_items; # to class() or subclass(). |
188
|
|
|
|
|
|
|
if ( defined $new_spec{required} ) { |
189
|
|
|
|
|
|
|
eval { $required_items = Class::Generate::Array->new($new_spec{required}) }; |
190
|
|
|
|
|
|
|
croak qq|$cm: Invalid specification for required constructor parameters ($sa_needed)| if $@; |
191
|
|
|
|
|
|
|
delete $new_spec{required}; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
if ( defined $new_spec{style} ) { |
194
|
|
|
|
|
|
|
eval { $param_style_spec = Class::Generate::Array->new($new_spec{style}) }; |
195
|
|
|
|
|
|
|
croak qq|$cm: Invalid parameter-passing style ($sa_needed)| if $@; |
196
|
|
|
|
|
|
|
delete $new_spec{style}; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
$class->constructor(Class::Generate::Constructor->new(%new_spec)); |
199
|
|
|
|
|
|
|
if ( defined $required_items ) { |
200
|
|
|
|
|
|
|
for ( $required_items->values ) { |
201
|
|
|
|
|
|
|
if ( /^\w+$/ ) { |
202
|
|
|
|
|
|
|
croak qq|$cm: Required params list for constructor contains unknown member "$_"| |
203
|
|
|
|
|
|
|
if ! defined $specs{$_}; |
204
|
|
|
|
|
|
|
$required{$_} = 1; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
else { |
207
|
|
|
|
|
|
|
$class->constructor->add_constraints($_); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
else { |
213
|
|
|
|
|
|
|
$class->constructor(Class::Generate::Constructor->new); |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
my $actual_name; |
217
|
|
|
|
|
|
|
for my $member_name ( grep $_ ne 'new', keys %specs ) { |
218
|
|
|
|
|
|
|
$actual_name = $member_name; |
219
|
|
|
|
|
|
|
$actual_name =~ s/^&//; |
220
|
|
|
|
|
|
|
croak qq|$cm: Invalid member/method name "$actual_name"| unless $actual_name =~ /^[A-Za-z_]\w*$/; |
221
|
|
|
|
|
|
|
croak qq|$cm: "$instance_var" is reserved| unless $actual_name ne $class_options{instance_var}; |
222
|
|
|
|
|
|
|
if ( substr($member_name, 0, 1) eq '&' ) { |
223
|
|
|
|
|
|
|
&$parse_method_specification($member_name, $actual_name, \%specs); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
else { |
226
|
|
|
|
|
|
|
&$parse_member_specification($member_name, \%specs, \%required); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
$class->constructor->style(&$constructor_parameter_passing_style); |
230
|
|
|
|
|
|
|
}; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
$parse_method_specification = sub { |
233
|
|
|
|
|
|
|
my ($member_name, $actual_name, $specs) = @_; |
234
|
|
|
|
|
|
|
my (%spec, $method); |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
eval { %spec = %{Class::Generate::Hash->new($$specs{$member_name} || die, 'body')} }; |
237
|
|
|
|
|
|
|
croak &$invalid_spec_message('method', $actual_name, 'body') if $@; |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
if ( $spec{class_method} ) { |
240
|
|
|
|
|
|
|
croak qq|$cm: Method "$actual_name": A class method cannot be protected| if $spec{protected}; |
241
|
|
|
|
|
|
|
$method = Class::Generate::Class_Method->new($actual_name, $spec{body}); |
242
|
|
|
|
|
|
|
if ( $spec{objects} ) { |
243
|
|
|
|
|
|
|
eval { $method->add_objects((Class::Generate::Array->new($spec{objects}))->values) }; |
244
|
|
|
|
|
|
|
croak qq|$cm: Invalid specification for objects of "$actual_name" ($sa_needed)| if $@; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
delete $spec{objects} if exists $spec{objects}; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
else { |
249
|
|
|
|
|
|
|
$method = Class::Generate::Method->new($actual_name, $spec{body}); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
delete $spec{class_method} if exists $spec{class_method}; |
252
|
|
|
|
|
|
|
$class->user_defined_methods($actual_name, $method); |
253
|
|
|
|
|
|
|
&$set_attributes($actual_name, $method, 'Method', 'body', \%spec); |
254
|
|
|
|
|
|
|
}; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
$parse_member_specification = sub { |
257
|
|
|
|
|
|
|
my ($member_name, $specs, $required) = @_; |
258
|
|
|
|
|
|
|
my (%spec, $member, %member_params); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
eval { %spec = %{Class::Generate::Hash->new($$specs{$member_name} || die, 'type')} }; |
261
|
|
|
|
|
|
|
croak &$invalid_spec_message('member', $member_name, 'type') if $@; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
$spec{required} = 1 if $$required{$member_name}; |
264
|
|
|
|
|
|
|
if ( exists $spec{default} ) { |
265
|
|
|
|
|
|
|
if ( warnings::enabled() && $class_options{check_default} ) { |
266
|
|
|
|
|
|
|
eval { Class::Generate::Support::verify_value($spec{default}, $spec{type}) }; |
267
|
|
|
|
|
|
|
warnings::warn(qq|$cm: Default value for "$member_name" is not correctly typed|) if $@; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
&$store_initial_value_reference(\$spec{default}, $member_name) if ref $spec{default}; |
270
|
|
|
|
|
|
|
$member_params{default} = $spec{default}; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
%member_params = map defined $spec{$_} ? ($_ => $spec{$_}) : (), qw(post pre assert); |
273
|
|
|
|
|
|
|
if ( $spec{type} =~ m/^[\$@%]?($class_name_regexp)$/o ) { |
274
|
|
|
|
|
|
|
$member_params{base} = $1; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
elsif ( $spec{type} !~ m/^[\$\@\%]$/ ) { |
277
|
|
|
|
|
|
|
croak qq|$cm: Member "$member_name": "$spec{type}" is not a valid type|; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
if ( $spec{required} && ($spec{private} || $spec{protected}) ) { |
280
|
|
|
|
|
|
|
warnings::warn(qq|$cm: "required" attribute ignored for private/protected member "$member_name"|) if warnings::enabled(); |
281
|
|
|
|
|
|
|
delete $spec{required}; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
if ( $spec{private} && $spec{protected} ) { |
284
|
|
|
|
|
|
|
warnings::warn(qq|$cm: Member "$member_name" declared both private and protected (protected assumed)|) if warnings::enabled(); |
285
|
|
|
|
|
|
|
delete $spec{private}; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
delete @member_params{grep ! defined $member_params{$_}, keys %member_params}; |
288
|
|
|
|
|
|
|
if ( substr($spec{type}, 0, 1) eq '@' ) { |
289
|
|
|
|
|
|
|
$member = Class::Generate::Array_Member->new($member_name, %member_params); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
elsif ( substr($spec{type}, 0, 1) eq '%' ) { |
292
|
|
|
|
|
|
|
$member = Class::Generate::Hash_Member->new($member_name, %member_params); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
else { |
295
|
|
|
|
|
|
|
$member = Class::Generate::Scalar_Member->new($member_name, %member_params); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
delete $spec{type}; |
298
|
|
|
|
|
|
|
$class->members($member_name, $member); |
299
|
|
|
|
|
|
|
&$set_attributes($member_name, $member, 'Member', undef, \%spec); |
300
|
|
|
|
|
|
|
}; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
$parse_any_flags = sub { |
303
|
|
|
|
|
|
|
my $params = $_[0]; |
304
|
|
|
|
|
|
|
my %flags = map substr($_, 0, 1) eq '-' ? ($_ => $$params{$_}) : (), keys %$params; |
305
|
|
|
|
|
|
|
return if ! %flags; |
306
|
|
|
|
|
|
|
flag: |
307
|
|
|
|
|
|
|
while ( my ($flag, $value) = each %flags ) { |
308
|
|
|
|
|
|
|
$flag eq '-use' and do { |
309
|
|
|
|
|
|
|
eval { $use_packages = Class::Generate::Array->new($value) }; |
310
|
|
|
|
|
|
|
croak qq|"-use" flag $sa_needed| if $@; |
311
|
|
|
|
|
|
|
next flag; |
312
|
|
|
|
|
|
|
}; |
313
|
|
|
|
|
|
|
$flag eq '-class_vars' and do { |
314
|
|
|
|
|
|
|
eval { $class_vars = Class::Generate::Array->new($value) }; |
315
|
|
|
|
|
|
|
croak qq|"-class_vars" flag $sa_needed| if $@; |
316
|
|
|
|
|
|
|
for my $var_spec ( grep ref($_), $class_vars->values ) { |
317
|
|
|
|
|
|
|
croak 'Each class variable must be scalar or hash reference' |
318
|
|
|
|
|
|
|
unless UNIVERSAL::isa($var_spec, 'HASH'); |
319
|
|
|
|
|
|
|
for my $var ( grep ref($$var_spec{$_}), keys %$var_spec ) { |
320
|
|
|
|
|
|
|
&$store_initial_value_reference(\$$var_spec{$var}, $var); |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
next flag; |
324
|
|
|
|
|
|
|
}; |
325
|
|
|
|
|
|
|
$flag eq '-virtual' and do { |
326
|
|
|
|
|
|
|
$class_options{virtual} = $value; |
327
|
|
|
|
|
|
|
next flag; |
328
|
|
|
|
|
|
|
}; |
329
|
|
|
|
|
|
|
$flag eq '-exclude' and do { |
330
|
|
|
|
|
|
|
eval { $excluded_methods = Class::Generate::Array->new($value) }; |
331
|
|
|
|
|
|
|
croak qq|"-exclude" flag $sa_needed| if $@; |
332
|
|
|
|
|
|
|
next flag; |
333
|
|
|
|
|
|
|
}; |
334
|
|
|
|
|
|
|
$flag eq '-comment' and do { |
335
|
|
|
|
|
|
|
$class_options{comment} = $value; |
336
|
|
|
|
|
|
|
next flag; |
337
|
|
|
|
|
|
|
}; |
338
|
|
|
|
|
|
|
$flag eq '-options' and do { |
339
|
|
|
|
|
|
|
croak qq|Options must be in hash reference| unless UNIVERSAL::isa($value, 'HASH'); |
340
|
|
|
|
|
|
|
if ( exists $$value{allow_redefine} ) { |
341
|
|
|
|
|
|
|
$allow_redefine_for_class = $$value{allow_redefine}; |
342
|
|
|
|
|
|
|
delete $$value{allow_redefine}; |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
option: |
345
|
|
|
|
|
|
|
while ( my ($o, $o_value) = each %$value ) { |
346
|
|
|
|
|
|
|
if ( ! $valid_option{$o} ) { |
347
|
|
|
|
|
|
|
warnings::warn(qq|Unknown option "$o" ignored|) if warnings::enabled(); |
348
|
|
|
|
|
|
|
next option; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
$class_options{$o} = $o_value; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
if ( exists $class_options{warnings} ) { |
354
|
|
|
|
|
|
|
my $w = $class_options{warnings}; |
355
|
|
|
|
|
|
|
if ( ref $w ) { |
356
|
|
|
|
|
|
|
croak 'Warnings must be scalar value or array reference' unless UNIVERSAL::isa($w, 'ARRAY'); |
357
|
|
|
|
|
|
|
croak 'Warnings array reference must have even number of elements' unless $#$w % 2 == 1; |
358
|
|
|
|
|
|
|
for ( my $i = 0; $i <= $#$w; $i += 2 ) { |
359
|
|
|
|
|
|
|
croak qq|Warnings array: Unknown key "$$w[$i]"| unless exists $warnings_keys{$$w[$i]}; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
next flag; |
365
|
|
|
|
|
|
|
}; |
366
|
|
|
|
|
|
|
warnings::warn(qq|Unknown flag "$flag" ignored|) if warnings::enabled(); |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
delete @$params{keys %flags}; |
369
|
|
|
|
|
|
|
}; |
370
|
|
|
|
|
|
|
# Set the appropriate attributes of |
371
|
|
|
|
|
|
|
$set_attributes = sub { # a member or method w.r.t. a class. |
372
|
|
|
|
|
|
|
my ($name, $m, $type, $exclusion, $spec) = @_; |
373
|
|
|
|
|
|
|
for my $attr ( defined $exclusion ? grep($_ ne $exclusion, keys %$spec) : keys %$spec ) { |
374
|
|
|
|
|
|
|
if ( $m->can($attr) ) { |
375
|
|
|
|
|
|
|
$m->$attr($$spec{$attr}); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
elsif ( $class->can($attr) ) { |
378
|
|
|
|
|
|
|
$class->$attr($name, $$spec{$attr}); |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
else { |
381
|
|
|
|
|
|
|
warnings::warn(qq|$cm: $type "$name": Unknown attribute "$attr"|) if warnings::enabled(); |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
}; |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
my $containing_package = __PACKAGE__ . '::'; |
387
|
|
|
|
|
|
|
my $initial_value_form = $containing_package . '_initial_values'; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
$store_initial_value_reference = sub { # Store initial values that are |
390
|
|
|
|
|
|
|
my ($default_value, $var_name) = @_; # references in an accessible |
391
|
|
|
|
|
|
|
push @_initial_values, $$default_value; # place. |
392
|
|
|
|
|
|
|
$$default_value = "\$$initial_value_form" . "[$#_initial_values]"; |
393
|
|
|
|
|
|
|
warnings::warn(qq|Cannot save reference as initial value for "$var_name"|) |
394
|
|
|
|
|
|
|
if $class_options{save} && warnings::enabled(); |
395
|
|
|
|
|
|
|
}; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
$class_defined = sub { # Return TRUE if the argument |
398
|
|
|
|
|
|
|
my $class_name = $_[0]; # is the name of a Perl package. |
399
|
|
|
|
|
|
|
return eval '%' . $class_name . '::'; |
400
|
|
|
|
|
|
|
}; |
401
|
|
|
|
|
|
|
# Do the main work of processing a class. |
402
|
|
|
|
|
|
|
$process_class = sub { # Parse its specification, generate a |
403
|
|
|
|
|
|
|
my $class_spec = $_[0]; # form, and evaluate that form. |
404
|
|
|
|
|
|
|
my (@warnings, $errors); |
405
|
|
|
|
|
|
|
&$croak_if_duplicate_names($class_spec); |
406
|
|
|
|
|
|
|
for my $var ( grep defined $class_options{$_}, qw(instance_var class_var) ) { |
407
|
|
|
|
|
|
|
croak qq|$cm: Value of $var option must be an identifier (without a "\$")| |
408
|
|
|
|
|
|
|
unless $class_options{$var} =~ /^[A-Za-z_]\w*$/; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
&$parse_class_specification(UNIVERSAL::isa($class_spec, 'ARRAY') ? @$class_spec : %$class_spec); |
411
|
|
|
|
|
|
|
Class::Generate::Member_Names::set_element_regexps(); |
412
|
|
|
|
|
|
|
$class->add_class_vars($class_vars->values) if $class_vars; |
413
|
|
|
|
|
|
|
$class->add_use_packages($use_packages->values) if $use_packages; |
414
|
|
|
|
|
|
|
$class->warnings($class_options{warnings}) if $class_options{warnings}; |
415
|
|
|
|
|
|
|
$class->check_params($class_options{check_params}) if $class_options{check_params}; |
416
|
|
|
|
|
|
|
$class->excluded_methods_regexp(join '|', map "(?:$_)", $excluded_methods->values) |
417
|
|
|
|
|
|
|
if $excluded_methods; |
418
|
|
|
|
|
|
|
if ( warnings::enabled() && $class_options{check_code} ) { |
419
|
|
|
|
|
|
|
Class::Generate::Code_Checker::check_user_defined_code($class, $cm, \@warnings, \$errors); |
420
|
|
|
|
|
|
|
for my $warning ( @warnings ) { |
421
|
|
|
|
|
|
|
warnings::warn($warning); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
warnings::warn($errors) if $errors; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my $form = $class->form; |
427
|
|
|
|
|
|
|
if ( $class_options{save} ) { |
428
|
|
|
|
|
|
|
my ($class_file, $ob, $cb); |
429
|
|
|
|
|
|
|
if ( $class_options{save} =~ /\.p[ml]$/ ) { |
430
|
|
|
|
|
|
|
$class_file = $class_options{save}; |
431
|
|
|
|
|
|
|
open CLASS_FILE, ">>$class_file" or croak qq|$cm: Cannot append to "$class_file": $!|; |
432
|
|
|
|
|
|
|
$ob = "{\n"; # The form is enclosed in braces to prevent |
433
|
|
|
|
|
|
|
$cb = "}\n"; # renaming duplicate "my" variables. |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
else { |
436
|
|
|
|
|
|
|
$class_file = $class_name . '.pm'; |
437
|
|
|
|
|
|
|
$class_file =~ s|::|/|g; |
438
|
|
|
|
|
|
|
open CLASS_FILE, ">$class_file" or croak qq|$cm: Cannot save to "$class_file": $!|; |
439
|
|
|
|
|
|
|
$ob = $cb = ''; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
$form =~ s/^(my [%@\$]\w+) = ([%@]\{)?\$$initial_value_form\[\d+\]\}?;/$1;/mgo; |
442
|
|
|
|
|
|
|
print CLASS_FILE $ob, $form, $cb, "\n1;\n"; |
443
|
|
|
|
|
|
|
close CLASS_FILE; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
croak "$cm: Cannot continue after errors" if $errors; |
446
|
|
|
|
|
|
|
{ |
447
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { }; # Warnings have been reported during |
448
|
13
|
100
|
100
|
13
|
|
87
|
eval $form; # user-defined code analysis. |
|
13
|
100
|
100
|
13
|
|
35
|
|
|
13
|
100
|
33
|
13
|
|
350
|
|
|
13
|
100
|
33
|
13
|
|
77
|
|
|
13
|
100
|
33
|
12
|
|
30
|
|
|
13
|
100
|
33
|
12
|
|
792
|
|
|
13
|
100
|
0
|
12
|
|
71
|
|
|
13
|
100
|
0
|
12
|
|
31
|
|
|
13
|
100
|
0
|
12
|
|
496
|
|
|
13
|
100
|
0
|
10
|
|
84
|
|
|
13
|
50
|
|
9
|
|
122
|
|
|
13
|
100
|
|
9
|
|
10470
|
|
|
12
|
100
|
|
9
|
|
73
|
|
|
12
|
100
|
|
9
|
|
24
|
|
|
12
|
100
|
|
8
|
|
1980
|
|
|
12
|
100
|
|
8
|
|
63
|
|
|
12
|
100
|
|
8
|
|
23
|
|
|
12
|
100
|
|
8
|
|
698
|
|
|
12
|
100
|
|
8
|
|
70
|
|
|
12
|
100
|
|
7
|
|
23
|
|
|
12
|
100
|
|
1
|
|
435
|
|
|
12
|
50
|
|
10
|
|
77
|
|
|
12
|
50
|
|
1
|
|
29
|
|
|
12
|
50
|
|
12
|
|
8234
|
|
|
12
|
100
|
|
8
|
|
76
|
|
|
12
|
100
|
|
1
|
|
25
|
|
|
12
|
100
|
|
0
|
|
1365
|
|
|
10
|
100
|
|
6
|
|
56
|
|
|
10
|
100
|
|
11
|
|
18
|
|
|
10
|
100
|
|
10
|
|
907
|
|
|
9
|
100
|
|
10
|
|
47
|
|
|
9
|
100
|
|
3
|
|
18
|
|
|
9
|
50
|
|
1
|
|
377
|
|
|
9
|
100
|
|
2
|
|
52
|
|
|
9
|
50
|
|
0
|
|
15
|
|
|
9
|
50
|
|
10
|
|
8075
|
|
|
8
|
50
|
|
5
|
|
49
|
|
|
8
|
50
|
|
1
|
|
18
|
|
|
8
|
100
|
|
2
|
|
209
|
|
|
8
|
50
|
|
4
|
|
37
|
|
|
8
|
0
|
|
2
|
|
17
|
|
|
8
|
0
|
|
4
|
|
1058
|
|
|
8
|
50
|
|
3
|
|
52
|
|
|
8
|
100
|
|
3
|
|
18
|
|
|
8
|
50
|
|
52
|
|
288
|
|
|
8
|
0
|
|
51
|
|
41
|
|
|
8
|
0
|
|
25
|
|
12
|
|
|
8
|
0
|
|
23
|
|
6009
|
|
|
8
|
50
|
|
8
|
|
56
|
|
|
8
|
100
|
|
22
|
|
17
|
|
|
8
|
100
|
|
8
|
|
692
|
|
|
8
|
100
|
|
6
|
|
50
|
|
|
8
|
100
|
|
3
|
|
15
|
|
|
8
|
100
|
|
4
|
|
364
|
|
|
8
|
100
|
|
2
|
|
38
|
|
|
8
|
100
|
|
2
|
|
17
|
|
|
8
|
100
|
|
0
|
|
438
|
|
|
7
|
100
|
|
9
|
|
35
|
|
|
7
|
100
|
|
2
|
|
12
|
|
|
7
|
100
|
|
11
|
|
3003
|
|
|
1
|
100
|
|
4
|
|
2
|
|
|
1
|
100
|
|
0
|
|
6
|
|
|
0
|
50
|
|
4
|
|
0
|
|
|
10
|
100
|
|
0
|
|
16
|
|
|
10
|
100
|
|
1
|
|
11
|
|
|
10
|
100
|
|
0
|
|
11
|
|
|
10
|
100
|
|
6
|
|
20
|
|
|
10
|
100
|
|
3
|
|
18
|
|
|
3
|
100
|
|
3
|
|
22
|
|
|
11
|
100
|
|
0
|
|
13
|
|
|
3
|
100
|
|
0
|
|
13
|
|
|
11
|
50
|
|
0
|
|
32
|
|
|
3
|
100
|
|
0
|
|
39
|
|
|
12
|
50
|
|
|
|
40
|
|
|
4
|
100
|
|
|
|
10
|
|
|
2
|
100
|
|
|
|
3
|
|
|
4
|
0
|
|
|
|
61
|
|
|
17
|
0
|
|
|
|
66
|
|
|
21
|
0
|
|
|
|
63
|
|
|
21
|
50
|
|
|
|
27
|
|
|
21
|
50
|
|
|
|
60
|
|
|
11
|
100
|
|
|
|
22
|
|
|
16
|
100
|
|
|
|
28
|
|
|
16
|
50
|
|
|
|
25
|
|
|
16
|
100
|
|
|
|
159
|
|
|
10
|
50
|
|
|
|
190
|
|
|
11
|
100
|
|
|
|
105
|
|
|
4
|
50
|
|
|
|
22
|
|
|
2
|
50
|
|
|
|
23
|
|
|
2
|
50
|
|
|
|
6
|
|
|
2
|
100
|
|
|
|
7
|
|
|
1
|
0
|
|
|
|
3
|
|
|
1
|
100
|
|
|
|
17
|
|
|
1
|
100
|
|
|
|
2
|
|
|
1
|
50
|
|
|
|
3
|
|
|
6
|
100
|
|
|
|
9
|
|
|
6
|
50
|
|
|
|
7
|
|
|
6
|
50
|
|
|
|
8
|
|
|
6
|
0
|
|
|
|
11
|
|
|
6
|
0
|
|
|
|
10
|
|
|
5
|
50
|
|
|
|
18
|
|
|
5
|
0
|
|
|
|
9
|
|
|
14
|
0
|
|
|
|
81
|
|
|
12
|
0
|
|
|
|
16
|
|
|
12
|
50
|
|
|
|
15
|
|
|
12
|
50
|
|
|
|
50
|
|
|
12
|
50
|
|
|
|
29
|
|
|
13
|
100
|
|
|
|
40
|
|
|
13
|
50
|
|
|
|
107
|
|
|
17
|
100
|
|
|
|
36
|
|
|
15
|
50
|
|
|
|
18
|
|
|
25
|
100
|
|
|
|
44
|
|
|
15
|
50
|
|
|
|
27
|
|
|
14
|
50
|
|
|
|
47
|
|
|
14
|
50
|
|
|
|
17
|
|
|
15
|
0
|
|
|
|
23
|
|
|
23
|
50
|
|
|
|
69
|
|
|
23
|
0
|
|
|
|
59
|
|
|
27
|
50
|
|
|
|
64
|
|
|
27
|
0
|
|
|
|
120
|
|
|
17
|
100
|
|
|
|
81
|
|
|
15
|
50
|
|
|
|
93
|
|
|
13
|
100
|
|
|
|
32
|
|
|
7
|
50
|
|
|
|
14
|
|
|
3
|
50
|
|
|
|
9
|
|
|
4
|
0
|
|
|
|
33
|
|
|
7
|
0
|
|
|
|
11
|
|
|
7
|
0
|
|
|
|
14
|
|
|
5
|
0
|
|
|
|
7
|
|
|
5
|
0
|
|
|
|
23
|
|
|
3
|
0
|
|
|
|
8
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
30
|
|
|
5
|
|
|
|
|
14
|
|
|
5
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
16
|
|
|
5
|
|
|
|
|
51
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
72
|
|
|
5
|
|
|
|
|
23
|
|
|
5
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
22
|
|
|
5
|
|
|
|
|
23
|
|
|
4
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
14
|
|
|
11
|
|
|
|
|
53
|
|
|
11
|
|
|
|
|
26
|
|
|
11
|
|
|
|
|
34
|
|
|
6
|
|
|
|
|
25
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
5
|
|
|
|
|
83
|
|
|
6
|
|
|
|
|
51
|
|
|
5
|
|
|
|
|
26
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
32
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
28
|
|
|
2
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
265
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
40
|
|
|
2
|
|
|
|
|
117
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
186
|
|
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
17
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
240
|
|
|
3
|
|
|
|
|
14
|
|
|
3
|
|
|
|
|
26
|
|
|
0
|
|
|
|
|
0
|
|
|
49
|
|
|
|
|
1261
|
|
|
49
|
|
|
|
|
126
|
|
|
49
|
|
|
|
|
101
|
|
|
52
|
|
|
|
|
327
|
|
|
51
|
|
|
|
|
157
|
|
|
51
|
|
|
|
|
198
|
|
|
46
|
|
|
|
|
227
|
|
|
36
|
|
|
|
|
98
|
|
|
31
|
|
|
|
|
65
|
|
|
29
|
|
|
|
|
67
|
|
|
66
|
|
|
|
|
1231
|
|
|
75
|
|
|
|
|
171
|
|
|
62
|
|
|
|
|
258
|
|
|
65
|
|
|
|
|
202
|
|
|
70
|
|
|
|
|
159
|
|
|
65
|
|
|
|
|
136
|
|
|
65
|
|
|
|
|
410
|
|
|
52
|
|
|
|
|
483
|
|
|
41
|
|
|
|
|
243
|
|
|
29
|
|
|
|
|
92
|
|
|
34
|
|
|
|
|
253
|
|
|
46
|
|
|
|
|
675
|
|
|
46
|
|
|
|
|
147
|
|
|
25
|
|
|
|
|
156
|
|
|
31
|
|
|
|
|
655
|
|
|
29
|
|
|
|
|
103
|
|
|
18
|
|
|
|
|
67
|
|
|
16
|
|
|
|
|
73
|
|
|
16
|
|
|
|
|
51
|
|
|
9
|
|
|
|
|
40
|
|
|
13
|
|
|
|
|
68
|
|
|
13
|
|
|
|
|
80
|
|
|
30
|
|
|
|
|
865
|
|
|
30
|
|
|
|
|
241
|
|
|
23
|
|
|
|
|
67
|
|
|
29
|
|
|
|
|
90
|
|
|
26
|
|
|
|
|
70
|
|
|
24
|
|
|
|
|
81
|
|
|
25
|
|
|
|
|
65
|
|
|
27
|
|
|
|
|
557
|
|
|
19
|
|
|
|
|
194
|
|
|
22
|
|
|
|
|
114
|
|
|
19
|
|
|
|
|
54
|
|
|
18
|
|
|
|
|
60
|
|
|
8
|
|
|
|
|
30
|
|
|
12
|
|
|
|
|
32
|
|
|
14
|
|
|
|
|
162
|
|
|
15
|
|
|
|
|
116
|
|
|
9
|
|
|
|
|
20
|
|
|
8
|
|
|
|
|
21
|
|
|
14
|
|
|
|
|
80
|
|
|
14
|
|
|
|
|
45
|
|
|
9
|
|
|
|
|
49
|
|
|
9
|
|
|
|
|
329
|
|
|
12
|
|
|
|
|
220
|
|
|
8
|
|
|
|
|
24
|
|
|
7
|
|
|
|
|
31
|
|
|
5
|
|
|
|
|
19
|
|
|
3
|
|
|
|
|
23
|
|
|
3
|
|
|
|
|
14
|
|
|
5
|
|
|
|
|
112
|
|
|
5
|
|
|
|
|
265
|
|
|
4
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
6
|
|
|
15
|
|
|
|
|
504
|
|
|
16
|
|
|
|
|
110
|
|
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
36
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
22
|
|
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
20
|
|
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
19
|
|
|
0
|
|
|
|
|
0
|
|
|
8
|
|
|
|
|
158
|
|
|
8
|
|
|
|
|
23
|
|
|
3
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
7
|
|
|
5
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
37
|
|
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
18
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
15
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
30
|
|
|
2
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
9
|
|
|
|
|
197
|
|
|
9
|
|
|
|
|
30
|
|
|
4
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
17
|
|
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
10
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
42
|
|
|
2
|
|
|
|
|
5
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
11
|
|
|
|
|
263
|
|
|
11
|
|
|
|
|
30
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
10
|
|
|
|
|
24
|
|
|
9
|
|
|
|
|
52
|
|
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
21
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
63
|
|
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
16
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
63
|
|
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
26
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
28
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
6
|
|
|
|
|
148
|
|
|
6
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
25
|
|
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
22
|
|
|
3
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
15
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
2
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
58
|
|
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
7
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
if ( $@ ) { |
450
|
|
|
|
|
|
|
my @lines = split("\n", $form); |
451
|
|
|
|
|
|
|
my ($l) = ($@ =~ /(\d+)\.$/); |
452
|
|
|
|
|
|
|
$@ =~ s/\(eval \d+\) //; |
453
|
|
|
|
|
|
|
croak "$cm: Evaluation failed (problem in ", __PACKAGE__, "?)\n", |
454
|
|
|
|
|
|
|
$@, "\n", join("\n", @lines[$l-1 .. $l+1]), "\n"; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
Class::Generate::Class_Holder::store($class); |
458
|
|
|
|
|
|
|
}; |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
$constructor_parameter_passing_style = sub { # Establish the parameter-passing style |
461
|
|
|
|
|
|
|
my ($style, # for a class' constructor, meanwhile |
462
|
|
|
|
|
|
|
@values, # checking for mismatches w.r.t. the |
463
|
|
|
|
|
|
|
$parent_with_constructor, # class' superclass. Return an |
464
|
|
|
|
|
|
|
$parent_constructor_package_name); # appropriate style. |
465
|
|
|
|
|
|
|
if ( defined $class->parents ) { |
466
|
|
|
|
|
|
|
$parent_with_constructor = Class::Generate::Support::class_containing_method('new', $class); |
467
|
|
|
|
|
|
|
$parent_constructor_package_name = (ref $parent_with_constructor ? $parent_with_constructor->name : $parent_with_constructor); |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
(($style, @values) = $param_style_spec->values)[0] eq 'key_value' and do { |
470
|
|
|
|
|
|
|
if ( defined $parent_with_constructor && ref $parent_with_constructor && index(ref $parent_with_constructor, $containing_package) == 0 ) { |
471
|
|
|
|
|
|
|
my $invoked_constructor_style = $parent_with_constructor->constructor->style; |
472
|
|
|
|
|
|
|
unless ( $invoked_constructor_style->isa($containing_package . 'Key_Value') || |
473
|
|
|
|
|
|
|
$invoked_constructor_style->isa($containing_package . 'Own') ) { |
474
|
|
|
|
|
|
|
warnings::warn(qq{$cm: Probable mismatch calling constructor in superclass "$parent_constructor_package_name"}) if warnings::enabled(); |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
return Class::Generate::Key_Value->new('params', $class->public_member_names); |
478
|
|
|
|
|
|
|
}; |
479
|
|
|
|
|
|
|
$style eq 'positional' and do { |
480
|
|
|
|
|
|
|
&$check_for_invalid_parameter_names(@values); |
481
|
|
|
|
|
|
|
my @member_names = $class->public_member_names; |
482
|
|
|
|
|
|
|
croak "$cm: Missing/extra members in style" unless $#values == $#member_names; |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
return Class::Generate::Positional->new(@values); |
485
|
|
|
|
|
|
|
}; |
486
|
|
|
|
|
|
|
$style eq 'mix' and do { |
487
|
|
|
|
|
|
|
&$check_for_invalid_parameter_names(@values); |
488
|
|
|
|
|
|
|
my @member_names = $class->public_member_names; |
489
|
|
|
|
|
|
|
croak "$cm: Extra parameters in style specifier" unless $#values <= $#member_names; |
490
|
|
|
|
|
|
|
my %kv_members = map(($_ => 1), @member_names); |
491
|
|
|
|
|
|
|
delete @kv_members{@values}; |
492
|
|
|
|
|
|
|
return Class::Generate::Mix->new('params', [@values], keys %kv_members); |
493
|
|
|
|
|
|
|
}; |
494
|
|
|
|
|
|
|
$style eq 'own' and do { |
495
|
|
|
|
|
|
|
for ( my $i = 0; $i <= $#values; $i++ ) { |
496
|
|
|
|
|
|
|
&$store_initial_value_reference(\$values[$i], $parent_constructor_package_name . '::new') if ref $values[$i]; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
return Class::Generate::Own->new([@values]); |
499
|
|
|
|
|
|
|
}; |
500
|
|
|
|
|
|
|
croak qq|$cm: Invalid parameter passing style "$style"|; |
501
|
|
|
|
|
|
|
}; |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
$check_for_invalid_parameter_names = sub { |
504
|
|
|
|
|
|
|
my @param_names = @_; |
505
|
|
|
|
|
|
|
my $i = 0; |
506
|
|
|
|
|
|
|
for my $param ( @param_names ) { |
507
|
|
|
|
|
|
|
croak qq|$cm: Error in new => { style => '... $param' }: $param is not a member| |
508
|
|
|
|
|
|
|
if ! defined $class->members($param); |
509
|
|
|
|
|
|
|
croak qq|$cm: Error in new => { style => '... $param' }: $param is not a public member| |
510
|
|
|
|
|
|
|
if $class->private($param) || $class->protected($param); |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
my %uses; |
513
|
|
|
|
|
|
|
for my $param ( @param_names ) { |
514
|
|
|
|
|
|
|
$uses{$param}++; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
%uses = map(($uses{$_} > 1 ? ($_ => $uses{$_}) : ()), keys %uses); |
517
|
|
|
|
|
|
|
if ( %uses ) { |
518
|
|
|
|
|
|
|
croak "$cm: Error in new => { style => '...' }: ", join('; ', map qq|Name "$_" used $uses{$_} times|, keys %uses); |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
}; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
$croak_if_duplicate_names = sub { |
523
|
|
|
|
|
|
|
my $class_spec = $_[0]; |
524
|
|
|
|
|
|
|
my (@names, %uses); |
525
|
|
|
|
|
|
|
if ( UNIVERSAL::isa($class_spec, 'ARRAY') ) { |
526
|
|
|
|
|
|
|
for ( my $i = 0; $i <= $#$class_spec; $i += 2 ) { |
527
|
|
|
|
|
|
|
push @names, $$class_spec[$i]; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
else { |
531
|
|
|
|
|
|
|
@names = keys %$class_spec; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
for ( @names ) { |
534
|
|
|
|
|
|
|
$uses{substr($_, 0, 1) eq '&' ? substr($_, 1) : $_}++; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
%uses = map(($uses{$_} > 1 ? ($_ => $uses{$_}) : ()), keys %uses); |
537
|
|
|
|
|
|
|
if ( %uses ) { |
538
|
|
|
|
|
|
|
croak "$cm: ", join('; ', map qq|Name "$_" used $uses{$_} times|, keys %uses); |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
}; |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
$invalid_spec_message = sub { |
543
|
|
|
|
|
|
|
return sprintf qq|$cm: Invalid specification of %s "%s" ($sh_needed with "%s" key)|, @_; |
544
|
|
|
|
|
|
|
}; |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
package Class::Generate::Class_Holder; # This package encapsulates functions |
547
|
|
|
|
|
|
|
$Class::Generate::Class_Holder::VERSION = '1.17'; |
548
|
15
|
|
|
15
|
|
349
|
use strict; # related to storing and retrieving |
|
15
|
|
|
|
|
43
|
|
|
15
|
|
|
|
|
19014
|
|
549
|
|
|
|
|
|
|
# information on classes. It lets classes |
550
|
|
|
|
|
|
|
# saved in files be reused transparently. |
551
|
|
|
|
|
|
|
my %classes; |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
sub store($) { # Given a class, store it so it's |
554
|
77
|
|
|
65
|
|
190
|
my $class = $_[0]; # accessible in future invocations of |
555
|
77
|
|
|
|
|
284
|
$classes{$class->name} = $class; # class() and subclass(). |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
# Given a class name, try to return an instance of Class::Generate::Class |
559
|
|
|
|
|
|
|
# that models the class. The instance comes from one of 3 places. We |
560
|
|
|
|
|
|
|
# first try to get it from wherever store() puts it. If that fails, |
561
|
|
|
|
|
|
|
# we check to see if the variable %::_cginfo exists (see |
562
|
|
|
|
|
|
|
# form(), below); if it does, we use the information it contains to |
563
|
|
|
|
|
|
|
# create an instance of Class::Generate::Class. If %::_cginfo |
564
|
|
|
|
|
|
|
# doesn't exist, the package wasn't created by Class::Generate. We try |
565
|
|
|
|
|
|
|
# to infer some characteristics of the class. |
566
|
|
|
|
|
|
|
sub get($;$) { |
567
|
47
|
|
|
34
|
|
162
|
my ($class_name, $default_type) = @_; |
568
|
47
|
100
|
|
|
|
215
|
return $classes{$class_name} if exists $classes{$class_name}; |
569
|
|
|
|
|
|
|
|
570
|
15
|
100
|
|
|
|
345
|
return undef if ! eval '%' . $class_name . '::'; # Package doesn't exist. |
571
|
|
|
|
|
|
|
|
572
|
13
|
|
|
|
|
422
|
my ($class, %info); |
573
|
10
|
100
|
|
|
|
163
|
if ( ! eval "exists \$" . $class_name . '::{_cginfo}' ) { # Package exists but is |
574
|
7
|
100
|
|
|
|
114
|
return undef if ! defined $default_type; # not a class generated |
575
|
7
|
100
|
|
|
|
70
|
if ( $default_type eq 'ARRAY' ) { # by Class::Generate. |
576
|
3
|
|
|
|
|
27
|
$class = new Class::Generate::Array_Class $class_name; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
else { |
579
|
2
|
|
|
|
|
8
|
$class = new Class::Generate::Hash_Class $class_name; |
580
|
|
|
|
|
|
|
} |
581
|
2
|
|
|
|
|
5
|
$class->constructor(new Class::Generate::Constructor); |
582
|
2
|
|
|
|
|
29
|
$class->constructor->style(new Class::Generate::Own); |
583
|
4
|
|
|
|
|
125
|
$classes{$class_name} = $class; |
584
|
6
|
|
|
|
|
182
|
return $class; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
5
|
|
|
|
|
31
|
eval '%info = %' . $class_name . '::_cginfo'; |
588
|
5
|
100
|
|
|
|
28
|
if ( $info{base} eq 'ARRAY' ) { |
589
|
3
|
|
|
|
|
20
|
$class = Class::Generate::Array_Class->new($class_name, last => $info{last}); |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
else { |
592
|
3
|
|
|
|
|
36
|
$class = Class::Generate::Hash_Class->new($class_name); |
593
|
|
|
|
|
|
|
} |
594
|
2
|
50
|
|
|
|
4
|
if ( exists $info{members} ) { # Add members ... |
595
|
2
|
|
|
|
|
18
|
while ( my ($name, $mem_info_ref) = each %{$info{members}} ) { |
|
2
|
|
|
|
|
16
|
|
596
|
2
|
|
|
|
|
21
|
my ($member, %mem_info); |
597
|
2
|
|
|
|
|
5
|
%mem_info = %$mem_info_ref; |
598
|
|
|
|
|
|
|
DEFN: { |
599
|
2
|
0
|
|
|
|
19
|
$mem_info{type} eq "\$" and do { $member = Class::Generate::Scalar_Member->new($name); last DEFN }; |
|
2
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
11
|
|
600
|
1
|
0
|
|
|
|
6
|
$mem_info{type} eq '@' and do { $member = Class::Generate::Array_Member->new($name); last DEFN }; |
|
2
|
|
|
|
|
62
|
|
|
3
|
|
|
|
|
65
|
|
601
|
3
|
100
|
|
|
|
16
|
$mem_info{type} eq '%' and do { $member = Class::Generate::Hash_Member->new($name); last DEFN }; |
|
3
|
|
|
|
|
17
|
|
|
2
|
|
|
|
|
10
|
|
602
|
|
|
|
|
|
|
} |
603
|
2
|
50
|
|
|
|
6
|
$member->base($mem_info{base}) if exists $mem_info{base}; |
604
|
2
|
|
|
|
|
6
|
$class->members($name, $member); |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
} |
607
|
2
|
50
|
|
|
|
7
|
if ( exists $info{class_methods} ) { # Add methods... |
608
|
2
|
|
|
|
|
7
|
for my $name ( @{$info{class_methods}} ) { |
|
2
|
|
|
|
|
30
|
|
609
|
0
|
|
|
|
|
0
|
$class->user_defined_methods($name, Class::Generate::Class_Method->new($name)); |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
} |
612
|
0
|
50
|
|
|
|
0
|
if ( exists $info{instance_methods} ) { |
613
|
0
|
|
|
|
|
0
|
for my $name ( @{$info{instance_methods}} ) { |
|
0
|
|
|
|
|
0
|
|
614
|
0
|
|
|
|
|
0
|
$class->user_defined_methods($name, Class::Generate::Method->new($name)); |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
} |
617
|
4
|
50
|
|
|
|
84
|
if ( exists $info{protected} ) { # Set access ... |
618
|
4
|
|
|
|
|
33
|
for my $protected_member ( @{$info{protected}} ) { |
|
4
|
|
|
|
|
37
|
|
619
|
3
|
|
|
|
|
87
|
$class->protected($protected_member, 1); |
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
} |
622
|
3
|
50
|
|
|
|
17
|
if ( exists $info{private} ) { |
623
|
3
|
|
|
|
|
19
|
for my $private_member ( @{$info{private}} ) { |
|
3
|
|
|
|
|
16
|
|
624
|
3
|
|
|
|
|
11
|
$class->private($private_member, 1); |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
} |
627
|
3
|
100
|
|
|
|
19
|
$class->excluded_methods_regexp($info{emr}) if exists $info{emr}; |
628
|
3
|
|
|
|
|
14
|
$class->constructor(new Class::Generate::Constructor); |
629
|
|
|
|
|
|
|
CONSTRUCTOR_STYLE: { |
630
|
3
|
50
|
|
|
|
10
|
exists $info{kv_style} and do { |
|
3
|
|
|
|
|
10
|
|
631
|
3
|
|
|
|
|
47
|
$class->constructor->style(new Class::Generate::Key_Value 'params', @{$info{kv_style}}); |
|
3
|
|
|
|
|
20
|
|
632
|
3
|
|
|
|
|
16
|
last CONSTRUCTOR_STYLE; |
633
|
|
|
|
|
|
|
}; |
634
|
2
|
50
|
|
|
|
5
|
exists $info{pos_style} and do { |
635
|
2
|
|
|
|
|
11
|
$class->constructor->style(new Class::Generate::Positional(@{$info{pos_style}})); |
|
2
|
|
|
|
|
6
|
|
636
|
8
|
|
|
|
|
359
|
last CONSTRUCTOR_STYLE; |
637
|
|
|
|
|
|
|
}; |
638
|
8
|
50
|
|
|
|
52
|
exists $info{mix_style} and do { |
639
|
|
|
|
|
|
|
$class->constructor->style(new Class::Generate::Mix('params', |
640
|
1
|
|
|
|
|
10
|
[@{$info{mix_style}{keyed}}], |
641
|
4
|
|
|
|
|
88
|
@{$info{mix_style}{pos}})); |
|
4
|
|
|
|
|
14
|
|
642
|
3
|
|
|
|
|
17
|
last CONSTRUCTOR_STYLE; |
643
|
|
|
|
|
|
|
}; |
644
|
2
|
0
|
|
|
|
48
|
exists $info{own_style} and do { |
645
|
2
|
|
|
|
|
82
|
$class->constructor->style(new Class::Generate::Own(@{$info{own_style}})); |
|
1
|
|
|
|
|
6
|
|
646
|
1
|
|
|
|
|
3
|
last CONSTRUCTOR_STYLE; |
647
|
|
|
|
|
|
|
}; |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
1
|
|
|
|
|
7
|
$classes{$class_name} = $class; |
651
|
3
|
|
|
|
|
124
|
return $class; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
sub remove($) { |
655
|
3
|
|
|
8
|
|
27
|
delete $classes{$_[0]}; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
sub form($) { |
659
|
64
|
|
|
65
|
|
151
|
my $class = $_[0]; |
660
|
64
|
|
|
|
|
159
|
my $form = qq|use vars qw(\%_cginfo);\n| . '%_cginfo = ('; |
661
|
67
|
100
|
|
|
|
594
|
if ( $class->isa('Class::Generate::Array_Class') ) { |
662
|
25
|
|
|
|
|
91
|
$form .= q|base => 'ARRAY', last => | . $class->last; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
else { |
665
|
48
|
|
|
|
|
149
|
$form .= q|base => 'HASH'|; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
64
|
100
|
|
|
|
181
|
if ( my @members = $class->members_values ) { |
669
|
55
|
|
|
|
|
221
|
$form .= ', members => { ' . join(', ', map(member($_), @members)) . ' }'; |
670
|
|
|
|
|
|
|
} |
671
|
64
|
|
|
|
|
159
|
my (@class_methods, @instance_methods); |
672
|
64
|
|
|
|
|
163
|
for my $m ( $class->user_defined_methods_values ) { |
673
|
31
|
100
|
|
|
|
105
|
if ( $m->isa('Class::Generate::Class_Method') ) { |
674
|
6
|
|
|
|
|
15
|
push @class_methods, $m->name; |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
else { |
677
|
30
|
|
|
|
|
62
|
push @instance_methods, $m->name; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
} |
680
|
65
|
|
|
|
|
236
|
$form .= comma_prefixed_list_of_values('class_methods', @class_methods); |
681
|
64
|
|
|
|
|
162
|
$form .= comma_prefixed_list_of_values('instance_methods', @instance_methods); |
682
|
64
|
|
|
|
|
122
|
$form .= comma_prefixed_list_of_values('protected', do { my %p = $class->protected; keys %p }); |
|
64
|
|
|
|
|
167
|
|
|
64
|
|
|
|
|
206
|
|
683
|
64
|
|
|
|
|
288
|
$form .= comma_prefixed_list_of_values('private', do { my %p = $class->private; keys %p }); |
|
64
|
|
|
|
|
193
|
|
|
64
|
|
|
|
|
193
|
|
684
|
|
|
|
|
|
|
|
685
|
62
|
100
|
|
|
|
165
|
if ( my $emr = $class->excluded_methods_regexp ) { |
686
|
8
|
|
|
|
|
52
|
$emr =~ s/\'/\\\'/g; |
687
|
8
|
|
|
|
|
44
|
$form .= ", emr => '$emr'"; |
688
|
|
|
|
|
|
|
} |
689
|
62
|
100
|
|
|
|
181
|
if ( (my $constructor = $class->constructor) ) { |
690
|
61
|
|
|
|
|
152
|
my $style = $constructor->style; |
691
|
|
|
|
|
|
|
STYLE: { |
692
|
61
|
100
|
|
|
|
114
|
$style->isa('Class::Generate::Key_Value') and do { |
|
61
|
|
|
|
|
366
|
|
693
|
41
|
|
|
|
|
132
|
my @kpn = $style->keyed_param_names; |
694
|
41
|
100
|
|
|
|
116
|
if ( @kpn ) { |
695
|
33
|
|
|
|
|
69
|
$form .= comma_prefixed_list_of_values('kv_style', $style->keyed_param_names); |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
else { |
698
|
8
|
|
|
|
|
17
|
$form .= ', kv_style => []'; |
699
|
|
|
|
|
|
|
} |
700
|
41
|
|
|
|
|
120
|
last STYLE; |
701
|
|
|
|
|
|
|
}; |
702
|
22
|
100
|
|
|
|
243
|
$style->isa('Class::Generate::Positional') and do { |
703
|
12
|
|
|
|
|
28
|
my @members = sort { $style->order($a) <=> $style->order($b) } do { my %m = $style->order; keys %m }; |
|
7
|
|
|
|
|
29
|
|
|
10
|
|
|
|
|
39
|
|
|
11
|
|
|
|
|
108
|
|
704
|
11
|
100
|
|
|
|
46
|
if ( @members ) { |
705
|
10
|
|
|
|
|
38
|
$form .= comma_prefixed_list_of_values('pos_style', @members); |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
else { |
708
|
1
|
|
|
|
|
2
|
$form .= ', pos_style => []'; |
709
|
|
|
|
|
|
|
} |
710
|
13
|
|
|
|
|
247
|
last STYLE; |
711
|
|
|
|
|
|
|
}; |
712
|
13
|
100
|
|
|
|
68
|
$style->isa('Class::Generate::Mix') and do { |
713
|
8
|
|
|
|
|
48
|
my @keyed_members = $style->keyed_param_names; |
714
|
5
|
|
|
|
|
12
|
my @pos_members = sort { $style->order($a) <=> $style->order($b) } do { my %m = $style->order; keys %m }; |
|
2
|
|
|
|
|
75
|
|
|
6
|
|
|
|
|
34
|
|
|
6
|
|
|
|
|
31
|
|
715
|
6
|
100
|
100
|
|
|
46
|
if ( @keyed_members || @pos_members ) { |
716
|
6
|
|
|
|
|
87
|
my $km_form = list_of_values('keyed', @keyed_members); |
717
|
5
|
|
|
|
|
20
|
my $pm_form = list_of_values('pos', @pos_members); |
718
|
5
|
|
|
|
|
66
|
$form .= ', mix_style => {' . join(', ', grep(length > 0, ($km_form, $pm_form))) . '}'; |
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
else { |
721
|
2
|
|
|
|
|
8
|
$form .= ', mix_style => {}'; |
722
|
|
|
|
|
|
|
} |
723
|
7
|
|
|
|
|
93
|
last STYLE; |
724
|
|
|
|
|
|
|
}; |
725
|
6
|
100
|
|
|
|
30
|
$style->isa('Class::Generate::Own') and do { |
726
|
6
|
|
|
|
|
26
|
my @super_values = $style->super_values; |
727
|
5
|
100
|
|
|
|
14
|
if ( @super_values ) { |
728
|
4
|
|
|
|
|
77
|
for my $sv ( @super_values) { |
729
|
6
|
|
|
|
|
24
|
$sv =~ s/\'/\\\'/g; |
730
|
|
|
|
|
|
|
} |
731
|
4
|
|
|
|
|
16
|
$form .= comma_prefixed_list_of_values('own_style', @super_values); |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
else { |
734
|
2
|
|
|
|
|
7
|
$form .= ', own_style => []'; |
735
|
|
|
|
|
|
|
} |
736
|
5
|
|
|
|
|
16
|
last STYLE; |
737
|
|
|
|
|
|
|
}; |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
} |
740
|
61
|
|
|
|
|
130
|
$form .= ');' . "\n"; |
741
|
61
|
|
|
|
|
187
|
return $form; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
sub member($) { |
745
|
133
|
|
|
136
|
|
189
|
my $member = $_[0]; |
746
|
133
|
|
|
|
|
162
|
my $base; |
747
|
133
|
|
|
|
|
209
|
my $form = $member->name . ' => {'; |
748
|
133
|
100
|
|
|
|
653
|
$form .= " type => '" . ($member->isa('Class::Generate::Scalar_Member') ? "\$" : |
|
|
100
|
|
|
|
|
|
749
|
|
|
|
|
|
|
$member->isa('Class::Generate::Array_Member') ? '@' : '%') . "'"; |
750
|
134
|
100
|
|
|
|
309
|
if ( defined ($base = $member->base) ) { |
751
|
17
|
|
|
|
|
34
|
$form .= ", base => '$base'"; |
752
|
|
|
|
|
|
|
} |
753
|
133
|
|
|
|
|
502
|
return $form . '}'; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
sub list_of_values($@) { |
757
|
76
|
|
|
78
|
|
239
|
my ($key, @list) = @_; |
758
|
76
|
100
|
|
|
|
183
|
return '' if ! @list; |
759
|
75
|
|
|
|
|
583
|
return "$key => [" . join(', ', map("'$_'", @list)) . ']'; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
sub comma_prefixed_list_of_values($@) { |
763
|
289
|
100
|
|
291
|
|
848
|
return $#_ > 0 ? ', ' . list_of_values($_[0], @_[1..$#_]) : ''; |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
package Class::Generate::Member_Names; # This package encapsulates functions |
767
|
|
|
|
|
|
|
$Class::Generate::Member_Names::VERSION = '1.17'; |
768
|
15
|
|
|
15
|
|
117
|
use strict; # to handle name substitution in |
|
15
|
|
|
|
|
38
|
|
|
15
|
|
|
|
|
21471
|
|
769
|
|
|
|
|
|
|
# user-defined code. |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
my ($member_regexp, # Regexp of accessible members. |
772
|
|
|
|
|
|
|
$accessor_regexp, # Regexp of accessible member accessors (x_size, etc.). |
773
|
|
|
|
|
|
|
$user_defined_methods_regexp, # Regexp of accessible user-defined instance methods. |
774
|
|
|
|
|
|
|
$nonpublic_member_regexp, # (For class methods) Regexp of accessors for protected and private members. |
775
|
|
|
|
|
|
|
$private_class_methods_regexp); # (Ditto) Regexp of private class methods. |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
sub accessible_member_regexps($;$); |
778
|
|
|
|
|
|
|
sub accessible_members($;$); |
779
|
|
|
|
|
|
|
sub accessible_accessor_regexps($;$); |
780
|
|
|
|
|
|
|
sub accessible_user_defined_method_regexps($;$); |
781
|
|
|
|
|
|
|
sub class_of($$;$); |
782
|
|
|
|
|
|
|
sub member_index($$); |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
sub set_element_regexps() { # Establish the regexps for |
785
|
61
|
|
|
64
|
|
97
|
my @names; # name substitution. |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
# First for members... |
788
|
61
|
|
|
|
|
188
|
@names = accessible_member_regexps($class); |
789
|
61
|
100
|
|
|
|
188
|
if ( ! @names ) { |
790
|
2
|
|
|
|
|
5
|
undef $member_regexp; |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
else { |
793
|
59
|
|
|
|
|
289
|
$member_regexp = '(?:\b(?:my|local)\b[^=;()]+)?(' . join('|', sort { length $b <=> length $a } @names) . ')\b'; |
|
249
|
|
|
|
|
522
|
|
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# Next for accessors (e.g., x_size)... |
797
|
61
|
|
|
|
|
235
|
@names = accessible_accessor_regexps($class); |
798
|
61
|
100
|
|
|
|
210
|
if ( ! @names ) { |
799
|
2
|
|
|
|
|
4
|
undef $accessor_regexp; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
else { |
802
|
59
|
|
|
|
|
217
|
$accessor_regexp = '&(' . join('|', sort { length $b <=> length $a } @names) . ')\b(?:\s*\()?'; |
|
1148
|
|
|
|
|
1501
|
|
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
# Next for user-defined instance methods... |
806
|
61
|
|
|
|
|
238
|
@names = accessible_user_defined_method_regexps($class); |
807
|
61
|
100
|
|
|
|
170
|
if ( ! @names ) { |
808
|
47
|
|
|
|
|
94
|
undef $user_defined_methods_regexp; |
809
|
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
|
else { |
811
|
14
|
|
|
|
|
65
|
$user_defined_methods_regexp = '&(' . join('|', sort { length $b <=> length $a } @names) . ')\b(?:\s*\()?'; |
|
48
|
|
|
|
|
131
|
|
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# Next for protected and private members, and instance methods in class methods... |
815
|
62
|
100
|
|
|
|
268
|
if ( $class->class_methods ) { |
816
|
2
|
|
100
|
|
|
9
|
@names = (map($_->accessor_names($class, $_->name), grep $class->protected($_->name) || $class->private($_->name), $class->members_values), |
|
|
|
100
|
|
|
|
|
817
|
|
|
|
|
|
|
grep($class->private($_) || $class->protected($_), map($_->name, $class->instance_methods))); |
818
|
3
|
100
|
|
|
|
11
|
if ( ! @names ) { |
819
|
2
|
|
|
|
|
5
|
undef $nonpublic_member_regexp; |
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
else { |
822
|
2
|
|
|
|
|
9
|
$nonpublic_member_regexp = join('|', sort { length $b <=> length $a } @names); |
|
0
|
|
|
|
|
0
|
|
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
else { |
826
|
59
|
|
|
|
|
156
|
undef $nonpublic_member_regexp; |
827
|
|
|
|
|
|
|
} |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# Finally for private class methods invoked from class and instance methods. |
830
|
61
|
50
|
100
|
|
|
195
|
if ( my @private_class_methods = grep $_->isa('Class::Generate::Class_Method') && |
831
|
|
|
|
|
|
|
$class->private($_->name), $class->user_defined_methods ) { |
832
|
0
|
|
|
|
|
0
|
$private_class_methods_regexp = $class->name . |
833
|
|
|
|
|
|
|
'\s*->\s*(' . |
834
|
|
|
|
|
|
|
join('|', map $_->name, @private_class_methods) . |
835
|
|
|
|
|
|
|
')' . |
836
|
|
|
|
|
|
|
'(\s*\((?:\s*\))?)?'; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
else { |
839
|
61
|
|
|
|
|
127
|
undef $private_class_methods_regexp; |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
} |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
sub substituted($) { # Within a code fragment, replace |
844
|
46
|
|
|
47
|
|
75
|
my $code = $_[0]; # member names and accessors with the |
845
|
|
|
|
|
|
|
# appropriate forms. |
846
|
46
|
100
|
|
|
|
1083
|
$code =~ s/$member_regexp/member_invocation($1, $&)/eg if defined $member_regexp; |
|
91
|
|
|
|
|
224
|
|
847
|
46
|
100
|
|
|
|
701
|
$code =~ s/$accessor_regexp/accessor_invocation($1, $+, $&)/eg if defined $accessor_regexp; |
|
26
|
|
|
|
|
62
|
|
848
|
46
|
100
|
|
|
|
471
|
$code =~ s/$user_defined_methods_regexp/accessor_invocation($1, $1, $&)/eg if defined $user_defined_methods_regexp; |
|
7
|
|
|
|
|
25
|
|
849
|
46
|
50
|
|
|
|
118
|
$code =~ s/$private_class_methods_regexp/nonpublic_method_invocation("'" . $class->name . "'", $1, $2)/eg if defined $private_class_methods_regexp; |
|
0
|
|
|
|
|
0
|
|
850
|
46
|
|
|
|
|
179
|
return $code; |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
# Perform the actual substitution |
853
|
|
|
|
|
|
|
sub member_invocation($$) { # for member references. |
854
|
91
|
|
|
92
|
|
280
|
my ($member_reference, $match) = @_; |
855
|
91
|
|
|
|
|
150
|
my ($name, $type, $form, $index); |
856
|
91
|
50
|
|
|
|
1613
|
return $member_reference if $match =~ /\A(?:my|local)\b[^=;()]+$member_reference$/s; |
857
|
91
|
|
|
|
|
361
|
$member_reference =~ /^(\W+)(\w+)$/; |
858
|
91
|
|
|
|
|
193
|
$name = $2; |
859
|
91
|
100
|
|
|
|
198
|
return $member_reference if ! defined ($index = member_index($class, $name)); |
860
|
91
|
|
|
|
|
190
|
$type = $1; |
861
|
91
|
|
|
|
|
180
|
$form = $class->instance_var . '->' . $index; |
862
|
91
|
100
|
|
|
|
833
|
return $type eq '$' ? $form : $type . '{' . $form . '}'; |
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
# Perform the actual substitution for |
865
|
|
|
|
|
|
|
sub accessor_invocation($$$) { # accessor and user-defined method references. |
866
|
33
|
|
|
34
|
|
107
|
my ($accessor_name, $element_name, $match) = @_; |
867
|
33
|
|
|
|
|
65
|
my $prefix = $class->instance_var . '->'; |
868
|
33
|
|
|
|
|
68
|
my $c = class_of($element_name, $class); |
869
|
33
|
100
|
100
|
|
|
67
|
if ( ! ($c->protected($element_name) || $c->private($element_name)) ) { |
870
|
2
|
50
|
|
|
|
19
|
return $prefix . $accessor_name . (substr($match, -1) eq '(' ? '(' : ''); |
871
|
|
|
|
|
|
|
} |
872
|
31
|
100
|
100
|
|
|
58
|
if ( $c->private($element_name) || $c->name eq $class->name ) { |
873
|
25
|
100
|
|
|
|
89
|
return "$prefix\$$accessor_name(" if substr($match, -1) eq '('; |
874
|
18
|
|
|
|
|
91
|
return "$prefix\$$accessor_name()"; |
875
|
|
|
|
|
|
|
} |
876
|
6
|
|
|
|
|
24
|
my $form = "&{$prefix" . $class->protected_members_info_index . qq|->{'$accessor_name'}}(|; |
877
|
6
|
|
|
|
|
15
|
$form .= $class->instance_var . ','; |
878
|
6
|
100
|
|
|
|
47
|
return substr($match, -1) eq '(' ? $form : $form . ')'; |
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
sub substituted_in_class_method { |
882
|
2
|
|
|
4
|
|
4
|
my $method = $_[0]; |
883
|
2
|
|
|
|
|
3
|
my (@objs, $code, @private_class_methods); |
884
|
2
|
|
|
|
|
5
|
$code = $method->body; |
885
|
2
|
100
|
66
|
|
|
9
|
if ( defined $nonpublic_member_regexp && (@objs = $method->objects) ) { |
886
|
0
|
|
|
|
|
0
|
my $nonpublic_member_invocation_regexp = '(' . join('|', map(quotemeta($_), @objs)) . ')' . |
887
|
|
|
|
|
|
|
'\s*->\s*(' . $nonpublic_member_regexp . ')' . |
888
|
|
|
|
|
|
|
'(\s*\((?:\s*\))?)?'; |
889
|
0
|
|
|
|
|
0
|
$code =~ s/$nonpublic_member_invocation_regexp/nonpublic_method_invocation($1, $2, $3)/ge; |
|
0
|
|
|
|
|
0
|
|
890
|
|
|
|
|
|
|
} |
891
|
2
|
50
|
|
|
|
5
|
if ( defined $private_class_methods_regexp ) { |
892
|
0
|
|
|
|
|
0
|
$code =~ s/$private_class_methods_regexp/nonpublic_method_invocation("'" . $class->name . "'", $1, $2)/ge; |
|
0
|
|
|
|
|
0
|
|
893
|
|
|
|
|
|
|
} |
894
|
2
|
|
|
|
|
13
|
return $code; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
sub nonpublic_method_invocation { # Perform the actual |
898
|
0
|
|
|
0
|
|
0
|
my ($object, $nonpublic_member, $paren_matter) = @_; # substitution for |
899
|
0
|
|
|
|
|
0
|
my $form = '&$' . $nonpublic_member . '(' . $object; # nonpublic method and |
900
|
0
|
0
|
|
|
|
0
|
if ( defined $paren_matter ) { # member references. |
901
|
0
|
0
|
|
|
|
0
|
if ( index($paren_matter, ')') != -1 ) { |
902
|
0
|
|
|
|
|
0
|
$form .= ')'; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
else { |
905
|
0
|
|
|
|
|
0
|
$form .= ', '; |
906
|
|
|
|
|
|
|
} |
907
|
|
|
|
|
|
|
} |
908
|
|
|
|
|
|
|
else { |
909
|
0
|
|
|
|
|
0
|
$form .= ')'; |
910
|
|
|
|
|
|
|
} |
911
|
0
|
|
|
|
|
0
|
return $form; |
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
sub member_index($$) { |
915
|
103
|
|
|
104
|
|
188
|
my ($class, $member_name) = @_; |
916
|
103
|
100
|
|
|
|
204
|
return $class->index($member_name) if defined $class->members($member_name); |
917
|
12
|
|
|
|
|
24
|
for my $parent ( grep ref $_, $class->parents ) { |
918
|
12
|
|
|
|
|
25
|
my $index = member_index($parent, $member_name); |
919
|
12
|
50
|
|
|
|
42
|
return $index if defined $index; |
920
|
|
|
|
|
|
|
} |
921
|
0
|
|
|
|
|
0
|
return undef; |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
sub accessible_member_regexps($;$) { |
925
|
76
|
|
|
76
|
|
189
|
my ($class, $disallow_private_members) = @_; |
926
|
76
|
|
|
|
|
145
|
my @members; |
927
|
76
|
100
|
|
|
|
167
|
if ( $disallow_private_members ) { |
928
|
15
|
|
|
|
|
51
|
@members = grep ! $class->private($_->name), $class->members_values; |
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
else { |
931
|
61
|
|
|
|
|
237
|
@members = $class->members_values; |
932
|
|
|
|
|
|
|
} |
933
|
76
|
|
|
|
|
327
|
return (map($_->method_regexp($class), @members), |
934
|
|
|
|
|
|
|
map(accessible_member_regexps($_, 1), grep(ref $_, $class->parents))); |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
sub accessible_members($;$) { |
938
|
76
|
|
|
76
|
|
227
|
my ($class, $disallow_private_members) = @_; |
939
|
76
|
|
|
|
|
131
|
my @members; |
940
|
76
|
100
|
|
|
|
172
|
if ( $disallow_private_members ) { |
941
|
15
|
|
|
|
|
47
|
@members = grep ! $class->private($_->name), $class->members_values; |
942
|
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
|
else { |
944
|
61
|
|
|
|
|
149
|
@members = $class->members_values; |
945
|
|
|
|
|
|
|
} |
946
|
76
|
|
|
|
|
218
|
return (@members, map(accessible_members($_, 1), grep(ref $_, $class->parents))); |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
sub accessible_accessor_regexps($;$) { |
950
|
76
|
|
|
76
|
|
182
|
my ($class, $disallow_private_members) = @_; |
951
|
76
|
|
|
|
|
134
|
my ($member_name, @accessor_names); |
952
|
76
|
|
|
|
|
205
|
for my $member ( $class->members_values ) { |
953
|
166
|
100
|
100
|
|
|
405
|
next if $class->private($member_name = $member->name) && $disallow_private_members; |
954
|
165
|
|
|
|
|
447
|
for my $accessor_name ( grep $class->include_method($_), $member->accessor_names($class, $member_name) ) { |
955
|
466
|
|
|
|
|
3088
|
$accessor_name =~ s/$member_name/($&)/; |
956
|
466
|
|
|
|
|
1183
|
push @accessor_names, $accessor_name; |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
} |
959
|
76
|
|
|
|
|
246
|
return (@accessor_names, map(accessible_accessor_regexps($_, 1), grep(ref $_, $class->parents))); |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
sub accessible_user_defined_method_regexps($;$) { |
963
|
76
|
|
|
76
|
|
186
|
my ($class, $disallow_private_methods) = @_; |
964
|
76
|
100
|
|
|
|
434
|
return (($disallow_private_methods ? grep ! $class->private($_), $class->user_defined_methods_keys : $class->user_defined_methods_keys), |
965
|
|
|
|
|
|
|
map(accessible_user_defined_method_regexps($_, 1), grep(ref $_, $class->parents))); |
966
|
|
|
|
|
|
|
} |
967
|
|
|
|
|
|
|
# Given element E and class C, return C if E is an |
968
|
|
|
|
|
|
|
sub class_of($$;$) { # element of C; if not, search parents recursively. |
969
|
39
|
|
|
39
|
|
69
|
my ($element_name, $class, $disallow_private_members) = @_; |
970
|
39
|
100
|
100
|
|
|
67
|
return $class if (defined $class->members($element_name) || defined $class->user_defined_methods($element_name)) && (! $disallow_private_members || ! $class->private($element_name)); |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
971
|
6
|
|
|
|
|
19
|
for my $parent ( grep ref $_, $class->parents ) { |
972
|
6
|
|
|
|
|
17
|
my $c = class_of($element_name, $parent, 1); |
973
|
6
|
50
|
|
|
|
24
|
return $c if defined $c; |
974
|
|
|
|
|
|
|
} |
975
|
0
|
|
|
|
|
0
|
return undef; |
976
|
|
|
|
|
|
|
} |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
package Class::Generate::Code_Checker; # This package encapsulates |
979
|
|
|
|
|
|
|
$Class::Generate::Code_Checker::VERSION = '1.17'; |
980
|
14
|
|
|
15
|
|
103
|
use strict; # checking for warnings and |
|
14
|
|
|
|
|
34
|
|
|
14
|
|
|
|
|
458
|
|
981
|
14
|
|
|
15
|
|
81
|
use Carp; # errors in user-defined code. |
|
14
|
|
|
|
|
26
|
|
|
14
|
|
|
|
|
11237
|
|
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
my $package_decl; |
984
|
|
|
|
|
|
|
my $member_error_message = '%s, member "%s": In "%s" code: %s'; |
985
|
|
|
|
|
|
|
my $method_error_message = '%s, method "%s": %s'; |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
sub create_code_checking_package($); |
988
|
|
|
|
|
|
|
sub fragment_as_sub($$\@;\@); |
989
|
|
|
|
|
|
|
sub collect_code_problems($$$$@); |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
# Check each user-defined code fragment in $class for errors. This includes |
992
|
|
|
|
|
|
|
# pre, post, and assert code, as well as user-defined methods. Set |
993
|
|
|
|
|
|
|
# $errors_found according to whether errors (not warnings) were found. |
994
|
|
|
|
|
|
|
sub check_user_defined_code($$$$) { |
995
|
61
|
|
|
61
|
|
201
|
my ($class, $class_name_label, $warnings, $errors) = @_; |
996
|
61
|
|
|
|
|
161
|
my ($code, $instance_var, @valid_variables, @class_vars, $w, $e, @members, $problems_in_pre, %seen); |
997
|
61
|
|
|
|
|
202
|
create_code_checking_package $class; |
998
|
61
|
100
|
|
|
|
292
|
@valid_variables = map { $seen{$_->name} ? () : do { $seen{$_->name} = 1; $_->as_var } } |
|
298
|
|
|
|
|
500
|
|
|
165
|
|
|
|
|
284
|
|
|
165
|
|
|
|
|
408
|
|
999
|
|
|
|
|
|
|
((@members = $class->members_values), |
1000
|
|
|
|
|
|
|
Class::Generate::Member_Names::accessible_members($class)); |
1001
|
61
|
|
|
|
|
248
|
@class_vars = $class->class_vars; |
1002
|
61
|
|
|
|
|
209
|
$instance_var = $class->instance_var; |
1003
|
61
|
|
|
|
|
140
|
@$warnings = (); |
1004
|
61
|
|
|
|
|
126
|
undef $$errors; |
1005
|
61
|
|
|
|
|
153
|
for my $member ( $class->constructor, @members ) { |
1006
|
194
|
100
|
|
|
|
474
|
if ( defined ($code = $member->pre) ) { |
1007
|
0
|
|
|
|
|
0
|
$code = fragment_as_sub $code, $instance_var, @class_vars, @valid_variables; |
1008
|
0
|
|
|
|
|
0
|
collect_code_problems $code, |
1009
|
|
|
|
|
|
|
$warnings, $errors, |
1010
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, 'pre'; |
1011
|
0
|
|
0
|
|
|
0
|
$problems_in_pre = @$warnings || $$errors; |
1012
|
|
|
|
|
|
|
} |
1013
|
|
|
|
|
|
|
# Because post shares pre's scope, check post with pre prepended. |
1014
|
|
|
|
|
|
|
# Strip newlines in pre to preserve line numbers in post. |
1015
|
194
|
100
|
|
|
|
460
|
if ( defined ($code = $member->post) ) { |
1016
|
13
|
|
|
|
|
32
|
my $pre = $member->pre; |
1017
|
13
|
50
|
33
|
|
|
48
|
if ( defined $pre && ! $problems_in_pre ) { # Don't report errors |
1018
|
0
|
|
|
|
|
0
|
$pre =~ s/\n+/ /g; # in pre again. |
1019
|
0
|
|
|
|
|
0
|
$code = $pre . $code; |
1020
|
|
|
|
|
|
|
} |
1021
|
13
|
|
|
|
|
47
|
$code = fragment_as_sub $code, $instance_var, @class_vars, @valid_variables; |
1022
|
13
|
|
|
|
|
44
|
collect_code_problems $code, |
1023
|
|
|
|
|
|
|
$warnings, $errors, |
1024
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, 'post'; |
1025
|
|
|
|
|
|
|
} |
1026
|
194
|
100
|
|
|
|
447
|
if ( defined ($code = $member->assert) ) { |
1027
|
5
|
|
|
|
|
29
|
$code = fragment_as_sub "unless($code){die}" , $instance_var, @class_vars, @valid_variables; |
1028
|
5
|
|
|
|
|
18
|
collect_code_problems $code, |
1029
|
|
|
|
|
|
|
$warnings, $errors, |
1030
|
|
|
|
|
|
|
$member_error_message, $class_name_label, $member->name, 'assert'; |
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
} |
1033
|
61
|
|
|
|
|
176
|
for my $method ( $class->user_defined_methods_values ) { |
1034
|
28
|
100
|
|
|
|
147
|
if ( $method->isa('Class::Generate::Class_Method') ) { |
1035
|
2
|
|
|
|
|
9
|
$code = fragment_as_sub $method->body, $class->class_var, @class_vars; |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
else { |
1038
|
26
|
|
|
|
|
72
|
$code = fragment_as_sub $method->body, $instance_var, @class_vars, @valid_variables; |
1039
|
|
|
|
|
|
|
} |
1040
|
28
|
|
|
|
|
81
|
collect_code_problems $code, $warnings, $errors, $method_error_message, $class_name_label, $method->name; |
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
} |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
sub create_code_checking_package($) { # Each class with user-defined code gets |
1045
|
61
|
|
|
61
|
|
156
|
my $class = $_[0]; # its own package in which that code is |
1046
|
|
|
|
|
|
|
# evaluated. Create said package. |
1047
|
61
|
|
|
|
|
218
|
$package_decl = 'package ' . __PACKAGE__ . '::check::' . $class->name . ";"; |
1048
|
61
|
50
|
|
|
|
283
|
$package_decl .= 'use strict;' if $class->strict; |
1049
|
61
|
|
|
|
|
123
|
my $packages = ''; |
1050
|
61
|
50
|
|
|
|
167
|
if ( $class->check_params ) { |
1051
|
61
|
|
|
|
|
124
|
$packages .= 'use Carp;'; |
1052
|
61
|
|
|
|
|
251
|
$packages .= join(';', $class->warnings_pragmas); |
1053
|
|
|
|
|
|
|
} |
1054
|
61
|
|
|
|
|
283
|
$packages .= join('', map('use ' . $_ . ';', $class->use_packages)); |
1055
|
61
|
100
|
|
|
|
176
|
$packages .= 'use vars qw(@ISA);' if $class->parents; |
1056
|
13
|
|
|
13
|
|
88
|
eval $package_decl . $packages; |
|
13
|
|
|
13
|
|
24
|
|
|
13
|
|
|
13
|
|
348
|
|
|
13
|
|
|
12
|
|
59
|
|
|
13
|
|
|
12
|
|
23
|
|
|
13
|
|
|
12
|
|
758
|
|
|
13
|
|
|
12
|
|
68
|
|
|
13
|
|
|
10
|
|
25
|
|
|
13
|
|
|
9
|
|
768
|
|
|
12
|
|
|
8
|
|
74
|
|
|
12
|
|
|
8
|
|
26
|
|
|
12
|
|
|
8
|
|
421
|
|
|
12
|
|
|
7
|
|
70
|
|
|
12
|
|
|
7
|
|
23
|
|
|
12
|
|
|
7
|
|
590
|
|
|
12
|
|
|
17
|
|
62
|
|
|
12
|
|
|
3
|
|
31
|
|
|
12
|
|
|
8
|
|
330
|
|
|
12
|
|
|
|
|
83
|
|
|
12
|
|
|
|
|
31
|
|
|
12
|
|
|
|
|
369
|
|
|
10
|
|
|
|
|
46
|
|
|
10
|
|
|
|
|
18
|
|
|
10
|
|
|
|
|
478
|
|
|
9
|
|
|
|
|
58
|
|
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
195
|
|
|
8
|
|
|
|
|
58
|
|
|
8
|
|
|
|
|
19
|
|
|
8
|
|
|
|
|
274
|
|
|
8
|
|
|
|
|
39
|
|
|
8
|
|
|
|
|
14
|
|
|
8
|
|
|
|
|
488
|
|
|
8
|
|
|
|
|
50
|
|
|
8
|
|
|
|
|
21
|
|
|
8
|
|
|
|
|
243
|
|
|
7
|
|
|
|
|
42
|
|
|
7
|
|
|
|
|
12
|
|
|
7
|
|
|
|
|
528
|
|
|
7
|
|
|
|
|
42
|
|
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
298
|
|
|
7
|
|
|
|
|
36
|
|
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
236
|
|
|
61
|
|
|
|
|
4806
|
|
|
17
|
|
|
|
|
367
|
|
|
17
|
|
|
|
|
38
|
|
|
6
|
|
|
|
|
24
|
|
|
5
|
|
|
|
|
25
|
|
|
11
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
22
|
|
|
5
|
|
|
|
|
69
|
|
|
4
|
|
|
|
|
53
|
|
|
4
|
|
|
|
|
53
|
|
1057
|
|
|
|
|
|
|
} |
1058
|
|
|
|
|
|
|
# Evaluate a code fragment, passing on |
1059
|
|
|
|
|
|
|
sub collect_code_problems($$$$@) { # warnings and errors. |
1060
|
46
|
|
|
46
|
|
153
|
my ($code_form, $warnings, $errors, $error_message, @params) = @_; |
1061
|
46
|
|
|
|
|
73
|
my @warnings; |
1062
|
46
|
|
|
1
|
|
280
|
local $SIG{__WARN__} = sub { push @warnings, $_[0] }; |
|
0
|
|
|
|
|
0
|
|
1063
|
46
|
|
|
|
|
142
|
local $SIG{__DIE__}; |
1064
|
10
|
|
|
10
|
|
59
|
eval $package_decl . $code_form; |
|
10
|
|
|
10
|
|
20
|
|
|
10
|
|
|
5
|
|
636
|
|
|
9
|
|
|
|
|
53
|
|
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
486
|
|
|
46
|
|
|
|
|
2840
|
|
|
6
|
|
|
|
|
19
|
|
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
7
|
|
1065
|
46
|
|
|
|
|
219
|
push @$warnings, map(filtered_message($error_message, $_, @params), @warnings); |
1066
|
46
|
50
|
|
|
|
359
|
$$errors .= filtered_message($error_message, $@, @params) if $@; |
1067
|
|
|
|
|
|
|
} |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
sub filtered_message { # Clean up errors and messages |
1070
|
0
|
|
|
0
|
|
0
|
my ($message, $error, @params) = @_; # a little by removing the |
1071
|
0
|
|
|
|
|
0
|
$error =~ s/\(eval \d+\) //g; # "(eval N)" forms that perl |
1072
|
0
|
|
|
|
|
0
|
return sprintf($message, @params, $error); # inserts. |
1073
|
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
sub fragment_as_sub($$\@;\@) { |
1076
|
46
|
|
|
46
|
|
123
|
my ($code, $id_var, $class_vars, $valid_vars) = @_; |
1077
|
46
|
|
|
|
|
62
|
my $form; |
1078
|
46
|
|
|
|
|
130
|
$form = "sub{my $id_var;"; |
1079
|
46
|
100
|
|
|
|
127
|
if ( $#$class_vars >= 0 ) { |
1080
|
4
|
50
|
|
|
|
17
|
$form .= 'my(' . join(',', map((ref $_ ? keys %$_ : $_), @$class_vars)) . ');'; |
1081
|
|
|
|
|
|
|
} |
1082
|
46
|
100
|
100
|
|
|
214
|
if ( $valid_vars && $#$valid_vars >= 0 ) { |
1083
|
42
|
|
|
|
|
156
|
$form .= 'my(' . join(',', @$valid_vars) . ');'; |
1084
|
|
|
|
|
|
|
} |
1085
|
46
|
|
|
|
|
157
|
$form .= '{' . $code . '}};'; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
package Class::Generate::Array; # Given a string or an ARRAY, return an |
1089
|
|
|
|
|
|
|
$Class::Generate::Array::VERSION = '1.17'; |
1090
|
16
|
|
|
15
|
|
112
|
use strict; # object that is either the ARRAY or |
|
16
|
|
|
|
|
34
|
|
|
16
|
|
|
|
|
501
|
|
1091
|
15
|
|
|
14
|
|
78
|
use Carp; # the string made into an ARRAY by |
|
15
|
|
|
|
|
31
|
|
|
15
|
|
|
|
|
2582
|
|
1092
|
|
|
|
|
|
|
# splitting the string on white space. |
1093
|
|
|
|
|
|
|
sub new { |
1094
|
63
|
|
|
63
|
|
148
|
my $class = shift; |
1095
|
63
|
|
|
|
|
108
|
my $self; |
1096
|
63
|
100
|
|
|
|
222
|
if ( ! ref $_[0] ) { |
|
|
50
|
|
|
|
|
|
1097
|
60
|
|
|
|
|
325
|
$self = [ split /\s+/, $_[0] ]; |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa($_[0], 'ARRAY') ) { |
1100
|
3
|
|
|
|
|
7
|
$self = $_[0]; |
1101
|
|
|
|
|
|
|
} |
1102
|
|
|
|
|
|
|
else { |
1103
|
0
|
|
|
|
|
0
|
croak 'Expected string or array reference'; |
1104
|
|
|
|
|
|
|
} |
1105
|
63
|
|
|
|
|
179
|
bless $self, $class; |
1106
|
63
|
|
|
|
|
161
|
return $self; |
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
sub values { |
1110
|
125
|
|
|
125
|
|
208
|
my $self = shift; |
1111
|
125
|
|
|
|
|
601
|
return @$self; |
1112
|
|
|
|
|
|
|
} |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
package Class::Generate::Hash; # Given a string or a HASH and a key |
1115
|
|
|
|
|
|
|
$Class::Generate::Hash::VERSION = '1.17'; |
1116
|
14
|
|
|
14
|
|
89
|
use strict; # name, return an object that is either |
|
14
|
|
|
|
|
34
|
|
|
14
|
|
|
|
|
382
|
|
1117
|
14
|
|
|
16
|
|
86
|
use Carp; # the HASH or a HASH of the form |
|
14
|
|
|
|
|
39
|
|
|
14
|
|
|
|
|
2253
|
|
1118
|
|
|
|
|
|
|
# (key => string). Also, if the object |
1119
|
|
|
|
|
|
|
sub new { # is a HASH, it *must* contain the key. |
1120
|
162
|
|
|
162
|
|
264
|
my $class = shift; |
1121
|
162
|
|
|
|
|
214
|
my $self; |
1122
|
162
|
|
|
|
|
295
|
my ($value, $key) = @_; |
1123
|
162
|
100
|
|
|
|
325
|
if ( ! ref $value ) { |
1124
|
104
|
|
|
|
|
213
|
$self = { $key => $value }; |
1125
|
|
|
|
|
|
|
} |
1126
|
|
|
|
|
|
|
else { |
1127
|
58
|
50
|
|
|
|
188
|
croak 'Expected string or hash reference' unless UNIVERSAL::isa($value, 'HASH'); |
1128
|
58
|
100
|
|
|
|
269
|
croak qq|Missing "$key"| unless exists $value->{$key}; |
1129
|
57
|
|
|
|
|
110
|
$self = $value; |
1130
|
|
|
|
|
|
|
} |
1131
|
161
|
|
|
|
|
261
|
bless $self, $class; |
1132
|
161
|
|
|
|
|
664
|
return $self; |
1133
|
|
|
|
|
|
|
} |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
package Class::Generate::Support; # Miscellaneous support routines. |
1136
|
|
|
|
|
|
|
$Class::Generate::Support::VERSION = '1.17'; |
1137
|
15
|
|
|
15
|
|
93
|
no strict; # Definitely NOT strict! |
|
15
|
|
|
|
|
38
|
|
|
15
|
|
|
|
|
3453
|
|
1138
|
|
|
|
|
|
|
# Return the superclass of $class that |
1139
|
|
|
|
|
|
|
sub class_containing_method { # contains the method that the form |
1140
|
46
|
|
|
46
|
|
109
|
my ($method, $class) = @_; # (new $class)->$method would invoke. |
1141
|
46
|
|
|
|
|
128
|
for my $parent ( $class->parents ) {# Return undef if no such class exists. |
1142
|
15
|
50
|
|
|
|
90
|
local *stab = eval ('*' . (ref $parent ? $parent->name : $parent) . '::'); |
1143
|
15
|
50
|
33
|
|
|
111
|
if ( exists $stab{$method} && |
1144
|
15
|
|
|
|
|
76
|
do { local *method_entry = $stab{$method}; defined &method_entry } ) { |
|
15
|
|
|
|
|
91
|
|
1145
|
15
|
|
|
|
|
57
|
return $parent; |
1146
|
|
|
|
|
|
|
} |
1147
|
0
|
|
|
|
|
0
|
return class_containing_method($method, $parent); |
1148
|
|
|
|
|
|
|
} |
1149
|
31
|
|
|
|
|
76
|
return undef; |
1150
|
|
|
|
|
|
|
} |
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
my %map = ('@' => 'ARRAY', '%' => 'HASH'); |
1153
|
|
|
|
|
|
|
sub verify_value($$) { # Die if a given value (ref or string) |
1154
|
1
|
|
|
1
|
|
3
|
my ($value, $type) = @_; # is not the specified type. |
1155
|
|
|
|
|
|
|
# The following code is not wrong, but it could be smarter. |
1156
|
1
|
50
|
|
|
|
4
|
if ( $type =~ /^\w/ ) { |
1157
|
0
|
|
|
|
|
0
|
$map{$type} = $type; |
1158
|
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
else { |
1160
|
1
|
|
|
|
|
3
|
$type = substr $type, 0, 1; |
1161
|
|
|
|
|
|
|
} |
1162
|
1
|
50
|
|
|
|
3
|
return if $type eq '$'; |
1163
|
0
|
|
|
0
|
|
0
|
local $SIG{__WARN__} = sub {}; |
1164
|
0
|
|
|
|
|
0
|
my $result; |
1165
|
0
|
0
|
|
|
|
0
|
$result = ref $value ? $value : eval $value; |
1166
|
0
|
0
|
|
|
|
0
|
die "Wrong type" if ! UNIVERSAL::isa($result, $map{$type}); |
1167
|
|
|
|
|
|
|
} |
1168
|
|
|
|
|
|
|
|
1169
|
14
|
|
|
14
|
|
120
|
use strict; |
|
14
|
|
|
|
|
264
|
|
|
14
|
|
|
|
|
2218
|
|
1170
|
|
|
|
|
|
|
sub comment_form { # Given arbitrary text, return a form that |
1171
|
1
|
|
|
1
|
|
2
|
my $comment = $_[0]; # is a valid Perl comment of that text. |
1172
|
1
|
|
|
|
|
5
|
$comment =~ s/^/# /mg; |
1173
|
1
|
50
|
|
|
|
6
|
$comment .= "\n" if substr($comment, -1, 1) ne "\n"; |
1174
|
1
|
|
|
|
|
3
|
return $comment; |
1175
|
|
|
|
|
|
|
} |
1176
|
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
sub my_decl_form { # Given a non-empty set of variable names, |
1178
|
8
|
|
|
8
|
|
24
|
my @vars = @_; # return a form declaring them as "my" variables. |
1179
|
8
|
100
|
|
|
|
67
|
return 'my ' . ($#vars == 0 ? $vars[0] : '(' . join(', ', @vars) . ')') . ";\n"; |
1180
|
|
|
|
|
|
|
} |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
package Class::Generate::Member; # A virtual class describing class |
1183
|
|
|
|
|
|
|
$Class::Generate::Member::VERSION = '1.17'; |
1184
|
14
|
|
|
14
|
|
101
|
use strict; # members. |
|
14
|
|
|
|
|
41
|
|
|
14
|
|
|
|
|
22718
|
|
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
sub new { |
1187
|
195
|
|
|
195
|
|
322
|
my $class = shift; |
1188
|
195
|
|
|
|
|
591
|
my $self = { name => $_[0], @_[1..$#_] }; |
1189
|
195
|
|
|
|
|
404
|
bless $self, $class; |
1190
|
195
|
|
|
|
|
363
|
return $self; |
1191
|
|
|
|
|
|
|
} |
1192
|
|
|
|
|
|
|
sub name { |
1193
|
3120
|
|
|
3120
|
|
3863
|
my $self = shift; |
1194
|
3120
|
|
|
|
|
7177
|
return $self->{'name'}; |
1195
|
|
|
|
|
|
|
} |
1196
|
|
|
|
|
|
|
sub default { |
1197
|
228
|
|
|
228
|
|
342
|
my $self = shift; |
1198
|
228
|
100
|
|
|
|
852
|
return $self->{'default'} if $#_ == -1; |
1199
|
1
|
|
|
|
|
3
|
$self->{'default'} = $_[0]; |
1200
|
|
|
|
|
|
|
} |
1201
|
|
|
|
|
|
|
sub base { |
1202
|
879
|
|
|
879
|
|
1046
|
my $self = shift; |
1203
|
879
|
50
|
|
|
|
2782
|
return $self->{'base'} if $#_ == -1; |
1204
|
0
|
|
|
|
|
0
|
$self->{'base'} = $_[0]; |
1205
|
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
|
sub assert { |
1207
|
556
|
|
|
556
|
|
769
|
my $self = shift; |
1208
|
556
|
100
|
|
|
|
1731
|
return $self->{'assert'} if $#_ == -1; |
1209
|
3
|
|
|
|
|
17
|
$self->{'assert'} = $_[0]; |
1210
|
|
|
|
|
|
|
} |
1211
|
|
|
|
|
|
|
sub post { |
1212
|
497
|
|
|
497
|
|
683
|
my $self = shift; |
1213
|
497
|
100
|
|
|
|
1478
|
return $self->{'post'} if $#_ == -1; |
1214
|
4
|
|
|
|
|
9
|
$self->{'post'} = possibly_append_semicolon_to($_[0]); |
1215
|
|
|
|
|
|
|
} |
1216
|
|
|
|
|
|
|
sub pre { |
1217
|
420
|
|
|
420
|
|
542
|
my $self = shift; |
1218
|
420
|
50
|
|
|
|
1188
|
return $self->{'pre'} if $#_ == -1; |
1219
|
0
|
|
|
|
|
0
|
$self->{'pre'} = possibly_append_semicolon_to($_[0]); |
1220
|
|
|
|
|
|
|
} |
1221
|
|
|
|
|
|
|
sub possibly_append_semicolon_to { # If user omits a trailing semicolon |
1222
|
4
|
|
|
4
|
|
6
|
my $code = $_[0]; # (or doesn't use braces), add one. |
1223
|
4
|
50
|
|
|
|
22
|
if ( $code !~ /[;\}]\s*\Z/s ) { |
1224
|
0
|
|
|
|
|
0
|
$code =~ s/\s*\Z/;$&/s; |
1225
|
|
|
|
|
|
|
} |
1226
|
4
|
|
|
|
|
20
|
return $code; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
sub comment { |
1229
|
132
|
|
|
132
|
|
202
|
my $self = shift; |
1230
|
132
|
|
|
|
|
356
|
return $self->{'comment'}; |
1231
|
|
|
|
|
|
|
} |
1232
|
|
|
|
|
|
|
sub key { |
1233
|
134
|
|
|
134
|
|
194
|
my $self = shift; |
1234
|
134
|
100
|
|
|
|
544
|
return $self->{'key'} if $#_ == -1; |
1235
|
3
|
|
|
|
|
10
|
$self->{'key'} = $_[0]; |
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
sub nocopy { |
1238
|
98
|
|
|
98
|
|
136
|
my $self = shift; |
1239
|
98
|
100
|
|
|
|
345
|
return $self->{'nocopy'} if $#_ == -1; |
1240
|
2
|
|
|
|
|
6
|
$self->{'nocopy'} = $_[0]; |
1241
|
|
|
|
|
|
|
} |
1242
|
|
|
|
|
|
|
sub assertion { # Return a form that croaks if |
1243
|
7
|
|
|
7
|
|
14
|
my $self = shift; # the member's assertion fails. |
1244
|
7
|
|
|
|
|
12
|
my $class = $_[0]; |
1245
|
7
|
|
|
|
|
16
|
my $assertion = $self->{'assert'}; |
1246
|
7
|
50
|
|
|
|
17
|
return undef if ! defined $assertion; |
1247
|
7
|
|
|
|
|
14
|
my $quoted_form = $assertion; |
1248
|
7
|
|
|
|
|
18
|
$quoted_form =~ s/'/\\'/g; |
1249
|
7
|
|
|
|
|
18
|
$assertion = Class::Generate::Member_Names::substituted($assertion); |
1250
|
7
|
|
|
|
|
34
|
return qq|unless ( $assertion ) { croak '| . $self->name_form($class) . qq|Failed assertion: $quoted_form' }|; |
1251
|
|
|
|
|
|
|
} |
1252
|
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
|
sub param_message { # Encapsulate the messages for |
1254
|
84
|
|
|
84
|
|
126
|
my $self = shift; # incorrect parameters. |
1255
|
84
|
|
|
|
|
106
|
my $class = $_[0]; |
1256
|
84
|
|
|
|
|
138
|
my $name = $self->name; |
1257
|
84
|
|
|
|
|
185
|
my $prefix_form = q|croak '| . $class->name . '::new' . ': '; |
1258
|
84
|
100
|
66
|
|
|
160
|
$class->required($name) && ! $self->default and do { |
1259
|
31
|
100
|
|
|
|
98
|
return $prefix_form . qq|Missing or invalid value for $name'| if $self->can_be_invalid; |
1260
|
25
|
|
|
|
|
168
|
return $prefix_form . qq|Missing value for required member $name'|; |
1261
|
|
|
|
|
|
|
}; |
1262
|
53
|
50
|
|
|
|
107
|
$self->can_be_invalid and do { |
1263
|
53
|
|
|
|
|
233
|
return $prefix_form . qq|Invalid value for $name'|; |
1264
|
|
|
|
|
|
|
}; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
sub param_test { # Return a form that dies if a constructor |
1268
|
84
|
|
|
84
|
|
128
|
my $self = shift; # parameter is not correctly passed. |
1269
|
84
|
|
|
|
|
418
|
my $class = $_[0]; |
1270
|
84
|
|
|
|
|
189
|
my $name = $self->name; |
1271
|
84
|
|
|
|
|
190
|
my $param = $class->constructor->style->ref($name); |
1272
|
84
|
|
|
|
|
224
|
my $exists = $class->constructor->style->existence_test($name) . ' ' . $param; |
1273
|
|
|
|
|
|
|
|
1274
|
84
|
|
|
|
|
184
|
my $form = ''; |
1275
|
84
|
100
|
66
|
|
|
196
|
if ( $class->required($name) && ! $self->default ) { |
|
|
50
|
|
|
|
|
|
1276
|
31
|
|
|
|
|
112
|
$form .= $self->param_message($class) . ' unless ' . $exists; |
1277
|
31
|
100
|
|
|
|
84
|
$form .= ' && ' . $self->valid_value_form($param) if $self->can_be_invalid; |
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
elsif ( $self->can_be_invalid ) { |
1280
|
53
|
|
|
|
|
144
|
$form .= $self->param_message($class) . ' unless ! ' . $exists . ' || ' . $self->valid_value_form($param); |
1281
|
|
|
|
|
|
|
} |
1282
|
84
|
|
|
|
|
363
|
return $form . ';'; |
1283
|
|
|
|
|
|
|
} |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
sub form { # Return a form for a member and all |
1286
|
132
|
|
|
132
|
|
206
|
my $self = shift; # its relevant associated accessors. |
1287
|
132
|
|
|
|
|
188
|
my $class = $_[0]; |
1288
|
132
|
|
|
|
|
202
|
my ($element, $exists, $lvalue, $values, $form, $body, $member_name); |
1289
|
132
|
|
|
|
|
232
|
$element = $class->instance_var . '->' . $class->index($member_name = $self->name); |
1290
|
132
|
|
|
|
|
329
|
$exists = $class->existence_test . ' ' . $element; |
1291
|
132
|
100
|
|
|
|
626
|
$lvalue = $self->lvalue('$_[0]') if $self->can('lvalue'); |
1292
|
132
|
100
|
|
|
|
463
|
$values = $self->values('$_[0]') if $self->can('values'); |
1293
|
|
|
|
|
|
|
|
1294
|
132
|
|
|
|
|
202
|
$form = ''; |
1295
|
132
|
50
|
|
|
|
372
|
$form .= Class::Generate::Support::comment_form($self->comment) if defined $self->comment; |
1296
|
|
|
|
|
|
|
|
1297
|
132
|
50
|
|
|
|
278
|
if ( $class->include_method($member_name) ) { |
1298
|
132
|
|
|
|
|
207
|
$body = ''; |
1299
|
132
|
|
|
|
|
405
|
for my $param_form ( $self->member_forms($class) ) { |
1300
|
299
|
|
|
|
|
860
|
$body .= $self->$param_form($class, $element, $exists, $lvalue, $values); |
1301
|
|
|
|
|
|
|
} |
1302
|
132
|
50
|
|
|
|
293
|
$body .= ' ' . $self->param_count_error_form($class) . ";\n" if $class->check_params; |
1303
|
132
|
|
|
|
|
361
|
$form .= $class->sub_form($member_name, $member_name, $body); |
1304
|
|
|
|
|
|
|
} |
1305
|
132
|
|
|
|
|
358
|
for my $a ( grep $_ ne $member_name, $self->accessor_names($class, $member_name) ) { |
1306
|
268
|
100
|
|
|
|
4248
|
$a =~ s/^([a-z]+)_$member_name$/$1_form/ || $a =~ s/^${member_name}_([a-z]+)$/$1_form/; |
1307
|
268
|
|
|
|
|
1045
|
$form .= $self->$a($class, $element, $member_name, $exists); |
1308
|
|
|
|
|
|
|
} |
1309
|
132
|
|
|
|
|
656
|
return $form; |
1310
|
|
|
|
|
|
|
} |
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
sub invalid_value_assignment_message { # Return a form that dies, reporting |
1313
|
78
|
|
|
78
|
|
98
|
my $self = shift; # a parameter that's not of the |
1314
|
78
|
|
|
|
|
107
|
my $class = $_[0]; # correct type for its element. |
1315
|
78
|
|
|
|
|
184
|
return 'croak \'' . $self->name_form($class) . 'Invalid parameter value (expected ' . $self->expected_type_form . ')\''; |
1316
|
|
|
|
|
|
|
} |
1317
|
|
|
|
|
|
|
sub valid_value_test_form { # Return a form that dies unless |
1318
|
63
|
|
|
63
|
|
104
|
my $self = shift; # a value is of the correct type |
1319
|
63
|
|
|
|
|
78
|
my $class = shift; # for the member. |
1320
|
63
|
|
|
|
|
160
|
return $self->invalid_value_assignment_message($class) . ' unless ' . $self->valid_value_form(@_) . ';'; |
1321
|
|
|
|
|
|
|
} |
1322
|
|
|
|
|
|
|
sub param_must_be_checked { |
1323
|
118
|
|
|
118
|
|
182
|
my $self = shift; |
1324
|
118
|
|
|
|
|
152
|
my $class = $_[0]; |
1325
|
118
|
|
100
|
|
|
219
|
return ($class->required($self->name) && ! defined $self->default) || $self->can_be_invalid; |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
sub maybe_guarded { # If parameter checking is enabled, guard a |
1329
|
106
|
|
|
106
|
|
149
|
my $self = shift; # form to check against a parameter |
1330
|
106
|
|
|
|
|
208
|
my ($form, $param_no, $class) = @_; # count. In any case, format the form |
1331
|
106
|
50
|
|
|
|
178
|
if ( $class->check_params ) { # a little. |
1332
|
106
|
|
|
|
|
541
|
$form =~ s/^/\t/mg; |
1333
|
106
|
|
|
|
|
417
|
return " \$#_ == $param_no\tand do {\n$form };\n"; |
1334
|
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
|
else { |
1336
|
0
|
|
|
|
|
0
|
$form =~ s/^/ /mg; |
1337
|
0
|
|
|
|
|
0
|
return $form; |
1338
|
|
|
|
|
|
|
} |
1339
|
|
|
|
|
|
|
} |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
sub accessor_names { |
1342
|
315
|
|
|
315
|
|
451
|
my $self = shift; |
1343
|
315
|
|
|
|
|
469
|
my ($class, $name) = @_; |
1344
|
315
|
100
|
100
|
|
|
638
|
return ! ($class->readonly($name) || $class->required($name)) ? ("undef_$name") : (); |
1345
|
|
|
|
|
|
|
} |
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
sub undef_form { # Return the form to undefine |
1348
|
88
|
|
|
88
|
|
150
|
my $self = shift; # a member. |
1349
|
88
|
|
|
|
|
214
|
my ($class, $element, $member_name) = @_[0..2]; |
1350
|
88
|
|
|
|
|
231
|
return $class->sub_form($member_name, 'undef_' . $member_name, ' ' . $class->undef_form . " $element;\n"); |
1351
|
|
|
|
|
|
|
} |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
sub param_count_error_form { # Return a form that standardizes |
1354
|
132
|
|
|
132
|
|
239
|
my $self = shift; # the message for dieing because |
1355
|
132
|
|
|
|
|
193
|
my $class = $_[0]; # of an incorrect parameter count. |
1356
|
132
|
|
|
|
|
327
|
return q|croak '| . $self->name_form($class) . q|Invalid number of parameters (', ($#_+1), ')'|; |
1357
|
|
|
|
|
|
|
} |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
sub name_form { # Standardize a method name |
1360
|
310
|
|
|
310
|
|
401
|
my $self = shift; # for error messages. |
1361
|
310
|
|
|
|
|
376
|
my $class = $_[0]; |
1362
|
310
|
|
|
|
|
507
|
return $class->name . '::' . $self->name . ': '; |
1363
|
|
|
|
|
|
|
} |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
sub param_assignment_form { # Return a form that assigns a parameter |
1366
|
118
|
|
|
118
|
|
176
|
my $self = shift; # value to the member. |
1367
|
118
|
|
|
|
|
217
|
my ($class, $style) = @_; |
1368
|
118
|
|
|
|
|
195
|
my ($name, $element, $param, $default, $exists); |
1369
|
118
|
|
|
|
|
202
|
$name = $self->name; |
1370
|
118
|
|
|
|
|
240
|
$element = $class->instance_var . '->' . $class->index($name); |
1371
|
118
|
|
|
|
|
271
|
$param = $style->ref($name); |
1372
|
118
|
|
|
|
|
279
|
$default = $self->default; |
1373
|
118
|
|
|
|
|
240
|
$exists = $style->existence_test($name) . ' ' . $param; |
1374
|
118
|
|
|
|
|
232
|
my $form = " $element = "; |
1375
|
118
|
50
|
66
|
|
|
357
|
if ( defined $default ) { |
|
|
100
|
|
|
|
|
|
1376
|
0
|
|
|
|
|
0
|
$form .= "$exists ? $param : $default"; |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
elsif ( $class->check_params && $class->required($name) ) { |
1379
|
31
|
|
|
|
|
73
|
$form .= $param; |
1380
|
|
|
|
|
|
|
} |
1381
|
|
|
|
|
|
|
else { |
1382
|
87
|
|
|
|
|
164
|
$form .= "$param if $exists"; |
1383
|
|
|
|
|
|
|
} |
1384
|
118
|
|
|
|
|
379
|
return $form . ";\n"; |
1385
|
|
|
|
|
|
|
} |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
sub default_assignment_form { # Return a form that assigns a default value |
1388
|
1
|
|
|
1
|
|
2
|
my $self = shift; # to a member. |
1389
|
1
|
|
|
|
|
4
|
my $class = $_[0]; |
1390
|
1
|
|
|
|
|
3
|
my $element; |
1391
|
1
|
|
|
|
|
2
|
$element = $class->instance_var . '->' . $class->index($self->name); |
1392
|
1
|
|
|
|
|
3
|
return " $element = " . $self->default . ";\n"; |
1393
|
|
|
|
|
|
|
} |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
package Class::Generate::Scalar_Member; # A Member subclass for |
1396
|
|
|
|
|
|
|
$Class::Generate::Scalar_Member::VERSION = '1.17'; |
1397
|
14
|
|
|
15
|
|
110
|
use strict; # scalar class members. |
|
14
|
|
|
|
|
38
|
|
|
14
|
|
|
|
|
1226
|
|
1398
|
14
|
|
|
14
|
|
94
|
use vars qw(@ISA); # accessor accepts 0 or 1 parameters. |
|
14
|
|
|
|
|
50
|
|
|
14
|
|
|
|
|
9270
|
|
1399
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
1400
|
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
|
sub member_forms { |
1402
|
71
|
|
|
71
|
|
120
|
my $self = shift; |
1403
|
71
|
|
|
|
|
108
|
my $class = $_[0]; |
1404
|
71
|
100
|
|
|
|
163
|
return $class->readonly($self->name) ? 'no_params' : ('no_params', 'one_param'); |
1405
|
|
|
|
|
|
|
} |
1406
|
|
|
|
|
|
|
sub no_params { |
1407
|
71
|
|
|
71
|
|
121
|
my $self = shift; |
1408
|
71
|
|
|
|
|
161
|
my ($class, $element) = @_; |
1409
|
71
|
50
|
66
|
|
|
166
|
if ( $class->readonly($self->name) && ! $class->check_params ) { |
1410
|
0
|
|
|
|
|
0
|
return " return $element;\n"; |
1411
|
|
|
|
|
|
|
} |
1412
|
71
|
|
|
|
|
242
|
return " \$#_ == -1\tand do { return $element };\n"; |
1413
|
|
|
|
|
|
|
} |
1414
|
|
|
|
|
|
|
sub one_param { |
1415
|
47
|
|
|
47
|
|
66
|
my $self = shift; |
1416
|
47
|
|
|
|
|
86
|
my ($class, $element) = @_; |
1417
|
47
|
|
|
|
|
71
|
my $form = ''; |
1418
|
47
|
50
|
|
|
|
95
|
$form .= Class::Generate::Member_Names::substituted($self->pre) if defined $self->pre; |
1419
|
47
|
100
|
66
|
|
|
101
|
$form .= $self->valid_value_test_form($class, '$_[0]') . "\n" if $class->check_params && defined $self->base; |
1420
|
47
|
|
|
|
|
114
|
$form .= "$element = \$_[0];\n"; |
1421
|
47
|
100
|
|
|
|
93
|
$form .= Class::Generate::Member_Names::substituted($self->post) if defined $self->post; |
1422
|
47
|
100
|
66
|
|
|
140
|
$form .= $self->assertion($class) . "\n" if defined $class->check_params && defined $self->assert; |
1423
|
47
|
|
|
|
|
121
|
$form .= "return;\n"; |
1424
|
47
|
|
|
|
|
146
|
return $self->maybe_guarded($form, 0, $class); |
1425
|
|
|
|
|
|
|
} |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
sub valid_value_form { # Return a form that tests if |
1428
|
12
|
|
|
12
|
|
13
|
my $self = shift; # a ref is of the correct |
1429
|
12
|
|
|
|
|
20
|
my ($param) = @_; # base type. |
1430
|
12
|
|
|
|
|
28
|
return qq|UNIVERSAL::isa($param, '| . $self->base . qq|')|; |
1431
|
|
|
|
|
|
|
} |
1432
|
|
|
|
|
|
|
|
1433
|
|
|
|
|
|
|
sub can_be_invalid { # Validity for a scalar member |
1434
|
102
|
|
|
102
|
|
159
|
my $self = shift; # is testable only if the member |
1435
|
102
|
|
|
|
|
197
|
return defined $self->base; # is supposed to be a class. |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
sub as_var { |
1439
|
99
|
|
|
99
|
|
157
|
my $self = shift; |
1440
|
99
|
|
|
|
|
193
|
return '$' . $self->name; |
1441
|
|
|
|
|
|
|
} |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
sub method_regexp { |
1444
|
99
|
|
|
99
|
|
226
|
my $self = shift; |
1445
|
99
|
|
|
|
|
153
|
my $class = $_[0]; |
1446
|
99
|
50
|
|
|
|
279
|
return $class->include_method($self->name) ? ('\$' . $self->name) : (); |
1447
|
|
|
|
|
|
|
} |
1448
|
|
|
|
|
|
|
sub accessor_names { |
1449
|
175
|
|
|
175
|
|
294
|
my $self = shift; |
1450
|
175
|
|
|
|
|
341
|
my ($class, $name) = @_; |
1451
|
175
|
|
|
|
|
542
|
return grep $class->include_method($_), ($name, $self->SUPER::accessor_names($class, $name)); |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
sub expected_type_form { |
1454
|
6
|
|
|
6
|
|
9
|
my $self = shift; |
1455
|
6
|
|
|
|
|
11
|
return $self->base; |
1456
|
|
|
|
|
|
|
} |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
sub copy_form { |
1459
|
37
|
|
|
37
|
|
71
|
my $self = shift; |
1460
|
37
|
|
|
|
|
91
|
my ($from, $to) = @_; |
1461
|
37
|
|
|
|
|
103
|
my $form = " $to = $from"; |
1462
|
37
|
50
|
|
|
|
146
|
if ( ! $self->nocopy ) { |
1463
|
37
|
100
|
|
|
|
84
|
$form .= '->copy' if $self->base; |
1464
|
|
|
|
|
|
|
} |
1465
|
37
|
|
|
|
|
122
|
$form .= " if defined $from;\n"; |
1466
|
37
|
|
|
|
|
126
|
return $form; |
1467
|
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
sub equals { |
1470
|
70
|
|
|
70
|
|
137
|
my $self = shift; |
1471
|
70
|
|
|
|
|
146
|
my ($index, $existence_test) = @_; |
1472
|
70
|
|
|
|
|
218
|
my ($sr, $or) = ('$self->' . $index, '$o->' . $index); |
1473
|
70
|
|
|
|
|
360
|
my $form = " return undef if $existence_test $sr ^ $existence_test $or;\n" . |
1474
|
|
|
|
|
|
|
" if ( $existence_test $sr ) { return undef unless $sr"; |
1475
|
70
|
100
|
|
|
|
166
|
if ( $self->base ) { |
1476
|
5
|
|
|
|
|
15
|
$form .= "->equals($or)"; |
1477
|
|
|
|
|
|
|
} |
1478
|
|
|
|
|
|
|
else { |
1479
|
65
|
|
|
|
|
143
|
$form .= " eq $or"; |
1480
|
|
|
|
|
|
|
} |
1481
|
70
|
|
|
|
|
398
|
return $form . " }\n"; |
1482
|
|
|
|
|
|
|
} |
1483
|
|
|
|
|
|
|
|
1484
|
|
|
|
|
|
|
package Class::Generate::List_Member; # A Member subclass for list |
1485
|
|
|
|
|
|
|
$Class::Generate::List_Member::VERSION = '1.17'; |
1486
|
14
|
|
|
14
|
|
112
|
use strict; # (array and hash) members. |
|
14
|
|
|
|
|
40
|
|
|
14
|
|
|
|
|
587
|
|
1487
|
14
|
|
|
14
|
|
84
|
use vars qw(@ISA); # accessor accepts 0-2 parameters. |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
10862
|
|
1488
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
sub member_forms { |
1491
|
61
|
|
|
61
|
|
85
|
my $self = shift; |
1492
|
61
|
|
|
|
|
79
|
my $class = $_[0]; |
1493
|
61
|
100
|
|
|
|
97
|
return $class->readonly($self->name) ? ('no_params', 'one_param') : ('no_params', 'one_param', 'two_params'); |
1494
|
|
|
|
|
|
|
} |
1495
|
|
|
|
|
|
|
sub no_params { |
1496
|
61
|
|
|
61
|
|
86
|
my $self = shift; |
1497
|
61
|
|
|
|
|
135
|
my ($class, $element, $exists, $lvalue, $values) = @_; |
1498
|
61
|
|
|
|
|
175
|
return " \$#_ == -1\tand do { return $exists ? " . $self->whole_lvalue($element) . " : () };\n"; |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
sub one_param { |
1501
|
61
|
|
|
61
|
|
83
|
my $self = shift; |
1502
|
61
|
|
|
|
|
116
|
my ($class, $element, $exists, $lvalue, $values) = @_; |
1503
|
61
|
|
|
|
|
100
|
my $form; |
1504
|
61
|
100
|
|
|
|
147
|
if ( $class->accept_refs ) { |
1505
|
59
|
|
|
|
|
195
|
$form = " \$#_ == 0\tand do {\n" . |
1506
|
|
|
|
|
|
|
"\t" . "return ($exists ? ${element}->$lvalue : undef) if ! ref \$_[0];\n"; |
1507
|
59
|
100
|
66
|
|
|
114
|
if ( $class->check_params && $class->readonly($self->name) ) { |
1508
|
2
|
|
|
|
|
7
|
$form .= "croak '" . $self->name_form($class) . "Member is read-only';\n"; |
1509
|
|
|
|
|
|
|
} |
1510
|
|
|
|
|
|
|
else { |
1511
|
57
|
50
|
|
|
|
119
|
$form .= "\t" . Class::Generate::Member_Names::substituted($self->pre) if defined $self->pre; |
1512
|
57
|
50
|
|
|
|
104
|
$form .= "\t" . $self->valid_value_test_form($class, '$_[0]') . "\n" if $class->check_params; |
1513
|
57
|
|
|
|
|
134
|
$form .= "\t" . $self->whole_lvalue($element) . ' = ' . $self->whole_lvalue('$_[0]') . ";\n"; |
1514
|
57
|
50
|
|
|
|
142
|
$form .= "\t" . Class::Generate::Member_Names::substituted($self->post) if defined $self->post; |
1515
|
57
|
50
|
33
|
|
|
107
|
$form .= "\t" . $self->assertion($class) . "\n" if defined $class->check_params && defined $self->assert; |
1516
|
57
|
|
|
|
|
107
|
$form .= "\t" . "return;\n"; |
1517
|
|
|
|
|
|
|
} |
1518
|
59
|
|
|
|
|
92
|
$form .= " };\n"; |
1519
|
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
|
else { |
1521
|
2
|
|
|
|
|
6
|
$form = " \$#_ == 0\tand do { return $exists ? ${element}->$lvalue : undef };\n" |
1522
|
|
|
|
|
|
|
} |
1523
|
61
|
|
|
|
|
154
|
return $form; |
1524
|
|
|
|
|
|
|
} |
1525
|
|
|
|
|
|
|
sub two_params { |
1526
|
59
|
|
|
59
|
|
90
|
my $self = shift; |
1527
|
59
|
|
|
|
|
119
|
my ($class, $element, $exists, $lvalue, $values) = @_; |
1528
|
59
|
|
|
|
|
102
|
my $form = ''; |
1529
|
59
|
50
|
|
|
|
121
|
$form .= Class::Generate::Member_Names::substituted($self->pre) if defined $self->pre; |
1530
|
59
|
100
|
66
|
|
|
110
|
$form .= $self->valid_element_test($class, '$_[1]') . "\n" if $class->check_params && defined $self->base; |
1531
|
59
|
|
|
|
|
154
|
$form .= "${element}->$lvalue = \$_[1];\n"; |
1532
|
59
|
50
|
|
|
|
102
|
$form .= Class::Generate::Member_Names::substituted($self->post) if defined $self->post; |
1533
|
59
|
|
|
|
|
88
|
$form .= "return;\n"; |
1534
|
59
|
|
|
|
|
165
|
return $self->maybe_guarded($form, 1, $class); |
1535
|
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
sub valid_value_form { # Return a form that tests if a |
1538
|
110
|
|
|
110
|
|
145
|
my $self = shift; # parameter is a correct list reference |
1539
|
110
|
|
|
|
|
140
|
my $param = $_[0]; # and (if relevant) if all of its |
1540
|
110
|
|
|
|
|
168
|
my $base = $self->base; # elements have the correct base type. |
1541
|
110
|
|
|
|
|
499
|
ref($self) =~ /::(\w+)_Member$/; |
1542
|
110
|
|
|
|
|
369
|
my $form = "UNIVERSAL::isa($param, '" . uc($1) . "')"; |
1543
|
110
|
100
|
|
|
|
212
|
if ( defined $base ) { |
1544
|
20
|
|
|
|
|
55
|
$form .= qq| && ! grep ! (defined \$_ && UNIVERSAL::isa(\$_, '$base')), | . $self->values($param); |
1545
|
|
|
|
|
|
|
} |
1546
|
110
|
|
|
|
|
321
|
return $form; |
1547
|
|
|
|
|
|
|
} |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
sub valid_element_test { # Return a form that dies unless an |
1550
|
10
|
|
|
10
|
|
14
|
my $self = shift; # element has the correct base type. |
1551
|
10
|
|
|
|
|
18
|
my ($class, $param) = @_; |
1552
|
10
|
|
|
|
|
16
|
return $self->invalid_value_assignment_message($class) . |
1553
|
|
|
|
|
|
|
qq| unless UNIVERSAL::isa($param, '| . $self->base . q|');|; |
1554
|
|
|
|
|
|
|
} |
1555
|
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
|
sub valid_elements_test { # Return a form that dies unless all |
1557
|
5
|
|
|
5
|
|
10
|
my $self = shift; # elements of a list are validly typed. |
1558
|
5
|
|
|
|
|
11
|
my ($class, $values) = @_; |
1559
|
5
|
|
|
|
|
10
|
my $base = $self->base; |
1560
|
5
|
|
|
|
|
11
|
return $self->invalid_value_assignment_message($class) . |
1561
|
|
|
|
|
|
|
q| unless ! grep ! UNIVERSAL::isa($_, '| . $self->base . qq|'), $values;|; |
1562
|
|
|
|
|
|
|
} |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
sub can_be_invalid { # A value for a list member can |
1565
|
153
|
|
|
153
|
|
424
|
return 1; # always be invalid: the wrong |
1566
|
|
|
|
|
|
|
} # type of list can be given. |
1567
|
|
|
|
|
|
|
|
1568
|
|
|
|
|
|
|
package Class::Generate::Array_Member; # A List subclass for array |
1569
|
|
|
|
|
|
|
$Class::Generate::Array_Member::VERSION = '1.17'; |
1570
|
14
|
|
|
14
|
|
108
|
use strict; # members. Provides the |
|
14
|
|
|
|
|
51
|
|
|
14
|
|
|
|
|
481
|
|
1571
|
14
|
|
|
14
|
|
83
|
use vars qw(@ISA); # of accessing array members. |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
10297
|
|
1572
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::List_Member); |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
sub lvalue { |
1575
|
31
|
|
|
31
|
|
52
|
my $self = shift; |
1576
|
31
|
|
|
|
|
74
|
return '[' . $_[0] . ']'; |
1577
|
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
sub whole_lvalue { |
1580
|
89
|
|
|
89
|
|
108
|
my $self = shift; |
1581
|
89
|
|
|
|
|
246
|
return '@{' . $_[0] . '}'; |
1582
|
|
|
|
|
|
|
} |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
sub values { |
1585
|
41
|
|
|
41
|
|
89
|
my $self = shift; |
1586
|
41
|
|
|
|
|
97
|
return '@{' . $_[0] . '}'; |
1587
|
|
|
|
|
|
|
} |
1588
|
|
|
|
|
|
|
|
1589
|
|
|
|
|
|
|
sub size_form { |
1590
|
31
|
|
|
31
|
|
57
|
my $self = shift; |
1591
|
31
|
|
|
|
|
121
|
my ($class, $element, $member_name, $exists) = @_; |
1592
|
31
|
|
|
|
|
158
|
return $class->sub_form($member_name, $member_name . '_size', " return $exists ? \$#{$element} : -1;\n"); |
1593
|
|
|
|
|
|
|
} |
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
sub last_form { |
1596
|
31
|
|
|
31
|
|
50
|
my $self = shift; |
1597
|
31
|
|
|
|
|
70
|
my ($class, $element, $member_name, $exists) = @_; |
1598
|
31
|
|
|
|
|
149
|
return $class->sub_form($member_name, 'last_' . $member_name, " return $exists ? $element" . "[\$#{$element}] : undef;\n"); |
1599
|
|
|
|
|
|
|
} |
1600
|
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
sub add_form { |
1602
|
30
|
|
|
30
|
|
53
|
my $self = shift; |
1603
|
30
|
|
|
|
|
65
|
my ($class, $element, $member_name, $exists) = @_; |
1604
|
30
|
|
|
|
|
48
|
my $body = ''; |
1605
|
30
|
100
|
66
|
|
|
69
|
$body .= ' ' . $self->valid_elements_test($class, '@_') . "\n" if $class->check_params && defined $self->base; |
1606
|
30
|
50
|
|
|
|
77
|
$body .= Class::Generate::Member_Names::substituted($self->pre) if defined $self->pre; |
1607
|
30
|
|
|
|
|
99
|
$body .= ' push @{' . $element . '}, @_;' . "\n"; |
1608
|
30
|
50
|
|
|
|
56
|
$body .= Class::Generate::Member_Names::substituted($self->post) if defined $self->post; |
1609
|
30
|
50
|
33
|
|
|
63
|
$body .= ' ' . $self->assertion($class) . "\n" if defined $class->check_params && defined $self->assert; |
1610
|
30
|
|
|
|
|
187
|
return $class->sub_form($member_name, 'add_' . $member_name, $body); |
1611
|
|
|
|
|
|
|
} |
1612
|
|
|
|
|
|
|
|
1613
|
|
|
|
|
|
|
sub as_var { |
1614
|
34
|
|
|
34
|
|
59
|
my $self = shift; |
1615
|
34
|
|
|
|
|
66
|
return '@' . $self->name; |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
sub method_regexp { |
1619
|
34
|
|
|
34
|
|
83
|
my $self = shift; |
1620
|
34
|
|
|
|
|
51
|
my $class = $_[0]; |
1621
|
34
|
50
|
|
|
|
81
|
return $class->include_method($self->name) ? ('@' . $self->name, '\$#?' . $self->name) : (); |
1622
|
|
|
|
|
|
|
} |
1623
|
|
|
|
|
|
|
sub accessor_names { |
1624
|
72
|
|
|
72
|
|
97
|
my $self = shift; |
1625
|
72
|
|
|
|
|
121
|
my ($class, $name) = @_; |
1626
|
72
|
|
|
|
|
261
|
my @names = ($name, "${name}_size", "last_$name", $self->SUPER::accessor_names($class, $name)); |
1627
|
72
|
100
|
|
|
|
166
|
push @names, "add_$name" if ! $class->readonly($name); |
1628
|
72
|
|
|
|
|
191
|
return grep $class->include_method($_), @names; |
1629
|
|
|
|
|
|
|
} |
1630
|
|
|
|
|
|
|
sub expected_type_form { |
1631
|
39
|
|
|
39
|
|
59
|
my $self = shift; |
1632
|
39
|
100
|
|
|
|
112
|
if ( defined $self->base ) { |
1633
|
15
|
|
|
|
|
23
|
return 'reference to array of ' . $self->base; |
1634
|
|
|
|
|
|
|
} |
1635
|
|
|
|
|
|
|
else { |
1636
|
24
|
|
|
|
|
113
|
return 'array reference'; |
1637
|
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
} |
1639
|
|
|
|
|
|
|
|
1640
|
|
|
|
|
|
|
sub copy_form { |
1641
|
30
|
|
|
30
|
|
55
|
my $self = shift; |
1642
|
30
|
|
|
|
|
66
|
my ($from, $to) = @_; |
1643
|
30
|
|
|
|
|
65
|
my $form = " $to = "; |
1644
|
30
|
100
|
|
|
|
87
|
if ( ! $self->nocopy ) { |
1645
|
29
|
|
|
|
|
58
|
$form .= '[ '; |
1646
|
29
|
100
|
|
|
|
70
|
$form .= 'map defined $_ ? $_->copy : undef, ' if $self->base; |
1647
|
29
|
|
|
|
|
79
|
$form .= "\@{$from} ]"; |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
else { |
1650
|
1
|
|
|
|
|
2
|
$form .= $from; |
1651
|
|
|
|
|
|
|
} |
1652
|
30
|
|
|
|
|
68
|
$form .= " if defined $from;\n"; |
1653
|
30
|
|
|
|
|
88
|
return $form; |
1654
|
|
|
|
|
|
|
} |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
sub equals { |
1657
|
27
|
|
|
27
|
|
47
|
my $self = shift; |
1658
|
27
|
|
|
|
|
58
|
my ($index, $existence_test) = @_; |
1659
|
27
|
|
|
|
|
83
|
my ($sr, $or) = ('$self->' . $index, '$o->' . $index); |
1660
|
27
|
|
|
|
|
238
|
my $form = " return undef if $existence_test($sr) ^ $existence_test($or);\n" . |
1661
|
|
|
|
|
|
|
" if ( $existence_test $sr ) {\n" . |
1662
|
|
|
|
|
|
|
" return undef unless (\$ub = \$#{$sr}) == \$#{$or};\n" . |
1663
|
|
|
|
|
|
|
" for ( my \$i = 0; \$i <= \$ub; \$i++ ) {\n" . |
1664
|
|
|
|
|
|
|
" return undef unless $sr" . '[$i]'; |
1665
|
27
|
100
|
|
|
|
61
|
if ( $self->base ) { |
1666
|
3
|
|
|
|
|
10
|
$form .= '->equals(' . $or . '[$i])'; |
1667
|
|
|
|
|
|
|
} |
1668
|
|
|
|
|
|
|
else { |
1669
|
24
|
|
|
|
|
64
|
$form .= ' eq ' . $or . '[$i]'; |
1670
|
|
|
|
|
|
|
} |
1671
|
27
|
|
|
|
|
165
|
return $form . ";\n\t}\n }\n"; |
1672
|
|
|
|
|
|
|
} |
1673
|
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
|
package Class::Generate::Hash_Member; # A List subclass for Hash |
1675
|
|
|
|
|
|
|
$Class::Generate::Hash_Member::VERSION = '1.17'; |
1676
|
14
|
|
|
14
|
|
95
|
use strict; # members. Provides the n_keys |
|
14
|
|
|
|
|
37
|
|
|
14
|
|
|
|
|
444
|
|
1677
|
14
|
|
|
14
|
|
75
|
use vars qw(@ISA); # specifics of accessing |
|
14
|
|
|
|
|
29
|
|
|
14
|
|
|
|
|
9877
|
|
1678
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::List_Member); # hash members. |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
sub lvalue { |
1681
|
30
|
|
|
30
|
|
55
|
my $self = shift; |
1682
|
30
|
|
|
|
|
77
|
return '{' . $_[0] . '}'; |
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
sub whole_lvalue { |
1685
|
86
|
|
|
86
|
|
105
|
my $self = shift; |
1686
|
86
|
|
|
|
|
218
|
return '%{' . $_[0] . '}'; |
1687
|
|
|
|
|
|
|
} |
1688
|
|
|
|
|
|
|
sub values { |
1689
|
40
|
|
|
40
|
|
127
|
my $self = shift; |
1690
|
40
|
|
|
|
|
99
|
return 'values %{' . $_[0] . '}'; |
1691
|
|
|
|
|
|
|
} |
1692
|
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
|
sub delete_form { |
1694
|
29
|
|
|
29
|
|
52
|
my $self = shift; |
1695
|
29
|
|
|
|
|
80
|
my ($class, $element, $member_name, $exists) = @_; |
1696
|
29
|
|
|
|
|
121
|
return $class->sub_form($member_name, 'delete_' . $member_name, " delete \@{$element}{\@_} if $exists;\n"); |
1697
|
|
|
|
|
|
|
} |
1698
|
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
|
sub keys_form { |
1700
|
29
|
|
|
29
|
|
58
|
my $self = shift; |
1701
|
29
|
|
|
|
|
81
|
my ($class, $element, $member_name, $exists) = @_; |
1702
|
29
|
|
|
|
|
146
|
return $class->sub_form($member_name, $member_name . '_keys', " return $exists ? keys \%{$element} : ();\n"); |
1703
|
|
|
|
|
|
|
} |
1704
|
|
|
|
|
|
|
sub values_form { |
1705
|
30
|
|
|
30
|
|
62
|
my $self = shift; |
1706
|
30
|
|
|
|
|
66
|
my ($class, $element, $member_name, $exists) = @_; |
1707
|
30
|
|
|
|
|
139
|
return $class->sub_form($member_name, $member_name . '_values', " return $exists ? values \%{$element} : ();\n"); |
1708
|
|
|
|
|
|
|
} |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
sub as_var { |
1711
|
32
|
|
|
32
|
|
50
|
my $self = shift; |
1712
|
32
|
|
|
|
|
57
|
return '%' . $self->name; |
1713
|
|
|
|
|
|
|
} |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
sub method_regexp { |
1716
|
32
|
|
|
32
|
|
73
|
my $self = shift; |
1717
|
32
|
|
|
|
|
52
|
my $class = $_[0]; |
1718
|
32
|
50
|
|
|
|
88
|
return $class->include_method($self->name) ? ('[%$]' . $self->name) : (); |
1719
|
|
|
|
|
|
|
} |
1720
|
|
|
|
|
|
|
sub accessor_names { |
1721
|
68
|
|
|
68
|
|
104
|
my $self = shift; |
1722
|
68
|
|
|
|
|
127
|
my ($class, $name) = @_; |
1723
|
68
|
|
|
|
|
243
|
my @names = ($name, "${name}_keys", "${name}_values", $self->SUPER::accessor_names($class, $name)); |
1724
|
68
|
100
|
|
|
|
158
|
push @names, "delete_$name" if ! $class->readonly($name); |
1725
|
68
|
|
|
|
|
181
|
return grep $class->include_method($_), @names; |
1726
|
|
|
|
|
|
|
} |
1727
|
|
|
|
|
|
|
sub expected_type_form { |
1728
|
33
|
|
|
33
|
|
48
|
my $self = shift; |
1729
|
33
|
100
|
|
|
|
75
|
if ( defined $self->base ) { |
1730
|
10
|
|
|
|
|
18
|
return 'reference to hash of ' . $self->base; |
1731
|
|
|
|
|
|
|
} |
1732
|
|
|
|
|
|
|
else { |
1733
|
23
|
|
|
|
|
101
|
return 'hash reference'; |
1734
|
|
|
|
|
|
|
} |
1735
|
|
|
|
|
|
|
} |
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
sub copy_form { |
1738
|
29
|
|
|
29
|
|
59
|
my $self = shift; |
1739
|
29
|
|
|
|
|
65
|
my ($from, $to) = @_; |
1740
|
29
|
100
|
|
|
|
126
|
if ( ! $self->nocopy ) { |
1741
|
28
|
100
|
|
|
|
60
|
if ( $self->base ) { |
1742
|
5
|
|
|
|
|
42
|
return " if ( defined $from ) {\n" . |
1743
|
|
|
|
|
|
|
"\t$to = {};\n" . |
1744
|
|
|
|
|
|
|
"\twhile ( my (\$key, \$value) = each \%{$from} ) {\n" . |
1745
|
|
|
|
|
|
|
"\t $to" . '->{$key} = defined $value ? $value->copy : undef;' . "\n" . |
1746
|
|
|
|
|
|
|
"\t}\n" . |
1747
|
|
|
|
|
|
|
" }\n"; |
1748
|
|
|
|
|
|
|
} |
1749
|
|
|
|
|
|
|
else { |
1750
|
23
|
|
|
|
|
121
|
return " $to = { \%{$from} } if defined $from;\n"; |
1751
|
|
|
|
|
|
|
} |
1752
|
|
|
|
|
|
|
} |
1753
|
|
|
|
|
|
|
else { |
1754
|
1
|
|
|
|
|
6
|
return " $to = $from if defined $from;\n"; |
1755
|
|
|
|
|
|
|
} |
1756
|
|
|
|
|
|
|
} |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
sub equals { |
1759
|
25
|
|
|
25
|
|
45
|
my $self = shift; |
1760
|
25
|
|
|
|
|
54
|
my ($index, $existence_test) = @_; |
1761
|
25
|
|
|
|
|
84
|
my ($sr, $or) = ('$self->' . $index, '$o->' . $index); |
1762
|
25
|
|
|
|
|
226
|
my $form = " return undef if $existence_test $sr ^ $existence_test $or;\n" . |
1763
|
|
|
|
|
|
|
" if ( $existence_test $sr ) {\n" . |
1764
|
|
|
|
|
|
|
' @self_keys = keys %{' . $sr . '};' . "\n" . |
1765
|
|
|
|
|
|
|
' return undef unless $#self_keys == scalar(keys %{' . $or . '}) - 1;' . "\n" . |
1766
|
|
|
|
|
|
|
' for my $k ( @self_keys ) {' . "\n" . |
1767
|
|
|
|
|
|
|
" return undef unless exists $or" . '{$k};' . "\n" . |
1768
|
|
|
|
|
|
|
' return undef if ($self_value_defined = defined ' . $sr . '{$k}) ^ defined ' . $or . '{$k};' . "\n" . |
1769
|
|
|
|
|
|
|
' if ( $self_value_defined ) { return undef unless '; |
1770
|
25
|
100
|
|
|
|
55
|
if ( $self->base ) { |
1771
|
3
|
|
|
|
|
10
|
$form .= $sr . '{$k}->equals(' . $or . '{$k})'; |
1772
|
|
|
|
|
|
|
} |
1773
|
|
|
|
|
|
|
else { |
1774
|
22
|
|
|
|
|
85
|
$form .= $sr . '{$k} eq ' . $or . '{$k}'; |
1775
|
|
|
|
|
|
|
} |
1776
|
25
|
|
|
|
|
59
|
$form .= " }\n\t}\n }\n"; |
1777
|
25
|
|
|
|
|
90
|
return $form; |
1778
|
|
|
|
|
|
|
} |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
package Class::Generate::Constructor; # The constructor is treated as a |
1781
|
|
|
|
|
|
|
$Class::Generate::Constructor::VERSION = '1.17'; |
1782
|
14
|
|
|
14
|
|
91
|
use strict; # special type of member. It includes |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
571
|
|
1783
|
14
|
|
|
14
|
|
80
|
use vars qw(@ISA); # constraints on required members. |
|
14
|
|
|
|
|
35
|
|
|
14
|
|
|
|
|
15888
|
|
1784
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Member); |
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
sub new { |
1787
|
62
|
|
|
62
|
|
141
|
my $class = shift; |
1788
|
62
|
|
|
|
|
299
|
my $self = $class->SUPER::new('new', @_); |
1789
|
62
|
|
|
|
|
249
|
return $self; |
1790
|
|
|
|
|
|
|
} |
1791
|
|
|
|
|
|
|
sub style { |
1792
|
358
|
|
|
358
|
|
481
|
my $self = shift; |
1793
|
358
|
100
|
|
|
|
944
|
return $self->{'style'} if $#_ == -1; |
1794
|
61
|
|
|
|
|
232
|
$self->{'style'} = $_[0]; |
1795
|
|
|
|
|
|
|
} |
1796
|
|
|
|
|
|
|
sub constraints { |
1797
|
52
|
|
|
52
|
|
92
|
my $self = shift; |
1798
|
52
|
100
|
|
|
|
288
|
return exists $self->{'constraints'} ? @{$self->{'constraints'}} : () if $#_ == -1; |
|
1
|
50
|
|
|
|
5
|
|
1799
|
0
|
0
|
|
|
|
0
|
return exists $self->{'constraints'} ? $self->{'constraints'}->[$_[0]] : undef if $#_ == 0; |
|
|
0
|
|
|
|
|
|
1800
|
0
|
|
|
|
|
0
|
$self->{'constraints'}->[$_[0]] = $_[1]; |
1801
|
|
|
|
|
|
|
} |
1802
|
|
|
|
|
|
|
sub add_constraints { |
1803
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1804
|
1
|
|
|
|
|
2
|
push @{$self->{'constraints'}}, @_; |
|
1
|
|
|
|
|
5
|
|
1805
|
|
|
|
|
|
|
} |
1806
|
|
|
|
|
|
|
sub constraints_size { |
1807
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1808
|
0
|
0
|
|
|
|
0
|
return exists $self->{'constraints'} ? $#{$self->{'constraints'}} : -1; |
|
0
|
|
|
|
|
0
|
|
1809
|
|
|
|
|
|
|
} |
1810
|
|
|
|
|
|
|
sub constraint_form { |
1811
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1812
|
1
|
|
|
|
|
3
|
my ($class, $style, $constraint) = @_; |
1813
|
1
|
|
|
|
|
2
|
my $param_given = $constraint; |
1814
|
1
|
|
|
|
|
5
|
$param_given =~ s/\w+/$style->existence_test($&) . ' ' . $style->ref($&)/eg; |
|
2
|
|
|
|
|
3
|
|
1815
|
1
|
|
|
|
|
3
|
$constraint =~ s/'/\\'/g; |
1816
|
1
|
|
|
|
|
4
|
return q|croak '| . $self->name_form($class) . qq|Parameter constraint "$constraint" failed' unless $param_given;|; |
1817
|
|
|
|
|
|
|
} |
1818
|
|
|
|
|
|
|
sub param_tests_form { |
1819
|
57
|
|
|
57
|
|
94
|
my $self = shift; |
1820
|
57
|
|
|
|
|
146
|
my ($class, $style) = @_; |
1821
|
57
|
|
|
|
|
122
|
my $form = ''; |
1822
|
57
|
100
|
100
|
|
|
127
|
if ( ! $class->parents && $style->can('params_check_form') ) { |
1823
|
45
|
|
|
|
|
140
|
$form .= $style->params_check_form($class, $self); |
1824
|
|
|
|
|
|
|
} |
1825
|
57
|
100
|
|
|
|
345
|
if ( ! $style->isa('Class::Generate::Own') ) { |
1826
|
52
|
|
|
|
|
193
|
my @public_members = map $class->members($_), $class->public_member_names; |
1827
|
52
|
100
|
|
|
|
282
|
for my $param_test ( map $_->param_must_be_checked($class) ? $_->param_test($class) : (), @public_members ) { |
1828
|
84
|
|
|
|
|
229
|
$form .= ' ' . $param_test . "\n"; |
1829
|
|
|
|
|
|
|
} |
1830
|
52
|
|
|
|
|
206
|
for my $constraint ( $self->constraints ) { |
1831
|
1
|
|
|
|
|
13
|
$form .= ' ' . $self->constraint_form($class, $style, $constraint) . "\n"; |
1832
|
|
|
|
|
|
|
} |
1833
|
|
|
|
|
|
|
} |
1834
|
57
|
|
|
|
|
173
|
return $form; |
1835
|
|
|
|
|
|
|
} |
1836
|
|
|
|
|
|
|
sub assertions_form { |
1837
|
57
|
|
|
57
|
|
100
|
my $self = shift; |
1838
|
57
|
|
|
|
|
93
|
my $class = $_[0]; |
1839
|
57
|
|
|
|
|
99
|
my $form = ''; |
1840
|
57
|
100
|
66
|
|
|
127
|
$form .= ' ' . $self->assertion($class) . "\n" if defined $class->check_params && defined $self->assert; |
1841
|
57
|
|
|
|
|
163
|
for my $member ( grep defined $_->assert, $class->members_values ) { |
1842
|
3
|
|
|
|
|
20
|
$form .= ' ' . $member->assertion($class) . "\n"; |
1843
|
|
|
|
|
|
|
} |
1844
|
57
|
|
|
|
|
148
|
return $form; |
1845
|
|
|
|
|
|
|
} |
1846
|
|
|
|
|
|
|
sub form { |
1847
|
57
|
|
|
57
|
|
115
|
my $self = shift; |
1848
|
57
|
|
|
|
|
97
|
my $class = $_[0]; |
1849
|
57
|
|
|
|
|
155
|
my $style = $self->style; |
1850
|
57
|
|
|
|
|
146
|
my ($iv, $cv) = ($class->instance_var, $class->class_var); |
1851
|
57
|
|
|
|
|
108
|
my $form; |
1852
|
57
|
100
|
|
|
|
264
|
$form = "sub new {\n" . |
1853
|
|
|
|
|
|
|
" my $cv = " . |
1854
|
|
|
|
|
|
|
($class->nfi ? 'do { my $proto = shift; ref $proto || $proto }' : 'shift') . |
1855
|
|
|
|
|
|
|
";\n"; |
1856
|
57
|
100
|
66
|
|
|
173
|
if ( $class->check_params && $class->virtual ) { |
1857
|
1
|
|
|
|
|
3
|
$form .= q| croak '| . $self->name_form($class) . q|Virtual class' unless $class ne '| . $class->name . qq|';\n|; |
1858
|
|
|
|
|
|
|
} |
1859
|
57
|
100
|
66
|
|
|
189
|
$form .= $style->init_form($class, $self) if ! $class->can_assign_all_params && |
1860
|
|
|
|
|
|
|
$style->can('init_form'); |
1861
|
57
|
50
|
|
|
|
151
|
$form .= $self->param_tests_form($class, $style) if $class->check_params; |
1862
|
57
|
100
|
|
|
|
159
|
if ( defined $class->parents ) { |
1863
|
11
|
|
|
|
|
48
|
$form .= $style->self_from_super_form($class); |
1864
|
|
|
|
|
|
|
} |
1865
|
|
|
|
|
|
|
else { |
1866
|
46
|
|
|
|
|
204
|
$form .= ' my ' . $iv . ' = ' . $class->base . ";\n" . |
1867
|
|
|
|
|
|
|
' bless ' . $iv . ', ' . $cv . ";\n"; |
1868
|
|
|
|
|
|
|
} |
1869
|
57
|
50
|
|
|
|
157
|
if ( ! $class->can_assign_all_params ) { |
1870
|
57
|
100
|
|
|
|
363
|
$form .= $class->size_establishment($iv) if $class->can('size_establishment'); |
1871
|
57
|
100
|
|
|
|
281
|
if ( ! $style->isa('Class::Generate::Own') ) { |
1872
|
52
|
|
|
|
|
136
|
for my $name ( $class->public_member_names ) { |
1873
|
118
|
|
|
|
|
253
|
$form .= $class->members($name)->param_assignment_form($class, $style); |
1874
|
|
|
|
|
|
|
} |
1875
|
|
|
|
|
|
|
} |
1876
|
|
|
|
|
|
|
} |
1877
|
57
|
|
|
|
|
249
|
$form .= $class->protected_members_info_form; |
1878
|
57
|
|
100
|
|
|
162
|
for my $member ( grep(($style->isa('Class::Generate::Own') || $class->protected($_->name) || $class->private($_->name)) && |
1879
|
|
|
|
|
|
|
defined $_->default, $class->members_values) ) { |
1880
|
1
|
|
|
|
|
9
|
$form .= $member->default_assignment_form($class); |
1881
|
|
|
|
|
|
|
} |
1882
|
57
|
100
|
|
|
|
164
|
$form .= Class::Generate::Member_Names::substituted($self->post) if defined $self->post; |
1883
|
57
|
50
|
|
|
|
148
|
$form .= $self->assertions_form($class) if $class->check_params; |
1884
|
57
|
|
|
|
|
177
|
$form .= ' return ' . $iv . ";\n" . |
1885
|
|
|
|
|
|
|
"}\n"; |
1886
|
57
|
|
|
|
|
260
|
return $form; |
1887
|
|
|
|
|
|
|
} |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
package Class::Generate::Method; # A user-defined method, |
1890
|
|
|
|
|
|
|
$Class::Generate::Method::VERSION = '1.17'; |
1891
|
|
|
|
|
|
|
# with a name and body. |
1892
|
|
|
|
|
|
|
sub new { |
1893
|
28
|
|
|
28
|
|
51
|
my $class = shift; |
1894
|
28
|
|
|
|
|
74
|
my $self = { name => $_[0], body => $_[1] }; |
1895
|
28
|
|
|
|
|
59
|
bless $self, $class; |
1896
|
28
|
|
|
|
|
54
|
return $self; |
1897
|
|
|
|
|
|
|
} |
1898
|
|
|
|
|
|
|
|
1899
|
|
|
|
|
|
|
sub name { |
1900
|
139
|
|
|
139
|
|
181
|
my $self = shift; |
1901
|
139
|
|
|
|
|
326
|
return $self->{'name'}; |
1902
|
|
|
|
|
|
|
} |
1903
|
|
|
|
|
|
|
|
1904
|
|
|
|
|
|
|
sub body { |
1905
|
77
|
|
|
77
|
|
106
|
my $self = shift; |
1906
|
77
|
|
|
|
|
226
|
return $self->{'body'}; |
1907
|
|
|
|
|
|
|
} |
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
sub comment { |
1910
|
26
|
|
|
26
|
|
37
|
my $self = shift; |
1911
|
26
|
50
|
|
|
|
110
|
return $self->{'comment'} if $#_ == -1; |
1912
|
0
|
|
|
|
|
0
|
$self->{'comment'} = $_[0]; |
1913
|
|
|
|
|
|
|
} |
1914
|
|
|
|
|
|
|
|
1915
|
|
|
|
|
|
|
sub form { |
1916
|
26
|
|
|
26
|
|
44
|
my $self = shift; |
1917
|
26
|
|
|
|
|
40
|
my $class = $_[0]; |
1918
|
26
|
|
|
|
|
44
|
my $form = ''; |
1919
|
26
|
50
|
|
|
|
69
|
$form .= Class::Generate::Support::comment_form($self->comment) if defined $self->comment; |
1920
|
26
|
|
|
|
|
62
|
$form .= $class->sub_form($self->name, $self->name, Class::Generate::Member_Names::substituted($self->body)); |
1921
|
26
|
|
|
|
|
100
|
return $form; |
1922
|
|
|
|
|
|
|
} |
1923
|
|
|
|
|
|
|
|
1924
|
|
|
|
|
|
|
package Class::Generate::Class_Method; # A user-defined class method, |
1925
|
|
|
|
|
|
|
$Class::Generate::Class_Method::VERSION = '1.17'; |
1926
|
14
|
|
|
14
|
|
107
|
use strict; # which may specify objects |
|
14
|
|
|
|
|
40
|
|
|
14
|
|
|
|
|
1843
|
|
1927
|
14
|
|
|
14
|
|
83
|
use vars qw(@ISA); # of the class used within its |
|
14
|
|
|
|
|
38
|
|
|
14
|
|
|
|
|
3081
|
|
1928
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Method); # body. |
1929
|
|
|
|
|
|
|
|
1930
|
|
|
|
|
|
|
sub objects { |
1931
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
1932
|
1
|
50
|
|
|
|
7
|
return exists $self->{'objects'} ? @{$self->{'objects'}} : () if $#_ == -1; |
|
0
|
50
|
|
|
|
0
|
|
1933
|
0
|
0
|
|
|
|
0
|
return exists $self->{'objects'} ? $self->{'objects'}->[$_[0]] : undef if $#_ == 0; |
|
|
0
|
|
|
|
|
|
1934
|
0
|
|
|
|
|
0
|
$self->{'objects'}->[$_[0]] = $_[1]; |
1935
|
|
|
|
|
|
|
} |
1936
|
|
|
|
|
|
|
sub add_objects { |
1937
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1938
|
0
|
|
|
|
|
0
|
push @{$self->{'objects'}}, @_; |
|
0
|
|
|
|
|
0
|
|
1939
|
|
|
|
|
|
|
} |
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
sub form { |
1942
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
1943
|
2
|
|
|
|
|
4
|
my $class = $_[0]; |
1944
|
2
|
|
|
|
|
5
|
return $class->class_sub_form($self->name, Class::Generate::Member_Names::substituted_in_class_method($self)); |
1945
|
|
|
|
|
|
|
} |
1946
|
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
|
package Class::Generate::Class; # A virtual class describing |
1948
|
|
|
|
|
|
|
$Class::Generate::Class::VERSION = '1.17'; |
1949
|
14
|
|
|
14
|
|
112
|
use strict; # a user-specified class. |
|
14
|
|
|
|
|
48
|
|
|
14
|
|
|
|
|
50104
|
|
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
sub new { |
1952
|
62
|
|
|
62
|
|
134
|
my $class = shift; |
1953
|
62
|
|
|
|
|
391
|
my $self = { name => shift, @_ }; |
1954
|
62
|
|
|
|
|
147
|
bless $self, $class; |
1955
|
62
|
|
|
|
|
179
|
return $self; |
1956
|
|
|
|
|
|
|
} |
1957
|
|
|
|
|
|
|
|
1958
|
|
|
|
|
|
|
sub name { |
1959
|
684
|
|
|
684
|
|
878
|
my $self = shift; |
1960
|
684
|
|
|
|
|
2704
|
return $self->{'name'}; |
1961
|
|
|
|
|
|
|
} |
1962
|
|
|
|
|
|
|
sub parents { |
1963
|
815
|
|
|
815
|
|
1125
|
my $self = shift; |
1964
|
815
|
100
|
|
|
|
3144
|
return exists $self->{'parents'} ? @{$self->{'parents'}} : () if $#_ == -1; |
|
213
|
50
|
|
|
|
1075
|
|
1965
|
0
|
0
|
|
|
|
0
|
return exists $self->{'parents'} ? $self->{'parents'}->[$_[0]] : undef if $#_ == 0; |
|
|
0
|
|
|
|
|
|
1966
|
0
|
|
|
|
|
0
|
$self->{'parents'}->[$_[0]] = $_[1]; |
1967
|
|
|
|
|
|
|
} |
1968
|
|
|
|
|
|
|
sub add_parents { |
1969
|
15
|
|
|
15
|
|
40
|
my $self = shift; |
1970
|
15
|
|
|
|
|
31
|
push @{$self->{'parents'}}, @_; |
|
15
|
|
|
|
|
74
|
|
1971
|
|
|
|
|
|
|
} |
1972
|
|
|
|
|
|
|
sub members { |
1973
|
725
|
|
|
725
|
|
936
|
my $self = shift; |
1974
|
725
|
100
|
|
|
|
1494
|
return exists $self->{'members'} ? %{$self->{'members'}} : () if $#_ == -1; |
|
52
|
100
|
|
|
|
319
|
|
1975
|
664
|
100
|
|
|
|
2486
|
return exists $self->{'members'} ? $self->{'members'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
1976
|
133
|
|
|
|
|
313
|
$self->{'members'}->{$_[0]} = $_[1]; |
1977
|
|
|
|
|
|
|
} |
1978
|
|
|
|
|
|
|
sub members_keys { |
1979
|
490
|
|
|
490
|
|
611
|
my $self = shift; |
1980
|
490
|
100
|
|
|
|
911
|
return exists $self->{'members'} ? keys %{$self->{'members'}} : (); |
|
434
|
|
|
|
|
1493
|
|
1981
|
|
|
|
|
|
|
} |
1982
|
|
|
|
|
|
|
sub members_values { |
1983
|
653
|
|
|
653
|
|
883
|
my $self = shift; |
1984
|
653
|
100
|
|
|
|
1212
|
return exists $self->{'members'} ? values %{$self->{'members'}} : (); |
|
574
|
|
|
|
|
2134
|
|
1985
|
|
|
|
|
|
|
} |
1986
|
|
|
|
|
|
|
sub user_defined_methods { |
1987
|
161
|
|
|
161
|
|
263
|
my $self = shift; |
1988
|
161
|
100
|
|
|
|
572
|
return exists $self->{'udm'} ? %{$self->{'udm'}} : () if $#_ == -1; |
|
13
|
100
|
|
|
|
186
|
|
1989
|
100
|
100
|
|
|
|
653
|
return exists $self->{'udm'} ? $self->{'udm'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
1990
|
28
|
|
|
|
|
75
|
$self->{'udm'}->{$_[0]} = $_[1]; |
1991
|
|
|
|
|
|
|
} |
1992
|
|
|
|
|
|
|
sub user_defined_methods_keys { |
1993
|
200
|
|
|
200
|
|
320
|
my $self = shift; |
1994
|
200
|
100
|
|
|
|
591
|
return exists $self->{'udm'} ? keys %{$self->{'udm'}} : (); |
|
46
|
|
|
|
|
229
|
|
1995
|
|
|
|
|
|
|
} |
1996
|
|
|
|
|
|
|
sub user_defined_methods_values { |
1997
|
311
|
|
|
311
|
|
441
|
my $self = shift; |
1998
|
311
|
100
|
|
|
|
872
|
return exists $self->{'udm'} ? values %{$self->{'udm'}} : (); |
|
70
|
|
|
|
|
395
|
|
1999
|
|
|
|
|
|
|
} |
2000
|
|
|
|
|
|
|
sub class_vars { |
2001
|
123
|
|
|
123
|
|
210
|
my $self = shift; |
2002
|
123
|
100
|
|
|
|
476
|
return exists $self->{'class_vars'} ? @{$self->{'class_vars'}} : () if $#_ == -1; |
|
3
|
50
|
|
|
|
10
|
|
2003
|
0
|
0
|
|
|
|
0
|
return exists $self->{'class_vars'} ? $self->{'class_vars'}->[$_[0]] : undef if $#_ == 0; |
|
|
0
|
|
|
|
|
|
2004
|
0
|
|
|
|
|
0
|
$self->{'class_vars'}->[$_[0]] = $_[1]; |
2005
|
|
|
|
|
|
|
} |
2006
|
|
|
|
|
|
|
sub add_class_vars { |
2007
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
2008
|
1
|
|
|
|
|
3
|
push @{$self->{'class_vars'}}, @_; |
|
1
|
|
|
|
|
5
|
|
2009
|
|
|
|
|
|
|
} |
2010
|
|
|
|
|
|
|
sub use_packages { |
2011
|
126
|
|
|
126
|
|
215
|
my $self = shift; |
2012
|
126
|
100
|
|
|
|
540
|
return exists $self->{'use_packages'} ? @{$self->{'use_packages'}} : () if $#_ == -1; |
|
12
|
50
|
|
|
|
108
|
|
2013
|
0
|
0
|
|
|
|
0
|
return exists $self->{'use_packages'} ? $self->{'use_packages'}->[$_[0]] : undef if $#_ == 0; |
|
|
0
|
|
|
|
|
|
2014
|
0
|
|
|
|
|
0
|
$self->{'use_packages'}->[$_[0]] = $_[1]; |
2015
|
|
|
|
|
|
|
} |
2016
|
|
|
|
|
|
|
sub add_use_packages { |
2017
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
2018
|
4
|
|
|
|
|
8
|
push @{$self->{'use_packages'}}, @_; |
|
4
|
|
|
|
|
15
|
|
2019
|
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
|
sub excluded_methods_regexp { |
2021
|
1843
|
|
|
1843
|
|
1958
|
my $self = shift; |
2022
|
1843
|
100
|
|
|
|
3770
|
return $self->{'em'} if $#_ == -1; |
2023
|
7
|
|
|
|
|
23
|
$self->{'em'} = $_[0]; |
2024
|
|
|
|
|
|
|
} |
2025
|
|
|
|
|
|
|
sub private { |
2026
|
2244
|
|
|
2244
|
|
2814
|
my $self = shift; |
2027
|
2244
|
100
|
|
|
|
3979
|
return exists $self->{'private'} ? %{$self->{'private'}} : () if $#_ == -1; |
|
4
|
100
|
|
|
|
17
|
|
2028
|
2183
|
100
|
|
|
|
7924
|
return exists $self->{'private'} ? $self->{'private'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
2029
|
6
|
|
|
|
|
30
|
$self->{'private'}->{$_[0]} = $_[1]; |
2030
|
|
|
|
|
|
|
} |
2031
|
|
|
|
|
|
|
sub protected { |
2032
|
1675
|
|
|
1675
|
|
2104
|
my $self = shift; |
2033
|
1675
|
100
|
|
|
|
2750
|
return exists $self->{'protected'} ? %{$self->{'protected'}} : () if $#_ == -1; |
|
4
|
100
|
|
|
|
17
|
|
2034
|
1614
|
100
|
|
|
|
5563
|
return exists $self->{'protected'} ? $self->{'protected'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
2035
|
9
|
|
|
|
|
40
|
$self->{'protected'}->{$_[0]} = $_[1]; |
2036
|
|
|
|
|
|
|
} |
2037
|
|
|
|
|
|
|
sub required { |
2038
|
681
|
|
|
681
|
|
908
|
my $self = shift; |
2039
|
681
|
0
|
|
|
|
1133
|
return exists $self->{'required'} ? %{$self->{'required'}} : () if $#_ == -1; |
|
0
|
50
|
|
|
|
0
|
|
2040
|
681
|
100
|
|
|
|
2973
|
return exists $self->{'required'} ? $self->{'required'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
2041
|
34
|
|
|
|
|
183
|
$self->{'required'}->{$_[0]} = $_[1]; |
2042
|
|
|
|
|
|
|
} |
2043
|
|
|
|
|
|
|
sub readonly { |
2044
|
743
|
|
|
743
|
|
936
|
my $self = shift; |
2045
|
743
|
0
|
|
|
|
1302
|
return exists $self->{'readonly'} ? %{$self->{'readonly'}} : () if $#_ == -1; |
|
0
|
50
|
|
|
|
0
|
|
2046
|
743
|
100
|
|
|
|
3069
|
return exists $self->{'readonly'} ? $self->{'readonly'}->{$_[0]} : undef if $#_ == 0; |
|
|
100
|
|
|
|
|
|
2047
|
26
|
|
|
|
|
136
|
$self->{'readonly'}->{$_[0]} = $_[1]; |
2048
|
|
|
|
|
|
|
} |
2049
|
|
|
|
|
|
|
sub constructor { |
2050
|
491
|
|
|
491
|
|
655
|
my $self = shift; |
2051
|
491
|
100
|
|
|
|
1523
|
return $self->{'constructor'} if $#_ == -1; |
2052
|
62
|
|
|
|
|
180
|
$self->{'constructor'} = $_[0]; |
2053
|
|
|
|
|
|
|
} |
2054
|
|
|
|
|
|
|
sub virtual { |
2055
|
66
|
|
|
66
|
|
122
|
my $self = shift; |
2056
|
66
|
50
|
|
|
|
347
|
return $self->{'virtual'} if $#_ == -1; |
2057
|
0
|
|
|
|
|
0
|
$self->{'virtual'} = $_[0]; |
2058
|
|
|
|
|
|
|
} |
2059
|
|
|
|
|
|
|
sub comment { |
2060
|
62
|
|
|
62
|
|
124
|
my $self = shift; |
2061
|
62
|
50
|
|
|
|
307
|
return $self->{'comment'} if $#_ == -1; |
2062
|
0
|
|
|
|
|
0
|
$self->{'comment'} = $_[0]; |
2063
|
|
|
|
|
|
|
} |
2064
|
|
|
|
|
|
|
sub accept_refs { |
2065
|
61
|
|
|
61
|
|
85
|
my $self = shift; |
2066
|
61
|
|
|
|
|
132
|
return $self->{'accept_refs'}; |
2067
|
|
|
|
|
|
|
} |
2068
|
|
|
|
|
|
|
sub strict { |
2069
|
122
|
|
|
122
|
|
192
|
my $self = shift; |
2070
|
122
|
|
|
|
|
400
|
return $self->{'strict'}; |
2071
|
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
sub nfi { |
2073
|
57
|
|
|
57
|
|
127
|
my $self = shift; |
2074
|
57
|
|
|
|
|
225
|
return $self->{'nfi'}; |
2075
|
|
|
|
|
|
|
} |
2076
|
|
|
|
|
|
|
sub warnings { |
2077
|
61
|
|
|
61
|
|
113
|
my $self = shift; |
2078
|
61
|
50
|
|
|
|
181
|
return $self->{'warnings'} if $#_ == -1; |
2079
|
61
|
|
|
|
|
186
|
$self->{'warnings'} = $_[0]; |
2080
|
|
|
|
|
|
|
} |
2081
|
|
|
|
|
|
|
sub check_params { |
2082
|
1318
|
|
|
1318
|
|
1570
|
my $self = shift; |
2083
|
1318
|
100
|
|
|
|
5764
|
return $self->{'check_params'} if $#_ == -1; |
2084
|
61
|
|
|
|
|
147
|
$self->{'check_params'} = $_[0]; |
2085
|
|
|
|
|
|
|
} |
2086
|
|
|
|
|
|
|
sub instance_methods { |
2087
|
2
|
|
|
2
|
|
5
|
my $self = shift; |
2088
|
2
|
|
|
|
|
6
|
return grep ! $_->isa('Class::Generate::Class_Method'), $self->user_defined_methods_values; |
2089
|
|
|
|
|
|
|
} |
2090
|
|
|
|
|
|
|
sub class_methods { |
2091
|
61
|
|
|
61
|
|
105
|
my $self = shift; |
2092
|
61
|
|
|
|
|
220
|
return grep $_->isa('Class::Generate::Class_Method'), $self->user_defined_methods_values; |
2093
|
|
|
|
|
|
|
} |
2094
|
|
|
|
|
|
|
sub include_method { |
2095
|
1714
|
|
|
1714
|
|
2092
|
my $self = shift; |
2096
|
1714
|
|
|
|
|
1938
|
my $method_name = $_[0]; |
2097
|
1714
|
|
|
|
|
2325
|
my $r = $self->excluded_methods_regexp; |
2098
|
1714
|
|
100
|
|
|
5429
|
return ! defined $r || $method_name !~ m/$r/; |
2099
|
|
|
|
|
|
|
} |
2100
|
|
|
|
|
|
|
sub member_methods_form { # Return a form containing methods for all |
2101
|
61
|
|
|
61
|
|
107
|
my $self = shift; # non-private members in the class, plus |
2102
|
61
|
|
|
|
|
122
|
my $form = ''; # private members used in class methods. |
2103
|
61
|
|
|
|
|
193
|
for my $element ( $self->public_member_names, $self->protected_member_names, $self->private_members_used_in_user_defined_code ) { |
2104
|
132
|
|
|
|
|
304
|
$form .= $self->members($element)->form($self); |
2105
|
|
|
|
|
|
|
} |
2106
|
61
|
100
|
|
|
|
218
|
$form .= "\n" if $form ne ''; |
2107
|
61
|
|
|
|
|
303
|
return $form; |
2108
|
|
|
|
|
|
|
} |
2109
|
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
|
sub user_defined_methods_form { # Return a form containing all |
2111
|
61
|
|
|
61
|
|
109
|
my $self = shift; # user-defined methods. |
2112
|
61
|
|
|
|
|
159
|
my $form = join('', map($_->form($self), $self->user_defined_methods_values)); |
2113
|
61
|
100
|
|
|
|
275
|
return length $form > 0 ? $form . "\n" : ''; |
2114
|
|
|
|
|
|
|
} |
2115
|
|
|
|
|
|
|
|
2116
|
|
|
|
|
|
|
sub warnings_pragmas { # Return an array containing the |
2117
|
122
|
|
|
122
|
|
180
|
my $self = shift; # warnings pragmas for the class. |
2118
|
122
|
|
|
|
|
231
|
my $w = $self->{'warnings'}; |
2119
|
122
|
50
|
|
|
|
296
|
return () if ! defined $w; |
2120
|
122
|
50
|
|
|
|
237
|
return ('no warnings;') if ! $w; |
2121
|
122
|
50
|
|
|
|
837
|
return ('use warnings;') if $w =~ /^\d+$/; |
2122
|
0
|
0
|
|
|
|
0
|
return ("use warnings $w;") if ! ref $w; |
2123
|
|
|
|
|
|
|
|
2124
|
0
|
|
|
|
|
0
|
my @pragmas; |
2125
|
0
|
|
|
|
|
0
|
for ( my $i = 0; $i <= $#$w; $i += 2 ) { |
2126
|
0
|
|
|
|
|
0
|
my ($key, $value) = ($$w[$i], $$w[$i+1]); |
2127
|
0
|
0
|
0
|
|
|
0
|
if ( $key eq 'register' ) { |
|
|
0
|
|
|
|
|
|
2128
|
0
|
0
|
|
|
|
0
|
push @pragmas, 'use warnings::register;' if $value; |
2129
|
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
|
elsif ( defined $value && $value ) { |
2131
|
0
|
0
|
|
|
|
0
|
if ( $value =~ /^\d+$/ ) { |
2132
|
0
|
|
|
|
|
0
|
push @pragmas, $key . ' warnings;'; |
2133
|
|
|
|
|
|
|
} |
2134
|
|
|
|
|
|
|
else { |
2135
|
0
|
|
|
|
|
0
|
push @pragmas, $key . ' warnings ' . $value . ';'; |
2136
|
|
|
|
|
|
|
} |
2137
|
|
|
|
|
|
|
} |
2138
|
|
|
|
|
|
|
} |
2139
|
0
|
|
|
|
|
0
|
return @pragmas; |
2140
|
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
|
|
2142
|
|
|
|
|
|
|
sub warnings_form { # Return a form representing the |
2143
|
61
|
|
|
61
|
|
100
|
my $self = shift; # warnings pragmas for a class. |
2144
|
61
|
|
|
|
|
147
|
my @warnings_pragmas = $self->warnings_pragmas; |
2145
|
61
|
50
|
|
|
|
309
|
return @warnings_pragmas ? join("\n", @warnings_pragmas) . "\n" : ''; |
2146
|
|
|
|
|
|
|
} |
2147
|
|
|
|
|
|
|
|
2148
|
|
|
|
|
|
|
sub form { # Return a form representing |
2149
|
61
|
|
|
61
|
|
118
|
my $self = shift; # a class. |
2150
|
61
|
|
|
|
|
89
|
my $form; |
2151
|
61
|
|
|
|
|
151
|
$form = 'package ' . $self->name . ";\n"; |
2152
|
61
|
50
|
|
|
|
156
|
$form .= "use strict;\n" if $self->strict; |
2153
|
61
|
100
|
|
|
|
167
|
$form .= join("\n", map("use $_;", $self->use_packages)) . "\n" if $self->use_packages; |
2154
|
61
|
50
|
|
|
|
233
|
$form .= "use Carp;\n" if defined $self->{'check_params'}; |
2155
|
61
|
|
|
|
|
214
|
$form .= $self->warnings_form; |
2156
|
61
|
|
|
|
|
236
|
$form .= Class::Generate::Class_Holder::form($self); |
2157
|
61
|
|
|
|
|
176
|
$form .= "\n"; |
2158
|
61
|
100
|
|
|
|
265
|
$form .= Class::Generate::Support::comment_form($self->comment) if defined $self->comment; |
2159
|
61
|
100
|
|
|
|
158
|
$form .= $self->isa_decl_form if $self->parents; |
2160
|
61
|
100
|
|
|
|
189
|
$form .= $self->private_methods_decl_form if grep $self->private($_), $self->user_defined_methods_keys; |
2161
|
61
|
100
|
|
|
|
249
|
$form .= $self->private_members_decl_form if $self->private_members_used_in_user_defined_code; |
2162
|
61
|
100
|
|
|
|
183
|
$form .= $self->protected_methods_decl_form if grep $self->protected($_), $self->user_defined_methods_keys; |
2163
|
61
|
100
|
|
|
|
157
|
$form .= $self->protected_members_decl_form if grep $self->protected($_), $self->members_keys; |
2164
|
61
|
100
|
|
|
|
186
|
$form .= join("\n", map(class_var_form($_), $self->class_vars)) . "\n\n" if $self->class_vars; |
2165
|
61
|
100
|
|
|
|
223
|
$form .= $self->constructor->form($self) if $self->needs_constructor; |
2166
|
61
|
|
|
|
|
264
|
$form .= $self->member_methods_form; |
2167
|
61
|
|
|
|
|
275
|
$form .= $self->user_defined_methods_form; |
2168
|
61
|
|
|
|
|
165
|
my $emr = $self->excluded_methods_regexp; |
2169
|
61
|
100
|
100
|
|
|
440
|
$form .= $self->copy_form if ! defined $emr || 'copy' !~ m/$emr/; |
2170
|
61
|
50
|
100
|
|
|
423
|
$form .= $self->equals_form if (! defined $emr || 'equals' !~ m/$emr/) && |
|
|
|
66
|
|
|
|
|
2171
|
|
|
|
|
|
|
! defined $self->user_defined_methods('equals'); |
2172
|
61
|
|
|
|
|
228
|
return $form; |
2173
|
|
|
|
|
|
|
} |
2174
|
|
|
|
|
|
|
|
2175
|
|
|
|
|
|
|
sub class_var_form { # Return a form for declaring a class |
2176
|
1
|
|
|
1
|
|
2
|
my $var_spec = $_[0]; # variable. Account for an initial value. |
2177
|
1
|
50
|
|
|
|
6
|
return "my $var_spec;" if ! ref $var_spec; |
2178
|
0
|
|
|
|
|
0
|
return map { my $value = $$var_spec{$_}; |
|
0
|
|
|
|
|
0
|
|
2179
|
0
|
0
|
|
|
|
0
|
"my $_ = " . (ref $value ? substr($_, 0, 1) . "{$value}" : $value) . ';' |
2180
|
|
|
|
|
|
|
} keys %$var_spec; |
2181
|
|
|
|
|
|
|
} |
2182
|
|
|
|
|
|
|
|
2183
|
|
|
|
|
|
|
sub isa_decl_form { |
2184
|
15
|
|
|
15
|
|
43
|
my $self = shift; |
2185
|
15
|
50
|
|
|
|
52
|
my @parent_names = map ! ref $_ ? $_ : $_->name, $self->parents; |
2186
|
15
|
|
|
|
|
84
|
return "use vars qw(\@ISA);\n" . |
2187
|
|
|
|
|
|
|
'@ISA = qw(' . join(' ', @parent_names) . ");\n"; |
2188
|
|
|
|
|
|
|
} |
2189
|
|
|
|
|
|
|
|
2190
|
|
|
|
|
|
|
sub sub_form { # Return a declaration for a sub, as an |
2191
|
426
|
|
|
426
|
|
553
|
my $self = shift; # assignment to a variable if not public. |
2192
|
426
|
|
|
|
|
724
|
my ($element_name, $sub_name, $body) = @_; |
2193
|
426
|
|
|
|
|
504
|
my ($form, $not_public); |
2194
|
426
|
|
100
|
|
|
708
|
$not_public = $self->private($element_name) || $self->protected($element_name); |
2195
|
426
|
100
|
|
|
|
1109
|
$form = ($not_public ? "\$$sub_name = sub" : "sub $sub_name") . " {\n" . |
2196
|
|
|
|
|
|
|
' my ' . $self->instance_var . " = shift;\n" . |
2197
|
|
|
|
|
|
|
$body . |
2198
|
|
|
|
|
|
|
'}'; |
2199
|
426
|
100
|
|
|
|
795
|
$form .= ';' if $not_public; |
2200
|
426
|
|
|
|
|
1437
|
return $form . "\n"; |
2201
|
|
|
|
|
|
|
} |
2202
|
|
|
|
|
|
|
|
2203
|
|
|
|
|
|
|
sub class_sub_form { # Ditto, but for a class method. |
2204
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
2205
|
2
|
|
|
|
|
5
|
my ($method_name, $body) = @_; |
2206
|
2
|
|
|
|
|
4
|
my ($form, $not_public); |
2207
|
2
|
|
33
|
|
|
5
|
$not_public = $self->private($method_name) || $self->protected($method_name); |
2208
|
2
|
50
|
|
|
|
11
|
$form = ($not_public ? "\$$method_name = sub" : "sub $method_name") . " {\n" . |
2209
|
|
|
|
|
|
|
' my ' . $self->class_var . " = shift;\n" . |
2210
|
|
|
|
|
|
|
$body . |
2211
|
|
|
|
|
|
|
'}'; |
2212
|
2
|
50
|
|
|
|
14
|
$form .= ';' if $not_public; |
2213
|
2
|
|
|
|
|
10
|
return $form . "\n"; |
2214
|
|
|
|
|
|
|
} |
2215
|
|
|
|
|
|
|
|
2216
|
|
|
|
|
|
|
sub private_methods_decl_form { # Private methods are implemented as CODE refs. |
2217
|
1
|
|
|
1
|
|
2
|
my $self = shift; # Return a form declaring the variables to hold them. |
2218
|
1
|
|
|
|
|
3
|
my @private_methods = grep $self->private($_), $self->user_defined_methods_keys; |
2219
|
1
|
|
|
|
|
6
|
return Class::Generate::Support::my_decl_form(map "\$$_", @private_methods); |
2220
|
|
|
|
|
|
|
} |
2221
|
|
|
|
|
|
|
|
2222
|
|
|
|
|
|
|
sub private_members_used_in_user_defined_code { # Return the names of all private |
2223
|
124
|
|
|
124
|
|
219
|
my $self = shift; # members that appear in user-defined code. |
2224
|
124
|
|
|
|
|
264
|
my @private_members = grep $self->private($_), $self->members_keys; |
2225
|
124
|
100
|
|
|
|
394
|
return () if ! @private_members; |
2226
|
8
|
|
|
|
|
23
|
my $member_regexp = join '|', @private_members; |
2227
|
8
|
|
|
|
|
13
|
my %private_members; |
2228
|
8
|
|
|
|
|
18
|
for my $code ( map($_->body, $self->user_defined_methods_values), |
2229
|
|
|
|
|
|
|
grep(defined $_, (map(($_->pre, $_->post, $_->assert), $self->members_values), |
2230
|
|
|
|
|
|
|
map(($_->post, $_->assert), $self->constructor))) ) { |
2231
|
21
|
|
|
|
|
147
|
while ( $code =~ /($member_regexp)/g ) { |
2232
|
66
|
|
|
|
|
209
|
$private_members{$1}++; |
2233
|
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
|
} |
2235
|
8
|
|
|
|
|
53
|
return keys %private_members; |
2236
|
|
|
|
|
|
|
} |
2237
|
|
|
|
|
|
|
|
2238
|
|
|
|
|
|
|
sub nonpublic_members_decl_form { |
2239
|
6
|
|
|
6
|
|
14
|
my $self = shift; |
2240
|
6
|
|
|
|
|
19
|
my @members = @_; |
2241
|
6
|
|
|
|
|
23
|
my @accessor_names = map($_->accessor_names($self, $_->name), @members); |
2242
|
6
|
|
|
|
|
57
|
return Class::Generate::Support::my_decl_form(map "\$$_", @accessor_names); |
2243
|
|
|
|
|
|
|
} |
2244
|
|
|
|
|
|
|
|
2245
|
|
|
|
|
|
|
sub private_members_decl_form { |
2246
|
2
|
|
|
2
|
|
13
|
my $self = shift; |
2247
|
2
|
|
|
|
|
10
|
return $self->nonpublic_members_decl_form(map $self->members($_), $self->private_members_used_in_user_defined_code); |
2248
|
|
|
|
|
|
|
} |
2249
|
|
|
|
|
|
|
|
2250
|
|
|
|
|
|
|
sub protected_methods_decl_form { |
2251
|
1
|
|
|
1
|
|
5
|
my $self = shift; |
2252
|
1
|
100
|
|
|
|
4
|
return Class::Generate::Support::my_decl_form(map $self->protected($_) ? "\$$_" : (), $self->user_defined_methods_keys); |
2253
|
|
|
|
|
|
|
} |
2254
|
|
|
|
|
|
|
sub protected_members_decl_form { |
2255
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
2256
|
4
|
|
|
|
|
11
|
return $self->nonpublic_members_decl_form(grep $self->protected($_->name), $self->members_values); |
2257
|
|
|
|
|
|
|
} |
2258
|
|
|
|
|
|
|
sub protected_members_info_form { |
2259
|
57
|
|
|
57
|
|
100
|
my $self = shift; |
2260
|
57
|
|
|
|
|
140
|
my @protected_members = grep $self->protected($_->name), $self->members_values; |
2261
|
57
|
|
|
|
|
150
|
my @protected_methods = grep $self->protected($_->name), $self->user_defined_methods_values; |
2262
|
57
|
100
|
66
|
|
|
328
|
return '' if ! (@protected_members || @protected_methods); |
2263
|
4
|
|
|
|
|
12
|
my $info_index_lvalue = $self->instance_var . '->' . $self->protected_members_info_index; |
2264
|
4
|
|
|
|
|
13
|
my @protected_element_names = (map($_->accessor_names($class, $_->name), @protected_members), |
2265
|
|
|
|
|
|
|
map($_->name, @protected_methods)); |
2266
|
4
|
50
|
|
|
|
14
|
if ( $self->parents ) { |
2267
|
0
|
|
|
|
|
0
|
my $form = ''; |
2268
|
0
|
|
|
|
|
0
|
for my $element_name ( @protected_element_names ) { |
2269
|
0
|
|
|
|
|
0
|
$form .= " ${info_index_lvalue}->{'$element_name'} = \$$element_name;\n"; |
2270
|
|
|
|
|
|
|
} |
2271
|
0
|
|
|
|
|
0
|
return $form; |
2272
|
|
|
|
|
|
|
} |
2273
|
|
|
|
|
|
|
else { |
2274
|
4
|
|
|
|
|
55
|
return " $info_index_lvalue = { " . join(', ', map "$_ => \$$_", @protected_element_names) . " };\n"; |
2275
|
|
|
|
|
|
|
} |
2276
|
|
|
|
|
|
|
} |
2277
|
|
|
|
|
|
|
|
2278
|
|
|
|
|
|
|
sub copy_form { |
2279
|
59
|
|
|
59
|
|
137
|
my $self = shift; |
2280
|
59
|
|
|
|
|
119
|
my ($form, @members, $has_parents); |
2281
|
59
|
|
|
|
|
145
|
@members = $self->members_values; |
2282
|
59
|
|
|
|
|
147
|
$has_parents = defined $self->parents; |
2283
|
59
|
|
|
|
|
136
|
$form = "sub copy {\n" . |
2284
|
|
|
|
|
|
|
" my \$self = shift;\n" . |
2285
|
|
|
|
|
|
|
" my \$copy;\n"; |
2286
|
59
|
100
|
100
|
|
|
94
|
if ( ! (do { my $has_complex_mems; |
2287
|
|
|
|
|
|
|
for my $m ( @members ) { |
2288
|
|
|
|
|
|
|
if ( $m->isa('Class::Generate::List_Member') || defined $m->base ) { |
2289
|
|
|
|
|
|
|
$has_complex_mems = 1; |
2290
|
|
|
|
|
|
|
last; |
2291
|
|
|
|
|
|
|
} |
2292
|
|
|
|
|
|
|
} |
2293
|
|
|
|
|
|
|
$has_complex_mems |
2294
|
|
|
|
|
|
|
} || $has_parents) ) { |
2295
|
20
|
|
|
|
|
67
|
$form .= ' $copy = ' . $self->wholesale_copy . ";\n"; |
2296
|
|
|
|
|
|
|
} |
2297
|
|
|
|
|
|
|
else { |
2298
|
39
|
100
|
|
|
|
180
|
$form .= ' $copy = ' . ($has_parents ? '$self->SUPER::copy' : $self->empty_form) . ";\n"; |
2299
|
39
|
100
|
|
|
|
248
|
$form .= $self->size_establishment('$copy') if $self->can('size_establishment'); |
2300
|
39
|
|
|
|
|
100
|
for my $m ( @members ) { |
2301
|
96
|
|
|
|
|
200
|
my $index = $self->index($m->name); |
2302
|
96
|
|
|
|
|
398
|
$form .= $m->copy_form('$self->' . $index, '$copy->' . $index); |
2303
|
|
|
|
|
|
|
} |
2304
|
|
|
|
|
|
|
} |
2305
|
59
|
|
|
|
|
148
|
$form .= " bless \$copy, ref \$self;\n" . |
2306
|
|
|
|
|
|
|
" return \$copy;\n" . |
2307
|
|
|
|
|
|
|
"}\n"; |
2308
|
59
|
|
|
|
|
332
|
return $form; |
2309
|
|
|
|
|
|
|
} |
2310
|
|
|
|
|
|
|
|
2311
|
|
|
|
|
|
|
sub equals_form { |
2312
|
59
|
|
|
59
|
|
158
|
my $self = shift; |
2313
|
59
|
|
|
|
|
135
|
my ($form, @parents, @members, $existence_test, @local_vars, @key_members); |
2314
|
59
|
|
|
|
|
175
|
@parents = $self->parents; |
2315
|
59
|
|
|
|
|
160
|
@members = $self->members_values; |
2316
|
59
|
100
|
|
|
|
280
|
if ( @key_members = grep $_->key, @members ) { |
2317
|
2
|
|
|
|
|
4
|
@members = @key_members; |
2318
|
|
|
|
|
|
|
} |
2319
|
59
|
|
|
|
|
151
|
$existence_test = $self->existence_test; |
2320
|
59
|
|
|
|
|
135
|
$form = "sub equals {\n" . |
2321
|
|
|
|
|
|
|
" my \$self = shift;\n" . |
2322
|
|
|
|
|
|
|
" my \$o = \$_[0];\n"; |
2323
|
59
|
|
|
|
|
191
|
for my $m ( @members ) { |
2324
|
51
|
50
|
|
|
|
314
|
if ( $m->isa('Class::Generate::Hash_Member'), @members ) { |
2325
|
51
|
|
|
|
|
137
|
push @local_vars, qw($self_value_defined @self_keys); |
2326
|
51
|
|
|
|
|
101
|
last; |
2327
|
|
|
|
|
|
|
} |
2328
|
|
|
|
|
|
|
} |
2329
|
59
|
|
|
|
|
128
|
for my $m ( @members ) { |
2330
|
51
|
50
|
|
|
|
252
|
if ( $m->isa('Class::Generate::Array_Member'), @members ) { |
2331
|
51
|
|
|
|
|
118
|
push @local_vars, qw($ub); |
2332
|
51
|
|
|
|
|
76
|
last; |
2333
|
|
|
|
|
|
|
} |
2334
|
|
|
|
|
|
|
} |
2335
|
59
|
100
|
|
|
|
158
|
if ( @local_vars ) { |
2336
|
51
|
|
|
|
|
227
|
$form .= ' my (' . join(', ', @local_vars) . ");\n"; |
2337
|
|
|
|
|
|
|
} |
2338
|
59
|
100
|
|
|
|
173
|
if ( @parents ) { |
2339
|
14
|
|
|
|
|
42
|
$form .= " return undef unless \$self->SUPER::equals(\$o);\n"; |
2340
|
|
|
|
|
|
|
} |
2341
|
59
|
|
|
|
|
225
|
$form .= join("\n", map $_->equals($self->index($_->name), $existence_test), @members) . |
2342
|
|
|
|
|
|
|
" return 1;\n" . |
2343
|
|
|
|
|
|
|
"}\n"; |
2344
|
59
|
|
|
|
|
312
|
return $form; |
2345
|
|
|
|
|
|
|
} |
2346
|
|
|
|
|
|
|
|
2347
|
|
|
|
|
|
|
sub all_members_required { |
2348
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2349
|
0
|
|
|
|
|
0
|
for my $m ( $self->members_keys ) { |
2350
|
0
|
0
|
0
|
|
|
0
|
return 0 if ! ($self->private($m) || $self->required($m)); |
2351
|
|
|
|
|
|
|
} |
2352
|
0
|
|
|
|
|
0
|
return 1; |
2353
|
|
|
|
|
|
|
} |
2354
|
|
|
|
|
|
|
sub private_member_names { |
2355
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2356
|
0
|
|
|
|
|
0
|
return grep $self->private($_), $self->members_keys; |
2357
|
|
|
|
|
|
|
} |
2358
|
|
|
|
|
|
|
sub protected_member_names { |
2359
|
61
|
|
|
61
|
|
132
|
my $self = shift; |
2360
|
61
|
|
|
|
|
133
|
return grep $self->protected($_), $self->members_keys; |
2361
|
|
|
|
|
|
|
} |
2362
|
|
|
|
|
|
|
sub public_member_names { |
2363
|
244
|
|
|
244
|
|
367
|
my $self = shift; |
2364
|
244
|
|
100
|
|
|
476
|
return grep ! ($self->private($_) || $self->protected($_)), $self->members_keys; |
2365
|
|
|
|
|
|
|
} |
2366
|
|
|
|
|
|
|
|
2367
|
|
|
|
|
|
|
sub class_var { |
2368
|
72
|
|
|
72
|
|
129
|
my $self = shift; |
2369
|
72
|
|
|
|
|
261
|
return '$' . $self->{'class_var'}; |
2370
|
|
|
|
|
|
|
} |
2371
|
|
|
|
|
|
|
sub instance_var { |
2372
|
940
|
|
|
940
|
|
1172
|
my $self = shift; |
2373
|
940
|
|
|
|
|
2589
|
return '$' . $self->{'instance_var'}; |
2374
|
|
|
|
|
|
|
} |
2375
|
|
|
|
|
|
|
sub needs_constructor { |
2376
|
61
|
|
|
61
|
|
110
|
my $self = shift; |
2377
|
|
|
|
|
|
|
return (defined $self->members || |
2378
|
|
|
|
|
|
|
($self->virtual && $self->check_params) || |
2379
|
|
|
|
|
|
|
! $self->parents || |
2380
|
61
|
|
66
|
|
|
161
|
do { |
2381
|
|
|
|
|
|
|
my $c = $self->constructor; |
2382
|
|
|
|
|
|
|
(defined $c->post || |
2383
|
|
|
|
|
|
|
defined $c->assert || |
2384
|
|
|
|
|
|
|
$c->style->isa('Class::Generate::Own')) |
2385
|
|
|
|
|
|
|
}); |
2386
|
|
|
|
|
|
|
} |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
package Class::Generate::Array_Class; # A subclass of Class defining |
2389
|
|
|
|
|
|
|
$Class::Generate::Array_Class::VERSION = '1.17'; |
2390
|
14
|
|
|
14
|
|
3350
|
use strict; # array-based classes. |
|
14
|
|
|
|
|
35
|
|
|
14
|
|
|
|
|
429
|
|
2391
|
14
|
|
|
14
|
|
76
|
use vars qw(@ISA); |
|
14
|
|
|
|
|
3256
|
|
|
14
|
|
|
|
|
12522
|
|
2392
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Class); |
2393
|
|
|
|
|
|
|
|
2394
|
|
|
|
|
|
|
sub new { |
2395
|
20
|
|
|
20
|
|
36
|
my $class = shift; |
2396
|
20
|
|
|
|
|
36
|
my $name = shift; |
2397
|
20
|
|
|
|
|
98
|
my %params = @_; |
2398
|
20
|
|
|
|
|
93
|
my %super_params = %params; |
2399
|
20
|
|
|
|
|
61
|
delete @super_params{qw(base_index member_index)}; |
2400
|
20
|
|
|
|
|
120
|
my $self = $class->SUPER::new($name, %super_params); |
2401
|
20
|
100
|
|
|
|
92
|
$self->{'base_index'} = defined $params{'base_index'} ? $params{'base_index'} : 1; |
2402
|
20
|
|
|
|
|
65
|
$self->{'next_index'} = $self->base_index - 1; |
2403
|
20
|
|
|
|
|
97
|
return $self; |
2404
|
|
|
|
|
|
|
} |
2405
|
|
|
|
|
|
|
|
2406
|
|
|
|
|
|
|
sub base_index { |
2407
|
20
|
|
|
20
|
|
29
|
my $self = shift; |
2408
|
20
|
|
|
|
|
48
|
return $self->{'base_index'}; |
2409
|
|
|
|
|
|
|
} |
2410
|
|
|
|
|
|
|
sub base { |
2411
|
17
|
|
|
17
|
|
23
|
my $self = shift; |
2412
|
17
|
50
|
|
|
|
57
|
return '[]' if ! $self->can_assign_all_params; |
2413
|
0
|
|
|
|
|
0
|
my @sorted_members = sort { $$self{member_index}{$a} <=> $$self{member_index}{$b} } $self->members_keys; |
|
0
|
|
|
|
|
0
|
|
2414
|
0
|
|
|
|
|
0
|
my %param_indices = map(($_, $self->constructor->style->order($_)), $self->members_keys); |
2415
|
0
|
|
|
|
|
0
|
for ( my $i = 0; $i <= $#sorted_members; $i++ ) { |
2416
|
0
|
0
|
|
|
|
0
|
next if $param_indices{$sorted_members[$i]} == $i; |
2417
|
0
|
|
|
|
|
0
|
return '[ undef, ' . join(', ', map { '$_[' . $param_indices{$_} . ']' } @sorted_members) . ' ]'; |
|
0
|
|
|
|
|
0
|
|
2418
|
|
|
|
|
|
|
} |
2419
|
0
|
|
|
|
|
0
|
return '[ undef, @_ ]'; |
2420
|
|
|
|
|
|
|
} |
2421
|
|
|
|
|
|
|
sub base_type { |
2422
|
0
|
|
|
0
|
|
0
|
return 'ARRAY'; |
2423
|
|
|
|
|
|
|
} |
2424
|
|
|
|
|
|
|
sub members { |
2425
|
158
|
|
|
158
|
|
193
|
my $self = shift; |
2426
|
158
|
100
|
|
|
|
327
|
return $self->SUPER::members(@_) if $#_ != 1; |
2427
|
31
|
|
|
|
|
95
|
$self->SUPER::members(@_); |
2428
|
31
|
|
|
|
|
41
|
my $overridden_class; |
2429
|
31
|
50
|
|
|
|
67
|
if ( defined ($overridden_class = Class::Generate::Support::class_containing_method($_[0], $self)) ) { |
2430
|
0
|
|
|
|
|
0
|
$self->{'member_index'}{$_[0]} = $overridden_class->{'member_index'}->{$_[0]}; |
2431
|
|
|
|
|
|
|
} |
2432
|
|
|
|
|
|
|
else { |
2433
|
31
|
|
|
|
|
73
|
$self->{'member_index'}{$_[0]} = ++$self->{'next_index'}; |
2434
|
|
|
|
|
|
|
} |
2435
|
|
|
|
|
|
|
} |
2436
|
|
|
|
|
|
|
sub index { |
2437
|
122
|
|
|
122
|
|
137
|
my $self = shift; |
2438
|
122
|
|
|
|
|
287
|
return '[' . $self->{'member_index'}{$_[0]} . ']'; |
2439
|
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
|
sub last { |
2441
|
47
|
|
|
47
|
|
68
|
my $self = shift; |
2442
|
47
|
|
|
|
|
134
|
return $self->{'next_index'}; |
2443
|
|
|
|
|
|
|
} |
2444
|
|
|
|
|
|
|
sub existence_test { |
2445
|
47
|
|
|
47
|
|
63
|
my $self = shift; |
2446
|
47
|
|
|
|
|
79
|
return 'defined'; |
2447
|
|
|
|
|
|
|
} |
2448
|
|
|
|
|
|
|
|
2449
|
|
|
|
|
|
|
sub size_establishment { |
2450
|
26
|
|
|
26
|
|
45
|
my $self = shift; |
2451
|
26
|
|
|
|
|
44
|
my $instance_var = $_[0]; |
2452
|
26
|
|
|
|
|
62
|
return ' $#' . $instance_var . ' = ' . $self->last . ";\n"; |
2453
|
|
|
|
|
|
|
} |
2454
|
|
|
|
|
|
|
sub can_assign_all_params { |
2455
|
51
|
|
|
51
|
|
63
|
my $self = shift; |
2456
|
51
|
|
0
|
|
|
71
|
return ! $self->check_params && |
2457
|
|
|
|
|
|
|
$self->all_members_required && |
2458
|
|
|
|
|
|
|
$self->constructor->style->isa('Class::Generate::Positional') && |
2459
|
|
|
|
|
|
|
! defined $self->parents; |
2460
|
|
|
|
|
|
|
} |
2461
|
|
|
|
|
|
|
sub undef_form { |
2462
|
15
|
|
|
15
|
|
50
|
return 'undef'; |
2463
|
|
|
|
|
|
|
} |
2464
|
|
|
|
|
|
|
sub wholesale_copy { |
2465
|
8
|
|
|
8
|
|
23
|
return '[ @$self ]'; |
2466
|
|
|
|
|
|
|
} |
2467
|
|
|
|
|
|
|
sub empty_form { |
2468
|
8
|
|
|
8
|
|
24
|
return '[]'; |
2469
|
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
|
sub protected_members_info_index { |
2471
|
1
|
|
|
1
|
|
3
|
return q|[0]|; |
2472
|
|
|
|
|
|
|
} |
2473
|
|
|
|
|
|
|
|
2474
|
|
|
|
|
|
|
package Class::Generate::Hash_Class; # A subclass of Class defining |
2475
|
|
|
|
|
|
|
$Class::Generate::Hash_Class::VERSION = '1.17'; |
2476
|
14
|
|
|
14
|
|
1559
|
use vars qw(@ISA); # hash-based classes. |
|
14
|
|
|
|
|
1547
|
|
|
14
|
|
|
|
|
4524
|
|
2477
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Class); |
2478
|
|
|
|
|
|
|
|
2479
|
|
|
|
|
|
|
sub index { |
2480
|
438
|
|
|
438
|
|
617
|
my $self = shift; |
2481
|
438
|
100
|
|
|
|
791
|
return "{'" . ($self->private($_[0]) ? '*' . $self->name . '_' . $_[0] : $_[0]) . "'}"; |
2482
|
|
|
|
|
|
|
} |
2483
|
|
|
|
|
|
|
sub base { |
2484
|
29
|
|
|
29
|
|
50
|
my $self = shift; |
2485
|
29
|
50
|
|
|
|
71
|
return '{}' if ! $self->can_assign_all_params; |
2486
|
0
|
|
|
|
|
0
|
my $style = $self->constructor->style; |
2487
|
0
|
0
|
|
|
|
0
|
return '{ @_ }' if $style->isa('Class::Generate::Key_Value'); |
2488
|
0
|
|
|
|
|
0
|
my %order = $style->order; |
2489
|
0
|
|
|
|
|
0
|
my $form = '{ ' . join(', ', map("$_ => \$_[$order{$_}]", keys %order)); |
2490
|
0
|
0
|
|
|
|
0
|
if ( $style->isa('Class::Generate::Mix') ) { |
2491
|
0
|
|
|
|
|
0
|
$form .= ', @_[' . $style->pcount . '..$#_]'; |
2492
|
|
|
|
|
|
|
} |
2493
|
0
|
|
|
|
|
0
|
return $form . ' }'; |
2494
|
|
|
|
|
|
|
} |
2495
|
|
|
|
|
|
|
sub base_type { |
2496
|
0
|
|
|
0
|
|
0
|
return 'HASH'; |
2497
|
|
|
|
|
|
|
} |
2498
|
|
|
|
|
|
|
sub existence_test { |
2499
|
144
|
|
|
144
|
|
335
|
return 'exists'; |
2500
|
|
|
|
|
|
|
} |
2501
|
|
|
|
|
|
|
sub can_assign_all_params { |
2502
|
109
|
|
|
109
|
|
158
|
my $self = shift; |
2503
|
109
|
|
0
|
|
|
196
|
return ! $self->check_params && |
2504
|
|
|
|
|
|
|
$self->all_members_required && |
2505
|
|
|
|
|
|
|
! $self->constructor->style->isa('Class::Generate::Own') && |
2506
|
|
|
|
|
|
|
! defined $self->parents; |
2507
|
|
|
|
|
|
|
} |
2508
|
|
|
|
|
|
|
sub undef_form { |
2509
|
73
|
|
|
73
|
|
233
|
return 'delete'; |
2510
|
|
|
|
|
|
|
} |
2511
|
|
|
|
|
|
|
sub wholesale_copy { |
2512
|
12
|
|
|
12
|
|
50
|
return '{ %$self }'; |
2513
|
|
|
|
|
|
|
} |
2514
|
|
|
|
|
|
|
sub empty_form { |
2515
|
17
|
|
|
17
|
|
59
|
return '{}'; |
2516
|
|
|
|
|
|
|
} |
2517
|
|
|
|
|
|
|
sub protected_members_info_index { |
2518
|
9
|
|
|
9
|
|
31
|
return q|{'*protected*'}|; |
2519
|
|
|
|
|
|
|
} |
2520
|
|
|
|
|
|
|
|
2521
|
|
|
|
|
|
|
package Class::Generate::Param_Style; # A virtual class encompassing |
2522
|
|
|
|
|
|
|
$Class::Generate::Param_Style::VERSION = '1.17'; |
2523
|
14
|
|
|
14
|
|
93
|
use strict; # parameter-passing styles for |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
3532
|
|
2524
|
|
|
|
|
|
|
|
2525
|
|
|
|
|
|
|
sub new { |
2526
|
71
|
|
|
71
|
|
138
|
my $class = shift; |
2527
|
71
|
|
|
|
|
192
|
return bless {}, $class; |
2528
|
|
|
|
|
|
|
} |
2529
|
|
|
|
|
|
|
sub keyed_param_names { |
2530
|
0
|
|
|
0
|
|
0
|
return (); |
2531
|
|
|
|
|
|
|
} |
2532
|
|
|
|
|
|
|
|
2533
|
|
|
|
|
|
|
sub delete_self_members_form { |
2534
|
1
|
|
|
1
|
|
3
|
shift; |
2535
|
1
|
|
|
|
|
5
|
my @self_members = @_; |
2536
|
1
|
50
|
|
|
|
5
|
if ( $#self_members == 0 ) { |
|
|
0
|
|
|
|
|
|
2537
|
1
|
|
|
|
|
13
|
return q|delete $super_params{'| . $self_members[0] . q|'};|; |
2538
|
|
|
|
|
|
|
} |
2539
|
|
|
|
|
|
|
elsif ( $#self_members > 0 ) { |
2540
|
0
|
|
|
|
|
0
|
return q|delete @super_params{qw(| . join(' ', @self_members) . q|)};|; |
2541
|
|
|
|
|
|
|
} |
2542
|
|
|
|
|
|
|
} |
2543
|
|
|
|
|
|
|
|
2544
|
|
|
|
|
|
|
sub odd_params_check_form { |
2545
|
42
|
|
|
42
|
|
74
|
my $self = shift; |
2546
|
42
|
|
|
|
|
89
|
my ($class, $constructor) = @_; |
2547
|
42
|
|
|
|
|
190
|
return q| croak '| . $constructor->name_form($class) . q|Odd number of parameters' if | . |
2548
|
|
|
|
|
|
|
$self->odd_params_test($class) . ";\n"; |
2549
|
|
|
|
|
|
|
} |
2550
|
|
|
|
|
|
|
|
2551
|
|
|
|
|
|
|
sub my_decl_form { |
2552
|
11
|
|
|
11
|
|
30
|
my $self = shift; |
2553
|
11
|
|
|
|
|
22
|
my $class = $_[0]; |
2554
|
11
|
|
|
|
|
33
|
return ' my ' . $class->instance_var . ' = ' . $class->class_var . '->SUPER::new'; |
2555
|
|
|
|
|
|
|
} |
2556
|
|
|
|
|
|
|
|
2557
|
|
|
|
|
|
|
package Class::Generate::Key_Value; # The key/value parameter- |
2558
|
|
|
|
|
|
|
$Class::Generate::Key_Value::VERSION = '1.17'; |
2559
|
15
|
|
|
14
|
|
96
|
use strict; # passing style. It adds |
|
15
|
|
|
|
|
40
|
|
|
15
|
|
|
|
|
2611
|
|
2560
|
14
|
|
|
14
|
|
72
|
use vars qw(@ISA); # the name of the variable |
|
14
|
|
|
|
|
29
|
|
|
14
|
|
|
|
|
6291
|
|
2561
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); # that holds the parameters. |
2562
|
|
|
|
|
|
|
|
2563
|
|
|
|
|
|
|
sub new { |
2564
|
46
|
|
|
46
|
|
91
|
my $class = shift; |
2565
|
46
|
|
|
|
|
178
|
my $self = $class->SUPER::new; |
2566
|
46
|
|
|
|
|
141
|
$self->{'holder'} = $_[0]; |
2567
|
46
|
|
|
|
|
190
|
$self->{'keyed_param_names'} = [@_[1..$#_]]; |
2568
|
46
|
|
|
|
|
237
|
return $self; |
2569
|
|
|
|
|
|
|
} |
2570
|
|
|
|
|
|
|
|
2571
|
|
|
|
|
|
|
sub holder { |
2572
|
176
|
|
|
176
|
|
205
|
my $self = shift; |
2573
|
176
|
|
|
|
|
427
|
return $self->{'holder'}; |
2574
|
|
|
|
|
|
|
} |
2575
|
|
|
|
|
|
|
sub ref { |
2576
|
176
|
|
|
176
|
|
202
|
my $self = shift; |
2577
|
176
|
|
|
|
|
334
|
return '$' . $self->holder . "{'" . $_[0] . "'}"; |
2578
|
|
|
|
|
|
|
} |
2579
|
|
|
|
|
|
|
sub keyed_param_names { |
2580
|
118
|
|
|
118
|
|
170
|
my $self = shift; |
2581
|
118
|
|
|
|
|
138
|
return @{$self->{'keyed_param_names'}}; |
|
118
|
|
|
|
|
304
|
|
2582
|
|
|
|
|
|
|
} |
2583
|
|
|
|
|
|
|
sub existence_test { |
2584
|
176
|
|
|
176
|
|
338
|
return 'exists'; |
2585
|
|
|
|
|
|
|
} |
2586
|
|
|
|
|
|
|
sub init_form { |
2587
|
38
|
|
|
38
|
|
81
|
my $self = shift; |
2588
|
38
|
|
|
|
|
117
|
my ($class, $constructor) = @_; |
2589
|
38
|
|
|
|
|
66
|
my ($form, $cn); |
2590
|
38
|
|
|
|
|
58
|
$form = ''; |
2591
|
38
|
50
|
|
|
|
84
|
$form .= $self->odd_params_check_form($class, $constructor) if $class->check_params; |
2592
|
38
|
|
|
|
|
84
|
$form .= " my \%params = \@_;\n"; |
2593
|
38
|
|
|
|
|
91
|
return $form; |
2594
|
|
|
|
|
|
|
} |
2595
|
|
|
|
|
|
|
sub odd_params_test { |
2596
|
38
|
|
|
38
|
|
120
|
return '$#_%2 == 0'; |
2597
|
|
|
|
|
|
|
} |
2598
|
|
|
|
|
|
|
sub self_from_super_form { |
2599
|
1
|
|
|
1
|
|
4
|
my $self = shift; |
2600
|
1
|
|
|
|
|
2
|
my $class = $_[0]; |
2601
|
1
|
|
|
|
|
5
|
return ' my %super_params = %params;' . "\n" . |
2602
|
|
|
|
|
|
|
' ' . $self->delete_self_members_form($class->public_member_names) . "\n" . |
2603
|
|
|
|
|
|
|
$self->my_decl_form($class) . "(\%super_params);\n"; |
2604
|
|
|
|
|
|
|
} |
2605
|
|
|
|
|
|
|
sub params_check_form { |
2606
|
39
|
|
|
39
|
|
68
|
my $self = shift; |
2607
|
39
|
|
|
|
|
89
|
my ($class, $constructor) = @_; |
2608
|
39
|
|
|
|
|
74
|
my ($cn, @valid_names, $form); |
2609
|
39
|
|
|
|
|
106
|
@valid_names = $self->keyed_param_names; |
2610
|
39
|
|
|
|
|
107
|
$cn = $constructor->name_form($class); |
2611
|
39
|
100
|
|
|
|
111
|
if ( ! @valid_names ) { |
2612
|
5
|
|
|
|
|
15
|
$form = " croak '$cn', join(', ', keys %params), ': Not a member' if keys \%params;\n"; |
2613
|
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
|
else { |
2615
|
34
|
|
|
|
|
67
|
$form = " {\n"; |
2616
|
34
|
100
|
|
|
|
88
|
if ( $#valid_names == 0 ) { |
2617
|
8
|
|
|
|
|
23
|
$form .= "\tmy \@unknown_params = grep \$_ ne '$valid_names[0]', keys \%params;\n"; |
2618
|
|
|
|
|
|
|
} |
2619
|
|
|
|
|
|
|
else { |
2620
|
26
|
|
|
|
|
194
|
$form .= "\tmy %valid_param = (" . join(', ', map("'$_' => 1", @valid_names)) . ");\n" . |
2621
|
|
|
|
|
|
|
"\tmy \@unknown_params = grep ! defined \$valid_param{\$_}, keys \%params;\n"; |
2622
|
|
|
|
|
|
|
} |
2623
|
34
|
|
|
|
|
140
|
$form .= "\tcroak '$cn', join(', ', \@unknown_params), ': Not a member' if \@unknown_params;\n" . |
2624
|
|
|
|
|
|
|
" }\n"; |
2625
|
|
|
|
|
|
|
} |
2626
|
39
|
|
|
|
|
104
|
return $form; |
2627
|
|
|
|
|
|
|
} |
2628
|
|
|
|
|
|
|
|
2629
|
|
|
|
|
|
|
package Class::Generate::Positional; # The positional parameter- |
2630
|
|
|
|
|
|
|
$Class::Generate::Positional::VERSION = '1.17'; |
2631
|
14
|
|
|
14
|
|
95
|
use strict; # passing style. It adds |
|
14
|
|
|
|
|
33
|
|
|
14
|
|
|
|
|
397
|
|
2632
|
13
|
|
|
15
|
|
71
|
use vars qw(@ISA); # an ordering of parameters. |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
5298
|
|
2633
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
2634
|
|
|
|
|
|
|
|
2635
|
|
|
|
|
|
|
sub new { |
2636
|
15
|
|
|
15
|
|
36
|
my $class = shift; |
2637
|
15
|
|
|
|
|
104
|
my $self = $class->SUPER::new; |
2638
|
15
|
|
|
|
|
71
|
for ( my $i = 0; $i <= $#_; $i++ ) { |
2639
|
17
|
|
|
|
|
112
|
$self->{'order'}->{$_[$i]} = $i; |
2640
|
|
|
|
|
|
|
} |
2641
|
15
|
|
|
|
|
149
|
return $self; |
2642
|
|
|
|
|
|
|
} |
2643
|
|
|
|
|
|
|
sub order { |
2644
|
27
|
|
|
27
|
|
53
|
my $self = shift; |
2645
|
27
|
100
|
|
|
|
144
|
return exists $self->{'order'} ? %{$self->{'order'}} : () if $#_ == -1; |
|
12
|
100
|
|
|
|
77
|
|
2646
|
12
|
50
|
|
|
|
65
|
return exists $self->{'order'} ? $self->{'order'}->{$_[0]} : undef if $#_ == 0; |
|
|
50
|
|
|
|
|
|
2647
|
0
|
|
|
|
|
0
|
$self->{'order'}->{$_[0]} = $_[1]; |
2648
|
|
|
|
|
|
|
} |
2649
|
|
|
|
|
|
|
sub ref { |
2650
|
28
|
|
|
28
|
|
55
|
my $self = shift; |
2651
|
28
|
|
|
|
|
109
|
return '$_[' . $self->{'order'}->{$_[0]} . ']'; |
2652
|
|
|
|
|
|
|
} |
2653
|
|
|
|
|
|
|
sub existence_test { |
2654
|
28
|
|
|
28
|
|
91
|
return 'defined'; |
2655
|
|
|
|
|
|
|
} |
2656
|
|
|
|
|
|
|
sub self_from_super_form { |
2657
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
2658
|
4
|
|
|
|
|
13
|
my $class = $_[0]; |
2659
|
4
|
|
100
|
|
|
13
|
my $lb = scalar($class->public_member_names) || 0; |
2660
|
4
|
|
|
|
|
59
|
return ' my @super_params = @_[' . $lb . '..$#_];' . "\n" . |
2661
|
|
|
|
|
|
|
$self->my_decl_form($class) . "(\@super_params);\n"; |
2662
|
|
|
|
|
|
|
} |
2663
|
|
|
|
|
|
|
sub params_check_form { |
2664
|
6
|
|
|
6
|
|
11
|
my $self = shift; |
2665
|
6
|
|
|
|
|
18
|
my ($class, $constructor) = @_; |
2666
|
6
|
|
|
|
|
53
|
my $cn = $constructor->name_form($class); |
2667
|
6
|
|
50
|
|
|
16
|
my $max_params = scalar($class->public_member_names) || 0; |
2668
|
6
|
|
|
|
|
50
|
return qq| croak '$cn| . qq|Only $max_params parameter(s) allowed (', \$#_+1, ' given)'| . |
2669
|
|
|
|
|
|
|
" unless \$#_ < $max_params;\n"; |
2670
|
|
|
|
|
|
|
} |
2671
|
|
|
|
|
|
|
|
2672
|
|
|
|
|
|
|
package Class::Generate::Mix; # The mix parameter-passing |
2673
|
|
|
|
|
|
|
$Class::Generate::Mix::VERSION = '1.17'; |
2674
|
13
|
|
|
14
|
|
79
|
use strict; # style. It combines key/value |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
332
|
|
2675
|
13
|
|
|
14
|
|
60
|
use vars qw(@ISA); # and positional. |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
10643
|
|
2676
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
2677
|
|
|
|
|
|
|
|
2678
|
|
|
|
|
|
|
sub new { |
2679
|
5
|
|
|
5
|
|
13
|
my $class = shift; |
2680
|
5
|
|
|
|
|
25
|
my $self = $class->SUPER::new; |
2681
|
5
|
|
|
|
|
11
|
$self->{'pp'} = Class::Generate::Positional->new(@{$_[1]}); |
|
5
|
|
|
|
|
28
|
|
2682
|
5
|
|
|
|
|
43
|
$self->{'kv'} = Class::Generate::Key_Value->new($_[0], @_[2..$#_]); |
2683
|
5
|
|
|
|
|
20
|
$self->{'pnames'} = { map( ($_ => 1), @{$_[1]}) }; |
|
5
|
|
|
|
|
37
|
|
2684
|
5
|
|
|
|
|
32
|
return $self; |
2685
|
|
|
|
|
|
|
} |
2686
|
|
|
|
|
|
|
|
2687
|
|
|
|
|
|
|
sub keyed_param_names { |
2688
|
5
|
|
|
5
|
|
13
|
my $self = shift; |
2689
|
5
|
|
|
|
|
24
|
return $self->{'kv'}->keyed_param_names; |
2690
|
|
|
|
|
|
|
} |
2691
|
|
|
|
|
|
|
sub order { |
2692
|
7
|
|
|
7
|
|
19
|
my $self = shift; |
2693
|
7
|
50
|
|
|
|
54
|
return $self->{'pp'}->order(@_) if $#_ <= 0; |
2694
|
0
|
|
|
|
|
0
|
$self->{'pp'}->order(@_); |
2695
|
0
|
|
|
|
|
0
|
$self->{'pnames'}{$_[0]} = 1; |
2696
|
|
|
|
|
|
|
} |
2697
|
|
|
|
|
|
|
sub ref { |
2698
|
20
|
|
|
20
|
|
36
|
my $self = shift; |
2699
|
20
|
100
|
|
|
|
90
|
return $self->{'pnames'}->{$_[0]} ? $self->{'pp'}->ref($_[0]) : $self->{'kv'}->ref($_[0]); |
2700
|
|
|
|
|
|
|
} |
2701
|
|
|
|
|
|
|
sub existence_test { |
2702
|
20
|
|
|
20
|
|
37
|
my $self = shift; |
2703
|
20
|
100
|
|
|
|
74
|
return $self->{'pnames'}->{$_[0]} ? $self->{'pp'}->existence_test : $self->{'kv'}->existence_test; |
2704
|
|
|
|
|
|
|
} |
2705
|
|
|
|
|
|
|
sub pcount { |
2706
|
22
|
|
|
22
|
|
35
|
my $self = shift; |
2707
|
22
|
50
|
|
|
|
52
|
return exists $self->{'pnames'} ? scalar(keys %{$self->{'pnames'}}) : 0; |
|
22
|
|
|
|
|
90
|
|
2708
|
|
|
|
|
|
|
} |
2709
|
|
|
|
|
|
|
sub init_form { |
2710
|
4
|
|
|
4
|
|
115
|
my $self = shift; |
2711
|
4
|
|
|
|
|
16
|
my ($class, $constructor) = @_; |
2712
|
4
|
|
|
|
|
25
|
my ($form, $m) = ('', $self->max_possible_params($class)); |
2713
|
4
|
50
|
|
|
|
16
|
$form .= $self->odd_params_check_form($class, $constructor, $self->pcount, $m) if $class->check_params; |
2714
|
4
|
|
|
|
|
19
|
$form .= ' my %params = ' . $self->kv_params_form($m) . ";\n"; |
2715
|
4
|
|
|
|
|
17
|
return $form; |
2716
|
|
|
|
|
|
|
} |
2717
|
|
|
|
|
|
|
sub odd_params_test { |
2718
|
4
|
|
|
4
|
|
11
|
my $self = shift; |
2719
|
4
|
|
|
|
|
8
|
my $class = $_[0]; |
2720
|
4
|
|
|
|
|
12
|
my ($p, $test); |
2721
|
4
|
|
|
|
|
11
|
$p = $self->pcount; |
2722
|
4
|
|
|
|
|
13
|
$test = '$#_>=' . $p; |
2723
|
4
|
100
|
|
|
|
15
|
$test .= ' && $#_<=' . $self->max_possible_params($class) if $class->parents; |
2724
|
4
|
100
|
|
|
|
25
|
$test .= ' && $#_%2 == ' . ($p%2 == 0 ? '0' : '1'); |
2725
|
4
|
|
|
|
|
21
|
return $test; |
2726
|
|
|
|
|
|
|
} |
2727
|
|
|
|
|
|
|
sub self_from_super_form { |
2728
|
2
|
|
|
2
|
|
6
|
my $self = shift; |
2729
|
2
|
|
|
|
|
5
|
my $class = $_[0]; |
2730
|
2
|
|
|
|
|
5
|
my @positional_members = keys %{$self->{'pnames'}}; |
|
2
|
|
|
|
|
10
|
|
2731
|
2
|
|
|
|
|
22
|
my %self_members = map { ($_ => 1) } $class->public_member_names; |
|
3
|
|
|
|
|
11
|
|
2732
|
2
|
|
|
|
|
6
|
delete @self_members{@positional_members}; |
2733
|
2
|
|
|
|
|
7
|
my $m = $self->max_possible_params($class); |
2734
|
2
|
|
|
|
|
15
|
return $self->my_decl_form($class) . '(@_[' . ($m+1) . '..$#_]);' . "\n"; |
2735
|
|
|
|
|
|
|
} |
2736
|
|
|
|
|
|
|
sub max_possible_params { |
2737
|
10
|
|
|
10
|
|
77
|
my $self = shift; |
2738
|
10
|
|
|
|
|
21
|
my $class = $_[0]; |
2739
|
10
|
|
|
|
|
43
|
my $p = $self->pcount; |
2740
|
10
|
|
|
|
|
30
|
return $p + 2*(scalar($class->public_member_names) - $p) - 1; |
2741
|
|
|
|
|
|
|
} |
2742
|
|
|
|
|
|
|
sub params_check_form { |
2743
|
2
|
|
|
2
|
|
6
|
my $self = shift; |
2744
|
2
|
|
|
|
|
7
|
my ($class, $constructor) = @_; |
2745
|
2
|
|
|
|
|
6
|
my ($form, $cn); |
2746
|
2
|
|
|
|
|
8
|
$cn = $constructor->name_form($class); |
2747
|
2
|
|
|
|
|
14
|
$form = $self->{'kv'}->params_check_form(@_); |
2748
|
2
|
|
|
|
|
9
|
my $max_params = $self->max_possible_params($class) + 1; |
2749
|
2
|
|
|
|
|
19
|
$form .= qq| croak '$cn| . qq|Only $max_params parameter(s) allowed (', \$#_+1, ' given)'| . |
2750
|
|
|
|
|
|
|
" unless \$#_ < $max_params;\n"; |
2751
|
2
|
|
|
|
|
9
|
return $form; |
2752
|
|
|
|
|
|
|
} |
2753
|
|
|
|
|
|
|
|
2754
|
|
|
|
|
|
|
sub kv_params_form { |
2755
|
4
|
|
|
4
|
|
11
|
my $self = shift; |
2756
|
4
|
|
|
|
|
10
|
my $max_params = $_[0]; |
2757
|
4
|
|
|
|
|
13
|
return '@_[' . $self->pcount . "..(\$#_ < $max_params ? \$#_ : $max_params)]"; |
2758
|
|
|
|
|
|
|
} |
2759
|
|
|
|
|
|
|
|
2760
|
|
|
|
|
|
|
package Class::Generate::Own; # The "own" parameter-passing |
2761
|
|
|
|
|
|
|
$Class::Generate::Own::VERSION = '1.17'; |
2762
|
13
|
|
|
13
|
|
86
|
use strict; # style. |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
315
|
|
2763
|
13
|
|
|
13
|
|
76
|
use vars qw(@ISA); |
|
13
|
|
|
|
|
20
|
|
|
13
|
|
|
|
|
6561
|
|
2764
|
|
|
|
|
|
|
@ISA = qw(Class::Generate::Param_Style); |
2765
|
|
|
|
|
|
|
|
2766
|
|
|
|
|
|
|
sub new { |
2767
|
5
|
|
|
5
|
|
9
|
my $class = shift; |
2768
|
5
|
|
|
|
|
23
|
my $self = $class->SUPER::new; |
2769
|
5
|
50
|
|
|
|
28
|
$self->{'super_values'} = $_[0] if defined $_[0]; |
2770
|
5
|
|
|
|
|
21
|
return $self; |
2771
|
|
|
|
|
|
|
} |
2772
|
|
|
|
|
|
|
|
2773
|
|
|
|
|
|
|
sub super_values { |
2774
|
9
|
|
|
9
|
|
14
|
my $self = shift; |
2775
|
9
|
50
|
|
|
|
24
|
return defined $self->{'super_values'} ? @{$self->{'super_values'}} : (); |
|
9
|
|
|
|
|
38
|
|
2776
|
|
|
|
|
|
|
} |
2777
|
|
|
|
|
|
|
|
2778
|
|
|
|
|
|
|
sub can_assign_all_params { |
2779
|
0
|
|
|
0
|
|
0
|
return 0; |
2780
|
|
|
|
|
|
|
} |
2781
|
|
|
|
|
|
|
|
2782
|
|
|
|
|
|
|
sub self_from_super_form { |
2783
|
4
|
|
|
4
|
|
5
|
my $self = shift; |
2784
|
4
|
|
|
|
|
9
|
my $class = $_[0]; |
2785
|
4
|
|
|
|
|
8
|
my ($form, @sv); |
2786
|
4
|
|
|
|
|
19
|
$form = $self->my_decl_form($class); |
2787
|
4
|
100
|
|
|
|
13
|
if ( @sv = $self->super_values ) { |
2788
|
3
|
|
|
|
|
14
|
$form .= '(' . join(',', @sv) . ')'; |
2789
|
|
|
|
|
|
|
} |
2790
|
4
|
|
|
|
|
13
|
$form .= ";\n"; |
2791
|
4
|
|
|
|
|
12
|
return $form; |
2792
|
|
|
|
|
|
|
} |
2793
|
|
|
|
|
|
|
|
2794
|
|
|
|
|
|
|
1; |
2795
|
|
|
|
|
|
|
|
2796
|
|
|
|
|
|
|
=pod |
2797
|
|
|
|
|
|
|
|
2798
|
|
|
|
|
|
|
=encoding UTF-8 |
2799
|
|
|
|
|
|
|
|
2800
|
|
|
|
|
|
|
=head1 NAME |
2801
|
|
|
|
|
|
|
|
2802
|
|
|
|
|
|
|
Class::Generate - Generate Perl class hierarchies |
2803
|
|
|
|
|
|
|
|
2804
|
|
|
|
|
|
|
=head1 VERSION |
2805
|
|
|
|
|
|
|
|
2806
|
|
|
|
|
|
|
version 1.17 |
2807
|
|
|
|
|
|
|
|
2808
|
|
|
|
|
|
|
=head1 SYNOPSIS |
2809
|
|
|
|
|
|
|
|
2810
|
|
|
|
|
|
|
use Class::Generate qw(class subclass delete_class); |
2811
|
|
|
|
|
|
|
|
2812
|
|
|
|
|
|
|
# Declare class Class_Name, with the following types of members: |
2813
|
|
|
|
|
|
|
class |
2814
|
|
|
|
|
|
|
Class_Name => [ |
2815
|
|
|
|
|
|
|
s => '$', # scalar |
2816
|
|
|
|
|
|
|
a => '@', # array |
2817
|
|
|
|
|
|
|
h => '%', # hash |
2818
|
|
|
|
|
|
|
c => 'Class', # Class |
2819
|
|
|
|
|
|
|
c_a => '@Class', # array of Class |
2820
|
|
|
|
|
|
|
c_h => '%Class', # hash of Class |
2821
|
|
|
|
|
|
|
'&m' => 'body', # method |
2822
|
|
|
|
|
|
|
]; |
2823
|
|
|
|
|
|
|
|
2824
|
|
|
|
|
|
|
# Allocate an instance of class_name, with members initialized to the |
2825
|
|
|
|
|
|
|
# given values (pass arrays and hashes using references). |
2826
|
|
|
|
|
|
|
$obj = Class_Name->new ( s => scalar, |
2827
|
|
|
|
|
|
|
a => [ values ], |
2828
|
|
|
|
|
|
|
h => { key1 => v1, ... }, |
2829
|
|
|
|
|
|
|
c => Class->new, |
2830
|
|
|
|
|
|
|
c_a => [ Class->new, ... ], |
2831
|
|
|
|
|
|
|
c_h => [ key1 => Class->new, ... ] ); |
2832
|
|
|
|
|
|
|
|
2833
|
|
|
|
|
|
|
# Scalar type accessor: |
2834
|
|
|
|
|
|
|
$obj->s($value); # Assign $value to member s. |
2835
|
|
|
|
|
|
|
$member_value = $obj->s; # Access member's value. |
2836
|
|
|
|
|
|
|
|
2837
|
|
|
|
|
|
|
# (Class) Array type accessor: |
2838
|
|
|
|
|
|
|
$obj->a([value1, value2, ...]); # Assign whole array to member. |
2839
|
|
|
|
|
|
|
$obj->a(2, $value); # Assign $value to array member 2. |
2840
|
|
|
|
|
|
|
$obj->add_a($value); # Append $value to end of array. |
2841
|
|
|
|
|
|
|
@a = $obj->a; # Access whole array. |
2842
|
|
|
|
|
|
|
$ary_member_value = $obj->a(2); # Access array member 2. |
2843
|
|
|
|
|
|
|
$s = $obj->a_size; # Return size of array. |
2844
|
|
|
|
|
|
|
$value = $obj->last_a; # Return last element of array. |
2845
|
|
|
|
|
|
|
|
2846
|
|
|
|
|
|
|
# (Class) Hash type accessor: |
2847
|
|
|
|
|
|
|
$obj->h({ k_1=>v1, ..., k_n=>v_n }) # Assign whole hash to member. |
2848
|
|
|
|
|
|
|
$obj->h($key, $value); # Assign $value to hash member $key. |
2849
|
|
|
|
|
|
|
%hash = $obj->h; # Access whole hash. |
2850
|
|
|
|
|
|
|
$hash_member_value = $obj->h($key); # Access hash member value $key. |
2851
|
|
|
|
|
|
|
$obj->delete_h($key); # Delete slot occupied by $key. |
2852
|
|
|
|
|
|
|
@keys = $obj->h_keys; # Access keys of member h. |
2853
|
|
|
|
|
|
|
@values = $obj->h_values; # Access values of member h. |
2854
|
|
|
|
|
|
|
|
2855
|
|
|
|
|
|
|
$another = $obj->copy; # Copy an object. |
2856
|
|
|
|
|
|
|
if ( $obj->equals($another) ) { ... } # Test equality. |
2857
|
|
|
|
|
|
|
|
2858
|
|
|
|
|
|
|
subclass s => [ ], -parent => 'class_name'; |
2859
|
|
|
|
|
|
|
|
2860
|
|
|
|
|
|
|
=head1 DESCRIPTION |
2861
|
|
|
|
|
|
|
|
2862
|
|
|
|
|
|
|
The C package exports functions that take as arguments |
2863
|
|
|
|
|
|
|
a class specification and create from these specifications a Perl 5 class. |
2864
|
|
|
|
|
|
|
The specification language allows many object-oriented constructs: |
2865
|
|
|
|
|
|
|
typed members, inheritance, private members, required members, |
2866
|
|
|
|
|
|
|
default values, object methods, class methods, class variables, and more. |
2867
|
|
|
|
|
|
|
|
2868
|
|
|
|
|
|
|
CPAN contains similar packages. |
2869
|
|
|
|
|
|
|
Why another? |
2870
|
|
|
|
|
|
|
Because object-oriented programming, |
2871
|
|
|
|
|
|
|
especially in a dynamic language like Perl, |
2872
|
|
|
|
|
|
|
is a complicated endeavor. |
2873
|
|
|
|
|
|
|
I wanted a package that would work very hard to catch the errors you |
2874
|
|
|
|
|
|
|
(well, I anyway) commonly make. |
2875
|
|
|
|
|
|
|
I wanted a package that could help me |
2876
|
|
|
|
|
|
|
enforce the contract of object-oriented programming. |
2877
|
|
|
|
|
|
|
I also wanted it to get out of my way when I asked. |
2878
|
|
|
|
|
|
|
|
2879
|
|
|
|
|
|
|
=head1 VERSION |
2880
|
|
|
|
|
|
|
|
2881
|
|
|
|
|
|
|
version 1.17 |
2882
|
|
|
|
|
|
|
|
2883
|
|
|
|
|
|
|
=head1 THE CLASS FUNCTION |
2884
|
|
|
|
|
|
|
|
2885
|
|
|
|
|
|
|
You create classes by invoking the C function. |
2886
|
|
|
|
|
|
|
The C function has two forms: |
2887
|
|
|
|
|
|
|
|
2888
|
|
|
|
|
|
|
class Class_Name => [ specification ]; # Objects are array-based. |
2889
|
|
|
|
|
|
|
class Class_Name => { specification }; # Objects are hash-based. |
2890
|
|
|
|
|
|
|
|
2891
|
|
|
|
|
|
|
The result is a Perl 5 class, in a package C. |
2892
|
|
|
|
|
|
|
This package must not exist when C is invoked. |
2893
|
|
|
|
|
|
|
|
2894
|
|
|
|
|
|
|
An array-based object is faster and smaller. |
2895
|
|
|
|
|
|
|
A hash-based object is more flexible. |
2896
|
|
|
|
|
|
|
Subsequent sections explain where and why flexibility matters. |
2897
|
|
|
|
|
|
|
|
2898
|
|
|
|
|
|
|
The specification consists of zero or more name/value pairs. |
2899
|
|
|
|
|
|
|
Each pair declares one member of the class, |
2900
|
|
|
|
|
|
|
with the given name, and with attributes specified by the given value. |
2901
|
|
|
|
|
|
|
|
2902
|
|
|
|
|
|
|
=head1 MEMBER TYPES |
2903
|
|
|
|
|
|
|
|
2904
|
|
|
|
|
|
|
In the simplest name/value form, |
2905
|
|
|
|
|
|
|
the value you give is a string that defines the member's type. |
2906
|
|
|
|
|
|
|
A C<'$'> denotes a scalar member type. |
2907
|
|
|
|
|
|
|
A C<'@'> denotes an array type. |
2908
|
|
|
|
|
|
|
A C<'%'> denotes a hash type. |
2909
|
|
|
|
|
|
|
Thus: |
2910
|
|
|
|
|
|
|
|
2911
|
|
|
|
|
|
|
class Person => [ name => '$', age => '$' ]; |
2912
|
|
|
|
|
|
|
|
2913
|
|
|
|
|
|
|
creates a class named C with two scalar members, |
2914
|
|
|
|
|
|
|
C and C. |
2915
|
|
|
|
|
|
|
|
2916
|
|
|
|
|
|
|
If the type is followed by an identifier, |
2917
|
|
|
|
|
|
|
the identifier is assumed to be a class name, |
2918
|
|
|
|
|
|
|
and the member is restricted to a blessed reference of the class |
2919
|
|
|
|
|
|
|
(or one of its subclasses), |
2920
|
|
|
|
|
|
|
an array whose elements are blessed references of the class, |
2921
|
|
|
|
|
|
|
or a hash whose keys are strings |
2922
|
|
|
|
|
|
|
and whose values are blessed references of the class. |
2923
|
|
|
|
|
|
|
For scalars, the C<$> may be omitted; |
2924
|
|
|
|
|
|
|
i.e., C and C<$Class_Name> are equivalent. |
2925
|
|
|
|
|
|
|
The class need not be declared using the C package. |
2926
|
|
|
|
|
|
|
|
2927
|
|
|
|
|
|
|
=head1 CREATING INSTANCES |
2928
|
|
|
|
|
|
|
|
2929
|
|
|
|
|
|
|
Each class that you generate has a constructor named C. |
2930
|
|
|
|
|
|
|
Invoking the constructor creates an instance of the class. |
2931
|
|
|
|
|
|
|
You may provide C with parameters to set the values of members: |
2932
|
|
|
|
|
|
|
|
2933
|
|
|
|
|
|
|
class Person => [ name => '$', age => '$' ]; |
2934
|
|
|
|
|
|
|
$p = Person->new; # Neither name nor age is defined. |
2935
|
|
|
|
|
|
|
$q = Person->new( name => 'Jim' ); # Only name is defined. |
2936
|
|
|
|
|
|
|
$r = Person->new( age => 32 ); # Only age is defined. |
2937
|
|
|
|
|
|
|
|
2938
|
|
|
|
|
|
|
=head1 ACCESSOR METHODS |
2939
|
|
|
|
|
|
|
|
2940
|
|
|
|
|
|
|
A class has a standard set of accessor methods for each member you specify. |
2941
|
|
|
|
|
|
|
The accessor methods depend on a member's type. |
2942
|
|
|
|
|
|
|
|
2943
|
|
|
|
|
|
|
=head2 Scalar (name => '$', name => 'Class_Name', or name => '$Class_Name') |
2944
|
|
|
|
|
|
|
|
2945
|
|
|
|
|
|
|
The member is a scalar. |
2946
|
|
|
|
|
|
|
The member has a single method C. |
2947
|
|
|
|
|
|
|
If called with no arguments, it returns the member's current value. |
2948
|
|
|
|
|
|
|
If called with arguments, it sets the member to the first value: |
2949
|
|
|
|
|
|
|
|
2950
|
|
|
|
|
|
|
$p = Person->new; |
2951
|
|
|
|
|
|
|
$p->age(32); # Sets age member to 32. |
2952
|
|
|
|
|
|
|
print $p->age; # Prints 32. |
2953
|
|
|
|
|
|
|
|
2954
|
|
|
|
|
|
|
If the C form is used, the member must be a reference blessed |
2955
|
|
|
|
|
|
|
to the named class or to one of its subclasses. |
2956
|
|
|
|
|
|
|
The method will C (see L) if the argument is not |
2957
|
|
|
|
|
|
|
a blessed reference to an instance of C or one of its subclasses. |
2958
|
|
|
|
|
|
|
|
2959
|
|
|
|
|
|
|
class Person => [ |
2960
|
|
|
|
|
|
|
name => '$', |
2961
|
|
|
|
|
|
|
spouse => 'Person' # Works, even though Person |
2962
|
|
|
|
|
|
|
]; # isn't yet defined. |
2963
|
|
|
|
|
|
|
$p = Person->new(name => 'Simon Bar-Sinister'); |
2964
|
|
|
|
|
|
|
$q = Person->new(name => 'Polly Purebred'); |
2965
|
|
|
|
|
|
|
$r = Person->new(name => 'Underdog'); |
2966
|
|
|
|
|
|
|
$r->spouse($q); # Underdog marries Polly. |
2967
|
|
|
|
|
|
|
print $r->spouse->name; # Prints 'Polly Purebred'. |
2968
|
|
|
|
|
|
|
print "He's married" if defined $p->spouse; # Prints nothing. |
2969
|
|
|
|
|
|
|
$p->spouse('Natasha Fatale'); # Croaks. |
2970
|
|
|
|
|
|
|
|
2971
|
|
|
|
|
|
|
=head2 Array (name => '@' or name => '@Class') |
2972
|
|
|
|
|
|
|
|
2973
|
|
|
|
|
|
|
The member is an array. |
2974
|
|
|
|
|
|
|
If the C<@Class> form is used, all members of the array must be |
2975
|
|
|
|
|
|
|
a blessed reference to C or one of its subclasses. |
2976
|
|
|
|
|
|
|
An array member has four associated methods: |
2977
|
|
|
|
|
|
|
|
2978
|
|
|
|
|
|
|
=over 4 |
2979
|
|
|
|
|
|
|
|
2980
|
|
|
|
|
|
|
=item C |
2981
|
|
|
|
|
|
|
|
2982
|
|
|
|
|
|
|
With no argument, C returns the member's whole array. |
2983
|
|
|
|
|
|
|
|
2984
|
|
|
|
|
|
|
With one argument, C's behavior depends on |
2985
|
|
|
|
|
|
|
whether the argument is an array reference. |
2986
|
|
|
|
|
|
|
If it is not, then the argument must be an integer I, |
2987
|
|
|
|
|
|
|
and C returns element I of the member. |
2988
|
|
|
|
|
|
|
If no such element exists, C returns C. |
2989
|
|
|
|
|
|
|
If the argument is an array reference, |
2990
|
|
|
|
|
|
|
it is cast into an array and assigned to the member. |
2991
|
|
|
|
|
|
|
|
2992
|
|
|
|
|
|
|
With two arguments, the first argument must be an integer I. |
2993
|
|
|
|
|
|
|
The second argument is assigned to element I of the member. |
2994
|
|
|
|
|
|
|
|
2995
|
|
|
|
|
|
|
=item C |
2996
|
|
|
|
|
|
|
|
2997
|
|
|
|
|
|
|
This method appends its arguments to the member's array. |
2998
|
|
|
|
|
|
|
|
2999
|
|
|
|
|
|
|
=item C |
3000
|
|
|
|
|
|
|
|
3001
|
|
|
|
|
|
|
This method returns the index of the last element in the array. |
3002
|
|
|
|
|
|
|
|
3003
|
|
|
|
|
|
|
=item C |
3004
|
|
|
|
|
|
|
|
3005
|
|
|
|
|
|
|
This method returns the last element of C, |
3006
|
|
|
|
|
|
|
or C if C has no elements. |
3007
|
|
|
|
|
|
|
It's a shorthand for C<$o-Earray_mem($o-Earray_mem_size)>. |
3008
|
|
|
|
|
|
|
|
3009
|
|
|
|
|
|
|
=back |
3010
|
|
|
|
|
|
|
|
3011
|
|
|
|
|
|
|
For example: |
3012
|
|
|
|
|
|
|
|
3013
|
|
|
|
|
|
|
class Person => [ name => '$', kids => '@Person' ]; |
3014
|
|
|
|
|
|
|
$p = Person->new; |
3015
|
|
|
|
|
|
|
$p->add_kids(Person->new(name => 'Heckle'), |
3016
|
|
|
|
|
|
|
Person->new(name => 'Jeckle')); |
3017
|
|
|
|
|
|
|
print $p->kids_size; # Prints 1. |
3018
|
|
|
|
|
|
|
$p->kids([Person->new(name => 'Bugs Bunny'), |
3019
|
|
|
|
|
|
|
Person->new(name => 'Daffy Duck')]); |
3020
|
|
|
|
|
|
|
$p->add_kids(Person->new(name => 'Yosemite Sam'), |
3021
|
|
|
|
|
|
|
Person->new(name => 'Porky Pig')); |
3022
|
|
|
|
|
|
|
print $p->kids_size; # Prints 3. |
3023
|
|
|
|
|
|
|
$p->kids(2, Person->new(name => 'Elmer Fudd')); |
3024
|
|
|
|
|
|
|
print $p->kids(2)->name; # Prints 'Elmer Fudd'. |
3025
|
|
|
|
|
|
|
@kids = $p->kids; # Get all the kids. |
3026
|
|
|
|
|
|
|
print $p->kids($p->kids_size)->name; # Prints 'Porky Pig'. |
3027
|
|
|
|
|
|
|
print $p->last_kids->name; # So does this. |
3028
|
|
|
|
|
|
|
|
3029
|
|
|
|
|
|
|
=head2 Hash (name => '%' or name => '%Class') |
3030
|
|
|
|
|
|
|
|
3031
|
|
|
|
|
|
|
The member is a hash. |
3032
|
|
|
|
|
|
|
If the C<%Class> form is used, all values in the hash |
3033
|
|
|
|
|
|
|
must be a blessed reference to C or one of its subclasses. |
3034
|
|
|
|
|
|
|
A hash member has four associated methods: |
3035
|
|
|
|
|
|
|
|
3036
|
|
|
|
|
|
|
=over 4 |
3037
|
|
|
|
|
|
|
|
3038
|
|
|
|
|
|
|
=item C |
3039
|
|
|
|
|
|
|
|
3040
|
|
|
|
|
|
|
With no arguments, C returns the member's whole hash. |
3041
|
|
|
|
|
|
|
|
3042
|
|
|
|
|
|
|
With one argument that is a hash reference, |
3043
|
|
|
|
|
|
|
the member's value becomes the key/value pairs in that reference. |
3044
|
|
|
|
|
|
|
With one argument that is a string, |
3045
|
|
|
|
|
|
|
the element of the hash keyed by that string is returned. |
3046
|
|
|
|
|
|
|
If no such element exists, C returns C. |
3047
|
|
|
|
|
|
|
|
3048
|
|
|
|
|
|
|
With two arguments, the second argument is assigned to the hash, |
3049
|
|
|
|
|
|
|
keyed by the string representation of the first argument. |
3050
|
|
|
|
|
|
|
|
3051
|
|
|
|
|
|
|
=item C |
3052
|
|
|
|
|
|
|
|
3053
|
|
|
|
|
|
|
The C method returns all keys associated with the member. |
3054
|
|
|
|
|
|
|
|
3055
|
|
|
|
|
|
|
=item C |
3056
|
|
|
|
|
|
|
|
3057
|
|
|
|
|
|
|
The C method returns all values associated with the member. |
3058
|
|
|
|
|
|
|
|
3059
|
|
|
|
|
|
|
=item C |
3060
|
|
|
|
|
|
|
|
3061
|
|
|
|
|
|
|
The C method takes one or more arguments. |
3062
|
|
|
|
|
|
|
It deletes from C's hash all elements matching the arguments. |
3063
|
|
|
|
|
|
|
|
3064
|
|
|
|
|
|
|
=back |
3065
|
|
|
|
|
|
|
|
3066
|
|
|
|
|
|
|
For example: |
3067
|
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
|
class Person => [ name => '$', kids => '%Kid_Info' ]; |
3069
|
|
|
|
|
|
|
class Kid_Info => [ |
3070
|
|
|
|
|
|
|
grade => '$', |
3071
|
|
|
|
|
|
|
skills => '@' |
3072
|
|
|
|
|
|
|
]; |
3073
|
|
|
|
|
|
|
$f = new Person( |
3074
|
|
|
|
|
|
|
name => 'Fred Flintstone', |
3075
|
|
|
|
|
|
|
kids => { Pebbles => new Kid_Info(grade => 1, |
3076
|
|
|
|
|
|
|
skills => ['Programs VCR']) } |
3077
|
|
|
|
|
|
|
); |
3078
|
|
|
|
|
|
|
print $f->kids('Pebbles')->grade; # Prints 1. |
3079
|
|
|
|
|
|
|
$b = new Kid_Info; |
3080
|
|
|
|
|
|
|
$b->grade('Kindergarten'); |
3081
|
|
|
|
|
|
|
$b->skills(['Knows Perl', 'Phreaks']); |
3082
|
|
|
|
|
|
|
$f->kids('BamBam', $b); |
3083
|
|
|
|
|
|
|
print join ', ', $f->kids_keys; # Prints "Pebbles, BamBam", |
3084
|
|
|
|
|
|
|
# though maybe not in that order. |
3085
|
|
|
|
|
|
|
|
3086
|
|
|
|
|
|
|
=head1 COMMON METHODS |
3087
|
|
|
|
|
|
|
|
3088
|
|
|
|
|
|
|
All members also have a method C. |
3089
|
|
|
|
|
|
|
This method undefines a member C. |
3090
|
|
|
|
|
|
|
|
3091
|
|
|
|
|
|
|
=head1 OBJECT INSTANCE METHODS |
3092
|
|
|
|
|
|
|
|
3093
|
|
|
|
|
|
|
C also generates methods |
3094
|
|
|
|
|
|
|
that you can invoke on an object instance. |
3095
|
|
|
|
|
|
|
These are as follows: |
3096
|
|
|
|
|
|
|
|
3097
|
|
|
|
|
|
|
=head2 Copy |
3098
|
|
|
|
|
|
|
|
3099
|
|
|
|
|
|
|
Use the C method to copy the value of an object. |
3100
|
|
|
|
|
|
|
The expression: |
3101
|
|
|
|
|
|
|
|
3102
|
|
|
|
|
|
|
$p = $o->copy; |
3103
|
|
|
|
|
|
|
|
3104
|
|
|
|
|
|
|
assigns to C<$p> a copy of C<$o>. |
3105
|
|
|
|
|
|
|
Members of C<$o> that are classes (or arrays or hashes of classes) |
3106
|
|
|
|
|
|
|
are copied using their own C method. |
3107
|
|
|
|
|
|
|
|
3108
|
|
|
|
|
|
|
=head2 Equals |
3109
|
|
|
|
|
|
|
|
3110
|
|
|
|
|
|
|
Use the C method to test the equality of two object instances: |
3111
|
|
|
|
|
|
|
|
3112
|
|
|
|
|
|
|
if ( $o1->equals($o2) ) { ... } |
3113
|
|
|
|
|
|
|
|
3114
|
|
|
|
|
|
|
The two object instances are equal if |
3115
|
|
|
|
|
|
|
members that have values in C<$o1> have equal values in C<$o2>, and vice versa. |
3116
|
|
|
|
|
|
|
Equality is tested as you would expect: |
3117
|
|
|
|
|
|
|
two scalar members are equal if they have the same value; |
3118
|
|
|
|
|
|
|
two array members are equal if they have the same elements; |
3119
|
|
|
|
|
|
|
two hash members are equal if they have the same key/value pairs. |
3120
|
|
|
|
|
|
|
|
3121
|
|
|
|
|
|
|
If a member's value is restricted to a class, |
3122
|
|
|
|
|
|
|
then equality is tested using that class' C method. |
3123
|
|
|
|
|
|
|
Otherwise, it is tested using the C operator. |
3124
|
|
|
|
|
|
|
|
3125
|
|
|
|
|
|
|
By default, all members participate in the equality test. |
3126
|
|
|
|
|
|
|
If one or more members possess true values for the C attribute, |
3127
|
|
|
|
|
|
|
then only those members participate in the equality test. |
3128
|
|
|
|
|
|
|
|
3129
|
|
|
|
|
|
|
You can override this definition of equality. |
3130
|
|
|
|
|
|
|
See L. |
3131
|
|
|
|
|
|
|
|
3132
|
|
|
|
|
|
|
=head1 ADVANCED MEMBER SPECIFICATIONS |
3133
|
|
|
|
|
|
|
|
3134
|
|
|
|
|
|
|
As shown, you specify each member as a Cvalue> pair. |
3135
|
|
|
|
|
|
|
If the C is a string, it specifies the member's type. |
3136
|
|
|
|
|
|
|
The value may also be a hash reference. |
3137
|
|
|
|
|
|
|
You use hash references to specify additional member attributes. |
3138
|
|
|
|
|
|
|
The following is a complete list of the attributes you may specify for a member: |
3139
|
|
|
|
|
|
|
|
3140
|
|
|
|
|
|
|
=over 4 |
3141
|
|
|
|
|
|
|
|
3142
|
|
|
|
|
|
|
=item type=>string |
3143
|
|
|
|
|
|
|
|
3144
|
|
|
|
|
|
|
If you use a hash reference for a member's value, |
3145
|
|
|
|
|
|
|
you I use the C attribute to specify its type: |
3146
|
|
|
|
|
|
|
|
3147
|
|
|
|
|
|
|
scalar_member => { type => '$' } |
3148
|
|
|
|
|
|
|
|
3149
|
|
|
|
|
|
|
=item required=>boolean |
3150
|
|
|
|
|
|
|
|
3151
|
|
|
|
|
|
|
If the C attribute is true, |
3152
|
|
|
|
|
|
|
the member must be passed each time the class' constructor is invoked: |
3153
|
|
|
|
|
|
|
|
3154
|
|
|
|
|
|
|
class Person => [ name => { type => '$', required => 1 } ]; |
3155
|
|
|
|
|
|
|
Person->new ( name => 'Wilma' ); # Valid |
3156
|
|
|
|
|
|
|
Person->new; # Invalid |
3157
|
|
|
|
|
|
|
|
3158
|
|
|
|
|
|
|
Also, you may not call C for the member. |
3159
|
|
|
|
|
|
|
|
3160
|
|
|
|
|
|
|
=item default=>value |
3161
|
|
|
|
|
|
|
|
3162
|
|
|
|
|
|
|
The C attribute provides a default value for a member |
3163
|
|
|
|
|
|
|
if none is passed to the constructor: |
3164
|
|
|
|
|
|
|
|
3165
|
|
|
|
|
|
|
class Person => [ name => '$', |
3166
|
|
|
|
|
|
|
job => { type => '$', |
3167
|
|
|
|
|
|
|
default => "'Perl programmer'" } ]; |
3168
|
|
|
|
|
|
|
$p = Person->new(name => 'Larry'); |
3169
|
|
|
|
|
|
|
print $p->job; # Prints 'Perl programmer'. |
3170
|
|
|
|
|
|
|
$q = Person->new(name => 'Bjourne', job => 'C++ programmer'); |
3171
|
|
|
|
|
|
|
print $q->job; # Unprintable. |
3172
|
|
|
|
|
|
|
|
3173
|
|
|
|
|
|
|
The value is treated as a string that is evaluated |
3174
|
|
|
|
|
|
|
when the constructor is invoked. |
3175
|
|
|
|
|
|
|
|
3176
|
|
|
|
|
|
|
For array members, use a string that looks like a Perl expression |
3177
|
|
|
|
|
|
|
that evaluates to an array reference: |
3178
|
|
|
|
|
|
|
|
3179
|
|
|
|
|
|
|
class Person => { |
3180
|
|
|
|
|
|
|
name => '$', |
3181
|
|
|
|
|
|
|
lucky_numbers => { type => '@', default => '[42, 17]' } |
3182
|
|
|
|
|
|
|
}; |
3183
|
|
|
|
|
|
|
class Silly => { |
3184
|
|
|
|
|
|
|
UIDs => { # Default value is all UIDs |
3185
|
|
|
|
|
|
|
type => '@', # currently in /etc/passwd. |
3186
|
|
|
|
|
|
|
default => 'do { |
3187
|
|
|
|
|
|
|
local $/ = undef; |
3188
|
|
|
|
|
|
|
open PASSWD, "/etc/passwd"; |
3189
|
|
|
|
|
|
|
[ map {(split(/:/))[2]} split /\n/, ] |
3190
|
|
|
|
|
|
|
}' |
3191
|
|
|
|
|
|
|
} |
3192
|
|
|
|
|
|
|
}; |
3193
|
|
|
|
|
|
|
|
3194
|
|
|
|
|
|
|
Specify hash members analogously. |
3195
|
|
|
|
|
|
|
|
3196
|
|
|
|
|
|
|
The value is evaluated each time the constructor is invoked. |
3197
|
|
|
|
|
|
|
In C, the default value for C can change between invocations. |
3198
|
|
|
|
|
|
|
If the default value is a reference rather than a string, |
3199
|
|
|
|
|
|
|
it is not re-evaluated. |
3200
|
|
|
|
|
|
|
In the following, default values for C and C |
3201
|
|
|
|
|
|
|
are based on the members of C<@default_value> |
3202
|
|
|
|
|
|
|
each time Cnew> is invoked, |
3203
|
|
|
|
|
|
|
whereas C's default value is set when the C function is invoked |
3204
|
|
|
|
|
|
|
to define C: |
3205
|
|
|
|
|
|
|
|
3206
|
|
|
|
|
|
|
@default_value = (1, 2, 3); |
3207
|
|
|
|
|
|
|
$var_name = '@' . __PACKAGE__ . '::default_value'; |
3208
|
|
|
|
|
|
|
class Example => { |
3209
|
|
|
|
|
|
|
e1 => { type => '@', default => "[$var_name]" }, |
3210
|
|
|
|
|
|
|
e2 => { type => '@', default => \@default_value }, |
3211
|
|
|
|
|
|
|
e3 => { type => '@', default => [ @default_value ] } |
3212
|
|
|
|
|
|
|
}; |
3213
|
|
|
|
|
|
|
Example->new; # e1, e2, and e3 are all identical. |
3214
|
|
|
|
|
|
|
@default_value = (10, 20, 30); |
3215
|
|
|
|
|
|
|
Example->new; # Now only e3 is (1, 2, 3). |
3216
|
|
|
|
|
|
|
|
3217
|
|
|
|
|
|
|
There are two more things to know about default values that are strings. |
3218
|
|
|
|
|
|
|
First, if a member is typed, |
3219
|
|
|
|
|
|
|
the C function evaluates its (string-based) |
3220
|
|
|
|
|
|
|
default value to ensure that it |
3221
|
|
|
|
|
|
|
is of the correct type for the member. |
3222
|
|
|
|
|
|
|
Be aware of this if your default value has side effects |
3223
|
|
|
|
|
|
|
(and see L). |
3224
|
|
|
|
|
|
|
|
3225
|
|
|
|
|
|
|
Second, the context of the default value is the C method |
3226
|
|
|
|
|
|
|
of the package generated to implement your class. |
3227
|
|
|
|
|
|
|
That's why C in C, above, |
3228
|
|
|
|
|
|
|
needs the name of the current package in its default value. |
3229
|
|
|
|
|
|
|
|
3230
|
|
|
|
|
|
|
=item post=>code |
3231
|
|
|
|
|
|
|
|
3232
|
|
|
|
|
|
|
The value of this attribute is a string of Perl code. |
3233
|
|
|
|
|
|
|
It is executed immediately after the member's value is modified through its accessor. |
3234
|
|
|
|
|
|
|
Within C code, you can refer to members as if they were Perl identifiers. |
3235
|
|
|
|
|
|
|
For instance: |
3236
|
|
|
|
|
|
|
|
3237
|
|
|
|
|
|
|
class Person => [ age => { type => '$', |
3238
|
|
|
|
|
|
|
post => '$age *= 2;' } ]; |
3239
|
|
|
|
|
|
|
$p = Person->new(age => 30); |
3240
|
|
|
|
|
|
|
print $p->age; # Prints 30. |
3241
|
|
|
|
|
|
|
$p->age(15); |
3242
|
|
|
|
|
|
|
print $p->age; # Prints 30 again. |
3243
|
|
|
|
|
|
|
|
3244
|
|
|
|
|
|
|
The trailing semicolon used to be required, but everyone forgot it. |
3245
|
|
|
|
|
|
|
As of version 1.06 it's optional: |
3246
|
|
|
|
|
|
|
C<'$age*=2'> is accepted and equivalent to C<'$age*=2;'> |
3247
|
|
|
|
|
|
|
(but see L<"BUGS">). |
3248
|
|
|
|
|
|
|
|
3249
|
|
|
|
|
|
|
You reference array and hash members as usual |
3250
|
|
|
|
|
|
|
(except for testing for definition; see L<"BUGS">). |
3251
|
|
|
|
|
|
|
You can reference individual elements, or the whole list: |
3252
|
|
|
|
|
|
|
|
3253
|
|
|
|
|
|
|
class Foo => [ |
3254
|
|
|
|
|
|
|
m1 => { type => '@', post => '$m1[$#m1/2] = $m2{xxx};' }, |
3255
|
|
|
|
|
|
|
m2 => { type => '%', post => '@m1 = keys %m2;' } |
3256
|
|
|
|
|
|
|
]; |
3257
|
|
|
|
|
|
|
|
3258
|
|
|
|
|
|
|
You can also invoke accessors. |
3259
|
|
|
|
|
|
|
Prefix them with a C<&>: |
3260
|
|
|
|
|
|
|
|
3261
|
|
|
|
|
|
|
class Bar => [ |
3262
|
|
|
|
|
|
|
m1 => { type => '@', post => '&undef_m1;' }, |
3263
|
|
|
|
|
|
|
m2 => { type => '%', post => '@m1 = &m2_keys;' } |
3264
|
|
|
|
|
|
|
]; |
3265
|
|
|
|
|
|
|
$o = new Bar; |
3266
|
|
|
|
|
|
|
$o->m1([1, 2, 3]); # m1 is still undefined. |
3267
|
|
|
|
|
|
|
$o->m2({a => 1, b => 2}); # Now m1 is qw(a b). |
3268
|
|
|
|
|
|
|
|
3269
|
|
|
|
|
|
|
=item pre=>code |
3270
|
|
|
|
|
|
|
|
3271
|
|
|
|
|
|
|
The C key is similar to the C key, |
3272
|
|
|
|
|
|
|
but it is executed just before an member is changed. |
3273
|
|
|
|
|
|
|
It is I executed if the member is only accessed. |
3274
|
|
|
|
|
|
|
The C and C code have the same scope, |
3275
|
|
|
|
|
|
|
which lets you share variables. |
3276
|
|
|
|
|
|
|
For instance: |
3277
|
|
|
|
|
|
|
|
3278
|
|
|
|
|
|
|
class Foo => [ |
3279
|
|
|
|
|
|
|
mem => { type => '$', pre => 'my $v = $mem;', post => 'return $v;' } |
3280
|
|
|
|
|
|
|
]; |
3281
|
|
|
|
|
|
|
$o = new Foo; |
3282
|
|
|
|
|
|
|
$p = $o->mem(1); # Sets $p to undef. |
3283
|
|
|
|
|
|
|
$q = $o->mem(2); # Sets $q to 1. |
3284
|
|
|
|
|
|
|
|
3285
|
|
|
|
|
|
|
is a way to return the previous value of C any time it's modified |
3286
|
|
|
|
|
|
|
(but see L<"NOTES">). |
3287
|
|
|
|
|
|
|
|
3288
|
|
|
|
|
|
|
=item assert=>expression |
3289
|
|
|
|
|
|
|
|
3290
|
|
|
|
|
|
|
The value of this key should be a Perl expression |
3291
|
|
|
|
|
|
|
that evaluates to true or false. |
3292
|
|
|
|
|
|
|
Use member names in the expression, as with C. |
3293
|
|
|
|
|
|
|
The expression will be tested any time |
3294
|
|
|
|
|
|
|
the member is modified through its accessors. |
3295
|
|
|
|
|
|
|
Your code will C if the expression evaluates to false. |
3296
|
|
|
|
|
|
|
For instance, |
3297
|
|
|
|
|
|
|
|
3298
|
|
|
|
|
|
|
class Person => [ |
3299
|
|
|
|
|
|
|
name => '$', |
3300
|
|
|
|
|
|
|
age => { type => '$', |
3301
|
|
|
|
|
|
|
assert => '$age =~ /^\d+$/ && $age < 200' } ]; |
3302
|
|
|
|
|
|
|
|
3303
|
|
|
|
|
|
|
ensures the age is reasonable. |
3304
|
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
|
The assertion is executed after any C code associated with the member. |
3306
|
|
|
|
|
|
|
|
3307
|
|
|
|
|
|
|
=item private=>boolean |
3308
|
|
|
|
|
|
|
|
3309
|
|
|
|
|
|
|
If the C attribute is true, |
3310
|
|
|
|
|
|
|
the member cannot be accessed outside the class; |
3311
|
|
|
|
|
|
|
that is, it has no accessor functions that can be called |
3312
|
|
|
|
|
|
|
outside the scope of the package defined by C. |
3313
|
|
|
|
|
|
|
A private member can, however, be accessed in C, C, and C |
3314
|
|
|
|
|
|
|
code of other members of the class. |
3315
|
|
|
|
|
|
|
|
3316
|
|
|
|
|
|
|
=item protected=>boolean |
3317
|
|
|
|
|
|
|
|
3318
|
|
|
|
|
|
|
If the C attribute is true, |
3319
|
|
|
|
|
|
|
the member cannot be accessed outside the class or any of its subclasses. |
3320
|
|
|
|
|
|
|
A protected member can, however, be accessed in C, C, and C |
3321
|
|
|
|
|
|
|
code of other members of the class or its subclasses. |
3322
|
|
|
|
|
|
|
|
3323
|
|
|
|
|
|
|
=item readonly=>boolean |
3324
|
|
|
|
|
|
|
|
3325
|
|
|
|
|
|
|
If this attribute is true, then the member cannot be modified |
3326
|
|
|
|
|
|
|
through its accessors. |
3327
|
|
|
|
|
|
|
Users can set the member only by using the class constructor. |
3328
|
|
|
|
|
|
|
The member's accessor that is its name can retrieve but not set the member. |
3329
|
|
|
|
|
|
|
The CI accessor is not defined for the member, |
3330
|
|
|
|
|
|
|
nor are other accessors that might modify the member. |
3331
|
|
|
|
|
|
|
(Code in C can set it, however.) |
3332
|
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
|
=item key=>boolean |
3334
|
|
|
|
|
|
|
|
3335
|
|
|
|
|
|
|
If this attribute is true, then the member participates in equality tests. |
3336
|
|
|
|
|
|
|
See L<"Equals">. |
3337
|
|
|
|
|
|
|
|
3338
|
|
|
|
|
|
|
=item nocopy=>value |
3339
|
|
|
|
|
|
|
|
3340
|
|
|
|
|
|
|
The C attribute gives you some per-member control |
3341
|
|
|
|
|
|
|
over how the C method. |
3342
|
|
|
|
|
|
|
If C is false (the default), |
3343
|
|
|
|
|
|
|
the original's value is copied as described in L<"Copy">. |
3344
|
|
|
|
|
|
|
If C is true, |
3345
|
|
|
|
|
|
|
the original's value is assigned rather than copied; |
3346
|
|
|
|
|
|
|
in other words, the copy and the original will have the same value |
3347
|
|
|
|
|
|
|
if the original's value is a reference. |
3348
|
|
|
|
|
|
|
|
3349
|
|
|
|
|
|
|
=back |
3350
|
|
|
|
|
|
|
|
3351
|
|
|
|
|
|
|
=head1 AFFECTING THE CONSTRUCTOR |
3352
|
|
|
|
|
|
|
|
3353
|
|
|
|
|
|
|
You may include a C attribute in the specification to affect the constructor. |
3354
|
|
|
|
|
|
|
Its value must be a hash reference. |
3355
|
|
|
|
|
|
|
Its attributes are: |
3356
|
|
|
|
|
|
|
|
3357
|
|
|
|
|
|
|
=over 4 |
3358
|
|
|
|
|
|
|
|
3359
|
|
|
|
|
|
|
=item required=>list of constraints |
3360
|
|
|
|
|
|
|
|
3361
|
|
|
|
|
|
|
This is another (and more general) way to require that |
3362
|
|
|
|
|
|
|
parameters be passed to the constructor. |
3363
|
|
|
|
|
|
|
Its value is a reference to an array of constraints. |
3364
|
|
|
|
|
|
|
Each constraint is a string that must be an expression |
3365
|
|
|
|
|
|
|
composed of Perl logical operators and member names. |
3366
|
|
|
|
|
|
|
For example: |
3367
|
|
|
|
|
|
|
|
3368
|
|
|
|
|
|
|
class Person => { |
3369
|
|
|
|
|
|
|
name => '$', |
3370
|
|
|
|
|
|
|
age => '$', |
3371
|
|
|
|
|
|
|
height => '$', |
3372
|
|
|
|
|
|
|
weight => '$', |
3373
|
|
|
|
|
|
|
new => { required => ['name', 'height^weight'] } |
3374
|
|
|
|
|
|
|
}; |
3375
|
|
|
|
|
|
|
|
3376
|
|
|
|
|
|
|
requires member C, and exactly one of C or C. |
3377
|
|
|
|
|
|
|
Note that the names are I prefixed with C<$>, C<@>, or C<%>. |
3378
|
|
|
|
|
|
|
|
3379
|
|
|
|
|
|
|
Specifying a list of constraints as an array reference can be clunky. |
3380
|
|
|
|
|
|
|
The C function also lets you specify the list as a string, |
3381
|
|
|
|
|
|
|
with individual constraints separated by spaces. |
3382
|
|
|
|
|
|
|
The following two strings are equivalent to the above C attribute: |
3383
|
|
|
|
|
|
|
|
3384
|
|
|
|
|
|
|
'name height^weight' |
3385
|
|
|
|
|
|
|
'name&(height^weight)' |
3386
|
|
|
|
|
|
|
|
3387
|
|
|
|
|
|
|
However, C<'name & (height ^ weight)'> would not work. |
3388
|
|
|
|
|
|
|
The C function interprets it as a five-member list, |
3389
|
|
|
|
|
|
|
four members of which are not valid expressions. |
3390
|
|
|
|
|
|
|
|
3391
|
|
|
|
|
|
|
This equivalence between a reference to array of strings |
3392
|
|
|
|
|
|
|
and a string of space-separated items is used throughout C. |
3393
|
|
|
|
|
|
|
Use whichever form works best for you. |
3394
|
|
|
|
|
|
|
|
3395
|
|
|
|
|
|
|
=item post=>string of code |
3396
|
|
|
|
|
|
|
|
3397
|
|
|
|
|
|
|
The C key is similar to the C key for members. |
3398
|
|
|
|
|
|
|
Its value is code that is inserted into the constructor |
3399
|
|
|
|
|
|
|
after parameter values have been assigned to members. |
3400
|
|
|
|
|
|
|
The C function performs variable substitution. |
3401
|
|
|
|
|
|
|
|
3402
|
|
|
|
|
|
|
The C key is I recognized in C. |
3403
|
|
|
|
|
|
|
|
3404
|
|
|
|
|
|
|
=item assert=>expression |
3405
|
|
|
|
|
|
|
|
3406
|
|
|
|
|
|
|
The C key's value is inserted |
3407
|
|
|
|
|
|
|
just after the C key's value (if any). |
3408
|
|
|
|
|
|
|
Assertions for members are inserted after the constructor's assertion. |
3409
|
|
|
|
|
|
|
|
3410
|
|
|
|
|
|
|
=item comment=>string |
3411
|
|
|
|
|
|
|
|
3412
|
|
|
|
|
|
|
This attribute's value can be any string. |
3413
|
|
|
|
|
|
|
If you save the class to a file |
3414
|
|
|
|
|
|
|
(see L), |
3415
|
|
|
|
|
|
|
the string is included as a comment just before |
3416
|
|
|
|
|
|
|
the member's methods. |
3417
|
|
|
|
|
|
|
|
3418
|
|
|
|
|
|
|
=item style=>style definition |
3419
|
|
|
|
|
|
|
|
3420
|
|
|
|
|
|
|
The C |