File Coverage

blib/lib/constant/Atom.pm
Criterion Covered Total %
statement 48 49 97.9
branch 6 8 75.0
condition 5 6 83.3
subroutine 15 16 93.7
pod 2 7 28.5
total 76 86 88.3


line stmt bran cond sub pod time code
1             package constant::Atom;
2             $constant::Atom::VERSION = '0.10';
3 2     2   24528 use 5.006;
  2         7  
  2         79  
4 2     2   10 use strict;
  2         4  
  2         65  
5 2     2   10 use warnings;
  2         9  
  2         50  
6              
7 2     2   10 use Carp;
  2         12  
  2         565  
8             sub new {
9 8     8 0 634 my($pkg, $client_package, $name) = @_;
10              
11 8 100 66     313 croak if not defined $name or not defined $client_package;
12 6         13 my $string = $client_package."::".$name;
13 6         18 my $self = bless \$string, $pkg;
14 6         13 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   961 my($a, $b, $c, $operator) = @_;
29 1         20 my $class = ref($a);
30 1         110 croak "The '$operator' operation isn't defined for $class objects";
31             },
32 2         27 '""' => 'tostring'
33 2     2   4228 ;
  2         2475  
34              
35             sub tostring {
36 2     2 0 6 my($self) = @_;
37              
38 2 100       9 if (not defined $self) {
39 1         130 croak "tostring should be called on an atom";
40             }
41 1         6 return overload::StrVal($self).'='.$$self;
42             }
43              
44             sub equals {
45 3 50   3 0 2224 ref($_[1]) eq ref($_[0]) and ${$_[0]} eq ${$_[1]}
  3         9  
  3         28  
46             };
47              
48             sub notequals {
49 4   100 4 0 2534 not (ref($_[1]) eq ref($_[0]) and ${$_[0]} eq ${$_[1]})
50             };
51              
52             sub name {
53 1     1 1 411 my($self) = @_;
54 1         6 my @parts = split /\:\:/, $$self;
55 1         6 return $parts[-1];
56             }
57              
58             sub fullname {
59 1     1 1 3 my($self) = @_;
60 1         5 return $$self;
61             }
62              
63              
64             sub make_identifier {
65 6     6 0 11 my($pkg, $client_package, $name) = @_;
66 6         19 my $id = $pkg->new($client_package, $name);
67              
68 2     2   1025 no strict 'refs';
  2         4  
  2         301  
69              
70 6         12 my $full_name = $client_package."::".$name;
71              
72 6     0   2392 *$full_name = sub () { $id; };
  0         0  
73             }
74              
75             sub import {
76 4     4   15414 my($pkg, @names) = @_;
77              
78 4 50       18 return unless $pkg; # Ignore 'use constant;'
79              
80 4         8 my $client_package = caller(0);
81 4         2060 for (@names) {
82 6         20 $pkg->make_identifier($client_package, $_);
83             }
84             }
85              
86              
87             1;
88              
89             __END__