[svn:p5ee] r11947 - in p5ee/trunk/App-Repository/lib/App: . Repository
[email protected] Tue, 7 Oct 2008 13:59:11 -0700 (PDT)
| Newsgroups | perl.cvs.p5ee |
|---|---|
| Message-ID | <[email protected]> |
Author: spadkins
Date: Tue Oct 7 13:59:09 2008
New Revision: 11947
Added:
p5ee/trunk/App-Repository/lib/App/Repository/Oracle.pm
Modified:
p5ee/trunk/App-Repository/lib/App/Repository.pm
p5ee/trunk/App-Repository/lib/App/Repository/DBI.pm
p5ee/trunk/App-Repository/lib/App/Repository/MySQL.pm
Log:
first version that supports Oracle explicitly
Modified: p5ee/trunk/App-Repository/lib/App/Repository.pm
==============================================================================
--- p5ee/trunk/App-Repository/lib/App/Repository.pm (original)
+++ p5ee/trunk/App-Repository/lib/App/Repository.pm Tue Oct 7 13:59:09 2008
@@ -2030,8 +2030,8 @@
my $table_def = $self->{table}{$table};
$columns = [];
foreach my $col (@{$table_def->{columns}}) {
- if (exists $hash->{$col}) {
- push(@$columns, $col);
+ if (exists $hash->{lc($col)}) {
+ push(@$columns, lc($col));
}
}
}
@@ -2120,7 +2120,7 @@
if (!$options->{temp}) {
my $retval = $self->insert_row($table, $object, undef, $options);
die "new($table) unable to create a new row" if (!$retval);
- my $params = $self->_last_inserted_id();
+ my $params = $self->_last_inserted_id($table);
if (!$params) {
$params = {};
foreach my $col (keys %$object) {
@@ -2162,16 +2162,7 @@
# }
#}
}
- my $alternate_keys = $table_def->{alternate_key};
- if ($alternate_keys) {
- foreach my $alternate_key (@$alternate_keys) {
- foreach my $column (@$alternate_key) {
- if (!defined $hash->{$column}) {
- die "Illegal object value for $table: $column cannot be NULL because it exists in an alternate key";
- }
- }
- }
- }
+
&App::sub_exit() if ($App::trace);
}
Modified: p5ee/trunk/App-Repository/lib/App/Repository/DBI.pm
==============================================================================
--- p5ee/trunk/App-Repository/lib/App/Repository/DBI.pm (original)
+++ p5ee/trunk/App-Repository/lib/App/Repository/DBI.pm Tue Oct 7 13:59:09 2008
@@ -6,13 +6,13 @@
use App;
use App::Repository;
+use Carp qw(confess);
+
package App::Repository::DBI;
$VERSION = (q$Revision$ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers generated by svn
@ISA = ( "App::Repository" );
-use Data::Dumper;
-
use strict;
=head1 NAME
@@ -174,44 +174,46 @@
&App::sub_entry if ($App::trace);
my $self = shift;
- if (!defined $self->{dbh}) {
- my $dsn = $self->_dsn();
- my $attr = $self->_attr();
+ return 1 if (defined $self->{dbh});
- while (1) {
- eval {
- $self->{dbh} = DBI->connect($dsn, $self->{dbuser}, $self->{dbpass}, $attr);
- };
- if ($@) {
- delete $self->{dbh};
- my $retryable_connection_error_regex = $self->retryable_connection_error_regex();
- if ($@ =~ /$retryable_connection_error_regex/i) {
- $self->{context}->log({level=>1},"DBI Exception (retrying) in _connect(): $@");
- sleep(1);
- }
- else {
- $self->{context}->log({level=>1},"DBI Exception (fail) in _connect(): $@");
- die $@;
- }
+ my ($dsn, $attr) = map {$self->$_} qw/_dsn _attr/;
+
+ while ((!$self->{dbh} || !$self->{dbh}->ping())) {
+
+ eval {
+ $self->{dbh} = DBI->connect($dsn, $self->{dbuser}, $self->{dbpass}, $attr);
+
+ };
+ if (my $e = $@) {
+ if ($self->is_retryable_connection_error($e)) {
+ $self->{context}->log({level=>1},"DBI Exception (retrying) in _connect(): $e");
+ sleep(1);
}
else {
- last;
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _connect(): $e");
+ die $e;
}
}
- die "Can't connect to database" if (!$self->{dbh});
- delete $self->{in_transaction};
}
+ delete $self->{in_transaction};
&App::sub_exit(defined $self->{dbh}) if ($App::trace);
return(defined $self->{dbh});
}
-sub retryable_connection_error_regex {
- return "Lost connection|server has gone away";
+sub is_retryable_connection_error {
+ my ($self, $e) = @_;
+ return(0);
+}
+
+sub is_retryable_modify_error {
+ my ($self, $e) = @_;
+ return(0);
}
-sub retryable_modify_error_regex {
- return "Lost connection|server has gone away|Deadlock found";
+sub is_duplicate_key_error {
+ my ($self, $e) = @_;
+ return($e =~ /duplicate/i);
}
# likely overridden at the subclass level
@@ -245,6 +247,7 @@
PrintError => 0,
AutoCommit => 1,
RaiseError => 1,
+ FetchHashKeyName => 'NAME_lc',
#ShowErrorStatement => 1, # this doesn't seem to include the right SQL statement. very confusing.
};
&App::sub_exit($attr) if ($App::trace);
@@ -321,7 +324,7 @@
sub _is_connected {
&App::sub_entry if ($App::trace);
my $self = shift;
- my $retval = ((defined $self->{dbh}) ? 1 : 0);
+ my $retval = ((defined $self->{dbh}) ? $self->{dbh}->ping() : 0);
&App::sub_exit($retval) if ($App::trace);
return ($retval);
}
@@ -341,40 +344,34 @@
sub _init2 {
&App::sub_entry if ($App::trace);
my $self = shift;
- my ($name);
+ return $self->{preconnected} = 1 if (defined $self->{dbh});
- $name = $self->{name};
- if (defined $self->{dbh}) {
- $self->{preconnected} = 1;
- }
- else {
- my $options = $self->{context}{options} || {};
+ my @opts = qw{
+ dbdsn dbdriver dbhost dbport dbsocket dbname
+ dbuser dbpass dbschema dbioptions
+ };
- my $config_from_options = 1;
- my $config_from_ext_options = 0;
- foreach my $var qw(dbdsn dbdriver dbhost dbport dbsocket dbname dbuser dbpass dbschema dbioptions) {
- if ($self->{$var}) {
- $config_from_options = 0;
- }
- if ($options->{"${name}.${var}"}) {
- $config_from_ext_options = 1;
- }
+ my $name = $self->{name};
+
+
+ my $options = $self->{context}{options} || {};
+
+ my $config_from_options = 1;
+ my $config_from_ext_options = 0;
+ foreach my $var (@opts) {
+ if ($self->{$var}) {
+ $config_from_options = 0;
+ }
+ if ($options->{"${name}.${var}"}) {
+ $config_from_ext_options = 1;
}
+ }
- if ($config_from_options) {
- if ($config_from_ext_options) {
- foreach my $var qw(dbdsn dbdriver dbhost dbport dbsocket dbname dbuser dbpass dbschema dbioptions) {
- if (defined $options->{"${name}.${var}"}) {
- $self->{$var} = $options->{"${name}.${var}"};
- }
- }
- }
- else {
- foreach my $var qw(dbdsn dbdriver dbhost dbport dbsocket dbname dbuser dbpass dbschema dbioptions) {
- if (defined $options->{$var}) {
- $self->{$var} = $options->{$var};
- }
- }
+ if ($config_from_options) {
+ foreach my $var (@opts) {
+ my $field = $config_from_ext_options ? "${name}.$var" : $var;
+ if (defined $options->{$field}) {
+ $self->{$var} = $options->{$field};
}
}
}
@@ -422,18 +419,18 @@
eval {
$row = $dbh->selectrow_arrayref($sql);
};
- if ($@) {
+ if (my $e = $@) {
$row = undef;
- if ($@ =~ /Lost connection/ || $@ =~ /server has gone away/) {
- $self->{context}->log({level=>1},"DBI Exception (retrying) in _get_row(): $@");
+ if ($self->is_retryable_connection_error($e)) {
+ $self->{context}->log({level=>1},"DBI Exception (retrying) in _get_row(): $e");
$self->_disconnect();
sleep(1);
$self->_connect();
$dbh = $self->{dbh};
}
else {
- $self->{context}->log({level=>1},"DBI Exception (fail) in _get_rows(): $@$sql");
- die $@;
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _get_rows(): $e$sql");
+ die $e;
}
}
else {
@@ -491,17 +488,17 @@
eval {
$rows = $self->_selectrange_arrayref($sql, $startrow, $endrow);
};
- if ($@) {
+ if (my $e = $@) {
$rows = [];
- if ($@ =~ /Lost connection/ || $@ =~ /server has gone away/) {
- $self->{context}->log({level=>1},"DBI Exception (retrying) in _get_rows(): $@");
+ if ($self->is_retryable_connection_error($e)) {
+ $self->{context}->log({level=>1},"DBI Exception (retrying) in _get_rows(): $e");
$self->_disconnect();
sleep(1);
$self->_connect();
}
else {
- $self->{context}->log({level=>1},"DBI Exception (fail) in _get_rows(): $@$sql");
- die $@;
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _get_rows(): $e$sql");
+ die $e;
}
}
else {
@@ -566,7 +563,7 @@
my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
if ($sth) {
- $sth->execute(@bind) || return;
+ eval {$sth->execute(@bind)}; if (my $e = $@){use Carp qw(confess); confess "Died on: $stmt because of $e";}
my $slice = $attr->{Slice}; # typically undef, else hash or array ref
if (!$slice and $slice=$attr->{Columns}) {
if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
@@ -593,56 +590,32 @@
$endrow = 0 if (!defined $endrow);
my $mode = ref $slice;
my @rows;
- my $row;
- my ($rownum);
+ my $rownum = 0;
if ($mode eq 'ARRAY') {
- # we copy the array here because fetch (currently) always
- # returns the same array ref. XXX
- if (@$slice) {
- $rownum = 0;
- while ($row = $sth->fetch) {
- $rownum++;
- last if ($endrow > 0 && $rownum > $endrow);
- push @rows, [ @{$row}[ @$slice] ] if ($rownum >= $startrow);
- }
- $sth->finish if ($endrow > 0 && $rownum > $endrow);
- }
- else {
- # return $sth->_fetchall_arrayref;
- $rownum = 0;
- while ($row = $sth->fetch) {
- $rownum++;
- last if ($endrow > 0 && $rownum > $endrow);
- push @rows, [ @$row ] if ($rownum >= $startrow);
- }
- $sth->finish if ($endrow > 0 && $rownum > $endrow);
+ # we copy the array here because fetch returns the same array ref.
+ while (my $row = $sth->fetch) {
+ next if ++$rownum < $startrow;
+ last if ($endrow > 0 && $rownum > $endrow);
+ push @rows, [ @$slice ? @{$row}[@$slice] : @$row];
}
}
elsif ($mode eq 'HASH') {
- if (keys %$slice) {
+ my @i_keys = map { lc } keys %$slice;
+ my @params = keys %$slice ? 'NAME_lc' : ();
+
+ while (my $row = $sth->fetchrow_hashref(@params)) {
my @o_keys = keys %$slice;
- my @i_keys = map { lc } keys %$slice;
- $rownum = 0;
- while ($row = $sth->fetchrow_hashref('NAME_lc')) {
- my %hash;
- @hash{@o_keys} = @{$row}{@i_keys};
- $rownum++;
- last if ($endrow > 0 && $rownum > $endrow);
- push @rows, \%hash if ($rownum >= $startrow);
- }
- $sth->finish if ($endrow > 0 && $rownum > $endrow);
- }
- else {
- # XXX assumes new ref each fetchhash
- while ($row = $sth->fetchrow_hashref()) {
- $rownum++;
- last if ($endrow > 0 && $rownum > $endrow);
- push @rows, $row if ($rownum >= $startrow);
- }
- $sth->finish if ($endrow > 0 && $rownum > $endrow);
+ next if ++$rownum < $startrow;
+ last if ($endrow > 0 && $rownum > $endrow);
+
+ push @rows, @o_keys ?
+ { map {shift @o_keys => $_ } @{$row}{@i_keys} } :
+ $row
}
}
else { Carp::croak("fetchall_arrayref($mode) invalid") }
+
+ $sth->finish if ($endrow > 0 && $rownum > $endrow);
&App::sub_exit(\@rows) if ($App::trace);
return \@rows;
}
@@ -654,12 +627,13 @@
sub _mk_where_clause {
&App::sub_entry if ($App::trace);
my ($self, $table, $params, $options) = @_;
- my ($where, $column, $param, $value, $colnum, $repop, $sqlop, $column_def, $quoted);
+ my ($value,$repop, $sqlop, $column_def, $quoted);
my ($tabledef, $tabcols, $alias, $dbexpr);
my $dbh = $self->{dbh};
- $tabledef = $self->{table}{$table};
+ #$tabledef = $self->{table}{$table}; #[[ $self->get_table_def($table, $opt);
+ $tabledef = $self->get_table_def($table, $options);
$alias = $tabledef->{alias};
$tabcols = $tabledef->{column};
my %sqlop = (
@@ -693,197 +667,178 @@
"!/" => "not_regexp",
);
- $where = "";
$params = {} if (!$params);
my $param_order = $params->{"_order"};
if (!defined $param_order && ref($params) eq "HASH") {
$param_order = [ (keys %$params) ];
}
- if (defined $param_order && $#$param_order > -1) {
- my ($include_null, $inferred_op, @where);
- for ($colnum = 0; $colnum <= $#$param_order; $colnum++) {
- $param = $param_order->[$colnum];
- $column = $param;
- $sqlop = "=";
- $repop = "";
- $inferred_op = 1;
- # check if $column contains an embedded operation, i.e. "name.eq", "name.contains"
- if ($param =~ /^(.*)\.([^.]+)$/) {
- $repop = $2;
- $inferred_op = 0;
- if ($sqlop{$repop}) {
- $column = $1;
- $sqlop = $sqlop{$repop};
- }
- }
- $value = $params->{$param};
- if (!$repop && $value && $value =~ s/^(=~|~|!~|==|=|!=|!|<=|<|>=|>)//) {
- $repop = $repop{$1};
- $sqlop = $sqlop{$repop};
- $inferred_op = 0 if ($1 eq "==");
- }
- if (!$repop && $value && $value =~ /[\*\?]/) {
- $repop = "matches";
+ if (!(defined $param_order && $#$param_order > -1)) {
+ return wantarray ? () : "";
+ }
+
+ my @where;
+ for my $param (@$param_order) {
+ next if (!defined $param || $param eq "");
+
+ my $column = $param;
+ $sqlop = "=";
+ $repop = "";
+ my $inferred_op = 1;
+ # check if $column contains an embedded operation, i.e. "name.eq", "name.contains"
+ if ($param =~ /^(.*)\.([^.]+)$/) {
+ $repop = $2;
+ $inferred_op = 0;
+ if ($sqlop{$repop}) {
+ $column = $1;
$sqlop = $sqlop{$repop};
}
+ }
+ $value = $params->{$param};
+ if (!$repop && $value && $value =~ s/^(=~|~|!~|==|=|!=|!|<=|<|>=|>)//) {
+ $repop = $repop{$1};
+ $sqlop = $sqlop{$repop};
+ $inferred_op = 0 if ($1 eq "==");
+ }
+ if (!$repop && $value && $value =~ /[\*\?]/) {
+ $repop = "matches";
+ $sqlop = $sqlop{$repop};
+ }
- if ($repop eq "verbatim") {
- push(@where, "$params->{$param}");
- next;
- }
+ if ($repop eq "verbatim") {
+ push(@where, "$params->{$param}");
+ next;
+ }
+
+ $column_def = $tabcols->{$column};
+ if (!defined $column_def) {
+ if ($param =~ /^(begin|end)_(.*)/) {
+ $column = $2;
+ $sqlop = {begin=>">=", end=>"<="}->{$1};
+ $inferred_op = 0;
+ }
$column_def = $tabcols->{$column};
+ }
+#[[ From other copy:
+# TODO: Remove comment block
+# elsif ($paramdefs && $paramdefs->{$param}) {
+# if ($paramdefs->{$param}{criteria}) {
+# push(@criteria_conditions, $self->substitute($paramdefs->{$param}{criteria}, $params));
+# }
+# }
+#]]
+ next if (!defined $column_def); # skip if the column is unknown
- if (!defined $column_def) {
- if ($param =~ /^begin_(.*)/) {
- $column = $1;
- $sqlop = ">=";
- $inferred_op = 0;
- }
- elsif ($param =~ /^end_(.*)/) {
- $column = $1;
- $sqlop = "<=";
- $inferred_op = 0;
- }
- $column_def = $tabcols->{$column};
+ if (! defined $value) {
+ # $value = "?";
+ # TODO: make this work with the "contains/matches" operators
+ if (!$sqlop || $sqlop eq "=") {
+ push(@where, "$column is null");
}
+ elsif ($sqlop eq "!=") {
+ push(@where, "$column is not null");
+ }
+ next;
+ }
+
+#Adding: [[
+# TODO: Remove comment block
+#
+# next if (defined $table_def->{param}{$param}{all_value} &&
+# $value eq $table_def->{param}{$param}{all_value});
+#
+#]]
- next if (!defined $column_def); # skip if the column is unknown
+ next if ($inferred_op && $value eq "ALL");
- if (! defined $value) {
- # $value = "?"; # TODO: make this work with the "contains/matches" operators
- if (!$sqlop || $sqlop eq "=") {
- push(@where, "$column is null");
- }
- elsif ($sqlop eq "!=") {
- push(@where, "$column is not null");
- }
- }
- else {
- next if ($inferred_op && $value eq "ALL");
+ if (ref($value) eq "ARRAY") {
+ $value = join(",", @$value);
+ }
- if (ref($value) eq "ARRAY") {
- $value = join(",", @$value);
- }
+ if ($value =~ s/^@\[(.*)\]$/$1/ ||# new @[] expressions replace !expr!
+ $value =~ s/^@\{(.*)\}$/$1/ ||# depreected. @{x} is interp'd by perl
+ $value =~ s/^!expr!//) # deprecated (ugh!)
+ {
+ $quoted = 0;
+ }
+ else {
+ my $c = ($value =~ /,/ &&
+ !$tabledef->{param}{$param}{no_auto_in_param}) ? ',' : '';
- if ($value =~ s/^@\[(.*)\]$/$1/) { # new @[] expressions replace !expr!
- $quoted = 0;
- }
- elsif ($value =~ s/^@\{(.*)\}$/$1/) { # replaced !expr!, but @{x} is interp'd by perl so deprecate!
- $quoted = 0;
- }
- elsif ($value =~ s/^!expr!//) { # deprecated (ugh!)
- $quoted = 0;
- }
- elsif ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
- $quoted = (defined $column_def->{quoted}) ? ($column_def->{quoted}) : ($value !~ /^-?[0-9.,]+$/);
- }
- else {
- $quoted = (defined $column_def->{quoted}) ? ($column_def->{quoted}) : ($value !~ /^-?[0-9.]+$/);
- }
+ $quoted = (defined $column_def->{quoted}) ?
+ ($column_def->{quoted}) : ($value !~ /^-?[0-9.$c]+$/);
+ }
- next if ($inferred_op && !$quoted && $value eq "");
+ next if ($inferred_op && !$quoted && $value eq "");
- $include_null = 0;
- if ($repop eq "contains" || $repop eq "not_contains") {
- $value = $dbh->quote("%" . $value . "%");
- }
- elsif ($repop eq "matches" || $repop eq "not_matches") {
- $value = $dbh->quote($value);
- $value =~ s/_/\\_/g;
- $value =~ s/\*/%/g;
- $value =~ s/\?/_/g;
- }
- elsif ($sqlop eq "in" || ($inferred_op && $sqlop eq "=")) {
- if (! defined $value || $value eq "NULL") {
- $sqlop = "is";
- $value = "null";
- }
- else {
- if ($value =~ s/NULL,//g || $value =~ s/,NULL//) {
- $include_null = 1;
- }
- if ($quoted) {
- $value = $dbh->quote($value);
- if ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
- $value =~ s/,/','/g;
- $value = "($value)";
- $sqlop = "in";
- }
- else {
- $sqlop = "=";
- }
- }
- else {
- if ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
- $value = "($value)";
- $sqlop = "in";
- }
- else {
- $sqlop = "=";
- }
- }
- }
- }
- elsif ($sqlop eq "not in" || ($inferred_op && $sqlop eq "!=")) {
- if (! defined $value || $value eq "NULL") {
- $sqlop = "is not";
- $value = "null";
- }
- else {
- if ($value =~ s/NULL,//g || $value =~ s/,NULL//) {
- $include_null = 1;
- }
- if ($quoted) {
- $value = $dbh->quote($value);
- if ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
- $value =~ s/,/','/g;
- $value = "($value)";
- $sqlop = "not in";
- }
- else {
- $sqlop = "!=";
- }
- }
- else {
- if ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
- $value = "($value)";
- $sqlop = "not in";
- }
- else {
- $sqlop = "!=";
- }
- }
- }
- }
- elsif ($quoted) {
- $value = $dbh->quote($value);
+ ($sqlop) = grep { defined } (
+ {'=' => 'in', '!=' => 'not in' }->{$sqlop}, $sqlop
+ ) if $inferred_op;
+
+
+ my $include_null = 0;
+ if ($repop eq "contains" || $repop eq "not_contains") {
+ $value = $dbh->quote("%" . $value . "%");
+ }
+ elsif ($repop eq "matches" || $repop eq "not_matches") {
+ $value = $dbh->quote($value);
+ $value =~ s/_/\\_/g;
+ $value =~ tr/*?/%_/;
+ }
+ elsif (my ($not) = $sqlop =~ m"(not|) ?in") {
+ if (! defined $value || $value eq "NULL") {
+ $sqlop = $not ? "is $not" : "is";
+ $value = "null";
+ }
+ else {
+ if ($value =~ s/NULL,//g || $value =~ s/,NULL//) {
+ $include_null = 1;
}
- $dbexpr = $column_def->{dbexpr};
- if ($dbexpr && $dbexpr ne "$alias.$column") {
- $column = $dbexpr;
- $column =~ s/$alias.//g;
- }
- if ($include_null) {
- if ($sqlop eq "not in" || $sqlop eq "!=") {
- push(@where, "($column $sqlop $value and $column is not null)");
- }
- else {
- push(@where, "($column $sqlop $value or $column is null)");
- }
+
+ $value = $dbh->quote($value) if $quoted;
+ if ($value =~ /,/ && ! $tabledef->{param}{$param}{no_auto_in_param}) {
+ $value =~ s/,/','/g if $quoted;
+ $value = "($value)";
+ $sqlop = $not ? "$not in" : "in";
}
else {
- push(@where, "$column $sqlop $value");
+ $sqlop = $not ? "!=" : "=";
}
}
}
- if ($#where > -1) {
- $where = "where " . join("\n and ", @where) . "\n";
+ elsif ($quoted) {
+ $value = $dbh->quote($value);
+ }
+ $dbexpr = $column_def->{dbexpr};
+#[[ from other copy:
+# TODO: use option hash {multitable} to decide on whether to execute this code
+# if (defined $dbexpr && $dbexpr ne "") {
+# $self->_require_tables($dbexpr, \%reqd_tables, $tablealiashref, 2);
+# }
+#]]
+ if ($dbexpr) {
+ $column = $dbexpr;
+ $column =~ s/\b$alias\.//g if ($options->{no_aliases});
+ }
+ if ($include_null) {
+ my ($not, $orand) = ($sqlop eq "not in" || $sqlop eq "!=" ) ?
+ ("not", "and") : ("", "or");
+ push(@where, "($column $sqlop $value $orand $column is $not null)");
+ }
+ else {
+ # push(@where, ($alias ?"$alias.":"")."$column $sqlop $value");
+ push(@where, "$column $sqlop $value"); #XXX dow => { alias => 'dow', dbexpr => 'dayofweek(hr.arv_dt)', },
+
}
}
+
+ my $where;
+ if ($#where > -1) {
+ $where = "where " . join("\n and ", @where) . "\n";
+ }
&App::sub_exit($where) if ($App::trace);
- $where;
+ wantarray ? @where : $where;
}
sub _mk_select_sql {
@@ -902,18 +857,14 @@
my $modifier = $options->{distinct} ? " distinct" : "";
$sql = "select$modifier\n " . join(",\n ", @$cols) . "\nfrom $table\n";
- $sql .= $self->_mk_where_clause($table, $params);
+ $sql .= $self->_mk_where_clause($table, $params, {no_aliases => 1});
if (defined $order_by && $#$order_by > -1) {
for ($colnum = 0; $colnum <= $#$order_by; $colnum++) {
$col = $order_by->[$colnum];
- if ($col =~ /^(.+)\.asc$/) {
+ if ($col =~ /^(.+)\.(asc|desc)$/) {
$col = $1;
- $dir = " asc";
- }
- elsif ($col =~ /^(.+)\.desc$/) {
- $col = $1;
- $dir = " desc";
+ $dir = $2;
}
else {
$dir = "";
@@ -947,8 +898,7 @@
my $table_def = $self->get_table_def($table, $options);
die "Table $table not defined" if (!$table_def);
- if (!defined $params || $params eq "") {
- $params = {};
+ if (!defined $params || $params eq "") { $params = {};
}
elsif (!ref($params)) {
$params = $self->_key_to_params($table,$params); # $params is undef/scalar => $key
@@ -962,7 +912,7 @@
$direction = $options->{direction} || $options->{directions}; # {directions} is deprecated
my $modifier = $options->{distinct} ? " distinct" : "";
- my ($where_condition, @join_conditions, @criteria_conditions, $repop, $sqlop, $value);
+ my (@criteria_conditions, $repop, $sqlop, $value);
# ADD ANY DEFAULT PARAMS
my $paramdefs = $table_def->{param};
@@ -1118,7 +1068,7 @@
############################################################
# allow param substitutions in dbexpr
############################################################
- if ($dbexpr =~ /{/) { # } (match braces)
+ if ($dbexpr =~ /{/) { #}
$dbexpr = $self->substitute($dbexpr, $params);
}
@@ -1128,8 +1078,8 @@
if ($is_summary) {
if ($is_summary_key{$column}) {
if (defined $dbexpr) {
- push(@select_phrase, "$dbexpr $columnalias");
- push(@group_summarykeys, $columnalias);
+ push(@select_phrase, "$dbexpr as $columnalias");
+ push(@group_summarykeys, $dbexpr);
}
}
else {
@@ -1154,11 +1104,11 @@
else {
$summaryexpr = "NULL";
}
- push(@select_phrase, "$summaryexpr $columnalias") if ($summaryexpr);
+ push(@select_phrase, "$summaryexpr as $columnalias") if ($summaryexpr);
}
}
else {
- push(@select_phrase, (defined $dbexpr) ? "$dbexpr $columnalias" : "NULL $columnalias");
+ push(@select_phrase, (defined $dbexpr) ? "$dbexpr as $columnalias" : "NULL $columnalias");
}
############################################################
@@ -1187,7 +1137,7 @@
$group_reqd = 1;
}
else {
- push(@group_dbexpr, $columnalias);
+ push(@group_dbexpr, $dbexpr);
}
############################################################
@@ -1262,312 +1212,9 @@
}
}
- ############################################################
- # create initial where conditions for the selected rows
- ############################################################
-
#print $App::DEBUG_FILE $self->{context}->dump(), "\n";
- my %sqlop = (
- "contains" => "like",
- "matches" => "like",
- "not_contains" => "not like",
- "not_matches" => "not like",
- "eq" => "=",
- "ne" => "!=",
- "le" => "<=",
- "lt" => "<",
- "ge" => ">=",
- "gt" => ">",
- "in" => "in",
- "not_in" => "not in",
- );
- my %repop = (
- "=~" => "contains",
- "~" => "contains",
- "!~" => "not_contains",
- "==" => "eq",
- "=" => "eq",
- "!" => "ne",
- "!=" => "ne",
- "<=" => "le",
- "<" => "lt",
- ">=" => "ge",
- ">" => "gt",
- );
-
- my ($include_null, $inferred_op);
- for ($idx = 0; $idx <= $#$param_order; $idx++) {
-
- $param = $param_order->[$idx];
- next if (!defined $param || $param eq "");
-
- $column = $param;
-
- #if ($param eq "_key") {
- # # o TODO: enable multi-field primary keys (this assumes one-field only)
- # # o TODO: enable non-integer primary key fields (this assumes integer, no quotes)
- # $column = $table_def->{primary_key}; # assumes one column primary key
- # $dbexpr = $table_def->{column}{$column}{dbexpr};
- # if ($value =~ /,/) {
- # $where_condition = "$dbexpr in ($value)"; # assumes one column, non-quoted primary key
- # }
- # else {
- # $where_condition = "$dbexpr = $value"; # assumes one column, non-quoted primary key
- # }
- # push(@criteria_conditions, $where_condition);
- # next;
- #}
-
- $sqlop = "=";
- $repop = "";
- $inferred_op = 1;
- $value = $params->{$param};
- # check if $param contains an embedded operation, i.e. "name.eq", "name.contains"
- if ($param =~ /^(.*)\.([^.]+)$/) {
- $repop = $2;
- $inferred_op = 0;
- if ($sqlop{$repop}) {
- $column = $1;
- $sqlop = $sqlop{$repop};
- }
- }
- if (!$repop && $value && $value =~ s/^(=~|~|!~|==|=|!=|!|<=|<|>=|>)//) {
- $repop = $repop{$1};
- $sqlop = $sqlop{$repop};
- $inferred_op = 0 if ($1 eq "==");
- }
- if (!$repop && $value && $value =~ /[\*\?]/) {
- $repop = "matches";
- $sqlop = $sqlop{$repop};
- }
-
- if ($repop eq "verbatim") {
- push(@criteria_conditions, $params->{$param});
- next;
- }
-
- $column_def = $table_def->{column}{$column};
-
- if (!defined $column_def) {
- if ($param =~ /^begin_(.*)/) {
- $column = $1;
- $sqlop = ">=";
- $inferred_op = 0;
- }
- elsif ($param =~ /^end_(.*)/) {
- $column = $1;
- $sqlop = "<=";
- $inferred_op = 0;
- }
- $column_def = $table_def->{column}{$column};
- }
-
- if (defined $column_def) { # skip if the column is unknown
- $include_null = 0;
-
- if (! defined $value) {
- # $value = "?"; # TODO: make this work with the "contains/matches" operators
- if (!$sqlop || $sqlop eq "=") {
- $sqlop = "is";
- }
- elsif ($sqlop eq "!=") {
- $sqlop = "is not";
- }
- else {
- next;
- }
- $value = "null";
- }
- else {
- next if (defined $table_def->{param}{$param}{all_value} &&
- $value eq $table_def->{param}{$param}{all_value});
-
- next if ($inferred_op && $value eq "ALL");
-
- if (ref($value) eq "ARRAY") {
- $value = join(",", @$value);
- }
-
- if ($value =~ s/^@\[(.*)\]$/$1/) { # new @[] expressions replace !expr!
- $quoted = 0;
- }
- elsif ($value =~ s/^@\{(.*)\}$/$1/) { # new @{} don't work.. perl interpolates... deprecate.
- $quoted = 0;
- }
- elsif ($value =~ s/^!expr!//) { # deprecated (ugh!)
- $quoted = 0;
- }
- elsif ($value =~ /,/ && ! $table_def->{param}{$param}{no_auto_in_param}) {
- $quoted = (defined $column_def->{quoted}) ? ($column_def->{quoted}) : ($value !~ /^-?[0-9.,]+$/);
- }
- else {
- $quoted = (defined $column_def->{quoted}) ? ($column_def->{quoted}) : ($value !~ /^-?[0-9.]+$/);
- }
-
- next if ($inferred_op && !$quoted && $value eq "");
-
- if ($repop eq "contains" || $repop eq "not_contains") {
- $value = $dbh->quote("%" . $value . "%");
- }
- elsif ($repop eq "matches" || $repop eq "not_matches") {
- $value = $dbh->quote($value);
- $value =~ s/_/\\_/g;
- $value =~ s/\*/%/g;
- $value =~ s/\?/_/g;
- }
- elsif ($sqlop eq "in" || ($inferred_op && $sqlop eq "=")) {
-
- if (! defined $value || $value eq "NULL") {
- $sqlop = "is";
- $value = "null";
- }
- else {
- if ($value =~ s/NULL,//g || $value =~ s/,NULL//) {
- $include_null = 1;
- }
- if ($quoted) {
- $value = $dbh->quote($value);
- if ($value =~ /,/ && ! $table_def->{param}{$param}{no_auto_in_param}) {
- $value =~ s/,/','/g;
- $value = "($value)";
- $sqlop = "in";
- }
- else {
- $sqlop = "=";
- }
- }
- else {
- if ($value =~ /,/ && ! $table_def->{param}{$param}{no_auto_in_param}) {
- $value = "($value)";
- $sqlop = "in";
- }
- else {
- $sqlop = "=";
- }
- }
- }
- }
- elsif ($sqlop eq "not in" || ($inferred_op && $sqlop eq "!=")) {
-
- if (! defined $value || $value eq "NULL") {
- $sqlop = "is not";
- $value = "null";
- }
- else {
- if ($value =~ s/NULL,//g || $value =~ s/,NULL//) {
- $include_null = 1;
- }
- if ($quoted) {
- $value = $dbh->quote($value);
- if ($value =~ /,/ && ! $table_def->{param}{$param}{no_auto_in_param}) {
- $value =~ s/,/','/g;
- $value = "($value)";
- $sqlop = "not in";
- }
- else {
- $sqlop = "!=";
- }
- }
- else {
- if ($value =~ /,/ && ! $table_def->{param}{$param}{no_auto_in_param}) {
- $value = "($value)";
- $sqlop = "not in";
- }
- else {
- $sqlop = "!=";
- }
- }
- }
- }
- elsif ($quoted) {
- $value = $dbh->quote($value);
- }
- }
-
- $dbexpr = $column_def->{dbexpr};
- if (defined $dbexpr && $dbexpr ne "") {
- $self->_require_tables($dbexpr, \%reqd_tables, $tablealiashref, 2);
- if ($include_null) {
- if ($sqlop eq "not in" || $sqlop eq "!=") {
- push(@criteria_conditions, "($dbexpr $sqlop $value and $dbexpr is not null)");
- }
- else {
- push(@criteria_conditions, "($dbexpr $sqlop $value or $dbexpr is null)");
- }
- }
- else {
- push(@criteria_conditions, "$dbexpr $sqlop $value");
- }
- }
- }
- elsif ($paramdefs && $paramdefs->{$param}) {
- if ($paramdefs->{$param}{criteria}) {
- push(@criteria_conditions, $self->substitute($paramdefs->{$param}{criteria}, $params));
- }
- }
- else {
- # skip. not a known column or a known param of any other type.
- }
- }
-
-# THIS IS DEAD CODE.
-# I NEED TO FIGURE OUT WHAT IT USED TO DO SO I CAN FIGURE WHETHER I NEED
-# TO REWRITE IT AND REINSTATE IT IN THE CURRENT CODE BASE.
-# {
-# my ($paramsql_alias_table, %param_used, @params_to_be_used);
-# my ($cond1, $cond2, $expr, $p1, $p2, $p1val, $p2val, @pval);
-# my ($crit_lines);
-#
-# $paramsql_alias_table = $self->{table}{aliases}{$table}{parametersql};
-# $paramsql_alias_table = $table if (!$dep_alias_table);
-# $crit_lines = $self->{table}{criterialines}{$dep_alias_table}
-#
-# CRIT: foreach $expr (@crit_lines) {
-# @params_to_be_used = ();
-# if ($expr =~ /^ *([^ ].*[^ ]) *\? *([^ ].*[^ ]) *$/) {
-# $cond1 = $1;
-# $expr = $2;
-#
-# if ($cond1 =~ /^#(.+)/) {
-# $p = $1;
-# @pval = $query->param($p);
-# next if ($#pval <= 0);
-# }
-# elsif ($cond1 =~ /^([a-zA-Z0-9]+) *== *\*([a-zA-Z0-9]+) *$/) {
-# $p1 = $1;
-# $p2 = $2;
-# next CRIT if (defined $param_used{$p1} || defined $param_used{$p2});
-# $p1val = $query->param($p1);
-# $p2val = $query->param($p2);
-# next CRIT if (!defined $p1val || !defined $p2val || $p1val ne $p2val);
-# push(@params_to_be_used, $p2);
-# }
-# }
-#
-# $cond2 = $expr;
-# while ($cond2 =~ s/{([a-zA-Z0-9]+)}//) {
-# $p = $1;
-# @pval = $query->param($p);
-# next CRIT if (!defined @pval || $#pval < 0 || $pval[0] eq "");
-# next CRIT if (defined $param_used{$p});
-# push(@params_to_be_used, $p);
-# if ($expr =~ /'{$p}'/) {
-# $p1val = "'" . join("','",@pval) . "'";
-# $expr =~ s/'{$p}'/$p1val/;
-# }
-# else {
-# $p1val = join(",",@pval);
-# $expr =~ s/{$p}/$p1val/;
-# }
-# }
-# foreach (@params_to_be_used) {
-# $param_used{$_} = 1;
-# }
-# push(@criteria_conditions, $expr);
-# $self->_require_tables($expr, \%reqd_tables, $table_aliases, 2);
-# }
-# }
+ @criteria_conditions = $self->_mk_where_clause($table, $params, $options);
############################################################
# put tables in table list in the standard order
@@ -1575,30 +1222,60 @@
############################################################
my ($dbtable, $tablealias, @from_tables, $tableref);
- my (@outer_join_clauses);
+ my (@outer_join_clauses, @join_conditions);
- foreach $tablealias (@$tablealiases) {
+ #print STDERR join ", ", "HERE" , map { Dumper($tablealiashref->{$_}->{dependencies})} @$tablealiases;
+ #print STDERR join ", ", "HERE0", map {@{($tablealiashref->{$_}->{dependencies} || [])}, $_} @$tablealiases,"\n";
+ #print STDERR join ", ", "HERE1", map {(grep {!/^$_$/} @{($tablealiashref->{$_}->{dependencies} || [])}), $_} @$tablealiases,"\n";
+ my %deps = map {
+ $table = $_;
+ $_ => [
+ grep {!/^$table$/}
+ @{($tablealiashref->{$table}->{dependencies} || [])}
+ ]
+ } @$tablealiases;
+
+ use Algorithm::Dependency::Ordered;
+ use Algorithm::Dependency::Source::HoA;
+
+ my $src = Algorithm::Dependency::Source::HoA->new({%deps});
+ my $queue = Algorithm::Dependency::Ordered->new(source=>$src);
+ #print STDERR 'Deps:'. Dumper({%deps});
+ #print STDERR 'queue:'. Dumper($queue->schedule_all);
+ #foreach $tablealias (map {(grep {!/^$_$/} @{($tablealiashref->{$_}->{dependencies} || [])}), $_} @$tablealiases) {
+
+ ##TODO Fix: There is some major uglyness in here with the $cnt stuff.
+ ## Bigger fish to fry right now. Come back later. #rl
+ my $cnt = 0;
+ foreach $tablealias (@{$queue->schedule_all}) {
#print $App::DEBUG_FILE "checking table $tablealias\n";
- if ($reqd_tables{$tablealias}) {
- $dbtable = $tablealiashref->{$tablealias}{table};
- $tableref = ($dbtable) ? "$dbtable $tablealias" : $tablealias;
- $where_condition = $tablealiashref->{$tablealias}{joincriteria};
- if ($where_condition =~ /\{.*\}/) {
- $where_condition = $self->substitute($where_condition, $params);
- }
- if ($tablealiashref->{$tablealias}{cardinality_zero}) {
- push(@outer_join_clauses, "left join $tableref on $where_condition") if ($where_condition);
- #print $App::DEBUG_FILE " $tablealias is [$dbtable] as [$tableref] where [$where_condition] (outer)\n";
- }
- else {
- push(@join_conditions, split(/ +and +/,$where_condition)) if ($where_condition);
- if ($tablealiashref->{$tablealias}{hint}) {
- $tableref .= " $tablealiashref->{$tablealias}{hint}";
- }
- push(@from_tables, $tableref);
- #print $App::DEBUG_FILE " $tablealias is [$dbtable] as [$tableref] where [$where_condition]\n";
- }
+ $dbtable = $tablealiashref->{$tablealias}{table};
+ $tableref = ($dbtable) ? "$dbtable $tablealias" : $tablealias;
+ my $where_condition = $tablealiashref->{$tablealias}{joincriteria};
+ if ($where_condition =~ /\{.*\}/) {
+ print STDERR "WHERE1: $where_condition\n";
+ $where_condition = $self->substitute($where_condition);
+ print STDERR "WHERE2: $where_condition\n";
+ }
+
+ # First time thouh loop We can't do a join on, so if we find anything
+ # tack it onto the where condition.
+ if (0 == $cnt++ && $where_condition) {
+ push @criteria_conditions, $where_condition;
+ undef $where_condition;
+ }
+ my $join_type =
+ $tablealiashref->{$tablealias}{cardinality_zero} ? 'left' : '';
+ push( @outer_join_clauses,
+ "$join_type join $tableref on $where_condition")if($where_condition);
+
+ #rl address !$join_type... See if needed.
+ if (!$join_type && $tablealiashref->{$tablealias}{hint}) {
+ $tableref .= " $tablealiashref->{$tablealias}{hint}";
}
+ push(@from_tables, $tableref) if !$join_type && $cnt <=1;
+ push( @outer_join_clauses,
+ "join $tableref") if (!$where_condition && $cnt>1);
}
if ($#from_tables == -1 && $#$tablealiases > -1) {
$tablealias = $tablealiases->[0];
@@ -1614,39 +1291,29 @@
# create the SQL statement
############################################################
- my ($sql, $conjunction);
-
- if ($#select_phrase >= 0) {
- $sql = "select$modifier\n " .
+ my $sql = "select$modifier\n " .
join(",\n ",@select_phrase) . "\n" .
"from\n " .
join(",\n ",@from_tables) . "\n";
- }
if ($#outer_join_clauses >= 0) {
$sql .= join("\n",@outer_join_clauses) . "\n";
}
- if ($#join_conditions >= 0) {
- $sql .= "where " . join("\n and ",@join_conditions) . "\n";
- }
- $conjunction = "AND";
- $conjunction = $params->{"_conjunction"} if (defined $params);
- $conjunction = "AND" if (!defined $conjunction);
- $conjunction = uc($conjunction);
if ($#criteria_conditions >= 0) {
- $sql .= ($#join_conditions == -1 ? "where " : " and ");
- if ($conjunction eq "NOT_AND") {
- $sql .= "not (" . join("\n and ",@criteria_conditions) . ")\n";
- }
- elsif ($conjunction eq "NOT_OR") {
- $sql .= "not (" . join("\n or ",@criteria_conditions) . ")\n";
- }
- elsif ($conjunction eq "OR") {
- $sql .= "(" . join("\n or ",@criteria_conditions) . ")\n";
+ my $conjunction = uc($params->{"_conjunction"}) if (defined $params);
+
+ my ($not, $andor) = @{{
+ NOT_AND => [qw(not and)], NOT_OR=> [qw(not and)], OR => ['', 'or'],
+ AND => ['', 'and']
+ }->{$conjunction} || ['', 'and']};
+
+ $sql .= 'where '; #($#join_conditions == -1 ? "where " : " and ");
+ if ($not) {
+ $sql .= "$not (" . join("\n $andor ",@criteria_conditions) . ")\n";
}
else {
- $sql .= join("\n and ",@criteria_conditions) . "\n";
+ $sql .= join("\n $andor ",@criteria_conditions) . "\n";
}
}
if ($#group_summarykeys >= 0) {
@@ -1680,6 +1347,7 @@
&App::sub_entry if ($App::trace >= 3);
my ($self, $dbexpr, $reqd_tables, $relationship_defs, $require_type) = @_;
#print $App::DEBUG_FILE "_require_tables($dbexpr,...,...,$require_type)\n";
+ #print STDERR "_require_tables($dbexpr,...,...,$require_type)\n";
my ($relationship, $relationship2, @relationship, %tableseen, $dependencies);
while ($dbexpr =~ s/([a-zA-Z_][a-zA-Z_0-9]*)\.[a-zA-Z_][a-zA-Z_0-9]*//) {
if (defined $relationship_defs->{$1} && !$tableseen{$1}) {
@@ -1687,9 +1355,10 @@
$tableseen{$1} = 1;
}
while ($relationship = pop(@relationship)) {
- if (! defined $reqd_tables->{$relationship}) {
+ if (0 && ! defined $reqd_tables->{$relationship}) {
$reqd_tables->{$relationship} = $require_type;
#print $App::DEBUG_FILE "table required: $relationship => $require_type\n";
+ #print STDERR "\ttable required: $relationship => $require_type\n";
$dependencies = $relationship_defs->{$relationship}{dependencies};
push(@relationship, @$dependencies)
if (defined $dependencies && ref($dependencies) eq "ARRAY");
@@ -1697,8 +1366,9 @@
elsif ($reqd_tables->{$relationship} < $require_type) {
$reqd_tables->{$relationship} = $require_type;
#print $App::DEBUG_FILE "table required: $relationship => $require_type\n";
+ #print STDERR "\ttable required: $relationship => $require_type\n";
}
- }
+ }
}
&App::sub_exit() if ($App::trace >= 3);
}
@@ -1708,52 +1378,32 @@
&App::sub_entry if ($App::trace);
my ($self, $table, $cols, $row) = @_;
- $self->_load_table_metadata($table) if (!defined $self->{table}{$table}{loaded});
+ $self->_load_table_metadata($table)
+ if (!defined $self->{table}{$table}{loaded});
my $dbh = $self->{dbh};
- my ($sql, $values, $col, $value, $colnum, $quoted);
- #print $App::DEBUG_FILE "_mk_insert_row_sql($table,\n [",
- # join(",",@$cols), "],\n [",
- # join(",",@$row), "])\n";
-
if ($#$cols == -1) {
$self->{error} = "Database->_mk_insert_row_sql(): no columns specified";
return();
}
my $tabcols = $self->{table}{$table}{column};
- $sql = "insert into $table\n";
- $values = "values\n";
- for ($colnum = 0; $colnum <= $#$cols; $colnum++) {
- $col = $cols->[$colnum];
- if (!defined $row || $#$row == -1) {
- $value = "?";
- }
- else {
- $value = $row->[$colnum];
- if (!defined $value) {
- $value = "NULL";
- }
- else {
- $quoted = (defined $tabcols->{$col}{quoted}) ? ($tabcols->{$col}{quoted}) : ($value !~ /^-?[0-9.]+$/);
- if ($quoted) {
- $value = $dbh->quote($value);
- }
- }
- }
- $sql .= ($colnum == 0) ? " ($col" : ",\n $col";
- if ($tabcols->{$col}{dbexpr_update}) {
- $value = sprintf($tabcols->{$col}{dbexpr_update}, $value);
- }
- $values .= ($colnum == 0) ? " ($value" : ",\n $value";
- }
- $sql .= ")\n";
- $values .= ")\n";
- $sql .= $values;
+ my $qtable = $table ; #$dbh->quote_identifier($table);
+ my $sql = qq{insert into $qtable (} . (join ',', @$cols). ") values (";
+ $sql .= (join ",", map {
+ my $x;
+ $tabcols->{$_}{dbexpr_update} ? sprintf($x, "?"): "?";
+ } @$cols). ")";
+
+
&App::sub_exit($sql) if ($App::trace);
$sql;
}
+sub _mk_insert_rows_sql {
+ &_mk_insert_row_sql;
+}
+
# $insert_sql = $rep->_mk_insert_sql ($table, \@cols, \@row, \%options);
sub _mk_insert_sql {
&App::sub_entry if ($App::trace);
@@ -1866,7 +1516,7 @@
}
}
elsif (ref($params) eq "HASH") {
- $where = $self->_mk_where_clause($table, $params);
+ $where = $self->_mk_where_clause($table, $params, {no_aliases => 1});
}
elsif (ref($params) eq "ARRAY") {
die "_mk_update_sql() can't update with no indexes/columns in params" if ($#$params == -1);
@@ -2002,7 +1652,7 @@
}
}
elsif (ref($params) eq "HASH") {
- $where = $self->_mk_where_clause($table, $params);
+ $where = $self->_mk_where_clause($table, $params, {no_aliases => 1});
}
elsif (ref($params) eq "ARRAY") {
die "_mk_delete_sql() can't delete with no indexes/columns in params" if ($#$params == -1);
@@ -2021,6 +1671,7 @@
$value = "NULL";
}
else {
+#TODO: FiX quoting to use lookslikeanumber();
$quoted = (defined $tabcols->{$col}{quoted})?($tabcols->{$col}{quoted}):($value !~ /^-?[0-9.]+$/);
if ($quoted) {
$value = $dbh->quote($value);
@@ -2100,7 +1751,7 @@
my ($sql);
$sql = "delete from $table\n";
- $sql .= $self->_mk_where_clause($table, $params);
+ $sql .= $self->_mk_where_clause($table, $params, {no_aliases => 1});
&App::sub_exit($sql) if ($App::trace);
$sql;
}
@@ -2195,10 +1846,20 @@
sub _insert_row {
&App::sub_entry if ($App::trace);
my ($self, $table, $cols, $row, $options) = @_;
+ # warn "Cols". Dumper($cols);
$self->{error} = "";
- my $sql = $self->_mk_insert_row_sql($table, $cols, undef, $options);
- $self->{sql} = $sql;
+
my $dbh = $self->{dbh};
+ my $sql;
+ my $sth = delete $self->{sth}; #rl XXX Hack fix this.
+ if (!$sth) {
+ $sql = $self->_mk_insert_row_sql($table, $cols, undef, $options);
+ confess "No SQL at _insert_row" if !$sql;
+ $self->{sql} = $sql;
+ $sth = $dbh->prepare($sql);
+ } else {
+ $sql = $self->{sql};
+ }
my $retval = 0;
my $context_options = $self->{context}{options};
@@ -2216,15 +1877,36 @@
}
if (defined $dbh) {
eval {
- ### TODO: make this work with regex for retry
- $retval = $dbh->do($sql, undef, @$row);
- $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
+ my $proceed_with_insert = 1;
+ if ($options->{replace} || $options->{update}) {
+ my $pk_idx = $self->_check_row($table, $cols, $row);
+ if ($pk_idx) {
+ if ($options->{replace}) {
+ $self->_delete_row($table, $cols, $row, [$pk_idx]);
+ } else {
+ $retval = $self->_update($table, [$pk_idx],$cols, $row);
+ $self->_set_insert_id($table, $cols, $row);
+ $proceed_with_insert = 0;
+ }
+ }
+ }
+ if ($proceed_with_insert) {
+ for(my $i = 0; $i<@$cols; ++$i) {
+ my $type=$self->{table}{$table}{column}{$cols->[$i]}{stype};
+ $sth->bind_param(
+ $i+1, $row->[$i],$type ? {TYPE=>$type} : ()
+ );
+ }
+ $retval = $sth->execute(@$row);
+ $self->_set_insert_id($table, $cols, $row);
+ $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
+ }
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
my $bind_values = join("|", map { defined $_ ? $_ : "undef" } @$row);
- $loglevel = 3 if ($@ =~ /duplicate/i);
- $self->{context}->log({level=>$loglevel}, "DBI Exception (fail) in _insert_row(): $@BIND VALUES: [$bind_values]\nSQL: $sql");
- die $@;
+ $loglevel = 3 if ($self->is_duplicate_key_error($e));
+ $self->{context}->log({level=>$loglevel}, "DBI Exception (fail) in _insert_row(): ${e}BIND VALUES: [$bind_values]\nSQL: $sql");
+ confess $e;
}
}
if ($debug_sql) {
@@ -2240,107 +1922,26 @@
# $nrows = $rep->_insert_rows ($table, \@cols, \@rows);
sub _insert_rows {
&App::sub_entry if ($App::trace);
- my ($self, $table, $cols, $rows, $options) = @_;
- $self->{error} = "";
+ my ($self, $table, $cols, $rows, $options) = @_; $self->{error} = "";
my ($sql, $retval);
+ my $debug_sql = $self->{context}{options}->{debug_sql};
my $dbh = $self->{dbh};
return 0 if (!defined $dbh);
my $nrows = 0;
- my $ok = 1;
- my $context_options = $self->{context}{options};
- my $debug_sql = $context_options->{debug_sql};
- my $explain_sql = $context_options->{explain_sql};
my ($timer, $elapsed_time);
- my $loglevel = 1;
- if ($debug_sql) {
- $timer = $self->_get_timer();
- }
- if (ref($rows) eq "ARRAY") {
- $sql = $self->_mk_insert_row_sql($table, $cols);
- foreach my $row (@$rows) {
- if ($debug_sql) {
- print $App::DEBUG_FILE "DEBUG_SQL: _insert_rows()\n";
- print $App::DEBUG_FILE "DEBUG_SQL: bind vars [", join("|",map { defined $_ ? $_ : "undef" } @$row), "]\n";
- print $App::DEBUG_FILE $sql;
- }
- if ($explain_sql) {
- $self->explain_sql($sql);
- }
- if (defined $dbh) {
- eval {
- ### TODO: make this work with regex for retry
- $retval = $dbh->do($sql, undef, @$row);
- $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
- };
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $loglevel = ($@ =~ /duplicate/i) ? 3 : 1;
- my $bind_values = join("|", map { defined $_ ? $_ : "undef" } @$row);
- $self->{context}->log({level=>$loglevel}, "DBI Exception (fail) in _insert_rows() [ARRAY]: $@BIND VALUES: [$bind_values]\nSQL: $sql");
- die $@;
- }
- }
- if ($debug_sql) {
- print $App::DEBUG_FILE "DEBUG_SQL: retval [$retval] $DBI::errstr\n";
- print $App::DEBUG_FILE "\n";
- }
-
- if ($retval) {
- $nrows ++;
- }
- else {
- $self->{numrows} = $nrows;
- $ok = 0;
- last;
- }
- }
+
+ if (ref($rows) ne "ARRAY") {
+ return $self->import_rows(@_[1..$#_]);
}
- else {
- my $fh = $rows; # assume it is a file handle
- $rows = []; # we will be refilling this buffer
- my %options = ( %$options ); # make a copy so it can be modified
- $options->{maxrows} = 100;
- $sql = $self->_mk_insert_row_sql($table, $cols);
- while (1) {
- $rows = $self->_read_rows_from_file($fh, $cols, \%options);
- last if ($#$rows == -1);
- foreach my $row (@$rows) {
- if ($debug_sql) {
- print $App::DEBUG_FILE "DEBUG_SQL: _insert_rows()\n";
- print $App::DEBUG_FILE "DEBUG_SQL: bind vars [", join("|",map { defined $_ ? $_ : "undef" } @$row), "]\n";
- print $App::DEBUG_FILE $sql;
- }
- if ($context_options->{explain_sql}) {
- $self->explain_sql($sql);
- }
- if (defined $dbh) {
- eval {
- ### TODO: make this work with regex for retry
- $retval = $dbh->do($sql, undef, @$row);
- $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
- };
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $loglevel = ($@ =~ /duplicate/i) ? 3 : 1;
- my $bind_values = join("|", map { defined $_ ? $_ : "undef" } @$row);
- $self->{context}->log({level=>$loglevel}, "DBI Exception (fail) in _insert_rows() [FILE]: $@BIND VALUES: [$bind_values]\nSQL: $sql");
- die $@;
- }
- }
- if ($debug_sql) {
- print $App::DEBUG_FILE "DEBUG_SQL: retval [$retval] $DBI::errstr\n";
- print $App::DEBUG_FILE "\n";
- }
-
- if ($retval) {
- $nrows ++;
- }
- else {
- $self->{numrows} = $nrows;
- $ok = 0;
- }
- }
- }
+
+ $timer = $self->_get_timer() if ($debug_sql); #return timer object.
+ $sql = $self->_mk_insert_row_sql($table, $cols);
+ $self->{sth} = $dbh->prepare($sql); #XXX hack for now -- backend pass of sth
+ foreach my $row (@$rows) {
+ $self->_insert_row($table, $cols, $row, $options);
+ ++$nrows;
}
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
@@ -2352,6 +1953,50 @@
return($nrows);
}
+sub _check_row {
+ my $self = shift;
+ my ($table, $cols, $row) = @_;
+ my $dbh = $self->{dbh};
+
+ #my $pk = $dbh->quote_identifier($self->{table}{$table}{primary_key}[0]);
+ my $pk = $self->{table}{$table}{primary_key}[0];
+ my $qtable = $table; #$dbh->quote_identifier($table);
+ my ($check_pk, $check_ak);
+
+
+ my $pk_col;
+ my $pknum=0;
+ for my $col (@$cols) {
+ if ($col eq $self->{table}{$table}->{primary_key}[0]) {
+ $pk_col = $pknum;
+ }
+ ++$pknum;
+ }
+
+ $check_pk = $dbh->prepare(qq{
+ SELECT count(*) FROM $qtable WHERE $pk = ?
+ });
+
+ $check_ak = $dbh->prepare(
+ qq{SELECT count(*) FROM $qtable WHERE }. join " OR ", map {
+ my $key = $_;
+ my $col = $dbh->quote_identifier($key);
+ $key ? qq{($col IN (?) AND $col IS NOT NULL)} : ();
+ } @{$self->{table}{$table}{alternate_key}}
+ ) if $self->{table}{$table}{alternate_key};
+ my $exists;
+ if (defined($pk_col)) {
+ $check_pk->execute($row->[$pk_col]);
+ ($exists) = $check_pk->fetchrow_array; $check_pk->finish();
+ }
+ # $check_ak->execute(@$cols);
+ # ($exists) ||= $check_ak->fetchrow_array; $check_ak->finish();
+
+ return $pk_col if $exists; #XXX another ugly HACK.
+}
+
+
+
sub _delete {
&App::sub_entry if ($App::trace);
my ($self, $table, $params, $cols, $row, $options) = @_;
@@ -2378,9 +2023,9 @@
$retval = $dbh->do($sql);
$retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $self->{context}->log({level=>1},"DBI Exception (fail) in _delete(): $@SQL: $sql");
- die $@;
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _delete(): ${e}SQL: $sql");
+ die $e;
}
}
if ($debug_sql) {
@@ -2424,9 +2069,9 @@
$retval = $dbh->do($sql);
$retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $self->{context}->log({level=>1},"DBI Exception (fail) in _update(): $@SQL: $sql");
- die $@;
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _update(): ${e}SQL: $sql");
+ die $e;
}
}
if ($debug_sql) {
@@ -2466,9 +2111,9 @@
$retval = $dbh->do($sql);
$retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $self->{context}->log({level=>1},"DBI Exception (fail) in _delete_row(): $@SQL: $sql");
- die $@;
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _delete_row(): ${e}SQL: $sql");
+ die $e;
}
}
if ($debug_sql) {
@@ -2502,18 +2147,18 @@
}
my $retval = 0;
my $dbh = $self->{dbh};
+#TODO: Make checks consistant. Make App::Repo level function handle connect verification
if (defined $dbh) {
eval {
### TODO: make this work with regex for retry
$retval = $dbh->do($sql);
$retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
- $self->{context}->log({level=>1},"DBI Exception (fail) in _delete_rows(): $@SQL: $sql");
- die $@;
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _delete_rows(): ${e}SQL: $sql");
+ die $e;
}
}
- $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
print $App::DEBUG_FILE "DEBUG_SQL: retval [$retval] ($elapsed_time sec) $DBI::errstr\n";
@@ -2544,6 +2189,7 @@
if ($context_options->{explain_sql}) {
$self->explain_sql($sql);
}
+ ### TODO: make this work with regex for retry
if (defined $dbh) {
$self->{sql} = $sql;
my $continue = 1;
@@ -2554,24 +2200,22 @@
$retval = $dbh->selectall_arrayref($sql);
}
else {
- $retval = $dbh->do($sql);
- $retval = 0 if ($retval == 0); # turn "0E0" into plain old "0"
+ $retval = $dbh->do($sql)+0; # turn "0E0" into plain old "0"
}
};
- if ($@) { # Log the error message with the SQL and rethrow the exception
- my $retryable_modify_error_regex = $self->retryable_modify_error_regex();
- if ($@ =~ /$retryable_modify_error_regex/i) {
+ if (my $e = $@) { # Log the error message with the SQL and rethrow the exception
+ if ($self->is_retryable_modify_error($e)) {
if ($tries >= 3) {
- $self->{context}->log({level=>1},"DBI Exception (fail) (tries=$tries) in _do(): $@$sql");
- die $@;
+ $self->{context}->log({level=>1},"DBI Exception (fail) (tries=$tries) in _do(): $e$sql");
+ die $e;
}
- $self->{context}->log({level=>1},"DBI Exception (retry) (tries=$tries) in _do(): $@$sql");
+ $self->{context}->log({level=>1},"DBI Exception (retry) (tries=$tries) in _do(): $e$sql");
$tries++;
sleep(1);
}
else {
- $self->{context}->log({level=>1},"DBI Exception (fail) in _do(): $@$sql");
- die $@;
+ $self->{context}->log({level=>1},"DBI Exception (fail) in _do(): $e$sql");
+ die $e;
}
}
else {
@@ -2826,7 +2470,8 @@
# in MySQL 4.0.13, the table names are surrounded by backticks (!?!)
# so for safe measure, get rid of all quotes
# Also, get rid of prepended schema names.
- @tables = grep(s/^[^.]+\.//, grep(s/['"`]//g, $dbh->tables(undef, undef, undef, "TABLE")));
+#TODO: Repository Specific way of getting table names;
+ @tables = map {lc} grep(s/^[^.]+\.//, grep(s/['"`]//g, $dbh->tables(undef, undef, undef, "TABLE")));
# REMOVE ALL DEPENDENCE ON DBIx::Compat
# if the DBI method doesn't work, try the DBIx method...
@@ -2834,6 +2479,7 @@
# $func = DBIx::Compat::GetItem($dbdriver, "ListTables");
# @tables = &{$func}($dbh);
# }
+my ($sql);
# go through the list of native tables from the database
foreach $table (@tables) {
@@ -2859,83 +2505,23 @@
#########################################################
my ($ntype_attribute_idx, @ntype_attribute_values);
- ($ntype_attribute_idx, @ntype_attribute_values) = @{$dbh->type_info_all};
-
- # Contents of $type_attribute_idx for MySQL:
- # $ntype_attribute_idx = {
- # "TYPE_NAME" => 0,
- # "DATA_TYPE" => 1,
- # "COLUMN_SIZE" => 2,
- # "LITERAL_PREFIX" => 3,
- # "LITERAL_SUFFIX" => 4,
- # "CREATE_PARAMS" => 5,
- # "NULLABLE" => 6,
- # "CASE_SENSITIVE" => 7,
- # "SEARCHABLE" => 8,
- # "UNSIGNED_ATTRIBUTE" => 9,
- # "FIXED_PREC_SCALE" => 10,
- # "AUTO_UNIQUE_VALUE" => 11,
- # "LOCAL_TYPE_NAME" => 12,
- # "MINIMUM_SCALE" => 13,
- # "MAXIMUM_SCALE" => 14,
- # "NUM_PREC_RADIX" => 15,
- # "mysql_native_type" => 16,
- # "mysql_is_num" => 17,
- # };
-
- # Contents of @ntype_attribute_values for MySQL:
- # TYPE_NAME DATA_TYPE COLUMN_SIZE PRE SUF CREATEPARAMETERS NUL CASE SRCH UNS FIX AUTO LTYPE MINS MAXS RDX
- # varchar 12 255 ' ' max length 1 0 1 0 0 0 0 0 0 0
- # decimal 3 15 precision,scale 1 0 1 0 0 0 0 0 6 2
- # tinyint -6 3 1 0 1 0 0 0 0 0 0 10
- # smallint 5 5 1 0 1 0 0 0 0 0 0 10
- # integer 4 10 1 0 1 0 0 0 0 0 0 10
- # float 7 7 1 0 0 0 0 0 0 0 2 2
- # double 8 15 1 0 1 0 0 0 0 0 4 2
- # timestamp 11 14 ' ' 0 0 1 0 0 0 0 0 0 0
- # bigint -5 20 1 0 1 0 0 0 0 0 0 10
- # middleint 4 8 1 0 1 0 0 0 0 0 0 10
- # date 9 10 ' ' 1 0 1 0 0 0 0 0 0 0
- # time 10 6 ' ' 1 0 1 0 0 0 0 0 0 0
- # datetime 11 21 ' ' 1 0 1 0 0 0 0 0 0 0
- # year 5 4 1 0 1 0 0 0 0 0 0 0
- # date 9 10 ' ' 1 0 1 0 0 0 0 0 0 0
- # enum 12 255 ' ' 1 0 1 0 0 0 0 0 0 0
- # set 12 255 ' ' 1 0 1 0 0 0 0 0 0 0
- # blob -1 65535 ' ' 1 0 1 0 0 0 0 0 0 0
- # tinyblob -1 255 ' ' 1 0 1 0 0 0 0 0 0 0
- # mediumblob -1 16777215 ' ' 1 0 1 0 0 0 0 0 0 0
- # longblob -1 2147483647 ' ' 1 0 1 0 0 0 0 0 0 0
- # char 1 255 ' ' max length 1 0 1 0 0 0 0 0 0 0
- # decimal 2 15 precision,scale 1 0 1 0 0 0 0 0 6 2
- # tinyint unsigned -6 3 1 0 1 1 0 0 0 0 0 10
- # smallint unsigned 5 5 1 0 1 1 0 0 0 0 0 10
- # middleint unsigned 4 8 1 0 1 1 0 0 0 0 0 10
- # int unsigned 4 10 1 0 1 1 0 0 0 0 0 10
- # int 4 10 1 0 1 0 0 0 0 0 0 10
- # integer unsigned 4 10 1 0 1 1 0 0 0 0 0 10
- # bigint unsigned -5 20 1 0 1 1 0 0 0 0 0 10
- # text -1 65535 ' ' 1 0 1 0 0 0 0 0 0 0
- # mediumtext -1 16777215 ' ' 1 0 1 0 0 0 0 0 0 0
-
- my ($ntype_name, @ntype_names, $ntype_num, $ntype_attribute_values, $ntype_def);
- my ($ntype_name_idx, $ntype_num_idx, $column_size_idx, $literal_prefix_idx, $literal_suffix_idx);
- my ($unsigned_attribute_idx, $auto_unique_value_idx, $column);
-
- $ntype_name_idx = $ntype_attribute_idx->{"TYPE_NAME"};
- $ntype_num_idx = $ntype_attribute_idx->{"DATA_TYPE"};
- $column_size_idx = $ntype_attribute_idx->{"COLUMN_SIZE"};
- $literal_prefix_idx = $ntype_attribute_idx->{"LITERAL_PREFIX"};
- $literal_suffix_idx = $ntype_attribute_idx->{"LITERAL_SUFFIX"};
- $unsigned_attribute_idx = $ntype_attribute_idx->{"UNSIGNED_ATTRIBUTE"};
- $auto_unique_value_idx = $ntype_attribute_idx->{"AUTO_UNIQUE_VALUE"};
+ ($ntype_attribute_idx,@ntype_attribute_values) = @{$dbh->type_info_all||[]};
# go through the list of native type info from the DBI handle
- foreach $ntype_attribute_values (@ntype_attribute_values) {
+ my (@ntype_names);
+ foreach my $ntype_attribute_values (@ntype_attribute_values) {
- $ntype_name = $ntype_attribute_values->[$ntype_name_idx];
- $ntype_num = $ntype_attribute_values->[$ntype_num_idx];
- $ntype_def = {};
+ my $ntype_def = {};
+ for (qw(TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX LITERAL_SUFFIX
+ UNSIGNED_ATTRIBUTE AUTO_UNIQUE_VALUE))
+ {
+ my $key = lc($_);
+ $key =~ s/^type_name/name/; $key =~ s/^data_type/num/;
+ $ntype_def->{$key} = $ntype_attribute_values->[$ntype_attribute_idx->{$_}];
+ }
+
+ my $ntype_name = $ntype_def->{name};
+ my $ntype_num = $ntype_def->{num};
push(@ntype_names, $ntype_name);
$self->{native}{type}{$ntype_name} = $ntype_def;
@@ -2943,45 +2529,24 @@
$self->{native}{type}{$ntype_num} = $ntype_def;
}
- # save all the info worth saving in a native type definition
- $ntype_def->{name} = $ntype_name; # a real type name
- $ntype_def->{num} = $ntype_num; # an internal data type number
- $ntype_def->{column_size} = $ntype_attribute_values->[$column_size_idx];
- $ntype_def->{literal_prefix} = $ntype_attribute_values->[$literal_prefix_idx];
- $ntype_def->{literal_suffix} = $ntype_attribute_values->[$literal_suffix_idx];
- $ntype_def->{unsigned_attribute} = $ntype_attribute_values->[$unsigned_attribute_idx];
- $ntype_def->{auto_unique_value} = $ntype_attribute_values->[$auto_unique_value_idx];
$ntype_def->{literal_prefix} = "" if (! defined $ntype_def->{literal_prefix});
$ntype_def->{literal_suffix} = "" if (! defined $ntype_def->{literal_suffix});
-
$ntype_def->{quoted} = ($ntype_def->{literal_prefix} ne "" || $ntype_def->{literal_suffix} ne "");
+
# translate a native type into a repository type
+ $ntype_def->{type} = (sub { local($_) = shift;
+ (/char/ || /^enum$/ || /^set$/ ) && return "string";
+ (/text/ ) && return "text";
+ (/int/ || /^year$/ ) && return "integer";
+ (/decimal/ || /float/ || /double/ ) && return "float";
+ (/datetime/ || /timestamp/ ) && return "datetime";
+ (/time/ ) && return "time";
+ (/date/ ) && return "date";
+ (/blob/ || /binary/ ) && return "binary";
+ # warn "Unknown type $_";
+ })->($ntype_name);
- if ($ntype_name =~ /char/ || $ntype_name eq "enum" || $ntype_name eq "set") {
- $ntype_def->{type} = "string";
- }
- elsif ($ntype_name =~ /text/) {
- $ntype_def->{type} = "text";
- }
- elsif ($ntype_name =~ /int/ || $ntype_name eq "year") {
- $ntype_def->{type} = "integer";
- }
- elsif ($ntype_name =~ /decimal/ || $ntype_name =~ /float/ || $ntype_name =~ /double/) {
- $ntype_def->{type} = "float";
- }
- elsif ($ntype_name =~ /datetime/ || $ntype_name =~ /timestamp/) {
- $ntype_def->{type} = "datetime";
- }
- elsif ($ntype_name =~ /time/) {
- $ntype_def->{type} = "time";
- }
- elsif ($ntype_name =~ /date/) {
- $ntype_def->{type} = "date";
- }
- elsif ($ntype_name =~ /blob/ || $ntype_name =~ /binary/) {
- $ntype_def->{type} = "binary";
- }
}
$self->{native}{types} = \@ntype_names;
@@ -3061,10 +2626,10 @@
# if we got a list of columns for the table from the database
if (defined $phys_columns && ref($phys_columns) eq "ARRAY") {
- $table_def->{phys_columns} = [ @$phys_columns ];
+ $table_def->{phys_columns} = [ map {lc} @$phys_columns ];
for ($colnum = 0; $colnum <= $#$phys_columns; $colnum++) {
- $column = $phys_columns->[$colnum];
+ $column = lc($phys_columns->[$colnum]);
$column_def = $table_def->{column}{$column};
if (!defined $column_def) {
@@ -3083,6 +2648,7 @@
$column_def->{name} = $column;
$column_def->{type} = $native_type_def->{type};
+ $column_def->{stype} = $native_type_num;
$column_def->{quoted} = $native_type_def->{quoted} ? 1 : 0;
$column_def->{alias} = "cn$colnum" if (!defined $column_def->{alias});
$column_def->{dbexpr} = $table_def->{alias} . "." . $column
@@ -3160,20 +2726,69 @@
&App::sub_exit() if ($App::trace);
}
+sub _set_insert_id {
+ my ($self) = shift;
+ my ($table, $cols, $row) = @_;
+
+ my $pk_col;
+ my $pknum=0;
+ for my $col (@$cols) {
+ if ($col eq $self->{table}{$table}->{primary_key}[0]) {
+ $pk_col = $pknum;
+ }
+ ++$pknum;
+ }
+
+ if (defined($pk_col)) {
+ $self->{last_inserted_id} = $row->[$pk_col];
+ return;
+ }
+
+ my $id = $self->{last_inserted_id} = $self->{dbh}->last_insert_id($self->{dbcatalog}, $self->{dbschema}, $table, $self->{table}{$table}{primary_key});
+
+ return if $id;
+
+ eval {
+ my $dbh = $self->{dbh};
+ my $pk = $self->{table}{$table}{primary_key}[0];
+ $id = ($dbh->selectall_arrayref(qq{SELECT max($pk) FROM $table}))->[0][0];
+ #warn "Primary key old skoo: $id";
+ $self->{last_inserted_id} = $id;
+ }; warn ($@) if $@;
+
+ warn "Could not find _last_inserted_id for table $id" if !$id;
+
+ return;
+}
+
+
+
+
+sub _last_inserted_id {
+ my ($self, $table) = @_;
+ return $self->{last_inserted_id};
+}
+
sub _load_table_key_metadata {
&App::sub_entry if ($App::trace);
my ($self, $table) = @_;
- return if (! $table);
+ warn "No Table name", return if (! $table);
my $table_def = $self->{table}{$table};
- return if (! $table_def);
- my $dbh = $self->{dbh};
+ warn "No Table def", return if (! $table_def);
+ if (!$table_def->{phys_table}) {
+ &App::sub_exit() if ($App::trace);
+ return();
+ }
+ my $dbh = $self->{dbh};
# if not defined at all, try to get it from the database
+ #$self->{dbcatalog} ||=$self->{dbname};
+ $self->{dbschema} ||= $self->{dbname} if $self->{dbdriver} eq 'Oracle';
if (! defined $table_def->{primary_key}) {
eval {
- $table_def->{primary_key} = [ $dbh->primary_key($self->{dbcatalog}, $self->{dbschema}, $table) ];
- };
+ $table_def->{primary_key} = [ map {lc} $dbh->primary_key($self->{dbcatalog}, $self->{dbschema}, $table) ];
+ }; if ($@) {die $@}
}
&App::sub_exit() if ($App::trace);
}
Modified: p5ee/trunk/App-Repository/lib/App/Repository/MySQL.pm
==============================================================================
--- p5ee/trunk/App-Repository/lib/App/Repository/MySQL.pm (original)
+++ p5ee/trunk/App-Repository/lib/App/Repository/MySQL.pm Tue Oct 7 13:59:09 2008
@@ -32,39 +32,13 @@
=cut
-sub _connect {
+sub _attr {
&App::sub_entry if ($App::trace);
my $self = shift;
+ my $attr = { %{$self->SUPER::_attr()}, mysql_auto_reconnect => 1};
- if (!defined $self->{dbh}) {
- my $dsn = $self->_dsn();
- my $attr = $self->_attr();
-
- while (1) {
- eval {
- $self->{dbh} = DBI->connect($dsn, $self->{dbuser}, $self->{dbpass}, $attr);
- $self->{dbh}{mysql_auto_reconnect} = 1;
- };
- if ($@) {
- delete $self->{dbh};
- if ($@ =~ /Lost connection/ || $@ =~ /server has gone away/) {
- $self->{context}->log("DBI Exception (retrying) in _connect(): $@");
- sleep(1);
- }
- else {
- $self->{context}->log("DBI Exception (fail) in _connect(): $@");
- die $@;
- }
- }
- else {
- last;
- }
- }
- die "Can't connect to database" if (!$self->{dbh});
- }
-
- &App::sub_exit(defined $self->{dbh}) if ($App::trace);
- return(defined $self->{dbh});
+ &App::sub_exit($attr) if ($App::trace);
+ return($attr);
}
sub _dsn {
@@ -474,88 +448,32 @@
&App::sub_entry if ($App::trace);
my ($self, $table) = @_;
- if (! $table) {
- &App::sub_exit() if ($App::trace);
- return;
- }
+ return if (! $table);
my $table_def = $self->{table}{$table};
- if (! $table_def) {
- &App::sub_exit() if ($App::trace);
- return;
- }
+ return if (! $table_def);
+
+ $self->SUPER::_load_table_key_metadata($table);
my $dbh = $self->{dbh};
# if not defined at all, try to get it from the database
- my (@primary_key, @alternate_key, @index, @key, $key_name, $non_unique);
- if ($table_def->{phys_table} && (! defined $table_def->{primary_key} || ! defined $table_def->{alternate_key})) {
+ if ($table_def->{phys_table} && (! defined $table_def->{primary_key} ||
+ !defined $table_def->{alternate_key}))
+ {
+ my $unique;
+
local $dbh->{FetchHashKeyName} = 'NAME_lc';
- my $sth = $dbh->prepare("SHOW INDEX FROM $table");
- my $hashes = $dbh->selectall_arrayref($sth, { Columns=>{} });
- foreach my $hash (@$hashes) {
- if ($key_name && $hash->{key_name} ne $key_name) {
- if ($key_name eq 'PRIMARY') {
- @primary_key = @key;
- }
- elsif ($non_unique) {
- push(@index, [@key]);
- }
- else {
- push(@alternate_key, [@key]);
- }
- @key = ();
- }
- $non_unique = $hash->{non_unique};
- $key_name = $hash->{key_name};
- push(@key, $hash->{column_name});
- }
- if ($key_name) {
- if ($key_name eq 'PRIMARY') {
- @primary_key = @key;
- }
- elsif ($non_unique) {
- push(@index, [@key]);
- }
- else {
- push(@alternate_key, [@key]);
- }
- }
-
- $table_def->{primary_key} = \@primary_key if (!$table_def->{primary_key});
- $table_def->{alternate_key} = \@alternate_key if (!$table_def->{alternate_key} && $#alternate_key > -1);
+ (my $sth = $dbh->prepare("SHOW INDEX FROM $table"))->execute();
+ for my $idx (@{$sth->fetchall_arrayref({})}) {
+ next if ('PRIMARY' eq $idx->{key_name}); # SUPER handles.
+ if (!($idx->{Non_unique})) {
+ push @{$unique->{$idx->{key_name}}},$idx->{column_name};
+ }
+ }
+ $table_def->{alternate_key} = [values %$unique];
}
&App::sub_exit() if ($App::trace);
}
-# The following patch purportedly adds primary_key() detection directly
-# to the DBD where it belongs. Until this is in, I may want to
-# duplicate the code in this module.
-#diff -ru DBD-mysql-2.9003/lib/DBD/mysql.pm new/lib/DBD/mysql.pm
-#--- DBD-mysql-2.9003/lib/DBD/mysql.pm Mon Oct 27 14:26:08 2003
-#+++ new/lib/DBD/mysql.pm Tue Mar 2 08:03:17 2004
-#@@ -282,7 +282,22 @@
-# return map { $_ =~ s/.*\.//; $_ } $dbh->tables();
-#}
-#-
-#+sub primary_key {
-#+ my ($dbh, $catalog, $schema, $table) = @_;
-#+ my $table_id = $dbh->quote_identifier($catalog, $schema, $table);
-#+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
-#+ my $desc_sth = $dbh->prepare("SHOW INDEX FROM $table_id");
-#+ my $desc = $dbh->selectall_arrayref($desc_sth, { Columns=>{} });
-#+ my %keys;
-#+ foreach my $row (@$desc) {
-#+ if ($row->{key_name} eq 'PRIMARY') {
-#+ $keys{$row->{column_name}} = $row->{seq_in_index};
-#+ }
-#+ }
-#+ my (@keys) = sort { $keys{$a} <=> $keys{$b} } keys %keys;
-#+ return (@keys);
-#+}
-#+
-#sub column_info {
-# my ($dbh, $catalog, $schema, $table, $column) = @_;
-# return $dbh->set_err(1, "column_info doesn't support table wildcard")
-
#############################################################################
# METHODS
#############################################################################
@@ -661,12 +579,12 @@
}
eval {
$nrows = $self->{dbh}->do($sql);
- };
+ }; my $e = $@;
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
- print $App::DEBUG_FILE "DEBUG_SQL: import_rows=[$nrows] ($elapsed_time sec) $DBI::errstr : $@\n";
+ print $App::DEBUG_FILE "DEBUG_SQL: import_rows=[$nrows] ($elapsed_time sec) $DBI::errstr : $e\n";
}
- die $@ if ($@);
+ die $e if ($e);
}
&App::sub_exit($nrows) if ($App::trace);
@@ -761,10 +679,10 @@
my ($retval);
eval {
$retval = $self->{dbh}->do($sql);
- };
+ }; my $e = $@;
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
- print $App::DEBUG_FILE "DEBUG_SQL: export_rows=[$retval] ($elapsed_time sec) $DBI::errstr : $@\n";
+ print $App::DEBUG_FILE "DEBUG_SQL: export_rows=[$retval] ($elapsed_time sec) $DBI::errstr : $e\n";
}
}
@@ -826,5 +744,20 @@
}
}
+sub is_retryable_connection_error {
+ my ($self, $e) = @_;
+ return($e =~ /Lost connection|server has gone away/);
+}
+
+sub is_retryable_modify_error {
+ my ($self, $e) = @_;
+ return($e =~ /Lost connection|server has gone away|Deadlock found/);
+}
+
+sub is_duplicate_key_error {
+ my ($self, $e) = @_;
+ return($e =~ /duplicate/i);
+}
+
1;
Added: p5ee/trunk/App-Repository/lib/App/Repository/Oracle.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Repository/lib/App/Repository/Oracle.pm Tue Oct 7 13:59:09 2008
@@ -0,0 +1,329 @@
+
+######################################################################
+## File: $Id: MySQL.pm 10474 2008-01-04 19:09:48Z spadkins $
+######################################################################
+
+use App::Repository::DBI;
+
+package App::Repository::Oracle;
+$VERSION = (q$Revision: 10474 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers generated by svn
+
+@ISA = ( "App::Repository::DBI" );
+
+use strict;
+use Data::Dumper;
+
+=head1 NAME
+
+App::Repository::MySQL - a MySQL database, accessed through the Repository interface
+
+=head1 SYNOPSIS
+
+ use App::Repository::MySQL;
+
+ (see man pages for App::Repository and App::Repository::DBI for additional methods)
+
+ ...
+
+=cut
+
+=head1 DESCRIPTION
+
+The App::Repository::MySQL class encapsulates all access to a MySQL database.
+
+=cut
+
+sub _dsn {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+
+ my $dbdriver = "Oracle";
+ $self->{dbdriver} = $dbdriver if (!$self->{dbdriver});
+
+ my $dsn = $self->{dbdsn};
+ if (!$dsn) {
+ my $dbhost = $self->{dbhost};
+ my $dbport = $self->{dbport};
+ my $dbsocket = $self->{dbsocket};
+ my $dbname = $self->{dbname};
+ my $dbuser = $self->{dbuser};
+ my $dbpass = $self->{dbpass};
+ my $dbschema = $self->{dbschema};
+ my $dbioptions = $self->{dbioptions};
+
+ die "ERROR: missing DBI driver and/or db name [$dbdriver,$dbname] in configuration.\n"
+ if (!$dbdriver || !$dbname);
+
+ # NOTE: mysql_client_found_rows=true is important for the following condition.
+ # If an update is executed against a row that exists, but its values do not change,
+ # MySQL does not ordinarily report this as a row that has been affected by the
+ # statement. However, we occasionally need to know if the update found the row.
+ # We really don't care if the values were changed or not. To get this behavior,
+ # we need to set this option.
+
+ $dsn = "dbi:${dbdriver}:sid=${dbname}";
+ $dsn .= ";host=$dbhost" if ($dbhost);
+ $dsn .= ";port=$dbport" if ($dbport);
+ $dsn .= ";$dbioptions" if ($dbioptions);
+ }
+
+ &App::sub_exit($dsn) if ($App::trace);
+ return($dsn);
+}
+
+sub _mk_where_clause {
+ &App::sub_entry if ($App::trace);
+ my ($self, $table, $options) = @_;
+ my $where = $self->SUPER::_mk_where_clause(@_[1..$#_]);
+
+ $options = {} if (!$options);
+ if ($options->{endrow}) {
+ $where .= "AND rownum <= $options->{endrow}\n";
+ }
+ &App::sub_exit($where) if ($App::trace);
+ return($where);
+}
+
+use Data::Dumper;
+sub _load_table_key_metadata {
+ &App::sub_entry if ($App::trace);
+ my ($self, $table) = @_;
+
+ return if (! $table);
+ my $table_def = $self->{table}{$table};
+ return if (! $table_def);
+ my $dbh = $self->{dbh};
+
+ $self->SUPER::_load_table_key_metadata($table);
+ # $self->_load_alternate_indices();
+ warn("Look for alternated indeces");
+
+ &App::sub_exit() if ($App::trace);
+}
+
+
+#############################################################################
+# METHODS
+#############################################################################
+
+=head1 Methods: Import/Export Data From File
+
+=cut
+
+#############################################################################
+# import_rows()
+#############################################################################
+
+=head2 import_rows()
+
+ * Signature: $rep->import_rows($table, $file);
+ * Signature: $rep->import_rows($table, $file, $options);
+ * Param: $table string
+ * Param: $file string
+ * Param: $options named
+ * Param: columns ARRAY names of columns of the fields in the file
+ * Param: import_method string [basic=invokes generic superclass to do work,
+ insert=loads with multiple-row inserts,
+ <otherwise>=use "load data infile"]
+ * Param: local boolean file is on client machine rather than database server
+ * Param: replace boolean rows should replace existing rows based on unique indexes
+ * Param: field_sep char character which separates the fields in the file (can by "\t")
+ * Param: field_quote char character which optionally encloses the fields in the file (i.e. '"')
+ * Param: field_escape char character which escapes the quote chars within quotes (i.e. "\")
+ * Return: void
+ * Throws: App::Exception::Repository
+ * Since: 0.01
+
+ Note: If you want to call this with $options->{local}, you will probably
+ need to make sure that mysql_local_infile=1 is in your DSN. This might
+ require a line like the following in your "app.conf" file.
+
+ dbioptions = mysql_local_infile=1
+
+ Sample Usage:
+
+ $rep->import_rows("usr","usr.dat");
+
+ # root:x:0:0:root:/root:/bin/bash
+ $rep->import_rows("usr", "/etc/passwd" ,{
+ field_sep => ":",
+ columns => [ "username", "password", "uid", "gid", "comment", "home_directory", "shell" ],
+ });
+
+=cut
+
+
+#############################################################################
+# export_rows()
+#############################################################################
+
+=head2 export_rows()
+
+ * Signature: $rep->export_rows($table, $file);
+ * Signature: $rep->export_rows($table, $file, $options);
+ * Param: $table string
+ * Param: $file string
+ * Param: $options named
+ * Param: columns ARRAY names of columns of the fields in the file
+ * Param: export_method string [basic=invokes generic superclass to do work]
+ * Param: field_sep char character which separates the fields in the file (can by "\t")
+ * Param: field_quote char character which optionally encloses the fields in the file (i.e. '"')
+ * Param: field_escape char character which escapes the quote chars within quotes (i.e. "\")
+ * Return: void
+ * Throws: App::Exception::Repository
+ * Since: 0.01
+
+ Sample Usage:
+
+ $rep->export_rows("usr","usr.dat");
+
+ # root:x:0:0:root:/root:/bin/bash
+ $rep->export_rows("usr", "passwd.dat" ,{
+ field_sep => ":",
+ columns => [ "username", "password", "uid", "gid", "comment", "home_directory", "shell" ],
+ });
+
+=cut
+
+#SELECT ... INTO OUTFILE is the complement of LOAD DATA INFILE; the syntax for the
+#export_options part of the statement consists of the same FIELDS and LINES clauses
+#that are used with the LOAD DATA INFILE statement.
+#See Section 13.2.5, .LOAD DATA INFILE Syntax..
+
+#SELECT
+# [ALL | DISTINCT | DISTINCTROW ]
+# [HIGH_PRIORITY]
+# [STRAIGHT_JOIN]
+# [SQL_SMALL_RESULT] [SQL_BIG_RESULT] [SQL_BUFFER_RESULT]
+# [SQL_CACHE | SQL_NO_CACHE] [SQL_CALC_FOUND_ROWS]
+# select_expr, ...
+# [INTO OUTFILE 'file_name' export_options
+# | INTO DUMPFILE 'file_name']
+# [FROM table_references
+# [WHERE where_definition]
+# [GROUP BY {col_name | expr | position}
+# [ASC | DESC], ... [WITH ROLLUP]]
+# [HAVING where_definition]
+# [ORDER BY {col_name | expr | position}
+# [ASC | DESC] , ...]
+# [LIMIT {[offset,] row_count | row_count OFFSET offset}]
+# [PROCEDURE procedure_name(argument_list)]
+# [FOR UPDATE | LOCK IN SHARE MODE]]
+
+sub export_rows {
+ &App::sub_entry if ($App::trace);
+ my ($self, $table, $params, $file, $options) = @_;
+
+ if ($options->{export_method} && $options->{export_method} eq "basic") {
+ $self->SUPER::export_rows($table, $file, $options);
+ }
+ else {
+ my $columns = $options->{columns} || $self->{table}{$table}{columns};
+ my $where_clause = $self->_mk_where_clause($table, $params, $options);
+ my $sql = "select\n " . join(",\n ", @$columns);
+ $sql .= "\n$where_clause" if ($where_clause);
+ $sql .= "\ninto outfile '$file'";
+ if ($options->{field_sep} || $options->{field_quote} || $options->{field_escape}) {
+ $sql .= "\nfields";
+ $sql .= "\n terminated by '$options->{field_sep}'" if ($options->{field_sep});
+ $sql .= "\n optionally enclosed by '$options->{field_quote}'" if ($options->{field_quote});
+ $sql .= "\n escaped by '$options->{field_escape}'" if ($options->{field_escape});
+ }
+ $sql .= "\n";
+ my $context_options = $self->{context}{options};
+ my $debug_sql = $context_options->{debug_sql};
+ my ($timer, $elapsed_time);
+ if ($debug_sql) {
+ $timer = $self->_get_timer();
+ print $App::DEBUG_FILE "DEBUG_SQL: export_rows()\n";
+ print $App::DEBUG_FILE $sql;
+ }
+ my ($retval);
+ eval {
+ print STDERR "\n".("HERE"x12).Dumper($sql);
+ $retval = $self->{dbh}->do($sql);
+ };
+ if ($debug_sql) {
+ $elapsed_time = $self->_read_timer($timer);
+ print $App::DEBUG_FILE "DEBUG_SQL: export_rows=[$retval] ($elapsed_time sec) $DBI::errstr : $@\n";
+ }
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
+#+----+-------------+-------+-------+-------------------------------------+-------------------+---------+-------------+------+-------+
+#| id | select_type | table | type | possible_keys | key | key_len | ref | rows | Extra |
+#+----+-------------+-------+-------+-------------------------------------+-------------------+---------+-------------+------+-------+
+#| 1 | SIMPLE | t1 | const | hotel_prop_ds_ak1,hotel_prop_ds_ie1 | hotel_prop_ds_ak1 | 9 | const,const | 1 | |
+#+----+-------------+-------+-------+-------------------------------------+-------------------+---------+-------------+------+-------+
+sub explain_sql {
+ my ($self, $sql) = @_;
+ my $dbh = $self->{dbh};
+ # NOTE: MySQL "explain" only works for "select".
+ # We convert "update" and "delete" to "select" to explain them.
+ if (defined $dbh) {
+ if ($sql =~ s/^delete/select */is) {
+ # do nothing
+ }
+ elsif ($sql =~ s/^update\s+(.*)\sset\s+.*\swhere/select * from $1\nwhere/is) {
+ # do nothing
+ }
+ if ($sql =~ /^select/i) {
+ my ($rows, $posskeys, $key, $keylen);
+ eval {
+ $rows = $dbh->selectall_arrayref("explain $sql");
+ };
+ print $App::DEBUG_FILE "EXPLAIN_SQL: $DBI::errstr\n";
+ if ($rows) {
+ print $App::DEBUG_FILE "+----+-------------+----------------------+-------+----------------------+---------+----------+\n";
+ print $App::DEBUG_FILE "| id | select_type | table | type | key | key_len | rows |\n";
+ print $App::DEBUG_FILE "+----+-------------+----------------------+-------+----------------------+---------+----------+\n";
+ foreach my $row (@$rows) {
+ $key = $row->[5];
+ $keylen = length($key);
+ if ($keylen > 21) {
+ $key = substr($key,0,12) . ".." . substr($key,$keylen-7,7);
+ }
+ printf($App::DEBUG_FILE "|%3s | %-12s| %-21s| %-6s| %-21s|%8d |%9d | %s\n", @{$row}[0,1,2,3], $key, @{$row}[6,8]);
+ }
+ print $App::DEBUG_FILE "+----+----------------------------------------------------------------------------------------+\n";
+ print $App::DEBUG_FILE "| id | possible_keys/ref/extra\n";
+ print $App::DEBUG_FILE "+----+----------------------------------------------------------------------------------------+\n";
+ foreach my $row (@$rows) {
+ $key = $row->[5];
+ $posskeys = $row->[4];
+ $posskeys =~ s/\b($key)\b/[$key]/;
+ printf($App::DEBUG_FILE "|%3s | posskeys: %s\n", $row->[0], $posskeys);
+ printf($App::DEBUG_FILE "|%3s | ref: %s; extra: %s\n", @{$row}[0,7,9]);
+ }
+ print $App::DEBUG_FILE "+---------------------------------------------------------------------------------------------+\n";
+ }
+ }
+ else {
+ $sql =~ /^\s*(\S*)/;
+ print $App::DEBUG_FILE "EXPLAIN_SQL: Can't explain $1 statement.\n";
+ }
+ }
+}
+
+sub is_retryable_connection_error {
+ my ($self, $e) = @_;
+ warn "Oracle-specific error messages not defined";
+ return($e =~ /TBD-FOO/);
+}
+
+sub is_retryable_modify_error {
+ my ($self, $e) = @_;
+ warn "Oracle-specific error messages not defined";
+ return($e =~ /TBD-FOO/);
+}
+
+sub is_duplicate_key_error {
+ my ($self, $e) = @_;
+ warn "Oracle-specific error messages not defined";
+ return($e =~ /duplicate/i);
+}
+
+1;
+