File Coverage

blib/lib/NoSQL/PL2SQL/DBI.pm
Criterion Covered Total %
statement 13 19 68.4
branch n/a
condition n/a
subroutine 5 7 71.4
pod n/a
total 18 26 69.2


line stmt bran cond sub pod time code
1             package NoSQL::PL2SQL::DBI::Null ;
2              
3             sub AUTOLOAD {
4 0     0     my $self = shift ;
5 0           my $sql = shift ;
6 0           return $sql ;
7             }
8              
9 0     0     sub DESTROY {}
10              
11             package NoSQL::PL2SQL::DBI ;
12              
13 1     1   29 use 5.008009;
  1         4  
  1         38  
14 1     1   7 use strict;
  1         1  
  1         36  
15 1     1   6 use warnings;
  1         3  
  1         29  
16 1     1   318523 use DBI ;
  1         21126  
  1         77  
17 1     1   3445 use XML::Parser::Nodes ;
  0            
  0            
18              
19             require Exporter;
20              
21             our @ISA = qw(Exporter);
22              
23             # Items to export into callers namespace by default. Note: do not export
24             # names by default without a very good reason. Use EXPORT_OK instead.
25             # Do not simply export all your public functions/methods/constants.
26              
27             # This allows declaration use NoSQL::PL2SQL::Node ':all';
28             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
29             # will save memory.
30             our %EXPORT_TAGS = ( 'all' => [ qw() ] ) ;
31              
32             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;
33              
34             our @EXPORT = qw() ;
35              
36             our $VERSION = '0.12';
37              
38             # Preloaded methods go here.
39              
40             my @sqllog ;
41             my $nulldbi = bless \( my $null = 'NoSQL::PL2SQL::DBI::Null' ),
42             'NoSQL::PL2SQL::DBI::Null' ;
43              
44             ## I started looking for an XML based schema that is implementation
45             ## independent. This one, my own invention and based on MySQL, was
46             ## originally a placeholder. Suffice that it remains a TODO...
47              
48             my $xmlschema =<<'endschema' ;
49            
50            
51            
52            
53            
54            
55            
56            
57            
58            
59            
60            
61            
62            
63            
64            
65            
66            
67            
68            
69            
70            
71            
72            
73            
74            
75            
76            
77            
78            
79            
80            
81            
82            
83            
84            
85            
86            
87            
88            
89            
90             endschema
91              
92             my $indexschema =<<'endschema' ;
93            
94            
95            
96            
97            
98            
99            
100            
101            
102            
103            
104            
105            
106            
107            
108            
109            
110            
111            
112            
113            
114            
115            
116            
117             endschema
118              
119             sub schema {
120             my $self = shift ;
121             my $package = ref $self || $self ;
122             my $schema = @_? shift( @_ ): $xmlschema ;
123              
124             my $nodes = bless XML::Parser::Nodes->new( $schema ),
125             join( '::', $package, 'Schema' ) ;
126              
127             return $nodes->schema ;
128             }
129              
130             ## indexschema is used by NoSQL::PL2SQL::Simple. No one has expressed
131             ## an intention of another DBI implementation. Since I can get away with
132             ## it, I'm arbitrarily extending this definition, and I really shouldn't.
133             ## In the future apps, will have to create their own database specific
134             ## subclasses: NoSQL::PL2SQL::Simple::MySQL, etc.
135              
136             sub indexschema {
137             return $indexschema ;
138             }
139              
140             sub sqldump {
141             shift @_ ;
142             @sqllog = () if @_ ;
143             return @sqllog ;
144             }
145              
146             sub debug {
147             push @sqllog, $_[-1] if @_ ;
148             }
149              
150             sub sqlstatement {
151             my $self = shift ;
152             my $sprintf = shift ;
153              
154             my $ct = 0 ;
155             $ct++ while $sprintf =~ /%s/g ;
156             return sprintf $sprintf, ( $self->[1] ) x$ct ;
157             }
158              
159             sub do {
160             my $self = shift ;
161             push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
162             return $self->db->do( $sql ) ;
163             }
164              
165             sub rows_hash {
166             my $self = shift ;
167             push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
168             my $st = $self->db->prepare( $sql ) ;
169             $st->execute ;
170             my @out = () ;
171             my $o ;
172             push @out, { %$o } while $o = $st->fetchrow_hashref ;
173             return $out[0] unless wantarray ;
174             return @out ;
175             }
176              
177             sub rows_array {
178             my $self = shift ;
179             push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
180             my $st = $self->db->prepare( $sql ) ;
181             $st->execute ;
182             my @out = () ;
183             my $o ;
184             push @out, [ @$o ] while $o = $st->fetchrow_arrayref ;
185             return $out[0] unless wantarray ;
186             return @out ;
187             }
188              
189             sub new {
190             my $package = shift ;
191             my $tablename = shift( @_ ) || '%s' ;
192              
193             if ( ref $package ) {
194             $tablename = $package->table ;
195             $package = ref $package ;
196             }
197              
198             return bless [ $nulldbi, $tablename ], $package ;
199             }
200              
201             sub connect {
202             my $self = shift ;
203             my $ref = $self ;
204             $ref = $ref->[0] while ref $ref eq ref $self
205             && ref $ref->[0] eq ref $self ;
206             $ref->[0] = DBI->connect( @_ ) ;
207             return $self ;
208             }
209              
210             sub table {
211             my $self = shift ;
212             return $self->[1] unless @_ ;
213              
214             my $package = ref $self ;
215             my $out = $package->new( @_ ) ;
216             $out->[0] = $self ;
217             return $out ;
218             }
219              
220             sub db {
221             my $self = shift ;
222             return ref $self->[0] eq ref $self? $self->[0]->db: $self->[0] ;
223             }
224              
225             sub dbconnected {
226             my $self = shift ;
227             my $db = $self->db ;
228             my $unconnected = $db->isa('SCALAR') && $$db eq ref $db ;
229             return ! $unconnected ;
230             }
231              
232             ## Implementation Specific
233             ## optionally pass a scalar integer- otherwise same arguments as fetch()
234             sub delete {
235             my $self = shift ;
236             my @delete = ref $_[0]? @_: ( [ id => $_[0] ] ) ;
237             return $self->fetch( 'DELETE FROM %s WHERE', @delete ) ;
238             }
239              
240             ## Implementation Specific
241             sub lastinsertid {
242             my $self = shift ;
243             my $db = $self->db ;
244             return ! $self->dbconnected? 0:
245             $db->last_insert_id(
246             undef, undef, $self->table, 'id' ) ;
247             }
248              
249             ## Implementation Specific
250             sub sqlupdate {
251             my $self = shift ;
252             my $nvp = shift ;
253             my $sql = sprintf 'UPDATE %s SET %s WHERE', '%s', $nvp ;
254             return $self->fetch( $sql, @_ ) ;
255             }
256              
257             ## update() method is used for SQL "INSERT" and "UPDATE" constructions.
258             ## Implementation Specific. Default method is MySQL syntax.
259             sub update {
260             my $self = shift ;
261             my $id = shift ;
262              
263             ## Each subsequent argument is an NVP array reference. An optional
264             ## third element, if true, indicates a string value
265              
266             my @pairsf = ( '%s=%s', '%s="%s"', '%s=NULL' ) ;
267             my @termsf = ( '%s', '"%s"', 'NULL' ) ;
268              
269             my $keys = join ',', map { $_->[0] } @_ ;
270             my $values = join ',', map {
271             sprintf $termsf[ defined $_->[1]?
272             $_->[2] || length $_->[1] == 0: 2 ],
273             $self->stringencode( $_->[1], ! $_->[2] ) ;
274             } @_ ;
275             my $nvp = join ',', map {
276             sprintf $pairsf[ defined $_->[1]?
277             $_->[2] || length $_->[1] == 0: 2 ],
278             $_->[0], $self->stringencode( $_->[1], ! $_->[2] )
279             } @_ ;
280              
281             ## User data should never be passed to sqlstatement()
282             my $update = $self->sqlstatement( 'UPDATE %s' ) ;
283             my $insert = $self->sqlstatement( 'INSERT INTO %s' ) ;
284             my $sql = defined $id?
285             "$update SET $nvp WHERE id=$id":
286             "$insert ($keys) VALUES ($values)" ;
287             $self->debug( $sql ) if $self->dbconnected ;
288             my $sqlresults = $self->db->do( $sql ) ; ## do not combine
289             return { id => $id || $self->lastinsertid,
290             sqlresults => $sqlresults,
291             nvp => $nvp
292             } ;
293             }
294              
295             sub insert {
296             my $self = shift ;
297             return $self->update( undef, @_ ) ;
298             }
299              
300             sub exclude {
301             shift @_ ;
302             my $package = join '::', __PACKAGE__, 'exclude' ;
303             my @out = map { bless $_, $package } @_ ;
304             return wantarray? @out: $out[0] ;
305             }
306              
307             ## Implementation Specific. Default method is MySQL syntax.
308             sub fetch {
309             my $self = shift ;
310             my $delete = ( @_ && ! ref $_[0] )? shift( @_ ): undef ;
311              
312             my @pairsf = ( '%s=%s', '%s="%s"', '%s=NULL' ) ;
313             my @invert = ( '%s!=%s', '%s!="%s"', '%s NOT NULL' ) ;
314              
315             my $exclude = ref $self->exclude( [] ) ;
316              
317             my @terms = () ;
318             foreach ( @_ ) {
319             my @how = ref $_ eq $exclude? @invert: @pairsf ;
320             push @terms, sprintf
321             $how[ defined $_->[1]?
322             $_->[2] || length $_->[1] == 0: 2 ],
323             $_->[0],
324             $self->stringencode( $_->[1], ! $_->[2] ) ;
325             }
326              
327             my $sql = join ' ', $delete || 'SELECT * FROM %s WHERE',
328             join ' AND ', @terms ;
329             return $self->do( $sql ) if defined $delete || ! $self->dbconnected ;
330              
331             my @out = $self->rows_hash( $sql ) ;
332             return wantarray? @out: { map { $_->{id} => $_ } @out } ;
333             }
334              
335             ## Implementation Specific. Default method is MySQL syntax.
336             sub stringencode {
337             my $self = shift ;
338             my $text = shift ;
339             return $text unless defined $text ;
340             return $text if @_ && $_[0] ;
341             $text =~ s/"/""/gs ;
342             $text =~ s/\\/\\\\/gs ;
343             return $text ;
344             }
345              
346             sub AUTOLOAD {
347             my $self = shift ;
348             my $sql = shift ;
349             my $package = ref $self ;
350              
351             use vars qw( $AUTOLOAD ) ;
352             my $func = $AUTOLOAD ;
353             $func =~ s/^${package}::// ;
354             return if $func eq 'DESTROY' ;
355              
356             my $cmd = sprintf '$self->db->%s( sprintf $sql || "", $self->table )',
357             $func ;
358             return eval $cmd ;
359             }
360              
361             sub loadschema {
362             my $self = shift ;
363             return map { $self->do( $_ ) } $self->schema( @_ ) ;
364             }
365              
366              
367             package NoSQL::PL2SQL::DBI::Schema ;
368             use base qw( XML::Parser::Nodes ) ;
369              
370             sub schema {
371             shift @_ unless ref $_[0] ;
372             my $self = shift ;
373              
374             my @mysql = $self->childnode('mysql') ;
375             return map { $self->new( $_ )->schema }
376             @mysql? $mysql[0]->childnodes: $self->childnodes ;
377             }
378              
379             sub new {
380             my $self = shift ;
381             my $nodechild = shift ;
382             my $package = ref $self ;
383             my @package = () ;
384              
385             my @nodenames = () ;
386             my @refself = split /::/, $package ;
387             push @nodenames, pop @refself
388             while @refself && $refself[-1] ne 'Schema' ;
389              
390             push @package, join '::', $package, $nodechild->[0] ;
391             return bless $nodechild->[1], $package[-1]
392             if eval join '', '@', $package[-1], '::ISA' ;
393              
394             push @package, join '::', __PACKAGE__, @nodenames, $nodechild->[0] ;
395             return bless $nodechild->[1], $package[-1]
396             if eval join '', '@', $package[-1], '::ISA' ;
397              
398             return bless $nodechild->[1], join '::', @refself ;
399             }
400              
401             sub command {
402             my $self = shift ;
403             my $command = $self->getattributes->{command} || '' ;
404              
405             return eval sprintf '$self->%s()', $command if $command ;
406             }
407              
408             ## Example Base Node Schemas
409             #
410             # package NoSQL::PL2SQL::DBI::Schema::table ;
411             # use base qw( NoSQL::PL2SQL::DBI::Schema ) ;
412             #
413             # sub schema {
414             # shift @_ unless ref $_[0] ;
415             # my $self = shift ;
416             #
417             # ## default table definition
418             # }
419             #
420             # package NoSQL::PL2SQL::DBI::Schema::index ;
421             # use base qw( NoSQL::PL2SQL::DBI::Schema ) ;
422             #
423             # sub schema {
424             # shift @_ unless ref $_[0] ;
425             # my $self = shift ;
426             #
427             # ## default index definition
428             # }
429             #
430             1;
431             __END__