File Coverage

blib/lib/RDF/Trine/Store/DBI.pm
Criterion Covered Total %
statement 636 830 76.6
branch 204 282 72.3
condition 25 58 43.1
subroutine 72 89 80.9
pod 21 21 100.0
total 958 1280 74.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             RDF::Trine::Store::DBI - Persistent RDF storage based on DBI
4              
5             =head1 VERSION
6              
7             This document describes RDF::Trine::Store::DBI version 1.018
8              
9             =head1 SYNOPSIS
10              
11             use RDF::Trine::Store::DBI;
12            
13             my $user = 'me';
14             my $pass = 'secret';
15             my $modelname = 'mymodel';
16              
17             # First, construct a DBI connection to your database
18             my $dsn = "DBI:mysql:database=perlrdf";
19             my $dbh = DBI->connect( $dsn, $user, $pass );
20            
21             # Second, create a new Store object with the database connection
22             # and specifying (by name) which model in the Store you want to use
23             my $store = RDF::Trine::Store::DBI->new( $modelname, $dbh );
24            
25             # Finally, wrap the Store objec into a Model, and use it to access your data
26             my $model = RDF::Trine::Model->new($store);
27             print $model->size . " RDF statements in store\n";
28              
29             =head1 DESCRIPTION
30              
31             RDF::Trine::Store::DBI provides a persistent triple-store using the L<DBI|DBI>
32             module.
33              
34             =cut
35              
36             package RDF::Trine::Store::DBI;
37              
38 68     68   1574418 use strict;
  68         192  
  68         2001  
39 68     68   361 use warnings;
  68         150  
  68         2075  
40 68     68   327 no warnings 'redefine';
  68         155  
  68         2340  
41 68     68   358 use base qw(RDF::Trine::Store);
  68         150  
  68         5320  
42              
43 68     68   79629 use DBI;
  68         842194  
  68         4079  
44 68     68   35791 use DBIx::Connector;
  68         188013  
  68         1788  
45              
46 68     68   536 use Carp;
  68         204  
  68         3865  
47 68     68   654 use DBI;
  68         174  
  68         2274  
48 68     68   384 use Scalar::Util qw(blessed reftype refaddr);
  68         149  
  68         3023  
49 68     68   384 use Encode;
  68         157  
  68         4563  
50 68     68   391 use Digest::MD5 ('md5');
  68         147  
  68         2762  
51 68     68   58082 use Math::BigInt;
  68         1091129  
  68         328  
52 68     68   708220 use Data::Dumper;
  68         182  
  68         4018  
53 68     68   438 use RDF::Trine::Node;
  68         172  
  68         2079  
54 68     68   386 use RDF::Trine::Statement;
  68         159  
  68         1310  
55 68     68   341 use RDF::Trine::Statement::Quad;
  68         150  
  68         1244  
56 68     68   330 use RDF::Trine::Iterator;
  68         151  
  68         2082  
57 68     68   376 use Log::Log4perl;
  68         154  
  68         758  
58              
59 68     68   4385 use RDF::Trine::Error;
  68         164  
  68         571  
60 68     68   32408 use RDF::Trine::Store::DBI::mysql;
  68         194  
  68         1806  
61 68     68   24004 use RDF::Trine::Store::DBI::SQLite;
  68         200  
  68         1862  
62 68     68   23746 use RDF::Trine::Store::DBI::Pg;
  68         191  
  68         3897  
63              
64             ######################################################################
65              
66             our $VERSION;
67             BEGIN {
68 68     68   232 $VERSION = "1.018";
69 68         149 my $class = __PACKAGE__;
70 68         86709 $RDF::Trine::Store::STORE_CLASSES{ $class } = $VERSION;
71             }
72              
73             ######################################################################
74              
75             =head1 METHODS
76              
77             Beyond the methods documented below, this class inherits methods from the
78             L<RDF::Trine::Store> class.
79              
80             =over 4
81              
82             =item C<new ( $model_name, $dbh )>
83              
84             =item C<new ( $model_name, $dsn, $user, $pass )>
85              
86             Returns a new storage object using the supplied arguments to construct a DBI
87             object for the underlying database.
88              
89             =item C<new_with_config ( $hashref )>
90              
91             Returns a new storage object configured with a hashref with certain
92             keys as arguments.
93              
94             The C<storetype> key must be C<DBI> for this backend.
95              
96             These keys should also be used:
97              
98             =over
99              
100             =item C<name>
101              
102             The name of the model.
103              
104             =item C<dsn>
105              
106             The DBI Data Source Name for the underlying database.
107              
108             =item C<username>
109              
110             The username of the database user.
111              
112             =item C<password>
113              
114             The password of the database user.
115              
116             =back
117              
118             =item C<new_with_object ( $dbi_db )>
119              
120             Initialize the store with a L<DBI::db> object.
121              
122             =cut
123              
124             sub new {
125 11     11 1 2034 my $class = shift;
126 11         37 my ($dbh, $conn);
127            
128 11         99 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
129            
130 11   100     3119 my $name = shift || 'model';
131 11         27 my %args;
132 11 100 66     68 if (scalar(@_) == 0) {
    100 33        
    50          
133 9         52 $l->trace("trying to construct a temporary model");
134 9         94 my $dsn = "dbi:SQLite:dbname=:memory:";
135 9         72 $conn = DBIx::Connector->new( $dsn, '', '' );
136 9         153 $class = 'RDF::Trine::Store::DBI::SQLite';
137             } elsif (blessed($_[0]) and $_[0]->isa('DBI::db')) {
138 1         6 $l->trace("got a DBD handle");
139 1         10 $dbh = shift;
140 1         7 my $name = $dbh->get_info(17);
141 1 50       17 if ($name eq 'MySQL') {
    50          
    50          
142 0         0 $class = 'RDF::Trine::Store::DBI::mysql';
143             } elsif ($name eq 'PostgreSQL') {
144 0         0 $class = 'RDF::Trine::Store::DBI::Pg';
145             } elsif ($name eq 'SQLite') {
146 1         2 $class = 'RDF::Trine::Store::DBI::SQLite';
147             }
148             } elsif (blessed($_[0]) and $_[0]->isa('DBIx::Connector')) {
149 0         0 $conn = shift;
150             } else {
151 1         3 my $dsn = shift;
152 1         3 my $user = shift;
153 1         2 my $pass = shift;
154 1 50       11 if ($dsn =~ /^DBI:mysql:/i) {
    50          
    50          
155 0         0 $class = 'RDF::Trine::Store::DBI::mysql';
156             } elsif ($dsn =~ /^DBI:Pg:/i) {
157 0         0 $class = 'RDF::Trine::Store::DBI::Pg';
158             } elsif ($dsn =~ /^DBI:SQLite:/i) {
159 1         3 $class = 'RDF::Trine::Store::DBI::SQLite';
160 1         3 $user = '';
161 1         2 $pass = '';
162             }
163 1         8 $l->trace("Connecting to $dsn ($user, $pass)");
164 1         17 $conn = DBIx::Connector->new( $dsn, $user, $pass );
165 1 50       17 unless ($conn) {
166 0         0 throw RDF::Trine::Error::DatabaseError -text => "Couldn't connect to database: " . DBI->errstr;
167             }
168             }
169            
170 11         88 my $self = bless( {
171             model_name => $name,
172             dbh => $dbh,
173             conn => $conn,
174             statements_table_prefix => 'Statements',
175             %args
176             }, $class );
177 11         84 $self->init();
178 11         63 return $self;
179             }
180              
181             sub _new_with_string {
182 0     0   0 my $class = shift;
183 0         0 my $config = shift;
184 0         0 my ($model, $dsn, $user, $pass) = split(';', $config);
185 0         0 return $class->new( $model, $dsn, $user, $pass );
186             }
187              
188             sub _new_with_config {
189 0     0   0 my $class = shift;
190 0         0 my $config = shift;
191             return $class->new( $config->{name},
192             $config->{dsn},
193             $config->{username},
194 0         0 $config->{password} );
195             }
196              
197             sub _new_with_object {
198 0     0   0 my $class = shift;
199 0         0 my $obj = shift;
200 0 0 0     0 return unless (blessed($obj) and $obj->isa('DBI::db'));
201 0         0 return $class->new( $obj );
202             }
203              
204             =item C<< nuke >>
205              
206             Permanently removes the store and its data. Note that because of this module's
207             use of the Redland schema, removing a store with this method will only delete
208             the Statements table and remove the model's entry in the Models table. The node
209             entries in the Literals, Bnodes, and Resources tables will still exist.
210              
211             =cut
212              
213             sub nuke {
214 0     0 1 0 my $self = shift;
215 0         0 my $dbh = $self->dbh;
216 0         0 my $name = $self->model_name;
217 0         0 my $id = $self->_mysql_hash( $name );
218 0         0 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
219            
220 0 0       0 $dbh->do( "DROP TABLE Statements${id};" ) || do { $l->trace( $dbh->errstr ); return };
  0         0  
  0         0  
221 0 0       0 $dbh->do( "DELETE FROM Models WHERE ID = ${id}") || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
  0         0  
  0         0  
  0         0  
222             }
223              
224             =item C<< supports ( [ $feature ] ) >>
225              
226             If C<< $feature >> is specified, returns true if the feature is supported by the
227             store, false otherwise. If C<< $feature >> is not specified, returns a list of
228             supported features.
229              
230             =cut
231              
232             sub supports {
233 0     0 1 0 return;
234             }
235              
236             =item C<< temporary_store >>
237              
238             =cut
239              
240             sub temporary_store {
241 2     2 1 22 my $class = shift;
242 2         8 my $name = 'model_' . sprintf( '%x%x%x%x', map { int(rand(16)) } (1..4) );
  8         142  
243 2         14 my $self = $class->new( $name, @_ );
244 2         10 $self->{ remove_store } = 1;
245 2         10 $self->init();
246 2         14 return $self;
247             }
248              
249             =item C<< clear_restrictions >>
250              
251             Clear's the restrictions put on the binding of node types to the different
252             statement positions. By default, the subject position is restricted to resources
253             and blank nodes, and the predicate position to only resources. Calling this
254             method will allow any node type in any statement position.
255              
256             =cut
257              
258             sub clear_restrictions {
259 0     0 1 0 my $self = shift;
260 0         0 foreach my $pos (qw(subject predicate object context)) {
261 0         0 $self->{restrictions}{$pos} = [];
262             }
263 0         0 return;
264             }
265              
266             =item C<< get_statements ($subject, $predicate, $object [, $context] ) >>
267              
268             Returns a stream object of all statements matching the specified subject,
269             predicate and objects. Any of the arguments may be undef to match any value.
270              
271             =cut
272              
273             sub get_statements {
274 81     81 1 210 my $self = shift;
275 81         365 my @nodes = @_[0..3];
276 81         219 my $bound = 0;
277 81         173 my %bound;
278            
279 81         180 my $use_quad = 0;
280 81 100       335 if (scalar(@_) >= 4) {
281 63         143 $use_quad = 1;
282             # warn "count statements with quad" if ($::debug);
283 63         129 my $g = $nodes[3];
284 63 100 100     341 if (blessed($g) and not($g->is_variable)) {
285 4         12 $bound++;
286 4         18 $bound{ 3 } = $g;
287             }
288             }
289            
290 81         279 my ($subj, $pred, $obj, $context) = @nodes;
291            
292 81         193 my $var = 0;
293 81         284 my $dbh = $self->dbh;
294             my $st = ($use_quad)
295 252 100       1007 ? RDF::Trine::Statement::Quad->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj,$context) )
296 81 100       4404 : RDF::Trine::Statement->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj) );
  54 100       233  
297            
298 81         607 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
299            
300 81         3241 my @vars = $st->referenced_variables;
301            
302 81 100       306 my $semantics = ($use_quad ? 'quad' : 'triple');
303 81         300 local($self->{context_variable_count}) = 0;
304 81 100 100     415 local($self->{join_context_nodes}) = 1 if (blessed($context) and $context->is_variable);
305 81         369 my $sql = $self->_sql_for_pattern( $st, $context, semantics => $semantics, unique => 1 );
306 81         1131 my $sth = $dbh->prepare( $sql );
307            
308 81         26720 $sth->execute();
309            
310             my $sub = sub {
311 663     663   21117 NEXTROW:
312             my $row = $sth->fetchrow_hashref;
313 663 100       3302 return unless (defined $row);
314 591         1052 my @triple;
315 591         990 my $temp_var_count = 1;
316 591 100       2750 my @nodes = ($st->nodes)[ $use_quad ? (0..3) : (0..2) ];
317 591         1448 foreach my $node (@nodes) {
318 2277 100       7049 if ($node->is_variable) {
319 1933         5346 my $nodename = $node->name;
320 1933         4804 my $uri = $self->_column_name( $nodename, 'URI' );
321 1933         3755 my $name = $self->_column_name( $nodename, 'Name' );
322 1933         3678 my $value = $self->_column_name( $nodename, 'Value' );
323 1933         3622 my $node = $self->_column_name( $nodename, 'Node' );
324 1933 100       5910 if ($row->{ $node } == 0) {
    100          
    100          
    50          
325 158         759 push( @triple, RDF::Trine::Node::Nil->new() );
326             } elsif (defined( my $u = $row->{ $uri })) {
327 1704         4990 $u = decode('utf8', $u);
328 1704         61418 push( @triple, RDF::Trine::Node::Resource->new( $u ) );
329             } elsif (defined( my $n = $row->{ $name })) {
330 29         173 push( @triple, RDF::Trine::Node::Blank->new( $n ) );
331             } elsif (defined( my $v = $row->{ $value })) {
332 42         106 my @cols = map { $self->_column_name( $nodename, $_ ) } qw(Value Language Datatype);
  126         238  
333 42         185 $cols[0] = decode('utf8', $cols[0]);
334 42         1707 $cols[2] = decode('utf8', $cols[2]);
335 42         1306 push( @triple, RDF::Trine::Node::Literal->new( @{ $row }{ @cols } ) );
  42         365  
336             } else {
337 0         0 warn "node isn't nil or a resource, blank, or literal?" . Dumper($row);
338 0         0 goto NEXTROW;
339             }
340             } else {
341 344         851 push(@triple, $node);
342             }
343             }
344            
345 591 100       2717 my $st = (@triple == 3)
346             ? RDF::Trine::Statement->new( @triple )
347             : RDF::Trine::Statement::Quad->new( @triple );
348 591         3321 return $st;
349 81         986 };
350            
351 81         707 return RDF::Trine::Iterator::Graph->new( $sub )
352             }
353              
354             sub _column_name {
355 8526     8526   12135 my $self = shift;
356 8526         17001 my @args = @_;
357 8526         15289 my $col = join('_', @args);
358 8526         15936 return $col;
359             }
360              
361             =item C<< get_pattern ( $bgp [, $context] ) >>
362              
363             Returns a stream object of all bindings matching the specified graph pattern.
364              
365             =cut
366              
367             sub get_pattern {
368 39     39 1 101 my $self = shift;
369 39         102 my $pattern = shift;
370 39         80 my $context = shift;
371 39         132 my %args = @_;
372            
373 39         302 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
374 39         1608 $l->trace("get_pattern called for: " . $pattern->sse);
375            
376 39 100       527 if (my $o = $args{ orderby }) {
377 19         74 my @ordering = @$o;
378 19         113 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
379 68     68   575 no warnings 'uninitialized';
  68         174  
  68         167950  
380 30 100       229 unless ($dir =~ /^(ASC|DESC)$/) {
381 3         32 throw RDF::Trine::Error::MethodInvocationError -text => "The sort direction for key $col must be either 'ASC' or 'DESC' in get_pattern call";
382             }
383             }
384             }
385            
386 36         131 my $dbh = $self->dbh;
387 36         1634 my @vars = $pattern->referenced_variables;
388 36         113 my %vars = map { $_ => 1 } @vars;
  62         182  
389            
390 36         212 my $sql = $self->_sql_for_pattern( $pattern, $context, %args );
391 36         288 $l->debug("get_pattern sql: $sql\n");
392            
393 36         801 my $sth = $dbh->prepare( $sql );
394 36         10555 $sth->execute();
395            
396             my $sub = sub {
397 110     110   3287 my $row = $sth->fetchrow_hashref;
398 110 100       553 return unless $row;
399            
400 78         161 my %bindings;
401 78         194 foreach my $nodename (@vars) {
402 164         498 my $uri = $self->_column_name( $nodename, 'URI' );
403 164         367 my $name = $self->_column_name( $nodename, 'Name' );
404 164         332 my $value = $self->_column_name( $nodename, 'Value' );
405 164 100       627 if (defined( my $u = $row->{ $uri })) {
    100          
    100          
406 80         311 $u = decode('utf8', $u);
407 80         3443 $bindings{ $nodename } = RDF::Trine::Node::Resource->new( $u );
408             } elsif (defined( my $n = $row->{ $name })) {
409 20         131 $bindings{ $nodename } = RDF::Trine::Node::Blank->new( $n );
410             } elsif (defined( my $v = $row->{ $value })) {
411 48         118 my @cols = map { $self->_column_name( $nodename, $_ ) } qw(Value Language Datatype);
  144         312  
412 48         105 my ($val,$lang,$dt) = @{ $row }{ @cols };
  48         149  
413 48         186 $val = decode('utf8', $val);
414 48         1991 $dt = decode('utf8', $dt);
415 48         1545 $bindings{ $nodename } = RDF::Trine::Node::Literal->new( $val, $lang, $dt );
416             } else {
417 16         39 $bindings{ $nodename } = undef;
418             }
419             }
420 78         428 return RDF::Trine::VariableBindings->new( \%bindings );
421 36         446 };
422            
423 36         89 my @args;
424 36 100       162 if (my $o = $args{ orderby }) {
425 16         64 my @ordering = @$o;
426 16         33 my @realordering;
427 16         107 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
428 27 100       95 if (exists $vars{ $col }) {
429 23         94 push(@realordering, $col, $dir);
430             }
431             }
432 16         61 @args = ( sorted_by => \@realordering );
433             }
434 36         353 return RDF::Trine::Iterator::Bindings->new( $sub, \@vars, @args )
435             }
436              
437              
438             =item C<< get_contexts >>
439              
440             Returns an RDF::Trine::Iterator over the RDF::Trine::Node objects comprising
441             the set of contexts of the stored quads.
442              
443             =cut
444              
445             sub get_contexts {
446 2     2 1 6 my $self = shift;
447 2         11 my $dbh = $self->dbh;
448 2         173 my $stable = $self->statements_table;
449 2         91 my $sql = "SELECT DISTINCT Context, r.URI AS URI, b.Name AS Name, l.Value AS Value, l.Language AS Language, l.Datatype AS Datatype FROM ${stable} s LEFT JOIN Resources r ON (r.ID = s.Context) LEFT JOIN Literals l ON (l.ID = s.Context) LEFT JOIN Bnodes b ON (b.ID = s.Context) ORDER BY URI, Name, Value;";
450 2         44 my $sth = $dbh->prepare( $sql );
451 2         869 $sth->execute();
452             my $sub = sub {
453 8     8   318 while (my $row = $sth->fetchrow_hashref) {
454 8 50       39 return unless defined($row);
455 8         43 my $uri = $self->_column_name( 'URI' );
456 8         31 my $name = $self->_column_name( 'Name' );
457 8         24 my $value = $self->_column_name( 'Value' );
458 8         23 my $ctx = $self->_column_name( 'Context' );
459 8 100       45 if ($row->{ $ctx } == 0) {
    50          
    0          
    0          
460 2         53 next;
461             # return RDF::Trine::Node::Nil->new();
462             } elsif ($row->{ $uri }) {
463 6         41 return RDF::Trine::Node::Resource->new( $row->{ $uri } );
464             } elsif ($row->{ $name }) {
465 0         0 return RDF::Trine::Node::Blank->new( $row->{ $name } );
466             } elsif (defined $row->{ $value }) {
467 0         0 my @cols = map { $self->_column_name( $_ ) } qw(Value Language Datatype);
  0         0  
468 0         0 return RDF::Trine::Node::Literal->new( @{ $row }{ @cols } );
  0         0  
469             } else {
470 0         0 return;
471             }
472             }
473 2         10 return;
474 2         26 };
475 2         25 return RDF::Trine::Iterator->new( $sub );
476             }
477              
478             =item C<< add_statement ( $statement [, $context] ) >>
479              
480             Adds the specified C<$statement> to the underlying model.
481              
482             =cut
483              
484             sub add_statement {
485 297     297 1 704 my $self = shift;
486 297         697 my $stmt = shift;
487 297         613 my $context = shift;
488 297         1041 my $dbh = $self->dbh;
489             # Carp::confess unless (blessed($stmt));
490 297         15558 my $stable = $self->statements_table;
491 297         9577 my @nodes = $stmt->nodes;
492 297         771 my @values = map { $self->_add_node( $_ ) } @nodes;
  1091         3426  
493            
494 297 100       2244 if ($stmt->isa('RDF::Trine::Statement::Quad')) {
495 200 100       873 if (blessed($context)) {
496 2         45 throw RDF::Trine::Error::MethodInvocationError -text => "add_statement cannot be called with both a quad and a context";
497             }
498 198         1013 $context = $stmt->context;
499             } else {
500 97 100       423 push @values, ($context ? $self->_add_node($context) : 0);
501             }
502 295         1106 my $sql = "SELECT 1 FROM ${stable} WHERE Subject = ? AND Predicate = ? AND Object = ? AND Context = ?";
503 295         1507 my $sth = $dbh->prepare( $sql );
504 295         22793 $sth->execute( @values );
505 295 100       34804 unless ($sth->fetch) {
506 283         1320 my $sql = sprintf( "INSERT INTO ${stable} (Subject, Predicate, Object, Context) VALUES (?,?,?,?)" );
507 283         1316 my $sth = $dbh->prepare( $sql );
508 283         18493 $sth->execute(@values);
509             }
510             }
511              
512             =item C<< remove_statement ( $statement [, $context]) >>
513              
514             Removes the specified C<$statement> from the underlying model.
515              
516             =cut
517              
518             sub remove_statement {
519 246     246 1 591 my $self = shift;
520 246         483 my $stmt = shift;
521 246         474 my $context = shift;
522 246         838 my $dbh = $self->dbh;
523 246         16112 my $stable = $self->statements_table;
524            
525 246 50       8342 unless (blessed($stmt)) {
526 0         0 throw RDF::Trine::Error::MethodInvocationError -text => "no statement passed to remove_statement";
527             }
528            
529 246 100       1447 if ($stmt->isa( 'RDF::Trine::Statement::Quad' )) {
530 178 100       661 if (blessed($context)) {
531 2         13 throw RDF::Trine::Error::MethodInvocationError -text => "remove_statement cannot be called with both a quad and a context";
532             }
533             } else {
534 68         346 my @nodes = $stmt->nodes;
535 68 100       288 if (blessed($context)) {
536 8         54 $stmt = RDF::Trine::Statement::Quad->new( @nodes[0..2], $context );
537             } else {
538 60         323 my $nil = RDF::Trine::Node::Nil->new();
539 60         382 $stmt = RDF::Trine::Statement::Quad->new( @nodes[0..2], $nil );
540             }
541             }
542            
543 244         992 my @nodes = $stmt->nodes;
544 244         2292 my $sth = $dbh->prepare("DELETE FROM ${stable} WHERE Subject = ? AND Predicate = ? AND Object = ? AND Context = ?");
545 244         23911 my @values = map { $self->_mysql_node_hash( $_ ) } (@nodes);
  976         2974  
546 244         3261 $sth->execute( @values );
547             }
548              
549             =item C<< remove_statements ( $subject, $predicate, $object [, $context]) >>
550              
551             Removes the specified C<$statement> from the underlying model.
552              
553             =cut
554              
555             sub remove_statements {
556 12     12 1 35 my $self = shift;
557 12         33 my $subj = shift;
558 12         27 my $pred = shift;
559 12         31 my $obj = shift;
560 12         27 my $context = shift;
561 12         49 my $dbh = $self->dbh;
562 12         713 my $stable = $self->statements_table;
563            
564 12         367 my (@where, @bind);
565 12         53 my @keys = qw(Subject Predicate Object Context);
566 12         42 foreach my $node ($subj, $pred, $obj, $context) {
567 48         83 my $key = shift(@keys);
568 48 100       133 if (defined($node)) {
569 14         36 push(@bind, $node);
570 14         47 push(@where, "${key} = ?");
571             }
572             }
573            
574 12         36 my $where = join(" AND ", @where);
575 12 50       157 my $sth = $dbh->prepare( join(' ', "DELETE FROM ${stable}", ($where ? "WHERE ${where}" : ())) );
576 12         979 my @values = map { $self->_mysql_node_hash( $_ ) } (@bind);
  14         61  
577 12         120 $sth->execute( @values );
578             }
579              
580             sub _add_node {
581 1099     1099   1896 my $self = shift;
582 1099         1885 my $node = shift;
583 1099         3037 my $hash = $self->_mysql_node_hash( $node );
584 1099         3370 my $dbh = $self->dbh;
585            
586 1099         60813 my @cols;
587             my $table;
588 1099         0 my %values;
589 1099 100       4421 return $hash if ($node->is_nil);
590 1089 100       3466 if ($node->is_blank) {
    100          
    50          
591 18         46 $table = "Bnodes";
592 18         68 @cols = qw(ID Name);
593 18         71 @values{ @cols } = ($hash, $node->blank_identifier);
594             } elsif ($node->is_resource) {
595 1039         2002 $table = "Resources";
596 1039         2479 @cols = qw(ID URI);
597 1039         3791 @values{ @cols } = ($hash, encode('utf8', $node->uri_value));
598             } elsif ($node->isa('RDF::Trine::Node::Literal')) {
599 32         84 $table = "Literals";
600 32         101 @cols = qw(ID Value);
601 32         133 @values{ @cols } = ($hash, encode('utf8', $node->literal_value));
602 32 100       1345 if ($node->has_language) {
    100          
603 10         30 push(@cols, 'Language');
604 10         37 $values{ 'Language' } = $node->literal_value_language;
605             } elsif ($node->has_datatype) {
606 8         23 push(@cols, 'Datatype');
607 8         34 $values{ 'Datatype' } = encode('utf8', $node->literal_datatype);
608             }
609             }
610            
611 1089         40143 my $ssql = "SELECT 1 FROM ${table} WHERE " . join(' AND ', map { join(' = ', $_, '?') } @cols);
  2196         7285  
612 1089         5888 my $sth = $dbh->prepare( $ssql );
613 1089         81698 my @values = map {"$_"} @values{ @cols };
  2196         44231  
614 1089         22128 $sth->execute( @values );
615 1089 100       10194 unless ($sth->fetch) {
616 73         449 my $sql = "INSERT INTO ${table} (" . join(', ', @cols) . ") VALUES (" . join(',',('?')x scalar(@cols)) . ")";
617 73         358 my $sth = $dbh->prepare( $sql );
618 73         115212 $sth->execute( @values );
619             }
620 1089         15359 return $hash;
621             }
622              
623             =item C<< count_statements ($subject, $predicate, $object) >>
624              
625             Returns a count of all the statements matching the specified subject,
626             predicate and objects. Any of the arguments may be undef to match any value.
627              
628             =cut
629              
630             sub count_statements {
631 189     189 1 450 my $self = shift;
632 189         819 my @nodes = @_[0..3];
633 189         410 my $bound = 0;
634 189         376 my %bound;
635            
636 189         370 my $use_quad = 0;
637 189 100       719 if (scalar(@_) >= 4) {
638 149         287 $use_quad = 1;
639             # warn "count statements with quad" if ($::debug);
640 149         284 my $g = $nodes[3];
641 149 100 100     886 if (blessed($g) and not($g->is_variable)) {
642 24         72 $bound++;
643 24         75 $bound{ 3 } = $g;
644             }
645             }
646            
647 189         587 my ($subj, $pred, $obj, $context) = @nodes;
648            
649 189         604 my $dbh = $self->dbh;
650 189         11049 my $var = 0;
651             my $st = ($use_quad)
652 596 100       2461 ? RDF::Trine::Statement::Quad->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj,$context) )
653 189 100       756 : RDF::Trine::Statement->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj) );
  120 100       600  
654 189         949 my @vars = $st->referenced_variables;
655            
656 189 100       689 my $semantics = ($use_quad ? 'quad' : 'triple');
657 189 100       521 my $countkey = ($use_quad) ? 'count' : 'count-distinct';
658 189         784 my $sql = $self->_sql_for_pattern( $st, $context, $countkey => 1, semantics => $semantics );
659             # $sql =~ s/SELECT\b(.*?)\bFROM/SELECT COUNT(*) AS c FROM/smo;
660 189         375 my $count;
661 189         1941 my $sth = $dbh->prepare( $sql );
662 189         43590 $sth->execute();
663 189         1454 $sth->bind_columns( \$count );
664 189         7458 $sth->fetch;
665 189         4434 return $count;
666             }
667              
668             =item C<add_uri ( $uri, $named, $format )>
669              
670             Addsd the contents of the specified C<$uri> to the model.
671             If C<$named> is true, the data is added to the model using C<$uri> as the
672             named context.
673              
674             =cut
675              
676             =item C<add_string ( $data, $base_uri, $named, $format )>
677              
678             Addsd the contents of C<$data> to the model. If C<$named> is true,
679             the data is added to the model using C<$base_uri> as the named context.
680              
681             =cut
682              
683             =item C<< add_statement ( $statement ) >>
684              
685             Adds the specified C<$statement> to the underlying model.
686              
687             =cut
688              
689             =item C<< remove_statement ( $statement ) >>
690              
691             Removes the specified C<$statement> from the underlying model.
692              
693             =cut
694              
695             =item C<< variable_columns ( $var ) >>
696              
697             Given a variable name, returns the set of column aliases that store the values
698             for the column (values for Literals, URIs, and Blank Nodes).
699              
700             =cut
701              
702             sub variable_columns {
703 23     23 1 50 my $self = shift;
704 23         47 my $var = shift;
705 23         35 my $context = shift;
706            
707             ### ORDERING of these is important to enforce the correct sorting of results
708             ### based on the SPARQL spec. Bnodes < IRIs < Literals, but since NULLs sort
709             ### higher than other values, the list needs to be reversed.
710 23         50 my $r = $context->{restrict}{$var};
711            
712 23         39 my @cols;
713 23 100       64 push(@cols, 'Value') unless ($r->{literal});
714 23 50       68 push(@cols, 'URI') unless ($r->{resource});
715 23 100       66 push(@cols, 'Name') unless ($r->{blank});
716 23         50 return map { "${var}_$_" } @cols;
  54         130  
717             }
718              
719             =item C<< add_variable_values_joins >>
720              
721             Modifies the query by adding LEFT JOINs to the tables in the database that
722             contain the node values (for literals, resources, and blank nodes).
723              
724             =cut
725              
726             my %NODE_TYPE_TABLES = (
727             resource => ['Resources', 'ljr', 'URI'],
728             literal => ['Literals', 'ljl', qw(Value Language Datatype)],
729             blank => ['Bnodes', 'ljb', qw(Name)]
730             );
731             sub add_variable_values_joins {
732 310     310 1 657 my $self = shift;
733 310         592 my $context = shift;
734 310         608 my $varhash = shift;
735            
736 310         2066 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
737            
738 310         12047 my @vars = keys %$varhash;
739 310         923 my %select_vars = map { $_ => 1 } @vars;
  889         2293  
740 310         719 my %variable_value_cols;
741            
742 310         734 my $vars = $context->{vars};
743 310         632 my $from = $context->{from_tables};
744 310         648 my $where = $context->{where_clauses};
745 310         1028 my $stable = $self->statements_table;
746            
747 310         9479 my @cols;
748 310         683 my $uniq_count = 0;
749 310         667 my (%seen_vars, %seen_joins);
750 310         2072 foreach my $var (grep { not $seen_vars{ $_ }++ } (sort (@vars, keys %$vars))) {
  1778         4225  
751 889         1837 my $col = $vars->{ $var };
752 889 50       2198 unless ($col) {
753 0         0 throw RDF::Trine::Error::CompilationError -text => "*** Nothing is known about the variable ?${var}";
754             }
755            
756 889         2960 my $col_table = (split(/[.]/, $col))[0];
757 889         3670 my ($count) = ($col_table =~ /\w(\d+)/);
758            
759 889         5062 $l->info("var: $var\t\tcol: $col\t\tcount: $count\t\tunique count: $uniq_count");
760            
761 889 50       10060 push(@cols, "${col} AS ${var}_Node") if ($select_vars{ $var });
762 889         2016 my $restricted = 0;
763 889         1469 my @used_ljoins;
764 889         3061 foreach my $type (reverse sort keys %NODE_TYPE_TABLES) {
765 2667         4123 my ($table, $alias, @join_cols) = @{ $NODE_TYPE_TABLES{ $type } };
  2667         6876  
766 2667 100       6322 if ($context->{restrict}{$var}{$type}) {
767 666         1077 $restricted = 1;
768 666         1320 next;
769             } else {
770 2001         4559 push(@used_ljoins, "${alias}${uniq_count}.$join_cols[0]");
771             }
772 2001         3590 foreach my $jc (@join_cols) {
773 2897         5424 my $column_real_name = "${alias}${uniq_count}.${jc}";
774 2897         4809 my $column_alias_name = "${var}_${jc}";
775 2897         5562 push(@cols, "${column_real_name} AS ${column_alias_name}");
776 2897         4041 push( @{ $variable_value_cols{ $var } }, $column_real_name);
  2897         6126  
777            
778 2897         4220 foreach my $i (0 .. $#{ $where }) {
  2897         6606  
779 3183 50       19757 if ($where->[$i] =~ /\b$column_alias_name\b/) {
780 0         0 $where->[$i] =~ s/\b${column_alias_name}\b/${column_real_name}/g;
781             }
782             }
783            
784             }
785             }
786            
787 889         1637 foreach my $i (0 .. $#{ $from }) {
  889         1848  
788 929         1617 my $f = $from->[ $i ];
789 929 50       3142 next if ($from->[ $i ] =~ m/^[()]$/);
790 929         5539 my ($alias) = ($f =~ m/${stable} (\w\d+)/); #split(/ /, $f))[1];
791            
792 929 100       2822 if ($alias eq $col_table) {
793             # my (@tables, @where);
794 889         2886 foreach my $type (reverse sort keys %NODE_TYPE_TABLES) {
795 2667 100       6344 next if ($context->{restrict}{$var}{$type});
796 2001         2963 my ($vtable, $vname) = @{ $NODE_TYPE_TABLES{ $type } };
  2001         4005  
797 2001         3836 my $valias = join('', $vname, $uniq_count);
798 2001 50       5809 next if ($seen_joins{ $valias }++);
799            
800             # push(@tables, "${vtable} ${valias}");
801             # push(@where, "${col} = ${valias}.ID");
802 2001         6255 $f .= " LEFT JOIN ${vtable} ${valias} ON (${col} = ${valias}.ID)";
803             }
804            
805             # my $join = sprintf("LEFT JOIN (%s) ON (%s)", join(', ', @tables), join(' AND ', @where));
806             # $from->[ $i ] = join(' ', $f, $join);
807 889         1781 $from->[ $i ] = $f;
808 889         1881 next;
809             }
810             }
811            
812 889 100       2096 if ($restricted) {
813             # if we're restricting the left-joins to only certain types of nodes,
814             # we need to insure that the rows we're getting back actually have data
815             # in the left-joined columns. otherwise, we might end up with data for
816             # a URI, but only left-join with Bnodes (for example), and end up with
817             # NULL values where we aren't expecting them.
818 441         1066 _add_where( $context, '(' . join(' OR ', map {"$_ IS NOT NULL"} @used_ljoins) . ')' );
  657         2532  
819             }
820            
821 889         2137 $uniq_count++;
822             }
823            
824 310         2700 return (\%variable_value_cols, @cols);
825             }
826              
827             sub _sql_for_pattern {
828 310     310   701 my $self = shift;
829 310         633 my $pat = shift;
830 310         610 my $ctx_node = shift;
831 310         1208 my %args = @_;
832            
833 310         616 my @disjunction;
834 310         814 my @patterns = $pat;
835 310         598 my $variables;
836 310         1184 while (my $p = shift(@patterns)) {
837 310 50       2249 if ($p->isa('RDF::Query::Algebra::Union')) {
838 0         0 push(@patterns, $p->patterns);
839             } else {
840 310         1065 my $pvars = join('#', sort $p->referenced_variables);
841 310 50       1073 if (@disjunction) {
842             # if we've already got some UNION patterns, make sure the new
843             # pattern has the same referenced variables (otherwise the
844             # columns of the result are going to come out all screwy
845 0 0       0 if ($pvars ne $variables) {
846 0         0 throw RDF::Trine::Error::CompilationError -text => 'All patterns in a UNION must reference the same variables.';
847             }
848             } else {
849 310         703 $variables = $pvars;
850             }
851 310         1159 push(@disjunction, $p);
852             }
853             }
854            
855 310         670 my @sql;
856 310         705 foreach my $pattern (@disjunction) {
857 310         1199 my $type = $pattern->type;
858 310         1016 my $method = "_sql_for_" . lc($type);
859 310         1037 my $context = $self->_new_context;
860            
861             # warn "*** sql compilation method $method";
862 310 50       1813 if ($self->can($method)) {
863 310         1792 $self->$method( $pattern, $ctx_node, $context, %args );
864 310         1600 push(@sql, $self->_sql_from_context( $context, %args ));
865             } else {
866 0         0 throw RDF::Trine::Error::CompilationError ( -text => "Don't know how to turn a $type into SQL" );
867             }
868             }
869 310         1907 return join(' UNION ', @sql);
870             }
871              
872             sub _new_context {
873 310     310   616 my $self = shift;
874 310         1202 my $context = {
875             next_alias => 0,
876             level => 0,
877             statement_table => $self->statements_table,
878             };
879 310         10230 return $context;
880             }
881              
882 68     68   663 use constant INDENT => "\t";
  68         182  
  68         91626  
883             sub _sql_from_context {
884 310     310   657 my $self = shift;
885 310         655 my $context = shift;
886 310         946 my %args = @_;
887 310         754 my $vars = $context->{vars};
888 310   50     996 my $from = $context->{from_tables} || [];
889 310   100     1260 my $where = $context->{where_clauses} || [];
890 310 100       926 my $unique = $args{'unique'} ? 1 : 0;
891            
892 310         1119 my ($varcols, @cols) = $self->add_variable_values_joins( $context, $vars );
893 310 100       1055 unless (@cols) {
894 4         14 push(@cols, 1);
895             }
896            
897 310         684 my $from_clause;
898 310         797 foreach my $f (@$from) {
899 331 50 66     1426 $from_clause .= ",\n" . INDENT if ($from_clause and $from_clause =~ m/[^(]$/ and $f !~ m/^([)]|LEFT JOIN)/);
      66        
900 331         846 $from_clause .= $f;
901             }
902            
903 310 100       1330 my $where_clause = @$where ? "WHERE\n"
904             . INDENT . join(" AND\n" . INDENT, @$where) : '';
905            
906 310 100       1110 if ($args{ count }) {
907 149         464 @cols = ('COUNT(*)');
908             }
909 310 100       945 if ($args{ 'count-distinct' }) {
910 40         85 $unique = 1;
911             }
912 310 100       879 if ($args{ 'count' }) {
913 149         343 @cols = 'COUNT(*)';
914             }
915            
916 310 100       2163 my @sql = (
917             "SELECT" . ($unique ? ' DISTINCT' : ''),
918             INDENT . join(",\n" . INDENT, @cols),
919             "FROM",
920             INDENT . $from_clause,
921             $where_clause,
922             );
923            
924 310 100       1112 if (my $o = $args{ orderby }) {
925 16         99 my @ordering = @$o;
926 16         33 my @sort;
927 16         90 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
928 27 100       90 if (exists $vars->{ $col }) {
929 23         90 push(@sort, map { "$_ $dir" } $self->variable_columns( $col, $context ));
  54         166  
930             }
931             }
932 16 100       59 if (@sort) {
933 12         52 push(@sql, "ORDER BY " . join(', ', @sort));
934             }
935             }
936             # push(@sql, $self->order_by_clause( $varcols, $level ) );
937             # push(@sql, $self->limit_clause( $options ) );
938            
939 310         815 my $sql = join("\n", grep {length} @sql);
  1562         2970  
940            
941 310 100       983 if ($args{ 'count-distinct' }) {
942 40         129 $sql = "SELECT COUNT(*) FROM ($sql) AS counttable";
943             }
944            
945             # warn $sql;
946 310         3112 return $sql;
947             }
948              
949 331     331   818 sub _get_level { return $_[0]{level}; }
950 331     331   1133 sub _next_alias { return $_[0]{next_alias}++; }
951 331     331   786 sub _statements_table { return $_[0]{statement_table}; };
952 331     331   598 sub _add_from { push( @{ $_[0]{from_tables} }, $_[1] ); }
  331         1253  
953 771     771   9147 sub _add_where { push( @{ $_[0]{where_clauses} }, $_[1] ); }
  771         3197  
954 907     907   2642 sub _get_var { return $_[0]{vars}{ $_[1] }; }
955 889     889   2742 sub _add_var { $_[0]{vars}{ $_[1] } = $_[2]; }
956             sub _add_restriction {
957 907     907   1501 my $context = shift;
958 907         1551 my $var = shift;
959 907         2026 my @rests = @_;
960 907         1915 foreach my $r (@rests) {
961 683         2297 $context->{restrict}{ $var->name }{ $r }++
962             }
963             }
964              
965             sub _sql_for_filter {
966 0     0   0 my $self = shift;
967 0         0 my $filter = shift;
968 0         0 my $ctx_node = shift;
969 0         0 my $context = shift;
970            
971 0         0 my $expr = $filter->expr;
972 0         0 my $pattern = $filter->pattern;
973 0         0 my $type = $pattern->type;
974 0         0 my $method = "_sql_for_" . lc($type);
975 0         0 $self->$method( $pattern, $ctx_node, $context );
976 0         0 $self->_sql_for_expr( $expr, $ctx_node, $context, @_ );
977             }
978              
979             sub _sql_for_expr {
980 0     0   0 my $self = shift;
981 0         0 my $expr = shift;
982 0         0 my $ctx_node = shift;
983 0         0 my $context = shift;
984            
985             ### None of these should affect the context directly, since the expression
986             ### might be a child of another expression (e.g. "isliteral(?node) || isresource(?node)")
987            
988 0 0       0 if ($expr->isa('RDF::Query::Expression::Function')) {
    0          
989 0         0 my $func = $expr->uri->uri_value;
990 0         0 my @args = $expr->arguments;
991 0 0 0     0 if ($func eq 'sparql:isliteral' and blessed($args[0]) and $args[0]->isa('RDF::Trine::Node::Variable')) {
    0 0        
    0 0        
    0 0        
      0        
      0        
992 0         0 my $node = $args[0];
993 0         0 _add_restriction( $context, $node, qw(blank resource) );
994             } elsif ($func =~ qr/^sparql:is[iu]ri$/ and blessed($args[0]) and $args[0]->isa('RDF::Trine::Node::Variable')) {
995 0         0 my $node = $args[0];
996 0         0 _add_restriction( $context, $node, qw(blank literal) );
997             } elsif ($func =~ qr/^sparql:isblank$/ and blessed($args[0]) and $args[0]->isa('RDF::Trine::Node::Variable')) {
998 0         0 my $node = $args[0];
999 0         0 _add_restriction( $context, $node, qw(literal resource) );
1000             } elsif ($func eq 'sparql:logical-or') {
1001 0         0 $self->_sql_for_or_expr( $expr, $ctx_node, $context, @_ );
1002             } else {
1003 0         0 throw RDF::Trine::Error::CompilationError -text => "Unknown function data: " . Dumper($expr);
1004             }
1005             } elsif ($expr->isa('RDF::Query::Expression::Binary')) {
1006 0 0       0 if ($expr->op eq '==') {
1007 0         0 $self->_sql_for_equality_expr( $expr, $ctx_node, $context, @_ );
1008             } else {
1009 0         0 throw RDF::Trine::Error::CompilationError -text => "Unknown expr data: " . Dumper($expr);
1010             }
1011            
1012             } else {
1013 0         0 throw RDF::Trine::Error::CompilationError -text => "Unknown expr data: " . Dumper($expr);
1014             }
1015 0         0 return;
1016             }
1017              
1018             sub _sql_for_or_expr {
1019 0     0   0 my $self = shift;
1020 0         0 my $expr = shift;
1021 0         0 my $ctx_node = shift;
1022 0         0 my $context = shift;
1023 0         0 my @args = $self->_logical_or_operands( $expr );
1024            
1025 0         0 my @disj;
1026 0         0 foreach my $e (@args) {
1027 0         0 my $tmp_ctx = $self->_new_context;
1028 0         0 $self->_sql_for_expr( $e, $ctx_node, $tmp_ctx, @_ );
1029 0         0 my ($var, $val) = %{ $tmp_ctx->{vars} };
  0         0  
1030 0         0 my $existing_col = _get_var( $context, $var );
1031 0         0 push(@disj, "${existing_col} = $val");
1032             }
1033 0         0 my $disj = '(' . join(' OR ', @disj) . ')';
1034 0         0 _add_where( $context, $disj );
1035             }
1036              
1037             sub _logical_or_operands {
1038 0     0   0 my $self = shift;
1039 0         0 my $expr = shift;
1040 0         0 my @args = $expr->operands;
1041 0         0 my @ops;
1042 0         0 foreach my $e (@args) {
1043 0 0 0     0 if ($e->isa('RDF::Query::Expression::Function') and $e->uri->uri_value eq 'sparql:logical-or') {
1044 0         0 push(@ops, $self->_logical_or_operands( $e ));
1045             } else {
1046 0         0 push(@ops, $e);
1047             }
1048             }
1049 0         0 return @ops;
1050             }
1051              
1052             sub _sql_for_equality_expr {
1053 0     0   0 my $self = shift;
1054 0         0 my $expr = shift;
1055 0         0 my $ctx_node = shift;
1056 0         0 my $context = shift;
1057            
1058 0         0 my @args = $expr->operands;
1059             # make sorted[0] be the variable
1060 0         0 my @sorted = sort { $b->isa('RDF::Trine::Node::Variable') } @args;
  0         0  
1061 0 0       0 unless ($sorted[0]->isa('RDF::Trine::Node::Variable')) {
1062 0         0 throw RDF::Trine::Error::CompilationError -text => "No variable in equality test";
1063             }
1064 0 0 0     0 unless ($sorted[1]->isa('RDF::Trine::Node') and not($sorted[1]->isa('RDF::Trine::Node::Variable'))) {
1065 0         0 throw RDF::Trine::Error::CompilationError -text => "No RDFNode in equality test";
1066             }
1067            
1068 0         0 my $name = $sorted[0]->name;
1069 0         0 my $id = $self->_mysql_node_hash( $sorted[1] );
1070             # $self->_add_sql_node_clause( $id, $sorted[0], $context );
1071 0 0       0 if (my $existing_col = _get_var( $context, $name )) {
1072 0         0 _add_where( $context, "${existing_col} = $id" );
1073             } else {
1074 0         0 _add_var( $context, $name, $id );
1075             }
1076             }
1077              
1078 119     119   391 sub _sql_for_triple { &_sql_for_statement; }
1079 212     212   667 sub _sql_for_quad { &_sql_for_statement; }
1080             {
1081             my %default_restrictions = (
1082             subject => ['literal'],
1083             predicate => [qw(literal blank)],
1084             object => [],
1085             context => [],
1086             );
1087             sub _sql_for_statement {
1088 331     331   746 my $self = shift;
1089 331         690 my $triple = shift;
1090 331         654 my $ctx = shift;
1091 331         656 my $context = shift;
1092 331         1143 my %args = @_;
1093            
1094             my %restrictions = defined $self->{restrictions}
1095 331 50       2227 ? %{ $self->{restrictions} }
  0         0  
1096             : %default_restrictions;
1097              
1098 331         1770 my $quad = $triple->isa('RDF::Trine::Statement::Quad');
1099 68     68   563 no warnings 'uninitialized';
  68         166  
  68         47275  
1100 331 100       1357 if ($args{semantics} eq 'triple') {
1101 58         144 $quad = 0;
1102             }
1103 331 100       1339 my @posmap = ($quad)
1104             ? qw(subject predicate object context)
1105             : qw(subject predicate object);
1106 331         1130 my $table = "s" . _next_alias($context);
1107 331         1126 my $stable = _statements_table($context);
1108 331         1040 my $level = _get_level( $context );
1109 331         1587 _add_from( $context, "${stable} ${table}" );
1110 331         955 foreach my $method (@posmap) {
1111 1217         5156 my $node = $triple->$method();
1112 1217 50       3168 next unless defined($node);
1113 1217         2111 my $pos = $method;
1114 1217         2601 my $col = "${table}.${pos}";
1115 1217 100       4813 if ($node->isa('RDF::Trine::Node::Variable')) {
1116 907         1495 _add_restriction( $context, $node, @{ $restrictions{ $method } } );
  907         2412  
1117             }
1118 1217         3238 $self->_add_sql_node_clause( $col, $node, $context );
1119             }
1120            
1121 331 100       1500 unless ($quad) {
1122 107 100       745 if (defined($ctx)) {
    50          
1123 2         7 $self->_add_sql_node_clause( "${table}.Context", $ctx, $context );
1124             } elsif ($self->{join_context_nodes}) {
1125 0         0 $self->_add_sql_node_clause( "${table}.Context", RDF::Trine::Node::Variable->new( 'sql_ctx_' . ++$self->{ context_variable_count } ), $context );
1126             }
1127             }
1128             }}
1129              
1130             sub _add_sql_node_clause {
1131 1219     1219   2219 my $self = shift;
1132 1219         1902 my $col = shift;
1133 1219         1850 my $node = shift;
1134 1219         1913 my $context = shift;
1135 1219 100       4677 if ($node->isa('RDF::Trine::Node::Variable')) {
    100          
    100          
    100          
    50          
1136 907         2299 my $name = $node->name;
1137 907 100       2068 if (my $existing_col = _get_var( $context, $name )) {
1138 18         75 _add_where( $context, "$col = ${existing_col}" );
1139             } else {
1140 889         2051 _add_var( $context, $name, $col );
1141             }
1142             } elsif ($node->isa('RDF::Trine::Node::Resource')) {
1143 249         1052 my $uri = $node->uri_value;
1144 249         907 my $id = $self->_mysql_node_hash( $node );
1145 249         745 $id =~ s/\D//;
1146 249         7665 _add_where( $context, "${col} = $id" );
1147             } elsif ($node->isa('RDF::Trine::Node::Blank')) {
1148 18         66 my $id = $self->_mysql_node_hash( $node );
1149 18         55 $id =~ s/\D//;
1150 18         518 _add_where( $context, "${col} = $id" );
1151             # my $id = $node->blank_identifier;
1152             # my $b = "b$level";
1153             # _add_from( $context, "Bnodes $b" );
1154             # _add_where( $context, "${col} = ${b}.ID" );
1155             # _add_where( $context, "${b}.Name = '$id'" );
1156             } elsif ($node->isa('RDF::Trine::Node::Literal')) {
1157 33         117 my $id = $self->_mysql_node_hash( $node );
1158 33         97 $id =~ s/\D//;
1159 33         1259 _add_where( $context, "${col} = $id" );
1160             } elsif ($node->is_nil) {
1161 12         50 _add_where( $context, "${col} = 0" );
1162             } else {
1163 0         0 throw RDF::Trine::Error::CompilationError( -text => "Unknown node type: " . Dumper($node) );
1164             }
1165             }
1166              
1167             sub _sql_for_bgp {
1168 25     25   58 my $self = shift;
1169 25         55 my $bgp = shift;
1170 25         48 my $ctx = shift;
1171 25         59 my $context = shift;
1172            
1173 25         112 foreach my $triple ($bgp->triples) {
1174 46         176 $self->_sql_for_triple( $triple, $ctx, $context, @_ );
1175             }
1176             }
1177              
1178             sub _sql_for_ggp {
1179 0     0   0 my $self = shift;
1180 0         0 my $ggp = shift;
1181 0         0 my $ctx = shift;
1182 0         0 my $context = shift;
1183            
1184 0         0 my @patterns = $ggp->patterns;
1185 0 0       0 throw RDF::Trine::Error::CompilationError -text => "Can't compile an empty GroupGraphPattern to SQL" unless (scalar(@patterns));;
1186            
1187 0         0 foreach my $p (@patterns) {
1188 0         0 my $type = $p->type;
1189 0         0 my $method = "_sql_for_" . lc($type);
1190 0         0 $self->$method( $p, $ctx, $context, @_ );
1191             }
1192             }
1193              
1194             =item C<< _mysql_hash ( $data ) >>
1195              
1196             Returns a hash value for the supplied C<$data> string. This value is computed
1197             using the same algorithm that Redland's mysql storage backend uses.
1198              
1199             =cut
1200              
1201             sub _mysql_hash;
1202             sub _mysql_hash_pp {
1203 0 0   0   0 if (ref($_[0])) {
1204 0         0 my $self = shift;
1205             }
1206 0         0 my $data = encode('utf8', shift);
1207 0         0 my @data = unpack('C*', md5( $data ));
1208 0         0 my $sum = Math::BigInt->new('0');
1209 0         0 foreach my $count (0 .. 7) {
1210 0         0 my $data = Math::BigInt->new( $data[ $count ] ); #shift(@data);
1211 0         0 my $part = $data << (8 * $count);
1212             # warn "+ $part\n";
1213 0         0 $sum += $part;
1214             }
1215             # warn "= $sum\n";
1216 0         0 $sum =~ s/\D//; # get rid of the extraneous '+' that pops up under perl 5.6
1217 0         0 return $sum;
1218             }
1219              
1220             BEGIN {
1221             ## no critic
1222 68     68   4191 eval "use RDF::Trine::XS;";
  68     68   13473  
  0         0  
  0         0  
1223 68     68   545 no strict 'refs';
  68         160  
  68         3836  
1224 68 50       1104 *{ '_mysql_hash' } = (RDF::Trine::XS->can('hash'))
  68         8993  
1225             ? \&RDF::Trine::XS::hash
1226             : \&_mysql_hash_pp;
1227             ## use critic
1228             }
1229              
1230             =item C<< _mysql_node_hash ( $node ) >>
1231              
1232             Returns a hash value (computed by C<_mysql_hash> for the supplied C<$node>.
1233             The hash value is based on the string value of the node and the node type.
1234              
1235             =cut
1236              
1237             sub _mysql_node_hash {
1238 2389     2389   4152 my $self = shift;
1239 2389         4104 my $node = shift;
1240            
1241             # my @node = @$node;
1242             # my ($type, $value) = splice(@node, 0, 2, ());
1243 2389 50       10778 return 0 unless (blessed($node));
1244 2389 100       9350 return 0 if ($node->is_nil);
1245            
1246 2317         4504 my $data;
1247 2317 100       7878 if ($node->isa('RDF::Trine::Node::Resource')) {
    100          
    50          
1248 2194         7286 my $value = $node->uri_value;
1249 2194         5631 $data = 'R' . $value;
1250             } elsif ($node->isa('RDF::Trine::Node::Blank')) {
1251 44         217 my $value = $node->blank_identifier;
1252 44         112 $data = 'B' . $value;
1253             } elsif ($node->isa('RDF::Trine::Node::Literal')) {
1254 79         404 my $value = $node->literal_value;
1255 79 50       241 unless (defined($value)) {
1256 0         0 $value = '';
1257             }
1258 79   100     281 my $lang = $node->literal_value_language || '';
1259 79   100     284 my $dt = $node->literal_datatype || '';
1260 68     68   464 no warnings 'uninitialized';
  68         164  
  68         59424  
1261 79         386 $data = sprintf("L%s<%s>%s", $value, $lang, $dt);
1262             # warn "($data)";
1263             } else {
1264 0         0 return;
1265             }
1266 2317         3590 my $hash;
1267 2317         7431 $hash = $self->_mysql_hash( $data );
1268 2317         7112 return $hash;
1269             }
1270              
1271             =item C<< statements_table >>
1272              
1273             Returns the name of the Statements table.
1274              
1275             =cut
1276              
1277             sub statements_table {
1278 1177     1177 1 2370 my $self = shift;
1279 1177         3534 my $model = $self->model_name;
1280 1177         4464 my $id = $self->_mysql_hash( $model );
1281 1177         3639 my $prefix = $self->{statements_table_prefix};
1282 1177         4372 return join('', $prefix, $id);
1283             }
1284              
1285             =item C<< statements_prefix >>
1286              
1287             Returns the prefix for the underlying Statements database table.
1288              
1289             =cut
1290              
1291             sub statements_prefix {
1292 0     0 1 0 my $self = shift;
1293 0         0 return $self->{ statements_table_prefix };
1294             }
1295              
1296             =item C<< set_statements_prefix ( $prefix ) >>
1297              
1298             Sets the prefix for the underlying Statements database table.
1299              
1300             =cut
1301              
1302             sub set_statements_prefix {
1303 0     0 1 0 my $self = shift;
1304 0         0 my $prefix = shift;
1305 0         0 $self->{ statements_table_prefix } = $prefix;
1306             }
1307              
1308             =item C<< model_name >>
1309              
1310             Returns the name of the underlying model.
1311              
1312             =cut
1313              
1314             sub model_name {
1315 1211     1211 1 2419 my $self = shift;
1316             # Carp::confess unless (blessed($self));
1317 1211         3348 return $self->{model_name};
1318             }
1319              
1320             =item C<< make_private_predicate_view ( $prefix, @preds ) >>
1321              
1322             =cut
1323              
1324             sub make_private_predicate_view {
1325 0     0 1 0 my $self = shift;
1326 0         0 my $prefix = shift;
1327 0         0 my @preds = @_;
1328            
1329 0         0 my $oldtable = $self->statements_table;
1330 0         0 my $oldpre = $self->statements_prefix;
1331 0         0 my $model = $self->model_name;
1332 0         0 my $id = $self->_mysql_hash( $model );
1333            
1334 0         0 my $stable = join('', $prefix, $oldpre, $id);
1335 0         0 my $predlist = join(', ', map { $self->_mysql_node_hash( $_ ) } (@preds));
  0         0  
1336 0         0 my $sql = "CREATE VIEW ${stable} AS SELECT * FROM ${oldtable} WHERE Predicate NOT IN (${predlist})";
1337            
1338 0         0 my $dbh = $self->dbh;
1339 0         0 $dbh->do( $sql );
1340            
1341 0         0 return $stable;
1342             }
1343              
1344             =item C<< dbh >>
1345              
1346             Returns the underlying DBI database handle.
1347              
1348             =cut
1349              
1350             sub dbh {
1351 2221     2221 1 4596 my $self = shift;
1352 2221 100       7372 if (my $conn = $self->{conn}) {
1353 2113         7812 return $conn->dbh;
1354             } else {
1355 108         214 my $dbh = $self->{dbh};
1356 108         280 return $dbh;
1357             }
1358             }
1359              
1360             sub _debug {
1361 0     0   0 my $self = shift;
1362 0         0 my $dbh = $self->{dbh};
1363 0         0 my $name = $self->model_name;
1364 0         0 my $id = $self->_mysql_hash( $name );
1365 0         0 my $table = 'Statements' . $id;
1366 0         0 my $sth = $dbh->prepare( "SELECT * FROM $table" );
1367 0         0 $sth->execute;
1368 0         0 my $count = 1;
1369 0         0 while (my $h = $sth->fetchrow_hashref) {
1370 0         0 my ($s,$p,$o,$g) = @{ $h }{ qw(Subject Predicate Object Context) };
  0         0  
1371 0         0 warn sprintf("[%5d] subj=%-20d pred=%-20d obj=%-20d context=%-20d\n", $count++, $s, $p, $o, $g );
1372             }
1373             }
1374              
1375             =item C<< init >>
1376              
1377             Creates the necessary tables in the underlying database.
1378              
1379             =cut
1380              
1381             sub init {
1382 17     17 1 37 my $self = shift;
1383 17         45 my $dbh = $self->dbh;
1384 17         836 my $name = $self->model_name;
1385 17         74 my $id = $self->_mysql_hash( $name );
1386 17         112 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
1387 17         693 local($dbh->{AutoCommit}) = 0;
1388            
1389 17 100       274 unless ($self->_table_exists("Literals")) {
1390 11 50       77 $dbh->do( <<"END" ) || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
  0         0  
  0         0  
  0         0  
1391             CREATE TABLE Literals (
1392             ID NUMERIC(20) PRIMARY KEY,
1393             Value text NOT NULL,
1394             Language text NOT NULL DEFAULT '',
1395             Datatype text NOT NULL DEFAULT ''
1396             );
1397             END
1398 11 50       2754 $dbh->do( <<"END" ) || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
  0         0  
  0         0  
  0         0  
1399             CREATE TABLE Resources (
1400             ID NUMERIC(20) PRIMARY KEY,
1401             URI text NOT NULL
1402             );
1403             END
1404 11 50       2059 $dbh->do( <<"END" ) || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
  0         0  
  0         0  
  0         0  
1405             CREATE TABLE Bnodes (
1406             ID NUMERIC(20) PRIMARY KEY,
1407             Name text NOT NULL
1408             );
1409             END
1410 11 50       2072 $dbh->do( <<"END" ) || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
  0         0  
  0         0  
  0         0  
1411             CREATE TABLE Models (
1412             ID NUMERIC(20) PRIMARY KEY,
1413             Name text NOT NULL
1414             );
1415             END
1416            
1417 11 50       27084 $dbh->commit or warn $dbh->errstr;
1418             }
1419            
1420 17 100       117 unless ($self->_table_exists("Statements${id}")) {
1421 11 50       66 $dbh->do( <<"END" ) || do { $l->trace( $dbh->errstr ); return };
  0         0  
  0         0  
1422             CREATE TABLE Statements${id} (
1423             Subject NUMERIC(20) NOT NULL,
1424             Predicate NUMERIC(20) NOT NULL,
1425             Object NUMERIC(20) NOT NULL,
1426             Context NUMERIC(20) NOT NULL DEFAULT 0,
1427             PRIMARY KEY (Subject, Predicate, Object, Context)
1428             );
1429             END
1430             # $dbh->do( "DELETE FROM Models WHERE ID = ${id}") || do { $l->trace( $dbh->errstr ); $dbh->rollback; return };
1431 11         3050 $dbh->do( "INSERT INTO Models (ID, Name) VALUES (${id}, ?)", undef, $name );
1432             }
1433            
1434             }
1435              
1436             sub _table_exists {
1437 51     51   737 my $self = shift;
1438 51         93 my $name = shift;
1439 51         128 my $dbh = $self->dbh;
1440 51         2281 my $type = 'TABLE';
1441 51         239 my $sth = $dbh->table_info(undef, undef, $name, 'TABLE');
1442 51         21035 my $row = $sth->fetchrow_hashref;
1443 51 100       1205 return ref($row) ? 1 : 0;
1444             }
1445              
1446             sub _cleanup {
1447 10     10   22 my $self = shift;
1448 10 50       40 if (my $dbh = $self->dbh) {
1449 10         1713 my $name = $self->{model_name};
1450 10         46 my $id = $self->_mysql_hash( $name );
1451 10 100       380 if ($self->{ remove_store }) {
1452 2         8 $dbh->do( "DROP TABLE `Statements${id}`;" );
1453 2         479 $dbh->do( "DELETE FROM Models WHERE Name = ?", undef, $name );
1454             }
1455             }
1456             }
1457              
1458             sub _begin_bulk_ops {
1459 7     7   19 my $self = shift;
1460 7         25 my $dbh = $self->dbh;
1461 7         442 $dbh->{AutoCommit} = 0;
1462             }
1463              
1464             sub _end_bulk_ops {
1465 157     157   349 my $self = shift;
1466 157         656 my $dbh = $self->dbh;
1467 157 100       9360 unless ($dbh->{AutoCommit}) {
1468 7         156 $dbh->commit;
1469             }
1470 157         1300 $dbh->{AutoCommit} = 1;
1471             }
1472              
1473             sub DESTROY {
1474 10     10   3942 my $self = shift;
1475 10         52 our $IGNORE_CLEANUP;
1476 10 50       37 if ($IGNORE_CLEANUP) {
1477 0         0 $self->dbh->{InactiveDestroy} = 1;
1478             } else {
1479 10         56 $self->_cleanup;
1480             }
1481             }
1482              
1483             1; # Magic true value required at end of module
1484             __END__
1485              
1486             =back
1487              
1488             =head1 BUGS
1489              
1490             Please report any bugs or feature requests to through the GitHub web interface
1491             at L<https://github.com/kasei/perlrdf/issues>.
1492              
1493             =head1 AUTHOR
1494              
1495             Gregory Todd Williams C<< <gwilliams@cpan.org> >>
1496              
1497             =head1 COPYRIGHT
1498              
1499             Copyright (c) 2006-2012 Gregory Todd Williams. This
1500             program is free software; you can redistribute it and/or modify it under
1501             the same terms as Perl itself.
1502              
1503             =cut
1504              
1505              
1506              
1507              
1508              
1509              
1510             DROP TABLE Bnodes;
1511             DROP TABLE Literals;
1512             DROP TABLE Models;
1513             DROP TABLE Resources;
1514             DROP TABLE Statements15799945864759145248;
1515             CREATE TABLE Literals (
1516             ID bigint unsigned PRIMARY KEY,
1517             Value longtext NOT NULL,
1518             Language text NOT NULL,
1519             Datatype text NOT NULL
1520             );
1521             CREATE TABLE Resources (
1522             ID bigint unsigned PRIMARY KEY,
1523             URI text NOT NULL
1524             );
1525             CREATE TABLE Bnodes (
1526             ID bigint unsigned PRIMARY KEY,
1527             Name text NOT NULL
1528             );
1529             CREATE TABLE Models (
1530             ID bigint unsigned PRIMARY KEY,
1531             Name text NOT NULL
1532             );
1533             CREATE TABLE Statements15799945864759145248 (
1534             Subject bigint unsigned NOT NULL,
1535             Predicate bigint unsigned NOT NULL,
1536             Object bigint unsigned NOT NULL,
1537             Context bigint unsigned NOT NULL
1538             );
1539             INSERT INTO Models (ID,Name) VALUES (15799945864759145248, "model");