File Coverage

blib/lib/Class/Generate.pm
Criterion Covered Total %
statement 1738 1928 90.1
branch 636 890 71.4
condition 118 187 63.1
subroutine 352 374 94.1
pod 3 3 100.0
total 2847 3382 84.1


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