File Coverage

blib/lib/constant/Atom.pm
Criterion Covered Total %
statement 47 48 97.9
branch 6 8 75.0
condition 6 6 100.0
subroutine 15 16 93.7
pod 2 7 28.5
total 76 85 89.4


line stmt bran cond sub pod time code
1             package constant::Atom;
2             $constant::Atom::VERSION = '0.11';
3 2     2   72937 use 5.006;
  2         8  
4 2     2   11 use strict;
  2         2  
  2         39  
5 2     2   9 use warnings;
  2         3  
  2         46  
6              
7 2     2   9 use Carp;
  2         4  
  2         600  
8             sub new {
9 8     8 0 981 my($pkg, $client_package, $name) = @_;
10              
11 8 100 100     319 croak if not defined $name or not defined $client_package;
12 6         14 my $string = $client_package."::".$name;
13 6         10 my $self = bless \$string, $pkg;
14 6         12 return $self;
15             }
16              
17             use overload
18             '==' => 'equals',
19             'eq' => 'equals',
20             '!=' => 'notequals',
21             'ne' => 'notequals',
22              
23             #I've decided that both numeric and string equality operators should be allowed.
24             # '==' => sub {my $class = ref(shift); croak "'==' operator isn't defined for $class objects. Did you mean 'eq'?"},
25             # '!=' => sub {my $class = ref(shift); croak "'!=' operator isn't defined for $class objects. Did you mean 'ne'?"},
26              
27             nomethod => sub {
28 1     1   848 my($a, $b, $c, $operator) = @_;
29 1         3 my $class = ref($a);
30 1         78 croak "The '$operator' operation isn't defined for $class objects";
31             },
32 2         19 '""' => 'tostring'
33 2     2   2574 ;
  2         2126  
34              
35             sub tostring {
36 2     2 0 8 my($self) = @_;
37              
38 2 100       9 if (not defined $self) {
39 1         76 croak "tostring should be called on an atom";
40             }
41 1         4 return overload::StrVal($self).'='.$$self;
42             }
43              
44             sub equals {
45 3 50   3 0 2602 ref($_[1]) eq ref($_[0]) and ${$_[0]} eq ${$_[1]}
  3         7  
  3         33  
46             };
47              
48             sub notequals {
49 4   100 4 0 2440 not (ref($_[1]) eq ref($_[0]) and ${$_[0]} eq ${$_[1]})
50             };
51              
52             sub name {
53 1     1 1 305 my($self) = @_;
54 1         6 my @parts = split /\:\:/, $$self;
55 1         7 return $parts[-1];
56             }
57              
58             sub fullname {
59 1     1 1 4 my($self) = @_;
60 1         4 return $$self;
61             }
62              
63              
64             sub make_identifier {
65 6     6 0 12 my($pkg, $client_package, $name) = @_;
66 6         13 my $id = $pkg->new($client_package, $name);
67              
68 2     2   820 no strict 'refs';
  2         4  
  2         288  
69              
70 6         13 my $full_name = $client_package."::".$name;
71              
72 6     0   1880 *$full_name = sub () { $id; };
  0         0  
73             }
74              
75             sub import {
76 4     4   12702 my($pkg, @names) = @_;
77              
78 4 50       18 return unless $pkg; # Ignore 'use constant;'
79              
80 4         9 my $client_package = caller(0);
81 4         1403 for (@names) {
82 6         16 $pkg->make_identifier($client_package, $_);
83             }
84             }
85              
86              
87             1;
88              
89             __END__