File Coverage

blib/lib/Class/Declare.pm
Criterion Covered Total %
statement 430 446 96.4
branch 171 200 85.5
condition 97 155 62.5
subroutine 48 48 100.0
pod 17 20 85.0
total 763 869 87.8


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -Tw
2              
3             # $Id: Declare.pm 1518 2010-08-22 23:56:21Z ian $
4             package Class::Declare;
5              
6 28     28   548449 use strict;
  28         67  
  28         749  
7 28     28   19318 use version;
  28         59031  
  28         259  
8              
9             =head1 NAME
10              
11             Class::Declare - Declare classes with public, private and protected
12             attributes and methods.
13              
14              
15             =head1 SYNOPSIS
16              
17             package My::Class;
18              
19             use strict;
20             use warnings;
21             use base qw( Class::Declare );
22              
23             __PACKAGE__->declare(
24              
25             public => { public_attr => 42 } ,
26             private => { private_attr => 'Foo' } ,
27             protected => { protected_attr => 'Bar' } ,
28             class => { class_attr => [ 3.141 ] }
29             static => { static_attr => { a => 1 } } ,
30             restricted => { restricted_attr => \'string' } ,
31             abstract => 'abstract_attr' ,
32             friends => 'main::trustedsub' ,
33             new => [ 'public_attr' , 'private_attr' ] ,
34             init => sub { # object initialisation
35             ...
36             1;
37             } ,
38             strict => 0
39              
40             );
41              
42             sub publicmethod {
43             my $self = __PACKAGE__->public( shift );
44             ...
45             }
46              
47             sub privatemethod {
48             my $self = __PACKAGE__->private( shift );
49             ...
50             }
51              
52             sub protectedmethod {
53             my $self = __PACKAGE__->protected( shift );
54             ...
55             }
56              
57             sub classmethod {
58             my $self = __PACKAGE__->class( shift );
59             ...
60             }
61              
62             sub staticmethod {
63             my $self = __PACKAGE__->static( shift );
64             ...
65             }
66              
67             sub restrictedmethod {
68             my $self = __PACKAGE__->restricted( shift );
69             ...
70             }
71              
72             sub abstractmethod { __PACKAGE__->abstract }
73              
74             1;
75              
76             ...
77              
78             my $obj = My::Class->new( public_attr => 'fish' );
79            
80             =cut
81              
82              
83 28     28   2525 use base qw( Exporter );
  28         54  
  28         2740  
84 28     28   136 use vars qw/ $VERSION @EXPORT_OK %EXPORT_TAGS /;
  28         54  
  28         2498  
85              
86             # the version of this module
87             $VERSION = '0.19';
88              
89             # declare the read-write and read-only methods for export
90             @EXPORT_OK = qw( rw ro );
91             %EXPORT_TAGS = ( modifiers => \@EXPORT_OK ,
92             'read-only' => [ qw( ro ) ] ,
93             'read-write' => [ qw( rw ) ] );
94              
95             # use Storable for deep-cloning of Class::Declare objects
96 28     28   28995 use Storable;
  28         99427  
  28         2024  
97              
98             # load the dump() and hash() modules
99 28     28   19604 use Class::Declare::Dump;
  28         81  
  28         1429  
100 28     28   19218 use Class::Declare::Hash;
  28         78  
  28         24074  
101              
102              
103             =head1 MOTIVATION
104              
105             One of Perl's greatest strengths is it's flexible object model. You can
106             turn anything (so long as it's a reference, or you can get a reference
107             to it) into an object. This allows coders to choose the most appropriate
108             implementation for each specific need, and still maintain a consistent
109             object oriented approach.
110              
111             A common paradigm for implementing objects in Perl is to use a blessed hash
112             reference, where the keys of the hash represent attributes of the class. This
113             approach is simple, relatively quick, and trivial to extend, but it's not
114             very secure. Since we return a reference to the hash directly to the user
115             they can alter hash values without using the class's accessor methods. This
116             allows for coding "short-cuts" which at best reduce the maintainability
117             of the code, and at worst may introduce bugs and inconsistencies not
118             anticipated by the original module author.
119              
120             On some systems, this may not be too much of a problem. If the developer
121             base is small, then we can trust the users of our modules to Do The Right
122             Thing. However, as a module's user base increases, or the complexity of
123             the systems our module's are embedded in grows, it may become desirable
124             to control what users can and can't access in our module to guarantee our
125             code's behaviour. A traditional method of indicating that an object's data
126             and methods are for internal use only is to prefix attribute and method
127             names with underscores. However, this still relies on the end user Doing
128             The Right Thing.
129              
130             B provides mechanisms for module developers to explicitly
131             state where and how their class attributes and methods may be accessed, as
132             well as hiding the underlying data store of the objects to prevent unwanted
133             tampering with the data of the objects and classes. This provides a robust
134             framework for developing Perl modules consistent with more strongly-typed
135             object oriented languages, such as Java and C++, where classes provide
136             C, C, and C interfaces to object and class
137             data and methods.
138              
139              
140             =head1 DESCRIPTION
141              
142             B allows class authors to specify public, private and
143             protected attributes and methods for their classes, giving them control
144             over how their modules may be accessed. The standard object oriented
145             programming concepts of I, I and I have been
146             implemented for both class and instance (or object) attributes and methods.
147              
148             Attributes and methods belong to either the I or an I
149             depending on whether they may be invoked via class instances (class and
150             instance methods/attributes), or via classes (class methods/attributes only).
151              
152             B uses the following definitions for I, I
153             and I:
154              
155             =over 4
156              
157             =item B
158              
159             Public attributes and methods may be accessed by anyone from anywhere. The
160             term B is used by B to refer to instance attributes
161             and methods, while the equivalent for class attributes and methods are
162             given the term B attributes and methods.
163              
164             =item B
165              
166             Private attributes and methods may be accessed only by the class defining
167             them and instances of that class. The term B is used to refer
168             to instance methods and attributes, while the term B refers to class
169             attributes and methods that exhibit the same properties.
170              
171             =item B
172              
173             Protected attributes and methods may only be accessed by the defining
174             class and it's instances, and classes and objects derived from the defining
175             class. Protected attributes and methods are used to define the interface
176             for extending a given class (through normal inheritance/derivation). The
177             term B is used to refer to protected instance methods and
178             attributes, while protected class methods and attributes are referred to
179             as B.
180              
181             B since version 0.02, protected class methods and attributes are
182             refered to as I, rather than I. This change was brought
183             about by the introduction of L and then clash
184             with the existing Perl threading attribute B<:shared>. The term I
185             has been chosen to reflect that the use of these methods and attributes
186             is restricted to the family of classes derived from the base class.
187              
188             =back
189              
190             The separation of terms for class and instance methods and attributes has
191             been adopted to simplify class declarations. See B below.
192              
193             Class attributes are regarded as constant by B: once
194             declared they may not be modified. Instance attributes, on the other hand,
195             are specific to each object, and may be modified at run-time.
196              
197             Internally, B uses hashes to represent the attributes of each
198             of its objects, with the hashes remaining local to B. To
199             the user, the objects are represented as references to scalars which
200             B maps to object hashes in the object accessors. This
201             prevents users from accessing object and class data without using the
202             class's accessors.
203              
204             The granting of access to attributes and methods is determined by examining
205             the I of the invocation (the first parameter passed to the method,
206             usually represented by C<$self>), as well as the I of the invocation
207             (where was the call made and who made it, determined by examining the
208             L() stack). This adds an unfortunate but necessary processing
209             overhead for B objects for each method and attribute
210             access. While this overhead has been kept as low as possible, it may be
211             desirable to turn it off in a production environment. B
212             permits disabling of the access control checks on a per-module basis,
213             which may greatly improve the performance of an application. Refer to
214             the I parameter of B below for more information.
215              
216             B inherits from L, so modules derived from
217             B can use the standard symbol export mechanisms. See
218             L for more information.
219              
220             =head2 Defining Classes
221              
222             To define a B-derived class, a package must first C
223             B and inherit from it (either by adding it to the C<@ISA>
224             array, or through C). Then B must
225             be called with the new class's name as its first parameter, followed by
226             a list of arguments that actually defines the class. For example:
227              
228             package My::Class;
229              
230             use strict;
231             use warnings;
232             use base qw( Class::Declare );
233              
234             __PACKAGE__->declare( ... );
235              
236             1;
237              
238             B is a class method of B and
239             has the following call syntax and behaviour:
240              
241             =over 4
242              
243             =item B [ I => I ] B<)>
244              
245             B's primary task is to define the attributes of the class
246             and its instances. In addition, it supports options for defining object
247             initialisation code, friend methods and classes, and the application of
248             strict access checking. I may have one of the following values:
249              
250             =over 4
251              
252             =item I
253              
254             I expects either a hash reference of attribute names and default
255             values, an array reference containing attribute names whose default
256             values will be C, or a single attribute name whose value will
257             default to C. These represent the public attributes of this
258             class. B constructs accessor methods within the class,
259             with the same name as the attributes. These methods are C methods
260             by default (see also B below), which means that the
261             attributes may be assigned to, as well as being set by passing the new
262             value as an accessor's argument.
263              
264             For example:
265              
266             package My::Class;
267              
268             use strict;
269             use warnings;
270             use base qw( Class::Declare );
271              
272             __PACKAGE__->declare( public => { name => 'John' } );
273              
274             1;
275              
276             my $obj = My::Class->new;
277             print $obj->name . "\n"; # prints 'John'
278             $obj->name = 'Fred'; # the 'name' attribute is now 'Fred'
279             $obj->name( 'Mary' ); # the 'name' attribute is now 'Mary'
280              
281             The default value of each attribute is assigned during the object
282             initialisation phase (see I and B below). Public attributes
283             may be set during the object creation call:
284              
285             my $obj = My::Class->new( name => 'Jane' );
286             print $obj->name . "\n"; # prints 'Jane'
287              
288             I attributes are instance attributes and therefore may only be
289             accessed through class instances, and not through the class itself.
290              
291             Note that the B call for C from above could have
292             been written as
293              
294             __PACKAGE__->declare( public => [ qw( name ) ] );
295              
296             or
297              
298             __PACKAGE__->declare( public => 'name' );
299              
300             In these cases, the attribute C would have had a default value
301             of C.
302              
303             =item I
304              
305             As with I above, but the attributes are private (i.e. only accessible
306             from within this class). If access is attempted from outside the defining
307             class, then an error will be reported through B. I attributes
308             may not be set in the call to the constructor, and as with I
309             attributes, are instance attributes. See also I and I below.
310              
311             =item I
312              
313             As with I above, but the attributes are protected (i.e. only
314             accessible from within this class, and all classes that inherit from this
315             class). Protected attributes are instance attributes, and they may not be
316             set in the call to the constructor. See also I and I below.
317              
318             =item I
319              
320             This declares class attributes in the same manner as I
321             above. I attributes are not restricted to object instances, and
322             may be accessed via the class directly. The accessor methods created by
323             B, however, are not C methods, and cannot, therefore,
324             be assigned to. Nor can the values be set through the accessor methods. They
325             behave in the same manner as values declared by C (except
326             they must be called as class or instance methods). I attributes
327             may not be set in the call to the constructor.
328              
329             =item I
330              
331             As with I attributes, except access to C attributes is
332             limited to the defining class and its objects. I attributes are
333             the class-equivalent of I instance attributes. See also I.
334              
335             =item I
336              
337             As with I attributes, except access to C attributes is
338             limited to the defining class and all classes that inherit from the defining
339             class, and their respective objects. I attributes are the
340             class-equivalent of I instance attributes. See also I.
341              
342             =item I
343              
344             This declares the set of abstract methods provided by this class, and will
345             cause the generation of stub routines that die() when invoked, ensuring
346             derived classes define these methods.
347              
348             =item I
349              
350             Here you may specify classes and methods that may be granted access to the
351             defining classes I, I, I and I
352             attributes and methods. I expects either a single value, or a
353             reference to a list of values. These values may either be class names, or
354             fully-qualified method names (i.e. class and method name). When a call is
355             made to a private or protected method or attribute accessor, and a friend
356             has been declared, a check is performed to see if the caller is within a
357             friend package or is a friend method. If so, access is granted. Otherwise,
358             access is denied through a call to B.
359              
360             Note that friend status may not be inherited. This is to avoid scenarios
361             such as the following:
362              
363             package My::Class;
364              
365             use strict;
366             use warnings;
367             use base qw( Class::Declare );
368              
369             __PACKAGE__->declare( ...
370             friends => 'My::Trusted::Class' );
371             1;
372              
373             package My::Trusted::Class;
374             ...
375             1;
376              
377             package Spy::Class;
378              
379             use strict;
380             use warnings;
381             use base qw( My::Trusted::Class );
382              
383             sub infiltrate {
384             .. do things here to My::Class objects that we shouldn't
385             }
386              
387             1;
388              
389              
390             =item I
391              
392             This defines the object initialisation code, which is executed as the last
393             phase of object creation by B. I expects a C which is
394             called with the first argument being the new object being created by the call
395             to B. The initialisation routine is expected to return a true value
396             to indicate success. A false value will cause B to C with an
397             error. The initialisation routines are invoked during object creation by
398             B, after default and constructor attribute values have been assigned.
399              
400             If the inheritance tree of a class contains multiple I methods,
401             then these will be executed in reverse @ISA order to ensure the primary
402             base-class of the new class has the final say on object initialisation
403             (i.e. the class left-most in the @ISA array will have it's I routine
404             executed last). If a class appears multiple times in an @ISA array, either
405             through repetition or inheritance, then it will only be executed once,
406             and as early in the I execution chain as possible.
407              
408             B uses a C rather than specifying a default
409             initialisation subroutine (e.g. C) to avoid unnecessary
410             pollution of class namespaces. There is generally no need for initialisation
411             routines to be accessible outside of B.
412              
413             =item I
414              
415             If I is defined, then it should contain a list (either a single value or
416             an array reference) of the instance attributes (public, private or protected)
417             that may be set in the call to the constructor B. This permits the
418             exposure of protected and private attributes during construction (and thus
419             permitting read-only protected and private attributes). I makes it
420             possible to do the following:
421              
422             package My::Class;
423              
424             use strict;
425             use warnings;
426             use base qw( Class::Declare );
427              
428             __PACKAGE__->declare(
429              
430             public => { mypublic => undef } ,
431             private => { myprivate => undef } ,
432             new => [ qw( myprivate ) ]
433              
434             );
435              
436             1;
437              
438             ...
439              
440             my $obj = My::Class->new( myprivate => 1 );
441              
442             Note that if I is specified in a call to B then B
443             those attributes listed in the value of I may be defined in the call
444             to the constructor B (overriding the default behaviour of allowing
445             public attributes). In addition, the attributes must be defined in this
446             class, and not inherited. This prevents unintended access such as:
447              
448             public My::Class;
449              
450             use strict;
451             use warnings;
452             use base qw( Class::Declare );
453              
454             __PACKAGE__->declare(
455            
456             private => { myprivate => undef }
457              
458             );
459              
460             1;
461              
462             ...
463              
464             public Bad::Class;
465              
466             use strict;
467             use warnings;
468             use base qw( My::Class );
469              
470             __PACKAGE__->declare(
471              
472             # this will throw an error with die()
473             new => 'myprivate'
474              
475             );
476              
477             1;
478              
479             =item I
480              
481             If I is set to I, then B will
482             define B, B, B, B,
483             B, and B methods (see L and
484             L below) within the current package that enforce the
485             class/static/restricted/public/private/protected relationships in method
486             calls.
487              
488             If I is set to I and defined (e.g. 0, not C),
489             then B will convert the above method calls to no-ops,
490             and no invocation checking will be performed. Note that this conversion
491             is performed for this class only.
492              
493             By setting I to C (or omitting it from the call to
494             B altogether), B will not create these methods in
495             the current package, but will rather let them be inherited from the parent
496             class. In this instance, if the parent's methods are no-ops, then the child
497             class will inherit no-ops. Note that the B, B, etc
498             methods from B enforce the public/private/etc relationships.
499              
500             One possible use of this feature is as follows:
501              
502             package My::Class;
503              
504             use strict;
505             use warnings;
506             use base qw( Class::Declare );
507              
508             __PACKAGE__->declare( public => ... ,
509             private => ... ,
510             protected => ... ,
511             strict => $ENV{ USE_STRICT } );
512              
513             ...
514              
515             1;
516              
517             Here, during development and testing the environment variable C
518             may be left undefined, or set to true to help ensure correctness of the
519             code, but then set to false (e.g. 0) in production to avoid the additional
520             computational overhead.
521              
522             Setting I to I does not interfere with the B
523             method (see below). Turning strict access checking off simply stops the
524             checks from being performed and does not change the logic of whether a
525             class or method as been declared as a friend of a given class.
526              
527             =back
528              
529             B
530              
531             =over 4
532              
533             =item *
534              
535             B may be called only once per class to prevent class redefinitions
536              
537             =item *
538              
539             attribute names specified in the call to B may not be the same
540             as class and instance methods already defined in the class
541              
542             =item *
543              
544             attribute names must be unique for a class
545              
546             =back
547              
548             If any of the above rules are violated, then B will raise an
549             error with B.
550              
551             =cut
552              
553             { # closure for Class admin storage
554              
555             # define class declaration list storage
556             #
557             my %__DECL__ = ();
558              
559             # define class initialisation storage
560             #
561             my %__INIT__ = ();
562              
563             # define class default attribute storage, mapping attribute to default
564             # value
565             #
566             my %__DEFN__ = ();
567              
568             # define class default attribute storage, mapping attribute to type
569             #
570             my %__ATTR__ = ();
571              
572             # define the attributes that may be defined in a call to new()
573             # - this overrides the use of public attributes
574             my %__NEW__ = ();
575              
576             # define class mapping of attributes to attribute types
577             #
578             my %__TYPE__ = ();
579              
580             # define class friend definitions storage
581             #
582             my %__FRIEND__ = ();
583              
584             # define global object storage
585             #
586             my %__OBJECTS__ = (); # hash holding current object hashes
587              
588             # create a map to say which attributes are instance attributes and
589             # which are class attributes
590             my %__INSTANCE__ = map { $_ => 1 } qw( public private protected );
591              
592              
593             # declare()
594             #
595             sub declare
596             {
597             # determine the class we've been called from
598 212     212 1 335918 my $class = __PACKAGE__->class( shift ); # this should be our name
599 212   33     917 $class = ref( $class ) || $class; # ... make sure it is :)
600            
601             # where were we called from
602 212         894 my ( undef , $file , $line ) = caller 0;
603              
604             # make sure this is only called once per class
605             ( exists $__DECL__{ $class } )
606             and die "$class redeclared at $file line $line "
607             . "\n\t(original declaration at "
608             . $__DECL__{ $class }->{ file } . " line "
609 212 100       3507 . $__DECL__{ $class }->{ line } . ")\n";
610              
611             # make sure we have a valid set of arguments
612 211         1210 my $_args = __PACKAGE__->arguments(
613             \@_ => [ qw( class static restricted
614             public private protected
615             init strict friends
616             new abstract ) ]
617             ); # $_args
618              
619             # ensure the init argument is undefined or is a code ref
620             ( ! defined $_args->{ init } || ref( $_args->{ init } ) eq 'CODE' )
621             or die "$class init failure: " . $_args->{ init }
622 209 100 100     1098 . " is not a CODEREF at $file line $line\n";
623              
624             # store the class initialiser reference
625 204         465 my $ref = delete $_args->{ init };
626 204 100       497 $__INIT__{ $class } = $ref if ( defined $ref );
627              
628             # store the allowed attributes of new()
629 204         318 my $new = delete $_args->{ new };
630 204 100       441 if ( defined $new ) {
631             # make sure we have a list of values
632 1 50       5 $new = [ $new ] unless ( ref $new );
633 1 50       4 ( ref( $new ) eq 'ARRAY' )
634             or die "An array reference or scalar expected for declaration "
635             . "of 'new' attributes at $file line $line\n";
636             }
637              
638             # have we been told of friends of this class?
639 204         316 my $friends = delete $_args->{ friends };
640 204 100       455 if ( defined $friends ) {
641             # make sure we have a list of values
642 8 100       24 $friends = [ $friends ] unless ( ref $friends );
643 8 50       21 ( ref( $friends ) eq 'ARRAY' )
644             or die "An array reference or scalar expected for declaration "
645             . "of friend methods and classes at $file line $line\n";
646              
647             # now create the friends lookup table for this class
648 8         11 $__FRIEND__{ $class } = { map { $_ => undef } @{ $friends } };
  13         36  
  8         16  
649             }
650              
651             # are we required to perform strict type checking, or not, or are
652             # they just not bothered?
653 204         366 my $strict = delete $_args->{ strict };
654 204 100       490 if ( defined $strict ) {
655             # if the class requires strict relationship checking, then
656             # insert reference to the standard Class::Declare public(),
657             # private(), protected() and class() methods into the new
658             # class's symbol table, otherwise, just ad no-ops.
659 21         31 foreach ( grep { $_ ne 'abstract' } keys %{ $_args } ) {
  147         242  
  21         51  
660 28     28   178 no strict 'refs';
  28         54  
  28         18328  
661              
662 126         214 my $glob = join '::' , $class , $_;
663 126         684 *{ $glob } = ( $strict ) ? *{ join '::' , __PACKAGE__ , $_ }
  24         53  
664 126 100   5544   380 : sub { $_[ 1 ] };
  5544         129397  
665             }
666              
667             }
668             # if there's no explicit definition of the public(), private(), etc
669             # methods, so this class will just inherit from its parents
670              
671             # make sure the arguments are understandable
672             # i.e. we either have a hash reference, an array reference or a scalar
673             # (non-reference) value for the value of each type of attribute (so that
674             # we can simplify the specification of attributes)
675 204         279 foreach my $type ( keys %{ $_args } ) {
  204         640  
676 1428         1918 my $ref = $_args->{ $type };
677              
678             # ignore this type of attribute if none have been declared
679 1428 100       2767 next unless ( defined $ref );
680              
681             # if we have a hash reference, then ignore this type of attribute
682 288 100 100     1519 next if ( ref( $ref ) && ref( $ref ) eq 'HASH' );
683              
684             # if we don't have a reference, then we can assume that we have simply
685             # been given the attribute name and should therefore default the
686             # attribute to undef
687 7 100       33 $ref = { $ref => undef } unless ( ref $ref );
688             # if we have an array reference rather than a hash reference, then
689             # convert this into a hash with undef default attribute values
690 7 100       27 $ref = { map { $_ => undef } @{ $ref } } if ( ref $ref eq 'ARRAY' );
  8         20  
  2         5  
691              
692             # must make sure we have a hash reference (at this stage)
693 7 50       25 ( ref( $ref ) eq 'HASH' )
694             or die "Scalar, array reference, or hash reference expected "
695             . "for declaration of $type attributes at $file line "
696             . "$line\n";
697              
698             # make sure the arguments hash is updated with the new reference
699 7         14 $_args->{ $type } = $ref;
700             }
701              
702             # make sure there are no duplicate attribute names
703             {
704 204         407 local %_;
  204         338  
705              
706             # examine each type of attribute
707 204         240 TYPE: foreach my $type ( keys %{ $_args } ) {
  204         606  
708 1428         1712 my $ref = $_args->{ $type };
709              
710             # if there are no attributes of this type, then skip
711 1428 100       3169 next TYPE unless ( defined $ref );
712              
713             # make sure we don't have doubling up
714 288         351 foreach my $attr ( keys %{ $ref } ) {
  288         652  
715             ( exists $_{ $attr } )
716             and die "$class attribute $attr redefined as $type "
717             . " at $file line $line"
718             . "\n\t(also defined as "
719             . $_{ $attr }->{ type } . " at "
720             . $_{ $attr }->{ file } . " line "
721 391 100       820 . $_{ $attr }->{ line } . ")\n";
722              
723             # store where this attribute was defined
724 390         1641 $_{ $attr } = { type => $type ,
725             file => $file ,
726             line => $line };
727             }
728             }
729              
730             # if 'new' was defined in declare() then ensure we have only instance
731             # attributes defined
732 203 100       849 if ( defined $new ) {
733             # ensure that the attributes defined in the 'new' attribute are known
734 1         2 my @unknown = grep { ! exists $_{ $_ } } @{ $new };
  2         5  
  1         3  
735 1 0       5 ( @unknown )
    50          
736             and die "Unknown attribute" . ( ( @unknown == 1 ) ? '' : 's' )
737             . " '" . join( "', '" , @unknown ) . "' in declaration "
738             . "of 'new' at $file line $line\n";
739             # ensure the defined attributes are instance attributes
740 2         7 my @class = grep { ! $__INSTANCE__{ $_{ $_ }->{ type } } }
741 1         2 @{ $new };
  1         2  
742 1 0       4 ( @class )
    50          
743             and die "Non-instance attribute" . ( ( @class == 1 ) ? '' : 's' )
744             . " '" . join( "', '" , @class ) . "' in declaraion "
745             . "of 'new' at $file line $line\n";
746              
747             # having made it here, we can set the $__NEW__ entry for this class
748 1         5 $__NEW__{ $class } = $new;
749             }
750             }
751              
752             # create the required attribute accessor methods
753 203         262 TYPE: foreach my $type ( keys %{ $_args } ) {
  203         544  
754 1416         1717 my $ref = $_args->{ $type };
755              
756             # if there are no types of these routines, then don't proceed
757 1416 100       2920 next TYPE unless ( defined $ref );
758              
759             # create all of the attribute accessor methods for this package
760 286         495 CREATE: foreach ( $type ) {
761             # class or abstract attribute
762 286 100       695 ( ! $__INSTANCE__{ $_ } ) && do {
763 141         198 METHOD: foreach my $method ( keys %{ $ref } ) {
  141         289  
764             # firstly, make sure this class doesn't already have a
765             # method of this name defined
766 148 50       673 ( $class->has( $method ) )
767             and die "Attempt to redeclare method $method in "
768             . "class $class as a $type method at $file "
769             . "line $line\n";
770              
771             # now, make sure Class::Declare doesn't already have
772             # a method of this name defined
773 148 100       354 ( __PACKAGE__->has( $method ) )
774             and die "Attempt to override " . __PACKAGE__
775             . "::$method() in class $class as a "
776             . "$type method at $file line $line\n";
777              
778             # OK, this method doesn't exist elsewhere, so we can
779             # continue
780             {
781 28     28   148 no strict 'refs';
  28         46  
  28         11000  
  147         197  
782              
783             # generate the glob name
784 147         385 my $glob = join '::' , $class , $method;
785 147         221 my $value = $ref->{ $method };
786             # by default class attributes are read-only
787 147         191 my $write = undef;
788              
789             # if we have an abstract method, then there's no value to
790             # consider
791 147 100       415 /^abstract$/ && do {
792 5     81   26 *{ $glob } = sub { $class->$type( shift , $glob ) };
  5         20  
  81         503  
793 5         15 next METHOD;
794             };
795              
796             # do we have a Class::Declare::Read object?
797 142 100 100     558 if ( ref( $value )
      100        
798             && $value =~ m#=#o
799             && $value->isa( 'Class::Declare::Read' ) ) {
800             # then we need to extract the actual attribute
801             # value and determine if it is read-write
802 6         14 $write = $value->write;
803             # make sure we store the value, and not the the
804             # wrapper Class::Declare::Read object beyond this
805             # point
806 6         13 $ref->{ $method } = $value = $value->value;
807             }
808              
809             # should we create a read-only or a read-write
810             # accessor?
811 142         609 *{ $glob } = ( $write ) ?
812             # the accessor should be read-write
813             sub : lvalue method {
814 30     30   491 $class->$type( shift , $glob );
815              
816 30 100       70 $value = shift if ( @_ );
817 30         148 $value;
818             } :
819             # the accessor should be read only
820             sub : method {
821 3321     3321   18577 $class->$type( $_[ 0 ] , $glob );
822              
823 3243         8734 return $value;
824 142 100       675 }; # new class/static/restricted method
825             }
826             }
827              
828 140         333 last CREATE;
829             };
830              
831             # otherwise we're creating public, protected and private
832             # methods
833 145         1025 foreach my $method ( keys %{ $ref } ) {
  145         384  
834             # need to make sure this class doesn't have a method of this
835             # name already
836 241 50       853 ( $class->has( $method ) )
837             and die "Attempt to redeclare method $method in "
838             . "class $class as a $type method at $file "
839             . "line $line\n";
840              
841             # now, make sure Class::Declare doesn't already have
842             # a method of this name defined
843 241 100       559 ( __PACKAGE__->has( $method ) )
844             and die "Attempt to override " . __PACKAGE__
845             . "::$method() in class $class as a "
846             . "$type method at $file line $line\n";
847              
848             # OK, this method doesn't exist already, so we can continue
849             {
850 28     28   144 no strict 'refs';
  28         48  
  28         22999  
  240         1434  
851              
852             # generate the glob name
853 240         645 my $glob = join '::' , $class , $method;
854 240         407 my $value = $ref->{ $method };
855             # by default instance attributes are read-write
856 240         309 my $write = 1;
857              
858             # do we have a Class::Declare::Read object?
859 240 100 100     785 if ( ref( $value )
      100        
860             && $value =~ m#=#o
861             && $value->isa( 'Class::Declare::Read' ) ) {
862             # then we need to extract the actual attribute
863             # value and determine if it is read-write
864 6         22 $write = $value->write;
865             # have to store the attribute value back into the
866             # original hash
867 6         24 $ref->{ $method } = $value->value;
868             }
869              
870             # should we create a read-write or a read-only accessor?
871 240         1275 *{ $glob } = ( $write ) ?
872             # the accessor should be read-write
873             sub : lvalue method {
874 9653     9653   473286 my $self = $class->$type( shift , $glob );
875              
876 9505         11171 my $hash;
877             # make sure we have a valid object
878             ( ref( $self )
879 9361         34198 and $hash = $__OBJECTS__{ ${ $self } } )
880 9505 100 66     21312 or do {
881 144         637 my ( undef , $file , $line ) = caller 0;
882 144         1086 die "$self is not a $class object at $file line $line\n";
883             };
884              
885             # set the value if required and return
886 9361 100       19279 $hash->{ $method } = shift if ( @_ );
887 9361         29536 $hash->{ $method };
888             } :
889             # the accessor should be read-only
890             sub : method {
891 10     10   381 my $self = $class->$type( $_[ 0 ] , $glob );
892              
893 10         16 my $hash;
894             # make sure we have a valid object
895             ( ref( $self )
896 10         50 and $hash = $__OBJECTS__{ ${ $self } } )
897 10 50 33     29 or do {
898 0         0 my ( undef , $file , $line ) = caller 0;
899 0         0 die "$self is not a $class object at $file line $line\n";
900             };
901              
902             # return the required value
903 10         63 return $hash->{ $method };
904 240 100       1279 }; # new public/private/protected method
905             }
906             }
907              
908             } # end of CREATE
909              
910             } # end of TYPE
911              
912             # OK, this is a new definition, so record the relevant details
913 201         841 $__DECL__{ $class } = { file => $file , line => $line };
914 284         340 $__DEFN__{ $class } = { map { %{ $_ } }
  284         1059  
915 1407         2201 grep { defined }
916 201         297 values %{ $_args } };
  201         521  
917              
918             # keep a record of the attributes of this class, making note of the type
919             # of each attribute as well
920 201         443 $__TYPE__{ $class } = {};
921 201         397 foreach my $type ( qw( class static restricted
922             public private protected
923             abstract ) ) {
924             # do we have attributes of this type for this class?
925 1407 100       1498 if ( my @attr = keys %{ $_args->{ $type } } ) {
  1407         4268  
926 284         596 $__ATTR__{ $class }->{ $type } = \@attr;
927 284         1257 $__TYPE__{ $class }->{ $_ } = $type foreach ( @attr );
928              
929             # if not, store an empty list
930             } else {
931 1123         2683 $__ATTR__{ $class }->{ $type } = [];
932             }
933             }
934              
935             # if this class is derived from Class::Declare::Attributes then attempt to
936             # call Class::Declare::Attributes::__init__()
937 201         344 my $cda = __PACKAGE__ . '::Attributes';
938 201 50       1143 if ( UNIVERSAL::isa( $class => $cda ) ) {
939 0         0 my $ref = UNIVERSAL::can( $cda => '__init__' );
940 0 0       0 $ref->( $class ) if ( defined $ref );
941             }
942              
943 201         1937 1; # everything is OK
944             } # declare()
945              
946              
947             =back
948              
949             =head2 Creating Objects
950              
951             Once a B-derived class has been declared, instances
952             of that class may be created through the B method supplied by
953             B. B may be called either as a class or an instance
954             method. If called as a class method, a new instance will be created,
955             using the class's default attribute values as the default values for this
956             instance. If B is called as an instance method, the default attribute
957             values for the new instance will be taken from the invoking instance. This
958             may be used to clone B-derived objects.
959              
960             B has the following call syntax and behaviour:
961              
962             =over 4
963              
964             =item B [ I => I ] B<)>
965              
966             B creates instances of B objects. If a problem
967             occurs during the creation of an object, such as the failure of an object
968             initialisation routine, then B will raise an error through B.
969              
970             When called as a class method, B will create new instances of the
971             specified class, using the class's default attribute values. If it's called
972             as an instance method, then B will clone the invoking object.
973              
974             B accepts named parameters as arguments, where I corresponds
975             to a I attribute of the class of the object being created. If an
976             unknown attribute name, or a non-I attribute name is specified, then
977             B will B with an error. Public attribute values specified
978             in the call to B are assigned after the creation of the object,
979             to permit over-riding of default values (either class-default attributes
980             or attributes cloned from the invoking object).
981              
982             B can be extended to accept non-public instance attributes as
983             parameters through the specification of the I attribute of B
984             (see above). In this instance, only the attributes listed in the definition
985             of I in B will be accepted, and all public attributes will
986             only be accepted if contained within this list.
987              
988             If the calling class, or any of its base classes, has an object
989             initialisation routine defined (specified by the I parameter of
990             B), then these routines will be invoked in reverse C<@ISA> order,
991             once the object's attribute values have been set. An initialisation routine
992             may only be called once per class per object, so if a class appears multiple
993             times in the C<@ISA> array of the new object's class, then the base class's
994             initialisation routine will be called as early in the initialisation chain
995             as possible, and only once (i.e. as a result of the right-most occurrence
996             of the base class in the C<@ISA> array).
997              
998             The initialisation routines should return a true value to indicate
999             success. If any of the routines fail (i.e. return a false value), then
1000             B will B with an error.
1001              
1002             =back
1003              
1004             When a new instance is created, instance attributes (i.e. I,
1005             I and I attributes) are cloned, so that the new instance
1006             has a copy of the default values. For values that are not references, this
1007             amounts to simply copying the value through assignment. For values that
1008             are references, B is used to ensure each instance has
1009             it's own copy of the references data structure (the structures are local
1010             to each instance).
1011              
1012             However, if an instance attribute value is a C, then B simply
1013             copies the reference to the new object, since Cs cannot be cloned.
1014              
1015             Class attributes are not cloned as they are assumed to be constant across
1016             all object instances.
1017              
1018             =cut
1019             sub new : method
1020             {
1021 305     305 1 40190 my $self = __PACKAGE__->class( shift );
1022 305   66     1110 my $class = ref( $self ) || $self;
1023              
1024             # generate the combined @ISA array for this class
1025 305         562 my @isa = ( $class );
1026 305         386 my $i = 0;
1027 305         714 while ( $i <= $#isa ) {
1028 28     28   161 no strict 'refs';
  28         55  
  28         74021  
1029              
1030 1259 50       2789 my $pkg = $isa[ $i++ ] or next;
1031 1259         1342 push @isa , @{ $pkg . '::ISA' };
  1259         4899  
1032             }
1033             # remove the duplicates and reverse
1034 305   33     1142 @isa = local %_ || grep { ! $_{ $_ }++ } reverse @isa;
1035              
1036             # initialise the hash reference for this object instance
1037             # - use Storable::dclone here to ensure that each object has
1038             # a copy of the default values of the attributes, regardless
1039             # of the structure
1040             # - CODEREFs are not copied
1041             # NB: when using Storable::dclone we need to make sure that we
1042             # only clone each reference once, so if multiple entries
1043             # refer to the same structure, then the copy of the hash will show
1044             # those entries pointing to the same structure
1045 305         469 my %hash; undef %hash;
  305         475  
1046             {
1047             # create a lookup table of all stored references
1048 305         346 my %memory; undef %memory;
  305         322  
  305         376  
1049              
1050             # for each class, extract the attribute definition array
1051 305         524 ISA: foreach my $isa ( @isa ) {
1052             # only worry about Class::Declare classes
1053 1123 100       2849 next ISA unless ( exists $__DECL__{ $isa } );
1054              
1055             # extract the definition hash for this class
1056             # this contains the default values for the class and object
1057             # attributes
1058             # however, if we've been called as an instance method, then we
1059             # should use the calling object's instance hash (stored in
1060             # %__OBJECTS__) for the default values
1061             # have we been called as an instance method?
1062             # - extract the instance hash
1063             # - otherwise, use the class's default hash (ignore this class
1064             # if there is no default hash)
1065 5         23 my $defn = ref( $self ) ? $__OBJECTS__{ ${ $self } }
1066 324 100       799 : $__DEFN__{ $isa };
1067              
1068             # split the typemap hash into key/value pairs
1069             # - the typemap hash maps attributes to their types
1070             # e.g. public, private, protected, etc
1071 324         417 while ( my ( $key , $type ) = each %{ $__TYPE__{ $isa } } ) {
  1390         4940  
1072             # extract the value for this attribute
1073 1066         1417 my $value = $defn->{ $key };
1074              
1075             # if this is an instance attribute and it has a reference
1076             # value then we should clone the attribute value so that
1077             # each instance has a copy of the original structure
1078 1066         1328 my $vtype = ref( $value );
1079 1066 100 100     2600 if ( $vtype && $vtype ne 'CODE' && $__INSTANCE__{ $type } ) {
      66        
1080             # OK, we need to keep track of the references we
1081             # clone, so that if we see the same reference more
1082             # than once we only clone it a single time
1083              
1084             # clone this reference if we haven't seen it before
1085 75   66     1960 $value = $memory{ $value }
1086             ||= Storable::dclone( $value );
1087             }
1088              
1089             # store the key/value pair
1090 1066         2505 $hash{ $key } = $value;
1091             }
1092             }
1093             }
1094              
1095             # create an anonymous hash reference for this object
1096 305         445 my $ref = \%hash;
1097 305         1503 my ( $key ) = ( $ref =~ m#0x([a-f\d]+)#o );
1098 305         752 $__OBJECTS__{ $key } = $ref;
1099              
1100             # create the new object (applying the index offset)
1101 305         603 my $obj = bless \$key => $class;
1102              
1103             # if there were any arguments passed, then these will be used to
1104             # set the parameters for this object
1105             # NB: - only public attributes may be set this way
1106             # - need to examine every class in the @ISA hierarchy
1107             # - may override 'public attributes' with 'new' list in declare()
1108             my $default = sub {
1109             ( defined $__NEW__{ $_[0] } )
1110 7         21 ? @{ $__NEW__{ $_[0] } }
1111 317         350 : map { @{ $_ } }
  317         925  
1112 317         603 grep { defined }
1113 317         687 map { $_->{ public } }
1114 1116         2646 grep { defined }
1115 1123 100   1123   2808 ( $__ATTR__{ $_ } )
1116 305         1165 }; # $default()
1117 293         838 my %default = map { $_ => $hash{ $_ } }
1118 305         525 map { $default->( $_ ) } @isa;
  1123         1902  
1119 305         516 my %args = eval { __PACKAGE__->arguments( \@_ => \%default ) };
  305         916  
1120              
1121             # if there has been an error, then augment the error string
1122             # with a new() specific explanation
1123             # NB: have to adjust the original error string to show the
1124             # source of the original error
1125 305 100       974 if ( $@ ) {
1126 7         17 my ( undef , $file , $line , $sub ) = caller 0;
1127              
1128             # rather than report this base class, make sure the
1129             # subroutine is a method of the calling class
1130 7         236 my $pkg = __PACKAGE__;
1131 7         45 $sub =~ s#$pkg#$class#g;
1132              
1133             # augment the error message
1134 7         14 my $msg = $@;
1135 7         63 $msg =~ s#\S+ at #$sub() at #;
1136 7         40 $msg =~ s#at \S+ line \d+#at $file line $line#;
1137              
1138             # add the additional explanation to the message
1139 7         63 die $msg . "\t(only public attributes may be set during "
1140             . "object creation)\n";
1141             }
1142              
1143             # otherwise, set the default attributes for this object
1144 298         775 $hash{ $_ } = $args{ $_ } foreach ( keys %args );
1145              
1146             # execute the initialisation routines
1147 298         493 foreach my $pkg ( grep { exists $__INIT__{ $_ } } @isa ) {
  1100         2106  
1148             # make sure the initialisation succeeds
1149             $__INIT__{ $pkg }->( $obj )
1150 49 100       354 or do {
1151 2         15 my ( undef , $file , $line ) = caller 0;
1152              
1153 2         105 die "Initialisation of $class object failed at "
1154             . "$file line $line\n\t($pkg initialisation)\n";
1155             };
1156             }
1157              
1158             # return the object
1159 296         2912 return $obj;
1160             } # new()
1161              
1162              
1163             =head2 Class Access Control Methods
1164              
1165             B provides the following class methods for implementing
1166             I, I and I access control in class methods. These
1167             methods may be called either through a B-derived class,
1168             or an instance of such a class.
1169              
1170             Note that a I method is a I class method, a I method
1171             is a I class method, and a I method is a I
1172             class method.
1173              
1174              
1175             =over 4
1176              
1177             =item B I B<)>
1178              
1179             Ensure a method is implemented, but throwing a fatal error (i.e. die()'ing
1180             if called).
1181              
1182             =cut
1183             sub abstract : method
1184             {
1185 145     145 1 1571 my ( undef , $file , $line , $sub ) = caller 1;
1186 145   66     527 $sub = $_[ 2 ] || $sub;
1187              
1188 145         1000 die "Abstract method $sub() called at $file line $line\n";
1189             } # abstract()
1190              
1191              
1192             =item B I B<)>
1193              
1194             Ensure a method is called as a class method of this package via the I.
1195              
1196             sub myclasssub {
1197             my $self = __PACKAGE__->class( shift );
1198             ...
1199             }
1200              
1201             A I method may be called from anywhere, and I must inherit
1202             from this class (either an object or instance). If B is not invoked
1203             in this manner, then B will B with an error.
1204              
1205             See also the I parameter for B above.
1206              
1207             =cut
1208             sub class : method
1209             {
1210             # has this method been called as a class or object method?
1211 4619 50 33 4619 1 208290 return $_[ 1 ] if ( defined $_[ 1 ] && $_[ 1 ]->isa( $_[ 0 ] ) );
1212              
1213             # determine where we (i.e. the method containing class()) was called from
1214 0         0 my ( undef , $file , $line , $sub ) = caller 1;
1215 0   0     0 $sub = $_[ 2 ] || $sub;
1216 0   0     0 my $class = ref $_[ 0 ] || $_[ 0 ];
1217 0         0 die "$_[ 1 ] is not a $class class or object in call to $sub() "
1218             . "at $file line $line\n";
1219             } # class()
1220              
1221              
1222             =item B I B<)>
1223              
1224             Ensure a method is called as a static method of this package via I.
1225              
1226             sub mystaticsub {
1227             my $self = __PACKAGE__->static( shift );
1228             ...
1229             }
1230              
1231             A I method may only be called from within the defining class,
1232             and I must inherit from this class (either an object or instance).
1233             If B is not invoked in this manner, then B will B
1234             with an error.
1235              
1236             See also the I and I parameters for B above.
1237              
1238             =cut
1239             sub static : method
1240             {
1241             # extract the caller context
1242 633     633 1 5512 my ( $pkg , $file , $line , $sub ) = caller 1;
1243 633   33     4754 my $class = ref $_[ 0 ] || $_[ 0 ];
1244            
1245             # at the very least we must have a reference
1246 633 50       1578 if ( defined $_[ 1 ] ) {
1247             # has this method been called as a static method?
1248 633 100 66     4057 return $_[ 1 ] if ( $_[ 1 ]->isa( $class )
1249             && $pkg eq $class );
1250              
1251             # has this method been called from within a parent class?
1252 148 100       862 return $_[ 1 ] if ( $class->isa( $pkg ) );
1253              
1254             # have to go back on more depth in the caller stack to obtain
1255             # the name of the method in which this call was made
1256 112         421 my ( undef , undef , undef , $caller ) = caller 2;
1257             # is the caller a friend of this class?
1258 112 100       1936 if ( my $ref = $__FRIEND__{ $class } ) {
1259             return $_[ 1 ] if ( exists $ref->{ $pkg }
1260 38 100 66     282 || exists $ref->{ $caller } );
1261             }
1262             }
1263              
1264             # someone's trying to be naughty: time to tell them about it
1265             # - the subroutine name may be passed in to ensure the correct
1266             # glob is reported by the dynamically instantiated methods
1267             # created by declare()
1268 92   66     237 $sub = $_[ 2 ] || $sub;
1269 92         714 die "cannot call static method $sub() from outside "
1270             . "$class or parent ($pkg) at $file line $line\n";
1271             } # static()
1272              
1273              
1274             =item B I B<)>
1275              
1276             Ensure a method is called as a restricted method of this package via
1277             I.
1278              
1279             sub myrestrictedsub {
1280             my $self = __PACKAGE__->restricted( shift );
1281             ...
1282             }
1283              
1284             A I method may only be called from within the defining class or
1285             a class that inherits from the defining class, and I must inherit
1286             from this class (either an object or instance). If B is
1287             not invoked in this manner, then B will B with an error.
1288              
1289             See also the I and I parameters for B above.
1290              
1291             B B was called B in the first release of
1292             B. However, with the advent of L,
1293             there was a clash between the use of B<:shared> as an attribute by
1294             L, and the Perl use of B<:shared> attributes
1295             for threading.
1296              
1297             =cut
1298             sub restricted : method
1299             {
1300             # extract the caller context
1301 726     726 1 5343 my ( $pkg , $file , $line , $sub ) = caller 1;
1302 726   33     4697 my $class = ref $_[ 0 ] || $_[ 0 ];
1303            
1304             # at the very least we must have a reference
1305 726 50       1545 if ( defined $_[ 1 ] ) {
1306             # has this method been called as a private method?
1307 726 100 66     5658 return $_[ 1 ] if ( $_[ 1 ]->isa( $_[ 0 ] )
1308             && $pkg->isa( $_[ 0 ] ) );
1309              
1310             # has this method been called from within a parent class?
1311 106 100       621 return $_[ 1 ] if ( $class->isa( $pkg ) );
1312              
1313             # have to go back on more depth in the caller stack to obtain
1314             # the name of the method in which this call was made
1315 70         284 my ( undef , undef , undef , $caller ) = caller 2;
1316              
1317             # is the caller a friend of this class?
1318 70 100       1496 if ( my $ref = $__FRIEND__{ $class } ) {
1319             return $_[ 1 ] if ( exists $ref->{ $pkg }
1320 34 100 66     241 || exists $ref->{ $caller } );
1321             }
1322             }
1323              
1324             # someone's trying to be naughty: time to tell them about it
1325             # - the subroutine name may be passed in to ensure the correct
1326             # glob is reported by the dynamically instantiated methods
1327             # created by declare()
1328 50   66     159 $sub = $_[ 2 ] || $sub;
1329 50         528 die "cannot call restricted method $sub() from outside $class "
1330             . "sub-class or parent ($pkg) at $file line $line\n";
1331             } # restricted()
1332              
1333              
1334             # NB: restricted() used to be shared(), so let's put a stub in place to show
1335             # the deprecation of shared()
1336             sub shared : method
1337             {
1338             # determine where we were called from
1339 1     1 0 533 my ( undef , $file , $line ) = caller 0;
1340              
1341             # show that shared() is no longer supported and die
1342 1         50 die __PACKAGE__ . '::shared() has been deprecated - see ' .
1343             __PACKAGE__ . "::restricted() instead (at $file line $line)\n";
1344             } # shared()
1345              
1346              
1347             =back
1348              
1349             =head2 Instance Access Control Methods
1350              
1351             B provides the following instance methods for implementing
1352             I, I and I access control in instance methods.
1353             These methods may only be called through a B-derived
1354             instance.
1355              
1356             =over 4
1357              
1358             =item B I B<)>
1359              
1360             Ensure a method is called as a public method of this class via I.
1361              
1362             sub mypublicsub {
1363             my $self = __PACKAGE__->public( shift );
1364             ...
1365             }
1366              
1367             A I method may be called from anywhere, and I must be an
1368             object that inherits from this class. If B is not invoked in
1369             this manner, then B will B with an error.
1370              
1371             See also the I parameter for B above.
1372              
1373             =cut
1374             sub public : method
1375             {
1376             # has this method been called as a public method?
1377 4800 100 66 4800 1 155991 return $_[ 1 ] if ( defined $_[ 1 ] && ref $_[ 1 ]
      66        
1378             && $_[ 1 ]->isa( $_[ 0 ] ) );
1379              
1380             # determine where we (i.e. the method containing public())
1381             # was called from
1382 256         1781 my ( undef , $file , $line , $sub ) = caller 1;
1383 256   33     959 my $class = ref $_[ 0 ] || $_[ 0 ];
1384 256   66     824 $sub = $_[ 2 ] || $sub;
1385 256         2322 die "$_[ 1 ] is not a $class object in call to $sub() "
1386             . "at $file line $line\n";
1387             } # public()
1388              
1389              
1390             =item B I B<)>
1391              
1392             Ensure a method is called as a private method of this class via I.
1393              
1394             sub myprivatesub {
1395             my $self = __PACKAGE__->private( shift );
1396             ...
1397             }
1398              
1399             A I method may only be called from within the defining class, and
1400             I must be an instance that inherits from this class. If B
1401             is not invoked in this manner, then B will B with an error.
1402              
1403             See also the I and I parameters for B above.
1404              
1405             =cut
1406             sub private : method
1407             {
1408             # extract the caller context
1409 17352     17352 1 601735 my ( $pkg , $file , $line , $sub ) = caller 1;
1410 17352   33     58666 my $class = ref $_[ 0 ] || $_[ 0 ];
1411            
1412             # at the very least we must have a reference
1413 17352 100 66     71438 if ( defined $_[ 1 ] && ref $_[ 1 ] ) {
1414             # has this method been called as a private method?
1415 17288 100 66     108391 return $_[ 1 ] if ( $_[ 1 ]->isa( $class )
1416             && $pkg eq $class );
1417              
1418             # has this method been called from within a parent class?
1419 98 100       480 return $_[ 1 ] if ( $class->isa( $pkg ) );
1420              
1421             # have to go back on more depth in the caller stack to obtain
1422             # the name of the method in which this call was made
1423 74         288 my ( undef , undef , undef , $caller ) = caller 2;
1424             # is the caller a friend of this class?
1425 74 100       1141 if ( my $ref = $__FRIEND__{ $class } ) {
1426             return $_[ 1 ] if ( exists $ref->{ $pkg }
1427 26 100 66     162 || exists $ref->{ $caller } );
1428             }
1429             }
1430              
1431             # someone's trying to be naughty: time to tell them about it
1432             # - the subroutine name may be passed in to ensure the correct
1433             # glob is reported by the dynamically instantiated methods
1434             # created by declare()
1435 126   66     327 $sub = $_[ 2 ] || $sub;
1436 126         978 die "cannot call private method $sub() from outside "
1437             . "$class or parent ($pkg) at $file line $line\n";
1438             } # private()
1439              
1440              
1441             =item B I B<)>
1442              
1443             Ensure a method is called as a protected method of this class via I.
1444              
1445             sub myprotectedsub {
1446             my $self = __PACKAGE__->protected( shift );
1447             ...
1448             }
1449              
1450             A I method may only be called from within the defining class or
1451             a class that inherits from the defining class, and I must be an
1452             instance that inherits from this class. If B is not invoked
1453             in this manner, then B will B with an error.
1454              
1455             See also the I and I parameters for B above.
1456              
1457             =cut
1458             sub protected : method
1459             {
1460             # extract the caller context
1461 451     451 1 3825 my ( $pkg , $file , $line , $sub ) = caller 1;
1462 451   33     3224 my $class = ref $_[ 0 ] || $_[ 0 ];
1463            
1464             # at the very least we must have a reference
1465 451 100 66     1891 if ( defined $_[ 1 ] && ref $_[ 1 ] ) {
1466             # has this method been called as a private method?
1467 387 100 66     3038 return $_[ 1 ] if ( $_[ 1 ]->isa( $_[ 0 ] )
1468             && $pkg->isa( $_[ 0 ] ) );
1469              
1470             # has this method been called from within a parent class?
1471 70 100       360 return $_[ 1 ] if ( $class->isa( $pkg ) );
1472              
1473             # have to go back on more depth in the caller stack to obtain
1474             # the name of the method in which this call was made
1475 46         164 my ( undef , undef , undef , $caller ) = caller 2;
1476              
1477             # is the caller a friend of this class?
1478 46 100       902 if ( my $ref = $__FRIEND__{ $class } ) {
1479             return $_[ 1 ] if ( exists $ref->{ $pkg }
1480 22 100 66     151 || exists $ref->{ $caller } );
1481             }
1482             }
1483              
1484             # someone's trying to be naughty: time to tell them about it
1485             # - the subroutine name may be passed in to ensure the correct
1486             # glob is reported by the dynamically instantiated methods
1487             # created by declare()
1488 98   66     267 $sub = $_[ 2 ] || $sub;
1489 98         1160 die "cannot call protected method $sub() from outside $class "
1490             . "sub-class or parent ($pkg) at $file line $line\n";
1491             } # protected()
1492              
1493              
1494             =back
1495              
1496             =head2 Destroying Objects
1497              
1498             Object destruction is handled via the normal Perl C
1499             method. B implements a C method that performs
1500             clean-up and house keeping, so it is important that any class derived from
1501             B that requires a C method ensures that it invokes
1502             it's parent's C method, using a paradigm similar to the following:
1503              
1504             sub DESTROY
1505             {
1506             my $self = __PACKAGE__->public( shift );
1507              
1508             ... do local clean-up here ..
1509              
1510             # call the parent clean-up
1511             $self->SUPER::DESTROY( @_ );
1512             } # DESTROY()
1513              
1514              
1515             =cut
1516              
1517             # DESTROY()
1518             #
1519             # Free object hash references.
1520             sub DESTROY
1521             {
1522 305     305   31011 my $self = __PACKAGE__->public( shift );
1523              
1524             # delete the hash holding this object's data
1525 305         409 delete $__OBJECTS__{ ${ $self } };
  305         3055  
1526             } # DESTROY()
1527              
1528              
1529             =head2 Attribute Modifiers
1530              
1531             By default B class attributes (C, C, and
1532             C) are I, while instance attributes (C,
1533             C, and C) are I. B provides
1534             two attribute modifiers, B and B for changing this behaviour,
1535             allowing class attributes to be read-write, and instance attributes to be
1536             read only.
1537              
1538             The modifiers may be imported separately,
1539              
1540             use Class::Declare qw( :read-only );
1541              
1542             or
1543              
1544             use Class::Declare qw( ro );
1545              
1546             or
1547              
1548             use Class::Declare qw( :read-write );
1549              
1550             or
1551            
1552             use Class::Declare qw( rw );
1553              
1554             or collectively, using the C<:modifiers> tag.
1555              
1556             use Class::Declare qw( :modifiers );
1557              
1558             To use the modifiers, they must be incorporated into the attribute definition
1559             for the class. For example:
1560              
1561             package My::Class;
1562              
1563             use strict;
1564             use Class::Declare qw( :modifiers );
1565             use vars qw( @ISA );
1566             @ISA = qw( Class::Declare );
1567              
1568             __PACKAGE__->declare( class => { my_class => rw undef } ,
1569             public => { my_public => ro 1234 } );
1570              
1571             Here, the attribute C has been declared I by B,
1572             permitting it's value to be changed at run time. The public attribute
1573             C has been declared I by B, preventing it from
1574             being changed once set. Please note that although they may be marked as
1575             I, public attributes may still be set during object creation
1576             (i.e. in the call to B). However, once set, the value may not
1577             be changed.
1578              
1579             =over 4
1580              
1581             =item B
1582              
1583             Declare a class attribute to be I, instead of defaulting to
1584             read-only. Note that this has no effect on instance attributes as they
1585             are read-write by default.
1586              
1587              
1588             =item B
1589              
1590             Declare an instance attribute to be I, instead of defaulting to
1591             read-write. Note that this has no effect on class attributes as they are
1592             read-only by default.
1593              
1594             =back
1595              
1596             =cut
1597              
1598             { # closure for declaring the Read::Write and Read::Only classes
1599              
1600             {
1601             # declare a base Read class
1602             package Class::Declare::Read;
1603              
1604 28     28   205 use strict;
  28         49  
  28         747  
1605 28     28   139 use base qw( Class::Declare );
  28         74  
  28         3145  
1606              
1607             __PACKAGE__->declare( public => { value => undef } );
1608              
1609             1;
1610              
1611              
1612             # declare the Read::Only class
1613             package Class::Declare::Read::Only;
1614              
1615 28     28   129 use strict;
  28         46  
  28         730  
1616 28     28   155 use base qw( Class::Declare::Read );
  28         78  
  28         14860  
1617              
1618             __PACKAGE__->declare( class => { write => undef } );
1619              
1620             1;
1621              
1622              
1623             # declare the Read::Write class
1624             package Class::Declare::Read::Write;
1625              
1626 28     28   166 use strict;
  28         57  
  28         771  
1627 28     28   137 use base qw( Class::Declare::Read );
  28         63  
  28         45872  
1628              
1629             __PACKAGE__->declare( class => { write => 1 } );
1630              
1631             1;
1632             }
1633              
1634             # make the given scalar as read-write
1635             sub rw ($)
1636             {
1637 7     7 1 87 return Class::Declare::Read::Write->new( value => shift );
1638             } # rw()
1639              
1640             # mark the given scalar as read-only
1641             sub ro ($)
1642             {
1643 7     7 1 122 return Class::Declare::Read::Only->new( value => shift );
1644             } # ro()
1645              
1646             } # end of Read::Write and Read::Only closure
1647              
1648              
1649             =head2 Serialising Objects
1650              
1651             B objects may be serialised (and therefore cloned) by using
1652             L. B uses B itself during
1653             object creation to copy instance attribute values. However, L
1654             is unable to serialise Cs, and attempts to do so will fail. This
1655             causes the failure of serialisation of B objects that have
1656             Cs as attribute values. However, for cloning, B
1657             avoids this problem by simply copying Cs from the original object
1658             to the clone.
1659              
1660             =cut
1661             { # closure for freezing/thawing CODEREFs
1662              
1663             # Storable is unable to freeze/thaw CODEREFs, so here we provide
1664             # in-memory storage for CODEREFs to create the illusion of being able to
1665             # handle CODEREFs. This is used to ensure Storable::dclone() works, but
1666             # is not guaranteed to work for all freeze/thaw combinations (otherwise
1667             # Storable would have done this a lot sooner), so is disabled for
1668             # non-cloning invocations.
1669             my %__CODEREFS__; undef %__CODEREFS__;
1670              
1671             #
1672             # STORABLE_freeze()
1673             #
1674             # Hook for Storable to freeze Class objects.
1675             sub STORABLE_freeze
1676             {
1677 12     12 0 165 my $self = __PACKAGE__->public( shift );
1678 12         18 my $cloning = shift;
1679              
1680             # make sure we're storing
1681             Storable::is_storing
1682 12 50       34 or do {
1683 0         0 my ( undef , $file , $line , $sub ) = caller 0;
1684              
1685 0         0 die "Unexpected call to " . __PACKAGE__ . "::$sub() "
1686             . "at $file line $line\n";
1687             };
1688              
1689             #
1690             # serialise the object
1691             #
1692            
1693             # we want to freeze the actual %__OBJECTS__ key and the data hash
1694 12         13 my $key = ${ $self };
  12         27  
1695              
1696             # extract the object hash
1697 12         24 my $hash = $__OBJECTS__{ $key };
1698              
1699             # if we're cloning, then we may have to play with attributes that have
1700             # CODEREFs as values
1701 12         13 my $code; undef $code;
  12         15  
1702 12 50       26 if ( $cloning ) {
1703              
1704             # if any of the attributes are CODEREFs then store them in %__CODEREFS__
1705             # and replace their values with a key to the %__CODEREFS__ hash
1706             # - a list of attributes with stored CODEREFs is then serialised in
1707             # addition to the rest of the object
1708              
1709             # because we may be playing around with the stored CODEREFs we should
1710             # clone $hash first (not a deep clone, just to the first level)
1711 12         10 $hash = { %{ $hash } };
  12         45  
1712              
1713             # now, we need to look for CODEREFs and store them in memory
1714 12         20 ATTRIBUTE: foreach ( keys %{ $hash } ) {
  12         31  
1715 56         69 my $value = $hash->{ $_ };
1716              
1717             # only interested in CODEREFs
1718 56 100 100     245 next ATTRIBUTE unless ( ref( $value )
1719             && ref( $value ) eq 'CODE' );
1720              
1721             # now store the coderef in %__CODEREFS__: use the package, attribute
1722             # and CODEREF itself as the key
1723 9         27 my $ref = join '=' , ref( $self ) , $_
1724             , $value , $key;
1725 9         22 $__CODEREFS__{ $ref } = $value;
1726              
1727             # replace the original CODEREF with the key
1728 9         15 $hash->{ $_ } = $ref;
1729             # make note of the fact that this attribute has had it's value
1730             # stashed in the CODEREFs storage
1731 9         12 push @{ $code } , $_;
  9         24  
1732             }
1733             }
1734              
1735             # return the object hash to serialise as well as the list of attributes
1736             # whose values are CODEREFs and who have had these CODEREFs "serialised"
1737             # in memory - we don't worry about the object key since we need to
1738             # ensure the key is unique at all times, so we'll generate a new one
1739             # when we thaw out the object
1740             # NB: we prefix the return value with '' since the first return value
1741             # is expected to be serialized already. we could send back the
1742             # object key (index into %__OBJECTS__) but as we have no need for
1743             # it when we thaw we minimize the freezing computations by sending
1744             # an empty string, rather than the key
1745 12 100       508 return ( defined $code ) ? ( '' , $hash , $code ) : ( '' , $hash );
1746             } # STORABLE_freeze()
1747              
1748              
1749             # STORABLE_thaw()
1750             #
1751             # Hook for Storable to thaw Class objects.
1752             # - if possible, the same object index will be used for the
1753             # recreated object
1754             # - if the index is currently occupied, then the next available
1755             # index will be taken.
1756             sub STORABLE_thaw
1757             {
1758 12     12 0 29 my $self = __PACKAGE__->public( shift );
1759 12         19 my $cloning = shift;
1760              
1761             # make sure we're thawing
1762             Storable::is_retrieving
1763 12 50       29 or do {
1764 0         0 my ( undef , $file , $line , $sub ) = caller 0;
1765              
1766 0         0 die "Unexpected call to " . __PACKAGE__ . "::$sub() "
1767             . "at $file line $line\n";
1768             };
1769              
1770             # OK, @ref should contain a reference to a hash representing the object
1771             # as well as a reference to an array of attributes whose values are
1772             # CODEREFs, and are therefore contained in the %__CODEREFS__ hash
1773 12         22 my ( undef , $hash , $code ) = @_;
1774             ( ref $hash eq 'HASH' )
1775 12 50       28 or do {
1776 0         0 my ( undef , $file , $line , $sub ) = caller 0;
1777              
1778 0         0 die "Corrupt call to " . __PACKAGE__ . "::$sub() "
1779             . "at $file line $line\n"
1780             . "\t(HASH reference expected, got $hash)\n";
1781             };
1782              
1783             # generate the new object key from the address of the object hash
1784 12         47 my ( $key ) = ( $hash =~ m#0x([a-f\d]+)#o );
1785              
1786             # if we have code references stored in memory and we're cloning,
1787             # then attempt to retrieve them
1788 12 100 66     49 if ( $cloning && defined $code ) {
1789 8         12 foreach ( @{ $code } ) {
  8         18  
1790             # extract the reference (delete it so that it doesn't consume
1791             # space ... i.e. a possible memory leak)
1792 9         31 $hash->{ $_ } = delete $__CODEREFS__{ $hash->{ $_ } };
1793             }
1794             }
1795              
1796             # now we can store the object and recreate it
1797 12         28 $__OBJECTS__{ $key } = $hash;
1798 12         13 ${ $self } = $key;
  12         18  
1799              
1800 12         94 return $self; # that's all folks
1801             } # STORABLE_thaw()
1802              
1803             } # end of CODEREFs storage closure
1804              
1805              
1806             =head2 Miscellaneous Methods
1807              
1808             The following methods are class methods of B provided to
1809             simplify the creation of classes. They are provided as convenience
1810             methods, and may be called as either class or instance methods.
1811              
1812             =over 4
1813              
1814             =item BB<)>
1815              
1816             Returns I if the calling class or method is a friend of the given
1817             class or object. That is, for a given object or class, B will
1818             return I if it is called within the context of a class or method
1819             that has been granted friend status by the object or class (see I
1820             in B above). A friend may access I, I,
1821             I and I methods and attributes of a class and it's
1822             instances, but not of derived classes.
1823              
1824             B will return true for a given class or object if called within
1825             that class. That is, a class is always it's own friend.
1826              
1827             In all other circumstances, B will return I.
1828              
1829             package Class::A;
1830              
1831             my $object = Class::B;
1832              
1833             sub somesub {
1834             ...
1835             $object->private_method if ( $object->friend );
1836             ...
1837             }
1838              
1839             =cut
1840             sub friend : method
1841             {
1842             # firstly, this is a class method
1843 102     102 1 529 my $self = __PACKAGE__->class( shift );
1844             # extract our class name
1845 102   66     266 $self = ref( $self ) || $self;
1846              
1847             # extract the calling class and method
1848             # NB: the calling method is in the call stack before the current
1849             # one (i.e. caller 1 not caller 0)
1850 102         233 my $class = caller;
1851 102         1414 my $method = ( caller 1 )[ 3 ];
1852              
1853             # you should always be a friend to yourself
1854 102 50       1488 return 1 if ( $class eq $self );
1855              
1856             # otherwise, extract the friend declarations for this class
1857 102         145 my $friend = $__FRIEND__{ $self };
1858             # if there's no friend information, then the answer is no
1859 102 100       247 return undef unless ( defined $friend );
1860              
1861             # return true only if the class or the method is recorded as a friend
1862             return ( defined $class && exists( $friend->{ $class } )
1863 66   66     445 || defined $method && exists( $friend->{ $method } ) );
1864             } # friend()
1865              
1866              
1867             =item B [ I => I ] B<)>
1868              
1869             Generate a textual representation of an object or class. Since
1870             B objects are represented as references to
1871             scalars, L is unable to generate a meaningful dump of
1872             B-derived objects. B pretty-prints objects,
1873             showing their attributes and their values. B obeys the access
1874             control imposed by B on it's objects and classes, limiting
1875             it's output to attributes a caller has been granted access to see or use.
1876              
1877             B will always observe the access control mechanisms as specified
1878             by B, B, etc, and it's
1879             behaviour is not altered by the setting of I in B to be
1880             I (see B above). This is because I is designed
1881             as a mechanism to accelerate the execution of B-derived
1882             modules, not circumvent the intended access restrictions of those modules.
1883              
1884             B accepts the following optional named parameters:
1885              
1886             =over 4
1887              
1888             =item I
1889              
1890             If I is true (the default value), and none of the attribute/method type
1891             parameters (e.g. I, I, etc) have been set, then B
1892             will display all attributes the caller has access to. If any of the attribute
1893             type parameters have been set to true, then I will be ignored, and only
1894             those attribute types specified in the call to B will be displayed.
1895              
1896             =item I
1897              
1898             If I is true, then B will display only I attributes of
1899             the invocant and their values, and all other types of attributes explicitly
1900             requested in the call to B (the I parameter is ignored). If the
1901             caller doesn't have access to I methods, then B will B
1902             with an error. If no class attributes exist, and no other attributes have
1903             been requested then C is returned.
1904              
1905             =item I
1906              
1907             As with I, but displaying I attributes and their values.
1908              
1909             =item I
1910              
1911             As with I, but displaying I attributes and their values.
1912              
1913             =item I
1914              
1915             As with I, but displaying I attributes and their
1916             values. Note that I attributes can only be displayed for class
1917             instances. Requesting the B of public attributes of a class will
1918             result in B Bing with an error.
1919              
1920             =item I
1921              
1922             As with I, but displaying I attributes and their values.
1923              
1924             =item I
1925              
1926             As with I, but displaying I attributes and their values.
1927              
1928             =item I
1929              
1930             If I is true, then B will display the list of friends of
1931             the invoking class or object.
1932              
1933             =item I
1934              
1935             By default, B operates recursively, creating a dump of all
1936             requested attribute values, and their attribute values (if they themselves
1937             are objects). If I is set, then I will limit it's output
1938             to the given recursive depth. A depth of C<0> will display the target's
1939             attributes, but will not expand those attribute values.
1940              
1941             =item I
1942              
1943             I specifies the indentation used in the output of B,
1944             and defaults to C<4> spaces.
1945              
1946             =item I
1947              
1948             If I is true, the B will back-trace references
1949             if they are encountered multiple times in the generation of the
1950             B output. The back-trace is similar to the default behaviour of
1951             L, where only the first instance of a reference is shown in
1952             full, and all other occurences are displayed as a link back to the original
1953             occurrence of that reference. By default, I is true.
1954              
1955              
1956             =back
1957              
1958             If an attribute type parameter, such as I or I, is set
1959             in the call to B then this only has effect on the target object
1960             of the B call, and not any subsequent recursive calls to B
1961             used to display nested objects.
1962              
1963             =cut
1964             BEGIN {
1965              
1966             #
1967             # create helper routines that'll be passed to Class::Declare::Dump to
1968             # grant it (limited) access to the object storage of Class::Declare.
1969             #
1970            
1971             # - create a routine for returning the attribute hash of an object or
1972             # class, where the hash values are the current attribute values for
1973             # the object, or the default attribute values for the class
1974             my $__get_values__ = sub { # |
1975 207         292 my $self = shift;
1976 207         242 my $hash = undef;
1977              
1978             # make sure we have a valid object
1979             ( ref( $self )
1980 77         399 and $hash = $__OBJECTS__{ ${ $self } }
1981             # and return the reference to its hash
1982             and return $hash )
1983             # or return the default values for this class
1984 207 50 66     837 or return $__DEFN__{ $self };
      100        
1985 28     28   164 }; # $__get_values__()
1986              
1987            
1988             # - create a routine for returning the declared attributes of a given
1989             # class or object
1990             my $__get_attributes__ = sub { # |
1991 419         547 my $self = shift;
1992              
1993 419   33     2214 return $__ATTR__{ ref( $self ) || $self };
1994 28         110 }; # $__get_attributes__()
1995              
1996            
1997             # - create a routine for returning the list of friends of a given class
1998             # or object
1999             my $__get_friends__ = sub { # |
2000 559         694 my $self = shift;
2001              
2002 559   33     2870 return $__FRIEND__{ ref( $self ) || $self };
2003 28         122 }; # $__get_friends__()
2004              
2005              
2006             # register the accessor methods
2007             # - these are used in dump() and hash() to access private data used
2008             # by Class::Declare that we don't want to have accessed from outside
2009 28         73 foreach ( map { join '::' , __PACKAGE__ , $_ }
  56         262  
2010             qw( Dump Hash ) ) {
2011             # initialise the referencing for the hash() and dump() routines
2012 56         313 $_->__init__( $__get_attributes__
2013             , $__get_values__
2014             , $__get_friends__
2015             );
2016             }
2017             }
2018              
2019              
2020             =item B [ I => I ] B<)>
2021              
2022             Return a hash representing the values of the attributes of the class or object
2023             (depending on how B is called. B supports the same calling
2024             parameters as B, except for C and C).
2025             B observes normal access control, only returning attributes that the
2026             caller would normally have access to. C attributes are returned with
2027             a value of C.
2028              
2029             If called in a list context, B will return a hash, otherwise a hash
2030             reference is returned.
2031              
2032             B As of v0.10, B supports the I parameter, and will,
2033             by default, recurse to generate a hash of the entire object tree (if derived
2034             from B). If I is set, then I will limit it's
2035             output to the given recursive depth. A depth of C<0> will display the target's
2036             attributes, but will not expand those attribute values. B will descend
2037             C and C references if asked to recurse.
2038              
2039             =cut
2040              
2041              
2042             } # end Class admin closure
2043              
2044              
2045             =item B I => I B<)>
2046              
2047             A class helper method for handling named argument lists. In Perl, named
2048             argument lists are supported by coercing a list into a hash by assuming
2049             a key/value pairing. For example, named arguments may be implemented as
2050              
2051             sub mysub {
2052             my %args = @_;
2053             ...
2054             }
2055              
2056             and called as
2057              
2058             mysub( name => 'John' , age => 34 );
2059              
2060             C<%args> is now the hash with keys C and C and corresponding
2061             values C<'John'> and C<34> respectively.
2062              
2063             So if named arguments are so easy to implement, why go to the trouble of
2064             calling B? To make your code more robust. The above example
2065             failed to test whether there was an even number of elements in the argument
2066             list (needed to flatten the list into a hash), and it made no checks to
2067             ensure the supplied arguments were expected. Does C really want
2068             a name and age, or does it want some other piece of information?
2069              
2070             B ensures the argument list can be safely flattened into a
2071             hash, and raises an error indicating the point at which the original method
2072             was called if it can't. Also, it ensures the arguments passed in are those
2073             expected by the method. Note that this does not check the argument values
2074             themselves, but merely ensures unknown named arguments are flagged as errors.
2075              
2076             B also enables you to define default values for your
2077             arguments. These values will be assigned when a named argument is not
2078             supplied in the list of arguments.
2079              
2080             The calling convention of B is as follows (note, we assume
2081             here that the method is in a B-derived class):
2082              
2083             sub mysub {
2084             ...
2085             my %args = $self->arguments( \@_ => { name => 'Guest user' ,
2086             age => undef } );
2087             ...
2088             }
2089              
2090             Here, C will accept two arguments, C and C, where
2091             the default value for C is C<'Guest user'>, while C defaults
2092             to C.
2093              
2094             Alternatively, B may be called in either of the following ways:
2095              
2096             my %args = $self->arguments( \@_ => [ qw( name age ) ] );
2097              
2098             or
2099              
2100             my %args = $self->arguments( \@_ => 'name' );
2101              
2102             Here, the default argument values are C, and in the second example,
2103             only the the single argument I will be recognized.
2104              
2105             If I is not given (or is undef), then B will simply
2106             flatten the argument list into a hash and assume that all named arguments
2107             are valid. If I is the empty hash (i.e. C<{}>), then no named
2108             arguments will be accepted.
2109              
2110             If called in a list context, B returns the argument hash, while
2111             if called in a scalar context, B will return a reference to
2112             the hash. B may be called as either a class or instance method.
2113              
2114             =cut
2115             sub arguments
2116             {
2117 655     655 1 4300 my $self = __PACKAGE__->class( shift );
2118              
2119             # if we have no arguments then we should return undef
2120 655 100       1684 return undef unless ( @_ );
2121              
2122             # extract the argument list and the default arguments
2123 653         1036 my $args = shift;
2124 653         1950 my $default = shift;
2125              
2126             # make sure the first argument is a reference to an array
2127             ( ref( $args ) && ref( $args ) eq 'ARRAY' )
2128 653 100 100     2909 or do {
2129 4         11 my ( undef , $file , $line , $sub ) = caller 0;
2130              
2131 4         161 die "Array reference expected in call to "
2132             . "$sub() at $file line $line\n";
2133             };
2134              
2135             # to make a hash we need to ensure we have an even number of
2136             # arguments
2137 649         1682 ( scalar( @{ $args } ) % 2 )
2138 649 100       700 and do {
2139 1         4 my ( undef , $file , $line , $sub ) = caller 1;
2140              
2141 1         89 die "Odd number of arguments to $sub() at $file line $line\n";
2142             };
2143              
2144             # convert the argument list into a hash
2145 648         813 $args = { @{ $args } };
  648         1602  
2146              
2147             # if there is a set of default arguments defined, then make sure
2148             # the given arguments conform, otherwise, if there are no default
2149             # arguments, accept whatever we're given
2150 648 100       1372 if ( defined $default ) {
2151             # the default arguments should either be a single argument name
2152 646 100       1304 $default = { $default => undef } unless ( ref $default );
2153             # or a list of argument names, where the default values are undef
2154 646 100       1416 $default = { map { $_ => undef } @{ $default } }
  2323         4407  
  213         379  
2155             if ( ref( $default ) eq 'ARRAY' );
2156              
2157             # make sure default is a hash reference
2158             ( ref( $default ) eq 'HASH' )
2159 646 100       1759 or do {
2160 2         6 my ( undef , $file , $line , $sub ) = caller 0;
2161              
2162 2         78 die "Unrecognized default arguments $default at "
2163             . "$sub() file $file line $line\n";
2164             };
2165              
2166             # make sure there are no keys in the given argument list that
2167             # are not defined in the default argument list
2168 644         709 foreach ( keys %{ $args } ) {
  644         1889  
2169 665 100       1757 next if ( exists $default->{ $_ } );
2170              
2171             # key doesn't exist, so die with an error
2172 12         32 my ( undef , $file , $line , $sub ) = caller 1;
2173              
2174 12         648 die "Unknown parameter '$_' used in call to $sub() "
2175             . "at $file line $line\n";
2176             }
2177              
2178             # for each default argument that isn't declared in the given
2179             # argument list, add it to the called argument list
2180             $args->{ $_ } = $default->{ $_ }
2181 632         837 foreach ( grep { ! exists $args->{ $_ } } keys %{ $default } );
  3918         9213  
  632         1622  
2182             }
2183              
2184             # return the argument hash
2185 634 100       2175 return ( wantarray ) ? %{ $args } : $args;
  299         1002  
2186             } # arguments()
2187              
2188              
2189             =item BB<)>
2190              
2191             Extract the revision number from CVS revision strings. B looks
2192             for the package variable C<$REVISION> for a valid CVS revision strings, and
2193             if found, will return the revision number from the string. If $REVISION is
2194             not defined, or does not contain a CVS revision string, then B
2195             returns C.
2196              
2197             package My::Class;
2198              
2199             use strict;
2200             use base qw( Class::Declare );
2201             use vars qw( $REVISION );
2202             $REVISION = '$Revision: 1518 $';
2203              
2204             ...
2205              
2206             1;
2207              
2208              
2209             print My::Class->REVISION; # prints the revision number
2210              
2211             =cut
2212             sub REVISION
2213             {
2214 10     10 1 23 my $self = __PACKAGE__->class( shift );
2215              
2216             # try to find the revision string
2217 10         13 my $revision = undef;
2218             {
2219 10         10 local $@;
  10         13  
2220 10         18 eval {
2221 28     28   2584 no strict 'refs';
  28         72  
  28         12920  
2222              
2223 10         9 $revision = ${ $self . '::REVISION' };
  10         38  
2224             };
2225             }
2226              
2227             # if there's no revision string, then return undef
2228 10 100       26 return undef unless ( $revision );
2229              
2230             # OK, now attempt to extract the revision number from the string
2231             # - because we don't want to expose ourselves to CVS keyword
2232             # expansion, we need to construct our target pattern
2233 7         10 my $target = ucfirst( 'revision' );
2234 7 50       50 return undef unless ( $revision =~ m#\$$target:\s*(\S+)\s*\$#o );
2235              
2236             # extract the revision number
2237 7         16 $revision = $1;
2238             # make sure the revision number starts with a digit
2239 7 50       31 $revision = undef unless ( $revision =~ m#^\d#o );
2240              
2241             # return the revision number
2242 7         23 return $revision;
2243             } # REVISION()
2244              
2245              
2246             =item B [ I ] B<)>
2247              
2248             Replacement for B, that falls back to B
2249             to report the CVS revision number as the version number if the package
2250             variable C<$VERSION> is not defined. If I is given, then
2251             B will die if the I version is not less than or equal
2252             to the current package version (or revision, if B falls back to
2253             B). B will die if I is not a valid version
2254             string.
2255              
2256             =cut
2257             sub VERSION(;$)
2258             {
2259 12     12 1 170 my $self = __PACKAGE__->class( shift );
2260              
2261             # extract the package version (if it exists)
2262             # - fallback to the REVISION if there's no version
2263 12         67 my $version = $self->SUPER::VERSION;
2264 12 100       40 $version = $self->REVISION if ( ! defined $version );
2265 12 100       71 $version = version->parse( $version ) if ( defined $version );
2266              
2267             # have we been given a required version?
2268 12 100       30 if ( defined $_[0] ) {
2269             # where have we been called from?
2270             # - we use this to ensure any die() message correctly reflects the
2271             # location of the cause of the failure
2272 8   33     29 my $class = ref( $self ) || $self;
2273 8         26 my ( undef , $file , $line ) = caller 0;
2274              
2275             # do we have version for this pacakge?
2276             # - if we don't, then we cannot support the required version
2277 8 100       271 ( defined $version )
2278             or die $class . ' does not define $' . $class . '::VERSION' .
2279             "--version check failed at $file line $line\n";
2280              
2281             # attempt to parse the required version
2282 7         10 my $required = eval { version->parse( $_[0] ) };
  7         62  
2283 7 100       18 if ( $@ ) {
2284 1         10 my $msg = ( $@ =~ /(.*) at \S+ line \d+/ )[0];
2285              
2286             # terminate with an appropriate error message
2287             # - we ensure the report the line with the bad version
2288 1         12 die $msg . " at " . $file . " line " . $line . "\n";
2289             }
2290              
2291             # is the package version/revision as required?
2292 6 100       72 ( $required <= $version )
2293             or die "$class version $required required--this is only version $version "
2294             . "at $file line $line\n";
2295             }
2296              
2297             # return the package version
2298 8 100       65 return ( defined $version ) ? $version->stringify() : undef;
2299             } # VERSION()
2300              
2301              
2302             =item B I B<)>
2303              
2304             If this class directly implements the given I(), then return a
2305             reference to this method. Otherwise, return false. This is similar to
2306             BB, which will return a reference if this class either
2307             directly implements I(), or inherits it.
2308              
2309             =cut
2310             sub has
2311             {
2312 784     784 1 1826 my $self = __PACKAGE__->class( shift );
2313             # if there's no method name, then raise an error
2314             my $method = shift
2315 784 50       1756 or do {
2316             # find out where we were called from
2317 0         0 my ( undef , $file , $line ) = caller;
2318              
2319 0         0 die "no method name supplied in call to has() "
2320             . "at $file line $line\n";
2321             };
2322              
2323             # extract the symbol table entry for this method
2324             {
2325 28     28   154 no strict 'refs';
  28         47  
  28         5193  
  784         846  
2326 784         1957 local $^W = 0; # suppress warnings
2327              
2328 784   66     2658 my $class = ref( $self ) || $self;
2329 784         813 return *{ $class . '::'. $method }{ CODE };
  784         5109  
2330             }
2331             } # has()
2332              
2333              
2334             =item BB<)>
2335              
2336             If this class is operating with strict access checking (i.e. I from
2337             B was not explicitly set to false in this class or one of its
2338             parent classes) then B will return true, otherwise return false.
2339              
2340             =cut
2341             sub strict
2342             {
2343 20     20 1 64 my $self = __PACKAGE__->class( shift );
2344 20   66     59 my $class = ref( $self ) || $self;
2345              
2346             # we test to see whether the class() method accessed through this class is
2347             # the same method provided by Class::Declare
2348 20         120 my $mine = $class->can( 'class' );
2349 20         86 my $original = __PACKAGE__->can( 'class' );
2350              
2351             # if these are the same, then we have strict checking in place
2352 20         103 return ( $mine == $original );
2353             } # strict()
2354              
2355              
2356             =back
2357              
2358              
2359             =head1 CAVEAT
2360              
2361             B has been designed to be thread-safe, and as such is
2362             suitable for such environments as C. However, it has not been
2363             proven to be thread-safe. If you are coding in a threaded environment, and
2364             experience problems with B's behaviour, please let me know.
2365              
2366              
2367             =head1 BUGS
2368              
2369             The name. I don't really like B as a name, but I can't
2370             think of anything more appropriate. I guess it really doesn't matter too
2371             much. Suggestions welcome.
2372              
2373             Apart from the name, B has no known bugs. That is not to
2374             say the bugs don't exist, rather they haven't been found. The testing for
2375             this module has been quite extensive (there are over 3000 test cases in
2376             the module's test suite), but patches are always welcome if you discover
2377             any problems.
2378              
2379              
2380             =head1 SEE ALSO
2381              
2382             L, L, L,
2383             L, L, L.
2384              
2385              
2386             =head1 AUTHOR
2387              
2388             Ian Brayshaw, Eian@onemore.orgE
2389              
2390              
2391             =head1 COPYRIGHT AND LICENSE
2392              
2393             Copyright 2003-2010 Ian Brayshaw. All rights reserved.
2394              
2395             This library is free software; you can redistribute it and/or modify
2396             it under the same terms as Perl itself.
2397              
2398             =cut
2399              
2400             ############################################################################
2401             1; # end of module
2402             __END__