App-Repository
view release on metacpan or search on metacpan
lib/App/Repository/DBI.pm view on Meta::CPAN
$self->{context}->log({level=>1},"DBI Exception (fail) in _get_rows(): $@$sql");
die $@;
}
}
else {
last;
}
}
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
print $App::DEBUG_FILE "DEBUG_SQL: nrows [", (defined $rows ? ($#$rows+1) : 0), "] ($elapsed_time sec) $DBI::errstr\n";
if ($debug_sql >= 2) {
foreach my $row (@$rows) {
print $App::DEBUG_FILE "DEBUG_SQL: [", join("|",map { defined $_ ? $_ : "undef"} @$row), "]\n";
}
}
print $App::DEBUG_FILE "\n";
}
&App::sub_exit($rows) if ($App::trace);
return($rows);
}
sub _get_default_columns {
&App::sub_entry if ($App::trace);
my ($self, $table) = @_;
$self->_load_table_metadata($table) if (!defined $self->{table}{$table}{loaded});
my $table_def = $self->{table}{$table};
my $columns = $table_def->{default_columns} || "";
if (ref($columns) eq "ARRAY") {
# do nothing
}
elsif ($columns eq "configured") {
$columns = $table_def->{columns};
}
elsif (!$columns || $columns eq "physical") {
$columns = $table_def->{phys_columns};
}
if (!$columns || ref($columns) ne "ARRAY") {
my $table_def = $self->{table}{$table};
my $repname = $table_def->{repository};
my $realtable = $table_def->{table} || $table;
if (defined $repname && $repname ne $self->{name}) {
my $rep = $self->{context}->repository($repname);
$columns = $rep->_get_default_columns($realtable);
}
elsif (defined $realtable && $realtable ne $table) {
$columns = $self->_get_default_columns($realtable);
}
}
if (!$columns || ref($columns) ne "ARRAY") {
$columns = [];
}
&App::sub_exit($columns) if ($App::trace);
return($columns);
}
# modified from the DBD::_::db::selectall_arrayref in DBI.pm
sub _selectrange_arrayref {
&App::sub_entry if ($App::trace);
my ($self, $stmt, $startrow, $endrow, $attr, @bind) = @_;
my $dbh = $self->{dbh};
return [] if (!$dbh);
my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
if ($sth) {
$sth->execute(@bind) || return;
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
$slice = [ @{$attr->{Columns}} ]; # take a copy
for (@$slice) { $_-- }
}
}
my $retval = $self->_fetchrange_arrayref($sth, $startrow, $endrow, $slice);
&App::sub_exit($retval) if ($App::trace);
return($retval);
}
else {
&App::sub_exit() if ($App::trace);
return();
}
}
# modified from the DBD::_::st::fetchall_arrayref in DBI.pm
sub _fetchrange_arrayref {
&App::sub_entry if ($App::trace);
my ($self, $sth, $startrow, $endrow, $slice) = @_;
$slice = [] if (! defined $slice);
$startrow = 0 if (!defined $startrow);
$endrow = 0 if (!defined $endrow);
my $mode = ref $slice;
my @rows;
my $row;
my ($rownum);
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);
}
}
elsif ($mode eq 'HASH') {
if (keys %$slice) {
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++;
lib/App/Repository/DBI.pm view on Meta::CPAN
my ($sql, $where, @colused, $col, $value, $colnum, $i, $nonkeycolnum, $quoted);
if ($#$cols == -1) {
$self->{error} = "Database->_mk_delete_row_sql(): no columns specified";
return();
}
my $tabcols = $self->{table}{$table}{column};
$colused[$#$cols] = 0; # pre-extend the array
$sql = "delete from $table\n";
if (defined $keycolidx && $#$keycolidx > -1) {
for ($i = 0; $i <= $#$keycolidx; $i++) {
$colnum = $keycolidx->[$i];
$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);
}
}
}
$where .= ($i == 0) ? "where $col = $value" : "\n and $col = $value";
$colused[$colnum] = 1;
}
$where .= "\n";
}
$sql .= $where;
&App::sub_exit($sql) if ($App::trace);
$sql;
}
# $delete_sql = $rep->_mk_delete_rows_sql($table, \@params, \%paramvalues);
sub _mk_delete_rows_sql {
&App::sub_entry if ($App::trace);
my ($self, $table, $params, $paramvalues) = @_;
$self->_load_table_metadata($table) if (!defined $self->{table}{$table}{loaded});
my ($sql);
$sql = "delete from $table\n";
$sql .= $self->_mk_where_clause($table, $params);
&App::sub_exit($sql) if ($App::trace);
$sql;
}
######################################################################
# SIMPLE SQL OPERATIONS
######################################################################
# $row = $rep->select_row ($table, \@cols, \@params, \%paramvalues);
# this is a new version that uses bind variables instead of relying on my quoting rules
# unfortunately, it doesn't work yet
sub _select_row {
&App::sub_entry if ($App::trace);
my ($self, $table, $cols, $params, $paramvalues) = @_;
my ($dbh, $sql, $param, @params, %paramvalues, @paramvalues);
$self->{error} = "";
if (defined $params) {
@params = @$params;
}
else {
@params = (keys %$paramvalues);
}
foreach $param (@params) {
push(@paramvalues, $paramvalues->{$param});
}
if ($self->{table}{$table}{rawaccess}) {
$sql = $self->_mk_select_sql($table, $cols, \@params, \%paramvalues, undef, 1, 1);
}
else {
$sql = $self->_mk_select_rows_sql($table, $cols, \@params, \%paramvalues, undef, 1, 1);
}
$self->{sql} = $sql;
my $rows = $self->_selectrange_arrayref($sql, 1, 1, undef, @paramvalues);
if (!$rows || $#$rows == -1) {
&App::sub_exit([]) if ($App::trace);
return [];
}
&App::sub_exit($rows->[0]) if ($App::trace);
return ($rows->[0]);
}
# NOTE: everything after the first line is optional
# @rows = $rep->_select_rows($table, \@cols,
# \@params, \%paramvalues, \@order_by,
# $startrow, $endrow,
# \@sortdircol, \@keycolidx, \@writeable, \@columntype, \@summarykeys);
# TODO: get the $startrow/$endrow working when one/both/neither work in the SQL portion
# TODO: rethink $startrow/$endrow vs. $numrows/$skiprows
# this is a new version that uses bind variables instead of relying on my quoting rules
# unfortunately, it doesn't work yet
sub _select_rows {
&App::sub_entry if ($App::trace);
my ($self, $table, $cols, $params, $paramvalues, $order_by, $startrow, $endrow,
$sortdircol, $keycolidx, $writeable, $columntype, $group_by) = @_;
my ($sql, $param, @params, %paramvalues, @paramvalues);
$self->{error} = "";
if (defined $params) {
@params = @$params;
}
else {
@params = (keys %$paramvalues);
}
foreach $param (@params) {
push(@paramvalues, $paramvalues->{$param});
}
if ($self->{table}{$table}{rawaccess}) {
$sql = $self->_mk_select_sql($table, $cols, \@params, \%paramvalues, $order_by,
$startrow, $endrow, $sortdircol, $keycolidx, $writeable, $columntype, $group_by);
}
else {
$sql = $self->_mk_select_rows_sql($table, $cols, \@params, \%paramvalues, $order_by,
$startrow, $endrow, $sortdircol, $keycolidx, $writeable, $columntype, $group_by);
}
$self->{sql} = $sql;
my $retval = $self->_selectrange_arrayref($sql, $startrow, $endrow, undef, @paramvalues);
&App::sub_exit($retval) if ($App::trace);
$retval;
}
# $ok = $rep->_insert_row($table, \@cols, \@row);
sub _insert_row {
&App::sub_entry if ($App::trace);
my ($self, $table, $cols, $row, $options) = @_;
$self->{error} = "";
my $sql = $self->_mk_insert_row_sql($table, $cols, undef, $options);
$self->{sql} = $sql;
my $dbh = $self->{dbh};
my $retval = 0;
my $context_options = $self->{context}{options};
my $debug_sql = $context_options->{debug_sql};
my ($timer, $elapsed_time);
my $loglevel = 1;
if ($debug_sql) {
$timer = $self->_get_timer();
print $App::DEBUG_FILE "DEBUG_SQL: insert()\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
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 $@;
}
}
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
print $App::DEBUG_FILE "DEBUG_SQL: retval [$retval] ($elapsed_time sec) $DBI::errstr\n";
print $App::DEBUG_FILE "\n";
}
&App::sub_exit($retval) if ($App::trace);
$retval;
}
# $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 ($sql, $retval);
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;
}
}
}
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;
}
}
}
}
if ($debug_sql) {
$elapsed_time = $self->_read_timer($timer);
print $App::DEBUG_FILE "DEBUG_SQL: nrows [$nrows] ($elapsed_time sec)\n";
}
$self->{sql} = $sql;
$self->{numrows} = $nrows;
&App::sub_exit($nrows) if ($App::trace);
return($nrows);
}
sub _delete {
&App::sub_entry if ($App::trace);
my ($self, $table, $params, $cols, $row, $options) = @_;
$self->{error} = "";
my $sql = $self->_mk_delete_sql($table, $params, $cols, $row, $options);
$self->{sql} = $sql;
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: _delete()\n";
print $App::DEBUG_FILE $sql;
}
if ($context_options->{explain_sql}) {
$self->explain_sql($sql);
}
my $retval = 0;
my $dbh = $self->{dbh};
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(): $@SQL: $sql");
die $@;
}
}
if ($debug_sql) {
lib/App/Repository/DBI.pm view on Meta::CPAN
#############################################################################
=head2 call_procedure()
* Signature: $rep->call_procedure($call_str);
* Signature: $rep->call_procedure($call_str, $return_type, $param_types, @params);
* Signature: $result = $rep->call_procedure($call_str, $return_type);
* Signature: $result = $rep->call_procedure($call_str, $return_type, $param_types, @params);
* Signature: @results = $rep->call_procedure($call_str, $return_type);
* Signature: @results = $rep->call_procedure($call_str, $return_type, $param_types, @params);
* Signature: $rows = $rep->call_procedure($call_str, $return_type);
* Signature: $rows = $rep->call_procedure($call_str, $return_type, $param_types, @params);
* Param: void
* Return: $result string (if $return_type is "SCALAR")
* Return: @results ARRAY (if $return_type is "LIST")
* Return: $row ARRAY (if $return_type is "ROW")
* Return: $rows ARRAY (if $return_type is "ROWS")
* Throws: App::Exception::Repository
* Since: 0.01
There is no standard way to call stored procedures in the DBI.
This is an attempt to provide access to them.
MySQL: Sample Usage
1. As of DBD-mysql-3.0008 and MySQL 5.1.12, INOUT and OUT parameters are not supported
2. In order to receive values back from a stored procedure in MySQL,
you need to have applied the "dbd-mysql-multi-statements.patch" patch.
https://rt.cpan.org/Public/Bug/Display.html?id=12322
https://rt.cpan.org/Ticket/Attachment/167152/53763/dbd-mysql-multi-statements.patch
This supports the "SCALAR" return type (and maybe "LIST" and "ROW"), but
a stored procedure can still not return multiple rows ("ROWS"). (I think.)
You DSN needs to have "mysql_multi_results=1" set to activate the ability to
get rows back from a stored procedure.
$rep->call_procedure("call sp_doit('prod',5)");
$val = $rep->call_procedure("call sp_doit_return_val('prod',5)", "SCALAR");
($val1, $val2) = $rep->call_procedure("call sp_doit_return_vals('prod',5)", "LIST");
$row = $rep->call_procedure("call sp_doit_return_vals('prod',5)", "ROW");
=cut
sub call_procedure {
&App::sub_entry if ($App::trace);
my ($self, $call_str, $return_type, $param_options, @params) = @_;
my $dbh = $self->{dbh};
my $sth = $dbh->prepare($call_str);
my ($i, $param_option, $param_direction, $param_length, $param_type);
for ($i = 0; $i <= $#params; $i++) {
$param_option = $param_options->[$i];
if (!ref($param_option)) {
$param_direction = $param_option || "IN";
$param_length = 100;
$param_type = undef;
}
else {
$param_direction = $param_option->{direction} || "IN";
$param_length = $param_option->{length} || 100;
$param_type = $param_option;
}
if ($param_direction eq "OUT") {
$sth->bind_param_inout($i+1, \$_[$i+4], $param_length);
}
elsif ($param_direction eq "INOUT") {
$sth->bind_param_inout($i+1, \$_[$i+4], $param_length);
}
else {
$sth->bind_param($i+1, $params[$i], $param_type);
}
}
$sth->execute();
my (@values);
my $rows = [];
if (defined $return_type) {
while (@values = $sth->fetchrow_array()) {
push(@$rows, [@values]);
}
if ($return_type eq "LIST") {
@values = @{$rows->[0]} if ($#$rows > -1);
}
elsif ($return_type eq "SCALAR") {
@values = ($rows->[0][0]) if ($#$rows > -1 && $#{$rows->[0]} > -1);
}
elsif ($return_type eq "ROW") {
@values = ( $rows->[0] ) if ($#$rows > -1);
}
elsif ($return_type eq "ROWS") {
@values = ( $rows );
}
}
$sth->finish();
if ($return_type eq "LIST") {
&App::sub_exit(@values) if ($App::trace);
return(@values);
}
else {
&App::sub_exit($values[0]) if ($App::trace);
return($values[0]);
}
}
sub explain_sql {
&App::sub_entry if ($App::trace);
my ($self, $sql) = @_;
# to be overridden in each Repository class
&App::sub_exit() if ($App::trace);
}
######################################################################
# METADATA REPOSITORY METHODS (implements methods from App::Repository)
######################################################################
# REMOVE ALL DEPENDENCE ON DBIx::Compat
# (ok. I want to, but I'm not ready to rewrite ListFields.)
use DBIx::Compat;
sub _load_rep_metadata_from_source {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my ($dbdriver, $dbh);
$dbdriver = $self->{dbdriver};
$dbh = $self->{dbh};
#####################################################
# TABLE DATA
#####################################################
( run in 1.960 second using v1.01-cache-2.11-cpan-2398b32b56e )