File Coverage

blib/lib/Data/SExpression/Symbol.pm
Criterion Covered Total %
statement 38 39 97.4
branch 10 12 83.3
condition 4 6 66.6
subroutine 10 10 100.0
pod 2 5 40.0
total 64 72 88.8


line stmt bran cond sub pod time code
1 9     9   25910 use warnings;
  9         16  
  9         315  
2 9     9   63 use strict;
  9         16  
  9         429  
3              
4             =head1 NAME
5              
6             Data::SExpression::Symbol -- A Lisp symbol read by Data::SExpression
7              
8             =head1 DESCRIPTION
9              
10             A Data::SExpression::Symbol represents a lisp symbol. Symbols are
11             usually used as opaque objects that can be compared with each other,
12             but are not intended to be used for other operations.
13              
14             There are two kinds of symbols, C, and C. Most
15             symbols are C. There is only ever one C instance
16             of the C class for a given name.
17              
18             =head1 STRINGIFICATION AND COMPARISON
19              
20             Interned symbols stringify to their ->name. Uninterned symbols
21             stringify to "#:$name", after the Common Lisp convention.
22              
23             Interned symbols are eq to their name. Uninterned symbols are not eq
24             to anything except themself.
25              
26             =cut
27              
28             package Data::SExpression::Symbol;
29 9     9   43 use base qw(Class::Accessor::Fast);
  9         16  
  9         1614  
30             __PACKAGE__->mk_ro_accessors(qw(interned name));
31              
32 9     9   3270 use Scalar::Util qw(blessed refaddr);
  9         16  
  9         844  
33              
34 9         118 use overload q{""} => \&stringify,
35             eq => \&equal,
36             ne => \¬_equal,
37 9     9   7568 fallback => 1;
  9         4580  
38              
39             our %INTERN;
40              
41             =head2 new NAME
42              
43             Returns a new interned symbol with the given NAME
44              
45             =cut
46              
47             sub new {
48 3     3 1 946 my $class = shift;
49 3         6 my $name = shift;
50 3 100       14 return $INTERN{$name} if $INTERN{$name};
51 2         9 my $self = {
52             interned => 1,
53             name => $name
54             };
55              
56 2         5 bless($self, $class);
57 2         6 $INTERN{$name} = $self;
58 2         6 return $self;
59             }
60              
61             =head2 uninterned NAME
62              
63             Returns a new uninterned symbol with the given NAME
64              
65             =cut
66              
67             sub uninterned {
68 2     2 1 493 my $class = shift;
69 2         4 my $name = shift;
70 2         15 return bless({interned => 0, name => $name}, $class);
71             }
72              
73             =head2 name
74              
75             Returns the symbol's name, as passed to C or C.
76              
77             =head2 interned
78              
79             Returned true iff the symbol is interned
80              
81             =cut
82              
83             sub stringify {
84 5     5 0 1664 my $self = shift;
85 5 100       16 return ($self->interned ? "" : "#:") . $self->name;
86             }
87              
88             sub equal {
89 7     7 0 1007 my $self = shift;
90 7         11 my $other = shift;
91 7 100       19 if(!$self->interned) {
92 5   100     78 return blessed($other) && refaddr($self) == refaddr($other);
93             } else {
94 2 100       22 if(!ref($other)) {
    50          
95 1         4 return $self->name eq $other;
96             } elsif(blessed($other)) {
97 1 50       9 if($other->isa(__PACKAGE__)) {
98 1   33     5 return $other->interned && ($self->name eq $other->name);
99             }
100             }
101             }
102 0         0 return;
103             }
104              
105             sub not_equal {
106 4     4 0 559 my $self = shift;
107 4         8 my $other = shift;
108 4         10 return !$self->equal($other);
109             }
110              
111             =head1 SEE ALSO
112              
113             L
114              
115             =head1 AUTHOR
116              
117             Nelson Elhage
118              
119             =cut
120              
121             1;