File Coverage

blib/lib/Class/Generate.pm
Criterion Covered Total %
statement 1733 1928 89.8
branch 631 890 70.9
condition 115 187 61.5
subroutine 353 374 94.3
pod 3 3 100.0
total 2835 3382 83.8


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