File Coverage

blib/lib/Class/AutoClass.pm
Criterion Covered Total %
statement 469 481 97.5
branch 188 226 83.2
condition 30 43 69.8
subroutine 71 72 98.6
pod 9 30 30.0
total 767 852 90.0


line stmt bran cond sub pod time code
1             package Class::AutoClass;
2 12     12   160 use strict;
  12         110  
  12         197  
3             our $VERSION = '1.0';
4 12     12   208 use vars qw($AUTOCLASS $AUTODB @ISA %CACHE @EXPORT);
  12         109  
  12         174  
5             $AUTOCLASS = __PACKAGE__;
6 12     12   392 use Class::AutoClass::Root;
  12         132  
  12         274  
7 12     12   333 use Class::AutoClass::Args;
  12         132  
  12         329  
8 12     12   230 use Storable qw(dclone);
  12         109  
  12         242  
9 12     12   820 use Carp;
  12         137  
  12         205  
10             @ISA = qw(Class::AutoClass::Root);
11              
12             sub new {
13 65     65 1 17937  my ( $class, @args ) = @_;
14 65   33     954  $class = ( ref $class ) || $class;
15             # NG 06-02-03: 1st attempt to call declare at runtime if not declared at compile-time
16             # declare($class) unless $class->DECLARED;
17             # NG 06-02-03: 2nd attempt to declare at runtime if not declared at compile-time
18             # include $case and flag to indicate this is runtime
19 65 100       964  declare($class,CASE($class),'runtime') unless $class->DECLARED;
20              
21 65   50     904  my $classes = $class->ANCESTORS || []; # NG 04-12-03. In case declare not called
22 65         851  my $can_new = $class->CAN_NEW;
23 65 100       812  if ( !@$classes ) { # compute on the fly for backwards compatibility
24             # enumerate internal super-classes and find a class to create object
25 1         11   ( $classes, $can_new ) = _enumerate($class);
26              }
27 65 50       780  my $self = $can_new ? $can_new->new(@args) : {};
28 65         737  bless $self, $class; # Rebless what comes from new just in case
29 65         1274  my $args = new Class::AutoClass::Args(@args);
30 65         1533  my $defaults = new Class::AutoClass::Args( $args->defaults );
31              
32             # set arg defaults into args
33 65         1017  while ( my ( $keyword, $value ) = each %$defaults ) {
34 0 0       0   $args->{$keyword} = $value unless exists $args->{$keyword};
35              }
36              
37             ################################################################################
38             # NG 05-12-08: initialization strategy changed. instead of init'ing class by class
39             # down the hierarchy, it's now done all at once.
40 65         1006  $self->_init($class,$args); # init attributes from args and defaults
41              
42             # $defaults=new Class::AutoClass::Args; # NG 05-12-07: reset $defaults.
43             # # will accumulate instance defaults during initialization
44             # my $default2code={};
45              
46 65         716  for my $class (@$classes) {
47 132         3067    my $init_self = $class->can('_init_self');
48 132 100       2293    $self->$init_self( $class, $args ) if $init_self;
49             # $self->_init( $class, $args, $defaults, $default2code );
50              }
51             ################################################################################
52              
53 65 100       5723    if($self->{__NULLIFY__}) {
    100          
54 1         13     return undef;
55                } elsif ($self->{__OVERRIDE__}) { # override self with the passed object
56 1         10       $self=$self->{__OVERRIDE__};
57 1         11       return $self;
58                } else {
59 63         967      return $self;
60                }
61             }
62              
63             ################################################################################
64             # NG 05-12-08: initialization strategy changed. instead of init'ing class by class
65             # down the hierarchy, it's now done all at once.
66             sub _init {
67 71     71   2800   my($self,$class,$args)=@_;
68 71         773   my @attributes=ATTRIBUTES_RECURSIVE($class);
69 71         869   my $defaults=DEFAULTS_RECURSIVE($class); # Args object
70 71         2021   my %fixed_attributes=FIXED_ATTRIBUTES_RECURSIVE($class);
71 71         1620   my %synonyms=SYNONYMS_RECURSIVE($class);
72 71         908   my %reverse=SYNONYMS_REVERSE($class); # reverse of SYNONYMS_RECURSIVE
73 71         831   my %cattributes=CATTRIBUTES_RECURSIVE($class);
74 71         987   my @cattributes=keys %cattributes;
75 71         964   my %iattributes=IATTRIBUTES_RECURSIVE($class);
76 71         1372   my @iattributes=keys %iattributes;
77 71         814   for my $func (@cattributes) { # class attributes
78 151         1402     my $fixed_func=$fixed_attributes{$func};
79 151 100       1654     next unless exists $args->{$fixed_func};
80             # no strict 'refs';
81             # next unless ref $self eq $class;
82 13         197     $class->$func($args->{$fixed_func});
83               }
84 71         6832   for my $func (@iattributes) { # instance attributes
85 729         7086     my $fixed_func=$fixed_attributes{$func};
86 729 100       11161     if (exists $args->{$fixed_func}) {
    100          
87 73         1001       $self->$func( $args->{$fixed_func} );
88                 } elsif (exists $defaults->{$fixed_func}) {
89             # because of synonyms, this is more complicated than it might appear.
90             # there are 4 cases: consider syn=>real
91             # 1) args sets syn, defaults sets syn
92             # 2) args sets real, defaults sets syn
93             # 3) args sets syn, defaults sets real
94             # 4) args sets real, defaults sets real
95 159 50       3871       next if exists $args->{$fixed_func}; # handles cases 1,4 plus case of not synonym
96 159         2187       my $real=$synonyms{$func};
97 159 100 100     2691       next if $real && exists $args->{$fixed_attributes{$real}}; # case 2
98 157         2229       my $syn_list=$reverse{$func};
99 22         771       next if $syn_list &&
100 157 100 100     1935 grep {exists $args->{$fixed_attributes{$_}}} @$syn_list; # case 3
101             # okay to set default!!
102 150         1776       my $value=$defaults->{$fixed_func};
103 150 50       2713       $value=ref $value? dclone($value): $value; # deep copy refs so each instance has own copy
104 150         7489       $self->$func($value);
105                 }
106               }
107             }
108              
109             ########################################
110              
111             #sub _init {
112             # my ( $self, $class, $args, $defaults, $default2code ) = @_;
113             # my %synonyms = SYNONYMS($class);
114             # my $attributes = ATTRIBUTES($class);
115             # # only object methods here
116             # $self->set_instance_defaults( $args, $defaults, $default2code, $class ); # NG 05-12-07
117             # $self->set_attributes( $attributes, $args, $defaults, $default2code, $class ); # NG 05-12-07
118             # my $init_self = $class->can('_init_self');
119             # $self->$init_self( $class, $args ) if $init_self;
120             #}
121              
122             sub set {
123 8     8 1 84  my $self = shift;
124 8         110  my $args = new Class::AutoClass::Args(@_);
125 8         116  while ( my ( $key, $value ) = each %$args ) {
126 12         149   my $func = $self->can($key);
127 12 50       183   $self->$func($value) if $func;
128              }
129             }
130              
131             sub get {
132 16     16 1 166  my $self = shift;
133 16         214  my @keys = Class::AutoClass::Args::fix_keyword(@_);
134 16         142  my @results;
135 16         136  for my $key (@keys) {
136 16         190   my $func = $self->can($key);
137 16 50       193   my $result = $func ? $self->$func() : undef;
138 16         181   push( @results, $result );
139              }
140 16 50       245  wantarray ? @results : $results[0];
141             }
142              
143             ########################################
144             # NG 05-12-09: changed to always call method. previous version just stored
145             # value for class attributes.
146             # note: this is user level method -- not just internal!!!
147             sub set_attributes {
148 2     2 1 22   my ( $self, $attributes, $args ) = @_;
149 2         31   my $class=$self->class;
150 2 50       69   $self->throw('Atrribute list must be an array ref') unless ref $attributes eq 'ARRAY';
151 2         26   my @attributes=Class::AutoClass::Args::fix_keyword(@$attributes);
152 2         21   for my $func (@attributes) {
153 8 50 33     191     next unless exists $args->{$func} && $class->can($func);
154 8         92     $self->$func( $args->{$func} );
155               }
156             }
157              
158             ## NG 05-12-07: process defaults. $defaults contains defaults seen so far in the
159             # # recursive initialization process that are NOT in $args. As we descend, also
160             # # have to check synonyms:
161             # @keywords=$class->ATTRIBUTES_RECURSIVE;
162             # for my $func (@keywords) {
163             # next unless exists $defaults->{$func};
164             # my $code=$class->can($func);
165             # next if $default2code->{$func} == $code;
166             # $self->$func($defaults->{$func});
167             # $default2code->{$func}=$code;
168             # }
169             ## for my $func (keys %$defaults) {
170             ## next if !$class->can($func);
171             ## $self->$func($defaults->{$func});
172             ## delete $defaults->{$func};
173             ## }
174             #}
175              
176             ## sets default attributes on a newly created instance
177             ## NG 05-12-07: changed to accumulate defaults in $defaults. setting done in set_attributes.
178             ## previous version set values directly into object HASH. this is wrong, since
179             ## it skips the important step of running the attribute's 'set' method.
180             #sub set_instance_defaults {
181             # my ( $self, $args, $defaults, $default2code, $class ) = @_;
182             # my %class_funcs;
183             # my $class_defaults = DEFAULTS($class);
184             # map { $class_funcs{$_}++ } CLASS_ATTRIBUTES($class);
185             # while ( my ( $key, $value ) = each %$class_defaults ) {
186             # next if exists $class_funcs{$key} || exists $args->{$key};
187             # $defaults->{$key} = ref $value? dclone($value): $value; # deep copy refs;
188             # delete $default2code->{$key}; # NG 05-12-07: so new default will be set
189             # }
190             #}
191              
192             ########################################
193             # NG 05-12-09: rewrote to use CATTRIBUTES_RECURSIVE. also changed to always call
194             # method. previous version just stored values
195             # sets class defaults at "declare time"
196             sub set_class_defaults {
197 41     41 1 5078  my ( $class ) = @_;
198 41         611  my $defaults = DEFAULTS_RECURSIVE($class); # Args object
199 41         898  my %fixed_attributes=FIXED_ATTRIBUTES_RECURSIVE($class);
200 41         4645  my %cattributes=CATTRIBUTES_RECURSIVE($class);
201 41         511  my @cattributes=keys %cattributes;
202 41         639  for my $func (@cattributes) { # class attributes
203 85         845    my $fixed_func=$fixed_attributes{$func};
204 85 100       956    next unless exists $defaults->{$fixed_func};
205 78         795    my $value=$defaults->{$fixed_func};
206             # NG 06-02-03. vcassen observed that dclone not needed here since there
207             # can only be one copy of each class attribute
208             # $value=ref $value? dclone($value): $value; # deep copy refs so each instance has own copy
209 78         1388    $class->$func($value);
210              }
211             }
212             ########################################
213 52     52 0 5465 sub class { ref $_[0]; }
214              
215             sub ISA {
216 87     87 0 826  my ($class) = @_;
217 87 50       2891  $class = $class->class if ref $class; # get class if called as object method
218 12     12   251  no strict 'refs';
  12         114  
  12         224  
219 87         703  @{ $class . '::ISA' };
  87         1425  
220             }
221              
222             sub AUTO_ATTRIBUTES {
223 83     83 1 809  my ($class) = @_;
224 83 50       1031  $class = $class->class if ref $class; # get class if called as object method
225 12     12   200  no strict 'refs';
  12         204  
  12         271  
226 83         769  @{ $class . '::AUTO_ATTRIBUTES' };
  83         1497  
227             }
228              
229             sub OTHER_ATTRIBUTES {
230 42     42 1 414  my ($class) = @_;
231 42 50       435  $class = $class->class if ref $class; # get class if called as object method
232 12     12   206  no strict 'refs';
  12         113  
  12         153  
233 42         375  @{ $class . '::OTHER_ATTRIBUTES' };
  42         534  
234             }
235              
236             sub CLASS_ATTRIBUTES {
237 83     83 0 881  my ($class) = @_;
238 12     12   368  no strict 'refs';
  12         149  
  12         217  
239 12     12   201  no warnings; # supress unitialized var warning
  12         112  
  12         274  
240 83         667  @{ $class . '::CLASS_ATTRIBUTES' };
  83         1308  
241             }
242              
243             sub SYNONYMS {
244 42     42 1 442  my ($class) = @_;
245 42 50       419  $class = $class->class if ref $class; # get class if called as object method
246 12     12   378  no strict 'refs';
  12         135  
  12         278  
247 42         352  %{ $class . '::SYNONYMS' };
  42         4031  
248             }
249             sub SYNONYMS_RECURSIVE {
250 135     135 0 1266  my $class = shift @_;
251 135 100       1469  $class = $class->class if ref $class; # get class if called as object method
252 12     12   197  no strict 'refs';
  12         113  
  12         257  
253 135         1378  my %synonyms;
254 135 100       1365  if (@_) {
255 28         252    %synonyms=%{ $class . '::SYNONYMS_RECURSIVE' } = @_;
  28         615  
256 28         290    my %reverse;
257 28         408    while(my($syn,$real)=each %synonyms) {
258 86   100     1284      my $list=$reverse{$real} || ($reverse{$real}=[]);
259 86         1096      push(@$list,$syn);
260                }
261 28         515    SYNONYMS_REVERSE($class, %reverse);
262              } else {
263 107         909    %synonyms=%{ $class . '::SYNONYMS_RECURSIVE' };
  107         1881  
264              }
265 135 100       5473  wantarray? %synonyms: \%synonyms;
266             }
267             sub SYNONYMS_REVERSE { # reverse of SYNONYMS_RECURSIVE. used to set instance defaults
268 99     99 0 964  my $class = shift @_;
269 99 100       963  $class = $class->class if ref $class; # get class if called as object method
270 12     12   258  no strict 'refs';
  12         167  
  12         155  
271 28         1739  my %synonyms=@_ ? %{ $class . '::SYNONYMS_REVERSE' } = @_:
  71         1161  
272 99 100       1164    %{ $class . '::SYNONYMS_REVERSE' };
273 99 100       1599  wantarray? %synonyms: \%synonyms;
274             }
275             # ATTRIBUTES -- all attributes
276             sub ATTRIBUTES {
277 42     42 0 408  my $class = shift @_;
278 42 50       714  $class = $class->class if ref $class; # get class if called as object method
279 12     12   190  no strict 'refs';
  12         142  
  12         155  
280 42 100       418  my @attributes=@_ ? @{ $class . '::ATTRIBUTES' } = @_ : @{ $class . '::ATTRIBUTES' };
  35         1221  
  7         89  
281 42 50       538  wantarray? @attributes: \@attributes;
282             }
283             sub ATTRIBUTES_RECURSIVE {
284 135     135 0 1291  my $class = shift @_;
285 135 100       1515  $class = $class->class if ref $class; # get class if called as object method
286 12     12   194  no strict 'refs';
  12         128  
  12         170  
287 35     35   354  sub _uniq {my %h; @h{@_}=@_; values %h;}
  35         4564  
  35         621  
288 35         1735  my @attributes=@_ ? @{ $class . '::ATTRIBUTES_RECURSIVE' } = _uniq(@_):
  100         1811  
289 135 100       1641    @{ $class . '::ATTRIBUTES_RECURSIVE' };
290 135 100       2548  wantarray? @attributes: \@attributes;
291             }
292