File Coverage

blib/lib/Class/ExtraAttributes.pm
Criterion Covered Total %
statement 27 27 100.0
branch 12 12 100.0
condition 2 2 100.0
subroutine 7 7 100.0
pod 1 1 100.0
total 49 49 100.0


line stmt bran cond sub pod time code
1             package Class::ExtraAttributes;
2              
3             # version
4             $VERSION= '0.04';
5              
6             # be as strict and verbose as possible
7 2     2   1927 use strict;
  2         3  
  2         48  
8 2     2   9 use warnings;
  2         4  
  2         47  
9              
10             # modules that we need
11 2     2   938 use OOB qw( OOB_get OOB_set );
  2         7215  
  2         24  
12              
13             # additionals attributes per class
14             my %attributes;
15              
16             # satisfy -require-
17             1;
18              
19             #-------------------------------------------------------------------------------
20             #
21             # Class Methods
22             #
23             #-------------------------------------------------------------------------------
24             # attributes
25             #
26             # Return the extra attributes for the given class
27             #
28             # IN: 1 Class::ExtraAttributes (ignored)
29             # 2 class to return extra attributes of (optional)
30             # OUT: 1 list (or list ref) with extra attributes
31              
32             sub attributes {
33             # fetch attributes
34 3 100   3 1 1984 my @attributes= keys %{ $attributes{ $_[1] ? $_[1] : caller() } || {} };
  3 100       18  
35              
36 3 100       10 return wantarray ? @attributes : \@attributes;
37             } #attributes
38              
39             #-------------------------------------------------------------------------------
40             #
41             # Standard Perl features
42             #
43             #-------------------------------------------------------------------------------
44             # import
45             #
46             # Export any constants requested
47             #
48             # IN: 1 class (ignored)
49             # 2..N attributes to be defined
50              
51             sub import {
52 3     3   482 my $class= shift;
53              
54             # nothing to export
55 3 100       15 return if !@_;
56              
57             # determine namespace to export to
58 2         4 my $namespace= caller();
59 2   100     8 my $attributes= $attributes{$namespace} ||= {};
60              
61             # create accessor / mutator for given attributes
62 2     2   246 no strict 'refs';
  2         4  
  2         266  
63 2         4 foreach my $method ( grep { !exists $attributes->{$_} } @_ ) {
  2         7  
64              
65             # make sure we don't cloak anything
66 2 100       16 die "Can already do '$method' on class $namespace"
67             if $namespace->can($method);
68              
69             # install accessor / mutator
70 1         3 $attributes->{$method}= undef;
71 1         4 *{ $namespace . '::' . $method }= sub {
72 2 100   2   569 return @_ == 2
73             ? OOB_set( $_[0], $method => $_[1], $namespace )
74             : OOB_get( $_[0], $method, $namespace );
75 1         3 };
76             }
77              
78 1         3 return;
79             } #import
80              
81             #-------------------------------------------------------------------------------
82              
83             __END__