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