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.017
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   1594097 use strict;
  68         193  
  68         2093  
39 68     68   663 use warnings;
  68         163  
  68         2236  
40 68     68   336 no warnings 'redefine';
  68         169  
  68         2487  
41 68     68   370 use base qw(RDF::Trine::Store);
  68         154  
  68         5513  
42              
43 68     68   81382 use DBI;
  68         863723  
  68         4420  
44 68     68   37654 use DBIx::Connector;
  68         193299  
  68         1794  
45              
46 68     68   511 use Carp;
  68         179  
  68         4155  
47 68     68   637 use DBI;
  68         177  
  68         2305  
48 68     68   385 use Scalar::Util qw(blessed reftype refaddr);
  68         158  
  68         3173  
49 68     68   417 use Encode;
  68         151  
  68         4825  
50 68     68   397 use Digest::MD5 ('md5');
  68         152  
  68         2797  
51 68     68   59051 use Math::BigInt;
  68         1131579  
  68         418  
52 68     68   710545 use Data::Dumper;
  68         217  
  68         4435  
53 68     68   451 use RDF::Trine::Node;
  68         171  
  68         2190  
54 68     68   395 use RDF::Trine::Statement;
  68         167  
  68         1336  
55 68     68   350 use RDF::Trine::Statement::Quad;
  68         150  
  68         1165  
56 68     68   334 use RDF::Trine::Iterator;
  68         150  
  68         2109  
57 68     68   380 use Log::Log4perl;
  68         162  
  68         764  
58              
59 68     68   4363 use RDF::Trine::Error;
  68         168  
  68         590  
60 68     68   33166 use RDF::Trine::Store::DBI::mysql;
  68         207  
  68         1819  
61 68     68   23866 use RDF::Trine::Store::DBI::SQLite;
  68         208  
  68         1803  
62 68     68   23238 use RDF::Trine::Store::DBI::Pg;
  68         221  
  68         3522  
63              
64             ######################################################################
65              
66             our $VERSION;
67             BEGIN {
68 68     68   226 $VERSION = "1.017";
69 68         161 my $class = __PACKAGE__;
70 68         86460 $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 2166 my $class = shift;
126 11         28 my ($dbh, $conn);
127            
128 11         87 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
129            
130 11   100     3256 my $name = shift || 'model';
131 11         27 my %args;
132 11 100 66     75 if (scalar(@_) == 0) {
    100 33        
    50          
133 9         45 $l->trace("trying to construct a temporary model");
134 9         93 my $dsn = "dbi:SQLite:dbname=:memory:";
135 9         70 $conn = DBIx::Connector->new( $dsn, '', '' );
136 9         154 $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         13 $dbh = shift;
140 1         9 my $name = $dbh->get_info(17);
141 1 50       18 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         3 $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         2 my $user = shift;
153 1         2 my $pass = shift;
154 1 50       18 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         5 $class = 'RDF::Trine::Store::DBI::SQLite';
160 1         4 $user = '';
161 1         5 $pass = '';
162             }
163 1         12 $l->trace("Connecting to $dsn ($user, $pass)");
164 1         27 $conn = DBIx::Connector->new( $dsn, $user, $pass );
165 1 50       66 unless ($conn) {
166 0         0 throw RDF::Trine::Error::DatabaseError -text => "Couldn't connect to database: " . DBI->errstr;
167             }
168             }
169            
170 11         91 my $self = bless( {
171             model_name => $name,
172             dbh => $dbh,
173             conn => $conn,
174             statements_table_prefix => 'Statements',
175             %args
176             }, $class );
177 11         63 $self->init();
178 11         65 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 15 my $class = shift;
242 2         7 my $name = 'model_' . sprintf( '%x%x%x%x', map { int(rand(16)) } (1..4) );
  8         115  
243 2         14 my $self = $class->new( $name, @_ );
244 2         8 $self->{ remove_store } = 1;
245 2         9 $self->init();
246 2         12 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 188 my $self = shift;
275 81         336 my @nodes = @_[0..3];
276 81         160 my $bound = 0;
277 81         174 my %bound;
278            
279 81         157 my $use_quad = 0;
280 81 100       289 if (scalar(@_) >= 4) {
281 63         129 $use_quad = 1;
282             # warn "count statements with quad" if ($::debug);
283 63         132 my $g = $nodes[3];
284 63 100 100     301 if (blessed($g) and not($g->is_variable)) {
285 4         11 $bound++;
286 4         11 $bound{ 3 } = $g;
287             }
288             }
289            
290 81         221 my ($subj, $pred, $obj, $context) = @nodes;
291            
292 81         164 my $var = 0;
293 81         238 my $dbh = $self->dbh;
294             my $st = ($use_quad)
295 252 100       944 ? RDF::Trine::Statement::Quad->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj,$context) )
296 81 100       4048 : RDF::Trine::Statement->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj) );
  54 100       203  
297            
298 81         464 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
299            
300 81         2688 my @vars = $st->referenced_variables;
301            
302 81 100       280 my $semantics = ($use_quad ? 'quad' : 'triple');
303 81         280 local($self->{context_variable_count}) = 0;
304 81 100 100     363 local($self->{join_context_nodes}) = 1 if (blessed($context) and $context->is_variable);
305 81         313 my $sql = $self->_sql_for_pattern( $st, $context, semantics => $semantics, unique => 1 );
306 81         877 my $sth = $dbh->prepare( $sql );
307            
308 81         23356 $sth->execute();
309            
310             my $sub = sub {
311 663     663   19228 NEXTROW:
312             my $row = $sth->fetchrow_hashref;
313 663 100       3135 return unless (defined $row);
314 591         968 my @triple;
315 591         961 my $temp_var_count = 1;
316 591 100       2537 my @nodes = ($st->nodes)[ $use_quad ? (0..3) : (0..2) ];
317 591         1377 foreach my $node (@nodes) {
318 2277 100       5958 if ($node->is_variable) {
319 1933         5258 my $nodename = $node->name;
320 1933         4459 my $uri = $self->_column_name( $nodename, 'URI' );
321 1933         3685 my $name = $self->_column_name( $nodename, 'Name' );
322 1933         3626 my $value = $self->_column_name( $nodename, 'Value' );
323 1933         3562 my $node = $self->_column_name( $nodename, 'Node' );
324 1933 100       5437 if ($row->{ $node } == 0) {
    100          
    100          
    50          
325 158         581 push( @triple, RDF::Trine::Node::Nil->new() );
326             } elsif (defined( my $u = $row->{ $uri })) {
327 1704         4301 $u = decode('utf8', $u);
328 1704         56924 push( @triple, RDF::Trine::Node::Resource->new( $u ) );
329             } elsif (defined( my $n = $row->{ $name })) {
330 29         138 push( @triple, RDF::Trine::Node::Blank->new( $n ) );
331             } elsif (defined( my $v = $row->{ $value })) {
332 42         92 my @cols = map { $self->_column_name( $nodename, $_ ) } qw(Value Language Datatype);
  126         235  
333 42         160 $cols[0] = decode('utf8', $cols[0]);
334 42         1579 $cols[2] = decode('utf8', $cols[2]);
335 42         1259 push( @triple, RDF::Trine::Node::Literal->new( @{ $row }{ @cols } ) );
  42         322  
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         781 push(@triple, $node);
342             }
343             }
344            
345 591 100       2452 my $st = (@triple == 3)
346             ? RDF::Trine::Statement->new( @triple )
347             : RDF::Trine::Statement::Quad->new( @triple );
348 591         3060 return $st;
349 81         862 };
350            
351 81         640 return RDF::Trine::Iterator::Graph->new( $sub )
352             }
353              
354             sub _column_name {
355 8526     8526   11432 my $self = shift;
356 8526         15980 my @args = @_;
357 8526         15223 my $col = join('_', @args);
358 8526         15410 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 100 my $self = shift;
369 39         78 my $pattern = shift;
370 39         77 my $context = shift;
371 39         116 my %args = @_;
372            
373 39         244 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
374 39         1344 $l->trace("get_pattern called for: " . $pattern->sse);
375            
376 39 100       511 if (my $o = $args{ orderby }) {
377 19         60 my @ordering = @$o;
378 19         94 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
379 68     68   631 no warnings 'uninitialized';
  68         163  
  68         167016  
380 30 100       196 unless ($dir =~ /^(ASC|DESC)$/) {
381 3         31 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         124 my $dbh = $self->dbh;
387 36         1539 my @vars = $pattern->referenced_variables;
388 36         123 my %vars = map { $_ => 1 } @vars;
  62         168  
389            
390 36         169 my $sql = $self->_sql_for_pattern( $pattern, $context, %args );
391 36         251 $l->debug("get_pattern sql: $sql\n");
392            
393 36         678 my $sth = $dbh->prepare( $sql );
394 36         9185 $sth->execute();
395            
396             my $sub = sub {
397 110     110   2920 my $row = $sth->fetchrow_hashref;
398 110 100       534 return unless $row;
399            
400 78         149 my %bindings;
401 78         178 foreach my $nodename (@vars) {
402 164         471 my $uri = $self->_column_name( $nodename, 'URI' );
403 164         333 my $name = $self->_column_name( $nodename, 'Name' );
404 164         350 my $value = $self->_column_name( $nodename, 'Value' );
405 164 100       598 if (defined( my $u = $row->{ $uri })) {
    100          
    100          
406 80         259 $u = decode('utf8', $u);
407 80         3101 $bindings{ $nodename } = RDF::Trine::Node::Resource->new( $u );
408             } elsif (defined( my $n = $row->{ $name })) {
409 20         120 $bindings{ $nodename } = RDF::Trine::Node::Blank->new( $n );
410             } elsif (defined( my $v = $row->{ $value })) {
411 48         116 my @cols = map { $self->_column_name( $nodename, $_ ) } qw(Value Language Datatype);
  144         282  
412 48         99 my ($val,$lang,$dt) = @{ $row }{ @cols };
  48         147  
413 48         182 $val = decode('utf8', $val);
414 48         1815 $dt = decode('utf8', $dt);
415 48         1527 $bindings{ $nodename } = RDF::Trine::Node::Literal->new( $val, $lang, $dt );
416             } else {
417 16         46 $bindings{ $nodename } = undef;
418             }
419             }
420 78         399 return RDF::Trine::VariableBindings->new( \%bindings );
421 36         360 };
422            
423 36         82 my @args;
424 36 100       159 if (my $o = $args{ orderby }) {
425 16         63 my @ordering = @$o;
426 16         35 my @realordering;
427 16         113 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
428 27 100       84 if (exists $vars{ $col }) {
429 23         89 push(@realordering, $col, $dir);
430             }
431             }
432 16         54 @args = ( sorted_by => \@realordering );
433             }
434 36         318 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         127 my $stable = $self->statements_table;
449 2         61 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         15 my $sth = $dbh->prepare( $sql );
451 2         482 $sth->execute();
452             my $sub = sub {
453 8     8   183 while (my $row = $sth->fetchrow_hashref) {
454 8 50       26 return unless defined($row);
455 8         24 my $uri = $self->_column_name( 'URI' );
456 8         21 my $name = $self->_column_name( 'Name' );
457 8         20 my $value = $self->_column_name( 'Value' );
458 8         18 my $ctx = $self->_column_name( 'Context' );
459 8 100       30 if ($row->{ $ctx } == 0) {
    50          
    0          
    0          
460 2         30 next;
461             # return RDF::Trine::Node::Nil->new();
462             } elsif ($row->{ $uri }) {
463 6         29 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         11 return;
474 2         18 };
475 2         20 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 740 my $self = shift;
486 297         606 my $stmt = shift;
487 297         575 my $context = shift;
488 297         889 my $dbh = $self->dbh;
489             # Carp::confess unless (blessed($stmt));
490 297         15553 my $stable = $self->statements_table;
491 297         9240 my @nodes = $stmt->nodes;
492 297         832 my @values = map { $self->_add_node( $_ ) } @nodes;
  1091         3302  
493            
494 297 100       2167 if ($stmt->isa('RDF::Trine::Statement::Quad')) {
495 200 100       893 if (blessed($context)) {
496 2         43 throw RDF::Trine::Error::MethodInvocationError -text => "add_statement cannot be called with both a quad and a context";
497             }
498 198         1066 $context = $stmt->context;
499             } else {
500 97 100       450 push @values, ($context ? $self->_add_node($context) : 0);
501             }
502 295         1033 my $sql = "SELECT 1 FROM ${stable} WHERE Subject = ? AND Predicate = ? AND Object = ? AND Context = ?";
503 295         1445 my $sth = $dbh->prepare( $sql );
504 295         21566 $sth->execute( @values );
505 295 100       34523 unless ($sth->fetch) {
506 283         1198 my $sql = sprintf( "INSERT INTO ${stable} (Subject, Predicate, Object, Context) VALUES (?,?,?,?)" );
507 283         1401 my $sth = $dbh->prepare( $sql );
508 283         17802 $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 584 my $self = shift;
520 246         512 my $stmt = shift;
521 246         457 my $context = shift;
522 246         925 my $dbh = $self->dbh;
523 246         16902 my $stable = $self->statements_table;
524            
525 246 50       7953 unless (blessed($stmt)) {
526 0         0 throw RDF::Trine::Error::MethodInvocationError -text => "no statement passed to remove_statement";
527             }
528            
529 246 100       1511 if ($stmt->isa( 'RDF::Trine::Statement::Quad' )) {
530 178 100       747 if (blessed($context)) {
531 2         11 throw RDF::Trine::Error::MethodInvocationError -text => "remove_statement cannot be called with both a quad and a context";
532             }
533             } else {
534 68         291 my @nodes = $stmt->nodes;
535 68 100       248 if (blessed($context)) {
536 8         44 $stmt = RDF::Trine::Statement::Quad->new( @nodes[0..2], $context );
537             } else {
538 60         301 my $nil = RDF::Trine::Node::Nil->new();
539 60         355 $stmt = RDF::Trine::Statement::Quad->new( @nodes[0..2], $nil );
540             }
541             }
542            
543 244         1038 my @nodes = $stmt->nodes;
544 244         2296 my $sth = $dbh->prepare("DELETE FROM ${stable} WHERE Subject = ? AND Predicate = ? AND Object = ? AND Context = ?");
545 244         23923 my @values = map { $self->_mysql_node_hash( $_ ) } (@nodes);
  976         2817  
546 244         3395 $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 55 my $self = shift;
557 12         29 my $subj = shift;
558 12         30 my $pred = shift;
559 12         26 my $obj = shift;
560 12         28 my $context = shift;
561 12         46 my $dbh = $self->dbh;
562 12         705 my $stable = $self->statements_table;
563            
564 12         341 my (@where, @bind);
565 12         51 my @keys = qw(Subject Predicate Object Context);
566 12         44 foreach my $node ($subj, $pred, $obj, $context) {
567 48         88 my $key = shift(@keys);
568 48 100       126 if (defined($node)) {
569 14         33 push(@bind, $node);
570 14         45 push(@where, "${key} = ?");
571             }
572             }
573            
574 12         36 my $where = join(" AND ", @where);
575 12 50       129 my $sth = $dbh->prepare( join(' ', "DELETE FROM ${stable}", ($where ? "WHERE ${where}" : ())) );
576 12         902 my @values = map { $self->_mysql_node_hash( $_ ) } (@bind);
  14         60  
577 12         112 $sth->execute( @values );
578             }
579              
580             sub _add_node {
581 1099     1099   1980 my $self = shift;
582 1099         1784 my $node = shift;
583 1099         2780 my $hash = $self->_mysql_node_hash( $node );
584 1099         3402 my $dbh = $self->dbh;
585            
586 1099         58191 my @cols;
587             my $table;
588 1099         0 my %values;
589 1099 100       4059 return $hash if ($node->is_nil);
590 1089 100       3611 if ($node->is_blank) {
    100          
    50          
591 18         46 $table = "Bnodes";
592 18         57 @cols = qw(ID Name);
593 18         63 @values{ @cols } = ($hash, $node->blank_identifier);
594             } elsif ($node->is_resource) {
595 1039         2022 $table = "Resources";
596 1039         2358 @cols = qw(ID URI);
597 1039         3577 @values{ @cols } = ($hash, encode('utf8', $node->uri_value));
598             } elsif ($node->isa('RDF::Trine::Node::Literal')) {
599 32         74 $table = "Literals";
600 32         105 @cols = qw(ID Value);
601 32         130 @values{ @cols } = ($hash, encode('utf8', $node->literal_value));
602 32 100       1226 if ($node->has_language) {
    100          
603 10         28 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         33 $values{ 'Datatype' } = encode('utf8', $node->literal_datatype);
608             }
609             }
610            
611 1089         38793 my $ssql = "SELECT 1 FROM ${table} WHERE " . join(' AND ', map { join(' = ', $_, '?') } @cols);
  2196         7308  
612 1089         5557 my $sth = $dbh->prepare( $ssql );
613 1089         76173 my @values = map {"$_"} @values{ @cols };
  2196         44576  
614 1089         19793 $sth->execute( @values );
615 1089 100       10075 unless ($sth->fetch) {
616 73         405 my $sql = "INSERT INTO ${table} (" . join(', ', @cols) . ") VALUES (" . join(',',('?')x scalar(@cols)) . ")";
617 73         343 my $sth = $dbh->prepare( $sql );
618 73         123558 $sth->execute( @values );
619             }
620 1089         15079 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 497 my $self = shift;
632 189         776 my @nodes = @_[0..3];
633 189         385 my $bound = 0;
634 189         375 my %bound;
635            
636 189         356 my $use_quad = 0;
637 189 100       664 if (scalar(@_) >= 4) {
638 149         277 $use_quad = 1;
639             # warn "count statements with quad" if ($::debug);
640 149         274 my $g = $nodes[3];
641 149 100 100     829 if (blessed($g) and not($g->is_variable)) {
642 24         75 $bound++;
643 24         75 $bound{ 3 } = $g;
644             }
645             }
646            
647 189         524 my ($subj, $pred, $obj, $context) = @nodes;
648            
649 189         619 my $dbh = $self->dbh;
650 189         10424 my $var = 0;
651             my $st = ($use_quad)
652 596 100       2390 ? RDF::Trine::Statement::Quad->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj,$context) )
653 189 100       735 : RDF::Trine::Statement->new( map { defined($_) ? $_ : RDF::Trine::Node::Variable->new( 'n' . $var++ ) } ($subj, $pred, $obj) );
  120 100       546  
654 189         895 my @vars = $st->referenced_variables;
655            
656 189 100       660 my $semantics = ($use_quad ? 'quad' : 'triple');
657 189 100       518 my $countkey = ($use_quad) ? 'count' : 'count-distinct';
658 189         707 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         401 my $count;
661 189         1651 my $sth = $dbh->prepare( $sql );
662 189         39050 $sth->execute();
663 189         1434 $sth->bind_columns( \$count );
664 189         7056 $sth->fetch;
665 189         4206 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 44 my $self = shift;
704 23         40 my $var = shift;
705 23         42 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         47 my $r = $context->{restrict}{$var};
711            
712 23         41 my @cols;
713 23 100       70 push(@cols, 'Value') unless ($r->{literal});
714 23 50       66 push(@cols, 'URI') unless ($r->{resource});
715 23 100       71 push(@cols, 'Name') unless ($r->{blank});
716 23         47 return map { "${var}_$_" } @cols;
  54         138  
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 596 my $self = shift;
733 310         572 my $context = shift;
734 310         557 my $varhash = shift;
735            
736 310         1783 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
737            
738 310         10981 my @vars = keys %$varhash;
739 310         814 my %select_vars = map { $_ => 1 } @vars;
  889         2262  
740 310         651 my %variable_value_cols;
741            
742 310         661 my $vars = $context->{vars};
743 310         624 my $from = $context->{from_tables};
744 310         555 my $where = $context->{where_clauses};
745 310         821 my $stable = $self->statements_table;
746            
747 310         9162 my @cols;
748 310         704 my $uniq_count = 0;
749 310         669 my (%seen_vars, %seen_joins);
750 310         1854 foreach my $var (grep { not $seen_vars{ $_ }++ } (sort (@vars, keys %$vars))) {
  1778         4175  
751 889         1690 my $col = $vars->{ $var };
752 889 50       2133 unless ($col) {
753 0         0 throw RDF::Trine::Error::CompilationError -text => "*** Nothing is known about the variable ?${var}";
754             }
755            
756 889         2737 my $col_table = (split(/[.]/, $col))[0];
757 889         3500 my ($count) = ($col_table =~ /\w(\d+)/);
758            
759 889         4623 $l->info("var: $var\t\tcol: $col\t\tcount: $count\t\tunique count: $uniq_count");
760            
761 889 50       9827 push(@cols, "${col} AS ${var}_Node") if ($select_vars{ $var });
762 889         1601 my $restricted = 0;
763 889         1362 my @used_ljoins;
764 889         2977 foreach my $type (reverse sort keys %NODE_TYPE_TABLES) {
765 2667         4233 my ($table, $alias, @join_cols) = @{ $NODE_TYPE_TABLES{ $type } };
  2667         6759  
766 2667 100       6125 if ($context->{restrict}{$var}{$type}) {
767 666         1038 $restricted = 1;
768 666         1327 next;
769             } else {
770 2001         4394 push(@used_ljoins, "${alias}${uniq_count}.$join_cols[0]");
771             }
772 2001         3566 foreach my $jc (@join_cols) {
773 2897         5582 my $column_real_name = "${alias}${uniq_count}.${jc}";
774 2897         4771 my $column_alias_name = "${var}_${jc}";
775 2897         5667 push(@cols, "${column_real_name} AS ${column_alias_name}");
776 2897         4623 push( @{ $variable_value_cols{ $var } }, $column_real_name);
  2897         5596  
777            
778 2897         4407 foreach my $i (0 .. $#{ $where }) {
  2897         6414  
779 3183 50       19206 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         1672 foreach my $i (0 .. $#{ $from }) {
  889         1771  
788 929         1633 my $f = $from->[ $i ];
789 929 50       2863 next if ($from->[ $i ] =~ m/^[()]$/);
790 929         5228 my ($alias) = ($f =~ m/${stable} (\w\d+)/); #split(/ /, $f))[1];
791            
792 929 100       2760 if ($alias eq $col_table) {
793             # my (@tables, @where);
794 889         2813 foreach my $type (reverse sort keys %NODE_TYPE_TABLES) {
795 2667 100       6371 next if ($context->{restrict}{$var}{$type});
796 2001         2881 my ($vtable, $vname) = @{ $NODE_TYPE_TABLES{ $type } };
  2001         4073  
797 2001         3785 my $valias = join('', $vname, $uniq_count);
798 2001 50       5635 next if ($seen_joins{ $valias }++);
799            
800             # push(@tables, "${vtable} ${valias}");
801             # push(@where, "${col} = ${valias}.ID");
802 2001         6082 $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         1787 $from->[ $i ] = $f;
808 889         1808 next;
809             }
810             }
811            
812 889 100       2138 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         1007 _add_where( $context, '(' . join(' OR ', map {"$_ IS NOT NULL"} @used_ljoins) . ')' );
  657         2518  
819             }
820            
821 889         2088 $uniq_count++;
822             }
823            
824 310         2467 return (\%variable_value_cols, @cols);
825             }
826              
827             sub _sql_for_pattern {
828 310     310   670 my $self = shift;
829 310         640 my $pat = shift;
830 310         587 my $ctx_node = shift;
831 310         1152 my %args = @_;
832            
833 310         570 my @disjunction;
834 310         731 my @patterns = $pat;
835 310         577 my $variables;
836 310         1041 while (my $p = shift(@patterns)) {
837 310 50       2143 if ($p->isa('RDF::Query::Algebra::Union')) {
838 0         0 push(@patterns, $p->patterns);
839             } else {
840 310         1086 my $pvars = join('#', sort $p->referenced_variables);
841 310 50       1065 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         677 $variables = $pvars;
850             }
851 310         1116 push(@disjunction, $p);
852             }
853             }
854            
855 310         624 my @sql;
856 310         631 foreach my $pattern (@disjunction) {
857 310         1142 my $type = $pattern->type;
858 310         951 my $method = "_sql_for_" . lc($type);
859 310         962 my $context = $self->_new_context;
860            
861             # warn "*** sql compilation method $method";
862 310 50       1721 if ($self->can($method)) {
863 310         1737 $self->$method( $pattern, $ctx_node, $context, %args );
864 310         1442 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         1680 return join(' UNION ', @sql);
870             }
871              
872             sub _new_context {
873 310     310   574 my $self = shift;
874 310         992 my $context = {
875             next_alias => 0,
876             level => 0,
877             statement_table => $self->statements_table,
878             };
879 310         9819 return $context;
880             }
881              
882 68     68   647 use constant INDENT => "\t";
  68         170  
  68         93721  
883             sub _sql_from_context {
884 310     310   677 my $self = shift;
885 310         619 my $context = shift;
886 310         984 my %args = @_;
887 310         717 my $vars = $context->{vars};
888 310   50     993 my $from = $context->{from_tables} || [];
889 310   100     1290 my $where = $context->{where_clauses} || [];
890 310 100       945 my $unique = $args{'unique'} ? 1 : 0;
891            
892 310         1111 my ($varcols, @cols) = $self->add_variable_values_joins( $context, $vars );
893 310 100       1063 unless (@cols) {
894 4         14 push(@cols, 1);
895             }
896            
897 310         598 my $from_clause;
898 310         703 foreach my $f (@$from) {
899 331 50 66     1254 $from_clause .= ",\n" . INDENT if ($from_clause and $from_clause =~ m/[^(]$/ and $f !~ m/^([)]|LEFT JOIN)/);
      66        
900 331         806 $from_clause .= $f;
901             }
902            
903 310 100       1153 my $where_clause = @$where ? "WHERE\n"
904             . INDENT . join(" AND\n" . INDENT, @$where) : '';
905            
906 310 100       1005 if ($args{ count }) {
907 149         457 @cols = ('COUNT(*)');
908             }
909 310 100       895 if ($args{ 'count-distinct' }) {
910 40         82 $unique = 1;
911             }
912 310 100       869 if ($args{ 'count' }) {
913 149         337 @cols = 'COUNT(*)';
914             }
915            
916 310 100       1991 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       975 if (my $o = $args{ orderby }) {
925 16         56 my @ordering = @$o;
926 16         36 my @sort;
927 16         88 while (my ($col, $dir) = splice( @ordering, 0, 2, () )) {
928 27 100       91 if (exists $vars->{ $col }) {
929 23         86 push(@sort, map { "$_ $dir" } $self->variable_columns( $col, $context ));
  54         174  
930             }
931             }
932 16 100       54 if (@sort) {
933 12         53 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         734 my $sql = join("\n", grep {length} @sql);
  1562         2969  
940            
941 310 100       908 if ($args{ 'count-distinct' }) {
942 40         122 $sql = "SELECT COUNT(*) FROM ($sql) AS counttable";
943             }
944            
945             # warn $sql;
946 310         2743 return $sql;
947             }
948              
949 331     331   736 sub _get_level { return $_[0]{level}; }
950 331     331   1107 sub _next_alias { return $_[0]{next_alias}++; }
951 331     331   802 sub _statements_table { return $_[0]{statement_table}; };
952 331     331   615 sub _add_from { push( @{ $_[0]{from_tables} }, $_[1] ); }
  331         1247  
953 771     771   8940 sub _add_where { push( @{ $_[0]{where_clauses} }, $_[1] ); }
  771         2976  
954 907     907   2563 sub _get_var { return $_[0]{vars}{ $_[1] }; }
955 889     889   2605 sub _add_var { $_[0]{vars}{ $_[1] } = $_[2]; }
956             sub _add_restriction {
957 907     907   1469 my $context = shift;
958 907         1442 my $var = shift;
959 907         1978 my @rests = @_;
960 907         1819 foreach my $r (@rests) {
961 683         2237 $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   334 sub _sql_for_triple { &_sql_for_statement; }
1079 212     212   624 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   682 my $self = shift;
1089 331         601 my $triple = shift;
1090 331         604 my $ctx = shift;
1091 331         599 my $context = shift;
1092 331         1066 my %args = @_;
1093            
1094             my %restrictions = defined $self->{restrictions}
1095 331 50       2104 ? %{ $self->{restrictions} }
  0         0  
1096             : %default_restrictions;
1097              
1098 331         1606 my $quad = $triple->isa('RDF::Trine::Statement::Quad');
1099 68     68   608 no warnings 'uninitialized';
  68         175  
  68         47239  
1100 331 100       1315 if ($args{semantics} eq 'triple') {
1101 58         126 $quad = 0;
1102             }
1103 331 100       1289 my @posmap = ($quad)
1104             ? qw(subject predicate object context)
1105             : qw(subject predicate object);
1106 331         1043 my $table = "s" . _next_alias($context);
1107 331         1087 my $stable = _statements_table($context);
1108 331         946 my $level = _get_level( $context );
1109 331         1455 _add_from( $context, "${stable} ${table}" );
1110 331         850 foreach my $method (@posmap) {
1111 1217         4775 my $node = $triple->$method();
1112 1217 50       2918 next unless defined($node);
1113 1217         1991 my $pos = $method;
1114 1217         2437 my $col = "${table}.${pos}";
1115 1217 100       4398 if ($node->isa('RDF::Trine::Node::Variable')) {
1116 907         1413 _add_restriction( $context, $node, @{ $restrictions{ $method } } );
  907         2334  
1117             }
1118 1217         2871 $self->_add_sql_node_clause( $col, $node, $context );
1119             }
1120            
1121 331 100       1397 unless ($quad) {
1122 107 100       664 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   2061 my $self = shift;
1132 1219         1856 my $col = shift;
1133 1219         1760 my $node = shift;
1134 1219         1747 my $context = shift;
1135 1219 100       4292 if ($node->isa('RDF::Trine::Node::Variable')) {
    100          
    100          
    100          
    50          
1136 907         2234 my $name = $node->name;
1137 907 100       2100 if (my $existing_col = _get_var( $context, $name )) {
1138 18         87 _add_where( $context, "$col = ${existing_col}" );
1139             } else {
1140 889         1902 _add_var( $context, $name, $col );
1141             }
1142             } elsif ($node->isa('RDF::Trine::Node::Resource')) {
1143 249         1020 my $uri = $node->uri_value;
1144 249         753 my $id = $self->_mysql_node_hash( $node );
1145 249         759 $id =~ s/\D//;
1146 249         7338 _add_where( $context, "${col} = $id" );
1147             } elsif ($node->isa('RDF::Trine::Node::Blank')) {
1148 18         64 my $id = $self->_mysql_node_hash( $node );
1149 18         62 $id =~ s/\D//;
1150 18         601 _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         96 my $id = $self->_mysql_node_hash( $node );
1158 33         95 $id =~ s/\D//;
1159 33         975 _add_where( $context, "${col} = $id" );
1160             } elsif ($node->is_nil) {
1161 12         48 _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   71 my $self = shift;
1169 25         57 my $bgp = shift;
1170 25         57 my $ctx = shift;
1171 25         58 my $context = shift;
1172            
1173 25         95 foreach my $triple ($bgp->triples) {
1174 46         185 $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   4137 eval "use RDF::Trine::XS;";
  68     68   12870  
  0         0  
  0         0  
1223 68     68   530 no strict 'refs';
  68         173  
  68         3823  
1224 68 50       1087 *{ '_mysql_hash' } = (RDF::Trine::XS->can('hash'))
  68         8775  
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   4666 my $self = shift;
1239 2389         3700 my $node = shift;
1240            
1241             # my @node = @$node;
1242             # my ($type, $value) = splice(@node, 0, 2, ());
1243 2389 50       10181 return 0 unless (blessed($node));
1244 2389 100       8940 return 0 if ($node->is_nil);
1245            
1246 2317         4703 my $data;
1247 2317 100       7769 if ($node->isa('RDF::Trine::Node::Resource')) {
    100          
    50          
1248 2194         7415 my $value = $node->uri_value;
1249 2194         5272 $data = 'R' . $value;
1250             } elsif ($node->isa('RDF::Trine::Node::Blank')) {
1251 44         200 my $value = $node->blank_identifier;
1252 44         126 $data = 'B' . $value;
1253             } elsif ($node->isa('RDF::Trine::Node::Literal')) {
1254 79         344 my $value = $node->literal_value;
1255 79 50       254 unless (defined($value)) {
1256 0         0 $value = '';
1257             }
1258 79   100     284 my $lang = $node->literal_value_language || '';
1259 79   100     260 my $dt = $node->literal_datatype || '';
1260 68     68   461 no warnings 'uninitialized';
  68         169  
  68         59642  
1261 79         383 $data = sprintf("L%s<%s>%s", $value, $lang, $dt);
1262             # warn "($data)";
1263             } else {
1264 0         0 return;
1265             }
1266 2317         3571 my $hash;
1267 2317         6654 $hash = $self->_mysql_hash( $data );
1268 2317         6701 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 2220 my $self = shift;
1279 1177         3278 my $model = $self->model_name;
1280 1177         3985 my $id = $self->_mysql_hash( $model );
1281 1177         3403 my $prefix = $self->{statements_table_prefix};
1282 1177         4092 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 2178 my $self = shift;
1316             # Carp::confess unless (blessed($self));
1317 1211         2932 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 4015 my $self = shift;
1352 2221 100       7334 if (my $conn = $self->{conn}) {
1353 2113         8043 return $conn->dbh;
1354             } else {
1355 108         199 my $dbh = $self->{dbh};
1356 108         244 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 39 my $self = shift;
1383 17         49 my $dbh = $self->dbh;
1384 17         927 my $name = $self->model_name;
1385 17         67 my $id = $self->_mysql_hash( $name );
1386 17         113 my $l = Log::Log4perl->get_logger("rdf.trine.store.dbi");
1387 17         739 local($dbh->{AutoCommit}) = 0;
1388            
1389 17 100       291 unless ($self->_table_exists("Literals")) {
1390 11 50       87 $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       2728 $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       2149 $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       2183 $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       26987 $dbh->commit or warn $dbh->errstr;
1418             }
1419            
1420 17 100       147 unless ($self->_table_exists("Statements${id}")) {
1421 11 50       74 $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         3353 $dbh->do( "INSERT INTO Models (ID, Name) VALUES (${id}, ?)", undef, $name );
1432             }
1433            
1434             }
1435              
1436             sub _table_exists {
1437 51     51   825 my $self = shift;
1438 51         112 my $name = shift;
1439 51         156 my $dbh = $self->dbh;
1440 51         2586 my $type = 'TABLE';
1441 51         267 my $sth = $dbh->table_info(undef, undef, $name, 'TABLE');
1442 51         22914 my $row = $sth->fetchrow_hashref;
1443 51 100       1232 return ref($row) ? 1 : 0;
1444             }
1445              
1446             sub _cleanup {
1447 10     10   24 my $self = shift;
1448 10 50       36 if (my $dbh = $self->dbh) {
1449 10         1516 my $name = $self->{model_name};
1450 10         45 my $id = $self->_mysql_hash( $name );
1451 10 100       349 if ($self->{ remove_store }) {
1452 2         11 $dbh->do( "DROP TABLE `Statements${id}`;" );
1453 2         473 $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         27 my $dbh = $self->dbh;
1461 7         424 $dbh->{AutoCommit} = 0;
1462             }
1463              
1464             sub _end_bulk_ops {
1465 157     157   302 my $self = shift;
1466 157         480 my $dbh = $self->dbh;
1467 157 100       8316 unless ($dbh->{AutoCommit}) {
1468 7         147 $dbh->commit;
1469             }
1470 157         1113 $dbh->{AutoCommit} = 1;
1471             }
1472              
1473             sub DESTROY {
1474 10     10   4068 my $self = shift;
1475 10         26 our $IGNORE_CLEANUP;
1476 10 50       33 if ($IGNORE_CLEANUP) {
1477 0         0 $self->dbh->{InactiveDestroy} = 1;
1478             } else {
1479 10         54 $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");