File Coverage

blib/lib/RDF/Query/Compiler/SQL.pm
Criterion Covered Total %
statement 59 530 11.1
branch 0 164 0.0
condition 0 59 0.0
subroutine 18 41 43.9
pod 12 12 100.0
total 89 806 11.0


line stmt bran cond sub pod time code
1             # RDF::Query::Compiler::SQL
2             # -----------------------------------------------------------------------------
3              
4             =head1 NAME
5              
6             RDF::Query::Compiler::SQL - Compile a SPARQL query directly to SQL.
7              
8             =head1 VERSION
9              
10             This document describes RDF::Query::Compiler::SQL version 2.915_01.
11              
12             =head1 STATUS
13              
14             This module's API and functionality should be considered deprecated.
15             If you need functionality that this module provides,
16             please L<get in touch|http://www.perlrdf.org/>.
17              
18             =cut
19              
20             package RDF::Query::Compiler::SQL;
21              
22 35     35   211 use strict;
  35         88  
  35         1133  
23 35     35   205 use warnings;
  35         77  
  35         1256  
24 35     35   188 no warnings 'redefine';
  35         79  
  35         1501  
25              
26 35     35   207 use RDF::Query::Error qw(:try);
  35         76  
  35         351  
27              
28 35     35   6450 use Log::Log4perl;
  35         87  
  35         419  
29 35     35   1856 use List::Util qw(first);
  35         81  
  35         2405  
30 35     35   203 use Data::Dumper;
  35         80  
  35         1746  
31 35     35   212 use Math::BigInt;
  35         91  
  35         394  
32 35     35   13569 use Digest::MD5 ('md5');
  35         92  
  35         1604  
33             #use Digest::Perl::MD5 (); #('md5');
34 35     35   214 use Carp qw(carp croak confess);
  35         91  
  35         2101  
35 35     35   197 use Scalar::Util qw(blessed reftype);
  35         85  
  35         2099  
36              
37 35     35   197 use RDF::Query::Error qw(:try);
  35         82  
  35         202  
38              
39             ######################################################################
40              
41             my (@NODE_TYPE_TABLES, %NODE_TYPE_TABLES);
42             our ($VERSION);
43             BEGIN {
44 35     35   7702 $VERSION = '2.915_01';
45 35         204 @NODE_TYPE_TABLES = (
46             ['Resources', 'ljr', 'URI'],
47             ['Literals', 'ljl', qw(Value Language Datatype)],
48             ['Bnodes', 'ljb', qw(Name)]
49             );
50 35         99 %NODE_TYPE_TABLES = map { $_->[0] => [ @{ $_ }[1 .. $#{ $_ }] ] } @NODE_TYPE_TABLES;
  105         245  
  105         1661  
  105         227  
51             }
52              
53             ######################################################################
54              
55 35     35   217 use constant INDENT => "\t";
  35         91  
  35         117208  
56              
57             =head1 METHODS
58              
59             =over 4
60              
61             =cut
62              
63             =item C<< new ( $parse_tree ) >>
64              
65             Returns a new compiler object.
66              
67             =cut
68              
69             sub new {
70 0     0 1   my $class = shift;
71 0           my $parsed = shift;
72 0           my $model = shift;
73 0           my $l = Log::Log4perl->get_logger("rdf.query.compiler.sql");
74 0           my $stable;
75 0 0         if ($model) {
76 0           my $mhash = _mysql_hash( $model );
77 0           $l->debug("Model: $model => $mhash\n");
78 0           $stable = "Statements${mhash}";
79             } else {
80 0           $stable = 'Statements';
81             }
82            
83 0           my $self = bless( {
84             parsed => $parsed,
85             stable => $stable,
86             vars => {},
87             from => [],
88             where => [],
89             }, $class );
90            
91 0           return $self;
92             }
93              
94              
95             =item C<< compile () >>
96              
97             Returns a SQL query string for the specified parse tree.
98              
99             =cut
100              
101             sub compile {
102 0     0 1   my $self = shift;
103 0           my $parsed = $self->{parsed};
104            
105 0           my $sql;
106             try {
107 0     0     my $method = uc $parsed->{'method'};
108 0 0         if ($method eq 'SELECT') {
109 0           $sql = $self->emit_select();
110             } else {
111 0           throw RDF::Query::Error::CompilationError( -text => "SQL compilation of $method queries not yet implemented." );
112             }
113             } catch RDF::Query::Error::CompilationError with {
114 0     0     my $err = shift;
115 0           throw $err;
116 0           };
117            
118 0           return $sql;
119             }
120              
121              
122             =item C<< emit_select >>
123              
124             Returns a SQL query string representing the query.
125              
126             =cut
127              
128             sub emit_select {
129 0     0 1   my $self = shift;
130 0           my $parsed = $self->{parsed};
131            
132 0           my $level = \do { my $a = 0 };
  0            
133 0           my @vars = map { $_->name } @{ $parsed->{variables} };
  0            
  0            
134 0           my %select_vars = map { $_ => 1 } @vars;
  0            
135            
136 0           $self->patterns2sql( $parsed->{'triples'}, $level );
137            
138 0           my ($varcols, @cols) = $self->add_variable_values_joins;
139 0           my $vars = $self->{vars};
140 0           my $from = $self->{from};
141 0           my $where = $self->{where};
142            
143 0   0       my $options = $self->{options} || {};
144 0           my $unique = $options->{'distinct'};
145            
146 0           my $from_clause;
147 0           foreach my $f (@$from) {
148 0 0 0       $from_clause .= ",\n" . INDENT if ($from_clause and $from_clause =~ m/[^(]$/ and $f !~ m/^([)]|LEFT JOIN)/);
      0        
149 0           $from_clause .= $f;
150             }
151            
152            
153 0 0         my $where_clause = @$where ? "WHERE\n"
154             . INDENT . join(" AND\n" . INDENT, @$where) : '';
155            
156            
157 0 0         my @sql = (
158             "SELECT" . ($unique ? ' DISTINCT' : ''),
159             INDENT . join(",\n" . INDENT, @cols),
160             "FROM",
161             INDENT . $from_clause,
162             $where_clause,
163             );
164            
165 0           push(@sql, $self->order_by_clause( $varcols, $level ) );
166 0           push(@sql, $self->limit_clause( $options ) );
167            
168 0           my $sql = join("\n", grep {length} @sql);
  0            
169 0           return $sql;
170             }
171              
172             =item C<< limit_clause >>
173              
174             Returns a SQL LIMIT clause, or an empty string if the query does not need limiting.
175              
176             =cut
177              
178             sub limit_clause {
179 0     0 1   my $self = shift;
180 0           my $options = shift;
181 0 0         if (my $limit = $options->{limit}) {
182 0           return "LIMIT ${limit}";
183             } else {
184 0           return "";
185             }
186             }
187              
188             =item C<< order_by_clause >>
189              
190             Returns a SQL ORDER BY clause, or an empty string if the query does not use ordering.
191              
192             =cut
193              
194             sub order_by_clause {
195 0     0 1   my $self = shift;
196 0           my $varcols = shift;
197 0   0       my $level = shift || \do{ my $a = 0 };
198            
199 0           my $vars = $self->{vars};
200            
201 0   0       my $options = $self->{options} || {};
202 0           my %variable_value_cols = %$varcols;
203            
204 0           my $sql = '';
205 0 0         if ($options->{orderby}) {
206 0           my $data = $options->{orderby}[0];
207 0           my ($dir, @operands) = @$data;
208            
209 0 0         if (scalar(@operands) > 1) {
210 0           throw RDF::Query::Error::CompilationError( -text => "Can't sort by more than one column yet." );
211             }
212            
213 0           my $sort = $operands[0];
214 0 0 0       if (blessed($sort) and $sort->type eq 'VAR') {
    0 0        
215 0           my $var = $sort->name;
216 0           my @cols = $self->variable_columns( $var );
217             $sql .= "ORDER BY\n"
218 0           . INDENT . join(', ', map { "$_ $dir" } @cols );
  0            
219             } elsif (blessed($sort) and $sort->type eq 'FUNCTION') {
220 0           my $uri = $self->qualify_uri( $sort->uri );
221 0           my $col = $self->expr2sql( $sort, $level );
222 0           my @sort;
223 0           foreach my $var (keys %$vars) {
224 0           my ($l_sort_col, $r_sort_col, $b_sort_col) = @{ $variable_value_cols{ $var } };
  0            
225 0           my $varcol = $vars->{ $var };
226 0 0         if ($col =~ /${varcol}/) {
227 0           my ($l, $r, $b) = ($col) x 3;
228 0           $l =~ s/$varcol/${l_sort_col}/;
229 0           $r =~ s/$varcol/${r_sort_col}/;
230 0           $b =~ s/$varcol/${b_sort_col}/;
231 0           push(@sort, "$l $dir, $r $dir, $b $dir");
232 0           last;
233             }
234             }
235 0 0         unless (@sort) {
236 0           push(@sort, "${col} $dir");
237             }
238 0           $sql .= "ORDER BY\n"
239             . INDENT . join(', ', @sort);
240             } else {
241 0           throw RDF::Query::Error::CompilationError( -text => "Can't sort by $$data[1][0] yet." );
242             }
243             }
244            
245 0           return $sql;
246             }
247              
248             =item C<< variable_columns ( $var ) >>
249              
250             Given a variable name, returns the set of column aliases that store the values
251             for the column (values for Literals, URIs, and Blank Nodes).
252              
253             =cut
254              
255             sub variable_columns {
256 0     0 1   my $self = shift;
257 0           my $var = shift;
258 0           return map { "${var}_$_" } (qw(Value URI Name));
  0            
259             }
260              
261             =item C<< add_variable_values_joins >>
262              
263             Modifies the query by adding LEFT JOINs to the tables in the database that
264             contain the node values (for literals, resources, and blank nodes).
265              
266             =cut
267              
268             sub add_variable_values_joins {
269 0     0 1   my $self = shift;
270 0           my $l = Log::Log4perl->get_logger("rdf.query.algebra.service");
271 0           my $parsed = $self->{parsed};
272 0           my @vars = map { $_->name } @{ $parsed->{variables} };
  0            
  0            
273 0           my %select_vars = map { $_ => 1 } @vars;
  0            
274 0           my %variable_value_cols;
275            
276 0           my $vars = $self->{vars};
277 0           my $from = $self->{from};
278 0           my $where = $self->{where};
279            
280 0           my @cols;
281 0           my $uniq_count = 0;
282 0           my (%seen_vars, %seen_joins);
283 0           foreach my $var (grep { not $seen_vars{ $_ }++ } (@vars, keys %$vars)) {
  0            
284 0           my $col = $vars->{ $var };
285 0 0         unless ($col) {
286 0           throw RDF::Query::Error::CompilationError "*** Nothing is known about the variable ?${var}";
287             }
288            
289 0           my $col_table = (split(/[.]/, $col))[0];
290 0           my ($count) = ($col_table =~ /\w(\d+)/);
291            
292 0           $l->debug("var: $var\t\tcol: $col\t\tcount: $count\t\tunique count: $uniq_count\n");
293            
294 0 0         push(@cols, "${col} AS ${var}_Node") if ($select_vars{ $var });
295 0           foreach (@NODE_TYPE_TABLES) {
296 0           my ($table, $alias, @join_cols) = @$_;
297 0           foreach my $jc (@join_cols) {
298 0           my $column_real_name = "${alias}${uniq_count}.${jc}";
299 0           my $column_alias_name = "${var}_${jc}";
300 0           push(@cols, "${column_real_name} AS ${column_alias_name}");
301 0           push( @{ $variable_value_cols{ $var } }, $column_real_name);
  0            
302            
303 0           foreach my $i (0 .. $#{ $where }) {
  0            
304 0 0         if ($where->[$i] =~ /\b$column_alias_name\b/) {
305 0           $where->[$i] =~ s/\b${column_alias_name}\b/${column_real_name}/g;
306             }
307             }
308            
309             }
310             }
311            
312 0           foreach my $i (0 .. $#{ $from }) {
  0            
313 0           my $f = $from->[ $i ];
314 0 0         next if ($from->[ $i ] =~ m/^[()]$/);
315            
316 0           my ($alias) = ($f =~ m/Statements\d* (\w\d+)/); #split(/ /, $f))[1];
317            
318 0 0         if ($alias eq $col_table) {
319            
320             # my (@tables, @where);
321 0           foreach (@NODE_TYPE_TABLES) {
322 0           my ($vtable, $vname) = @$_;
323 0           my $valias = join('', $vname, $uniq_count);
324 0 0         next if ($seen_joins{ $valias }++);
325            
326             # push(@tables, "${vtable} ${valias}");
327             # push(@where, "${col} = ${valias}.ID");
328 0           $f .= " LEFT JOIN ${vtable} ${valias} ON (${col} = ${valias}.ID)";
329             }
330            
331             # my $join = sprintf("LEFT JOIN (%s) ON (%s)", join(', ', @tables), join(' AND ', @where));
332             # $from->[ $i ] = join(' ', $f, $join);
333 0           $from->[ $i ] = $f;
334 0           next;
335             }
336             }
337            
338 0           $uniq_count++;
339             }
340            
341 0           return (\%variable_value_cols, @cols);
342             }
343              
344             =item C<< patterns2sql ( \@triples, \$level, %args ) >>
345              
346             Builds the SQL query in instance data from the supplied C<@triples>.
347             C<$level> is used as a unique identifier for recursive calls.
348              
349             C<%args> may contain callback closures for the following keys:
350              
351             'where_hook'
352             'from_hook'
353              
354             When present, these closures are used to add SQL FROM and WHERE clauses
355             to the query instead of adding them directly to the object's instance data.
356              
357             =cut
358              
359             sub patterns2sql {
360 0     0 1   my $self = shift;
361 0           my $triples = shift;
362 0   0       my $level = shift || \do{ my $a = 0 };
363 0           my %args = @_;
364            
365             # my %vars = scalar(@_) ? %{ $_[0] } : ();
366            
367 0           my $parsed = $self->{parsed};
368 0           my $parsed_vars = $parsed->{variables};
369 0           my %queryvars = map { $_->name => 1 } @$parsed_vars;
  0            
370            
371             # my (@from, @where);
372            
373 0           my $from = $self->{from};
374 0           my $where = $self->{where};
375 0           my $vars = $self->{vars};
376              
377             my $add_where = sub {
378 0     0     my $w = shift;
379 0 0         if (my $hook = $args{ where_hook }) {
380 0           push(@$where, $hook->( $w ));
381             } else {
382 0           push(@$where, $w);
383             }
384 0           return $w;
385 0           };
386            
387             my $add_from = sub {
388 0     0     my $f = shift;
389 0 0         if (my $hook = $args{ from_hook }) {
390 0           push(@$from, $hook->( $f ));
391             } else {
392 0           push(@$from, $f);
393             }
394 0           return $f;
395 0           };
396            
397            
398 0           my $triple = shift(@$triples);
399 0 0         Carp::confess "unblessed atom: " . Dumper($triple) unless (blessed($triple));
400            
401 0 0 0       if ($triple->isa('RDF::Query::Algebra::Triple') or $triple->isa('RDF::Query::Algebra::Quad')) {
402 0           my $quad = $triple->isa('RDF::Query::Algebra::Quad');
403 0 0         my @posmap = ($quad)
404             ? qw(subject predicate object context)
405             : qw(subject predicate object);
406             # $add_from->('(');
407 0           my $table = "s${$level}";
  0            
408 0           my $stable = $self->{stable};
409 0           $add_from->( "${stable} ${table}" );
410 0           foreach my $method (@posmap) {
411 0           my $node = $triple->$method();
412 0           my $pos = $method;
413 0           my $col = "${table}.${pos}";
414 0 0         if ($node->isa('RDF::Query::Node::Variable')) {
    0          
    0          
    0          
415 0           my $name = $node->name;
416 0 0         if (exists $vars->{ $name }) {
417 0           my $existing_col = $vars->{ $name };
418 0           $add_where->( "$col = ${existing_col}" );
419             } else {
420 0           $vars->{ $name } = $col;
421             }
422             } elsif ($node->isa('RDF::Query::Node::Resource')) {
423 0           my $uri = $node->uri_value;
424 0           my $id = $self->_mysql_node_hash( $node );
425 0           $id =~ s/\D//;
426 0           $add_where->( "${col} = $id" );
427             } elsif ($node->isa('RDF::Query::Node::Blank')) {
428 0           my $id = $node->blank_identifier;
429 0           my $b = "b${$level}";
  0            
430 0           $add_from->( "Bnodes $b" );
431            
432 0           $add_where->( "${col} = ${b}.ID" );
433 0           $add_where->( "${b}.Name = '$id'" );
434             } elsif ($node->isa('RDF::Query::Node::Literal')) {
435 0           my $id = $self->_mysql_node_hash( $node );
436 0           $id =~ s/\D//;
437 0           $add_where->( "${col} = $id" );
438             } else {
439 0           throw RDF::Query::Error::CompilationError( -text => "Unknown node type: " . Dumper($node) );
440             }
441             }
442             # $add_from->(')');
443             } else {
444 0 0         if ($triple->isa('RDF::Query::Algebra::Optional')) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
445 0           throw RDF::Query::Error::CompilationError( -text => "SQL compilation of OPTIONAL blocks is currently broken" );
446             } elsif ($triple->isa('RDF::Query::Algebra::NamedGraph')) {
447 0           $self->patterns2sql( [ $triple->pattern ], $level, %args );
448             # my $graph = $triple->graph;
449             # my $pattern = $triple->pattern;
450             # if ($graph->isa('RDF::Query::Node::Variable')) {
451             # my $name = $graph->name;
452             # my $context;
453             # my $hook = sub {
454             # my $f = shift;
455             # if ($f =~ /^Statements/i) {
456             # my $alias = (split(/ /, $f))[1];
457             # if (defined($context)) {
458             # $context =~ s/\D//;
459             # $add_where->( "${alias}.Context = ${context}" );
460             # } else {
461             # $context = "${alias}.Context";
462             # $vars->{ $name } = $context;
463             # }
464             # }
465             # return $f;
466             # };
467             # $self->patterns2sql( [ $pattern ], $level, from_hook => $hook );
468             # } else {
469             # my $hash = $self->_mysql_node_hash( $graph );
470             # my $hook = sub {
471             # my $f = shift;
472             # if ($f =~ /^Statements/i) {
473             # my $alias = (split(/ /, $f))[1];
474             # $hash =~ s/\D//;
475             # $add_where->( "${alias}.Context = ${hash}" );
476             # }
477             # return $f;
478             # };
479             # $self->patterns2sql( [ $pattern ], $level, from_hook => $hook );
480             # }
481             } elsif ($triple->isa('RDF::Query::Algebra::Filter')) {
482 0           ++$$level;
483 0           my $expr = $triple->expr;
484 0           my $pattern = $triple->pattern;
485 0           $self->expr2sql( $expr, $level, from_hook => $add_from, where_hook => $add_where );
486 0           ++$$level;
487 0           $self->patterns2sql( [ $pattern ], $level, %args );
488             } elsif ($triple->isa('RDF::Query::Algebra::BasicGraphPattern')) {
489 0           ++$$level;
490 0           $self->patterns2sql( [ $triple->triples ], $level, %args );
491             } elsif ($triple->isa('RDF::Query::Algebra::GroupGraphPattern')) {
492 0           ++$$level;
493 0           $self->patterns2sql( [ $triple->patterns ], $level, %args );
494             } elsif ($triple->isa('RDF::Query::Algebra::Distinct')) {
495 0           $self->{options}{distinct} = 1;
496 0           my $pattern = $triple->pattern;
497 0           $self->patterns2sql( [ $pattern ], $level, %args );
498             } elsif ($triple->isa('RDF::Query::Algebra::Limit')) {
499 0           $self->{options}{limit} = $triple->limit;
500 0           my $pattern = $triple->pattern;
501 0           $self->patterns2sql( [ $pattern ], $level, %args );
502             } elsif ($triple->isa('RDF::Query::Algebra::Offset')) {
503 0           $self->{options}{offset} = $triple->offset;
504 0           my $pattern = $triple->pattern;
505 0           $self->patterns2sql( [ $pattern ], $level, %args );
506             } elsif ($triple->isa('RDF::Query::Algebra::Sort')) {
507 0           $self->{options}{orderby} = [ $triple->orderby ];
508 0           my $pattern = $triple->pattern;
509 0           $self->patterns2sql( [ $pattern ], $level, %args );
510             } elsif ($triple->isa('RDF::Query::Algebra::Project')) {
511 0           my $pattern = $triple->pattern;
512 0           $self->patterns2sql( [ $pattern ], $level, %args );
513             } else {
514 0           throw RDF::Query::Error::CompilationError( -text => "Unknown pattern type '$triple' in SQL compilation." );
515             }
516             }
517            
518 0 0         if (scalar(@$triples)) {
519 0           ++$$level;
520 0           $self->patterns2sql( $triples, $level );
521             }
522 0           return;
523             # return (\%vars, \@from, \@where);
524             }
525              
526             =item C<< expr2sql ( $expression, \$level, %args ) >>
527              
528             Returns a SQL expression for the supplied query C<$expression>.
529             C<$level> is used as a unique identifier for recursive calls.
530              
531             C<%args> may contain callback closures for the following keys:
532              
533             'where_hook'
534             'from_hook'
535              
536             When present, these closures are used to add necessary SQL FROM and WHERE
537             clauses to the query.
538              
539             =cut
540              
541             sub expr2sql {
542 0     0 1   my $self = shift;
543 0           my $expr = shift;
544 0   0       my $level = shift || \do{ my $a = 0 };
545 0           my %args = @_;
546            
547            
548 35 0   35   256 my $equality = do { no warnings 'uninitialized'; ($args{'equality'} eq 'rdf') ? 'rdf' : 'xpath' };
  35         78  
  35         17198  
  0            
  0            
549            
550 0           my $from = $self->{from};
551 0           my $where = $self->{where};
552 0           my $vars = $self->{vars};
553            
554 0           my $sql;
555             my $add_where = sub {
556 0     0     my $w = shift;
557 0   0       $sql ||= $w;
558 0 0         if (my $hook = $args{ where_hook }) {
559 0           $hook->( $w );
560             }
561 0           };
562            
563             my $add_from = sub {
564 0     0     my $f = shift;
565 0 0         if (my $hook = $args{ from_hook }) {
566 0           $hook->( $f );
567             }
568 0           };
569            
570 0           my $parsed = $self->{parsed};
571 0           my $parsed_vars = $parsed->{variables};
572 0           my %queryvars = map { $_->name => 1 } @$parsed_vars;
  0            
573            
574 0 0         Carp::confess unless ref($expr);
575            
576 0           my $blessed = blessed($expr);
577 0 0 0       if ($blessed and $expr->isa('RDF::Trine::Node')) {
    0 0        
    0 0        
578 0 0         if ($expr->isa('RDF::Trine::Node::Literal')) {
    0          
    0          
    0          
579 0           my $literal = $expr->literal_value;
580 0           my $dt = $expr->literal_datatype;
581            
582 0           my $hash = $self->_mysql_node_hash( $expr );
583            
584 0 0         if ($equality eq 'rdf') {
585 0           $literal = $hash;
586             } else {
587 0 0         if (defined($dt)) {
588 0           my $uri = $dt;
589 0           my $func = $self->get_function( $self->qualify_uri( $uri ) );
590 0 0         if ($func) {
591 0           my ($v, $f, $w) = $func->( $self, $parsed_vars, $level, RDF::Query::Node::Literal->new($literal) );
592 0           $literal = $w->[0];
593             } else {
594 0           $literal = qq("${literal}");
595             }
596             } else {
597 0           $literal = qq('${literal}');
598             }
599             }
600            
601 0           $add_where->( $literal );
602             } elsif ($expr->isa('RDF::Query::Node::Blank')) {
603 0           my $hash = $self->_mysql_node_hash( $expr );
604 0           $add_where->( $hash );
605             } elsif ($expr->isa('RDF::Query::Node::Resource')) {
606 0           my $uri = $self->_mysql_node_hash( $expr );
607 0           $add_where->( $uri );
608             } elsif ($expr->isa('RDF::Query::Node::Variable')) {
609 0           my $name = $expr->name;
610 0           my $col = $vars->{ $name };
611 35     35   205 no warnings 'uninitialized';
  35         95  
  35         57066  
612 0           $add_where->( qq(${col}) );
613             }
614             } elsif ($blessed and $expr->isa('RDF::Query::Expression::Function')) {
615 0           my $uri = $expr->uri->uri_value;
616 0           my $func = $self->get_function( $uri );
617 0 0         if ($func) {
618 0           my ($v, $f, $w) = $func->( $self, $parsed_vars, $level, $expr->arguments );
619 0           foreach my $key (keys %$v) {
620 0           my $val = $v->{ $key };
621 0 0         $vars->{ $key } = $val unless (exists($vars->{ $key }));
622             }
623            
624 0           foreach my $f (@$f) {
625 0           $add_from->( @$f );
626             }
627            
628 0           foreach my $w (@$w) {
629 0           $add_where->( $w );
630             }
631             } else {
632 0           throw RDF::Query::Error::CompilationError( -text => "Unknown custom function $uri in FILTER." );
633             }
634             } elsif ($blessed and $expr->isa('RDF::Query::Expression')) {
635 0           my $op = $expr->op;
636 0           my @args = $expr->operands;
637            
638 0 0         if ($op eq '!') {
639 0 0         if ($args[0]->isa('RDF::Query::Expression::Function')) {
640 0 0         if ($args[0]->uri->uri_value eq 'sparql:isbound') {
641 0           my $expr = RDF::Query::Expression::Function->new(
642             RDF::Query::Node::Resource->new('rdfquery:isNotBound'),
643             $args[0]->arguments
644             );
645 0           $self->expr2sql( $expr, $level, %args );
646             }
647             }
648             } else {
649 0 0         if ($op =~ m#^(=|==|!=|[<>]=?|[*]|/|[-+])$#) {
    0          
    0          
650            
651 0 0         $op = '<>' if ($op eq '!=');
652 0 0         $op = '=' if ($op eq '==');
653            
654 0           my ($a, $b) = @args;
655 0           my $a_type = $a->type;
656 0           my $b_type = $b->type;
657            
658             try {
659 0 0   0     if ($op eq '=') {
660 0 0 0       if ($a_type eq 'VAR' and $b_type eq 'VAR') {
661             # comparing equality on two type-unknown variables.
662             # could need rdf-term equality, so punt to the
663             # catch block below.
664 0           throw RDF::Query::Error::ComparisonError;
665             }
666             }
667            
668 0           foreach my $data ([$a_type, 'LHS'], [$b_type, 'RHS']) {
669 0           my ($type, $side) = @$data;
670 0 0         unless ($type =~ m/^(VAR|LITERAL|FUNCTION)$/) {
671 0 0         if ($op =~ m/^!?=$/) {
672             # throw to the catch block below.
673 0           throw RDF::Query::Error::ComparisonError( -text => "Using comparison operator '${op}' on unknown node type requires RDF-Term semantics." );
674             } else {
675             # throw error out of the compiler.
676 0           throw RDF::Query::Error::CompilationError( -text => "Cannot use the comparison operator '${op}' on a ${side} ${type} node." );
677             }
678             }
679             }
680            
681 0 0         if ($a_type eq 'VAR') {
682 0           ++$$level; my $var_name_a = $self->expr2sql( $a, $level, equality => $equality );
  0            
683 0           my $sql_a = "(SELECT value FROM Literals WHERE ${var_name_a} = ID LIMIT 1)";
684 0 0         if ($b_type eq 'VAR') {
685             # ?var cmp ?var
686 0           ++$$level; my $var_name_b = $self->expr2sql( $b, $level, equality => $equality );
  0            
687 0           my $sql_b = "(SELECT value FROM Literals WHERE ${var_name_b} = ID LIMIT 1)";
688 0           $add_where->( "${sql_a} ${op} ${sql_b}" );
689             } else {
690             # ?var cmp NODE
691 0           ++$$level; my $sql_b = $self->expr2sql( $b, $level, equality => $equality );
  0            
692 0           $add_where->( "${sql_a} ${op} ${sql_b}" );
693             }
694             } else {
695 0           ++$$level; my $sql_a = $self->expr2sql( $a, $level, equality => $equality );
  0            
696 0 0         if ($b->type eq 'VAR') {
697             # ?var cmp NODE
698 0           ++$$level; my $var_name = $self->expr2sql( $b, $level, equality => $equality );
  0            
699 0           my $sql_b = "(SELECT value FROM Literals WHERE ${var_name} = ID LIMIT 1)";
700 0           $add_where->( "${sql_a} ${op} ${sql_b}" );
701             } else {
702             # NODE cmp NODE
703 0           ++$$level; my $sql_b = $self->expr2sql( $b, $level, equality => $equality );
  0            
704 0           $add_where->( "${sql_a} ${op} ${sql_b}" );
705             }
706             }
707             } catch RDF::Query::Error::ComparisonError with {
708             # we can't compare these terms using the XPath semantics (for literals),
709             # so fall back on RDF-Term semantics.
710 0     0     my $err = shift;
711            
712 0           my @w;
713             my $where_hook = sub {
714 0           my $w = shift;
715 0           push(@w, $w);
716 0           return;
717 0           };
718            
719 0           foreach my $expr (@args) {
720 0           $self->expr2sql( $expr, $level, %args, %args, equality => 'rdf', where_hook => $where_hook )
721             }
722            
723 0           $add_where->("$w[0] ${op} $w[1]");
724            
725 0           };
726             } elsif ($op eq '&&') {
727 0           foreach my $expr (@args) {
728 0           $self->expr2sql( $expr, $level, %args )
729             }
730             } elsif ($op eq '||') {
731 0           my @w;
732             my $where_hook = sub {
733 0     0     my $w = shift;
734 0           push(@w, $w);
735 0           return;
736 0           };
737            
738 0           foreach my $expr (@args) {
739 0           $self->expr2sql( $expr, $level, %args, where_hook => $where_hook )
740             }
741            
742 0           my $where = '(' . join(' OR ', map { qq<($_)> } @w) . ')';
  0            
743 0           $add_where->( $where );
744             } else {
745 0           throw RDF::Query::Error::CompilationError( -text => "SQL compilation of FILTER($op) queries not yet implemented." );
746             }
747             }
748             }
749 0           return $sql;
750             }
751              
752             =item C<< _mysql_hash ( $data ) >>
753              
754             Returns a hash value for the supplied C<$data> string. This value is computed
755             using the same algorithm that Redland's mysql storage backend uses.
756              
757             =cut
758              
759             sub _mysql_hash {
760 0     0     my $data = shift;
761 0           my @data = unpack('C*', md5( $data ));
762 0           my $sum = Math::BigInt->new('0');
763             # my $count = 0;
764 0           foreach my $count (0 .. 7) {
765             # while (@data) {
766 0           my $data = Math::BigInt->new( $data[ $count ] ); #shift(@data);
767 0           my $part = $data << (8 * $count);
768             # warn "+ $part\n";
769 0           $sum += $part;
770             } # continue { last if ++$count == 8 } # limit to 64 bits
771             # warn "= $sum\n";
772 0           $sum =~ s/\D//; # get rid of the extraneous '+' that pops up under perl 5.6
773 0           return $sum;
774             }
775              
776             =item C<< _mysql_node_hash ( $node ) >>
777              
778             Returns a hash value (computed by C<_mysql_hash> for the supplied C<$node>.
779             The hash value is based on the string value of the node and the node type.
780              
781             =cut
782              
783             sub _mysql_node_hash {
784 0     0     my $self = shift;
785 0           my $node = shift;
786            
787             # my @node = @$node;
788             # my ($type, $value) = splice(@node, 0, 2, ());
789            
790 0           my $data;
791 0 0         Carp::confess 'node a blessed node: ' . Dumper($node) unless blessed($node);
792 0 0         if ($node->isa('RDF::Query::Node::Resource')) {
    0          
    0          
793 0           my $value = $node->uri_value;
794 0 0         if (ref($value)) {
795 0           $value = $self->qualify_uri( $value );
796             }
797 0           $data = 'R' . $value;
798             } elsif ($node->isa('RDF::Query::Node::Blank')) {
799 0           my $value = $node->blank_identifier;
800 0           $data = 'B' . $value;
801             } elsif ($node->isa('RDF::Query::Node::Literal')) {
802 0           my $value = $node->literal_value;
803 0           my $lang = $node->literal_value_language;
804 0           my $dt = $node->literal_datatype;
805 35     35   230 no warnings 'uninitialized';
  35         79  
  35         41544  
806 0           $data = sprintf("L%s<%s>%s", $value, $lang, $dt);
807             # warn "($data)";
808             } else {
809 0           return undef;
810             }
811            
812 0           my $hash = _mysql_hash( $data );
813 0           return $hash;
814             }
815              
816             =item C<< qualify_uri ( $uri ) >>
817              
818             Returns a fully qualified URI from the supplied C<$uri>. C<$uri> may already
819             be a qualified URI, or a parse tree for a qualified URI or QName. If C<$uri> is
820             a QName, the namespaces defined in the query parse tree are used to fully qualify.
821              
822             =cut
823              
824             sub qualify_uri {
825 0     0 1   my $self = shift;
826 0           my $uri = shift;
827 0           my $parsed = $self->{parsed};
828 0 0 0       if (ref($uri) and $uri->type eq 'URI') {
829 0           $uri = $uri->uri_value;
830             }
831            
832 0 0         if (ref($uri)) {
833 0           my ($abbr, $local) = @$uri;
834 0 0         if (exists $parsed->{namespaces}{$abbr}) {
835 0           my $ns = $parsed->{namespaces}{$abbr};
836 0           $uri = join('', $ns, $local);
837             } else {
838 0           throw RDF::Query::Error::ParseError ( -text => "Unknown namespace prefix: $abbr" );
839             }
840             }
841 0           return $uri;
842             }
843              
844             =item C<add_function ( $uri, $function )>
845              
846             Associates the custom function C<$function> (a CODE reference) with the
847             specified URI, allowing the function to be called by query FILTERs.
848              
849             =cut
850              
851             sub add_function {
852 0     0 1   my $self = shift;
853 0           my $uri = shift;
854 0           my $code = shift;
855 0 0         if (ref($self)) {
856 0           $self->{'functions'}{$uri} = $code;
857             } else {
858 0           our %functions;
859 0           $functions{ $uri } = $code;
860             }
861             }
862              
863             =item C<get_function ( $uri )>
864              
865             If C<$uri> is associated with a query function, returns a CODE reference
866             to the function. Otherwise returns C<undef>.
867             =cut
868              
869             sub get_function {
870 0     0 1   my $self = shift;
871 0           my $uri = shift;
872            
873 0           our %functions;
874 0   0       my $func = $self->{'functions'}{$uri} || $functions{ $uri };
875 0           return $func;
876             }
877              
878              
879              
880              
881             our %functions;
882             BEGIN {
883             $functions{ 'sparql:regex' } = sub {
884 0         0 my $self = shift;
885 0         0 my $parsed_vars = shift;
886 0   0     0 my $level = shift || \do{ my $a = 0 };
887 0         0 my @args = @_;
888 0         0 my (@from, @where);
889            
890 0         0 my (@regex, @literal, @pattern);
891 0 0 0     0 if (blessed($args[0]) and $args[0]->isa('RDF::Query::Node::Variable')) {
892 0         0 my $name = $args[0]->name;
893 0         0 push(@literal, "${name}_Value");
894 0         0 push(@literal, "${name}_URI");
895 0         0 push(@literal, "${name}_Name");
896             } else {
897 0         0 push(@literal, $self->expr2sql( $args[0], $level ));
898             }
899            
900 0 0       0 if ($args[1]->type eq 'VAR') {
901 0         0 my $name = $args[0][1];
902 0         0 push(@pattern, "${name}_Value");
903 0         0 push(@pattern, "${name}_URI");
904 0         0 push(@pattern, "${name}_Name");
905             } else {
906 0         0 push(@pattern, $self->expr2sql( $args[1], $level ));
907             }
908            
909 0         0 foreach my $literal (@literal) {
910 0         0 foreach my $pattern (@pattern) {
911 0         0 push(@regex, sprintf(qq(%s REGEXP %s), $literal, $pattern));
912             }
913             }
914            
915 0         0 push(@where, '(' . join(' OR ', @regex) . ')');
916 0         0 return ({}, \@from, \@where);
917 35     35   314 };
918            
919             $functions{ 'sparql:bound' } = sub {
920 0         0 my $self = shift;
921 0         0 my $parsed_vars = shift;
922 0   0     0 my $level = shift || \do{ my $a = 0 };
923 0         0 my @args = @_;
924 0         0 my (@from, @where);
925            
926 0         0 my $literal = $self->expr2sql( $args[0], $level );
927 0         0 push(@where, sprintf(qq(%s IS NOT NULL), $literal));
928 0         0 return ({}, \@from, \@where);
929 35         228 };
930            
931             $functions{ 'rdfquery:isNotBound' } = sub {
932 0         0 my $self = shift;
933 0         0 my $parsed_vars = shift;
934 0   0     0 my $level = shift || \do{ my $a = 0 };
935 0         0 my @args = @_;
936 0         0 my (@from, @where);
937            
938 0         0 my $literal = $self->expr2sql( $args[0], $level );
939 0         0 push(@where, sprintf(qq(%s IS NULL), $literal));
940 0         0 return ({}, \@from, \@where);
941 35         191 };
942            
943             $functions{ 'http://www.w3.org/2001/XMLSchema#integer' } = sub {
944 0         0 my $self = shift;
945 0         0 my $parsed_vars = shift;
946 0   0     0 my $level = shift || \do{ my $a = 0 };
947 0         0 my @args = @_;
948 0         0 my (@from, @where);
949            
950 0         0 my $literal = $self->expr2sql( $args[0], $level );
951 0         0 push(@where, sprintf(qq((0 + %s)), $literal));
952 0         0 return ({}, \@from, \@where);
953 35         205 };
954            
955             $functions{ 'http://www.w3.org/2001/XMLSchema#double' } =
956             $functions{ 'http://www.w3.org/2001/XMLSchema#decimal' } = sub {
957 0           my $self = shift;
958 0           my $parsed_vars = shift;
959 0   0       my $level = shift || \do{ my $a = 0 };
960 0           my @args = @_;
961            
962 0           my (@from, @where);
963            
964 0 0         if ($args[0] eq 'FUNCTION') {
965 0           Carp::confess;
966             }
967            
968 0           my $literal = $self->expr2sql( $args[0], $level );
969 0           push(@where, sprintf(qq((0.0 + %s)), $literal));
970 0           return ({}, \@from, \@where);
971 35         1923 };
972             }
973              
974              
975              
976              
977              
978             1;
979              
980             __END__
981              
982             =back
983              
984             =head1 AUTHOR
985              
986             Gregory Williams <gwilliams@cpan.org>
987              
988             =cut