File Coverage

lib/DBIx/Struct.pm
Criterion Covered Total %
statement 1033 2385 43.3
branch 294 1108 26.5
condition 124 346 35.8
subroutine 158 293 53.9
pod 6 29 20.6
total 1615 4161 38.8


line stmt bran cond sub pod time code
1             package DBIx::Struct::JSON::Array;
2 3     3   18350 use strict;
  3         24  
  3         131  
3 3     3   23 use warnings;
  3         9  
  3         2333  
4              
5             sub TIEARRAY {
6 0     0   0 bless [$_[1], $_[2], $_[3]], $_[0];
7             }
8              
9             sub FETCHSIZE {
10 0     0   0 scalar @{$_[0][0]};
  0         0  
11             }
12              
13             sub STORESIZE {
14 0     0   0 $_[0][1]{$_[0][2]} = undef;
15 0         0 $#{$_[0][0]} = $_[1] - 1;
  0         0  
16             }
17              
18             sub STORE {
19 0     0   0 $_[0][1]{$_[0][2]} = undef;
20 0         0 $_[0][0][$_[1]] = $_[2];
21             }
22 0     0   0 sub FETCH {$_[0][0][$_[1]]}
23              
24             sub CLEAR {
25 0     0   0 $_[0][1]{$_[0][2]} = undef;
26 0         0 @{$_[0][0]} = ();
  0         0  
27             }
28              
29             sub POP {
30 0     0   0 $_[0][1]{$_[0][2]} = undef;
31 0         0 pop(@{$_[0][0]});
  0         0  
32             }
33              
34             sub PUSH {
35 0     0   0 my $o = shift;
36 0         0 $o->[1]{$o->[2]} = undef;
37 0         0 push(@{$o->[0]}, @_);
  0         0  
38             }
39              
40             sub SHIFT {
41 0     0   0 $_[0][1]{$_[0][2]} = undef;
42 0         0 shift(@{$_[0][0]});
  0         0  
43             }
44              
45             sub UNSHIFT {
46 0     0   0 my $o = shift;
47 0         0 $o->[1]{$o->[2]} = undef;
48 0         0 unshift(@$o, @_);
49             }
50 0     0   0 sub EXISTS {exists $_[0][0]->[$_[1]]}
51 0     0   0 sub DELETE {delete $_[0][0]->[$_[1]]}
52              
53             sub SPLICE {
54 0     0   0 my $ob = shift;
55 0         0 my $sz = $ob->FETCHSIZE;
56 0 0       0 my $off = @_ ? shift : 0;
57 0 0       0 $off += $sz if $off < 0;
58 0 0       0 my $len = @_ ? shift : $sz - $off;
59 0         0 $ob->[1]{$ob->[2]} = undef;
60 0         0 return splice(@{$ob->[0]}, $off, $len, @_);
  0         0  
61             }
62              
63             package DBIx::Struct::JSON::Hash;
64 3     3   32 use strict;
  3         7  
  3         116  
65 3     3   21 use warnings;
  3         7  
  3         1589  
66              
67             sub TIEHASH {
68 0     0   0 bless [$_[1], $_[2], $_[3]], $_[0];
69             }
70              
71             sub STORE {
72 0     0   0 $_[0][1]{$_[0][2]} = undef;
73 0         0 $_[0][0]->{$_[1]} = $_[2];
74             }
75              
76             sub FETCH {
77 0     0   0 $_[0][0]->{$_[1]};
78             }
79              
80             sub FIRSTKEY {
81 0     0   0 my $a = scalar keys %{$_[0][0]};
  0         0  
82 0         0 each %{$_[0][0]};
  0         0  
83             }
84              
85             sub NEXTKEY {
86 0     0   0 each %{$_[0][0]};
  0         0  
87             }
88              
89             sub EXISTS {
90 0     0   0 exists $_[0][0]->{$_[1]};
91             }
92              
93             sub DELETE {
94 0     0   0 $_[0][1]{$_[0][2]} = undef;
95 0         0 delete $_[0][0]->{$_[1]};
96             }
97              
98             sub CLEAR {
99 0     0   0 $_[0][1]{$_[0][2]} = undef;
100 0         0 %{$_[0][0]} = ();
  0         0  
101             }
102              
103             sub SCALAR {
104 0     0   0 scalar %{$_[0][0]};
  0         0  
105             }
106              
107             package DBIx::Struct::JSON;
108              
109 3     3   26 use strict;
  3         8  
  3         108  
110 3     3   20 use warnings;
  3         7  
  3         119  
111 3     3   2407 use JSON;
  3         48957  
  3         25  
112              
113             sub factory {
114 0     0   0 my ($class, $value_ref, $update_hash, $hash_key) = @_;
115 0         0 my $self;
116 0 0       0 if (not ref $$value_ref) {
117 0 0       0 my $jv = from_json($$value_ref) if $$value_ref;
118 0 0       0 $$value_ref = $jv if $jv;
119             }
120 0 0       0 if (not defined $$value_ref) {
    0          
    0          
121 0         0 $self = [undef, undef];
122             } elsif ('HASH' eq ref $$value_ref) {
123 0         0 my %h;
124 0         0 tie %h, 'DBIx::Struct::JSON::Hash', $$value_ref, $update_hash, $hash_key;
125 0         0 $self = [\%h, $$value_ref];
126             } elsif ('ARRAY' eq ref $$value_ref) {
127 0         0 my @a;
128 0         0 tie @a, 'DBIx::Struct::JSON::Array', $$value_ref, $update_hash, $hash_key;
129 0         0 $self = [\@a, $$value_ref];
130             }
131 0         0 $$value_ref = bless $self, $class;
132             }
133              
134             sub revert {
135 0 0   0   0 $_[0] = defined($_[0][1]) ? to_json $_[0][1] : undef;
136             }
137              
138             sub data {
139 0     0   0 $_[0][1];
140             }
141              
142             sub accessor {
143 0     0   0 $_[0][0];
144             }
145              
146             package DBIx::Struct::Connector;
147 3     3   1415 use strict;
  3         7  
  3         128  
148 3     3   21 use warnings;
  3         7  
  3         133  
149 3     3   34 use base 'DBIx::Connector';
  3         9  
  3         2169  
150              
151             our $db_reconnect_timeout = 30;
152              
153             sub _connect {
154 0     0   0 my ($self, @args) = @_;
155 0         0 for my $try (1 .. $db_reconnect_timeout) {
156 0         0 my $dbh = eval {$self->SUPER::_connect(@args)};
  0         0  
157 0 0       0 return $dbh if $dbh;
158 0 0       0 sleep 1 if $try != $db_reconnect_timeout;
159             }
160 0 0       0 die $@ if $@;
161 0         0 die "DB connect error";
162             }
163              
164             package DBIx::Struct::Error::String;
165 3     3   98499 use strict;
  3         9  
  3         97  
166 3     3   21 use warnings;
  3         8  
  3         133  
167 3     3   21 use Carp;
  3         9  
  3         795  
168              
169             sub error_message (+%) {
170 0     0   0 my $msg = $_[0];
171 0         0 delete $msg->{result};
172 0         0 my $message = delete $msg->{message};
173 0         0 croak join "; ", $message, map {"$_: $msg->{$_}"} keys %$msg;
  0         0  
174             }
175              
176             package DBIx::Struct::Error::Hash;
177 3     3   26 use strict;
  3         8  
  3         108  
178 3     3   21 use warnings;
  3         6  
  3         364  
179              
180             sub error_message (+%) {
181 0     0   0 die $_[0];
182             }
183              
184             package DBIx::Struct;
185 3     3   27 use strict;
  3         6  
  3         96  
186 3     3   20 use warnings;
  3         13  
  3         118  
187 3     3   3176 use SQL::Abstract;
  3         47225  
  3         220  
188 3     3   31 use Digest::MD5;
  3         6  
  3         94  
189 3     3   2322 use Data::Dumper;
  3         21112  
  3         233  
190 3     3   22 use Scalar::Util 'refaddr';
  3         6  
  3         351  
191 3     3   21 use base 'Exporter';
  3         6  
  3         544  
192 3     3   40 use v5.14;
  3         9  
193              
194             our $VERSION = '0.48';
195              
196             our @EXPORT = qw{
197             one_row
198             all_rows
199             for_rows
200             new_row
201             };
202              
203             our @EXPORT_OK = qw{
204             connector
205             hash_ref_slice
206             };
207              
208             sub ccmap ($) {
209 51     51 0 80 my $name = $_[0];
210 51         258 $name =~ s/([[:upper:]])/_\l$1/g;
211 51         129 $name =~ s/^_//;
212 51         153 return $name;
213             }
214              
215             our $camel_case_map = \&ccmap;
216             our $conn;
217             our $update_on_destroy = 1;
218             our $connector_module = 'DBIx::Struct::Connector';
219             our $connector_constructor = 'new';
220             our $connector_pool;
221             our $connector_pool_method = 'get_connector';
222             our $connector_args = [];
223             our $connector_driver;
224             our $user_schema_namespace;
225             our $table_classes_namespace = 'DBC';
226             our $query_classes_namespace = 'DBQ';
227             our $error_message_class = 'DBIx::Struct::Error::String';
228             our %driver_pk_insert;
229              
230             sub error_message (+%) {
231 0     0 0 0 goto &DBIx::Struct::Error::String::error_message;
232             }
233              
234             %driver_pk_insert = (
235             _returning => sub {
236             my ($table, $pk_row_data, $pk_returninig) = @_;
237             my $ret;
238             if ($pk_row_data) {
239             $ret = <
240             ($pk_row_data) =
241             \$_->selectrow_array(\$insert . " $pk_returninig", undef, \@bind)
242             INS
243             } else {
244             $ret = <
245             \$_->do(\$insert, undef, \@bind)
246             INS
247             }
248             $ret .= <
249             or DBIx::Struct::error_message {
250             result => 'SQLERR',
251             message => 'error '.\$_->errstr.' inserting into table $table'
252             };
253             INS
254             },
255             _last_id_undef => sub {
256             my ($table, $pk_row_data) = @_;
257             my $ret;
258             $ret = <
259             \$_->do(\$insert, undef, \@bind)
260             or DBIx::Struct::error_message {
261             result => 'SQLERR',
262             message => 'error '.\$_->errstr.' inserting into table $table'
263             };
264             INS
265             if ($pk_row_data) {
266             $ret .= <
267             $pk_row_data = \$_->last_insert_id(undef, undef, undef, undef);
268             INS
269             }
270             },
271             _last_id_empty => sub {
272             my ($table, $pk_row_data) = @_;
273             my $ret;
274             $ret = <
275             \$_->do(\$insert, undef, \@bind)
276             or DBIx::Struct::error_message {
277             result => 'SQLERR',
278             message => 'error '.\$_->errstr.' inserting into table $table'
279             };
280             INS
281             if ($pk_row_data) {
282             $ret .= <
283             $pk_row_data = \$_->last_insert_id("", "", "", "");
284             INS
285             }
286             }
287             );
288              
289             $driver_pk_insert{Pg} = $driver_pk_insert{_returning};
290             $driver_pk_insert{mysql} = $driver_pk_insert{_last_id_undef};
291             $driver_pk_insert{SQLite} = $driver_pk_insert{_last_id_empty};
292              
293             sub hash_ref_slice($@) {
294 0     0 1 0 my ($hashref, @slice) = @_;
295 0 0       0 error_message {
296             message => "first parameter is not hash reference",
297             result => 'INTERR',
298             }
299             if 'HASH' ne ref $hashref;
300 0         0 map {$_ => $hashref->{$_}} @slice;
  0         0  
301             }
302              
303             my @already_exported_to;
304              
305             sub connector {
306 51     51 0 316 $conn;
307             }
308              
309             sub connector_from_pool {
310 0     0 0 0 $connector_pool->$connector_pool_method();
311             }
312              
313             sub set_connector_pool {
314 0     0 0 0 $connector_pool = $_[0];
315 0 0       0 if (\&connector != \&connector_from_pool) {
316 3     3   23 no warnings 'redefine';
  3         5  
  3         222  
317 3     3   21 no strict 'refs';
  3         7  
  3         905  
318 0         0 *connector = \&connector_from_pool;
319 0         0 for my $aep (@already_exported_to) {
320 0         0 *{"$aep\::connector"} = \&connector;
  0         0  
321             }
322             }
323             }
324              
325             sub set_user_schema_namespace {
326 0     0 0 0 $user_schema_namespace = $_[0];
327             }
328              
329             sub set_connector_pool_method {
330 0     0 0 0 $connector_pool_method = $_[0];
331             }
332              
333             sub set_connector_object {
334 0     0 0 0 *conn = \$_[0];
335             }
336              
337             sub set_camel_case_map {
338 0 0   0 0 0 error_message {
339             message => "CamelCaseMap must be code reference",
340             result => 'SQLERR',
341             } if 'CODE' ne ref $_[0];
342 0         0 $camel_case_map = $_[0];
343             }
344              
345             sub check_package_scalar {
346 3     3 0 14 my ($package, $scalar) = @_;
347 3     3   21 no strict 'refs';
  3         6  
  3         508  
348 3         7 my $pr = \%{$package . '::'};
  3         17  
349 3         13 my $er = $$pr{$scalar};
350 3 50       29 return unless $er;
351 0         0 defined *{$er}{'SCALAR'};
  0         0  
352             }
353              
354             sub import {
355 3     3   35 my ($class, @args) = @_;
356 3         8 my $defconn = 0;
357 3         4 my $_emc = 0;
358 3         7 my $_cp = 0;
359 3         5 my $_c = 0;
360 3         15 for (my $i = 0; $i < @args; ++$i) {
361 4 100 33     23 if ($args[$i] eq 'connector_module') {
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
362 3         11 (undef, $connector_module) = splice @args, $i, 2;
363 3         6 --$i;
364 3 50 33     21 if (not $defconn and check_package_scalar($connector_module, 'conn')) {
365 3     3   17 no strict 'refs';
  3         5  
  3         1004  
366 0         0 set_connector_object(${$connector_module . '::conn'});
  0         0  
367             }
368             } elsif ($args[$i] eq 'connector_constructor') {
369 0         0 (undef, $connector_constructor) = splice @args, $i, 2;
370 0         0 --$i;
371             } elsif ($args[$i] eq 'camel_case_map' && 'CODE' eq ref $args[$i]) {
372 0         0 (undef, $camel_case_map) = splice @args, $i, 2;
373 0         0 --$i;
374             } elsif ($args[$i] eq 'user_schema_namespace') {
375 1         5 (undef, $user_schema_namespace) = splice @args, $i, 2;
376 1         3 --$i;
377             } elsif ($args[$i] eq 'table_classes_namespace') {
378 0         0 (undef, $table_classes_namespace) = splice @args, $i, 2;
379 0         0 --$i;
380             } elsif ($args[$i] eq 'query_classes_namespace') {
381 0         0 (undef, $query_classes_namespace) = splice @args, $i, 2;
382 0         0 --$i;
383             } elsif ($args[$i] eq 'connect_timeout') {
384 0         0 (undef, $db_reconnect_timeout) = splice @args, $i, 2;
385 0         0 --$i;
386             } elsif ($args[$i] eq 'error_class') {
387 0         0 my (undef, $emc) = splice @args, $i, 2;
388 0         0 $error_message_class = $emc;
389 0         0 $_emc = 1;
390 0         0 --$i;
391             } elsif ($args[$i] eq 'connector_pool') {
392 0         0 (undef, $connector_pool) = splice @args, $i, 2;
393 0         0 $_cp = 1;
394 0         0 --$i;
395             } elsif ($args[$i] eq 'connector_pool_method') {
396 0         0 (undef, $connector_pool_method) = splice @args, $i, 2;
397 0         0 --$i;
398             } elsif ($args[$i] eq 'connector_args') {
399 0         0 (undef, $connector_args) = splice @args, $i, 2;
400 0         0 --$i;
401             } elsif ($args[$i] eq 'connector') {
402 0         0 $_c = 1;
403             } elsif ($args[$i] eq 'connector_object') {
404 0         0 $defconn = 1;
405 0         0 set_connector_object($args[$i + 1]);
406 0         0 splice @args, $i, 2;
407 0         0 --$i;
408             }
409             }
410 3 50       11 if ($_emc) {
411 3     3   19 no warnings 'redefine';
  3         6  
  3         113  
412 3     3   16 no strict 'refs';
  3         6  
  3         262  
413 0         0 *error_message = \&{$error_message_class . "::error_message"};
  0         0  
414             }
415 3 50       9 if ($_cp) {
416 3     3   25 no warnings 'redefine';
  3         7  
  3         141  
417 3     3   19 no strict 'refs';
  3         26  
  3         1427  
418 0         0 *connector = \&connector_from_pool;
419 0         0 for my $aep (@already_exported_to) {
420 0         0 *{"$aep\::connector"} = \&connector;
  0         0  
421             }
422             }
423 3         9 my $callpkg = caller;
424 3 50       11 push @already_exported_to, $callpkg if $_c;
425 3         11 my %imps = map {$_ => undef} @args, @EXPORT;
  12         32  
426 3         644 $class->export_to_level(1, $class, keys %imps);
427             }
428              
429             sub _not_yet_connected {
430 2 50 33 2   18 if (!$connector_pool && !$conn) {
431 2         9 my ($dsn, $user, $password) = @_;
432 2 50 33     8 if ($dsn && $dsn !~ /^dbi:/i) {
433 0         0 $dsn = "dbi:Pg:dbname=$dsn";
434             }
435 2         47 my $connect_attrs = {
436             AutoCommit => 1,
437             PrintError => 0,
438             AutoInactiveDestroy => 1,
439             RaiseError => 0,
440             };
441 2 50       7 if ($dsn) {
442 0         0 my ($driver) = $dsn =~ /^dbi:(\w*?)(?:\((.*?)\))?:/i;
443 0 0       0 if ($driver) {
444 0 0       0 if ($driver eq 'Pg') {
    0          
    0          
445 0         0 $connect_attrs->{pg_enable_utf8} = 1;
446             } elsif ($driver eq 'mysql') {
447 0         0 $connect_attrs->{mysql_enable_utf8} = 1;
448             } elsif ($driver eq 'SQLite') {
449 0         0 $connect_attrs->{sqlite_unicode} = 1;
450             }
451             }
452             }
453 2 50       13 if (!@$connector_args) {
454 2         10 @$connector_args = ($dsn, $user, $password, $connect_attrs);
455             }
456 2 50       27 $conn = $connector_module->$connector_constructor(@$connector_args)
457             or error_message {
458             message => "DB connect error",
459             result => 'SQLERR',
460             };
461 2         30 $conn->mode('fixup');
462             }
463 2         14 '' =~ /()/;
464 2         9 $connector_driver = connector->driver->{driver};
465 3     3   23 no warnings 'redefine';
  3         6  
  3         1550  
466 2         20 *connect = \&connector;
467 2         10 populate();
468 2         20 connector;
469             }
470              
471             sub connect {
472 2     2 1 280 goto &_not_yet_connected;
473             }
474              
475             {
476             my $md5 = Digest::MD5->new;
477              
478             sub make_name {
479 35     35 0 72 my ($table) = @_;
480 35         82 my $simple_table = (index($table, " ") == -1);
481 35         45 my $ncn;
482 35 100       75 if ($simple_table) {
483 30         195 $ncn = $table_classes_namespace . "::" . join('', map {ucfirst($_)} split(/[^a-zA-Z0-9]/, $table));
  39         177  
484             } else {
485 5         40 $md5->add($table);
486 5         39 $ncn = $query_classes_namespace . "::" . "G" . $md5->hexdigest;
487 5         17 $md5->reset;
488             }
489 35         155 $ncn;
490             }
491             }
492              
493             sub populate {
494 2     2 0 9 my @tables;
495             DBIx::Struct::connect->run(
496             sub {
497 2     2   42 my $sth = $_->table_info('', '%', '%', "TABLE");
498 2 50       163 return if not $sth;
499 2         9 my $tables = $sth->fetchall_arrayref;
500             @tables = map {
501 6         17 (my $t = $_->[2]) =~ s/"//g;
502 6         48 $t;
503             } grep {
504 2 50       23 $_->[3] eq 'TABLE' and $_->[2] !~ /^sql_/
  6         35  
505             } @$tables;
506             }
507 2         8 );
508 2         18 for (@tables) {
509 6         36 my $ncn = setup_row($_);
510 6 100       38 if ($user_schema_namespace) {
511 3         26 (my $uncn = $ncn) =~ s/^.*:://;
512 3     1   198 eval "use ${user_schema_namespace}::${uncn}";
  1         306  
  0            
  0            
513 3     3   21 no strict 'refs';
  3         4  
  3         2163  
514 3         15 eval {
515 3 50 33     6 if (
      66        
516 3         44 keys %{"${user_schema_namespace}::${uncn}::"}
517             and ( not ${"${user_schema_namespace}::${uncn}::"}{ISA}
518             or not "${user_schema_namespace}::${uncn}"->isa($ncn))
519             )
520             {
521 0         0 unshift @{"${user_schema_namespace}::${uncn}::ISA"}, $ncn;
  0         0  
522             }
523             };
524             }
525             }
526             }
527              
528             #<<<
529             my @uneq = (
530             qr/LessThanEqual$/, '<=',
531             qr/LessThan$/, '<',
532             qr/GreaterThanEqual$/, '>=',
533             qr/GreaterThan$/, '>',
534             qr/IsNull$/, sub {"'$_[0]' => {'=', undef}"},
535             qr/IsNotNull$/, sub {"'$_[0]' => {'!=', undef}"},
536             qr/IsNot$/, '!=',
537             qr/NotNull$/, sub {"'$_[0]' => {'!=', undef}"},
538             qr/NotEquals$/, '!=',
539             qr/NotIn$/, '-not_in',
540             qr/NotLike$/, '-not_like',
541             qr/IsEqualTo$/, '=',
542             qr/IsTrue$/, sub {"-bool => '$_[0]'"},
543             qr/IsFalse$/, sub {"-not_bool => '$_[0]'"},
544             qr/Equals$/, '=',
545             qr/True$/, sub {"-bool => '$_[0]'"},
546             qr/False$/, sub {"-not_bool => '$_[0]'"},
547             qr/Like$/, '-like',
548             qr/Is$/, '=',
549             qr/Not$/, '!=',
550             qr/In$/, '-in',
551             );
552             #>>>
553              
554             sub _parse_find_by {
555 20     20   11268 my ($table, $find) = @_;
556 20 50 66     180 $find =~ s/^find(?.*?)By(?![[:lower:]])// || $find =~ s/^find(?.*)// or die "bad pattern: $find";
557 3   100 3   2017 my $what = $+{what} || 'All';
  3         1268  
  3         6396  
  20         156  
558 20         64 $what =~ s/(?Distinct)(?![[:lower:]])//;
559 20   100     100 my $distinct = $+{distinct} // 0;
560 20         132 $what =~ s/((?(All|One|First))(?\d+)?)(?![[:lower:]])//;
561 20   100     98 my $type = $+{type} // 'All';
562 20         71 my $limit = $+{limit};
563 20         51 $what =~ s/(?\w+)//;
564 20   100     99 my $column = $camel_case_map->($+{column} // '');
565 20 100       90 $find =~ s/OrderBy(?.*?)(?Asc|Desc)(?=[[:upper:]]|$)// || $find =~ s/OrderBy(?.*?)$//;
566 20         70 my $order = $+{order};
567 20   100     93 my $asc = $+{asc} || 'Asc';
568 20         33 my $where = $find;
569              
570 20 100 100     57 if ($type eq 'First' && !$limit) {
571 2         3 $limit = 1;
572             }
573 20 100 100     56 if ($limit && $limit == 1) {
574 3         5 $type = 'One';
575             }
576 20         23 my $pi = 1;
577             my $pp = sub {
578 26     26   48 my ($param) = @_;
579 26         27 my $found;
580 26         55 for (my $i = 0; $i < @uneq; $i += 2) {
581 475 100       1332 if ($param =~ s/$uneq[$i]//) {
582 4         6 $found = $i + 1;
583 4         5 last;
584             }
585             }
586 26         50 $param = $camel_case_map->($param);
587 26         33 my $ret;
588 26 100       42 if ($found) {
589 4 100       7 if ('CODE' eq ref $uneq[$found]) {
590 1         4 $ret = $uneq[$found]->($param);
591             } else {
592 3         9 $ret = "'$param' => { '$uneq[$found]' => \$_[$pi]}";
593 3         5 ++$pi;
594             }
595             } else {
596 22         51 $ret = "'$param' => \$_[$pi]";
597 22         36 ++$pi;
598             }
599 26         93 $ret;
600 20         103 };
601             #<<<
602             my $conds = join(
603             ", ",
604             map {
605 20         67 /And(?![[:lower:]])/
606 16 100       74 ? '-and => [' . join(", ", map {$pp->($_)} split /And(?![[:lower:]])/x, $_) . ']'
  19         32  
607             : $pp->($_);
608             } split /Or(?![[:lower:]])/, $where
609             );
610             #>>>
611 20 100       47 my $obj = $type eq 'One' ? 'DBIx::Struct::one_row' : 'DBIx::Struct::all_rows';
612 20 100       38 my $flags = $column ? ", -column => '$column'" : '';
613 20 50       40 $flags = $distinct ? $flags ? ", -distinct => '$column'" : ", '-distinct'" : $flags;
    100          
614 20 100       39 $order =
    100          
615             $order
616             ? $asc eq 'Asc'
617             ? ", -order_by => '" . $camel_case_map->($order) . "'"
618             : ", -order_by => {-desc => '" . $camel_case_map->($order) . "'}"
619             : '';
620 20 100       42 $where = $conds ? ", -where => [$conds]" : '';
621 20 100 66     74 $limit = $limit && $limit > 1 && $type ne 'One' ? ", -limit => $limit" : '';
622 20         36 my $tspec = "'$table'" . $flags;
623 20 100       57 $tspec = "[$tspec]" if $column;
624 20         31 $tspec .= $where . $order . $limit;
625 20         202 return "sub { $obj($tspec) }";
626             }
627              
628             sub _row_data () {0}
629             sub _row_updates () {1}
630              
631             sub make_object_new {
632 10     10 0 34 my ($table, $required, $pk_row_data, $pk_returninig) = @_;
633 10         21 my $new = <
634             sub new {
635             my \$class = \$_[0];
636             my \$self = [ [] ];
637             bless \$self, \$class;
638             if(CORE::defined(\$_[1]) && CORE::ref(\$_[1]) eq 'ARRAY') {
639 10         37 \$self->[@{[_row_data]}] = \$_[1];
640             }
641             NEW
642 10 100       36 if (not ref $table) {
643 6         9 $new .= <
644             else {
645             my \%insert;
646             for(my \$i = 1; \$i < \@_; \$i += 2) {
647             if (CORE::exists \$fields{\$_[\$i]}) {
648             my \$f = \$_[\$i];
649 6         49 \$self->[@{[_row_data]}]->[\$fields{\$_[\$i]}] = \$_[\$i + 1];
650             \$insert{\$f} = \$_[\$i + 1];
651             } else {
652             DBIx::Struct::error_message {
653             result => 'SQLERR',
654             message => "unknown column \$_[\$i] inserting into table $table"
655             }
656             }
657             }
658             my (\@insert, \@values, \@bind);
659             \@insert =
660             CORE::map {
661             if(CORE::ref(\$insert{\$_}) eq 'ARRAY' and CORE::ref(\$insert{\$_}[0]) eq 'SCALAR') {
662             CORE::push \@bind, \@{\$insert{\$_}}[1..\$#{\$insert{\$_}}];
663             CORE::push \@values, \${\$insert{\$_}[0]};
664             DBIx::Struct::connect->dbh->quote_identifier(\$_);
665             } elsif(CORE::ref(\$insert{\$_}) eq 'REF' and CORE::ref(\${\$insert{\$_}}) eq 'ARRAY') {
666             if(CORE::defined \${\$insert{\$_}}->[0]) {
667             CORE::push \@bind, \@{\${\$insert{\$_}}}[1..\$#{\${\$insert{\$_}}}];
668             CORE::push \@values, \${\$insert{\$_}}->[0];
669             DBIx::Struct::connect->dbh->quote_identifier(\$_);
670             } else {
671             CORE::push \@values, "null";
672             DBIx::Struct::connect->dbh->quote_identifier(\$_)
673             }
674             } elsif(CORE::ref(\$insert{\$_}) eq 'SCALAR') {
675             CORE::push \@values, \${\$insert{\$_}};
676             DBIx::Struct::connect->dbh->quote_identifier(\$_);
677             } elsif(CORE::exists (\$json_fields{\$_})
678             && (CORE::ref(\$insert{\$_}) eq 'ARRAY' || CORE::ref(\$insert{\$_}) eq 'HASH')) {
679             CORE::push \@bind, JSON::to_json(\$insert{\$_});
680             CORE::push \@values, "?";
681             DBIx::Struct::connect->dbh->quote_identifier(\$_);
682             } else {
683             CORE::push \@bind, \$insert{\$_};
684             CORE::push \@values, "?";
685             DBIx::Struct::connect->dbh->quote_identifier(\$_);
686             }
687             } CORE::keys \%insert;
688             my \$insert;
689             if(\%insert){
690             \$insert = "insert into $table (" . CORE::join( ", ", \@insert) . ") values ("
691             . CORE::join( ", ", \@values) . ")";
692             } else {
693             \$insert = "insert into $table values (default)";
694             }
695             NEW
696 6 50       25 if ($required) {
697 0         0 $new .= <
698             for my \$r ($required) {
699             DBIx::Struct::error_message {
700             result => 'SQLERR',
701             message => "required field \$r is absent for table $table"
702             } if not CORE::exists \$insert{\$r};
703             }
704             NEW
705             }
706 6         22 $new .= <
707             DBIx::Struct::connect->run(
708             sub {
709             NEW
710 6         30 $new .= $driver_pk_insert{$connector_driver}->($table, $pk_row_data, $pk_returninig);
711 6         13 $new .= <
712             });
713             }
714             NEW
715             }
716 10         22 $new .= <
717             \$self;
718             }
719             NEW
720 10         60 $new;
721             }
722              
723             sub make_object_filter_timestamp {
724 10     10 0 21 my ($timestamps) = @_;
725 10         37 my $filter_timestamp = <
726             sub filter_timestamp {
727             my \$self = \$_[0];
728             if(\@_ == 1) {
729             for my \$f ($timestamps) {
730 10         51 if(\$self->[@{[_row_data]}][\$fields{\$f}]) {
731 10         40 \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/\\.\\d+(\$|\\+|\\-)/\$1/;
732 10         43 \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/(\\+|\\-)(\\d{2})\$/\$1\${2}00/;
733             }
734             }
735             } else {
736             for my \$f (\@_[1..\$#_]) {
737 10         32 if(\$self->[@{[_row_data]}][\$fields{\$f}]) {
738 10         31 \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/\\.\\d+(\$|\\+|\\-)/\$1/;
739 10         35 \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/(\\+|\\-)(\\d{2})\$/\$1\${2}00/;
740             }
741             }
742             }
743             '' =~ /()/;
744             \$self;
745             }
746             FTS
747 10         32 $filter_timestamp;
748             }
749              
750             sub make_object_set {
751 10     10 0 20 my $table = $_[0];
752 10         15 my $set = <
753             sub set {
754             my \$self = \$_[0];
755             my \@unknown_columns;
756             if(CORE::defined(\$_[1])) {
757             if(CORE::ref(\$_[1]) eq 'ARRAY') {
758 10         39 \$self->[@{[_row_data]}] = \$_[1];
759 10         63 \$self->[@{[_row_updates]}] = {};
760             } elsif(CORE::ref(\$_[1]) eq 'HASH') {
761             for my \$f (CORE::keys \%{\$_[1]}) {
762             if (CORE::exists \$fields{\$f}) {
763             \$self->\$f(\$_[1]->{\$f});
764             } else {
765             CORE::push \@unknown_columns, \$f;
766             }
767             }
768             } elsif(not CORE::ref(\$_[1])) {
769             for(my \$i = 1; \$i < \@_; \$i += 2) {
770             if (CORE::exists \$fields{\$_[\$i]}) {
771             my \$f = \$_[\$i];
772             \$self->\$f(\$_[\$i + 1]);
773             } else {
774             CORE::push \@unknown_columns, \$_[\$i];
775             }
776             }
777             }
778             }
779             DBIx::Struct::error_message {
780             result => 'SQLERR',
781             message => 'unknown columns '.CORE::join(", ", \@unknown_columns).' for $table->data'
782             } if \@unknown_columns;
783             \$self;
784             }
785             SET
786 10         36 $set;
787             }
788              
789             sub make_object_data {
790 10     10 0 17 my $table = $_[0];
791 10         19 my $data = <
792             sub data {
793             my \$self = \$_[0];
794             my \@ret_keys;
795             my \$ret;
796             if(CORE::defined(\$_[1])) {
797             if(CORE::ref(\$_[1]) eq 'ARRAY') {
798             if(!\@{\$_[1]}) {
799 10         38 \$ret = \$self->[@{[_row_data]}];
800             } else {
801 10         38 \$ret = [CORE::map {\$self->[@{[_row_data]}]->[\$fields{\$_}] } \@{\$_[1]}];
802             }
803             } else {
804             for my \$k (\@_[1..\$#_]) {
805             CORE::push \@ret_keys, \$k if CORE::exists \$fields{\$k};
806             }
807             }
808             } else {
809             \@ret_keys = keys \%fields;
810             }
811             my \@unknown_columns = CORE::grep {not CORE::exists \$fields{\$_}} \@ret_keys;
812             DBIx::Struct::error_message {
813             result => 'SQLERR',
814             message => 'unknown columns '.CORE::join(", ", \@unknown_columns).' for $table->data'
815             } if \@unknown_columns;
816             \$ret = {
817             CORE::map {\$_ => \$self->\$_} \@ret_keys
818             } if not CORE::defined \$ret;
819             \$ret;
820             }
821             DATA
822 10         31 $data;
823             }
824              
825             sub make_object_update {
826 10     10 0 26 my ($table, $pk_where, $pk_row_data) = @_;
827 10         15 my $update;
828 10 100       30 if (not ref $table) {
829              
830             # means this is just one simple table
831 6         42 $update = <
832             sub update {
833             my \$self = \$_[0];
834             if(\@_ > 1 && CORE::ref(\$_[1]) eq 'HASH') {
835             my (\$set, \$where, \@bind, \@bind_where);
836             {
837             no strict 'vars';
838             local *set_hash = \$_[1];
839             my \@unknown_columns = CORE::grep {not CORE::exists \$fields{\$_}} CORE::keys %set_hash;
840             DBIx::Struct::error_message {
841             result => 'SQLERR',
842             message => 'unknown columns '.CORE::join(", ", \@unknown_columns).' updating table $table'
843             } if \@unknown_columns;
844             \$set =
845             CORE::join ", ",
846             CORE::map {
847             if(CORE::ref(\$set_hash{\$_}) eq 'ARRAY' and CORE::ref(\$set_hash{\$_}[0]) eq 'SCALAR') {
848             CORE::push \@bind, \@{\$set_hash{\$_}}[1..\$#{\$set_hash{\$_}}];
849             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \${\$set_hash{\$_}[0]};
850             } elsif(CORE::ref(\$set_hash{\$_}) eq 'REF' and CORE::ref(\${\$set_hash{\$_}}) eq 'ARRAY') {
851             if(CORE::defined \${\$set_hash{\$_}}->[0]) {
852             CORE::push \@bind, \@{\${\$set_hash{\$_}}}[1..\$#{\${\$set_hash{\$_}}}];
853             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \${\$set_hash{\$_}}->[0];
854             } else {
855             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = null"
856             }
857             } elsif(CORE::ref(\$set_hash{\$_}) eq 'SCALAR') {
858             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \${\$set_hash{\$_}};
859             } elsif(CORE::exists(\$json_fields{\$_})
860             && (CORE::ref(\$set_hash{\$_}) eq 'ARRAY' || CORE::ref(\$set_hash{\$_}) eq 'HASH')) {
861             CORE::push \@bind, JSON::to_json(\$set_hash{\$_});
862             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = ?"
863             } else {
864             CORE::push \@bind, \$set_hash{\$_};
865             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = ?"
866             }
867             } CORE::keys \%set_hash;
868             }
869             if(\@_ > 2) {
870             my \$cond = \$_[2];
871             if(not CORE::ref(\$cond)) {
872             \$cond = {(selectKeys)[0] => \$_[2]};
873             }
874             (\$where, \@bind_where) = SQL::Abstract->new->where(\$cond);
875             }
876             return DBIx::Struct::connect->run(sub {
877             \$_->do(qq{update $table set \$set \$where}, undef, \@bind, \@bind_where)
878             or DBIx::Struct::error_message {
879             result => 'SQLERR',
880             message => 'error '.\$_->errstr.' updating table $table'
881             }
882             });
883 6         19 } elsif (CORE::ref(\$self) && \@\$self > 1 && \%{\$self->[@{[_row_updates]}]}) {
884             my (\$set, \@bind);
885             {
886             no strict 'vars';
887             \$set =
888             CORE::join ", ",
889             CORE::map {
890 6         39 local *column_value = \\\$self->[@{[_row_data]}][\$fields{\$_}];
891             if(CORE::ref(\$column_value) eq 'ARRAY' and CORE::ref(\$column_value->[0]) eq 'SCALAR') {
892             CORE::push \@bind, \@{\$column_value}[1..\$#\$column_value];
893             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \${\$column_value->[0]};
894             } elsif(CORE::ref(\$column_value) eq 'REF' and CORE::ref(\${\$column_value}) eq 'ARRAY') {
895             if(CORE::defined \${\$column_value}->[0]) {
896             CORE::push \@bind, \@{\${\$column_value}}[1..\$#{\${\$column_value}}];
897             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \${\$column_value}->[0];
898             } else {
899             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = null"
900             }
901             } elsif(CORE::ref(\$column_value) && CORE::ref(\$column_value) =~ /^DBIx::Struct::JSON/) {
902             \$column_value->revert;
903             CORE::push \@bind, \$column_value;
904             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = ?"
905             } elsif(CORE::ref(\$column_value) eq 'SCALAR') {
906             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = " . \$\$column_value;
907             } else {
908             CORE::push \@bind, \$column_value;
909             DBIx::Struct::connect->dbh->quote_identifier(\$_) . " = ?"
910             }
911 6         74 } CORE::keys \%{\$self->[@{[_row_updates]}]};
912             }
913             my \$update_query = qq{update $table set \$set where $pk_where};
914             DBIx::Struct::connect->run(
915             sub {
916             \$_->do(\$update_query, undef, \@bind, $pk_row_data)
917             or DBIx::Struct::error_message {
918             result => 'SQLERR',
919             message => 'error '.\$_->errstr.' updating table $table',
920             query => \$update_query,
921             bind => \\\@bind,
922             }
923             }
924             );
925 6         73 \$#\$self = @{[_row_data]};
926             }
927             \$self;
928             }
929             UPD
930             } else {
931 4         8 $update = <
932             sub update {}
933             UPD
934             }
935 10         43 $update;
936             }
937              
938             sub make_object_delete {
939 10     10 0 31 my ($table, $pk_where, $pk_row_data) = @_;
940 10         18 my $delete;
941 10 100       34 if (not ref $table) {
942 6         51 $delete = <
943             sub delete {
944             my \$self = \$_[0];
945             if(Scalar::Util::blessed \$self) {
946             DBIx::Struct::connect->run(
947             sub {
948             \$_->do(qq{delete from $table where $pk_where}, undef, $pk_row_data)
949             or DBIx::Struct::error_message {
950             result => 'SQLERR',
951             message => 'error '.\$_->errstr.' updating table $table'
952             }
953             });
954             return \$self;
955             }
956             my \$where = '';
957             my \@bind;
958             my \$cond = \$_[1] if \@_ > 1;
959             if(not CORE::ref(\$cond)) {
960             \$cond = {};
961             my \@keys = selectKeys();
962             for(my \$i = 1; \$i < \@_; ++\$i) {
963             DBIx::Struct::error_message {
964             result => 'SQLERR',
965             message => "Too many keys to delete for $table"
966             } if not CORE::defined \$keys[\$i-1];
967             \$cond->{\$keys[\$i-1]} = \$_[\$i];
968             }
969             }
970             my \@rpar = ();
971             if(\$cond) {
972             (\$where, \@bind) = SQL::Abstract->new->where(\$cond);
973             \@rpar = (undef, \@bind);
974             }
975             return DBIx::Struct::connect->run(sub {
976             \$_->do(qq{delete from $table \$where}, \@rpar)
977             or DBIx::Struct::error_message {
978             result => 'SQLERR',
979             message => 'error '.\$_->errstr.' updating table $table'
980             }
981             });
982             }
983             DEL
984             } else {
985 4         9 $delete = <
986             sub delete {}
987             DEL
988             }
989 10         30 $delete;
990             }
991              
992             sub make_object_autoload_find {
993 10     10 0 24 my ($table, $pk_where, $pk_row_data) = @_;
994 10         19 my $find = '';
995 10 100       50 if (not ref $table) {
996 6         30 $find = <
997             sub AUTOLOAD {
998             my \$self = \$_[0];
999             ( my \$method = \$AUTOLOAD ) =~ s{.*::}{};
1000            
1001             if(Scalar::Util::blessed \$self) {
1002             \$self = CORE::ref \$self;
1003             }
1004             DBIx::Struct::error_message {
1005             result => 'SQLERR',
1006             message => "Unknown method \$method for $table"
1007             } if !\$self || !"\$self"->can("tableName") || \$method !~ /^find/;
1008             my \$func = DBIx::Struct::_parse_find_by('$table', \$method);
1009             my \$ncn = DBIx::Struct::make_name('$table');
1010             {
1011             no strict 'refs';
1012             *{\$ncn."::".\$method} = eval \$func;
1013             DBIx::Struct::error_message {
1014             result => 'SQLERR',
1015             message => "Error creating method \$method for $table: \$\@"
1016             } if \$\@;
1017             }
1018             goto &{\$ncn."::".\$method};
1019             }
1020             AUTOLOAD
1021             }
1022 10         23 $find;
1023             }
1024              
1025             sub make_object_fetch {
1026 10     10 0 32 my ($table, $pk_where, $pk_row_data) = @_;
1027 10         25 my $fetch;
1028 10 100       29 if (not ref $table) {
1029 6         40 $fetch = <
1030             sub fetch {
1031             my \$self = \$_[0];
1032             if(\@_ > 1) {
1033             my (\$where, \@bind);
1034             my \$cond = \$_[1];
1035             if(not CORE::ref(\$cond)) {
1036             \$cond = {(selectKeys)[0] => \$_[1]};
1037             }
1038             (\$where, \@bind) = SQL::Abstract->new->where(\$cond);
1039             DBIx::Struct::connect->run(sub {
1040             my \$rowref = \$_->selectrow_arrayref(qq{select * from $table \$where}, undef, \@bind)
1041             or DBIx::Struct::error_message {
1042             result => 'SQLERR',
1043             message => 'error '.\$_->errstr.' fetching table $table'
1044             };
1045 6         46 \$self->[@{[_row_data]}] = [\@\$rowref];
1046             });
1047             } else {
1048             DBIx::Struct::connect->run(
1049             sub {
1050             my \$rowref = \$_->selectrow_arrayref(qq{select * from $table where $pk_where}, undef, $pk_row_data)
1051             or DBIx::Struct::error_message {
1052             result => 'SQLERR',
1053             message => 'error '.\$_->errstr.' fetching table $table'
1054             };
1055 6         24 \$self->[@{[_row_data]}] = [\@\$rowref];
1056             });
1057             }
1058             \$self;
1059             }
1060             FETCH
1061             } else {
1062 4         6 $fetch = <
1063             sub fetch { \$_[0] }
1064             FETCH
1065             }
1066 10         28 $fetch;
1067             }
1068              
1069             sub _exists_row ($) {
1070 49     49   67 my $ncn = $_[0];
1071 3     3   29 no strict "refs";
  3         6  
  3         588  
1072 49 100       68 if (grep {!/::$/} keys %{"${ncn}::"}) {
  1368         1972  
  49         464  
1073 39         134 return 1;
1074             }
1075 10         36 return;
1076             }
1077              
1078             sub _parse_interface ($) {
1079 0     0   0 my $interface = $_[0];
1080 0         0 my %ret;
1081 0 0       0 $interface = [$interface] if not ref $interface;
1082 0 0       0 if ('ARRAY' eq ref $interface) {
    0          
1083 0         0 for my $i (@$interface) {
1084 0         0 my $dbc_name = make_name($i);
1085 0 0       0 error_message {
1086             result => 'SQLERR',
1087             message => "Unknown base interface table $i",
1088             }
1089             unless _exists_row $dbc_name;
1090 3     3   21 no strict 'refs';
  3         6  
  3         540  
1091 0         0 my $href = \%{"${dbc_name}::fkfuncs"};
  0         0  
1092 0 0 0     0 if ($href && %$href) {
1093 0         0 my @i = keys %$href;
1094 0         0 @ret{@i} = @{$href}{@i};
  0         0  
1095             }
1096             }
1097             } elsif ('HASH' eq ref $interface) {
1098 0         0 for my $i (keys %$interface) {
1099 0         0 my $dbc_name = make_name($i);
1100 0 0       0 error_message {
1101             result => 'SQLERR',
1102             message => "Unknown base interface table $i",
1103             }
1104             unless _exists_row $dbc_name;
1105 3     3   20 no strict 'refs';
  3         5  
  3         2879  
1106 0         0 my $href = \%{"${dbc_name}::fkfuncs"};
  0         0  
1107 0 0 0     0 next if not $href or not %$href;
1108 0         0 my $fl = $interface->{$i};
1109 0 0       0 $fl = [$fl] if not ref $fl;
1110 0 0       0 if ('ARRAY' eq ref $fl) {
1111              
1112 0         0 for my $m (@$fl) {
1113 0 0       0 $ret{$m} = $href->{$m} if exists $href->{$m};
1114             }
1115             } else {
1116 0         0 error_message {
1117             result => 'SQLERR',
1118             message => "Usupported interface structure",
1119             };
1120             }
1121             }
1122             } else {
1123 0         0 error_message {
1124             result => 'SQLERR',
1125             message => "Unknown interface structure: " . ref($interface),
1126             };
1127             }
1128 0         0 \%ret;
1129             }
1130              
1131             sub make_object_to_json {
1132 10     10 0 42 my ($table, $field_types, $fields) = @_;
1133 10         42 my @to_types = map {[
1134             $_,
1135 20         131 qq|!defined(\$self->[@{[_row_data]}][$fields->{$_}])? undef: |
1136             . (
1137 16         133 $field_types->{$_} eq 'number' ? "0+\$self->[@{[_row_data]}][$fields->{$_}]"
1138 0         0 : $field_types->{$_} eq 'boolean' ? "\$self->[@{[_row_data]}][$fields->{$_}]? \\1: \\0"
1139 20 50       41 : $field_types->{$_} eq 'json'
    50          
    100          
1140 0         0 ? "CORE::ref(\$self->[@{[_row_data]}]->[$fields->{$_}])? \$self->[@{[_row_data]}][$fields->{$_}]->data"
  0         0  
1141 0         0 . ": JSON::from_json(\$self->[@{[_row_data]}][$fields->{$_}])"
1142 4         42 : "\"\$self->[@{[_row_data]}][$fields->{$_}]\""
1143             )
1144             ]
1145             } keys %$field_types;
1146 10         39 my $field_to_types = join ",\n\t\t\t\t ", map {qq|"$_->[0]" => $_->[1]|} @to_types;
  20         79  
1147 10         27 my $sub_to_types = '';
1148 10         26 for my $tt (@to_types) {
1149 20         31 my $k = $tt->[0];
1150 20         48 $k =~ s/[^\w\d]/_/g;
1151 20         87 $sub_to_types .= <
1152             sub _to_json_$k { my \$self = \$_[0]; $tt->[1] }
1153             JSTT
1154             }
1155 10         44 my $to_json = <
1156             sub TO_JSON {
1157             my \$self = shift;
1158             my \$ret;
1159             my \@columns = CORE::grep { not ref } \@_;
1160             my \@refs = CORE::grep { 'HASH' eq ref } \@_;
1161             if(\@columns) {
1162             \$ret = +{
1163             map {
1164             DBIx::Struct::error_message {
1165             result => 'SQLERR',
1166             message => "unknown column \$_ in table $table"
1167             } if not CORE::exists \$fields{\$_};
1168             my \$k = \$_;
1169             \$k =~ s/[^\\w\\d]/_/g;
1170             my \$m = "_to_json_\$k";
1171             \$_ => \$self->\$m
1172             } \@columns
1173             };
1174             } else {
1175             \$ret = +{
1176             $field_to_types
1177             };
1178             }
1179             if(\@refs) {
1180             \$ret = +{ %\$ret, map { %\$_ } \@refs };
1181             }
1182             return \$ret;
1183             }
1184             TOJSON
1185 10         97 return $sub_to_types . $to_json;
1186             }
1187              
1188             sub _field_type_from_name {
1189 20     20   36 my $type_name = $_[0];
1190 20 50       54 return 'string' if not defined $type_name;
1191 20 100 66     302 if ( $type_name =~ /int(\d+)?$/i
    50 66        
    50 66        
    50 33        
    50          
    50          
1192             || $type_name =~ /integer/i
1193             || $type_name =~ /bit$/
1194             || $type_name =~ /float|double|real|decimal|numeric/i)
1195             {
1196 16         101 return 'number';
1197             } elsif ($type_name =~ /json/i) {
1198 0         0 return 'json';
1199             } elsif ($type_name =~ /bool/i) {
1200 0         0 return 'boolean';
1201             } elsif ($type_name =~ /date/i && $type_name =~ /time/i) {
1202 0         0 return 'datetime';
1203             } elsif ($type_name =~ /date/i) {
1204 0         0 return 'date';
1205             } elsif ($type_name =~ /time/i) {
1206 0         0 return 'time';
1207             } else {
1208 4         34 return 'string';
1209             }
1210             }
1211              
1212             sub _schema_name {
1213 23     23   38 my $ncn = $_[0];
1214 23 100       55 if ($user_schema_namespace) {
1215 5         23 (my $uncn = $ncn) =~ s/^.*:://;
1216 3     3   25 no strict 'refs';
  3         5  
  3         10852  
1217 5         9 eval {
1218 5 100 66     6 if (${"${user_schema_namespace}::${uncn}::"}{ISA}
  5         35  
1219             && "${user_schema_namespace}::${uncn}"->isa($ncn))
1220             {
1221 2         7 $ncn = "${user_schema_namespace}::${uncn}";
1222             }
1223             };
1224             }
1225 23         37 $ncn;
1226             }
1227              
1228             sub setup_row {
1229 49     49 0 111 my ($table, $ncn, $interface) = @_;
1230             error_message {
1231             result => 'SQLERR',
1232             message => "Unsupported driver $connector_driver",
1233             }
1234 49 50       142 unless exists $driver_pk_insert{$connector_driver};
1235 49   66     126 $ncn ||= make_name($table);
1236 49 100       100 return $ncn if _exists_row $ncn ;
1237 10         76 my %fields;
1238             my @fields;
1239 10         0 my @timestamp_fields;
1240 10         0 my @required;
1241 10         0 my @pkeys;
1242 10         0 my @fkeys;
1243 10         0 my @refkeys;
1244 10         0 my %json_fields;
1245 10         25 my $connector = DBIx::Struct::connect;
1246 10         17 my %field_types;
1247              
1248 10 100       33 if (not ref $table) {
1249             # means this is just one simple table
1250             $connector->run(
1251             sub {
1252 6     6   93 my $ssth = $_->prepare('select * from ' . $_->quote_identifier($table) . ' where 0 = 1');
1253 6 50       612 error_message {
1254             result => 'SQLERR',
1255             message => "Unknown table $table",
1256             }
1257             if not $ssth;
1258 6 50       44 $ssth->execute
1259             or error_message {
1260             result => 'SQLERR',
1261             message => "Probably unknown table $table: " . $_->errstr,
1262              
1263             };
1264 6         104 my $cih = $_->column_info(undef, undef, $table, undef);
1265 6 50       661 error_message {
1266             result => 'SQLERR',
1267             message => "Unknown table $table",
1268             }
1269             if not $cih;
1270 6         15 my $i = 0;
1271 6         25 while (my $chr = $cih->fetchrow_hashref) {
1272 12         1326 $chr->{COLUMN_NAME} =~ s/"//g;
1273 12         32 $chr->{COLUMN_NAME} = lc $chr->{COLUMN_NAME};
1274 12         33 push @fields, $chr->{COLUMN_NAME};
1275 12 50       54 if ($chr->{TYPE_NAME} =~ /^time/i) {
1276 0         0 push @timestamp_fields, $chr->{COLUMN_NAME};
1277             }
1278 12 50       43 if ($chr->{TYPE_NAME} =~ /^json/i) {
1279 0         0 $json_fields{$chr->{COLUMN_NAME}} = undef;
1280             }
1281 12   66     57 $chr->{COLUMN_DEF} //= $chr->{mysql_is_auto_increment};
1282 12 50 66     54 if ($chr->{NULLABLE} == 0 && !defined($chr->{COLUMN_DEF})) {
1283 0         0 push @required, $chr->{COLUMN_NAME};
1284             }
1285 12         39 $fields{$chr->{COLUMN_NAME}} = $i++;
1286 12         46 $field_types{$chr->{COLUMN_NAME}} = _field_type_from_name($chr->{TYPE_NAME});
1287             }
1288 6         87 @pkeys = map {lc} $_->primary_key(undef, undef, $table);
  4         50  
1289 6 50 66     43 if (!@pkeys && @required) {
1290 0         0 my $ukh = $_->statistics_info(undef, undef, $table, 1, 1);
1291 0         0 my %req = map {$_ => undef} @required;
  0         0  
1292 0         0 my %pkeys;
1293 0         0 while (my $ukr = $ukh->fetchrow_hashref) {
1294 0 0 0     0 if (not exists $req{$ukr->{COLUMN_NAME}} or defined $ukr->{FILTER_CONDITION}) {
1295 0         0 $pkeys{lc $ukr->{INDEX_NAME}}{drop} = 1;
1296             } else {
1297 0         0 $pkeys{lc $ukr->{INDEX_NAME}}{fields}{lc $ukr->{COLUMN_NAME}} = undef;
1298             }
1299             }
1300 0         0 my @d = grep {exists $pkeys{$_}{drop}} keys %pkeys;
  0         0  
1301 0         0 delete $pkeys{$_} for @d;
1302 0 0       0 if (%pkeys) {
1303 0         0 my @spk = sort {scalar(keys %{$pkeys{$a}{fields}}) <=> scalar(keys %{$pkeys{$b}{fields}})}
  0         0  
  0         0  
  0         0  
1304             keys %pkeys;
1305 0         0 @pkeys = keys %{$pkeys{$spk[0]}{fields}};
  0         0  
1306             }
1307             }
1308 6         25 my $sth = $_->foreign_key_info(undef, undef, undef, undef, undef, $table);
1309 6 50       530 if ($sth) {
1310             @fkeys =
1311 4 50 33     60 grep {($_->{PKTABLE_NAME} || $_->{UK_TABLE_NAME}) && $_->{FK_COLUMN_NAME} !~ /[^a-z_0-9]/}
1312             map {
1313             $_->{FK_COLUMN_NAME} = $_->{FKCOLUMN_NAME}
1314 4 50       313 if $_->{FKCOLUMN_NAME};
1315 4 50       9 $_->{FK_TABLE_NAME} = $_->{FKTABLE_NAME} if $_->{FKTABLE_NAME};
1316 4         10 $_->{FK_TABLE_NAME} = lc $_->{FK_TABLE_NAME};
1317 4         8 $_->{FK_COLUMN_NAME} = lc $_->{FK_COLUMN_NAME};
1318 4   33     26 $_->{PKTABLE_NAME} ||= $_->{UK_TABLE_NAME};
1319 4   33     33 $_->{PKCOLUMN_NAME} ||= $_->{UK_COLUMN_NAME};
1320 4 50       21 $_->{PKTABLE_NAME} = lc $_->{PKTABLE_NAME} if $_->{PKTABLE_NAME};
1321 4 50       19 $_->{PKCOLUMN_NAME} = lc $_->{PKCOLUMN_NAME} if $_->{PKCOLUMN_NAME};
1322 4         15 $_
1323 6         14 } @{$sth->fetchall_arrayref({})};
  6         24  
1324             }
1325 6         89 $sth = $_->foreign_key_info(undef, undef, $table, undef, undef, undef);
1326 6 50       487 if ($sth) {
1327             @refkeys =
1328 4 50 33     109 grep {($_->{PKTABLE_NAME} || $_->{UK_TABLE_NAME}) && $_->{FK_COLUMN_NAME} !~ /[^a-z_0-9]/}
1329             map {
1330             $_->{FK_COLUMN_NAME} = $_->{FKCOLUMN_NAME}
1331 4 50       274 if $_->{FKCOLUMN_NAME};
1332 4 50       11 $_->{FK_TABLE_NAME} = $_->{FKTABLE_NAME} if $_->{FKTABLE_NAME};
1333 4         11 $_->{FK_TABLE_NAME} = lc $_->{FK_TABLE_NAME};
1334 4         9 $_->{FK_COLUMN_NAME} = lc $_->{FK_COLUMN_NAME};
1335 4   33     28 $_->{PKTABLE_NAME} = lc($_->{PKTABLE_NAME} || $_->{UK_TABLE_NAME});
1336 4   33     24 $_->{PKCOLUMN_NAME} = lc($_->{PKCOLUMN_NAME} || $_->{UK_COLUMN_NAME});
1337 4         16 $_
1338 6         13 } @{$sth->fetchall_arrayref({})};
  6         16  
1339             }
1340             }
1341 6         91 );
1342             } else {
1343              
1344             # means this is a query
1345 4         7 my %tnh = %{$table->{NAME_lc_hash}};
  4         33  
1346 4         15 for my $k (keys %tnh) {
1347 8         12 my $fk = $k;
1348 8         19 $fk =~ s/[^\w ].*$//;
1349 8         19 $fields{$fk} = $tnh{$k};
1350             }
1351             $connector->run(
1352             sub {
1353 4     4   37 for (my $cn = 0; $cn < @{$table->{NAME}}; ++$cn) {
  12         45  
1354 8         37 my $ti = $_->type_info($table->{TYPE}->[$cn]);
1355 8         71 my $field = lc $table->{NAME}->[$cn];
1356 8         20 $field =~ s/[^\w ].*$//;
1357 8         22 $field_types{$field} = _field_type_from_name($ti->{TYPE_NAME});
1358             push @timestamp_fields, $field
1359 8 50 33     40 if $ti->{TYPE_NAME} && $ti->{TYPE_NAME} =~ /^time/;
1360             $json_fields{$field} = undef
1361 8 50 33     43 if $ti->{TYPE_NAME} && $ti->{TYPE_NAME} =~ /^json/;
1362             }
1363             }
1364 4         42 );
1365             }
1366 10         298 my $field_types = join ", ", map {qq|"$_" => '$field_types{$_}'|} keys %field_types;
  20         89  
1367 10         33 my $fields = join ", ", map {qq|"$_" => $fields{$_}|} keys %fields;
  20         67  
1368 10         35 my $json_fields = join ", ", map {qq|"$_" => undef|} keys %json_fields;
  0         0  
1369 10         18 my $required = '';
1370 10 50       27 if (@required) {
1371 0         0 $required = join(", ", map {qq|"$_"|} @required);
  0         0  
1372             }
1373 10         22 my $timestamps = '';
1374 10 50       25 if (@timestamp_fields) {
1375 0         0 $timestamps = join(", ", map {qq|"$_"|} @timestamp_fields);
  0         0  
1376             } else {
1377 10         17 $timestamps = "()";
1378             }
1379 10         67 my %keywords = (
1380             new => undef,
1381             set => undef,
1382             data => undef,
1383             delete => undef,
1384             fetch => undef,
1385             update => undef,
1386             DESTROY => undef,
1387             filter_timestamp => undef,
1388             );
1389 10         20 my $pk_row_data = '';
1390 10         30 my $pk_returninig = '';
1391 10         15 my $pk_where = '';
1392 10         15 my $select_keys = '';
1393 10         17 my %pk_fields;
1394 10 100       26 if (@pkeys) {
1395 4         17 @pk_fields{@pkeys} = undef;
1396 4         12 $pk_row_data = join(", ", map {qq|\$self->[@{[_row_data]}]->[$fields{"$_"}]|} @pkeys);
  4         7  
  4         32  
1397 4         10 $pk_returninig = 'returning ' . join(", ", @pkeys);
1398 4         10 $pk_where = join(" and ", map {"$_ = ?"} @pkeys);
  4         13  
1399 4         8 my $sk_list = join(", ", map {qq|"$_"|} @pkeys);
  4         14  
1400 4         12 $select_keys = <
1401             sub selectKeys () {
1402             ($sk_list)
1403             }
1404             SK
1405             } else {
1406 6 100       25 if (@fields) {
1407 2         7 my $sk_list = join(", ", map {qq|"$_"|} @fields);
  4         18  
1408 2         10 $select_keys = <
1409             sub selectKeys () {
1410             ($sk_list)
1411             }
1412             SK
1413             } else {
1414 4         10 $select_keys = <
1415             sub selectKeys () { () }
1416             SK
1417             }
1418             }
1419 10         23 my $foreign_tables = '';
1420 10         19 my %foreign_tables;
1421             my %fkfuncs;
1422 10         31 for my $fk (@fkeys) {
1423 4   33     17 (my $pt = $fk->{PKTABLE_NAME} || $fk->{UK_TABLE_NAME}) =~ s/"//g;
1424 4   33     13 (my $pk = $fk->{PKCOLUMN_NAME} || $fk->{UK_COLUMN_NAME}) =~ s/"//g;
1425 4         6 my $fn = $pt;
1426 4         7 $fn =~ tr/_/-/;
1427 4         34 $fn =~ s/\b(\w)/\u$1/g;
1428 4         10 $fn =~ tr/-//d;
1429 4         7 $fk->{FK_COLUMN_NAME} =~ s/"//g;
1430 4         7 my $fn_suffix = $fk->{FK_COLUMN_NAME};
1431 4 50 33     41 $fn_suffix =~ s/^${pk}_*//i or $fn_suffix =~ s/_$pk(?=[^a-z]|$)//i or $fn_suffix =~ s/$pk(?=[^a-z]|$)//i;
1432 4         6 $fn_suffix =~ tr/_/-/;
1433 4         18 $fn_suffix =~ s/\b(\w)/\u$1/g;
1434 4         7 $fn_suffix =~ tr/-//d;
1435 4         40 $fn_suffix =~ s/$fn//;
1436 4         6 $fn .= $fn_suffix;
1437 4         11 $fkfuncs{$fn} = undef;
1438 4         18 $foreign_tables .= <
1439             sub $fn {
1440             if(CORE::defined(\$_[0]->$fk->{FK_COLUMN_NAME})) {
1441             return DBIx::Struct::one_row("$pt", {$pk => \$_[0]->$fk->{FK_COLUMN_NAME}});
1442             } else {
1443             return
1444             }
1445             }
1446             FKT
1447 4         15 $foreign_tables{$pt} = [$fk->{FK_COLUMN_NAME} => $pk];
1448             }
1449 10         29 for my $ft (keys %foreign_tables) {
1450 4         10 my $ucft = ucfirst $ft;
1451 4         11 $fkfuncs{"foreignKey$ucft"} = undef;
1452 4         25 $foreign_tables .= <
1453             sub foreignKey$ucft () {("$foreign_tables{$ft}[0]" => "$foreign_tables{$ft}[1]")}
1454             FKT
1455             }
1456 10         31 my $references_tables = '';
1457 10         24 for my $rk (@refkeys) {
1458 4         16 $rk->{FK_TABLE_NAME} =~ s/"//g;
1459 4         22 my $ft = $rk->{FK_TABLE_NAME};
1460 4         15 (my $fk = $rk->{FK_COLUMN_NAME}) =~ s/"//g;
1461 4   33     24 (my $pt = $rk->{PKTABLE_NAME} || $rk->{UK_TABLE_NAME}) =~ s/"//g;
1462 4   33     22 (my $pk = $rk->{PKCOLUMN_NAME} || $rk->{UK_COLUMN_NAME}) =~ s/"//g;
1463 4 50       14 if ($pk ne $fk) {
1464 4         6 my $fn = $fk;
1465 4 50 33     66 $fn =~ s/^${pk}_*//i or $fn =~ s/_$pk(?=[^a-z]|$)//i or $fn =~ s/$pk(?=[^a-z]|$)//i;
1466 4         49 $fn =~ s/$pt//i;
1467 4 50       13 $ft .= "_$fn" if $fn;
1468             }
1469 4         13 $ft =~ tr/_/-/;
1470 4         53 $ft =~ s/\b(\w)/\u$1/g;
1471 4         15 $ft =~ tr/-//d;
1472 4         15 $fkfuncs{"ref${ft}s"} = undef;
1473 4         13 $fkfuncs{"ref${ft}"} = undef;
1474 4         43 $references_tables .= <
1475             sub ref${ft}s {
1476             my (\$self, \@cond) = \@_;
1477             my \%cond;
1478             if(\@cond) {
1479             if(not CORE::ref \$cond[0]) {
1480             \%cond = \@cond;
1481             } else {
1482             \%cond = \%{\$cond[0]};
1483             }
1484             }
1485             \$cond{$fk} = \$self->$pk;
1486             return DBIx::Struct::all_rows("$rk->{FK_TABLE_NAME}", \\\%cond);
1487             }
1488             sub ref${ft} {
1489             my (\$self, \@cond) = \@_;
1490             my \%cond;
1491             if(\@cond) {
1492             if(not CORE::ref \$cond[0]) {
1493             \%cond = \@cond;
1494             } else {
1495             \%cond = \%{\$cond[0]};
1496             }
1497             }
1498             \$cond{$fk} = \$self->$pk;
1499             return DBIx::Struct::one_row("$rk->{FK_TABLE_NAME}", \\\%cond);
1500             }
1501             RT
1502             }
1503 10         25 my $accessors = <
1504             sub markUpdated {
1505 10         49 \$_[0]->[@{[_row_updates]}]{\$_[1]} = undef if CORE::exists \$fields{\$_[1]};
1506             \$_[0];
1507             }
1508             ACC
1509 10         42 for my $k (keys %fields) {
1510 20 50       94 next if exists $keywords{$k};
1511 20 50       82 next if $k =~ /^\d/;
1512 20         48 $k =~ s/[^\w\d]/_/g;
1513 20 50       46 if (!exists $json_fields{$k}) {
1514 20 100 100     96 if (!exists($pk_fields{$k}) && (not ref $table)) {
1515 8         24 $accessors .= <
1516             sub _$k {
1517             if(\@_ > 1) {
1518 8         34 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1];
1519             }
1520 8         29 \$_[0]->[@{[_row_data]}]->[$fields{$k}];
1521             }
1522             sub $k {
1523             if(\@_ > 1) {
1524 8         22 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1];
1525 8         30 \$_[0]->[@{[_row_updates]}]{"$k"} = undef;
1526             }
1527 8         53 \$_[0]->[@{[_row_data]}]->[$fields{$k}];
1528             }
1529             ACC
1530             } else {
1531 12         34 $accessors .= <
1532             sub $k {
1533 12         58 \$_[0]->[@{[_row_data]}]->[$fields{$k}];
1534             }
1535             ACC
1536             }
1537             } else {
1538 0 0 0     0 if (!exists($pk_fields{$k}) && (not ref $table)) {
1539 0         0 $accessors .= <
1540             sub _$k {
1541             if(\@_ > 1) {
1542             if(not CORE::ref \$_[1]) {
1543 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1];
1544             } else {
1545 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = JSON::to_json(\$_[1]);
1546             }
1547             }
1548 0         0 if(not CORE::ref \$_[0]->[@{[_row_data]}]->[$fields{$k}]) {
1549 0         0 \$_[0]->[@{[_row_updates]}] = {} if not \$_[0]->[@{[_row_updates]}];
  0         0  
1550 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] =
1551 0         0 DBIx::Struct::JSON->factory(\\\$_[0]->[@{[_row_data]}]->[$fields{$k}], \$_[0]->[@{[_row_updates]}], "$k");
  0         0  
1552             }
1553 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}]->accessor;
1554             }
1555             sub $k {
1556             if(\@_ > 1) {
1557             if(not CORE::ref \$_[1]) {
1558 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1];
1559             } else {
1560 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = JSON::to_json(\$_[1]);
1561             }
1562 0         0 \$_[0]->[@{[_row_updates]}]{"$k"} = undef;
1563             }
1564 0         0 if(not CORE::ref \$_[0]->[@{[_row_data]}]->[$fields{$k}]) {
1565 0         0 \$_[0]->[@{[_row_updates]}] = {} if not \$_[0]->[@{[_row_updates]}];
  0         0  
1566 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] =
1567 0         0 DBIx::Struct::JSON->factory(\\\$_[0]->[@{[_row_data]}]->[$fields{$k}], \$_[0]->[@{[_row_updates]}], "$k");
  0         0  
1568             }
1569 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}]->accessor;
1570             }
1571             ACC
1572             } else {
1573 0         0 $accessors .= <
1574             sub $k {
1575 0         0 if(\$_[0]->[@{[_row_data]}]->[$fields{$k}] and not CORE::ref \$_[0]->[@{[_row_data]}]->[$fields{$k}]) {
  0         0  
1576 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}] = JSON::from_json(\$_[0]->[@{[_row_data]}]->[$fields{$k}]);
  0         0  
1577             }
1578 0         0 \$_[0]->[@{[_row_data]}]->[$fields{$k}];
1579             }
1580             ACC
1581             }
1582             }
1583             }
1584 10         70 my $package_header = <
1585             package ${ncn};
1586             use strict;
1587             use warnings;
1588             use Carp;
1589             use SQL::Abstract;
1590             use JSON;
1591             use Scalar::Util 'blessed';
1592             use vars qw(\$AUTOLOAD);
1593             our \%field_types = ($field_types);
1594             our \%fields = ($fields);
1595             our \%json_fields = ($json_fields);
1596             PHD
1597 10 100       33 if (not ref $table) {
1598 6 50       15 if (%fkfuncs) {
1599 6         21 my $fkfuncs = join ",", map {qq{"$_" => \\&${ncn}::$_}} keys %fkfuncs;
  16         57  
1600 6         32 $package_header .= <
1601             our \%fkfuncs = ($fkfuncs);
1602             PHD
1603             } else {
1604 0         0 $package_header .= <
1605             our \%fkfuncs = ();
1606             PHD
1607             }
1608 6         23 $package_header .= <
1609             sub tableName () {"$table"}
1610             PHD
1611             } else {
1612 4         11 $package_header .= <
1613             sub tableName () {"\\\$query\\\$$ncn"}
1614             PHD
1615             }
1616 10         42 my $new = make_object_new($table, $required, $pk_row_data, $pk_returninig);
1617 10         36 my $filter_timestamp = make_object_filter_timestamp($timestamps);
1618 10         34 my $set = make_object_set($table);
1619 10         44 my $data = make_object_data($table);
1620 10         37 my $update = make_object_update($table, $pk_where, $pk_row_data);
1621 10         34 my $delete = make_object_delete($table, $pk_where, $pk_row_data);
1622 10         38 my $fetch = make_object_fetch($table, $pk_where, $pk_row_data);
1623 10         35 my $autoload = make_object_autoload_find($table, $pk_where, $pk_row_data);
1624 10         48 my $to_json = make_object_to_json($table, \%field_types, \%fields);
1625 10         22 my $destroy;
1626              
1627 10 100       35 if (not ref $table) {
1628 6         14 $destroy = <
1629             sub DESTROY {
1630             no warnings 'once';
1631             \$_[0]->update if \$DBIx::Struct::update_on_destroy;
1632             }
1633             DESTROY
1634             } else {
1635 4         8 $destroy = '';
1636             }
1637 10         229 my $eval_code = join "", $package_header, $select_keys, $new,
1638             $set, $data, $fetch, $autoload, $to_json, $filter_timestamp,
1639             $update, $delete, $destroy, $accessors, $foreign_tables, $references_tables;
1640              
1641             # print $eval_code;
1642 2 0 0 2   54 eval $eval_code;
  2 0 0 2   8  
  2 0 0 2   97  
  2 0 0 2   15  
  2 0 0 2   12  
  2 0 0 2   145  
  2 0 33 2   14  
  2 0 0 2   5  
  2 0 0 2   144  
  2 50 0 2   10  
  2 50 0 2   4  
  2 50 33 2   109  
  2 0 33 2   13  
  2 50 0 2   3  
  2 0 0 2   17  
  2 0 0 2   444  
  2 0 0 2   4  
  2 0 33 2   121  
  2 0 66 2   12  
  2 0 66 2   5  
  2 0 33 2   4365  
  2 0 0 2   20  
  2 0 33 3   4  
  2 0 33 2   2110  
  2 0 33 2   19  
  2 0 33 2   5  
  2 0 0 2   1403  
  2 0 0 2   15  
  2 0 0 2   5  
  2 0 0 2   2036  
  2 0 33 2   16  
  2 0 33 2   4  
  2 0 0 2   1064  
  2 0 0 2   17  
  2 0 0 1   3  
  2 0 66 1   56  
  2 0 33 1   9  
  2 0 33 1   2  
  2 0 0 1   59  
  2 0 33 1   9  
  2 0 66 1   4  
  2 0 66 1   176  
  2 0 66 1   13  
  2 0 33 1   5  
  2 0 66 1   78  
  2 0 33 1   13  
  2 0 0 1   3  
  2 0 0 1   20  
  2 0 0 1   323  
  2 0 0 1   5  
  2 0 33 1   94  
  2 0 33 1   10  
  2 50 0 1   4  
  2 0 0 1   4206  
  2 50 0 1   20  
  2 50   1   6  
  2 0   1   2182  
  2 0   1   21  
  2 0   1   6  
  2 0   1   2109  
  2 0   1   23  
  2 0   0   7  
  2 0   0   2598  
  2 0   0   20  
  2 50   8   6  
  2 0   5   1416  
  3 0   4   213  
  2 0   0   6  
  2 0   3   82  
  2 0   0   13  
  2 0   0   5  
  2 0   0   83  
  2 0   0   13  
  2 0   0   5  
  2 0   0   149  
  2 0   0   11  
  2 0   0   4  
  2 0   0   91  
  2 0   0   11  
  2 0   0   3  
  2 0   0   16  
  2 0   0   396  
  2 0   0   6  
  2 0   0   122  
  2 0   0   12  
  2 0   0   3  
  2 0   0   4033  
  2 0   0   22  
  2 0   0   7  
  2 0   0   2055  
  2 0   0   20  
  2 0   0   5  
  2 0   0   1346  
  2 0   0   16  
  2 0   0   4  
  2 0   0   1883  
  2 0   0   24  
  2 0   0   4  
  2 0   0   975  
  2 0   0   198  
  1 0   0   3  
  1 0   0   53  
  1 0   0   9  
  1 0   1   4  
  1 0   0   49  
  1 0   0   5  
  1 0   0   1  
  1 0   0   82  
  1 0   0   6  
  1 0   0   1  
  1 0   0   39  
  1 0   0   5  
  1 0   0   2  
  1 0   0   7  
  1 0   0   233  
  1 0   0   2  
  1 0   0   48  
  1 0   0   5  
  1 0   0   2  
  1 0   0   1969  
  1 0   0   13  
  1 0   0   3  
  1 0   0   55  
  1 0   1   7  
  1 0   0   3  
  1 0   5   49  
  1 0   0   6  
  1 0   0   1  
  1 0   0   82  
  1 0   0   6  
  1 0   0   1  
  1 0   0   40  
  1 0   6   9  
  1 0   0   2  
  1 0   0   8  
  1 50   0   301  
  1 50   0   2  
  1 0   0   60  
  1 50   0   5  
  1 50   0   2  
  1 0   5   1514  
  1 0   2   9  
  1 0   4   9  
  1 0   1   39  
  1 0   6   10  
  1 0   1   14  
  1 0   1   53  
  1 0   1   5  
  1 0   0   2  
  1 0   4   78  
  1 0   0   5  
  1 0   0   2  
  1 0   0   53  
  1 0   5   8  
  1 0   0   3  
  1 0   0   7  
  1 0   0   204  
  1 0   0   1  
  1 0   0   56  
  1 0   0   4  
  1 0   0   2  
  1 0   0   1891  
  1 0   0   9  
  1 0   0   2  
  1 0   0   33  
  1 0   0   6  
  1 0   0   2  
  1 0   0   31  
  1 0   0   21  
  1 0   4   2  
  1 0   12   62  
  1 0   2   5  
  1 0   3   2  
  1 50   0   36  
  1 0   0   6  
  1 0   0   1  
  1 0       6  
  1 0       163  
  1 0       2  
  1 0       53  
  1 0       5  
  1 0       2  
  1 0       1792  
  10 0       1213  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 100       0  
  0 50       0  
  0 100       0  
  0 50       0  
  0 50       0  
  0 100       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 100       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  8 0       1455  
  5 0       35  
  4 0       828  
  0 0       0  
  0 0       0  
  0 0       0  
  3 0       13  
  3 0       8  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 100       0  
  0 50       0  
  0 50       0  
  0 100       0  
  0 100       0  
  0 100       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         32  
  0         0  
  3         57  
  3         62  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         37  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         341  
  1         7  
  0         0  
  0         0  
  1         3  
  1         2  
  1         4  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         2  
  1         3  
  1         5  
  1         272  
  1         29  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         7  
  0         0  
  5         17  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  6         25  
  0         0  
  0         0  
  6         21  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  5         21  
  5         11  
  5         9  
  5         29  
  5         18  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  5         79  
  2         6  
  2         5  
  2         5  
  2         20  
  2         9  
  0         0  
  4         17  
  4         12  
  4         9  
  4         28  
  4         21  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  2         41  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  4         64  
  1         4  
  1         2  
  1         3  
  1         7  
  1         10  
  1         21  
  6         15  
  6         10  
  6         11  
  6         27  
  3         10  
  3         3  
  3         78  
  3         10  
  3         6  
  3         8  
  3         10  
  0         0  
  3         6  
  3         8  
  3         31  
  1         3  
  1         3  
  1         3  
  1         4  
  1         4  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         2  
  1         3  
  1         4  
  0         0  
  0         0  
  0         0  
  1         4  
  1         4  
  1         4  
  3         128  
  3         9  
  3         14  
  0         0  
  3         7  
  6         111  
  1         2  
  1         2  
  1         2  
  1         9  
  1         9  
  1         10  
  1         2  
  1         2  
  1         3  
  1         7  
  1         7  
  1         15  
  1         5  
  0         0  
  0         0  
  1         6  
  0         0  
  4         1144  
  3         9  
  3         12  
  4         18  
  0         0  
  0         0  
  0         0  
  5         106  
  5         9  
  5         17  
  0         0  
  0         0  
  0         0  
  0         0  
  5         19  
  5         36  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  4         10  
  4         48  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  4         61  
  12         67  
  12         106  
  1         2  
  1         3  
  1         4  
  1         4  
  1         5  
  1         17  
  1         4  
  1         17  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         4  
  1         5  
  1         55  
  1         2  
  1         4  
  0         0  
  1         7  
  1         319  
  3         14  
  3         4  
  3         4  
  3         4  
  3         8  
  3         29  
  1         5  
  1         3  
  1         4  
  1         39  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         13  
  1         3  
  1         4  
  3         13  
  3         117  
  3         9  
  3         90  
  11         189  
  5         11  
  5         75  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  5         250  
1643 10 50       59 error_message {
1644             result => 'SQLERR',
1645             message => "Unknown error: $@",
1646             } if $@;
1647 10 50       39 if ($interface) {
1648 0         0 my $ifuncs = _parse_interface $interface;
1649 3     3   43 no strict 'refs';
  3         8  
  3         12907  
1650 0         0 for my $f (keys %$ifuncs) {
1651 0         0 *{"${ncn}::$f"} = $ifuncs->{$f};
  0         0  
1652             }
1653             }
1654 10         68 '' =~ /()/;
1655 10         229 return $ncn;
1656             }
1657              
1658             my %cache_complex_query;
1659             my $json_canonical = JSON->new->canonical->convert_blessed;
1660              
1661             sub _cached_complex_query {
1662 4     4   56 my $key = $json_canonical->encode(\@_);
1663 4         8 my ($ret, $is_one_column);
1664 4 50       22 if (exists $cache_complex_query{$key}) {
1665 0         0 ($ret, $is_one_column) = @{$cache_complex_query{$key}};
  0         0  
1666             } else {
1667 4         14 ($ret, $is_one_column) = _build_complex_query(@_);
1668 4         26 $cache_complex_query{$key} = [($ret, $is_one_column)];
1669             }
1670 4 50       23 if (wantarray) {
1671 4         17 return ($ret, $is_one_column);
1672             } else {
1673 0         0 return $ret;
1674             }
1675             }
1676              
1677             sub _table_name() {0}
1678             sub _table_alias() {1}
1679             sub _table_join() {2}
1680             sub _table_join_on() {3}
1681              
1682             my $sql_abstract = SQL::Abstract->new;
1683             my $tblnum;
1684              
1685             sub _build_complex_query {
1686 4     4   10 my ($table, $query_bind, $where) = @_;
1687 4 50       10 return $table if not ref $table;
1688 4         6 my @from;
1689             my @columns;
1690 4 50       16 my @linked_list = (
1691             ref($table) eq 'ARRAY'
1692             ? @$table
1693             : error_message {
1694             result => 'SQLERR',
1695             message => "Unsupported type of query: " . ref($table)
1696             }
1697             );
1698 4         6 my ($conditions, $groupby, $having, $limit, $offset, $orderby);
1699 4         6 my $one_column = 0;
1700 4         6 my $distinct = 0;
1701 4         5 my $count = 0;
1702 4         6 my $all = 0;
1703              
1704 4         11 for (my $i = 0; $i < @linked_list; ++$i) {
1705 11         13 my $le = $linked_list[$i];
1706 11 50       23 if ('ARRAY' eq ref $le) {
1707 0         0 my $subfrom = _build_complex_query($le, $query_bind);
1708 0         0 my $ta = "t$tblnum";
1709 0         0 ++$tblnum;
1710 0         0 push @from, ["($subfrom)", $ta];
1711 0         0 next;
1712             }
1713 11 100       24 if (substr($le, 0, 1) ne '-') {
1714 5         15 my ($tn, $ta) = split ' ', $le;
1715 5 50       12 $ta = $tn if not $ta;
1716 5         10 my $ncn = make_name($tn);
1717 5         13 $ncn = _schema_name($ncn);
1718 5 50       13 error_message {
1719             result => 'SQLERR',
1720             message => "Unknown table $tn"
1721             }
1722             unless setup_row($tn, $ncn);
1723 5         20 push @from, [$tn, $ta];
1724             } else {
1725 6         11 my $cmd = substr($le, 1);
1726 6 50 66     73 if ($cmd eq 'left') {
    50 100        
    100 66        
    50 33        
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
1727 0         0 $from[-1][_table_join] = 'left join';
1728             } elsif ($cmd eq 'right') {
1729 0         0 $from[-1][_table_join] = 'right join';
1730             } elsif ($cmd eq 'join') {
1731 1         4 $from[-1][_table_join] = 'join';
1732             } elsif ($cmd eq 'on') {
1733 0         0 $from[-1][_table_join_on] = ["on", $linked_list[++$i]];
1734             } elsif ($cmd eq 'using') {
1735 0         0 $from[-1][_table_join_on] = ["using", $linked_list[++$i]];
1736             } elsif ($cmd eq 'as') {
1737 0         0 $from[-1][_table_alias] = $linked_list[++$i];
1738             } elsif ($cmd eq 'where') {
1739 0         0 $conditions = $linked_list[++$i];
1740             } elsif ($cmd eq 'group_by') {
1741 0         0 $groupby = $linked_list[++$i];
1742             } elsif ($cmd eq 'order_by') {
1743 0         0 $orderby = $linked_list[++$i];
1744             } elsif ($cmd eq 'having') {
1745 0         0 $having = $linked_list[++$i];
1746             } elsif ($cmd eq 'limit') {
1747 0         0 $limit = 0 + $linked_list[++$i];
1748             } elsif ($cmd eq 'offset') {
1749 0         0 $offset = 0 + $linked_list[++$i];
1750             } elsif ($cmd eq 'columns'
1751             || $cmd eq 'column'
1752             || $cmd eq 'distinct'
1753             || $cmd eq 'count'
1754             || $cmd eq 'all')
1755             {
1756 5 50       23 if ($cmd eq 'all') {
1757 0         0 $all = 1;
1758             }
1759 5 100       17 if ($cmd eq 'distinct') {
1760 1         1 $distinct = 1;
1761             }
1762 5 100       14 if ($cmd eq 'count') {
1763 2         3 $count = 1;
1764             }
1765 5 100 66     27 if ($i + 1 < @linked_list && substr($linked_list[$i + 1], 0, 1) ne '-') {
1766 4         8 my $cols = $linked_list[++$i];
1767 4 100 66     40 if ($cols && $cols !~ /^\d|^true$/) {
    50 33        
      33        
1768 2 50       6 if ('ARRAY' eq ref($cols)) {
1769 0         0 push @columns, @$cols;
1770             } else {
1771 2         5 push @columns, $cols;
1772             }
1773             } elsif (($cols =~ /^\d+$/ && $cols == 0) || $cols eq '') {
1774 0 0       0 $distinct = 0 if $cmd eq 'distinct';
1775             }
1776             }
1777 5 50       12 if ($cmd eq 'column') {
1778 0         0 ++$one_column;
1779             } else {
1780 5         11 $one_column += 2;
1781             }
1782              
1783             } else {
1784 0         0 error_message {
1785             result => 'SQLERR',
1786             message => "Unknown directive $le"
1787             };
1788             }
1789             }
1790             }
1791 4 50       7 error_message {
1792             result => 'SQLERR',
1793             message => "No table to build query on"
1794             } if !@from;
1795 4         11 for (my $idx = 1; $idx < @from; ++$idx) {
1796 1 50 33     10 next if $from[$idx][_table_join_on] or not $from[$idx - 1][_table_join];
1797 1 50       6 next if substr($from[$idx][_table_name], 0, 1) eq "(";
1798 1         2 my $cta = $from[$idx][_table_alias];
1799 1         3 my $cto = make_name($from[$idx][_table_name]);
1800 1         3 my $ucct = ucfirst $from[$idx][_table_name];
1801 1         3 my @join;
1802 1         6 for (my $i = $idx - 1; $i >= 0; --$i) {
1803 1 50       4 next if not $from[$i][_table_join];
1804 1         2 my $ptn = $from[$i][_table_name];
1805 1 50       4 next if substr($ptn, 0, 1) eq "(";
1806 1         3 my $ucfptn = ucfirst $ptn;
1807 1 50       13 if ($cto->can("foreignKey$ucfptn")) {
1808 1         4 my $fkfn = "foreignKey$ucfptn";
1809 1         31 my ($ctf, $ptk) = $cto->$fkfn;
1810 1         11 push @join, "$cta.$ctf = " . $from[$i][_table_alias] . ".$ptk";
1811             } else {
1812 0         0 my $ptno = make_name($ptn);
1813 0 0       0 if ($ptno->can("foreignKey$ucct")) {
1814 0         0 my $fkfn = "foreignKey$ucct";
1815 0         0 my ($ptf, $ctk) = $ptno->$fkfn;
1816 0         0 push @join, "$cta.$ctk = " . $from[$i][_table_alias] . ".$ptf";
1817             }
1818             }
1819             }
1820 1         9 $from[$idx][_table_join_on] = ["on", join(" and ", @join)];
1821             }
1822 4         9 my $from = '';
1823 4 100       11 @columns = ('*') if not @columns;
1824 4 50       8 @columns = map {('SCALAR' eq ref) ? DBIx::Struct::connect->dbh->quote_identifier($$_) : $_} @columns;
  4         18  
1825 4         12 my $joined = 0;
1826 4         15 for (my $idx = 0; $idx < @from; ++$idx) {
1827 5 100       10 if (not $joined) {
1828 4         13 $from .= " " . $from[$idx][_table_name];
1829 4 50       11 $from .= " " . $from[$idx][_table_alias] if $from[$idx][_table_alias] ne $from[$idx][_table_name];
1830             }
1831 5 100       17 if ($from[$idx][_table_join]) {
1832 1         4 my $nt = $from[$idx + 1];
1833 1         5 $from .= " " . $from[$idx][_table_join];
1834 1         4 $from .= " " . $nt->[_table_name];
1835 1 50       8 $from .= " " . $nt->[_table_alias] if $nt->[_table_alias] ne $nt->[_table_name];
1836 1         3 my $using_on = $nt->[_table_join_on][0];
1837 1 50 33     22 if ($using_on eq 'on' and ref $nt->[_table_join_on][1]) {
1838 0         0 my ($on_where, @on_bind) = $sql_abstract->where($nt->[_table_join_on][1]);
1839 0         0 $on_where =~ s/WHERE //;
1840 0         0 push @$query_bind, @on_bind;
1841 0         0 $from .= " $using_on(" . $on_where . ")";
1842             } else {
1843 1         8 $from .= " $using_on(" . $nt->[_table_join_on][1] . ")";
1844             }
1845 1         4 $joined = 1;
1846             } else {
1847 4 50       13 $from .= "," if $idx != $#from;
1848 4         9 $joined = 0;
1849             }
1850             }
1851 4         11 my $what = join(", ", @columns);
1852 4 100       10 if ($count) {
1853 2         2 $one_column = 1;
1854 2 100       6 if ($distinct) {
    50          
1855 1 50       77 $what = $from[0][_table_alias] . ".*" if $what eq '*';
1856 1         11 $what = "count(distinct $what)";
1857             } elsif ($all) {
1858 0 0       0 $what = $from[0][_table_alias] . ".*" if $what eq '*';
1859 0         0 $what = "count(all $what)";
1860             } else {
1861 1         3 $what = "count(*)";
1862             }
1863             } else {
1864 2 50       6 if ($distinct) {
1865 0         0 $what = "distinct $what";
1866             }
1867             }
1868 4         16 my $ret = "select $what from" . $from;
1869 4 50       14 if (not defined $where) {
1870 0         0 my $sql_grp = _parse_groupby($groupby);
1871 0         0 my $having_bind = [];
1872 0 0 0     0 if ($sql_grp && defined $having) {
1873 0         0 my $sql_having;
1874 0         0 ($sql_having, $having_bind) = _parse_having($having);
1875 0         0 $sql_grp .= " $sql_having";
1876             }
1877 0 0       0 if ($conditions) {
1878 0         0 my @where_bind;
1879 0         0 ($where, @where_bind) = $sql_abstract->where($conditions);
1880 0         0 push @$query_bind, @where_bind;
1881             } else {
1882 0         0 $where = '';
1883             }
1884 0 0       0 if (defined $sql_grp) {
1885 0         0 $where .= " $sql_grp";
1886 0         0 push @$query_bind, @$having_bind;
1887             }
1888 0 0       0 $where .= " limit $limit" if defined $limit;
1889 0 0       0 $where .= " offset $offset" if $offset;
1890             }
1891 4 50       10 $ret .= " $where" if $where;
1892 4 50       17 if (wantarray) {
1893 4         38 return ($ret, $one_column == 1);
1894             } else {
1895 0         0 return $ret;
1896             }
1897             }
1898              
1899             sub _parse_groupby {
1900 20     20   29 my $groupby = $_[0];
1901 20         28 my $sql_grp;
1902 20 100       44 if (defined $groupby) {
1903 2         4 $sql_grp = "GROUP BY ";
1904             my @groupby =
1905 2 50       6 map {/^\d+$/ ? $_ : /^[a-z][\w ]*$/i ? "\"$_\"" : "$_"} (ref($groupby) ? @$groupby : ($groupby));
  2 50       23  
    50          
1906 2         8 $sql_grp .= join(", ", @groupby);
1907             }
1908 20         39 $sql_grp;
1909             }
1910              
1911             sub _parse_having {
1912 2     2   3 my $having = $_[0];
1913 2         3 my $sql_having;
1914             my @having_bind;
1915 2 50       5 if (defined $having) {
1916 2         9 ($sql_having, @having_bind) = $sql_abstract->where($having);
1917 2         746 $sql_having =~ s/\bWHERE\b/HAVING/;
1918             }
1919 2         21 ($sql_having, \@having_bind);
1920             }
1921              
1922             sub execute {
1923 20     20 0 50 my ($groupby, $having, $up_conditions, $up_order, $up_limit, $up_offset, $up_interface, $sql, $dry_run);
1924 20         39 my $distinct = '';
1925 20         74 for (my $i = 2; $i < @_; ++$i) {
1926 18 100 66     105 next unless defined $_[$i] and not ref $_[$i];
1927 8 100       89 if ($_[$i] eq '-group_by') {
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
1928 2         8 (undef, $groupby) = splice @_, $i, 2;
1929 2         5 --$i;
1930             } elsif ($_[$i] eq '-distinct') {
1931 0         0 $distinct = ' distinct';
1932 0         0 splice @_, $i, 1;
1933 0         0 --$i;
1934             } elsif ($_[$i] eq '-having') {
1935 2         3 (undef, $having) = splice @_, $i, 2;
1936 2         3 --$i;
1937             } elsif ($_[$i] eq '-order_by') {
1938 0         0 (undef, $up_order) = splice @_, $i, 2;
1939 0         0 --$i;
1940             } elsif ($_[$i] eq '-where') {
1941 0         0 (undef, $up_conditions) = splice @_, $i, 2;
1942 0         0 --$i;
1943             } elsif ($_[$i] eq '-limit') {
1944 0         0 (undef, $up_limit) = splice @_, $i, 2;
1945 0         0 --$i;
1946             } elsif ($_[$i] eq '-interface') {
1947 0         0 (undef, $up_interface) = splice @_, $i, 2;
1948 0         0 --$i;
1949             } elsif ($_[$i] eq '-offset') {
1950 0         0 (undef, $up_offset) = splice @_, $i, 2;
1951 0         0 --$i;
1952             } elsif ($_[$i] eq '-sql') {
1953 0         0 (undef, $sql) = splice @_, $i, 2;
1954 0         0 --$i;
1955             } elsif ($_[$i] eq '-dry_run') {
1956 0         0 (undef, $dry_run) = splice @_, $i, 2;
1957 0         0 --$i;
1958             } elsif (substr($_[$i], 0, 1) eq '-') {
1959 0         0 error_message {
1960             result => 'SQLERR',
1961             message => "Unknown directive $_[$i]"
1962             };
1963             }
1964             }
1965 20         32 $tblnum = 1;
1966 20         54 my $sql_grp = _parse_groupby($groupby);
1967 20         37 my $having_bind = [];
1968 20 100 66     54 if ($sql_grp && defined $having) {
1969 2         2 my $sql_having;
1970 2         8 ($sql_having, $having_bind) = _parse_having($having);
1971 2         8 $sql_grp .= " $sql_having";
1972             }
1973 20         55 my ($code, $table, $conditions, $order, $limit, $offset) = @_;
1974 20         36 my $have_conditions = @_ > 2;
1975 20   66     66 $conditions //= $up_conditions;
1976 20   33     74 $order //= $up_order;
1977 20   33     63 $limit //= $up_limit;
1978 20   33     59 $offset //= $up_offset;
1979 20         22 my $where;
1980 20         27 my $need_where = 0;
1981 20         32 my @where_bind;
1982 20   100     90 my $simple_table = (not ref $table and index($table, " ") == -1);
1983 20         25 my $ncn;
1984              
1985 20 100       41 if ($simple_table) {
1986 15         33 $ncn = make_name($table);
1987 15         41 $ncn = _schema_name($ncn);
1988 15         37 setup_row($table, $ncn);
1989 15 100 100     90 if ($have_conditions and not ref $conditions) {
1990 4 50       33 my $id = ($ncn->selectKeys())[0]
1991             or error_message {
1992             result => 'SQLERR',
1993             message => "unknown primary key",
1994             query => "select * from $table",
1995             };
1996 4 50       11 if (defined $conditions) {
1997 4         12 $where = "where $id = ?";
1998 4         12 @where_bind = ($conditions);
1999             } else {
2000 0         0 $where = "where $id is null";
2001             }
2002             } else {
2003 11         21 $need_where = 1;
2004             }
2005             } else {
2006 5         11 $need_where = 1;
2007             }
2008 20 100       46 if ($need_where) {
2009 16         79 ($where, @where_bind) = $sql_abstract->where($conditions);
2010             }
2011 20 100       2261 if (defined $sql_grp) {
2012 2         8 $where .= " $sql_grp";
2013 2         6 push @where_bind, @$having_bind;
2014             }
2015 20 50       53 if ($order) {
2016 0         0 my ($order_sql, @order_bind) = $sql_abstract->where(undef, $order);
2017 0         0 $where .= " $order_sql";
2018 0         0 push @where_bind, @order_bind;
2019             }
2020 20 50       50 if (defined($limit)) {
2021 0         0 $limit += 0;
2022 0         0 $where .= " limit $limit";
2023             }
2024 20 50       44 if (defined($offset)) {
2025 0         0 $offset += 0;
2026 0 0       0 $where .= " offset $offset" if $offset;
2027             }
2028 20         29 my $query;
2029             my @query_bind;
2030 20         29 my $one_column = 0;
2031 20 100       35 if ($simple_table) {
2032 15         44 $query = qq{select$distinct * from $table $where};
2033             } else {
2034 5 100       14 if (not ref $table) {
2035 1         3 $query = "$table $where";
2036             } else {
2037 4         13 ($query, $one_column) = _cached_complex_query($table, \@query_bind, $where);
2038             }
2039 5         16 $ncn = make_name($query);
2040             }
2041 20 50       41 if ($sql) {
2042 0 0       0 if ('CODE' eq ref $sql) {
    0          
2043 0         0 $sql->($query, \@where_bind);
2044             } elsif ('SCALAR' eq ref $sql) {
2045 0         0 $$sql = $query;
2046             }
2047             }
2048 20 50       43 return if $dry_run;
2049 20         66 '' =~ /()/;
2050 20         23 my $sth;
2051             return DBIx::Struct::connect->run(
2052             sub {
2053 20 50   20   223 $sth = $_->prepare($query)
2054             or error_message {
2055             result => 'SQLERR',
2056             message => $_->errstr,
2057             query => $query,
2058             };
2059 20 50       840 $sth->execute(@query_bind, @where_bind)
2060             or error_message {
2061             result => 'SQLERR',
2062             message => $_->errstr,
2063             query => $query,
2064             where_bind => Dumper(\@where_bind),
2065             query_bind => Dumper(\@query_bind),
2066             conditions => Dumper($conditions),
2067             };
2068 20         339 setup_row($sth, $ncn, $up_interface);
2069 20         69 return $code->($sth, $ncn, $one_column);
2070             }
2071 20         49 );
2072             }
2073              
2074             sub one_row {
2075             return execute(
2076             sub {
2077 20     20   46 my ($sth, $ncn, $one_column) = @_;
2078 20         66 my $data = $sth->fetchrow_arrayref;
2079 20         329 $sth->finish;
2080 20 100       60 return if not $data;
2081 19 100       37 if ($one_column) {
2082             #<<<
2083             # json type is not working yet here
2084             # no strict 'refs';
2085             # my @f = %{$ncn . "::field_types"};
2086             # if ($f[1] eq 'json') {
2087             # return (defined($data->[0]) ? from_json($data->[0]) : undef);
2088             # } else {
2089 2         12 return $data->[0];
2090             #>>> }
2091             }
2092 17         417 return $ncn->new([@$data]);
2093             },
2094             @_
2095 20     20 1 5049 );
2096             }
2097              
2098             sub all_rows {
2099 0     0 1 0 my $mapfunc;
2100 0         0 for (my $i = 0; $i < @_; ++$i) {
2101 0 0       0 if (ref($_[$i]) eq 'CODE') {
2102 0         0 $mapfunc = splice @_, $i, 1;
2103 0         0 last;
2104             }
2105             }
2106             return execute(
2107             sub {
2108 0     0   0 my ($sth, $ncn, $one_column) = @_;
2109 0         0 my @rows;
2110             my $row;
2111 0 0       0 if ($mapfunc) {
2112 0         0 while ($row = $sth->fetch) {
2113 0         0 local $_ = $ncn->new([@$row]);
2114 0         0 push @rows, $mapfunc->();
2115             }
2116             } else {
2117 0 0       0 if ($one_column) {
2118             #<<<
2119             # json type is not working yet here
2120             # no strict 'refs';
2121             # my @f = %{$ncn . "::field_types"};
2122             # if ($f[1] eq 'json') {
2123             # push @rows, (defined($row->[0]) ? from_json($row->[0]) : undef) while ($row = $sth->fetch);
2124             # } else {
2125 0         0 push @rows, $row->[0] while ($row = $sth->fetch);
2126             # }
2127             #>>>
2128             } else {
2129 0         0 push @rows, $ncn->new([@$row]) while ($row = $sth->fetch);
2130             }
2131             }
2132 0         0 return \@rows;
2133             },
2134             @_
2135 0         0 );
2136             }
2137              
2138             sub for_rows {
2139 0     0 1 0 my $itemfunc;
2140 0         0 for (my $i = 0; $i < @_; ++$i) {
2141 0 0       0 if (ref($_[$i]) eq 'CODE') {
2142 0         0 $itemfunc = splice @_, $i, 1;
2143 0         0 last;
2144             }
2145             }
2146 0 0       0 error_message {
2147             result => 'SQLERR',
2148             message => "Item function is required",
2149             query => "(not parsed)",
2150             where_bind => "(not parsed)",
2151             query_bind => "(not parsed)",
2152             conditions => "(not parsed)",
2153             }
2154             if not $itemfunc;
2155             return execute(
2156             sub {
2157 0     0   0 my ($sth, $ncn) = @_;
2158 0         0 my $rows = 0;
2159 0         0 my $row;
2160 0         0 my $dbh = $_;
2161 0 0       0 local $dbh->{mysql_use_result} = 1 if $connector_driver eq 'mysql';
2162 0         0 local $_;
2163 0         0 while ($row = $sth->fetch) {
2164 0         0 ++$rows;
2165 0         0 $_ = $ncn->new([@$row]);
2166 0 0       0 last if not $itemfunc->();
2167             }
2168 0         0 return $rows;
2169             },
2170             @_
2171 0         0 );
2172             }
2173              
2174             sub new_row {
2175 3     3 1 882 my ($table, @data) = @_;
2176 3         8 my $simple_table = (index($table, " ") == -1);
2177 3 50       8 error_message {
2178             result => 'SQLERR',
2179             message => "insert row can't work for queries"
2180             }
2181             unless $simple_table;
2182 3         6 my $ncn = make_name($table);
2183 3         7 $ncn = _schema_name($ncn);
2184 3         7 $ncn = setup_row($table, $ncn);
2185 3         46 return $ncn->new(@data);
2186             }
2187              
2188             1;