File Coverage

lib/Badger/Class/Vars.pm
Criterion Covered Total %
statement 32 33 96.9
branch 27 34 79.4
condition 3 4 75.0
subroutine 5 5 100.0
pod 2 2 100.0
total 69 78 88.4


line stmt bran cond sub pod time code
1             #========================================================================
2             #
3             # Badger::Class::Vars
4             #
5             # DESCRIPTION
6             # Class mixin module for adding package variables to a class.
7             #
8             # AUTHOR
9             # Andy Wardley
10             #
11             #========================================================================
12              
13             package Badger::Class::Vars;
14              
15 3     3   824 use Badger::Debug ':dump';
  3         7  
  3         28  
16             use Badger::Class
17 3         33 version => 0.01,
18             debug => 0,
19             base => 'Badger::Base Badger::Exporter',
20             import => 'BCLASS',
21             constants => 'DELIMITER SCALAR ARRAY HASH REFS PKG',
22             utils => 'is_object',
23             messages => {
24             no_target => 'No target class specified to generate variables for',
25             no_vars => 'No vars specified to define',
26             bad_vars => 'Invalid vars specified: %s',
27             bad_var => 'Invalid variable name in vars: %s',
28             bad_hash => 'Invalid hash variable for %s in vars: %s',
29             bad_sigil => 'Unrecognised sigil for symbol: %s',
30 3     3   19 };
  3         12  
31              
32            
33             sub export {
34 6 100   6 1 47 goto &vars if @_ > 2;
35             }
36              
37              
38             sub vars {
39 9     9 1 16 my $class = shift;
40 9   50     19 my $target = shift || return $class->error_msg('no_target');
41 9 100       24 my $vars = @_ == 1 ? shift : { @_ };
42 9         11 my ($symbol, $sigil, $name, $dest, $ref);
43              
44             # downgrade $target from a Badger::Class object to a package name
45 9 50       22 $target = $target->name
46             if is_object(BCLASS, $target);
47              
48             # split text string into lisy ref of variable names
49 9 100       37 $vars = [ split(DELIMITER, $vars) ]
50             unless ref $vars;
51              
52             # upgrade a list ref to a hash ref
53 9 100       25 $vars = { map { $_ => undef } @$vars }
  9         21  
54             if ref $vars eq ARRAY;
55              
56 9 50       20 $class->error_msg( bad_vars => $vars )
57             unless ref $vars eq HASH;
58              
59 9 50       21 $class->error_msg('no_vars')
60             unless %$vars;
61              
62 9         10 $class->debug("Defining vars for $target: ", $class->dump_data($vars))
63             if DEBUG;
64              
65             # This is a slightly simplified (stricter) version of the equivalent
66             # code in vars.pm with a little extra syntactic sugar supported.
67             # Unfortunately it's not possible to delegate to vars.pm because
68             # it will only export to its caller, and not to a third party package
69            
70 9         35 while (($symbol, $ref) = each %$vars) {
71 3     3   22 no strict REFS;
  3         7  
  3         989  
72              
73             # only accept: $WORD @WORD %WORD WORD
74 37 50       149 $symbol =~ /^([\$\@\%])?(\w+)$/
75             || return $class->error_msg( bad_var => $symbol );
76 37   100     120 ($sigil, $name) = ($1 || '$', $2);
77            
78             # expand destination to full package name ($Your::Module::WORD)
79 37         59 $dest = $target.PKG.$name;
80              
81 37         34 $class->debug("var: $sigil$name => ", $ref || '\\'.$sigil.$dest, "\n")
82             if DEBUG;
83            
84 37 100       62 if ($sigil eq '$') {
    100          
    50          
85             *$dest = defined $ref
86 22 50       60 ? (ref $ref eq SCALAR ? $ref : do { my $copy = $ref; \$copy })
  19 100       21  
  19         144  
87             : \$$dest;
88             }
89             elsif ($sigil eq '@') {
90 8 100       183 *$dest = defined $ref
    100          
91             ? (ref $ref eq ARRAY ? $ref : [$ref])
92             : \@$dest;
93             }
94             elsif ($sigil eq '%') {
95 7 50       45 *$dest = defined $ref
    100          
96             ? (ref $ref eq HASH
97             ? $ref
98             : return $class->error_msg( bad_hash => $symbol, $ref )
99             )
100             : \%$dest;
101             }
102             else {
103             # should never happen
104 0           return $class->error_msg( bad_sigil => $symbol );
105             }
106             }
107             }
108              
109             1;
110              
111             __END__