package DBIx::Struct::JSON::Array; use strict; use warnings; sub TIEARRAY { bless [$_[1], $_[2], $_[3]], $_[0]; } sub FETCHSIZE { scalar @{$_[0][0]}; } sub STORESIZE { $_[0][1]{$_[0][2]} = undef; $#{$_[0][0]} = $_[1] - 1; } sub STORE { $_[0][1]{$_[0][2]} = undef; $_[0][0][$_[1]] = $_[2]; } sub FETCH {$_[0][0][$_[1]]} sub CLEAR { $_[0][1]{$_[0][2]} = undef; @{$_[0][0]} = (); } sub POP { $_[0][1]{$_[0][2]} = undef; pop(@{$_[0][0]}); } sub PUSH { my $o = shift; $o->[1]{$o->[2]} = undef; push(@{$o->[0]}, @_); } sub SHIFT { $_[0][1]{$_[0][2]} = undef; shift(@{$_[0][0]}); } sub UNSHIFT { my $o = shift; $o->[1]{$o->[2]} = undef; unshift(@$o, @_); } sub EXISTS {exists $_[0][0]->[$_[1]]} sub DELETE {delete $_[0][0]->[$_[1]]} sub SPLICE { my $ob = shift; my $sz = $ob->FETCHSIZE; my $off = @_ ? shift : 0; $off += $sz if $off < 0; my $len = @_ ? shift : $sz - $off; $ob->[1]{$ob->[2]} = undef; return splice(@{$ob->[0]}, $off, $len, @_); } package DBIx::Struct::JSON::Hash; use strict; use warnings; sub TIEHASH { bless [$_[1], $_[2], $_[3]], $_[0]; } sub STORE { $_[0][1]{$_[0][2]} = undef; $_[0][0]->{$_[1]} = $_[2]; } sub FETCH { $_[0][0]->{$_[1]}; } sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]}; } sub NEXTKEY { each %{$_[0][0]}; } sub EXISTS { exists $_[0][0]->{$_[1]}; } sub DELETE { $_[0][1]{$_[0][2]} = undef; delete $_[0][0]->{$_[1]}; } sub CLEAR { $_[0][1]{$_[0][2]} = undef; %{$_[0][0]} = (); } sub SCALAR { scalar %{$_[0][0]}; } package DBIx::Struct::JSON; use strict; use warnings; use JSON; sub factory { my ($class, $value_ref, $update_hash, $hash_key) = @_; my $self; if (not ref $$value_ref) { return if not $$value_ref; my $jv = from_json $$value_ref; $$value_ref = $jv if $jv; } if ('HASH' eq ref $$value_ref) { my %h; tie %h, 'DBIx::Struct::JSON::Hash', $$value_ref, $update_hash, $hash_key; $self = [\%h, $$value_ref]; } elsif ('ARRAY' eq ref $$value_ref) { my @a; tie @a, 'DBIx::Struct::JSON::Array', $$value_ref, $update_hash, $hash_key; $self = [\@a, $$value_ref]; } $$value_ref = bless $self, $class; } sub revert { $_[0] = to_json $_[0][1]; } sub accessor { $_[0][0]; } package DBIx::Struct::Connector; use strict; use warnings; use base 'DBIx::Connector'; our $db_reconnect_timeout = 30; sub _connect { my ($self, @args) = @_; for my $try (1 .. $db_reconnect_timeout) { my $dbh = eval {$self->SUPER::_connect(@args)}; return $dbh if $dbh; sleep 1 if $try != $db_reconnect_timeout; } die $@ if $@; die "DB connect error"; } package DBIx::Struct::Error::String; use strict; use warnings; use Carp; sub error_message (+%) { my $msg = $_[0]; delete $msg->{result}; my $message = delete $msg->{message}; croak join "; ", $message, map {"$_: $msg->{$_}"} keys %$msg; } package DBIx::Struct::Error::Hash; use strict; use warnings; sub error_message (+%) { die $_[0]; } package DBIx::Struct; use strict; use warnings; use SQL::Abstract; use Digest::MD5; use Data::Dumper; use base 'Exporter'; use v5.14; our $VERSION = '0.13'; our @EXPORT = qw{ one_row all_rows new_row }; our @EXPORT_OK = qw{ connector hash_ref_slice }; our $conn; our $update_on_destroy = 1; our $connector_module = 'DBIx::Struct::Connector'; our $connector_constructor = 'new'; our $connector_pool; our $connector_pool_method = 'get_connector'; our $connector_args = []; our $connector_driver; our $table_classes_namespace = 'DBC'; our $query_classes_namespace = 'DBQ'; our $error_message_class = 'DBIx::Struct::Error::String'; our %driver_pk_insert; sub error_message (+%) { goto &DBIx::Struct::Error::String::error_message; } %driver_pk_insert = ( _returning => sub { my ($table, $pk_row_data, $pk_returninig) = @_; my $ret; if ($pk_row_data) { $ret = <<INS; ($pk_row_data) = \$_->selectrow_array(\$insert . " $pk_returninig", undef, \@bind) INS } else { $ret = <<INS; \$_->do(\$insert, undef, \@bind) INS } $ret .= <<INS or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' inserting into table $table' }; INS }, _last_id_undef => sub { my ($table, $insert_exp, $pk_row_data) = @_; my $ret; $ret = <<INS; \$_->do(\$insert, undef, \@bind) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' inserting into table $table' }; INS if ($pk_row_data) { $ret .= <<INS; $pk_row_data = $_->last_insert_id(undef, undef, undef, undef); INS } }, _last_id_empty => sub { my ($table, $insert_exp, $pk_row_data) = @_; my $ret; $ret = <<INS; \$_->do(\$insert, undef, \@bind) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' inserting into table $table' }; INS if ($pk_row_data) { $ret .= <<INS; $pk_row_data = $_->last_insert_id("", "", "", ""); INS } } ); $driver_pk_insert{Pg} = $driver_pk_insert{_returning}; $driver_pk_insert{mysql} = $driver_pk_insert{_last_id_undef}; $driver_pk_insert{SQLite} = $driver_pk_insert{_last_id_empty}; sub hash_ref_slice($@) { my ($hashref, @slice) = @_; error_message { message => "first parameter is not hash reference", result => 'INTERR', } if 'HASH' ne ref $hashref; map {$_ => $hashref->{$_}} @slice; } my @already_exported_to; sub connector { $conn; } sub connector_from_pool { $connector_pool->$connector_pool_method(); } sub set_connector_pool { $connector_pool = $_[0]; if (\&connector != \&connector_from_pool) { no warnings 'redefine'; no strict 'refs'; *connector = \&connector_from_pool; for my $aep (@already_exported_to) { *{"$aep\::connector"} = \&connector; } } } sub set_connector_pool_method { $connector_pool_method = $_[0]; } sub set_connector_object { *conn = \$_[0]; } sub check_package_scalar { my ($package, $scalar) = @_; no strict 'refs'; my $pr = \%{$package . '::'}; my $er = $$pr{$scalar}; return unless $er; defined *{$er}{'SCALAR'}; } sub import { my ($class, @args) = @_; my $defconn = 0; my $_emc = 0; my $_cp = 0; my $_c = 0; for (my $i = 0; $i < @args; ++$i) { if ($args[$i] eq 'connector_module') { (undef, $connector_module) = splice @args, $i, 2; --$i; if (not $defconn and check_package_scalar($connector_module, 'conn')) { no strict 'refs'; set_connector_object(${$connector_module . '::conn'}); } } elsif ($args[$i] eq 'connector_constructor') { (undef, $connector_constructor) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'table_classes_namespace') { (undef, $table_classes_namespace) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'query_classes_namespace') { (undef, $query_classes_namespace) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'connect_timeout') { (undef, $db_reconnect_timeout) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'error_class') { my (undef, $emc) = splice @args, $i, 2; $error_message_class = $emc; $_emc = 1; --$i; } elsif ($args[$i] eq 'connector_pool') { (undef, $connector_pool) = splice @args, $i, 2; $_cp = 1; --$i; } elsif ($args[$i] eq 'connector_pool_method') { (undef, $connector_pool_method) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'connector_args') { (undef, $connector_args) = splice @args, $i, 2; --$i; } elsif ($args[$i] eq 'connector') { $_c = 1; } elsif ($args[$i] eq 'connector_object') { $defconn = 1; set_connector_object($args[$i + 1]); splice @args, $i, 2; --$i; } } if ($_emc) { no warnings 'redefine'; no strict 'refs'; *error_message = \&{$error_message_class . "::error_message"}; } if ($_cp) { no warnings 'redefine'; no strict 'refs'; *connector = \&connector_from_pool; for my $aep (@already_exported_to) { *{"$aep\::connector"} = \&connector; } } my $callpkg = caller; push @already_exported_to, $callpkg if $_c; my %imps = map {$_ => undef} @args, @EXPORT; $class->export_to_level(1, $class, keys %imps); } sub _not_yet_connected { if (!$connector_pool && !$conn) { my ($dsn, $user, $password) = @_; if ($dsn && $dsn !~ /^dbi:/i) { $dsn = "dbi:Pg:dbname=$dsn"; } my $connect_attrs = { AutoCommit => 1, PrintError => 0, AutoInactiveDestroy => 1, RaiseError => 0, }; if ($dsn) { my ($driver) = $dsn =~ /^dbi:(\w*?)(?:\((.*?)\))?:/i; if ($driver) { if ($driver eq 'Pg') { $connect_attrs->{pg_enable_utf8} = 1; } elsif ($driver eq 'mysql') { $connect_attrs->{mysql_enable_utf8} = 1; } } } if (!@$connector_args) { @$connector_args = ($dsn, $user, $password, $connect_attrs); } $conn = $connector_module->$connector_constructor(@$connector_args) or error_message { message => "DB connect error", result => 'SQLERR', }; $conn->mode('fixup'); } '' =~ /()/; $connector_driver = connector->driver->{driver}; no warnings 'redefine'; *connect = \&connector; populate(); connector; } sub connect { goto &_not_yet_connected; } { my $md5 = Digest::MD5->new; sub make_name { my ($table) = @_; my $simple_table = (index($table, " ") == -1); my $ncn; if ($simple_table) { $ncn = $table_classes_namespace . "::" . join('', map {ucfirst($_)} split(/[^a-zA-Z0-9]/, $table)); } else { $md5->add($table); $ncn = $query_classes_namespace . "::" . "G" . $md5->hexdigest; $md5->reset; } $ncn; } } sub populate { my @tables; DBIx::Struct::connect->run( sub { my $sth = $_->table_info('', '', '%', "TABLE"); return if not $sth; my $tables = $sth->fetchall_arrayref; @tables = map {$_->[2]} grep {$_->[3] eq 'TABLE' and $_->[2] !~ /^sql_/} @$tables; } ); setup_row($_) for @tables; } sub _row_data () {0} sub _row_updates () {1} sub make_object_new { my ($table, $required, $pk_row_data, $pk_returninig) = @_; my $new = <<NEW; sub new { my \$class = \$_[0]; my \$self = [ [] ]; bless \$self, \$class; if(CORE::defined(\$_[1]) && CORE::ref(\$_[1]) eq 'ARRAY') { \$self->[@{[_row_data]}] = \$_[1]; } NEW if (not ref $table) { $new .= <<NEW; else { my \%insert; for(my \$i = 1; \$i < \@_; \$i += 2) { if (CORE::exists \$fields{\$_[\$i]}) { my \$f = \$_[\$i]; \$self->[@{[_row_data]}]->[\$fields{\$_[\$i]}] = \$_[\$i + 1]; \$insert{\$f} = \$_[\$i + 1]; } else { DBIx::Struct::error_message { result => 'SQLERR', message => "unknown column \$_[\$i] inserting into table $table" } } } my (\@insert, \@values, \@bind); \@insert = CORE::map { if(CORE::ref(\$insert{\$_}) eq 'ARRAY' and CORE::ref(\$insert{\$_}[0]) eq 'SCALAR') { CORE::push \@bind, \@{\$insert{\$_}}[1..\$#{\$insert{\$_}}]; CORE::push \@values, \${\$insert{\$_}[0]}; "\$_"; } elsif(CORE::ref(\$insert{\$_}) eq 'REF' and CORE::ref(\${\$insert{\$_}}) eq 'ARRAY') { if(CORE::defined \${\$insert{\$_}}->[0]) { CORE::push \@bind, \@{\${\$insert{\$_}}}[1..\$#{\${\$insert{\$_}}}]; CORE::push \@values, \${\$insert{\$_}}->[0]; "\$_"; } else { CORE::push \@values, "null"; "\$_" } } elsif(CORE::ref(\$insert{\$_}) eq 'SCALAR') { CORE::push \@values, \${\$insert{\$_}}; "\$_"; } elsif(CORE::exists (\$json_fields{\$_}) && (CORE::ref(\$insert{\$_}) eq 'ARRAY' || CORE::ref(\$insert{\$_}) eq 'HASH')) { CORE::push \@bind, JSON::to_json(\$insert{\$_}); CORE::push \@values, "?"; "\$_" } else { CORE::push \@bind, \$insert{\$_}; CORE::push \@values, "?"; "\$_" } } CORE::keys \%insert; my \$insert; if(\%insert){ \$insert = "insert into $table (" . CORE::join( ", ", \@insert) . ") values (" . CORE::join( ", ", \@values) . ")"; } else { \$insert = "insert into $table values (default)"; } NEW if ($required) { $new .= <<NEW; for my \$r ($required) { DBIx::Struct::error_message { result => 'SQLERR', message => "required field \$r is absent for table $table" } if not CORE::exists \$insert{\$r}; } NEW } $new .= <<NEW; DBIx::Struct::connect->run( sub { NEW $new .= $driver_pk_insert{$connector_driver}->($table, $pk_row_data, $pk_returninig); $new .= <<NEW; }); } NEW } $new .= <<NEW; \$self; } NEW $new; } sub make_object_filter_timestamp { my ($timestamps) = @_; my $filter_timestamp = <<FTS; sub filter_timestamp { my \$self = \$_[0]; if(\@_ == 1) { for my \$f ($timestamps) { if(\$self->[@{[_row_data]}][\$fields{\$f}]) { \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/\\.\\d+(\$|\\+|\\-)/$1/; \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/(\\+|\\-)(\\d{2})\$/\$1\${2}00/; } } } else { for my \$f (\@_[1..\$#_]) { if(\$self->[@{[_row_data]}][\$fields{\$f}]) { \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/\\.\\d+(\$|\\+|\\-)/$1/; \$self->[@{[_row_data]}][\$fields{\$f}] =~ s/(\\+|\\-)(\\d{2})\$/\$1\${2}00/; } } } '' =~ /()/; \$self; } FTS $filter_timestamp; } sub make_object_set { my $set = <<SET; sub set { my \$self = \$_[0]; if(CORE::defined(\$_[1])) { if(CORE::ref(\$_[1]) eq 'ARRAY') { \$self->[@{[_row_data]}] = \$_[1]; \$self->[@{[_row_updates]}] = {}; } elsif(CORE::ref(\$_[1]) eq 'HASH') { for my \$f (CORE::keys \%{\$_[1]}) { if (CORE::exists \$fields{\$f}) { \$self->\$f(\$_[1]->{\$f}); } } } elsif(not CORE::ref(\$_[1])) { for(my \$i = 1; \$i < \@_; \$i += 2) { if (CORE::exists \$fields{\$_[\$i]}) { my \$f = \$fields{\$_[\$i]}; \$self->\$f(\$_[\$i + 1]); } } } } \$self; } SET $set; } sub make_object_data { my $data = <<DATA; sub data { my \$self = \$_[0]; my \@ret_keys; my \$ret; if(CORE::defined(\$_[1])) { if(CORE::ref(\$_[1]) eq 'ARRAY') { if(!\@{\$_[1]}) { \$ret = \$self->[@{[_row_data]}]; } else { \$ret = [CORE::map {\$self->[@{[_row_data]}]->[\$fields{\$_}] } CORE::grep {CORE::exists \$fields{\$_}} \@{\$_[1]}]; } } else { for my \$k (\@_[1..\$#_]) { CORE::push \@ret_keys, \$k if CORE::exists \$fields{\$k}; } } } else { \@ret_keys = keys \%fields; } \$ret = { CORE::map { CORE::exists(\$json_fields{\$_}) ? (\$_ => \$self->\$_->accessor) : (\$_ => \$self->\$_) } \@ret_keys } if not CORE::defined \$ret; \$ret; } DATA $data; } sub make_object_update { my ($table, $pk_where, $pk_row_data) = @_; my $update; if (not ref $table) { # means this is just one simple table $update = <<UPD; sub update { my \$self = \$_[0]; if(\@_ > 1 && CORE::ref(\$_[1]) eq 'HASH') { my (\$set, \$where, \@bind, \@bind_where); { no strict 'vars'; local *set_hash = \$_[1]; my \@unknown_columns = CORE::grep {not CORE::exists \$fields{\$_}} CORE::keys %set_hash; DBIx::Struct::error_message { result => 'SQLERR', message => 'unknown columns '.CORE::join(", ", \@unknown_columns).' updating table $table' } if \@unknown_columns; \$set = CORE::join ", ", CORE::map { if(CORE::ref(\$set_hash{\$_}) eq 'ARRAY' and CORE::ref(\$set_hash{\$_}[0]) eq 'SCALAR') { CORE::push \@bind, \@{\$set_hash{\$_}}[1..\$#{\$set_hash{\$_}}]; "\$_ = " . \${\$set_hash{\$_}[0]}; } elsif(CORE::ref(\$set_hash{\$_}) eq 'REF' and CORE::ref(\${\$set_hash{\$_}}) eq 'ARRAY') { if(CORE::defined \${\$set_hash{\$_}}->[0]) { CORE::push \@bind, \@{\${\$set_hash{\$_}}}[1..\$#{\${\$set_hash{\$_}}}]; "\$_ = " . \${\$set_hash{\$_}}->[0]; } else { "\$_ = null" } } elsif(CORE::ref(\$set_hash{\$_}) eq 'SCALAR') { "\$_ = " . \${\$set_hash{\$_}}; } elsif(CORE::exists(\$json_fields{\$_}) && (CORE::ref(\$set_hash{\$_}) eq 'ARRAY' || CORE::ref(\$set_hash{\$_}) eq 'HASH')) { CORE::push \@bind, JSON::to_json(\$set_hash{\$_}); "\$_ = ?" } else { CORE::push \@bind, \$set_hash{\$_}; "\$_ = ?" } } CORE::keys \%set_hash; } if(\@_ > 2) { my \$cond = \$_[2]; if(not CORE::ref(\$cond)) { \$cond = {(selectKeys)[0] => \$_[2]}; } (\$where, \@bind_where) = SQL::Abstract->new->where(\$cond); } return DBIx::Struct::connect->run(sub { \$_->do(qq{update $table set \$set \$where}, undef, \@bind, \@bind_where) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' updating table $table' } }); } elsif (CORE::ref(\$self) && \@\$self > 1 && \%{\$self->[@{[_row_updates]}]}) { my (\$set, \@bind); { no strict 'vars'; \$set = CORE::join ", ", CORE::map { local *column_value = \\\$self->[@{[_row_data]}][\$fields{\$_}]; if(CORE::ref(\$column_value) eq 'ARRAY' and CORE::ref(\$column_value->[0]) eq 'SCALAR') { CORE::push \@bind, \@{\$column_value}[1..\$#\$column_value]; "\$_ = " . \${\$column_value->[0]}; } elsif(CORE::ref(\$column_value) eq 'REF' and CORE::ref(\${\$column_value}) eq 'ARRAY') { if(CORE::defined \${\$column_value}->[0]) { CORE::push \@bind, \@{\${\$column_value}}[1..\$#{\${\$column_value}}]; "\$_ = " . \${\$column_value}->[0]; } else { "\$_ = null" } } elsif(CORE::ref(\$column_value) && CORE::ref(\$column_value) =~ /^DBIx::Struct::JSON/) { \$column_value->revert; CORE::push \@bind, \$column_value; "\$_ = ?" } elsif(CORE::ref(\$column_value) eq 'SCALAR') { "\$_ = " . \$\$column_value; } else { CORE::push \@bind, \$column_value; "\$_ = ?" } } CORE::keys \%{\$self->[@{[_row_updates]}]}; } my \$update_query = qq{update $table set \$set where $pk_where}; DBIx::Struct::connect->run( sub { \$_->do(\$update_query, undef, \@bind, $pk_row_data) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' updating table $table', query => \$update_query, bind => \\\@bind, } } ); pop \@{\$self}; } \$self; } UPD } else { $update = <<UPD; sub update {} UPD } $update; } sub make_object_delete { my ($table, $pk_where, $pk_row_data) = @_; my $delete; if (not ref $table) { $delete = <<DEL; sub delete { my \$self = \$_[0]; if(\@_ > 1) { my (\$where, \@bind); my \$cond = \$_[1]; if(not CORE::ref(\$cond)) { \$cond = {(selectKeys)[0] => \$_[1]}; } (\$where, \@bind) = SQL::Abstract->new->where(\$cond); return DBIx::Struct::connect->run(sub { \$_->do(qq{delete from $table \$where}, undef, \@bind) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' updating table $table' } }); } else { DBIx::Struct::connect->run( sub { \$_->do(qq{delete from $table where $pk_where}, undef, $pk_row_data) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' updating table $table' } }); } \$self; } DEL } else { $delete = <<DEL sub delete {} DEL } $delete; } sub make_object_fetch { my ($table, $pk_where, $pk_row_data) = @_; my $fetch; if (not ref $table) { $fetch = <<FETCH; sub fetch { my \$self = \$_[0]; if(\@_ > 1) { my (\$where, \@bind); my \$cond = \$_[1]; if(not CORE::ref(\$cond)) { \$cond = {(selectKeys)[0] => \$_[1]}; } (\$where, \@bind) = SQL::Abstract->new->where(\$cond); DBIx::Struct::connect->run(sub { my \$rowref = \$_->selectrow_arrayref(qq{select * from $table \$where}, undef, \@bind) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' fetching table $table' }; \$self->[@{[_row_data]}] = [\@\$rowref]; }); } else { DBIx::Struct::connect->run( sub { my \$rowref = \$_->selectrow_arrayref(qq{select * from $table where $pk_where}, undef, $pk_row_data) or DBIx::Struct::error_message { result => 'SQLERR', message => 'error '.\$_->errstr.' fetching table $table' }; \$self->[@{[_row_data]}] = [\@\$rowref]; }); } \$self; } FETCH } else { $fetch = <<FETCH; sub fetch { \$_[0] } FETCH } $fetch; } sub _exists_row ($) { my $ncn = $_[0]; no strict "refs"; if (grep {!/::$/} keys %{"${ncn}::"}) { return 1; } return; } sub _parse_interface ($) { my $interface = $_[0]; my %ret; $interface = [$interface] if not ref $interface; if ('ARRAY' eq ref $interface) { for my $i (@$interface) { my $dbc_name = make_name($i); error_message { result => 'SQLERR', message => "Unknown base interface table $i", } unless _exists_row $dbc_name; no strict 'refs'; my $href = \%{"${dbc_name}::fkfuncs"}; if ($href && %$href) { my @i = keys %$href; @ret{@i} = @{$href}{@i}; } } } elsif ('HASH' eq ref $interface) { for my $i (keys %$interface) { my $dbc_name = make_name($i); error_message { result => 'SQLERR', message => "Unknown base interface table $i", } unless _exists_row $dbc_name; no strict 'refs'; my $href = \%{"${dbc_name}::fkfuncs"}; next if not $href or not %$href; my $fl = $interface->{$i}; $fl = [$fl] if not ref $fl; if ('ARRAY' eq ref $fl) { for my $m (@$fl) { $ret{$m} = $href->{$m} if exists $href->{$m}; } } else { error_message { result => 'SQLERR', message => "Usupported interface structure", }; } } } else { error_message { result => 'SQLERR', message => "Unknown interface structure: " . ref($interface), }; } \%ret; } sub setup_row { my ($table, $ncn, $interface) = @_; error_message { result => 'SQLERR', message => "Unsupported driver $connector_driver", } unless exists $driver_pk_insert{$connector_driver}; $ncn ||= make_name($table); return $ncn if _exists_row $ncn ; my %fields; my @fields; my @timestamp_fields; my @required; my @pkeys; my @fkeys; my @refkeys; my %json_fields; my $connector = DBIx::Struct::connect; if (not ref $table) { # means this is just one simple table $connector->run( sub { my $cih = $_->column_info(undef, undef, $table, undef); error_message { result => 'SQLERR', message => "Unknown table $table", } if not $cih; my $i = 0; while (my $chr = $cih->fetchrow_hashref) { $chr->{COLUMN_NAME} =~ s/"//g; push @fields, $chr->{COLUMN_NAME}; if ($chr->{TYPE_NAME} =~ /^time/) { push @timestamp_fields, $chr->{COLUMN_NAME}; } if ($chr->{TYPE_NAME} =~ /^json/) { $json_fields{$chr->{COLUMN_NAME}} = undef; } if ($chr->{NULLABLE} == 0 && !defined($chr->{COLUMN_DEF})) { push @required, $chr->{COLUMN_NAME}; } $fields{$chr->{COLUMN_NAME}} = $i++; } @pkeys = $_->primary_key(undef, undef, $table); if (!@pkeys && @required) { my $ukh = $_->statistics_info(undef, undef, $table, 1, 1); my %req = map {$_ => undef} @required; my %pkeys; while (my $ukr = $ukh->fetchrow_hashref) { if (not exists $req{$ukr->{COLUMN_NAME}} or defined $ukr->{FILTER_CONDITION}) { $pkeys{$ukr->{INDEX_NAME}}{drop} = 1; } else { $pkeys{$ukr->{INDEX_NAME}}{fields}{$ukr->{COLUMN_NAME}} = undef; } } my @d = grep {exists $pkeys{$_}{drop}} keys %pkeys; delete $pkeys{$_} for @d; if (%pkeys) { my @spk = sort {scalar(keys %{$pkeys{$a}{fields}}) <=> scalar(keys %{$pkeys{$b}{fields}})} keys %pkeys; @pkeys = keys %{$pkeys{$spk[0]}{fields}}; } } my $sth = $_->foreign_key_info(undef, undef, undef, undef, undef, $table); if ($sth) { @fkeys = grep {$_->{FK_COLUMN_NAME} !~ /[^a-z_0-9]/} @{$sth->fetchall_arrayref({})}; } $sth = $_->foreign_key_info(undef, undef, $table, undef, undef, undef); if ($sth) { @refkeys = grep {$_->{FK_COLUMN_NAME} !~ /[^a-z_0-9]/} @{$sth->fetchall_arrayref({})}; } } ); } else { # means this is a query %fields = %{$table->{NAME_hash}}; $connector->run( sub { for (my $cn = 0; $cn < @{$table->{NAME}}; ++$cn) { my $ti = $_->type_info($table->{TYPE}->[$cn]); push @timestamp_fields, $table->{NAME}->[$cn] if $ti && $ti->{TYPE_NAME} =~ /^time/; $json_fields{$table->{NAME}->[$cn]} = undef if $ti && $ti->{TYPE_NAME} =~ /^json/; } } ); } my $fields = join ", ", map {qq|"$_" => $fields{$_}|} keys %fields; my $json_fields = join ", ", map {qq|"$_" => undef|} keys %json_fields; my $required = ''; if (@required) { $required = join(", ", map {qq|"$_"|} @required); } my $timestamps = ''; if (@timestamp_fields) { $timestamps = join(", ", map {qq|"$_"|} @timestamp_fields); } else { $timestamps = "()"; } my %keywords = ( new => undef, set => undef, data => undef, delete => undef, fetch => undef, update => undef, DESTROY => undef, filter_timestamp => undef, ); my $pk_row_data = ''; my $pk_returninig = ''; my $pk_where = ''; my $select_keys = ''; my %pk_fields; if (@pkeys) { @pk_fields{@pkeys} = undef; $pk_row_data = join(", ", map {qq|\$self->[@{[_row_data]}]->[$fields{"$_"}]|} @pkeys); $pk_returninig = 'returning ' . join(", ", @pkeys); $pk_where = join(" and ", map {"$_ = ?"} @pkeys); my $sk_list = join(", ", map {qq|"$_"|} @pkeys); $select_keys = <<SK; sub selectKeys () { ($sk_list) } SK } else { if (@fields) { my $sk_list = join(", ", map {qq|"$_"|} @fields); $select_keys = <<SK; sub selectKeys () { ($sk_list) } SK } else { $select_keys = <<SK; sub selectKeys () { () } SK } } my $foreign_tables = ''; my %foreign_tables; my %fkfuncs; for my $fk (@fkeys) { $fk->{FK_COLUMN_NAME} =~ s/"//g; my $fn = $fk->{FK_COLUMN_NAME}; $fn =~ s/^id_// or $fn =~ s/_id(?=[^a-z]|$)//; $fn =~ tr/_/-/; $fn =~ s/\b(\w)/\u$1/g; $fn =~ tr/-//d; (my $pt = $fk->{PKTABLE_NAME} || $fk->{UK_TABLE_NAME}) =~ s/"//g; (my $pk = $fk->{PKCOLUMN_NAME} || $fk->{UK_COLUMN_NAME}) =~ s/"//g; $fkfuncs{$fn} = undef; $foreign_tables .= <<FKT; sub $fn { if(CORE::defined(\$_[0]->$fk->{FK_COLUMN_NAME})) { return DBIx::Struct::one_row("$pt", {$pk => \$_[0]->$fk->{FK_COLUMN_NAME}}); } else { return } } FKT $foreign_tables{$pt} = [$fk->{FK_COLUMN_NAME} => $pk]; } for my $ft (keys %foreign_tables) { my $ucft = ucfirst $ft; $fkfuncs{"foreignKey$ucft"} = undef; $foreign_tables .= <<FKT; sub foreignKey$ucft () {("$foreign_tables{$ft}[0]" => "$foreign_tables{$ft}[1]")} FKT } my $references_tables = ''; for my $rk (@refkeys) { $rk->{FK_TABLE_NAME} =~ s/"//g; my $ft = $rk->{FK_TABLE_NAME}; (my $fk = $rk->{FK_COLUMN_NAME}) =~ s/"//g; (my $pt = $rk->{PKTABLE_NAME} || $rk->{UK_TABLE_NAME}) =~ s/"//g; (my $pk = $rk->{PKCOLUMN_NAME} || $rk->{UK_COLUMN_NAME}) =~ s/"//g; if ($pk ne $fk) { my $fn = $fk; $fn =~ s/^id_// or $fn =~ s/_id(?=[^a-z]|$)//; $fn =~ s/$ft//; $ft .= "_$fn" if $fn; } $ft =~ tr/_/-/; $ft =~ s/\b(\w)/\u$1/g; $ft =~ tr/-//d; $fkfuncs{"ref${ft}s"} = undef; $fkfuncs{"ref${ft}"} = undef; $references_tables .= <<RT; sub ref${ft}s { my (\$self, \@cond) = \@_; my \%cond; if(\@cond) { if(not CORE::ref \$cond[0]) { \%cond = \@cond; } else { \%cond = \%{\$cond[0]}; } } \$cond{$fk} = \$self->$pk; return DBIx::Struct::all_rows("$rk->{FK_TABLE_NAME}", \\\%cond); } sub ref${ft} { my (\$self, \@cond) = \@_; my \%cond; if(\@cond) { if(not CORE::ref \$cond[0]) { \%cond = \@cond; } else { \%cond = \%{\$cond[0]}; } } \$cond{$fk} = \$self->$pk; return DBIx::Struct::one_row("$rk->{FK_TABLE_NAME}", \\\%cond); } RT } my $accessors = <<ACC; sub markUpdated { \$_[0]->[@{[_row_updates]}]{\$_[1]} = undef if CORE::exists \$fields{\$_[1]}; \$_[0]; } ACC for my $k (keys %fields) { next if exists $keywords{$k}; next if $k =~ /^\d/; $k =~ s/[^\w\d]/_/g; if (!exists $json_fields{$k}) { if (!exists($pk_fields{$k}) && (not ref $table)) { $accessors .= <<ACC; sub $k { if(\@_ > 1) { \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1]; \$_[0]->[@{[_row_updates]}]{"$k"} = undef; } \$_[0]->[@{[_row_data]}]->[$fields{$k}]; } ACC } else { $accessors .= <<ACC; sub $k { \$_[0]->[@{[_row_data]}]->[$fields{$k}]; } ACC } } else { if (!exists($pk_fields{$k}) && (not ref $table)) { $accessors .= <<ACC; sub $k { if(\@_ > 1) { if(not CORE::ref \$_[1]) { \$_[0]->[@{[_row_data]}]->[$fields{$k}] = \$_[1]; } else { \$_[0]->[@{[_row_data]}]->[$fields{$k}] = JSON::to_json(\$_[1]); } \$_[0]->[@{[_row_updates]}]{"$k"} = undef; } if(not CORE::ref \$_[0]->[@{[_row_data]}]->[$fields{$k}]) { \$_[0]->[@{[_row_updates]}] = {} if not \$_[0]->[@{[_row_updates]}]; \$_[0]->[@{[_row_data]}]->[$fields{$k}] = DBIx::Struct::JSON->factory(\\\$_[0]->[@{[_row_data]}]->[$fields{$k}], \$_[0]->[@{[_row_updates]}], "$k"); } \$_[0]->[@{[_row_data]}]->[$fields{$k}]->accessor; } ACC } else { $accessors .= <<ACC; sub $k { if(\$_[0]->[@{[_row_data]}]->[$fields{$k}] and not CORE::ref \$_[0]->[@{[_row_data]}]->[$fields{$k}]) { \$_[0]->[@{[_row_data]}]->[$fields{$k}] = JSON::from_json(\$_[0]->[@{[_row_data]}]->[$fields{$k}]); } \$_[0]->[@{[_row_data]}]->[$fields{$k}]; } ACC } } } my $package_header = <<PHD; package ${ncn}; use strict; use warnings; use Carp; use SQL::Abstract; use JSON; our \%fields = ($fields); our \%json_fields = ($json_fields); PHD if (not ref $table) { if (%fkfuncs) { my $fkfuncs = join ",", map {qq{"$_" => \\&${ncn}::$_}} keys %fkfuncs; $package_header .= <<PHD; our \%fkfuncs = ($fkfuncs); PHD } else { $package_header .= <<PHD; our \%fkfuncs = (); PHD } $package_header .= <<PHD; our \$table_name = "$table"; PHD } my $new = make_object_new($table, $required, $pk_row_data, $pk_returninig); my $filter_timestamp = make_object_filter_timestamp($timestamps); my $set = make_object_set(); my $data = make_object_data(); my $update = make_object_update($table, $pk_where, $pk_row_data); my $delete = make_object_delete($table, $pk_where, $pk_row_data); my $fetch = make_object_fetch($table, $pk_where, $pk_row_data); my $destroy; if (not ref $table) { $destroy = <<DESTROY; sub DESTROY { no warnings 'once'; \$_[0]->update if \$DBIx::Struct::update_on_destroy; } DESTROY } else { $destroy = ''; } my $eval_code = join "", $package_header, $select_keys, $new, $filter_timestamp, $set, $data, $fetch, $update, $delete, $destroy, $accessors, $foreign_tables, $references_tables; # print $eval_code; eval $eval_code; error_message { result => 'SQLERR', message => "Unknown error: $@", } if $@; if ($interface) { my $ifuncs = _parse_interface $interface; no strict 'refs'; for my $f (keys %$ifuncs) { *{"${ncn}::$f"} = $ifuncs->{$f}; } } '' =~ /()/; return $ncn; } sub _table_name() {0} sub _table_alias() {1} sub _table_join() {2} sub _table_join_on() {3} my $sql_abstract = SQL::Abstract->new; my $tblnum; sub _build_complex_query { my ($table, $query_bind, $where) = @_; return $table if not ref $table; my @from; my @columns; my @linked_list = ( ref($table) eq 'ARRAY' ? @$table : error_message { result => 'SQLERR', message => "Unsupported type of query: " . ref($table) } ); my ($conditions, $groupby, $having, $limit, $offset); for (my $i = 0; $i < @linked_list; ++$i) { my $le = $linked_list[$i]; if ('ARRAY' eq ref $le) { my $subfrom = _build_complex_query($le, $query_bind); my $ta = "t$tblnum"; ++$tblnum; push @from, ["($subfrom)", $ta]; next; } if (substr($le, 0, 1) ne '-') { my ($tn, $ta) = split ' ', $le; $ta = $tn if not $ta; error_message { result => 'SQLERR', message => "Unknown table $tn" } unless _exists_row(make_name($tn)); push @from, [$tn, $ta]; } else { my $cmd = substr($le, 1); if ($cmd eq 'left') { $from[-1][_table_join] = 'left join'; } elsif ($cmd eq 'right') { $from[-1][_table_join] = 'right join'; } elsif ($cmd eq 'join') { $from[-1][_table_join] = 'join'; } elsif ($cmd eq 'on') { $from[-1][_table_join_on] = ["on", $linked_list[++$i]]; } elsif ($cmd eq 'using') { $from[-1][_table_join_on] = ["using", $linked_list[++$i]]; } elsif ($cmd eq 'as') { $from[-1][_table_alias] = $linked_list[++$i]; } elsif ($cmd eq 'where') { $conditions = $linked_list[++$i]; } elsif ($cmd eq 'group_by') { $groupby = $linked_list[++$i]; } elsif ($cmd eq 'having') { $having = $linked_list[++$i]; } elsif ($cmd eq 'limit') { $limit = 0 + $linked_list[++$i]; } elsif ($cmd eq 'offset') { $offset = 0 + $linked_list[++$i]; } elsif ($cmd eq 'columns') { my $cols = $linked_list[++$i]; if ('ARRAY' eq ref($cols)) { push @columns, @$cols; } else { push @columns, $cols; } } else { error_message { result => 'SQLERR', message => "Unknown directive $le" }; } } } error_message { result => 'SQLERR', message => "No table to build query on" } if !@from; for (my $idx = 1; $idx < @from; ++$idx) { next if $from[$idx][_table_join_on] or not $from[$idx - 1][_table_join]; next if substr($from[$idx][_table_name], 0, 1) eq "("; my $cta = $from[$idx][_table_alias]; my $cto = make_name($from[$idx][_table_name]); my $ucct = ucfirst $from[$idx][_table_name]; my @join; for (my $i = $idx - 1; $i >= 0; --$i) { next if not $from[$i][_table_join]; my $ptn = $from[$i][_table_name]; next if substr($ptn, 0, 1) eq "("; my $ucfptn = ucfirst $ptn; if ($cto->can("foreignKey$ucfptn")) { my $fkfn = "foreignKey$ucfptn"; my ($ctf, $ptk) = $cto->$fkfn; push @join, "$cta.$ctf = " . $from[$i][_table_alias] . ".$ptk"; } else { my $ptno = make_name($ptn); if ($ptno->can("foreignKey$ucct")) { my $fkfn = "foreignKey$ucct"; my ($ptf, $ctk) = $ptno->$fkfn; push @join, "$cta.$ctk = " . $from[$i][_table_alias] . ".$ptf"; } } } $from[$idx][_table_join_on] = ["on", join(" and ", @join)]; } my $from = ''; @columns = ('*') if not @columns; @columns = map {('SCALAR' eq ref) ? DBIx::Struct::connect->dbh->quote_identifier($_) : $_} @columns; my $joined = 0; for (my $idx = 0; $idx < @from; ++$idx) { if (not $joined) { $from .= " " . $from[$idx][_table_name]; $from .= " " . $from[$idx][_table_alias] if $from[$idx][_table_alias] ne $from[$idx][_table_name]; } if ($from[$idx][_table_join]) { my $nt = $from[$idx + 1]; $from .= " " . $from[$idx][_table_join]; $from .= " " . $nt->[_table_name]; $from .= " " . $nt->[_table_alias] if $nt->[_table_alias] ne $nt->[_table_name]; my $using_on = $nt->[_table_join_on][0]; if ($using_on eq 'on' and ref $nt->[_table_join_on][1]) { my ($on_where, @on_bind) = $sql_abstract->where($nt->[_table_join_on][1]); $on_where =~ s/WHERE //; push @$query_bind, @on_bind; $from .= " $using_on(" . $on_where . ")"; } else { $from .= " $using_on(" . $nt->[_table_join_on][1] . ")"; } $joined = 1; } else { $from .= "," if $idx != $#from; $joined = 0; } } my $ret = "select " . join(", ", @columns) . " from" . $from; if (not defined $where) { my $sql_grp = _parse_groupby($groupby); my $having_bind = []; if ($sql_grp && defined $having) { my $sql_having; ($sql_having, $having_bind) = _parse_having($having); $sql_grp .= " $sql_having"; } if ($conditions) { my @where_bind; ($where, @where_bind) = $sql_abstract->where($conditions); push @$query_bind, @where_bind; } else { $where = ''; } if (defined $sql_grp) { $where .= " $sql_grp"; push @$query_bind, @$having_bind; } $where .= " limit $limit" if defined $limit; $where .= " offset $offset" if $offset; } $ret .= " $where" if $where; $ret; } sub _parse_groupby { my $groupby = $_[0]; my $sql_grp; if (defined $groupby) { $sql_grp = "GROUP BY "; my @groupby = map {/^\d+$/ ? $_ : "$_"} (ref($groupby) ? @$groupby : ($groupby)); $sql_grp .= join(", ", @groupby); } $sql_grp; } sub _parse_having { my $having = $_[0]; my $sql_having; my @having_bind; if (defined $having) { ($sql_having, @having_bind) = $sql_abstract->where($having); $sql_having =~ s/\bWHERE\b/HAVING/; } ($sql_having, \@having_bind); } sub execute { my ($groupby, $having, $up_conditions, $up_order, $up_limit, $up_offset, $up_interface, $sql, $dry_run); for (my $i = 2; $i < @_; ++$i) { next unless defined $_[$i] and not ref $_[$i]; if ($_[$i] eq '-group_by') { (undef, $groupby) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-having') { (undef, $having) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-order_by') { (undef, $up_order) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-where') { (undef, $up_conditions) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-limit') { (undef, $up_limit) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-interface') { (undef, $up_interface) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-offset') { (undef, $up_offset) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-sql') { (undef, $sql) = splice @_, $i, 2; --$i; } elsif ($_[$i] eq '-dry_run') { (undef, $dry_run) = splice @_, $i, 2; --$i; } elsif (substr($_[$i], 0, 1) eq '-') { error_message { result => 'SQLERR', message => "Unknown directive $_[$i]" }; } } $tblnum = 1; my $sql_grp = _parse_groupby($groupby); my $having_bind = []; if ($sql_grp && defined $having) { my $sql_having; ($sql_having, $having_bind) = _parse_having($having); $sql_grp .= " $sql_having"; } my ($code, $table, $conditions, $order, $limit, $offset) = @_; my $have_conditions = @_ > 2; $conditions //= $up_conditions; $order //= $up_order; $limit //= $up_limit; $offset //= $up_offset; my $where; my $need_where = 0; my @where_bind; my $simple_table = (not ref $table and index($table, " ") == -1); my $ncn; if ($simple_table) { $ncn = make_name($table); setup_row($table); if ($have_conditions and not ref $conditions) { my $id = ($ncn->selectKeys())[0] or error_message { result => 'SQLERR', message => "unknown primary key", query => "select * from $table", }; if (defined $conditions) { $where = "where $id = ?"; @where_bind = ($conditions); } else { $where = "where $id is null"; } } else { $need_where = 1; } } else { $need_where = 1; } if ($need_where) { ($where, @where_bind) = $sql_abstract->where($conditions); } if (defined $sql_grp) { $where .= " $sql_grp"; push @where_bind, @$having_bind; } if ($order) { my ($order_sql, @order_bind) = $sql_abstract->where(undef, $order); $where .= " $order_sql"; push @where_bind, @order_bind; } if (defined($limit)) { $limit += 0; $where .= " limit $limit"; } if (defined($offset)) { $offset += 0; $where .= " offset $offset" if $offset; } my $query; my @query_bind; if ($simple_table) { $query = qq{select * from $table $where}; } else { $query = (not ref $table) ? qq{$table $where} : _build_complex_query($table, \@query_bind, $where); $ncn = make_name($query); } if ($sql) { if ('CODE' eq ref $sql) { $sql->($query, \@where_bind); } elsif ('SCALAR' eq ref $sql) { $$sql = $query; } } return if $dry_run; '' =~ /()/; my $sth; return DBIx::Struct::connect->run( sub { $sth = $_->prepare($query) or error_message { result => 'SQLERR', message => $_->errstr, query => $query, }; $sth->execute(@query_bind, @where_bind) or error_message { result => 'SQLERR', message => $_->errstr, query => $query, where_bind => Dumper(\@where_bind), query_bind => Dumper(\@query_bind), conditions => Dumper($conditions), }; setup_row($sth, $ncn, $up_interface); return $code->($sth, $ncn); } ); } sub one_row { return execute( sub { my ($sth, $ncn) = @_; my $data = $sth->fetchrow_arrayref; $sth->finish; return if not $data; return $ncn->new([@$data]); }, @_ ); } sub all_rows { my $mapfunc; for (my $i = 0; $i < @_; ++$i) { if (ref($_[$i]) eq 'CODE') { $mapfunc = splice @_, $i, 1; last; } } return execute( sub { my ($sth, $ncn) = @_; my @rows; my $row; if ($mapfunc) { while ($row = $sth->fetch) { local $_ = $ncn->new([@$row]); push @rows, $mapfunc->(); } } else { push @rows, $ncn->new([@$row]) while ($row = $sth->fetch); } return \@rows; }, @_ ); } sub new_row { my ($table, @data) = @_; my $simple_table = (index($table, " ") == -1); error_message { result => 'SQLERR', message => "insert row can't work for queries" } unless $simple_table; my $ncn = setup_row($table); return $ncn->new(@data); } 1;