File Coverage

blib/lib/ex/constant/vars.pm
Criterion Covered Total %
statement 99 99 100.0
branch 14 16 87.5
condition 2 3 66.6
subroutine 29 29 100.0
pod 1 3 33.3
total 145 150 96.6


line stmt bran cond sub pod time code
1             package ex::constant::vars;
2              
3 4     4   99876 use 5.006;
  4         15  
  4         143  
4 4     4   20 use strict;
  4         6  
  4         130  
5 4     4   24 use warnings;
  4         11  
  4         184  
6 4     4   21 use Carp;
  4         5  
  4         2303  
7              
8             require Exporter;
9              
10             our $VERSION = '0.05';
11              
12             our @ISA = qw(
13             Exporter
14             ex::constant::vars::scalar
15             ex::constant::vars::array
16             ex::constant::vars::hash
17             );
18             our @EXPORT_OK = qw( const SCALAR ARRAY HASH );
19              
20             sub const {
21 14     14 1 20 my $type = shift;
22 14         40 my @values = splice @_, 1;
23 14 100       57 if ( $type eq 'scalar' ) {
    100          
24 4         5 return tie ${$_[0]}, __PACKAGE__ . '::' . $type, @values;
  4         25  
25             } elsif ( $type eq 'array' ) {
26 5         8 return tie @{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  5         137  
27             } else {
28 5         9 return tie %{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  5         29  
29             }
30             }
31              
32 4     4   22 sub SCALAR (\$$) { 'scalar', @_ }
33 5     5 0 438 sub ARRAY (\@@) { 'array', @_ }
34 5     5 0 23 sub HASH (\%%) { 'hash', @_ }
35              
36             sub import {
37 6     6   51 my $self = shift;
38 6 100       2246 return unless @_;
39 4 100 66     30 if ( @_ == 1 && $_[0] eq 'const' ) {
40 2         3881 $self->export_to_level( 1, $self, @EXPORT_OK );
41             } else {
42 2         12 my %variables = @_;
43 2         4 my $caller = caller( 0 );
44 2         14 while ( my( $var, $val ) = each %variables ) {
45 7         17 my( $prefix, $name ) = split //, $var, 2;
46 7 50       28 croak "'$var' not a valid variable name" unless $prefix =~ /^[\$\@\%]$/;
47 7 100       23 if ( $prefix eq '$' ) {
    100          
    50          
48 4     4   22 no strict 'refs';
  4         7  
  4         611  
49 2         3 *{__PACKAGE__ . "::variables::$name"} = \$val;
  2         15  
50 2         4 *{"${caller}::$name"} = \${__PACKAGE__ . "::variables::$name"};
  2         6  
  2         8  
51 2         4 const SCALAR ${"${caller}::$name"}, $val;
  2         6  
52             } elsif ( $prefix eq '@' ) {
53 4     4   21 no strict 'refs';
  4         7  
  4         604  
54 2         3 *{__PACKAGE__ . "::variables::$name"} = \@{$val};
  2         9  
  2         2  
55 2         3 *{"${caller}::$name"} = \@{__PACKAGE__ . "::variables::$name"};
  2         6  
  2         5  
56 2         2 const ARRAY @{"${caller}::$name"}, @{$val};
  2         3  
  2         6  
57             } elsif ( $prefix eq '%' ) {
58 4     4   20 no strict 'refs';
  4         5  
  4         524  
59 3         3 *{__PACKAGE__ . "::variables::$name"} = \%{$val};
  3         17  
  3         6  
60 3         6 *{"${caller}::$name"} = \%{__PACKAGE__ . "::variables::$name"};
  3         11  
  3         8  
61 3         3 const HASH %{"${caller}::$name"}, %{$val};
  3         7  
  3         9  
62             }
63             }
64             }
65             }
66              
67              
68             package ex::constant::vars::scalar;
69 4     4   63 use Carp;
  4         8  
  4         606  
70             $Carp::CarpLevel = 1;
71 7     7   519 sub TIESCALAR { shift; bless \(my $scalar = shift), __PACKAGE__ }
  7         54  
72 15     15   2950 sub FETCH { ${$_[0]} }
  15         82  
73 8     8   1730 sub STORE { croak "Modification of a read-only value attempted" }
74              
75              
76             package ex::constant::vars::array;
77 4     4   91 use Carp;
  4         4  
  4         868  
78             $Carp::CarpLevel = 1;
79 7     7   14 sub TIEARRAY { shift; bless $_=\@_, __PACKAGE__ }
  7         50  
80 38     38   456 sub FETCH { $_[0]->[$_[1]] }
81 15     15   3633 sub FETCHSIZE { @{$_[0]} }
  15         70  
82 1     1   260 sub EXISTS { exists $_[0]->[$_[1]] }
83 13     13   2499 sub STORE { croak "Modification of a read-only value attempted" }
84             *CLEAR = *EXTEND = *POP = *PUSH = *SHIFT =
85             *UNSHIFT = *SPLICE = *STORESIZE = *DELETE = \*STORE;
86              
87              
88             package ex::constant::vars::hash;
89 4     4   55 use Carp;
  4         7  
  4         1079  
90             $Carp::CarpLevel = 1;
91 7     7   4686 sub TIEHASH { bless {@_[1...$#_]}, __PACKAGE__ }
92 56     56   563 sub FETCH { $_[0]->{$_[1]} }
93 19     19   4521 sub FIRSTKEY { keys %{$_[0]}; each %{$_[0]} }
  19         50  
  19         25  
  19         70  
94 56     56   63 sub NEXTKEY { each %{$_[0]} }
  56         150  
95 1     1   11 sub EXISTS { exists $_[0]->{$_[1]} }
96 15     15   3250 sub STORE { croak "Modification of a read-only value attempted" }
97             *CLEAR = *DELETE = \*STORE;
98              
99             1;
100              
101             __END__