File Coverage

lib/DBIx/Struct.pm
Criterion Covered Total %
statement 1040 2388 43.5
branch 297 1110 26.7
condition 126 352 35.8
subroutine 160 293 54.6
pod 6 29 20.6
total 1629 4172 39.0


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