File Coverage

blib/lib/RDF/Query/Node/Literal.pm
Criterion Covered Total %
statement 119 171 69.5
branch 41 80 51.2
condition 21 52 40.3
subroutine 25 29 86.2
pod 7 7 100.0
total 213 339 62.8


line stmt bran cond sub pod time code
1             # RDF::Query::Node::Literal
2             # -----------------------------------------------------------------------------
3              
4             =head1 NAME
5              
6             RDF::Query::Node::Literal - RDF Node class for literals
7              
8             =head1 VERSION
9              
10             This document describes RDF::Query::Node::Literal version 2.915_01.
11              
12             =cut
13              
14             package RDF::Query::Node::Literal;
15              
16 36     36   180 use strict;
  36         70  
  36         895  
17 36     36   175 use warnings;
  36         66  
  36         910  
18 36     36   177 no warnings 'redefine';
  36         65  
  36         1147  
19 36     36   171 use base qw(RDF::Query::Node RDF::Trine::Node::Literal);
  36         71  
  36         3589  
20              
21 36     36   2839 use DateTime;
  36         285449  
  36         918  
22 36     36   1736 use DateTime::Format::W3CDTF;
  36         1755  
  36         929  
23 36     36   1256 use RDF::Query::Error;
  36         70  
  36         319  
24 36     36   1828 use Data::Dumper;
  36         75  
  36         1534  
25 36     36   2831 use Log::Log4perl;
  36         106954  
  36         275  
26 36     36   1811 use Scalar::Util qw(blessed refaddr looks_like_number);
  36         77  
  36         2167  
27 36     36   175 use Carp qw(carp croak confess);
  36         71  
  36         2686  
28              
29             ######################################################################
30              
31             our ($VERSION, $LAZY_COMPARISONS);
32             BEGIN {
33 36     36   6987 $VERSION = '2.915_01';
34             }
35              
36             ######################################################################
37              
38             use overload '<=>' => \&_cmp,
39             'cmp' => \&_cmp,
40 30     30   536 '<' => sub { _cmp(@_[0,1], '<') == -1 },
41 24     24   805 '>' => sub { _cmp(@_[0,1], '>') == 1 },
42 1     1   365 '!=' => sub { _cmp(@_[0,1], '!=') != 0 },
43 47     47   1312 '==' => sub { _cmp(@_[0,1], '==') == 0 },
44 0     0   0 '+' => sub { $_[0] },
45 903     903   41961 '""' => sub { $_[0]->sse },
46 36     36   200 ;
  36         78  
  36         617  
47              
48             my %INSIDE_OUT_DATES;
49              
50             =head1 METHODS
51              
52             Beyond the methods documented below, this class inherits methods from the
53             L<RDF::Query::Node> and L<RDF::Trine::Node::Literal> classes.
54              
55             =over 4
56              
57             =cut
58              
59             sub _cmp {
60 133     133   537 my $nodea = shift;
61 133         189 my $nodeb = shift;
62 133         201 my $op = shift;
63            
64 133         465 my $l = Log::Log4perl->get_logger("rdf.query.node.literal");
65 133         6391 $l->debug('literal comparison: ' . Dumper($nodea, $nodeb));
66            
67 133 50       10145 return 1 unless blessed($nodeb);
68 133 50       780 return -1 if ($nodeb->isa('RDF::Trine::Node::Nil'));
69 133 100       588 return 1 if ($nodeb->isa('RDF::Query::Node::Blank'));
70 132 50       564 return 1 if ($nodeb->isa('RDF::Query::Node::Resource'));
71 132 50       449 return 1 unless ($nodeb->isa('RDF::Query::Node::Literal'));
72            
73 132   100     399 my $dta = $nodea->literal_datatype || '';
74 132   100     1009 my $dtb = $nodeb->literal_datatype || '';
75 132         730 my $datetype = '^http://www.w3.org/2001/XMLSchema#dateTime';
76 132   66     769 my $datecmp = ($dta =~ $datetype and $dtb =~ $datetype);
77 132   66     349 my $numericcmp = ($nodea->is_numeric_type and $nodeb->is_numeric_type);
78            
79 132 100       907 if ($datecmp) {
80 8         29 $l->trace('datecmp');
81 8         65 my $datea = $nodea->datetime;
82 8         26 my $dateb = $nodeb->datetime;
83 8 50 33     65 if ($datea and $dateb) {
84 8         741 my $cmp = eval { DateTime->compare_ignore_floating( $datea, $dateb ) };
  8         35  
85 8 50       416 return $cmp unless ($@);
86             }
87             }
88            
89 124 100       277 if ($numericcmp) {
90 49         162 $l->trace('both numeric cmp');
91 49 100       435 return 0 if ($nodea->equal( $nodeb )); # if the nodes are identical, return true (even if the lexical values don't appear to be numeric). i.e., "xyz"^^xsd:integer should equal itself, even though it's not a valid integer.
92 38         732 return $nodea->numeric_value <=> $nodeb->numeric_value;
93             }
94            
95             {
96 75         115 $l->trace('other cmp');
  75         224  
97            
98 75 50 66     588 if ($nodea->has_language and $nodeb->has_language) {
    50 33        
    50 66        
    100 33        
    100 33        
      100        
      66        
99 0         0 $l->trace('both have language');
100 0         0 my $lc = lc($nodea->literal_value_language) cmp lc($nodeb->literal_value_language);
101 0         0 my $vc = $nodea->literal_value cmp $nodeb->literal_value;
102 0         0 my $c;
103 0 0 0     0 if ($LAZY_COMPARISONS and ($lc != 0)) {
    0          
104 0   0     0 $c = ($vc || $lc);
105             } elsif ($lc == 0) {
106 0         0 $c = $vc;
107             } else {
108 0         0 $l->debug("Attempt to compare literals with differing languages.");
109 0         0 throw RDF::Query::Error::TypeError -text => "Attempt to compare literals with differing languages.";
110             }
111 0         0 $l->trace("-> $c");
112 0         0 return $c;
113             } elsif (($nodea->has_datatype and $dta eq 'http://www.w3.org/2001/XMLSchema#string') or ($nodeb->has_datatype and $dtb eq 'http://www.w3.org/2001/XMLSchema#string')) {
114 0         0 $l->trace("one is xsd:string");
115 36     36   19659 no warnings 'uninitialized';
  36         72  
  36         46755  
116             my ($na, $nb) = sort {
117 0 0 0     0 (blessed($b) and $b->isa('RDF::Query::Node::Literal'))
  0 0       0  
118             ? $b->literal_datatype eq 'http://www.w3.org/2001/XMLSchema#string'
119             : ($LAZY_COMPARISONS)
120             ? refaddr($a) <=> refaddr($b)
121             : throw RDF::Query::Error::TypeError -text => "Attempt to compare xsd:string with non-literal";
122             } ($nodea, $nodeb);
123            
124 0         0 my $c;
125 0 0 0     0 if ($nb->has_language) {
    0          
    0          
126 0         0 $c = -1;
127             } elsif (not($nb->has_datatype) or $nb->literal_datatype eq 'http://www.w3.org/2001/XMLSchema#string') {
128 0         0 $c = $nodea->literal_value cmp $nodeb->literal_value;
129             } elsif ($LAZY_COMPARISONS) {
130 0         0 return $nodea->as_string cmp $nodeb->as_string;
131             } else {
132 0         0 throw RDF::Query::Error::TypeError -text => "Attempt to compare typed-literal with xsd:string.";
133             }
134 0         0 $l->trace("-> $c");
135 0         0 return $c;
136             } elsif ($nodea->has_datatype and $nodeb->has_datatype) {
137 0         0 $l->trace("both have datatype");
138 0         0 my $dc = $nodea->literal_datatype cmp $nodeb->literal_datatype;
139 0         0 my $vc = $nodea->literal_value cmp $nodeb->literal_value;
140 0         0 my $c;
141            
142 0 0       0 if ($op eq '!=') {
143 0         0 throw RDF::Query::Error::TypeError -text => "Attempt to compare (neq) literals with unrecognized datatypes.";
144             } else {
145 0 0       0 if ($LAZY_COMPARISONS) {
    0          
146 0   0     0 $c = ($vc || $dc);
147             } elsif ($dc == 0) {
148 0         0 $c = $vc;
149             } else {
150 0         0 $l->debug("Attempt to compare literals with different datatypes.");
151 0         0 throw RDF::Query::Error::TypeError -text => "Attempt to compare literals with differing datatypes.";
152             }
153 0         0 $l->trace("-> $c");
154 0         0 return $c;
155             }
156             } elsif ($nodea->has_language or $nodeb->has_language) {
157 3         131 $l->trace("one has language");
158 3 100       26 my $c = ($nodea->has_language) ? 1 : -1;
159 3         32 $l->trace("-> $c");
160 3         28 return $c;
161             } elsif ($nodea->has_datatype or $nodeb->has_datatype) {
162 1         63 $l->trace("one has datatype");
163 1 50       9 if ($LAZY_COMPARISONS) {
164 0 0       0 my $c = ($nodea->has_datatype) ? 1 : -1;
165 0         0 $l->trace("-> $c");
166 0         0 return $c;
167             } else {
168 1         4 $l->debug("Attempt to compare typed-literal with plain-literal");
169 1         22 throw RDF::Query::Error::TypeError -text => "Attempt to compare typed-literal with plain-literal";
170             }
171             } else {
172 71         4122 $l->trace("something else");
173 71         522 my $vcmp = $nodea->literal_value cmp $nodeb->literal_value;
174 71         747 $l->trace("-> $vcmp");
175 71         754 return $vcmp;
176             }
177             }
178             }
179              
180             =item C<< datetime >>
181              
182             Returns a DateTime object from the literal if the literal value is in W3CDTF format.
183              
184             =cut
185              
186             sub datetime {
187 16     16 1 25 my $self = shift;
188 16         55 my $addr = refaddr( $self );
189 16 100       46 if (exists($INSIDE_OUT_DATES{ $addr })) {
190 3         8 return $INSIDE_OUT_DATES{ $addr };
191             } else {
192 13         43 my $value = $self->literal_value;
193 13         138 my $f = DateTime::Format::W3CDTF->new;
194 13         66 my $dt = eval { $f->parse_datetime( $value ) };
  13         43  
195 13         5208 $INSIDE_OUT_DATES{ $addr } = $dt;
196 13         48 return $dt;
197             }
198             }
199              
200             =item C<< as_sparql >>
201              
202             Returns the SPARQL string for this node.
203              
204             =cut
205              
206             sub as_sparql {
207 60     60 1 629 my $self = shift;
208 60 100       203 if ($self->is_numeric_type) {
209 7         29 return $self->literal_value;
210             } else {
211 53         624 return $self->sse;
212             }
213             }
214              
215             =item C<< as_hash >>
216              
217             Returns the query as a nested set of plain data structures (no objects).
218              
219             =cut
220              
221             sub as_hash {
222 0     0 1 0 my $self = shift;
223 0         0 my $context = shift;
224 0         0 my $hash = {
225             type => 'node',
226             literal => $self->literal_value,
227             };
228 0 0       0 $hash->{ language } = $self->literal_value_language if ($self->has_language);
229 0 0       0 $hash->{ datatype } = $self->literal_datatype if ($self->has_datatype);
230 0         0 return $hash;
231             }
232              
233             =item C<< is_simple_literal >>
234              
235             Returns true if the literal is "simple" -- is a literal without datatype or language.
236              
237             =cut
238              
239             sub is_simple_literal {
240 0     0 1 0 my $self = shift;
241 0   0     0 return not($self->has_language or $self->has_datatype);
242             }
243              
244             =item C<< is_numeric_type >>
245              
246             Returns true if the literal is a known (xsd) numeric type.
247              
248             =cut
249              
250             sub is_numeric_type {
251 682     682 1 1504 my $self = shift;
252 682 100       2007 return 0 unless ($self->has_datatype);
253 522         4602 my $type = $self->literal_datatype;
254 522 100       5370 if ($type =~ qr<^http://www.w3.org/2001/XMLSchema#(integer|decimal|float|double|non(Positive|Negative)Integer|(positive|negative)Integer|long|int|short|byte|unsigned(Long|Int|Short|Byte))>) {
255 388         1441 return 1;
256             } else {
257 134         661 return 0;
258             }
259             }
260              
261             =item C<< numeric_value >>
262              
263             Returns the numeric value of the literal (even if the literal isn't a known numeric type.
264              
265             =cut
266              
267             sub numeric_value {
268 181     181 1 10614 my $self = shift;
269 181 100       384 if ($self->is_numeric_type) {
    100          
    50          
270 177         507 my $value = $self->literal_value;
271 177 50       1294 if (looks_like_number($value)) {
272 177         8773 my $v = 0 + eval "$value";
273 177         943 return $v;
274             } else {
275 0         0 throw RDF::Query::Error::TypeError -text => "Literal with numeric type does not appear to have numeric value.";
276             }
277             } elsif (not $self->has_datatype) {
278 1 50       22 if (looks_like_number($self->literal_value)) {
279 1         11 return 0+$self->literal_value;
280             } else {
281 0         0 return;
282             }
283             } elsif ($self->literal_datatype eq 'http://www.w3.org/2001/XMLSchema#boolean') {
284 3 100       40 return ($self->literal_value eq 'true') ? 1 : 0;
285             } else {
286 0         0 return;
287             }
288             }
289              
290             =item C<< type_list >>
291              
292             Returns a two-item list suitable for use as the second and third arguments to
293             RDF::Query::Node::Literal constructor. The two returned values correspond to
294             literal language tag and literal datatype URI, respectively.
295              
296             =cut
297              
298             sub type_list {
299 0     0 1 0 my $self = shift;
300 0         0 return ($self->literal_value_language, $self->literal_datatype);
301             }
302              
303             sub DESTROY {
304 931     931   112277 my $self = shift;
305 931         2036 my $addr = refaddr($self);
306 931         4572 delete $INSIDE_OUT_DATES{ $addr };
307             }
308              
309              
310             1;
311              
312             __END__
313              
314             =back
315              
316             =head1 AUTHOR
317              
318             Gregory Todd Williams <gwilliams@cpan.org>
319              
320             =cut