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

# RDF::Query::Compiler::SQL
# -----------------------------------------------------------------------------

=head1 NAME

RDF::Query::Compiler::SQL - Compile a SPARQL query directly to SQL.

=head1 VERSION

This document describes RDF::Query::Compiler::SQL version 2.916.

=head1 STATUS

This module's API and functionality should be considered deprecated.
If you need functionality that this module provides,
please L<get in touch|http://www.perlrdf.org/>.

=cut

package RDF::Query::Compiler::SQL;

use strict;
use warnings;
no warnings 'redefine';

use RDF::Query::Error qw(:try);

use Log::Log4perl;
use List::Util qw(first);
use Data::Dumper;
use Math::BigInt;
use Digest::MD5 ('md5');
#use Digest::Perl::MD5 (); #('md5');
use Carp qw(carp croak confess);
use Scalar::Util qw(blessed reftype);

use RDF::Query::Error qw(:try);

######################################################################

my (@NODE_TYPE_TABLES, %NODE_TYPE_TABLES);
our ($VERSION);
BEGIN {
	$VERSION	= '2.916';
	@NODE_TYPE_TABLES	= (
							['Resources', 'ljr', 'URI'],
							['Literals', 'ljl', qw(Value Language Datatype)],
							['Bnodes', 'ljb', qw(Name)]
						);
	%NODE_TYPE_TABLES	= map { $_->[0] => [ @{ $_ }[1 .. $#{ $_ }] ] } @NODE_TYPE_TABLES;
}

######################################################################

use constant INDENT		=> "\t";

=head1 METHODS

=over 4

=cut

=item C<< new ( $parse_tree ) >>

Returns a new compiler object.

=cut

sub new {
	my $class	= shift;
	my $parsed	= shift;
	my $model	= shift;
	my $l		= Log::Log4perl->get_logger("rdf.query.compiler.sql");
	my $stable;
	if ($model) {
		my $mhash	= _mysql_hash( $model );
		$l->debug("Model: $model => $mhash\n");
		$stable		= "Statements${mhash}";
	} else {
		$stable		= 'Statements';
	}

	my $self	= bless( {
					parsed	=> $parsed,
					stable	=> $stable,
					vars	=> {},
					from	=> [],
					where	=> [],
				}, $class );

	return $self;
}


=item C<< compile () >>

Returns a SQL query string for the specified parse tree.

=cut

sub compile {
	my $self	= shift;
	my $parsed	= $self->{parsed};

	my $sql;
	try {
		my $method	= uc $parsed->{'method'};
		if ($method eq 'SELECT') {
			$sql	= $self->emit_select();
		} else {
			throw RDF::Query::Error::CompilationError( -text => "SQL compilation of $method queries not yet implemented." );
		}
	} catch RDF::Query::Error::CompilationError with {
		my $err	= shift;
		throw $err;
	};

	return $sql;
}


=item C<< emit_select >>

Returns a SQL query string representing the query.

=cut

sub emit_select {
	my $self	= shift;
	my $parsed	= $self->{parsed};

	my $level		= \do { my $a = 0 };
	my @vars		= map { $_->name } @{ $parsed->{variables} };
	my %select_vars	= map { $_ => 1 } @vars;

	$self->patterns2sql( $parsed->{'triples'}, $level );

	my ($varcols, @cols)	= $self->add_variable_values_joins;
	my $vars	= $self->{vars};
	my $from	= $self->{from};
	my $where	= $self->{where};

	my $options				= $self->{options} || {};
	my $unique				= $options->{'distinct'};

	my $from_clause;
	foreach my $f (@$from) {
		$from_clause	.= ",\n" . INDENT if ($from_clause and $from_clause =~ m/[^(]$/ and $f !~ m/^([)]|LEFT JOIN)/);
		$from_clause	.= $f;
	}


	my $where_clause	= @$where ? "WHERE\n"
						. INDENT . join(" AND\n" . INDENT, @$where) : '';


	my @sql	= (
				"SELECT" . ($unique ? ' DISTINCT' : ''),
				INDENT . join(",\n" . INDENT, @cols),
				"FROM",
				INDENT . $from_clause,
				$where_clause,
			);

	push(@sql, $self->order_by_clause( $varcols, $level ) );
	push(@sql, $self->limit_clause( $options ) );

	my $sql	= join("\n", grep {length} @sql);
	return $sql;
}

=item C<< limit_clause >>

Returns a SQL LIMIT clause, or an empty string if the query does not need limiting.

=cut

sub limit_clause {
	my $self	= shift;
	my $options	= shift;
	if (my $limit = $options->{limit}) {
		return "LIMIT ${limit}";
	} else {
		return "";
	}
}

=item C<< order_by_clause >>

Returns a SQL ORDER BY clause, or an empty string if the query does not use ordering.

=cut

sub order_by_clause {
	my $self	= shift;
	my $varcols	= shift;
	my $level	= shift || \do{ my $a = 0 };

	my $vars	= $self->{vars};

	my $options				= $self->{options} || {};
	my %variable_value_cols	= %$varcols;

	my $sql		= '';
	if ($options->{orderby}) {
		my $data	= $options->{orderby}[0];
		my ($dir, @operands)	= @$data;

		if (scalar(@operands) > 1) {
			throw RDF::Query::Error::CompilationError( -text => "Can't sort by more than one column yet." );
		}

		my $sort	= $operands[0];
		if (blessed($sort) and $sort->type eq 'VAR') {
			my $var		= $sort->name;
			my @cols	= $self->variable_columns( $var );
			$sql	.= "ORDER BY\n"
					. INDENT . join(', ', map { "$_ $dir" } @cols );
		} elsif (blessed($sort) and $sort->type eq 'FUNCTION') {
			my $uri		= $self->qualify_uri( $sort->uri );
			my $col		= $self->expr2sql( $sort, $level );
			my @sort;
			foreach my $var (keys %$vars) {
				my ($l_sort_col, $r_sort_col, $b_sort_col)	= @{ $variable_value_cols{ $var } };
				my $varcol	= $vars->{ $var };
				if ($col =~ /${varcol}/) {
					my ($l, $r, $b)	= ($col) x 3;
					$l		=~ s/$varcol/${l_sort_col}/;
					$r		=~ s/$varcol/${r_sort_col}/;
					$b		=~ s/$varcol/${b_sort_col}/;
					push(@sort, "$l $dir, $r $dir, $b $dir");
					last;
				}
			}
			unless (@sort) {
				push(@sort, "${col} $dir");
			}
			$sql	.= "ORDER BY\n"
					. INDENT . join(', ', @sort);
		} else {
			throw RDF::Query::Error::CompilationError( -text => "Can't sort by $$data[1][0] yet." );
		}
	}

	return $sql;
}

=item C<< variable_columns ( $var ) >>

Given a variable name, returns the set of column aliases that store the values
for the column (values for Literals, URIs, and Blank Nodes).

=cut

sub variable_columns {
	my $self	= shift;
	my $var		= shift;
	return map { "${var}_$_" } (qw(Value URI Name));
}

=item C<< add_variable_values_joins >>

Modifies the query by adding LEFT JOINs to the tables in the database that
contain the node values (for literals, resources, and blank nodes).

=cut

sub add_variable_values_joins {
	my $self	= shift;
	my $l		= Log::Log4perl->get_logger("rdf.query.algebra.service");
	my $parsed	= $self->{parsed};
	my @vars	= map { $_->name } @{ $parsed->{variables} };
	my %select_vars	= map { $_ => 1 } @vars;
	my %variable_value_cols;

	my $vars	= $self->{vars};
	my $from	= $self->{from};
	my $where	= $self->{where};

	my @cols;
	my $uniq_count	= 0;
	my (%seen_vars, %seen_joins);
	foreach my $var (grep { not $seen_vars{ $_ }++ } (@vars, keys %$vars)) {
		my $col	= $vars->{ $var };
		unless ($col) {
			throw RDF::Query::Error::CompilationError "*** Nothing is known about the variable ?${var}";
		}

		my $col_table	= (split(/[.]/, $col))[0];
		my ($count)		= ($col_table =~ /\w(\d+)/);

		$l->debug("var: $var\t\tcol: $col\t\tcount: $count\t\tunique count: $uniq_count\n");

		push(@cols, "${col} AS ${var}_Node") if ($select_vars{ $var });
		foreach (@NODE_TYPE_TABLES) {
			my ($table, $alias, @join_cols)	= @$_;
			foreach my $jc (@join_cols) {
				my $column_real_name	= "${alias}${uniq_count}.${jc}";
				my $column_alias_name	= "${var}_${jc}";
				push(@cols, "${column_real_name} AS ${column_alias_name}");
				push( @{ $variable_value_cols{ $var } }, $column_real_name);

				foreach my $i (0 .. $#{ $where }) {
					if ($where->[$i] =~ /\b$column_alias_name\b/) {
						$where->[$i]	=~ s/\b${column_alias_name}\b/${column_real_name}/g;
					}
				}

			}
		}

		foreach my $i (0 .. $#{ $from }) {
			my $f		= $from->[ $i ];
			next if ($from->[ $i ] =~ m/^[()]$/);

			my ($alias)	= ($f =~ m/Statements\d* (\w\d+)/);	#split(/ /, $f))[1];

			if ($alias eq $col_table) {

#				my (@tables, @where);
				foreach (@NODE_TYPE_TABLES) {
					my ($vtable, $vname)	= @$_;
					my $valias	= join('', $vname, $uniq_count);
					next if ($seen_joins{ $valias }++);

#					push(@tables, "${vtable} ${valias}");
#					push(@where, "${col} = ${valias}.ID");
					$f	.= " LEFT JOIN ${vtable} ${valias} ON (${col} = ${valias}.ID)";
				}

#				my $join	= sprintf("LEFT JOIN (%s) ON (%s)", join(', ', @tables), join(' AND ', @where));
#				$from->[ $i ]	= join(' ', $f, $join);
				$from->[ $i ]	= $f;
				next;
			}
		}

		$uniq_count++;
	}

	return (\%variable_value_cols, @cols);
}

=item C<< patterns2sql ( \@triples, \$level, %args ) >>

Builds the SQL query in instance data from the supplied C<@triples>.
C<$level> is used as a unique identifier for recursive calls.

C<%args> may contain callback closures for the following keys:

  'where_hook'
  'from_hook'

When present, these closures are used to add SQL FROM and WHERE clauses
to the query instead of adding them directly to the object's instance data.

=cut

sub patterns2sql {
	my $self	= shift;
	my $triples	= shift;
	my $level	= shift || \do{ my $a = 0 };
	my %args	= @_;

#	my %vars	= scalar(@_) ? %{ $_[0] } : ();

	my $parsed		= $self->{parsed};
	my $parsed_vars	= $parsed->{variables};
	my %queryvars	= map { $_->name => 1 } @$parsed_vars;

#	my (@from, @where);

	my $from	= $self->{from};
	my $where	= $self->{where};
	my $vars	= $self->{vars};

	my $add_where	= sub {
		my $w	= shift;
		if (my $hook = $args{ where_hook }) {
			push(@$where, $hook->( $w ));
		} else {
			push(@$where, $w);
		}
		return $w;
	};

	my $add_from	= sub {
		my $f	= shift;
		if (my $hook = $args{ from_hook }) {
			push(@$from, $hook->( $f ));
		} else {
			push(@$from, $f);
		}
		return $f;
	};


	my $triple	= shift(@$triples);
	Carp::confess "unblessed atom: " . Dumper($triple) unless (blessed($triple));

	if ($triple->isa('RDF::Query::Algebra::Triple') or $triple->isa('RDF::Query::Algebra::Quad')) {
		my $quad	= $triple->isa('RDF::Query::Algebra::Quad');
		my @posmap	= ($quad)
					? qw(subject predicate object context)
					: qw(subject predicate object);
#		$add_from->('(');
		my $table	= "s${$level}";
		my $stable	= $self->{stable};
		$add_from->( "${stable} ${table}" );
		foreach my $method (@posmap) {
			my $node	= $triple->$method();
			my $pos		= $method;
			my $col		= "${table}.${pos}";
			if ($node->isa('RDF::Query::Node::Variable')) {
				my $name	= $node->name;
				if (exists $vars->{ $name }) {
					my $existing_col	= $vars->{ $name };
					$add_where->( "$col = ${existing_col}" );
				} else {
					$vars->{ $name }	= $col;
				}
			} elsif ($node->isa('RDF::Query::Node::Resource')) {
				my $uri	= $node->uri_value;
				my $id	= $self->_mysql_node_hash( $node );
				$id		=~ s/\D//;
				$add_where->( "${col} = $id" );
			} elsif ($node->isa('RDF::Query::Node::Blank')) {
				my $id	= $node->blank_identifier;
				my $b	= "b${$level}";
				$add_from->( "Bnodes $b" );

				$add_where->( "${col} = ${b}.ID" );
				$add_where->( "${b}.Name = '$id'" );
			} elsif ($node->isa('RDF::Query::Node::Literal')) {
				my $id	= $self->_mysql_node_hash( $node );
				$id		=~ s/\D//;
				$add_where->( "${col} = $id" );
			} else {
				throw RDF::Query::Error::CompilationError( -text => "Unknown node type: " . Dumper($node) );
			}
		}
#		$add_from->(')');
	} else {
		if ($triple->isa('RDF::Query::Algebra::Optional')) {
			throw RDF::Query::Error::CompilationError( -text => "SQL compilation of OPTIONAL blocks is currently broken" );
		} elsif ($triple->isa('RDF::Query::Algebra::NamedGraph')) {
			$self->patterns2sql( [ $triple->pattern ], $level, %args );
# 			my $graph	= $triple->graph;
# 			my $pattern	= $triple->pattern;
# 			if ($graph->isa('RDF::Query::Node::Variable')) {
# 				my $name	= $graph->name;
# 				my $context;
# 				my $hook	= sub {
# 								my $f	= shift;
# 								if ($f =~ /^Statements/i) {
# 									my $alias	= (split(/ /, $f))[1];
# 									if (defined($context)) {
# 										$context	=~ s/\D//;
# 										$add_where->( "${alias}.Context = ${context}" );
# 									} else {
# 										$context	= "${alias}.Context";
# 										$vars->{ $name }	= $context;
# 									}
# 								}
# 								return $f;
# 							};
# 				$self->patterns2sql( [ $pattern ], $level, from_hook => $hook );
# 			} else {
# 				my $hash	= $self->_mysql_node_hash( $graph );
# 				my $hook	= sub {
# 								my $f	= shift;
# 								if ($f =~ /^Statements/i) {
# 									my $alias	= (split(/ /, $f))[1];
# 									$hash	=~ s/\D//;
# 									$add_where->( "${alias}.Context = ${hash}" );
# 								}
# 								return $f;
# 							};
# 				$self->patterns2sql( [ $pattern ], $level, from_hook => $hook );
# 			}
		} elsif ($triple->isa('RDF::Query::Algebra::Filter')) {
			++$$level;
			my $expr		= $triple->expr;
			my $pattern	= $triple->pattern;
			$self->expr2sql( $expr, $level, from_hook => $add_from, where_hook => $add_where );
			++$$level;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::BasicGraphPattern')) {
			++$$level;
			$self->patterns2sql( [ $triple->triples ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::GroupGraphPattern')) {
			++$$level;
			$self->patterns2sql( [ $triple->patterns ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::Distinct')) {
			$self->{options}{distinct}	= 1;
			my $pattern	= $triple->pattern;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::Limit')) {
			$self->{options}{limit}	= $triple->limit;
			my $pattern	= $triple->pattern;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::Offset')) {
			$self->{options}{offset}	= $triple->offset;
			my $pattern	= $triple->pattern;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::Sort')) {
			$self->{options}{orderby}	= [ $triple->orderby ];
			my $pattern	= $triple->pattern;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} elsif ($triple->isa('RDF::Query::Algebra::Project')) {
			my $pattern	= $triple->pattern;
			$self->patterns2sql( [ $pattern ], $level, %args );
		} else {
			throw RDF::Query::Error::CompilationError( -text => "Unknown pattern type '$triple' in SQL compilation." );
		}
	}

	if (scalar(@$triples)) {
		++$$level;
		$self->patterns2sql( $triples, $level );
	}
	return;
#	return (\%vars, \@from, \@where);
}

=item C<< expr2sql ( $expression, \$level, %args ) >>

Returns a SQL expression for the supplied query C<$expression>.
C<$level> is used as a unique identifier for recursive calls.

C<%args> may contain callback closures for the following keys:

  'where_hook'
  'from_hook'

When present, these closures are used to add necessary SQL FROM and WHERE
clauses to the query.

=cut

sub expr2sql {
	my $self	= shift;
	my $expr	= shift;
	my $level	= shift || \do{ my $a = 0 };
	my %args	= @_;


	my $equality	= do { no warnings 'uninitialized'; ($args{'equality'} eq 'rdf') ? 'rdf' : 'xpath' };

	my $from	= $self->{from};
	my $where	= $self->{where};
	my $vars	= $self->{vars};

	my $sql;
	my $add_where	= sub {
		my $w	= shift;
		$sql	||= $w;
		if (my $hook = $args{ where_hook }) {
			$hook->( $w );
		}
	};

	my $add_from	= sub {
		my $f	= shift;
		if (my $hook = $args{ from_hook }) {
			$hook->( $f );
		}
	};

	my $parsed		= $self->{parsed};
	my $parsed_vars	= $parsed->{variables};
	my %queryvars	= map { $_->name => 1 } @$parsed_vars;

	Carp::confess unless ref($expr);

	my $blessed	= blessed($expr);
	if ($blessed and $expr->isa('RDF::Trine::Node')) {
		if ($expr->isa('RDF::Trine::Node::Literal')) {
			my $literal	= $expr->literal_value;
			my $dt		= $expr->literal_datatype;

			my $hash	= $self->_mysql_node_hash( $expr );

			if ($equality eq 'rdf') {
				$literal	= $hash;
			} else {
				if (defined($dt)) {
					my $uri		= $dt;
					my $func	= $self->get_function( $self->qualify_uri( $uri ) );
					if ($func) {
						my ($v, $f, $w)	= $func->( $self, $parsed_vars, $level, RDF::Query::Node::Literal->new($literal) );
						$literal	= $w->[0];
					} else {
						$literal	= qq("${literal}");
					}
				} else {
					$literal	= qq('${literal}');
				}
			}

			$add_where->( $literal );
		} elsif ($expr->isa('RDF::Query::Node::Blank')) {
			my $hash		= $self->_mysql_node_hash( $expr );
			$add_where->( $hash );
		} elsif ($expr->isa('RDF::Query::Node::Resource')) {
			my $uri		= $self->_mysql_node_hash( $expr );
			$add_where->( $uri );
		} elsif ($expr->isa('RDF::Query::Node::Variable')) {
			my $name	= $expr->name;
			my $col		= $vars->{ $name };
			no warnings 'uninitialized';
			$add_where->( qq(${col}) );
		}
	} elsif ($blessed and $expr->isa('RDF::Query::Expression::Function')) {
		my $uri	= $expr->uri->uri_value;
		my $func	= $self->get_function( $uri );
		if ($func) {
			my ($v, $f, $w)	= $func->( $self, $parsed_vars, $level, $expr->arguments );
			foreach my $key (keys %$v) {
				my $val	= $v->{ $key };
				$vars->{ $key }	= $val unless (exists($vars->{ $key }));
			}

			foreach my $f (@$f) {
				$add_from->( @$f );
			}

			foreach my $w (@$w) {
				$add_where->( $w );
			}
		} else {
			throw RDF::Query::Error::CompilationError( -text => "Unknown custom function $uri in FILTER." );
		}
	} elsif ($blessed and $expr->isa('RDF::Query::Expression')) {
		my $op		= $expr->op;
		my @args	= $expr->operands;

		if ($op eq '!') {
			if ($args[0]->isa('RDF::Query::Expression::Function')) {
				if ($args[0]->uri->uri_value eq 'sparql:isbound') {
					my $expr	= RDF::Query::Expression::Function->new(
									RDF::Query::Node::Resource->new('rdfquery:isNotBound'),
									$args[0]->arguments
								);
					$self->expr2sql( $expr, $level, %args );
				}
			}
		} else {
			if ($op =~ m#^(=|==|!=|[<>]=?|[*]|/|[-+])$#) {

				$op	= '<>' if ($op eq '!=');
				$op	= '=' if ($op eq '==');

				my ($a, $b)	= @args;
				my $a_type	= $a->type;
				my $b_type	= $b->type;

				try {
					if ($op eq '=') {
						if ($a_type eq 'VAR' and $b_type eq 'VAR') {
							# comparing equality on two type-unknown variables.
							# could need rdf-term equality, so punt to the
							# catch block below.
							throw RDF::Query::Error::ComparisonError;
						}
					}

					foreach my $data ([$a_type, 'LHS'], [$b_type, 'RHS']) {
						my ($type, $side)	= @$data;
						unless ($type =~ m/^(VAR|LITERAL|FUNCTION)$/) {
							if ($op =~ m/^!?=$/) {
								# throw to the catch block below.
								throw RDF::Query::Error::ComparisonError( -text => "Using comparison operator '${op}' on unknown node type requires RDF-Term semantics." );
							} else {
								# throw error out of the compiler.
								throw RDF::Query::Error::CompilationError( -text => "Cannot use the comparison operator '${op}' on a ${side} ${type} node." );
							}
						}
					}

					if ($a_type eq 'VAR') {
						++$$level; my $var_name_a	= $self->expr2sql( $a, $level, equality => $equality );
						my $sql_a	= "(SELECT value FROM Literals WHERE ${var_name_a} = ID LIMIT 1)";
						if ($b_type eq 'VAR') {
							# ?var cmp ?var
							++$$level; my $var_name_b	= $self->expr2sql( $b, $level, equality => $equality );
							my $sql_b	= "(SELECT value FROM Literals WHERE ${var_name_b} = ID LIMIT 1)";
							$add_where->( "${sql_a} ${op} ${sql_b}" );
						} else {
							# ?var cmp NODE
							++$$level; my $sql_b	= $self->expr2sql( $b, $level, equality => $equality );
							$add_where->( "${sql_a} ${op} ${sql_b}" );
						}
					} else {
						++$$level; my $sql_a	= $self->expr2sql( $a, $level, equality => $equality );
						if ($b->type eq 'VAR') {
							# ?var cmp NODE
							++$$level; my $var_name	= $self->expr2sql( $b, $level, equality => $equality );
							my $sql_b	= "(SELECT value FROM Literals WHERE ${var_name} = ID LIMIT 1)";
							$add_where->( "${sql_a} ${op} ${sql_b}" );
						} else {
							# NODE cmp NODE
							++$$level; my $sql_b	= $self->expr2sql( $b, $level, equality => $equality );
							$add_where->( "${sql_a} ${op} ${sql_b}" );
						}
					}
				} catch RDF::Query::Error::ComparisonError with {
					# we can't compare these terms using the XPath semantics (for literals),
					# so fall back on RDF-Term semantics.
					my $err	= shift;

					my @w;
					my $where_hook	= sub {
									my $w	= shift;
									push(@w, $w);
									return;
								};

					foreach my $expr (@args) {
						$self->expr2sql( $expr, $level, %args, %args, equality => 'rdf', where_hook => $where_hook )
					}

					$add_where->("$w[0] ${op} $w[1]");

				};
			} elsif ($op eq '&&') {
				foreach my $expr (@args) {
					$self->expr2sql( $expr, $level, %args )
				}
			} elsif ($op eq '||') {
				my @w;
				my $where_hook	= sub {
								my $w	= shift;
								push(@w, $w);
								return;
							};

				foreach my $expr (@args) {
					$self->expr2sql( $expr, $level, %args, where_hook => $where_hook )
				}

				my $where	= '(' . join(' OR ', map { qq<($_)> } @w) . ')';
				$add_where->( $where );
			} else {
				throw RDF::Query::Error::CompilationError( -text => "SQL compilation of FILTER($op) queries not yet implemented." );
			}
		}
	}
	return $sql;
}

=item C<< _mysql_hash ( $data ) >>

Returns a hash value for the supplied C<$data> string. This value is computed
using the same algorithm that Redland's mysql storage backend uses.

=cut

sub _mysql_hash {
	my $data	= shift;
	my @data	= unpack('C*', md5( $data ));
	my $sum		= Math::BigInt->new('0');
#	my $count	= 0;
	foreach my $count (0 .. 7) {
#	while (@data) {
		my $data	= Math::BigInt->new( $data[ $count ] ); #shift(@data);
		my $part	= $data << (8 * $count);
#		warn "+ $part\n";
		$sum		+= $part;
	} # continue { last if ++$count == 8 }	# limit to 64 bits
#	warn "= $sum\n";
	$sum	=~ s/\D//;	# get rid of the extraneous '+' that pops up under perl 5.6
	return $sum;
}

=item C<< _mysql_node_hash ( $node ) >>

Returns a hash value (computed by C<_mysql_hash> for the supplied C<$node>.
The hash value is based on the string value of the node and the node type.

=cut

sub _mysql_node_hash {
	my $self	= shift;
	my $node	= shift;

#	my @node	= @$node;
#	my ($type, $value)	= splice(@node, 0, 2, ());

	my $data;
	Carp::confess 'node a blessed node: ' . Dumper($node) unless blessed($node);
	if ($node->isa('RDF::Query::Node::Resource')) {
		my $value	= $node->uri_value;
		if (ref($value)) {
			$value	= $self->qualify_uri( $value );
		}
		$data	= 'R' . $value;
	} elsif ($node->isa('RDF::Query::Node::Blank')) {
		my $value	= $node->blank_identifier;
		$data	= 'B' . $value;
	} elsif ($node->isa('RDF::Query::Node::Literal')) {
		my $value	= $node->literal_value;
		my $lang	= $node->literal_value_language;
		my $dt		= $node->literal_datatype;
		no warnings 'uninitialized';
		$data	= sprintf("L%s<%s>%s", $value, $lang, $dt);
#		warn "($data)";
	} else {
		return undef;
	}

	my $hash	= _mysql_hash( $data );
	return $hash;
}

=item C<< qualify_uri ( $uri ) >>

Returns a fully qualified URI from the supplied C<$uri>. C<$uri> may already
be a qualified URI, or a parse tree for a qualified URI or QName. If C<$uri> is
a QName, the namespaces defined in the query parse tree are used to fully qualify.

=cut

sub qualify_uri {
	my $self	= shift;
	my $uri		= shift;
	my $parsed	= $self->{parsed};
	if (ref($uri) and $uri->type eq 'URI') {
		$uri	= $uri->uri_value;
	}

	if (ref($uri)) {
		my ($abbr, $local)	= @$uri;
		if (exists $parsed->{namespaces}{$abbr}) {
			my $ns		= $parsed->{namespaces}{$abbr};
			$uri		= join('', $ns, $local);
		} else {
			throw RDF::Query::Error::ParseError ( -text => "Unknown namespace prefix: $abbr" );
		}
	}
	return $uri;
}

=item C<add_function ( $uri, $function )>

Associates the custom function C<$function> (a CODE reference) with the
specified URI, allowing the function to be called by query FILTERs.

=cut

sub add_function {
	my $self	= shift;
	my $uri		= shift;
	my $code	= shift;
	if (ref($self)) {
		$self->{'functions'}{$uri}	= $code;
	} else {
		our %functions;
		$functions{ $uri }	= $code;
	}
}

=item C<get_function ( $uri )>

If C<$uri> is associated with a query function, returns a CODE reference
to the function. Otherwise returns C<undef>.
=cut

sub get_function {
	my $self	= shift;
	my $uri		= shift;

	our %functions;
	my $func	= $self->{'functions'}{$uri} || $functions{ $uri };
	return $func;
}




our %functions;
BEGIN {
	$functions{ 'sparql:regex' }	= sub {
		my $self	= shift;
		my $parsed_vars	= shift;
		my $level	= shift || \do{ my $a = 0 };
		my @args	= @_;
		my (@from, @where);

		my (@regex, @literal, @pattern);
		if (blessed($args[0]) and $args[0]->isa('RDF::Query::Node::Variable')) {
			my $name	= $args[0]->name;
			push(@literal, "${name}_Value");
			push(@literal, "${name}_URI");
			push(@literal, "${name}_Name");
		} else {
			push(@literal, $self->expr2sql( $args[0], $level ));
		}

		if ($args[1]->type eq 'VAR') {
			my $name	= $args[0][1];
			push(@pattern, "${name}_Value");
			push(@pattern, "${name}_URI");
			push(@pattern, "${name}_Name");
		} else {
			push(@pattern, $self->expr2sql( $args[1], $level ));
		}

		foreach my $literal (@literal) {
			foreach my $pattern (@pattern) {
				push(@regex, sprintf(qq(%s REGEXP %s), $literal, $pattern));
			}
		}

		push(@where, '(' . join(' OR ', @regex) . ')');
		return ({}, \@from, \@where);
	};

	$functions{ 'sparql:bound' } = sub {
		my $self	= shift;
		my $parsed_vars	= shift;
		my $level	= shift || \do{ my $a = 0 };
		my @args	= @_;
		my (@from, @where);

		my $literal	= $self->expr2sql( $args[0], $level );
		push(@where, sprintf(qq(%s IS NOT NULL), $literal));
		return ({}, \@from, \@where);
	};

	$functions{ 'rdfquery:isNotBound' }	= sub {
		my $self	= shift;
		my $parsed_vars	= shift;
		my $level	= shift || \do{ my $a = 0 };
		my @args	= @_;
		my (@from, @where);

		my $literal	= $self->expr2sql( $args[0], $level );
		push(@where, sprintf(qq(%s IS NULL), $literal));
		return ({}, \@from, \@where);
	};

	$functions{ 'http://www.w3.org/2001/XMLSchema#integer' }	= sub {
		my $self	= shift;
		my $parsed_vars	= shift;
		my $level	= shift || \do{ my $a = 0 };
		my @args	= @_;
		my (@from, @where);

		my $literal	= $self->expr2sql( $args[0], $level );
		push(@where, sprintf(qq((0 + %s)), $literal));
		return ({}, \@from, \@where);
	};

	$functions{ 'http://www.w3.org/2001/XMLSchema#double' }	=
	$functions{ 'http://www.w3.org/2001/XMLSchema#decimal' }	= sub {
		my $self	= shift;
		my $parsed_vars	= shift;
		my $level	= shift || \do{ my $a = 0 };
		my @args	= @_;

		my (@from, @where);

		if ($args[0] eq 'FUNCTION') {
			Carp::confess;
		}

		my $literal	= $self->expr2sql( $args[0], $level );
		push(@where, sprintf(qq((0.0 + %s)), $literal));
		return ({}, \@from, \@where);
	};
}





1;

__END__

=back

=head1 AUTHOR

 Gregory Williams <[e-mail]>

=cut