File Coverage

blib/lib/DBI/SQL/Nano.pm
Criterion Covered Total %
statement 387 450 86.0
branch 161 252 63.8
condition 66 121 54.5
subroutine 39 49 79.5
pod n/a
total 653 872 74.8


line stmt bran cond sub pod time code
1             #######################################################################
2             #
3             # DBI::SQL::Nano - a very tiny SQL engine
4             #
5             # Copyright (c) 2010 by Jens Rehsack < rehsack AT cpan.org >
6             # Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
7             #
8             # All rights reserved.
9             #
10             # You may freely distribute and/or modify this module under the terms
11             # of either the GNU General Public License (GPL) or the Artistic License,
12             # as specified in the Perl README file.
13             #
14             # See the pod at the bottom of this file for help information
15             #
16             #######################################################################
17              
18             #######################
19             package DBI::SQL::Nano;
20             #######################
21 54     54   364 use strict;
  54         106  
  54         1578  
22 54     54   304 use warnings;
  54         132  
  54         1581  
23 54     54   277 use vars qw( $VERSION $versions );
  54         114  
  54         2482  
24              
25 54     54   295 use Carp qw(croak);
  54         106  
  54         8175  
26              
27             require DBI; # for looks_like_number()
28              
29             BEGIN
30             {
31 54     54   245 $VERSION = "1.015544";
32              
33 54         201 $versions->{nano_version} = $VERSION;
34 54 50 66     519 if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.400' } )
  30         4537  
  0         0  
35             {
36 54         1400 @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
37 54         3236 @DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
38             }
39             else
40             {
41 0         0 @DBI::SQL::Nano::Statement::ISA = qw( SQL::Statement );
42 0         0 @DBI::SQL::Nano::Table::ISA = qw( SQL::Eval::Table);
43 0         0 $versions->{statement_version} = $SQL::Statement::VERSION;
44             }
45             }
46              
47             ###################################
48             package DBI::SQL::Nano::Statement_;
49             ###################################
50              
51 54     54   337 use Carp qw(croak);
  54         118  
  54         2446  
52 54     54   337 use Errno;
  54         114  
  54         253675  
53              
54             if ( eval { require Clone; } )
55             {
56             Clone->import("clone");
57             }
58             else
59             {
60             require Storable; # in CORE since 5.7.3
61             *clone = \&Storable::dclone;
62             }
63              
64             sub new
65             {
66 750     750   1975 my ( $class, $sql ) = @_;
67 750         1423 my $self = {};
68 750         1410 bless $self, $class;
69 750         2188 return $self->prepare($sql);
70             }
71              
72             #####################################################################
73             # PREPARE
74             #####################################################################
75             sub prepare
76             {
77 750     750   1697 my ( $self, $sql ) = @_;
78 750         3415 $sql =~ s/\s+$//;
79 750         1630 $sql =~ s/\s*;$//;
80 750         1899 for ($sql)
81             {
82             /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is
83             && do
84 750 100       2798 {
85 86         341 $self->{command} = 'CREATE';
86 86         312 $self->{table_name} = $1;
87             defined $2 and $2 ne "" and
88 86 50 33     837 $self->{column_names} = parse_coldef_list($2);
89 86 50       328 $self->{column_names} or croak "Can't find columns";
90             };
91             /^\s*DROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.*?)\s*$/is
92             && do
93 750 100       3355 {
94 128         536 $self->{command} = 'DROP';
95 128         461 $self->{table_name} = $2;
96             defined $1 and $1 ne "" and
97 128 100 66     795 $self->{ignore_missing_table} = 1;
98             };
99             /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is
100             && do
101 750 100       3116 {
102 160         632 $self->{command} = 'SELECT';
103             defined $1 and $1 ne "" and
104 160 50 33     1417 $self->{column_names} = parse_comma_list($1);
105 160 50       558 $self->{column_names} or croak "Can't find columns";
106 160         539 $self->{table_name} = $2;
107 160 100       761 if ( my $clauses = $4 )
108             {
109 58 100       368 if ( $clauses =~ /^(.*)\s+ORDER\s+BY\s+(.*)$/is )
110             {
111 48         128 $clauses = $1;
112 48         414 $self->{order_clause} = $self->parse_order_clause($2);
113             }
114 58 100       1333 $self->{where_clause} = $self->parse_where_clause($clauses) if ($clauses);
115             }
116             };
117             /^\s*INSERT\s+(?:INTO\s+)?(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
118             && do
119 750 100       2963 {
120 214         754 $self->{command} = 'INSERT';
121 214         684 $self->{table_name} = $1;
122             defined $2 and $2 ne "" and
123 214 100 66     967 $self->{column_names} = parse_comma_list($2);
124             defined $4 and $4 ne "" and
125 214 50 33     2625 $self->{values} = $self->parse_values_list($4);
126 214 50       729 $self->{values} or croak "Can't parse values";
127             };
128             /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is
129             && do
130 750 100       2526 {
131 68         224 $self->{command} = 'DELETE';
132 68         201 $self->{table_name} = $1;
133             defined $3 and $3 ne "" and
134 68 100 66     659 $self->{where_clause} = $self->parse_where_clause($3);
135             };
136             /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is
137             && do
138 750 100       2678 {
139 46         177 $self->{command} = 'UPDATE';
140 46         175 $self->{table_name} = $1;
141 46 50 33     597 defined $2 and $2 ne "" and
142             $self->parse_set_clause($2);
143             defined $3 and $3 ne "" and
144 46 50 33     440 $self->{where_clause} = $self->parse_where_clause($3);
145             };
146             }
147 750 100 66     10625 croak "Couldn't parse" unless ( $self->{command} and $self->{table_name} );
148 702         2471 return $self;
149             }
150              
151             sub parse_order_clause
152             {
153 48     48   189 my ( $self, $str ) = @_;
154 48         207 my @clause = split /\s+/, $str;
155 48 100       270 return { $clause[0] => 'ASC' } if ( @clause == 1 );
156 12 50       37 croak "Bad ORDER BY clause '$str'" if ( @clause > 2 );
157 12   50     36 $clause[1] ||= '';
158 12 50 33     131 return { $clause[0] => uc $clause[1] }
159             if $clause[1] =~ /^ASC$/i
160             or $clause[1] =~ /^DESC$/i;
161 0         0 croak "Bad ORDER BY clause '$clause[1]'";
162             }
163              
164             sub parse_coldef_list
165             { # check column definitions
166 86     86   182 my @col_defs;
167 86         443 for ( split ',', shift )
168             {
169 164         462 my $col = clean_parse_str($_);
170 164 50       1597 if ( $col =~ /^(\S+?)\s+.+/ )
171             { # doesn't check what it is
172 164         378 $col = $1; # just checks if it exists
173             }
174             else
175             {
176 0         0 croak "No column definition for '$_'";
177             }
178 164         405 push @col_defs, $col;
179             }
180 86         280 return \@col_defs;
181             }
182              
183             sub parse_comma_list
184             {
185 192     192   898 [ map { clean_parse_str($_) } split( ',', shift ) ];
  284         697  
186             }
187 874     874   1599 sub clean_parse_str { local $_ = shift; s/\(//; s/\)//; s/^\s+//; s/\s+$//; $_; }
  874         1657  
  874         1404  
  874         1990  
  874         1880  
  874         3288  
188              
189             sub parse_values_list
190             {
191 214     214   820 my ( $self, $str ) = @_;
192 214         891 [ map { $self->parse_value( clean_parse_str($_) ) } split( ',', $str ) ];
  426         1043  
193             }
194              
195             sub parse_set_clause
196             {
197 46     46   101 my $self = shift;
198 46         194 my @cols = split /,/, shift;
199 46         107 my $set_clause;
200 46         148 for my $col (@cols)
201             {
202 46         332 my ( $col_name, $value ) = $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s;
203 46         125 push @{ $self->{column_names} }, $col_name;
  46         188  
204 46         98 push @{ $self->{values} }, $self->parse_value($value);
  46         212  
205             }
206 46 50 33     342 croak "Can't parse set clause" unless ( $self->{column_names} and $self->{values} );
207             }
208              
209             sub parse_value
210             {
211 652     652   1332 my ( $self, $str ) = @_;
212 652 50       1390 return unless ( defined $str );
213 652         1371 $str =~ s/\s+$//;
214 652         1215 $str =~ s/^\s+//;
215 652 100       1574 if ( $str =~ /^\?$/ )
216             {
217 164         252 push @{ $self->{params} }, '?';
  164         449  
218             return {
219 164         869 value => '?',
220             type => 'placeholder'
221             };
222             }
223             return {
224 488 100       1115 value => undef,
225             type => 'NULL'
226             } if ( $str =~ /^NULL$/i );
227             return {
228 476 100       2240 value => $1,
229             type => 'string'
230             } if ( $str =~ /^'(.+)'$/s );
231             return {
232 300 100       1375 value => $str,
233             type => 'number'
234             } if ( DBI::looks_like_number($str) );
235             return {
236 110         542 value => $str,
237             type => 'column'
238             };
239             }
240              
241             sub parse_where_clause
242             {
243 90     90   298 my ( $self, $str ) = @_;
244 90         333 $str =~ s/\s+$//;
245 90 50       397 if ( $str =~ /^\s*WHERE\s+(.*)/i )
246             {
247 90         231 $str = $1;
248             }
249             else
250             {
251 0         0 croak "Couldn't find WHERE clause in '$str'";
252             }
253 90         317 my ($neg) = $str =~ s/^\s*(NOT)\s+//is;
254 90         180 my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS';
255 90         1670 my ( $val1, $op, $val2 ) = $str =~ /^(.+?)\s*($opexp)\s*(.+)\s*$/iso;
256 90 50 33     628 croak "Couldn't parse WHERE expression '$str'" unless ( defined $val1 and defined $op and defined $val2 );
      33        
257             return {
258 90         275 arg1 => $self->parse_value($val1),
259             arg2 => $self->parse_value($val2),
260             op => $op,
261             neg => $neg,
262             };
263             }
264              
265             #####################################################################
266             # EXECUTE
267             #####################################################################
268             sub execute
269             {
270 502     502   1235 my ( $self, $data, $params ) = @_;
271 502         1077 my $num_placeholders = $self->params;
272 502   100     1944 my $num_params = scalar @$params || 0;
273 502 50       1339 croak "Number of params '$num_params' does not match number of placeholders '$num_placeholders'"
274             unless ( $num_placeholders == $num_params );
275 502 100       1465 if ( scalar @$params )
276             {
277 64         151 for my $i ( 0 .. $#{ $self->{values} } )
  64         262  
278             {
279 120 50       371 if ( $self->{values}->[$i]->{type} eq 'placeholder' )
280             {
281 120         313 $self->{values}->[$i]->{value} = shift @$params;
282             }
283             }
284 64 50       241 if ( $self->{where_clause} )
285             {
286 0 0       0 if ( $self->{where_clause}->{arg1}->{type} eq 'placeholder' )
287             {
288 0         0 $self->{where_clause}->{arg1}->{value} = shift @$params;
289             }
290 0 0       0 if ( $self->{where_clause}->{arg2}->{type} eq 'placeholder' )
291             {
292 0         0 $self->{where_clause}->{arg2}->{value} = shift @$params;
293             }
294             }
295             }
296 502         1064 my $command = $self->{command};
297 502         3030 ( $self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'}, $self->{'data'}, ) = $self->$command( $data, $params );
298 470   66     3030 $self->{NAME} ||= $self->{column_names};
299 470   100     3922 return $self->{'NUM_OF_ROWS'} || '0E0';
300             }
301              
302             my $enoentstr = "Cannot open .*\(" . Errno::ENOENT . "\)";
303             my $enoentrx = qr/$enoentstr/;
304              
305             sub DROP ($$$)
306             {
307 120     120   333 my ( $self, $data, $params ) = @_;
308              
309 120         256 my $table;
310             my @err;
311 120         218 eval {
312 120     0   870 local $SIG{__WARN__} = sub { push @err, @_ };
  0         0  
313 120         522 ($table) = $self->open_tables( $data, 0, 1 );
314             };
315 120 100 66     3855 if ( $self->{ignore_missing_table} and ( $@ or @err ) and grep { $_ =~ $enoentrx } ( @err, $@ ) )
  40   100     526  
      66        
316             {
317 40         122 $@ = '';
318 40         230 return ( -1, 0 );
319             }
320              
321 80 100 33     1162 croak( $@ || $err[0] ) if ( $@ || @err );
      66        
322 72 50       254 return ( -1, 0 ) unless $table;
323              
324 72         441 $table->drop($data);
325 72         414 ( -1, 0 );
326             }
327              
328             sub CREATE ($$$)
329             {
330 66     66   205 my ( $self, $data, $params ) = @_;
331 66         283 my $table = $self->open_tables( $data, 1, 1 );
332 66         424 $table->push_names( $data, $self->{column_names} );
333 66         721 ( 0, 0 );
334             }
335              
336             sub INSERT ($$$)
337             {
338 142     142   365 my ( $self, $data, $params ) = @_;
339 142         452 my $table = $self->open_tables( $data, 0, 1 );
340 134         841 $self->verify_columns($table);
341 134         289 my $all_columns = $table->{col_names};
342 134 50       1204 $table->seek( $data, 0, 2 ) unless ( $table->can('insert_one_row') );
343 134         305 my ($array) = [];
344 134         295 my ( $val, $col, $i );
345 134 50       411 $self->{column_names} = $table->col_names() unless ( $self->{column_names} );
346 134 50       398 my $cNum = scalar( @{ $self->{column_names} } ) if ( $self->{column_names} );
  134         332  
347 134         239 my $param_num = 0;
348              
349 134 50       398 $cNum or
350             croak "Bad col names in INSERT";
351              
352 134         262 my $maxCol = $#$all_columns;
353              
354 134         516 for ( $i = 0; $i < $cNum; $i++ )
355             {
356 268         520 $col = $self->{column_names}->[$i];
357 268         847 $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i);
358             }
359              
360             # Extend row to put values in ALL fields
361 134 50       398 $#$array < $maxCol and $array->[$maxCol] = undef;
362              
363 134 100       1032 $table->can('insert_new_row') ? $table->insert_new_row( $data, $array ) : $table->push_row( $data, $array );
364              
365 134         660 return ( 1, 0 );
366             }
367              
368             sub DELETE ($$$)
369             {
370 36     36   116 my ( $self, $data, $params ) = @_;
371 36         143 my $table = $self->open_tables( $data, 0, 1 );
372 28         115 $self->verify_columns($table);
373 28         61 my ($affected) = 0;
374 28         53 my ( @rows, $array );
375 28         149 my $can_dor = $table->can('delete_one_row');
376 28         128 while ( $array = $table->fetch_row($data) )
377             {
378 102 100       317 if ( $self->eval_where( $table, $array ) )
379             {
380 60         91 ++$affected;
381 60 100       136 if ( $self->{fetched_from_key} )
382             {
383 8         24 $array = $self->{fetched_value};
384 8         41 $table->delete_one_row( $data, $array );
385 8         59 return ( $affected, 0 );
386             }
387 52 100       196 push( @rows, $array ) if ($can_dor);
388             }
389             else
390             {
391 42 100       134 push( @rows, $array ) unless ($can_dor);
392             }
393             }
394 20 100       67 if ($can_dor)
395             {
396 16         42 foreach $array (@rows)
397             {
398 48         156 $table->delete_one_row( $data, $array );
399             }
400             }
401             else
402             {
403 4         28 $table->seek( $data, 0, 0 );
404 4         8 foreach $array (@rows)
405             {
406 2         7 $table->push_row( $data, $array );
407             }
408 4         10 $table->truncate($data);
409             }
410 20         124 return ( $affected, 0 );
411             }
412              
413             sub _anycmp($$;$)
414             {
415 64     64   151 my ( $a, $b, $case_fold ) = @_;
416              
417 64 50 33     447 if ( !defined($a) || !defined($b) )
    50 33        
418             {
419 0         0 return defined($a) - defined($b);
420             }
421             elsif ( DBI::looks_like_number($a) && DBI::looks_like_number($b) )
422             {
423 64         163 return $a <=> $b;
424             }
425             else
426             {
427 0 0 0     0 return $case_fold ? lc($a) cmp lc($b) || $a cmp $b : $a cmp $b;
428             }
429             }
430              
431             sub SELECT ($$$)
432             {
433 104     104   322 my ( $self, $data, $params ) = @_;
434 104         415 my $table = $self->open_tables( $data, 0, 0 );
435 96         619 $self->verify_columns($table);
436 96         251 my $tname = $self->{table_name};
437 96         224 my ($affected) = 0;
438 96         225 my ( @rows, %cols, $array, $val, $col, $i );
439 96         472 while ( $array = $table->fetch_row($data) )
440             {
441 202 50       1038 if ( $self->eval_where( $table, $array ) )
442             {
443 202 50       510 $array = $self->{fetched_value} if ( $self->{fetched_from_key} );
444 202 100       520 unless ( keys %cols )
445             {
446 96         269 my $col_nums = $self->column_nums($table);
447 96         238 %cols = reverse %{$col_nums};
  96         494  
448             }
449              
450 202         396 my $rowhash;
451 202         725 for ( sort keys %cols )
452             {
453 378         1096 $rowhash->{ $cols{$_} } = $array->[$_];
454             }
455 202         357 my @newarray;
456 202         394 for ( $i = 0; $i < @{ $self->{column_names} }; $i++ )
  580         1277  
457             {
458 378         623 $col = $self->{column_names}->[$i];
459 378         818 push @newarray, $rowhash->{$col};
460             }
461 202         407 push( @rows, \@newarray );
462 0         0 return ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows )
463 202 50       888 if ( $self->{fetched_from_key} );
464             }
465             }
466 96 100       443 if ( $self->{order_clause} )
467             {
468 32         66 my ( $sort_col, $desc ) = each %{ $self->{order_clause} };
  32         146  
469 32         138 my @sortCols = ( $self->column_nums( $table, $sort_col, 1 ) );
470 32 100       138 $sortCols[1] = uc $desc eq 'DESC' ? 1 : 0;
471              
472             @rows = sort {
473 32         183 my ( $result, $colNum, $desc );
  64         114  
474 64         92 my $i = 0;
475             do
476 64   33     89 {
477 64         108 $colNum = $sortCols[ $i++ ];
478 64         100 $desc = $sortCols[ $i++ ];
479 64         175 $result = _anycmp( $a->[$colNum], $b->[$colNum] );
480 64 100       273 $result = -$result if ($desc);
481             } while ( !$result && $i < @sortCols );
482             $result;
483             } @rows;
484             }
485 96         235 ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows );
  96         632  
486             }
487              
488             sub UPDATE ($$$)
489             {
490 34     34   112 my ( $self, $data, $params ) = @_;
491 34         141 my $table = $self->open_tables( $data, 0, 1 );
492 34         167 $self->verify_columns($table);
493 34 50       122 return undef unless $table;
494 34         69 my $affected = 0;
495 34         176 my $can_usr = $table->can('update_specific_row');
496 34         145 my $can_uor = $table->can('update_one_row');
497 34   66     126 my $can_rwu = $can_usr || $can_uor;
498 34         90 my ( @rows, $array, $f_array, $val, $col, $i );
499              
500 34         186 while ( $array = $table->fetch_row($data) )
501             {
502 60 100       195 if ( $self->eval_where( $table, $array ) )
503             {
504 58 100 66     233 $array = $self->{fetched_value} if ( $self->{fetched_from_key} and $can_rwu );
505 58 100       1718 my $orig_ary = clone($array) if ($can_usr);
506 58         222 for ( $i = 0; $i < @{ $self->{column_names} }; $i++ )
  116         373  
507             {
508 58         142 $col = $self->{column_names}->[$i];
509 58         184 $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i);
510             }
511 58         114 $affected++;
512 58 100       159 if ( $self->{fetched_value} )
513             {
514 8 50       26 if ($can_usr)
    0          
515             {
516 8         53 $table->update_specific_row( $data, $array, $orig_ary );
517             }
518             elsif ($can_uor)
519             {
520 0         0 $table->update_one_row( $data, $array );
521             }
522 8         63 return ( $affected, 0 );
523             }
524 50 100       269 push( @rows, $can_usr ? [ $array, $orig_ary ] : $array );
525             }
526             else
527             {
528 2 50       10 push( @rows, $array ) unless ($can_rwu);
529             }
530             }
531 26 100       97 if ($can_rwu)
532             {
533 24         71 foreach my $array (@rows)
534             {
535 48 50       134 if ($can_usr)
    0          
536             {
537 48         177 $table->update_specific_row( $data, @$array );
538             }
539             elsif ($can_uor)
540             {
541 0         0 $table->update_one_row( $data, $array );
542             }
543             }
544             }
545             else
546             {
547 2         10 $table->seek( $data, 0, 0 );
548 2         5 foreach my $array (@rows)
549             {
550 4         12 $table->push_row( $data, $array );
551             }
552 2         9 $table->truncate($data);
553             }
554              
555 26         177 return ( $affected, 0 );
556             }
557              
558             sub verify_columns
559             {
560 292     292   750 my ( $self, $table ) = @_;
561 292         528 my @cols = @{ $self->{column_names} };
  292         1013  
562 292 100       904 if ( $self->{where_clause} )
563             {
564 54 50       203 if ( my $col = $self->{where_clause}->{arg1} )
565             {
566 54 50       247 push @cols, $col->{value} if $col->{type} eq 'column';
567             }
568 54 50       186 if ( my $col = $self->{where_clause}->{arg2} )
569             {
570 54 50       207 push @cols, $col->{value} if $col->{type} eq 'column';
571             }
572             }
573 292         888 for (@cols)
574             {
575 590         1510 $self->column_nums( $table, $_ );
576             }
577             }
578              
579             sub column_nums
580             {
581 1044     1044   2134 my ( $self, $table, $stmt_col_name, $find_in_stmt ) = @_;
582 1044         1340 my %dbd_nums = %{ $table->col_nums() };
  1044         2034  
583 1044         1649 my @dbd_cols = @{ $table->col_names() };
  1044         1913  
584 1044         1486 my %stmt_nums;
585 1044 100 100     3231 if ( $stmt_col_name and !$find_in_stmt )
586             {
587 916         2654 while ( my ( $k, $v ) = each %dbd_nums )
588             {
589 1373 100       5621 return $v if uc $k eq uc $stmt_col_name;
590             }
591 0         0 croak "No such column '$stmt_col_name'";
592             }
593 128 100 66     556 if ( $stmt_col_name and $find_in_stmt )
594             {
595 32         101 for my $i ( 0 .. @{ $self->{column_names} } )
  32         125  
596             {
597 32 50       226 return $i if uc $stmt_col_name eq uc $self->{column_names}->[$i];
598             }
599 0         0 croak "No such column '$stmt_col_name'";
600             }
601 96         379 for my $i ( 0 .. $#dbd_cols )
602             {
603 180         285 for my $stmt_col ( @{ $self->{column_names} } )
  180         426  
604             {
605 344 100       1040 $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col;
606             }
607             }
608 96         439 return \%stmt_nums;
609             }
610              
611             sub eval_where
612             {
613 364     364   743 my ( $self, $table, $rowary ) = @_;
614 364   100     1138 my $where = $self->{"where_clause"} || return 1;
615 130         311 my $col_nums = $table->col_nums();
616 130         187 my %cols = reverse %{$col_nums};
  130         463  
617 130         201 my $rowhash;
618 130         490 for ( sort keys %cols )
619             {
620 260         2004 $rowhash->{ uc $cols{$_} } = $rowary->[$_];
621             }
622 130         509 return $self->process_predicate( $where, $table, $rowhash );
623             }
624              
625             sub process_predicate
626             {
627 130     130   302 my ( $self, $pred, $table, $rowhash ) = @_;
628 130         220 my $val1 = $pred->{arg1};
629 130 50       1325 if ( $val1->{type} eq 'column' )
630             {
631 130         348 $val1 = $rowhash->{ uc $val1->{value} };
632             }
633             else
634             {
635 0         0 $val1 = $val1->{value};
636             }
637 130         210 my $val2 = $pred->{arg2};
638 130 50       252 if ( $val2->{type} eq 'column' )
639             {
640 0         0 $val2 = $rowhash->{ uc $val2->{value} };
641             }
642             else
643             {
644 130         205 $val2 = $val2->{value};
645             }
646 130         206 my $op = $pred->{op};
647 130         215 my $neg = $pred->{neg};
648 130 100 33     881 if ( $op eq '=' and !$neg and $table->can('fetch_one_row') )
      66        
649             {
650 120         389 my $key_col = $table->fetch_one_row( 1, 1 );
651 120 100       793 if ( $pred->{arg1}->{value} =~ /^$key_col$/i )
652             {
653 16         54 $self->{fetched_from_key} = 1;
654 16         55 $self->{fetched_value} = $table->fetch_one_row( 0, $pred->{arg2}->{value} );
655 16         86 return 1;
656             }
657             }
658 114   100     358 my $match = $self->is_matched( $val1, $op, $val2 ) || 0;
659 114 0       241 if ($neg) { $match = $match ? 0 : 1; }
  0 50       0  
660 114         484 return $match;
661             }
662              
663             sub is_matched
664             {
665 114     114   257 my ( $self, $val1, $op, $val2 ) = @_;
666 114 50       252 if ( $op eq 'IS' )
667             {
668 0 0 0     0 return 1 if ( !defined $val1 or $val1 eq '' );
669 0         0 return 0;
670             }
671 114 50       236 $val1 = '' unless ( defined $val1 );
672 114 50       238 $val2 = '' unless ( defined $val2 );
673 114 50       251 if ( $op =~ /LIKE|CLIKE/i )
674             {
675 0         0 $val2 = quotemeta($val2);
676 0         0 $val2 =~ s/\\%/.*/g;
677 0         0 $val2 =~ s/_/./g;
678             }
679 114 50       228 if ( $op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; }
  0         0  
680 114 50       236 if ( $op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
  0         0  
681 114 100 66     385 if ( DBI::looks_like_number($val1) && DBI::looks_like_number($val2) )
682             {
683 2 50       6 if ( $op eq '<' ) { return $val1 < $val2; }
  0         0  
684 2 50       5 if ( $op eq '>' ) { return $val1 > $val2; }
  0         0  
685 2 50       5 if ( $op eq '=' ) { return $val1 == $val2; }
  2         9  
686 0 0       0 if ( $op eq '<>' ) { return $val1 != $val2; }
  0         0  
687 0 0       0 if ( $op eq '<=' ) { return $val1 <= $val2; }
  0         0  
688 0 0       0 if ( $op eq '>=' ) { return $val1 >= $val2; }
  0         0  
689             }
690             else
691             {
692 112 50       250 if ( $op eq '<' ) { return $val1 lt $val2; }
  0         0  
693 112 50       240 if ( $op eq '>' ) { return $val1 gt $val2; }
  0         0  
694 112 50       232 if ( $op eq '=' ) { return $val1 eq $val2; }
  112         410  
695 0 0       0 if ( $op eq '<>' ) { return $val1 ne $val2; }
  0         0  
696 0 0       0 if ( $op eq '<=' ) { return $val1 ge $val2; }
  0         0  
697 0 0       0 if ( $op eq '>=' ) { return $val1 le $val2; }
  0         0  
698             }
699             }
700              
701             sub params
702             {
703 1706     1706   3079 my ( $self, $val_num ) = @_;
704 1706 100       3778 if ( !$self->{"params"} ) { return 0; }
  1490         4459  
705 216 50       467 if ( defined $val_num )
706             {
707 0         0 return $self->{"params"}->[$val_num];
708             }
709              
710 216 50       467 return wantarray ? @{ $self->{"params"} } : scalar @{ $self->{"params"} };
  0         0  
  216         755  
711             }
712              
713             sub open_tables
714             {
715 502     502   1298 my ( $self, $data, $createMode, $lockMode ) = @_;
716 502         1077 my $table_name = $self->{table_name};
717 502         727 my $table;
718 502         1015 eval { $table = $self->open_table( $data, $table_name, $createMode, $lockMode ) };
  502         2133  
719 502 100       6399 if ($@)
720             {
721 72         197 chomp $@;
722 72         12074 croak $@;
723             }
724 430 50       1356 croak "Couldn't open table '$table_name'" unless $table;
725 430 100 100     1979 if ( !$self->{column_names} or $self->{column_names}->[0] eq '*' )
726             {
727 260         1117 $self->{column_names} = $table->col_names();
728             }
729 430         1373 return $table;
730             }
731              
732             sub row_values
733             {
734 326     326   646 my ( $self, $val_num ) = @_;
735 326 50       741 if ( !$self->{"values"} ) { return 0; }
  0         0  
736 326 50       686 if ( defined $val_num )
737             {
738 326         1086 return $self->{"values"}->[$val_num]->{value};
739             }
740 0 0       0 if (wantarray)
741             {
742 0         0 return map { $_->{"value"} } @{ $self->{"values"} };
  0         0  
  0         0  
743             }
744             else
745             {
746 0         0 return scalar @{ $self->{"values"} };
  0         0  
747             }
748             }
749              
750             sub column_names
751             {
752 1422     1422   2774 my ($self) = @_;
753 1422         2029 my @col_names;
754 1422 100 100     4705 if ( $self->{column_names} and $self->{column_names}->[0] ne '*' )
755             {
756 470         755 @col_names = @{ $self->{column_names} };
  470         1350  
757             }
758 1422         3599 return @col_names;
759             }
760              
761             ###############################
762             package DBI::SQL::Nano::Table_;
763             ###############################
764              
765 54     54   606 use Carp qw(croak);
  54         128  
  54         30147  
766              
767             sub new ($$)
768             {
769 430     430   1180 my ( $proto, $attr ) = @_;
770 430         1883 my ($self) = {%$attr};
771              
772             defined( $self->{col_names} ) and "ARRAY" eq ref( $self->{col_names} )
773 430 50 33     2757 or croak("attribute 'col_names' must be defined as an array");
774 430 50       1975 exists( $self->{col_nums} ) or $self->{col_nums} = _map_colnums( $self->{col_names} );
775             defined( $self->{col_nums} ) and "HASH" eq ref( $self->{col_nums} )
776 430 50 33     2224 or croak("attribute 'col_nums' must be defined as a hash");
777              
778 430   33     1712 bless( $self, ( ref($proto) || $proto ) );
779 430         2284 return $self;
780             }
781              
782             sub _map_colnums
783             {
784 430     430   811 my $col_names = $_[0];
785 430         679 my %col_nums;
786 430         1425 for my $i ( 0 .. $#$col_names )
787             {
788 668 50       1541 next unless $col_names->[$i];
789 668         2106 $col_nums{ $col_names->[$i] } = $i;
790             }
791 430         1289 return \%col_nums;
792             }
793              
794 0     0   0 sub row() { return $_[0]->{row}; }
795 0     0   0 sub column($) { return $_[0]->{row}->[ $_[0]->column_num( $_[1] ) ]; }
796 0     0   0 sub column_num($) { $_[0]->{col_nums}->{ $_[1] }; }
797 1174     1174   3429 sub col_nums() { $_[0]->{col_nums} }
798 1304     1304   3079 sub col_names() { $_[0]->{col_names}; }
799              
800 0     0     sub drop ($$) { croak "Abstract method " . ref( $_[0] ) . "::drop called" }
801 0     0     sub fetch_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::fetch_row called" }
802 0     0     sub push_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_row called" }
803 0     0     sub push_names ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_names called" }
804 0     0     sub truncate ($$) { croak "Abstract method " . ref( $_[0] ) . "::truncate called" }
805 0     0     sub seek ($$$$) { croak "Abstract method " . ref( $_[0] ) . "::seek called" }
806              
807             1;
808             __END__