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             # maps attributes to fixed (ie, de-cased) attributes. use when initializing attributes
293             # to args or defauls
294             sub FIXED_ATTRIBUTES_RECURSIVE {
295 153     153 0 1714  my $class = shift @_;
296 153 100       1512  $class = $class->class if ref $class; # get class if called as object method
297 12     12   317  no strict 'refs';
  12         114  
  12         265  
298 35         3065  my %attributes=@_ ? %{ $class . '::FIXED_ATTRIBUTES_RECURSIVE' } = @_:
  118         3498  
299 153 100       1706    %{ $class . '::FIXED_ATTRIBUTES_RECURSIVE' };
300 153 100       5042  wantarray? %attributes: \%attributes;
301             }
302             # IATTRIBUTES -- instance attributes -- hash
303             sub IATTRIBUTES {
304 83     83 0 891  my $class = shift @_;
305 83 50       845  $class = $class->class if ref $class; # get class if called as object method
306 12     12   199  no strict 'refs';
  12         163  
  12         158  
307 83 100       895  my %attributes=@_ ? %{ $class . '::IATTRIBUTES' } = @_ : %{ $class . '::IATTRIBUTES' };
  32         1969  
  51         1383  
308 83 100       1664  wantarray? %attributes: \%attributes;
309             }
310             sub IATTRIBUTES_RECURSIVE {
311 135     135 0 1494  my $class = shift @_;
312 135 100       1745  $class = $class->class if ref $class; # get class if called as object method
313 12     12   193  no strict 'refs';
  12         112  
  12         221  
314 35         1391  my %attributes=@_ ? %{ $class . '::IATTRIBUTES_RECURSIVE' } = @_:
  100         3133  
315 135 100       1447    %{ $class . '::IATTRIBUTES_RECURSIVE' };
316 135 100       4600  wantarray? %attributes: \%attributes;
317             }
318             # CATTRIBUTES -- class attributes -- hash
319              
320             # NG 05-12-08: commented out. DEFAULTS_ARGS renamed to DEFAULTS
321             #sub DEFAULTS {
322             # my ($class) = @_;
323             # $class = $class->class if ref $class; # get class if called as object method
324             # no strict 'refs';
325             # %{ $class . '::DEFAULTS' };
326             #}
327             sub CATTRIBUTES {
328 42     42 0 394  my $class = shift @_;
329 42 50       456  $class = $class->class if ref $class; # get class if called as object method
330 12     12   209  no strict 'refs';
  12         114  
  12         216  
331 42 100       573  my %attributes=@_ ? %{ $class . '::CATTRIBUTES' } = @_ : %{ $class . '::CATTRIBUTES' };
  30         578  
  12         151  
332 42 50       489  wantarray? %attributes: \%attributes;
333             }
334             sub CATTRIBUTES_RECURSIVE {
335 176     176 0 1739  my $class = shift @_;
336 176 100       2065  $class = $class->class if ref $class; # get class if called as object method
337 12     12   194  no strict 'refs';
  12         111  
  12         153  
338 29         664  my %attributes=@_ ? %{ $class . '::CATTRIBUTES_RECURSIVE' } = @_:
  147         2493  
339 176 100       1840    %{ $class . '::CATTRIBUTES_RECURSIVE' };
340 176 100       4031  wantarray? %attributes: \%attributes;
341             }
342             # NG 05-12-08: DEFAULTS_ARGS renamed to DEFAULTS.
343             # incorporates logic to convert %DEFAULTS to Args object
344             sub DEFAULTS {
345 41     41 0 381  my $class = shift @_;
346 41 50       476  $class = $class->class if ref $class; # get class if called as object method
347 12     12   184  no strict 'refs';
  12         111  
  12         151  
348 40         662  ${ $class . '::DEFAULTS_ARGS' } or
  41         777  
349 41 100       405   ${ $class . '::DEFAULTS_ARGS' } = new Class::AutoClass::Args(%{ $class . '::DEFAULTS' }); # convert DEFAULTS hash into AutoArgs
  40         1002  
350             }
351             sub DEFAULTS_RECURSIVE {
352 176     176 0 1727  my $class = shift @_;
353 176 100       4141  $class = $class->class if ref $class; # get class if called as object method
354 12     12   189  no strict 'refs';
  12         126  
  12         219  
355 41         648  my $defaults=@_ ? ${ $class . '::DEFAULTS_RECURSIVE' } = $_[0]:
  135         1812  
356 176 100       2204    ${ $class . '::DEFAULTS_RECURSIVE' };
357 176 50       2088 wantarray? %$defaults: $defaults;
358             }
359             # NG 06-03-14: Used to save $case from compile-time declare for use by run-time declare
360             sub CASE {
361 56     56 0 649  my $class = shift @_;
362 56 50       4110  $class = $class->class if ref $class; # get class if called as object method
363 12     12   214  no strict 'refs';
  12         177  
  12         292  
364 56 100       562  my $case=@_ ? $ { $class . '::CASE' } = $_[0] : $ { $class . '::CASE' };
  6         71  
  50         665  
365 56         741  $case;
366             }
367             sub AUTODB {
368 45     45 0 471  my ($class) = @_;
369 45 50       494  $class = $class->class if ref $class; # get class if called as object method
370 12     12   591  no strict 'refs';
  12         401  
  12         155  
371 45         388  %{ $class . '::AUTODB' };
  45         796  
372             }
373              
374             sub ANCESTORS {
375 106     106 0 1144  my $class = shift @_;
376 106 50       1190  $class = $class->class if ref $class; # get class if called as object method
377 12     12   179  no strict 'refs';
  12         148  
  12         174  
378 106 100       1439  @_ ? ${ $class . '::ANCESTORS' } = $_[0] : ${ $class . '::ANCESTORS' };
  41         620  
  65         1045  
379             }
380              
381             sub CAN_NEW {
382 106     106 0 948  my $class = shift @_;
383 106 50       1025  $class = $class->class if ref $class; # get class if called as object method
384 12     12   233  no strict 'refs';
  12         235  
  12         203  
385 106 100       1306  @_ ? ${ $class . '::CAN_NEW' } = $_[0] : ${ $class . '::CAN_NEW' };
  41         694  
  65         4607  
386             }
387              
388             sub FORCE_NEW {
389 78     78 0 1010   my $class = shift @_;
390 78 50       803   $class = $class->class if ref $class; # get class if called as object method
391 12     12   230   no strict 'refs';
  12         111  
  12         291  
392 78         650   ${ $class . '::FORCE_NEW' };
  78         1928  
393             }
394             sub DECLARED { # set to 1 by declare. tested in new
395 142     142 0 1961   my $class = shift @_;
396 142 50       1710   $class = $class->class if ref $class; # get class if called as object method
397 12     12   179   no strict 'refs';
  12         124  
  12         386  
398 142 100       2795   @_ ? ${ $class . '::DECLARED' } = $_[0] : ${ $class . '::DECLARED' };
  42         1138  
  100         1580  
399             }
400             sub AUTOCLASS_DEFERRED_DECLARE {
401 44     44 0 397   my $class = shift @_;
402 44 50       479   $class = $class->class if ref $class; # get class if called as object method
403 12     12   218   no strict 'refs';
  12         181  
  12         159  
404 44 100       568   ${ $class . '::AUTOCLASS_DEFERRED_DECLARE' }{$_[0]}=$_[0] if @_;
  3         94  
405             # push(@{ $class . '::AUTOCLASS_DEFERRED_DECLARE' }, @_) if @_;
406             # @{ $class . '::AUTOCLASS_DEFERRED_DECLARE' };
407 44         377   keys %{ $class . '::AUTOCLASS_DEFERRED_DECLARE' };
  44         1197  
408             }
409             sub declare {
410 45     45 1 655  my ( $class, $case, $is_runtime ) = @_;
411             # NG 06-03-18: improved code to recognize that user can set $CASE in module
412             # this is first step toward deprecating this parameter
413 45 100       529  if (defined $case) {
414 6         61     CASE($class,$case); # save $case for run-time
415               } else {
416 39         412     $case=CASE($class); # else, set $case from $CASE
417               }
418             ########################################
419             # NG 05-12-08,09: added code to compute RECURSIVE values, IATTRIBUTES, CATTRIBUTES
420 45         665  my @attributes_recursive;
421 45         410  my %iattributes_recursive;
422 45         373  my %cattributes_recursive;
423 45         377  my %synonyms_recursive;
424 45         3341  my $defaults_recursive;
425             # get info from superclasses. recursively, this includes all ancestors
426             # NG 06-03-14: split loop to get all supers that are AutoClasses
427             # and make sure they are declared. If any not declared,
428             # have to defer this declaration to run-time
429 45         564  my $defer;
430 45         2174  for my $super (ISA($class)) {
431 52 100       590    next if $super eq 'Class::AutoClass';
432             ####################
433             # NG 05-12-09: added check for super classes not yet used
434             # Caution: this all works fine if people follow the Perl convention of
435             # placing module Foo in file Foo.pm. Else, there's no easy way to
436             # translate a classname into a string that can be 'used'
437             # The test 'unless %{$class.'::'}' cause the 'use' to be skipped if
438             # the class is already loaded. This should reduce the opportunities
439             # for messing up the class-to-file translation.
440             # Note that %{$super.'::'} is the symbol table for the class
441 12     12   458    { no strict 'refs';
  12         146  
  12         174  
  28         238  
442 28 100       239      unless (%{$super.'::'}) {
  28         492  
443 3         35        eval "use $super";
  7         113  
  5         77  
  11         172  
444 3 50       81        confess "'use $super' failed while declaring class $class. Note that class $super is listed in \@ISA for class $class, but is not explicitly used in the code. We suggest, as a matter of coding style, that classes listed in \@ISA be explicitly used" if $@;
445                  }}
446             # next unless UNIVERSAL::isa($super,'Class::AutoClass');
447             # NG 06-03-14: handle different cases of $super being declared
448             # at runtime, okay to declare $super now since entire module
449             # has been parsed.
450             # at compile time, there is no guarantee that AutoClass variables
451             # have yet been parsed. so, we defer declaration of current class
452             # until $super is declared. CAUTION: this writes into $super's
453             # namespace which is rude if $super is not an AutoClass class !!!
454 28 100       372    if (!DECLARED($super)) {
455 7 100       68      if ($is_runtime) {
456 4 100       86        if (UNIVERSAL::isa($super,'Class::AutoClass')) {
457 3         59 declare($super,CASE($class),$is_runtime);
458                    } else { # not AutoClass class, so just call it declared
459 1         11 DECLARED($class,1);
460                    }
461                  } else {
462 3         31        AUTOCLASS_DEFERRED_DECLARE($super,$class); # push class onto super's deferred list
463 3         34        $defer=1; # causes return before loop that does the work
464                  }
465                }
466              }
467             # NG 06-03-14: AutoDB registration must be done at compile-time. if this code get
468             # moved later, remember that hacking of @ISA has to happen before class
469             # hierarchy enumerated
470 45         703  my %autodb = AUTODB($class);
471 45 50       474  if (%autodb) {
472 12     12   245   no strict 'refs';
  12         114  
  12         159  
473             # add AutoDB::Object to @ISA if necessary
474 0 0       0   unless ( grep /^Class::AutoDB::Object/, @{ $class . '::ISA' } ) {
  0         0  
475 0         0     unshift @{ $class . '::ISA' }, 'Class::AutoDB::Object';
  0         0  
476               }
477 0         0   require 'Class/AutoDB/Object.pm';
478 0         0   require 'Class/AutoDB.pm'; # AutoDB.pm is needed for calling auto_register
479              }
480             # NG 05-12-02: auto-register subclasses which do not set %AUTODB
481             # if (%autodb) { # register after setting ANCESTORS
482 45 50       1353  if (UNIVERSAL::isa($class,'Class::AutoDB::Object')) {
483 0         0    require 'Class/AutoDB.pm'; # AutoDB.pm is needed for calling auto_register
484 0         0    my $args = Class::AutoClass::Args->new( %autodb, -class => $class ); # TODO - spec says %AUTODB=(1) should work
485 0         0   Class::AutoDB::auto_register($args);
486              }
487              
488 45 100       480  return if $defer;
489             # NG 06-03-14: this part of the loop does the work
490 42         529  for my $super (ISA($class)) {
491 47 100 100     904    next if $super eq 'Class::AutoClass' || !UNIVERSAL::isa($super,'Class::AutoClass');
492 23         435    push(@attributes_recursive,ATTRIBUTES_RECURSIVE($super));
493 23         241    my %h;
494 23         248    %h=IATTRIBUTES_RECURSIVE($super);
495 23         482    @iattributes_recursive{keys %h}=values %h;
496 23         278    undef %h;
497 23         291    %h=CATTRIBUTES_RECURSIVE($super);
498 23         327    @cattributes_recursive{keys %h}=values %h;
499 23         222    undef %h;
500 23         266    %h=SYNONYMS_RECURSIVE($super);
501 23         921    @synonyms_recursive{keys %h}=values %h;
502 23         268    my $d=DEFAULTS_RECURSIVE($super);
503 23         596    @$defaults_recursive{keys %$d}=values %$d;
504              }
505              
506             # add info from self. do this after parents so our defaults, synonyms override parents
507             # for IATTRIBUTES, don't add in any that are already defined, since this just creates
508             # redundant methods
509 42         1571  my %synonyms = SYNONYMS($class);
510 42         397  my %iattributes;
511 42         593  my %cattributes;
512             # init cattributes to declared CLASS_ATTRIBUTES
513 42         453  map {$cattributes{$_}=$class} CLASS_ATTRIBUTES($class);
  64         1021  
514             # iattributes = all attributes that are not cattributes
515 42 50 33     538  map {$iattributes{$_}=$class unless $iattributes_recursive{$_} || $cattributes{$_}}
  150         2774  
516                (AUTO_ATTRIBUTES($class),OTHER_ATTRIBUTES($class));
517             # add in synonyms
518 42         731  while(my($syn,$real)=each %synonyms) {
519 47 50 33     642    confess "Inconsistent declaration for attribute $syn: both synonym and real attribute"
520                  if $cattributes{$syn} && $iattributes{$syn};
521 47 100 66     606    $cattributes{$syn}=$class if $cattributes{$real} || $cattributes_recursive{$real};
522 47 100 100     3615    $iattributes{$syn}=$class if $iattributes{$real} || $iattributes_recursive{$real};
523              }
524 42         743  IATTRIBUTES($class,%iattributes);
525 42         639  CATTRIBUTES($class,%cattributes);
526 42         591  ATTRIBUTES($class,keys %iattributes,keys %cattributes);
527              
528             # store our attributes into recursives
529 42         774  @iattributes_recursive{keys %iattributes}=values %iattributes;
530 42         620  @cattributes_recursive{keys %cattributes}=values %cattributes;
531 42         590  push(@attributes_recursive,keys %iattributes,keys %cattributes);
532             # are all these declarations consistent?
533 42 100       952  if (my @inconsistents=grep {exists $cattributes_recursive{$_}} keys %iattributes_recursive) {
  364         7758  
534             # inconsistent class vs. instance declarations
535 1         15    my @errstr=("Inconsistent declarations for attribute(s) @inconsistents");
536 2         25    map {
537 1         10      push(@errstr,
538             "\tAttribute $_: declared instance attribute in $iattributes_recursive{$_}, class attribute in $cattributes_recursive{$_}");
539                } @inconsistents;
540 1         15    confess join("\n",@errstr);
541              }
542             # store our synonyms into recursive
543 41         1392  @synonyms_recursive{keys %synonyms}=values %synonyms;
544             # store our defaults into recursive
545              
546 41         752  my $d=DEFAULTS($class);
547 41         822  @$defaults_recursive{keys %$d}=values %$d;
548             # store computed values into class
549 41         525  ATTRIBUTES_RECURSIVE($class,@attributes_recursive);
550 41         708  IATTRIBUTES_RECURSIVE($class,%iattributes_recursive);
551 41         666  CATTRIBUTES_RECURSIVE($class,%cattributes_recursive);
552 41         574  SYNONYMS_RECURSIVE($class,%synonyms_recursive);
553 41         568  DEFAULTS_RECURSIVE($class,$defaults_recursive);
554              
555             # note that attributes are case sensitive, while defaults and args are not.
556             # (this may be a crock, but it's documented this way). to deal with this, we build
557             # a map from de-cased attributes to attributes. really, the map takes use from
558             # id's as fixed by Args to attributes as they exist here
559 41         8016  my %fixed_attributes;
560 41         549  my @fixed_attributes=Class::AutoClass::Args::fix_keywords(@attributes_recursive);
561 41         2389  @fixed_attributes{@attributes_recursive}=@fixed_attributes;
562 41         668  FIXED_ATTRIBUTES_RECURSIVE($class,%fixed_attributes);
563              
564             ########################################
565              
566             # enumerate internal super-classes and find an external class to create object
567              
568             # NG 06-03-14: moved code for AutoDB registration higher.
569             # my %autodb = AUTODB($class);
570             # if (%autodb) { # hack ISA before setting ancestors
571             # no strict 'refs';
572              
573             # # add AutoDB::Object to @ISA if necessary
574             # unless ( grep /^Class::AutoDB::Object/, @{ $class . '::ISA' } ) {
575             # unshift @{ $class . '::ISA' }, 'Class::AutoDB::Object';
576             # }
577             # require 'Class/AutoDB/Object.pm';
578             # require 'Class/AutoDB.pm'; # AutoDB.pm is needed for calling auto_register
579             # }
580              
581 41         658  my ( $ancestors, $can_new ) = _enumerate($class);
582 41         524  ANCESTORS( $class, $ancestors );
583 41         449  CAN_NEW( $class, $can_new );
584              
585             # DEFAULTS_ARGS( $class, new Class::AutoClass::Args( DEFAULTS($class) ) ); # convert DEFAULTS hash into AutoArgs. NG 05-12-08: commented out since logic moved to DEFAULTS sub
586              
587             # # NG 05-12-02: auto-register subclasses which do not set %AUTODB
588             # # if (%autodb) { # register after setting ANCESTORS
589             # if (UNIVERSAL::isa($class,'Class::AutoDB::Object')) { # register after setting ANCESTORS
590             # require 'Class/AutoDB.pm'; # AutoDB.pm is needed for calling auto_register
591             # my $args = Class::AutoClass::Args->new( %autodb, -class => $class ); # TODO - spec says %AUTODB=(1) should work
592             # Class::AutoDB::auto_register($args);
593             # }
594              
595             ########################################
596             # NG 05-12-09: changed loops to iterate separately over instance and class attributes.
597             # commented out code for AutoDB dispatch -- could never have run anyway
598             # since %keys never set. also not longer compatible with new
599             # Registration format.
600             # generate the methods
601              
602 41         487  my @auto_attributes=AUTO_ATTRIBUTES($class);
603 41         880  undef %iattributes;
604 41         562  %iattributes=IATTRIBUTES($class);
605 41 50       593  my @iattributes=grep {$iattributes{$_} && !exists $synonyms{$_}} @auto_attributes;
  120         1848  
606 41         456  my @class_attributes=(@auto_attributes,CLASS_ATTRIBUTES($class));
607 41 100       910  my @cattributes=grep {$cattributes{$_} && !exists $synonyms{$_}} @class_attributes;
  183         2175  
608              
609 41         422  for my $func (@iattributes) {
610 120         1965   my $fixed_func = Class::AutoClass::Args::fix_keyword($func);
611 120         1638   my $sub = '*' . $class . '::' . $func . "=sub{\@_>1?
612             \$_[0]->{\'$fixed_func\'}=\$_[1]:
613             \$_[0]->{\'$fixed_func\'};}";
614 120 100   41   20055   eval $sub;
  41 100       778  
  52 100       985  
  32 100       630  
  30 100       534  
  42         8765  
615               }
616 41         605  for my $func (@cattributes) {
617 63         689   my $fixed_func = Class::AutoClass::Args::fix_keyword($func);
618 63         1256   my $sub = '*' . $class . '::' . $func . "=sub{\@_>1?
619             \${$class\:\:$fixed_func\}=\$_[1]:
620             \${$class\:\:$fixed_func\};}";
621 63 100   24   7307   eval $sub;
  24 100       518  
  23 100       349  
  29 100       522  
  34 100       546  
  13 100       657  
  20         423  
622               }
623             # NG 05-12-08: commented out. $args was never set anyway... This renders moot the
624             # 'then' clause of the 'if' below. I left it in just in case I have to
625             # revert the change :)
626             # TODO: eliminate 'then' clause if not needed
627             # if ( $args and $args->{keys} ) {
628             # %keys = map { split } split /,/, $args->{keys};
629             # }
630             # if ( $keys{$func} ) { # AutoDB dispatch
631             # $sub = '*' . $class . '::' . $func . "=sub{\@_>1?
632             # \$_[0] . '::AUTOLOAD'->{\'$fixed_func\'}=\$_[1]:
633             # \$_[0] . '::AUTOLOAD'->{\'$fixed_func\'};}";
634             # } else {
635             # if ( exists $cattributes{$func} ) {
636             # $sub = '*' . $class . '::' . $func . "=sub{\@_>1?
637             # \${$class\:\:$fixed_func\}=\$_[1]:
638             # \${$class\:\:$fixed_func\};}";
639             # } else {
640             # $sub = '*' . $class . '::' . $func . "=sub{\@_>1?
641             # \$_[0]->{\'$fixed_func\'}=\$_[1]:
642             # \$_[0]->{\'$fixed_func\'};}";
643             # }
644             # }
645             # eval $sub;
646             # }
647 41         636  while ( my ( $func, $old_func ) = each %synonyms ) {
648 47 50       512   next if $func eq $old_func; # avoid redundant def if old same as new
649             # my $class_defined=$iattributes_recursive{$old_func} || $cattributes_recursive{$old_func};
650             # my $sub=
651             # '*' . $class . '::' . $func . '=\& ' . $class_defined . '::' . $old_func;
652 47         534   my $sub =
653                 '*' . $class . '::' . $func . "=sub {\$_[0]->$old_func(\@_[1..\$\#_])}";
654 47     8   5294   eval $sub;
  31         814  
655              }
656 41 100 100     4181  if ( defined $case && $case =~ /lower|lc/i )
657              { # create lowercase versions of each method, too
658 1         11   for my $func (@iattributes,@cattributes) {
659 9         82    my $lc_func = lc $func;
660                next
661 9 100       85      if $lc_func eq $func; # avoid redundant def if func already lowercase
662 4         45   my $sub=
663                 '*' . $class . '::' . $lc_func . '=\& '. $class . '::' . $func;
664             # my $sub =
665             # '*' . $class . '::' . $lc_func . "=sub {\$_[0]->$func(\@_[1..\$\#_])}";
666 4         213    eval $sub;
667               }
668              }
669 41 100 100     720  if ( defined $case && $case =~ /upper|uc/i )
670              { # create uppercase versions of each method, too
671 5         54   for my $func (@iattributes,@cattributes) {
672 19         184    my $uc_func = uc $func;
673                next
674 19 100       183      if $uc_func eq $func; # avoid redundant def if func already uppercase
675 17         424   my $sub=
676                 '*' . $class . '::' . $uc_func . '=\& '. $class . '::' . $func;
677             # my $sub =
678             # '*' . $class . '::' . $uc_func . "=sub {\$_[0]->$func(\@_[1..\$\#_])}";
679 17         818    eval $sub;
680               }
681              }
682             # NG 05-12-08: removed $args from parameter list
683             # NG 05-12-09: converted call from method ($class->...) to function. removed eval that
684             # wrappped call. provided regression test for class that does not inherit
685             # from AutoClass
686 41         533  set_class_defaults($class);
687 41         940  DECLARED($class,1); # NG 06-02-03: so 'new' can know when to call declare
688              
689             # NG 06-03-14: Process deferred subclasses
690 41         414  my @deferreds=AUTOCLASS_DEFERRED_DECLARE($class);
691 41         1219  for my $subclass (@deferreds) {
692 3 50       31    declare($subclass,CASE($subclass),$is_runtime) unless DECLARED($subclass);
693              }
694             }
695              
696             sub _enumerate {
697 58     42   824  my ($class) = @_;
698 58         796  my $classes = [];
699 78         1157  my $types = {};
700 76         928  my $can_new;
701 58         683  __enumerate( $classes, $types, \$can_new, $class );
702 65         1189  return ( $classes, $can_new );
703             }
704              
705             sub __enumerate {
706 12     12   386  no warnings;
  12         118  
  12         1150  
707 91     82   2828  my ( $classes, $types, $can_new, $class ) = @_;
708 91 100       1169  die "Circular inheritance structure. \$class=$class"
709                if ( $types->{$class} eq 'pending' );
710 107 100       1342  return $types->{$class} if defined $types->{$class};
711 88         2264  $types->{$class} = 'pending';
712 85         871  my @isa;
713              {
714 12     12   195   no strict "refs";
  12         113  
  12         167  
  92         1065  
715 78         919   @isa = @{ $class . '::ISA' };
  97         3314  
716              }
717 84         931  my $type = 'external';
718 78         701  for my $super (@isa) {
719 86 100       997   $type = 'internal', next if $super eq $AUTOCLASS;
720 59         1727   my $super_type = __enumerate( $classes, $types, $can_new, $super );
721 40 100       1782   $type = $super_type unless $type eq 'internal';
722              }
723 100 100 33     1386  if ( !FORCE_NEW($class) && !$$can_new && $type eq 'internal' ) {
      66        
724 73         5507   for my $super (@isa) {
725 84 100       1175    next unless $types->{$super} eq 'external';
726 0 100       0    $$can_new = $super, last if $super->can('new');
727               }
728              }
729 78 100       1203  push( @$classes, $class ) if $type eq 'internal';
730 78         1217  $types->{$class} = $type;
731 78         1169  return $types->{$class};
732             }
733              
734             sub _is_positional {
735 0 100   0   0  @_ % 2 || $_[0] !~ /^-/;
736             }
737             1;
738             __END__
739            
740             # Pod documentation
741            
742             =head1 NAME
743            
744             Class::AutoClass - Automatically define simple get and set methods and
745             automatically initialize objects in a (possibly mulitple) inheritance
746             structure
747            
748             =head1 SYNOPSIS
749            
750             package SubClass;
751             use Class::AutoClass;
752             use SomeOtherClass;
753             @ISA=qw(AutoClass SomeOtherClass);
754            
755             @AUTO_ATTRIBUTES=qw(name sex address dob);
756             @OTHER_ATTRIBUTES=qw(age);
757             %SYNONYMS=(gender=>'sex');
758             %DEFAULTS=(name=>'unknown');
759             $CASE='upper';
760             Class::AutoClass::declare(__PACKAGE__);
761            
762             sub age {print "Calculate age from dob. NOT YET IMPLEMENTED\n"; undef}
763            
764             sub _init_self {
765             my($self,$class,$args)=@_;
766             return unless $class eq __PACKAGE__; # to prevent subclasses from re-running this
767             print __PACKAGE__.'::_init_self: ',"$class\n";
768             }
769            
770             =head1 DESCRIPTION
771            
772             1) get and set methods for simple attributes can be automatically
773             generated
774            
775             2) argument lists are handled as described below
776            
777             3) the protocol for object creation and initialization is close to
778             the 'textbook' approach generally suggested for object-oriented Perl
779             (see below)
780            
781             4) object initialization is handled correctly in the presence of multiple inheritance
782            
783             @AUTO_ATTRIBUTES is a list of 'attribute' names: get and set methods
784             are created for each attribute. By default, the name of the method
785             is identical to the attribute (but see $CASE below). Values of
786             attributes can be set via the 'new' constructor, %DEFAULTS, or the
787             'set' method as discussed below.
788            
789             @CLASS_ATTRIBUTES is a list of class attributes: get and set methods
790             are created for each attribute. By default, the name of the method
791             is identical to the attribute (but see $CASE below). Values of
792             attributes can be set via the 'new' constructor, %DEFAULTS (initialized
793             at "declare time" (when the declare function is called) versus instance
794             attributes, which are of course initialized at runtime), standard
795             class variable access syntax ($PackageName::AttributeName), or the
796             'set' method as discussed below. Normal inheritance rules apply to
797             class attributes (but of course, instances of the same class share
798             the same class variable).
799            
800             @OTHER_ATTRIBUTES is a list of attributes for which get and set
801             methods are NOT generated, but whose values can be set via the 'new'
802             constructor or the 'set' method as discussed below.
803            
804             %SYNONYMS is a hash that defines synonyms for attribues. Each entry
805             is of the form 'new_attribute_name'=>'old_attribute_name'. get and
806             set methods are generated for the new names; these methods simply
807             call the method for the old name.
808            
809             %DEFAULTS is a hash that defines default values for attributes. Each
810             entry is of the form 'attribute_name'=>'default_value'. get and
811             set methods are generated for each attributes.
812            
813             $CASE controls whether additional methods are generated with all
814             upper or all lower case names. It should be a string containing the
815             strings 'upper' or 'lower' (case insenstive) if the desired case is
816             desired.
817            
818             The declare function actually generates the method.
819             This should be called once and no where else.
820            
821             AutoClass must be the first class in @ISA !! As usual, you create
822             objects by calling 'new'. Since AutoClass is the first class in @ISA,
823             it's 'new' method is the one that's called. AutoClass's 'new'
824             examines the rest of @ISA and searches for a superclass that is
825             capable of creating the object. If no such superclass is found,
826             AutoClass creates the object itself. Once the object is created,
827             AutoClass arranges to have all subclasses run their initialization
828             methods (_init_self) in a top-down order.
829            
830             =head2 Argument Processing
831            
832             We support positional and keyword argument lists, but we strongly urge
833             that each method pick one form or the other, as the combination is inherently ambiguous (see below).
834            
835             Consider a method, foo, that takes two arguments, a first name and a
836             last_name name. The positional form might be
837            
838             $object->foo('Nat', 'Goodman')
839            
840             while the keyword form might be
841            
842             $object->foo(first_name=>'Nat', last_name=>'Goodman')
843            
844             In keyword form, keywords are insensitive to case and leading
845             dashes: the keywords
846            
847             first_name, -first_name, -FIRST_NAME, --FIRST_NAME, First_Name, -First_Name
848            
849             are all equivalent. Internally, for those who care, our convention is
850             to use uppercase, un-dashed keys for the attributes of an object.
851            
852             We convert repeated keyword arguments into an ARRAY ref of the values. Thus:
853            
854             $object->foo(first_name=>'Nat', first_name=>'Nathan')
855            
856             is equivalent to
857            
858             $object->foo(first_name=>['Nat', 'Nathan'])
859            
860             Keyword arguments can be specified via ARRAY or HASH
861             refs which are dereferenced back to their elements, e.g.,
862            
863             $object->foo([first_name=>'Nat', last_name=>'Goodman'])
864            
865             $object->foo({first_name=>'Nat', last_name=>'Goodman'})
866            
867             are both equivalent to
868            
869             $object->foo(first_name=>'Nat', last_name=>'Goodman')
870            
871             We can get away with this, because we encourage method writers to
872             choose between positional and keyword argument lists. If a method
873             uses positional arguments, it will interpret
874            
875             $object->foo($array)
876            
877             as a call that is setting the first_name parameter to $array, while if
878             it uses keyword arguments, it will dereference the array to a list of
879             keyword, value pairs.
880            
881             We also allow the argument list to be an object. This is often used
882             in new to accomplish what a C++ programmer would call a cast. In
883             simple cases, the object is just treated as a HASH ref and its
884             attributes are passed to a the method as keyword, value pairs.
885            
886             =head2 Why the Combination of Positional and Keyword Forms is Ambiguous
887            
888             The keyword => value notation is just a Perl shorthand for stating two
889             list members with the first one quoted. Thus,
890            
891             $object->foo(first_name=>'Nat', last_name=>'Goodman')
892            
893             is completely equivalent to
894            
895             $object->foo('first_name', 'Nat', 'last_name', 'Goodman')
896            
897             The ambiguity of allowing both positional and keyword forms should now
898             be apparent. In this example,
899            
900             $object->foo('first_name', 'Nat')
901            
902             there is s no way to tell whether the program is calling foo with the
903             first_name parameter set to the value 'first_name' and the last_name
904             parameter set to 'Nat', vs. calling foo with the first_name parameter
905             set to 'Nat' and the last_name parameter left undefined.
906            
907             If a program wishes to permit both forms, we suggest that keywords be
908             required to start with '-' (and that values do not start with '-').
909             Obviously, this is not fully general. We provide a method, _is_positional,
910             that checks this convention. Subclasses are free to ignore this.
911            
912             =head2 Protocol for Object Creation and Initializaton
913            
914             We expect objects to be created by invoking new on its class. For example
915            
916             $object = new SomeClass(first=>'Nat', last=>'Goodman')
917            
918             To correctly initialize objects that participate in multiple inheritance,
919             we use a technqiue described in Chapter 10 of Paul Fenwick's excellent
920             tutorial on Object Oriented Perl (see http://perltraining.com.au/notes/perloo.pdf).
921             (We experimented with Damian Conway's interesting NEXT
922             pseudo-pseudo-class discussed in Chapter 11 of Fenwick's tutorial
923             available in CPAN at http://search.cpan.org/author/DCONWAY/NEXT-0.50/lib/NEXT.pm,
924             but could not get it to traverse the inheritance structure in the correct,
925             top-down order.)
926            
927             AutoClass class provides a 'new' method that expects a keyword argument
928             list. This method processes the argument list as discussed in
929             L<Argument Processing>: it figures out the syntactic form (list of
930             keyword, value pairs, vs. ARRAY ref vs. HASH ref, etc.). It then
931             converts the argument list into a canonical form, which is a list of
932             keyword, value pairs with all keywords uppercased and de-dashed. Once
933             the argument list is in this form, subsequent code treats it as a HASH
934             ref.
935            
936             AutoClass::new initializes the object's class structure from top to
937             bottom, and is careful to initialize each class exactly once even in
938             the presence of multiple inheritance. The net effect is that objects
939             are initialized top-down as expected; a subclass object can assume
940             that all superior classes are initialized by the time subclass
941             initialization occurs.
942            
943             AutoClass automatically initializes attributes and synonyms declared
944             when the class is defined. If additional initialization is required,
945             the class writer can provide an _init_self method. _init_self is
946             called after all superclasses are initialized and after the automatic
947             initialization for the class has been done.
948            
949             AutoClass initializes attributes and synonyms by calling the set methods
950             for these elements with the like-named parameter -- it does not simply
951             slam the parameter into a slot in the object''s HASH. This allows the
952             class writer implement non-standard initialization within the set
953             method.
954            
955             The main case where a subclass needs its own 'new' method is if it
956             wishes to allow positional arguments. In this case, the subclass 'new'
957             is responsible for is responsible for recognizing that positional
958             arguments are being used (if the class permits keyword arguments
959             also), and converting the positional arguments into keyword, value
960             form. At this point, the method can simply call AutoClass::new with
961             the converted argument list.
962            
963             The subclass should not generally call SUPER::new as this would force
964             redundant argument processing in any super-class that also has its own
965             new. It would also force the super-class new to be smart enough to
966             handle positional as well as keyword parameters, which as we've noted
967             is inherently ambiguous.
968            
969             =head1 KNOWN BUGS AND CAVEATS
970            
971             This is still a work in progress.
972            
973             =head2 Bugs, Caveats, and ToDos
974            
975             1) There is no way to manipulate the arguments that are sent to the
976             real base class. There should be a way to specify a subroutine that
977             reformats these if needed.
978            
979             2) DESTROY not handled
980            
981             3) Autogeneration of methods is hand crafted. It may be better to
982             use Class::MakeMethods or Damian Conway's Multimethod class for
983             doing signature-based method dispatch
984            
985             4) Caveat: In order to specify that a class that uses AutoClass should return
986             undef (versus an uninitialized (but blessed) object), one need to set:
987             $self->{__NULLIFY__}=1;
988            
989             =head1 AUTHOR - Nat Goodman
990            
991             Email natg@shore.net
992            
993             =head1 MAINTAINER - Christopher Cavnor
994            
995             Email ccavnor@systemsbiology.net
996            
997             =head1 COPYRIGHT
998            
999             Copyright (c) 2003 Institute for Systems Biology (ISB). All Rights Reserved.
1000            
1001             This module is free software; you can redistribute it and/or modify
1002             it under the same terms as Perl itself.
1003            
1004             =head1 APPENDIX
1005            
1006             The rest of the documentation describes the methods. Note that
1007             internal methods are preceded with _
1008            
1009             =head2 new
1010            
1011             Title : new
1012             Usage : $object=new Foo(first_name=>'Nat', last_name=>'Goodman')
1013             where Foo is a subclass of AutoClass
1014             Function: Create and initialize object
1015             Returns : New object of class $class
1016             Args : Any arguments needed by subclasses
1017             -->> Arguments must be in keyword form. See DESCRIPTION for more.
1018             Notes : Tries to invoke superclass to actually create the object
1019            
1020            
1021             =head2 _init
1022            
1023             Title : _init
1024             Usage : $self->_init($class,$args)
1025             Function: Initialize new object
1026             Returns : nothing useful
1027             Args : $class -- lexical (static) class being initialized, not the
1028             actual (dynamic) class of $self
1029             $arg -- argument list in canonical keyword form
1030             Notes : Adapted from Chapter 10 of Paul Fenwick''s excellent tutorial on
1031             Object Oriented Perl (see http://perltraining.com.au/notes/perloo.pdf).
1032            
1033             =head2 set
1034            
1035             Title : set
1036             Usage : $self->set(-first_name=>'Nat',-last_name=>'Goodman')
1037             Function: Set multiple attributes in existing object
1038             Args : Parameter list in same format as for new
1039             Returns : nothing
1040            
1041             =head2 set_attributes
1042            
1043             Title : set_attributes
1044             Usage : $self->set_attributes([qw(first_name last_name)],$args)
1045             Function: Set multiple attributes from a Class::AutoClass::Args object
1046             Any attribute value that is present in $args is set
1047             Args : ARRAY ref of attributes
1048             Class::AutoClass::Args object
1049             Returns : nothing
1050            
1051             =head2 get
1052            
1053             Title : get
1054             Usage : ($first,$last)=$self->get(qw(-first_name,-last_name))
1055             Function: Get values for multiple attributes
1056             Args : Attribute names
1057             Returns : List of attribute values
1058            
1059             =head2 AUTO_ATTRIBUTES
1060            
1061             Title : AUTO_ATTRIBUTES
1062             Usage : @auto_attributes=AUTO_ATTRIBUTES('SubClass')
1063             @auto_attributes=$self->AUTO_ATTRIBUTES();
1064             Function: Get @AUTO_ATTRIBUTES for lexical class.
1065             @AUTO_ATTRIBUTES is defined by class writer. These are attributes for which get and set methods
1066             are automatically generated. _init automatically
1067             initializes these attributes from like-named parameters in
1068             the argument list
1069             Args : class
1070            
1071             =head2 OTHER_ATTRIBUTES
1072            
1073             Title : OTHER_ATTRIBUTES
1074             Usage : @other_attributes=OTHER_ATTRIBUTES('SubClass')
1075             @other_attributes=$self->OTHER_ATTRIBUTES();
1076             Function: Get @OTHER_ATTRIBUTES for lexical class.
1077             @OTHER_ATTRIBUTES is defined by class writer. These are attributes for which get and set methods
1078             are not automatically generated. _init automatically
1079             initializes these attributes from like-named parameters in
1080             the argument list
1081             Args : class
1082            
1083             =head2 SYNONYMS
1084            
1085             Title : SYNONYMS
1086             Usage : %synonyms=SYNONYMS('SubClass')
1087             %synonyms=$self->SYNONYMS();
1088             Function: Get %SYNONYMS for lexical class.
1089             %SYNONYMS is defined by class writer. These are alternate names for attributes generally
1090             defined in superclasses. get and set methods are
1091             automatically generated. _init automatically initializes
1092             these attributes from like-named parameters in the argument
1093             list
1094             Args : class
1095            
1096             =head2 declare
1097            
1098             Title : declare
1099             Usage : @AUTO_ATTRIBUTES=qw(sex address dob);
1100             @OTHER_ATTRIBUTES=qw(age);
1101             %SYNONYMS=(name=>'id');
1102             AutoClass::declare(__PACKAGE__,'lower|upper');
1103             Function: Generate get and set methods for simple attributes and synonyms.
1104             Method names are identical to the attribute names including case
1105             Returns : nothing
1106             Args : lexical class being created -- should always be __PACKAGE__
1107             ARRAY ref of attributes
1108             HASH ref of synonyms. Keys are new names, values are old
1109             code that indicates whether method should also be generated
1110             with all lower or upper case names
1111            
1112             =head2 _enumerate
1113            
1114             Title : _enumerate
1115             Usage : _enumerate($class);
1116             Function: locates classes that have a callable constructor
1117             Args : a class reference
1118             Returns : list of internal classes, a class with a callable constructor
1119            
1120            
1121             =head2 _fix_args
1122            
1123             Title : _fix_args
1124             Usage : $args=_fix_args(-name=>'Nat',-name=>Goodman,address=>'Seattle')
1125             $args=$self->_fix_args(@args)
1126            
1127             Function: Convert argument list into canonical form. This is a HASH ref in
1128             which keys are uppercase with no leading dash, and repeated
1129             keyword arguments are merged into an ARRAY ref. In the
1130             example above, the argument list would be converted to this
1131             hash
1132             (NAME=>['Nat', 'Goodman'],ADDRESS=>'Seattle')
1133             Returns : argument list in canonical form
1134             Args : argument list in any keyword form
1135            
1136             =head2 _fix_keyword
1137            
1138             Title : _fix_keyword
1139             Usage : $keyword=_fix_keyword('-name')
1140             @keywords=_fix_keyword('-name','-address');
1141             Function: Convert a keyword or list of keywords into canonical form. This
1142             is uppercase with no leading dash. In the example above,
1143             '-name' would be converted to 'NAME'. Non-scalars are left
1144             unchanged.
1145             Returns : keyword or list of keywords in canonical form
1146             Args : keyword or list of keywords
1147            
1148             =head2 _set_attributes
1149            
1150             Title : _set_attributes
1151             Usage : my %synonyms=SYNONYMS($class);
1152             my $attributes=[AUTO_ATTRIBUTES($class),
1153             OTHER_ATTRIBUTES($class),
1154             keys %synonyms];
1155             $self->_set_attributes($attributes,$args);
1156             Function: Set a list of simple attributes from a canonical argument list
1157             Returns : nothing
1158             Args : $attributes -- ARRAY ref of attributes to be set
1159             $args -- argument list in canonical keyword (hash) form
1160             Notes : The function calls the set method for each attribute passing
1161             it the like-named parameter from the argument list
1162            
1163             =head2 _is_positional
1164            
1165             Title : _is_positional
1166             Usage : if (_is_positional(@args)) {
1167             ($arg1,$arg2,$arg3)=@args;
1168             }
1169             Function: Checks whether an argument list conforms to our convention
1170             for positional arguments. The function returns true if
1171             (1) the argument list has an odd number of elements, or
1172             (2) the first argument starts with a dash ('-').
1173             Obviously, this is not fully general.
1174             Returns : boolean
1175             Args : argument list
1176             Notes : As explained in DESCRIPTION, we recommend that methods not
1177             support both positional and keyford argument lists, as this
1178             is inherently ambiguous.
1179             BUGS : NOT YET TESTED in this version
1180            
1181             =head2 set_class_defaults
1182            
1183             Title : set_class_defaults
1184             Usage : $self->set_class_defaults($attributes,$class,$args);
1185             Function: Set default values for class argument
1186             Args : reference to the class and a Class::AutoClass::Args object
1187             which contains the arguments to set
1188             Returns : nothing
1189            
1190             =cut
1191            
1192