[interchange-cvs] interchange - heins modified 10 files
interchange-cvs at icdevgroup.org
interchange-cvs at icdevgroup.org
Sat Jul 12 01:47:00 EDT 2003
User: heins
Date: 2003-07-12 04:47:10 GMT
Modified: dist/lib/UI/pages/admin direct_sql.html
Modified: lib/Vend Scan.pm Util.pm
Modified: lib/Vend/Table Common.pm DBI.pm DB_File.pm GDBM.pm
Modified: InMemory.pm LDAP.pm SDBM.pm
Log:
* Set up error reporting to be able to catch database errors
and display in session, catalog error.log, or global error.log
1. Logging levels are on a per-table basis, with
defaults that can be set with DatabaseDefault:
DatabaseDefault LOG_ERROR_CATALOG 1
DatabaseDefault LOG_ERROR_SESSION 1
DatabaseDefault LOG_ERROR_GLOBAL 0
DatabaseDefault DIE_ERROR 0
2. Log errors to the catalog error.log by default.
Database inventory LOG_ERROR_CATALOG 0|1*
3. Log errors to the session always if an admin, and
controlled by configuration if not.
Database inventory LOG_ERROR_SESSION 0|1*
This has the effect of giving a big red error message when such
an event as failing to create a record occured. In most cases,
you would be able to use the <-Back button and fix the error
and resubmit.
The error tag is "table foo", where foo is the table.
4. Die at the page level (500 error) only if that is explicit
request in config for that table:
Database inventory DIE_ERROR 0*|1
5. Log errors globally only on explicit request:
Database inventory LOG_ERROR_GLOBAL 0*|1
6. LENGTH_EXCEPTION errors go into warnings if they are handled
with truncate.
* default
* Fix numeric sorting in SQL statements if a field is NUMERIC.
* Allow limits from SQL statement to flow through even if ml="" is set
and let direct_sql.html admin page honor them.
* Fix table names so that we don't have the funky .txt problems
where a SQL query would not work on a DBM database unless
the file name base matched the table name.
* Attempt to regularize error messages so that they can be
more easily translated. Now should have about 50% less
variations.
Revision Changes Path
1.5 +1 -0 interchange/dist/lib/UI/pages/admin/direct_sql.html
rev 1.5, prev_rev 1.4
Index: direct_sql.html
===================================================================
RCS file: /var/cvs/interchange/dist/lib/UI/pages/admin/direct_sql.html,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- direct_sql.html 17 Jun 2003 21:31:00 -0000 1.4
+++ direct_sql.html 12 Jul 2003 04:47:10 -0000 1.5
@@ -122,6 +122,7 @@
<td>
<input type=submit>
<select name=limit>
+ <OPTION value=""> --no limit--
[loop list="250 10 25 50 100 500 1000 10000 50000" option=limit cgi=1]
<OPTION value="[loop-code]"> Limit to [loop-code]
[/loop]
2.24 +11 -4 interchange/lib/Vend/Scan.pm
rev 2.24, prev_rev 2.23
Index: Scan.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Scan.pm,v
retrieving revision 2.23
retrieving revision 2.24
diff -u -r2.23 -r2.24
--- Scan.pm 7 Jul 2003 05:49:33 -0000 2.23
+++ Scan.pm 12 Jul 2003 04:47:10 -0000 2.24
@@ -1,6 +1,6 @@
# Vend::Scan - Prepare searches for Interchange
#
-# $Id: Scan.pm,v 2.23 2003/07/07 05:49:33 mheins Exp $
+# $Id: Scan.pm,v 2.24 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -30,7 +30,7 @@
perform_search
);
-$VERSION = substr(q$Revision: 2.23 $, 10);
+$VERSION = substr(q$Revision: 2.24 $, 10);
use strict;
use Vend::Util;
@@ -112,6 +112,9 @@
prefix
));
+## Place marker, not used in search specs but is reserved
+## rt mv_real_table
+##
my %Scan = ( qw(
ac mv_all_chars
bd mv_base_directory
@@ -580,7 +583,7 @@
}
if ($table) {
- push_spec('fi', $table, $ary, $hash)
+ push_spec('fi', $table, $ary, $hash), push_spec('rt', $table, $ary, $hash)
# GLIMPSE
unless "\L$table" eq 'glimpse';
# END GLIMPSE
@@ -626,8 +629,10 @@
my $db = Vend::Data::database_exists_ref($t);
if($db) {
$codename = $db->config('KEY') || 'code';
- $nuhash = $db->config('NUMERIC') || undef;
+ # Only for first table, what else can we do?
+ $nuhash ||= $db->config('NUMERIC') || undef;
push_spec( 'fi', $db->config('file'), $ary, $hash);
+ push_spec( 'rt', $t, $ary, $hash);
$stmt->verbatim_fields(1)
if $db->config('VERBATIM_FIELDS');
}
@@ -640,6 +645,7 @@
# END GLIMPSE
else {
push_spec('fi', $t, $ary, $hash);
+ push_spec('rt', $t, $ary, $hash);
}
#::logDebug("t=$t obj=$_ db=$db nuhash=" . ::uneval($nuhash));
}
@@ -679,6 +685,7 @@
#::logDebug("found order column=$c");
push_spec('tf', $c, $ary, $hash);
my $d = $_->desc() ? 'fr' : 'f';
+ $d =~ s/f/n/ if exists $nuhash->{$c};
#::logDebug("found order sense=$d");
push_spec('to', $d, $ary, $hash);
}
2.62 +7 -5 interchange/lib/Vend/Util.pm
rev 2.62, prev_rev 2.61
Index: Util.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Util.pm,v
retrieving revision 2.61
retrieving revision 2.62
diff -u -r2.61 -r2.62
--- Util.pm 7 Jul 2003 22:24:04 -0000 2.61
+++ Util.pm 12 Jul 2003 04:47:10 -0000 2.62
@@ -1,6 +1,6 @@
# Vend::Util - Interchange utility functions
#
-# $Id: Util.pm,v 2.61 2003/07/07 22:24:04 ramoore Exp $
+# $Id: Util.pm,v 2.62 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -87,7 +87,7 @@
use Vend::File;
use subs qw(logError logGlobal);
use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = substr(q$Revision: 2.61 $, 10);
+$VERSION = substr(q$Revision: 2.62 $, 10);
my $Eval_routine;
my $Eval_routine_file;
@@ -113,11 +113,13 @@
'-_./~='
;
-## This is an alias for a commonly-used function
-*dbref = \&Vend::Data::database_exists_ref;
-
## This is a character class for HTML::Entities
$ESCAPE_CHARS::std = "^\n\t !\#\$%\'-;=?-Z\\\]-~";
+
+## Some standard error templates
+
+## This is an alias for a commonly-used function
+*dbref = \&Vend::Data::database_exists_ref;
my $need_escape;
2.30 +108 -46 interchange/lib/Vend/Table/Common.pm
rev 2.30, prev_rev 2.29
Index: Common.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/Common.pm,v
retrieving revision 2.29
retrieving revision 2.30
diff -u -r2.29 -r2.30
--- Common.pm 6 Jul 2003 04:38:28 -0000 2.29
+++ Common.pm 12 Jul 2003 04:47:10 -0000 2.30
@@ -1,6 +1,6 @@
# Vend::Table::Common - Common access methods for Interchange databases
#
-# $Id: Common.pm,v 2.29 2003/07/06 04:38:28 mheins Exp $
+# $Id: Common.pm,v 2.30 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -23,7 +23,7 @@
# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
-$VERSION = substr(q$Revision: 2.29 $, 10);
+$VERSION = substr(q$Revision: 2.30 $, 10);
use strict;
package Vend::Table::Common;
@@ -100,8 +100,13 @@
#::logDebug("set KEY_INDEX to $i: " . ::uneval($config));
}
- die("Cannot find key column $config->{KEY} in $config->{name} ($config->{file}): $!")
- unless defined $config->{KEY_INDEX};
+ die errmsg(
+ "Cannot find key column %s in %s (%s): %s",
+ $config->{KEY},
+ $config->{name},
+ $config->{file},
+ $!,
+ ) unless defined $config->{KEY_INDEX};
return $column_index;
}
@@ -195,7 +200,7 @@
#::logDebug("closing table $s->[$FILENAME]");
undef $s->[$DBM];
untie %{$s->[$TIE_HASH]}
- or die "Could not close DBM table $s->[$FILENAME]: $!\n";
+ or $s->log_error("%s %s: %s", errmsg("untie"), $s->[$FILENAME], $!);
undef $s->[$TIE_HASH];
#::logDebug("closed table $s->[$FILENAME], self=" . ::uneval($s));
}
@@ -233,7 +238,11 @@
my ($s, $column) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
my $i = $s->[$COLUMN_INDEX]{$column};
- die "There is no column named '$column' in $s->[$FILENAME]" unless defined $i;
+ die $s->log_error(
+ "There is no column named '%s' in %s",
+ $column,
+ $s->[$FILENAME],
+ ) unless defined $i;
return $i;
}
@@ -242,8 +251,6 @@
sub record_exists {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
- # guess what? The GDBM "exists" function got renamed to "EXISTS"
- # in 5.002.
my $r = $s->[$DBM]->EXISTS("k$key");
return $r;
}
@@ -266,8 +273,11 @@
sub unstuff_row {
my ($s, $key) = @_;
my $line = $s->[$TIE_HASH]{"k$key"};
- die "There is no row with index '$key' in database $s->[$FILENAME]"
- unless defined $line;
+ die $s->log_error(
+ "There is no row with index '%s' in database %s",
+ $key,
+ $s->[$FILENAME],
+ ) unless defined $line;
return map(unstuff($_), split(/\t/, $line, 9999))
unless $s->[$CONFIG]{FILTER_FROM};
my @f = map(unstuff($_), split(/\t/, $line, 9999));
@@ -278,7 +288,8 @@
sub thaw_row {
my ($s, $key) = @_;
my $line = $s->[$TIE_HASH]{"k$key"};
- die "There is no row with index '$key'" unless defined $line;
+ die $s->log_error( "There is no row with index '%s'", $key,)
+ unless defined $line;
return (@{ Storable::thaw($line) })
unless $s->[$CONFIG]{FILTER_FROM};
#::logDebug("filtering.");
@@ -340,7 +351,7 @@
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
if($s->[$CONFIG]{Read_only}) {
- ::logError(
+ $s->log_error(
"Attempt to set slice of %s in read-only table %s",
$key,
$s->[$CONFIG]{name},
@@ -375,7 +386,7 @@
$key = $s->set_row(@current);
length($key) or
- ::logError(
+ $s->log_error(
"Did set_slice with empty key on table %s",
$s->[$CONFIG]{name},
);
@@ -476,7 +487,10 @@
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to set $s->[$CONFIG]{name}::${column}::$key in read-only table");
+ $s->log_error(
+ "Attempt to write %s in read-only table",
+ "$s->[$CONFIG]{name}::${column}::$key",
+ );
return undef;
}
my @row;
@@ -497,7 +511,10 @@
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
my($value);
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to set $s->[$CONFIG]{name}::${column}::$key in read-only table");
+ $s->log_error(
+ "Attempt to write %s in read-only table",
+ "$s->[$CONFIG]{name}::${column}::$key",
+ );
return undef;
}
my @row = $s->row($key);
@@ -640,7 +657,11 @@
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to delete row '$key' in read-only table $s->[$CONFIG]{name}");
+ $s->log_error(
+ "Attempt to delete row '$key' in read-only table %s",
+ $key,
+ $s->[$CONFIG]{name},
+ );
return undef;
}
@@ -715,20 +736,18 @@
($spec, $stmt) = Vend::Scan::sql_statement($query, $opt);
};
if($@) {
- my $msg = ::errmsg("SQL query failed: %s\nquery was: %s", $@, $query);
+ my $msg = errmsg("SQL query failed: %s\nquery was: %s", $@, $query);
+ $s->log_error($msg);
Carp::croak($msg) if $Vend::Try;
- ::logError($msg);
return ($opt->{failure} || undef);
}
my @additions = grep length($_) == 2, keys %$opt;
- if(@additions) {
- @{$spec}{@additions} = @{$opt}{@additions};
+ for(@additions) {
+ next unless length $opt->{$_};
+ $spec->{$_} = $opt->{$_};
}
}
- my @tabs = @{$spec->{fi}};
- for (@tabs) {
- s/\..*//;
- }
+ my @tabs = @{$spec->{rt} || $spec->{fi}};
my $reroute;
my $tname = $s->[$CONFIG]{name};
@@ -742,10 +761,11 @@
}
if($reroute) {
- unless ($s = $Vend::Database{$tabs[0]}) {
- ::logError("Table %s not found in databases", $tabs[0]);
+ unless ($reroute = $Vend::Database{$tabs[0]}) {
+ $s->log_error("Table %s not found in databases", $tabs[0]);
return $opt->{failure} || undef;
}
+ $s = $reroute;
#::logDebug("rerouting to $tabs[0]");
$opt->{STATEMENT} = $stmt;
$opt->{SPEC} = $spec;
@@ -757,7 +777,11 @@
my @vals;
if($stmt->command() ne 'SELECT') {
if(defined $s and $s->[$CONFIG]{Read_only}) {
- die ("Attempt to write read-only database $s->[$CONFIG]{name}");
+ $s->log_error(
+ "Attempt to write read-only table %s",
+ $s->[$CONFIG]{name},
+ );
+ return undef;
}
$update = $stmt->command();
@vals = $stmt->row_values();
@@ -767,6 +791,7 @@
@na = @{$spec->{rf}} if $spec->{rf};
+#::logDebug("spec->{ml}=$spec->{ml} opt->{ml}=$opt->{ml}");
$spec->{ml} = $opt->{ml} if $opt->{ml};
$spec->{ml} ||= '1000';
$spec->{fn} = [$s->columns];
@@ -865,7 +890,12 @@
#::logDebug("ref returned: " . substr(Vend::Util::uneval($ref), 0, 100));
#::logDebug("opt is: " . Vend::Util::uneval($opt));
if($@) {
- ::logError("MVSQL query failed for $opt->{table}: $@\nquery was: $query");
+ $s->log_error(
+ "MVSQL query failed for %s: %s\nquery was: %s",
+ $opt->{table},
+ $@,
+ $query,
+ );
$return = $opt->{failure} || undef;
}
@@ -939,13 +969,13 @@
if(! defined $realfile) {
open(IN, "+<$infile")
- or die ::errmsg("Couldn't open '%s' read/write: %s", $infile, $!);
+ or die errmsg("%s %s: %s\n", errmsg("open read/write"), $infile, $!);
lockfile(\*IN, 1, 1)
- or die ::errmsg("lock '%s': %s", $infile, $!);
+ or die errmsg("%s %s: %s\n", errmsg("lock"), $infile, $!);
}
else {
open(IN, "<$infile")
- or die ::errmsg("Couldn't open '%s' for read: %s", $infile, $!);
+ or die errmsg("%s %s: %s\n", errmsg("open"), $infile, $!);
}
my $field_hash;
@@ -1113,8 +1143,8 @@
for($i = 0; $i < @i; $i++) {
my $fnum = $i[$i];
$fh = new IO::File "> $infile.$i[$i]";
- die "Couldn't create $infile.$i[$i]: $!\n"
- unless defined $fh;
+ die errmsg("%s %s: %s\n", errmsg("create"), "$infile.$i[$i]",
+ $!) unless defined $fh;
eval {
unlink "$infile.$n[$i]" if -l "$infile.$n[$i]";
symlink "$infile.$i[$i]", "$infile.$n[$i]";
@@ -1273,26 +1303,22 @@
);
eval $format{$format};
- die ::errmsg("$options->{name} import failed: %s", $@) if $@;
+ die errmsg("%s import failed: %s", $options->{name}, $@) if $@;
if($realfile) {
close IN
- or die ::errmsg("close preload file %s: %s", $infile, $!) . "\n";
+ or die errmsg("%s %s: %s\n", errmsg("close"), $infile, $!);
if(-f $realfile) {
open(IN, "+<$realfile")
- or die ::errmsg(
- "Couldn't open user file %s read/write: %s",
- $realfile,
- $!) . "\n";
- lockfile(\*IN, 1, 1) or die "lock\n";
+ or die
+ errmsg("%s %s: %s\n", errmsg("open read/write"), $realfile, $!);
+ lockfile(\*IN, 1, 1)
+ or die errmsg("%s %s: %s\n", errmsg("lock"), $realfile, $!);
<IN>;
eval $format{$format};
- die ::errmsg("%s import failed: %s", $options->{name}, $@) if $@;
+ die errmsg("%s %s: %s\n", errmsg("import"), $options->{name}, $!) if $@;
}
elsif (! open(IN, ">$realfile") ) {
- warn ::errmsg(
- "can't create %s import failed: %s",
- $options->{file}, $@
- );
+ die errmsg("%s %s: %s\n", errmsg("create"), $realfile, $!);
}
else {
print IN join($options->{DELIMITER}, @field_names);
@@ -1402,7 +1428,7 @@
};
if($@) {
- die ::errmsg(
+ die errmsg(
"Problem with mirror import from source %s to target %s\n",
$tname,
$table_name,
@@ -1463,6 +1489,42 @@
sub reset {
undef $restrict;
+}
+
+sub errstr {
+ return shift(@_)->[$CONFIG]{last_error};
+}
+
+sub log_error {
+ my ($s, $tpl, @args) = @_;
+ if($tpl =~ /^(prepare|execute)$/) {
+ if(!@args) {
+ $tpl = "Statement $tpl failed: %s";
+ }
+ elsif (@args == 1) {
+ $tpl = "Statement $tpl failed: %s\nQuery was: %s";
+ }
+ else {
+ $tpl = "Statement $tpl failed: %s\nQuery was: %s";
+ $tpl .= "\nAdditional: %s" for (2 .. scalar(@args));
+ }
+ unshift @args, $DBI::errstr;
+ }
+ my $msg = errmsg($tpl, @args);
+ my $ekey = 'table ' . $s->[$CONFIG]{name};
+ my $cfg = $s->[$CONFIG];
+ unless(defined $cfg->{LOG_CATALOG} and ! $cfg->{LOG_CATALOG}) {
+ logError($msg);
+ }
+ if($cfg->{LOG_GLOBAL}) {
+ logGlobal($msg);
+ }
+ if($Vend::admin or ! defined($cfg->{LOG_SESSION}) or $cfg->{LOG_SESSION}) {
+ $Vend::Session->{errors} = {} unless ref($Vend::Session->{errors}) eq 'HASH';
+ $Vend::Session->{errors}{$ekey} = $msg;
+ }
+ die $msg if $cfg->{DIE_ERROR};
+ return $cfg->{last_error} = $msg;
}
1;
2.50 +134 -120 interchange/lib/Vend/Table/DBI.pm
rev 2.50, prev_rev 2.49
Index: DBI.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/DBI.pm,v
retrieving revision 2.49
retrieving revision 2.50
diff -u -r2.49 -r2.50
--- DBI.pm 6 Jul 2003 04:38:28 -0000 2.49
+++ DBI.pm 12 Jul 2003 04:47:10 -0000 2.50
@@ -1,6 +1,6 @@
# Vend::Table::DBI - Access a table stored in an DBI/DBD database
#
-# $Id: DBI.pm,v 2.49 2003/07/06 04:38:28 mheins Exp $
+# $Id: DBI.pm,v 2.50 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -21,7 +21,7 @@
# MA 02111-1307 USA.
package Vend::Table::DBI;
-$VERSION = substr(q$Revision: 2.49 $, 10);
+$VERSION = substr(q$Revision: 2.50 $, 10);
use strict;
@@ -323,7 +323,7 @@
|| $DBI::errstr
|| "unknown error. Driver '$dname' installed?";
}
- die "connect failed (create) -- $msg\n";
+ die ::errstr("connect failed (create) -- %s\n",$msg);
}
# Allow multiple tables in different DBs to have same local name
@@ -337,8 +337,11 @@
check_capability($config, $db->{Driver}{Name});
- die "columns argument $columns is not an array ref\n"
- unless CORE::ref($columns) eq 'ARRAY';
+ die ::errmsg(
+ "table %s: columns argument %s is not an array ref\n",
+ $config->{name},
+ $columns,
+ ) unless CORE::ref($columns) eq 'ARRAY';
if(defined $dattr) {
for(keys %$dattr) {
@@ -593,7 +596,7 @@
};
$msg = $@ || $DBI::errstr || "unknown error. Driver '$dname' installed?";
}
- die "connect failed -- $msg\n";
+ die ::errmsg("table %s connect failed -- %s\n", $tablename, $msg);
}
}
$DBI_connect_bad{$config->{dsn_id}} = 0;
@@ -605,6 +608,8 @@
}
}
+ die ::errmsg("%s: %s", $tablename, $DBI::errstr) unless $db;
+
# Allow multiple tables in different DBs to have same local name
$tablename = $config->{REAL_NAME}
if $config->{REAL_NAME};
@@ -621,8 +626,6 @@
}
#::logDebug("connect count open: " . $DBI_connect_count{$config->{dsn_id}});
- die "$tablename: $DBI::errstr" unless $db;
-
if($config->{HANDLE_ONLY}) {
return bless [$config, $tablename, undef, undef, undef, $db], $class;
}
@@ -661,7 +664,7 @@
- die "DBI: no column names returned for $tablename\n"
+ die ::errmsg("DBI: no column names returned for %s\n", $tablename)
unless defined $config->{NAME}[0];
# Check if we have a non-first-column key
@@ -806,15 +809,21 @@
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
$column = $s->[$NAME][ $s->column_index($column) ];
- $key = $s->[$DBI]->quote($key)
- unless exists $s->[$CONFIG]{NUMERIC}{$s->[$KEY]};
- my $sth = $s->[$DBI]->prepare(
- "select $column from $s->[$TABLE] where $s->[$KEY] = $key");
- die "inc_field: $DBI::errstr\n" unless defined $sth;
- $sth->execute();
- $value += ($sth->fetchrow_array)[0];
- #$value = $s->[$DBI]->quote($value, $column);
- $sth = $s->[$DBI]->do("update $s->[$TABLE] SET $column=$value where $s->[$KEY] = $key");
+ my $q1 = "select $column from $s->[$TABLE] where $s->[$KEY] = ?";
+ my $q2 = "update $s->[$TABLE] set $column = ? where $s->[$KEY] = ?";
+ my $sth1 = $s->[$DBI]->prepare($q1)
+ or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $DBI::errstr)
+ and return undef;
+ my $sth2 = $s->[$DBI]->prepare($q2)
+ or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q2, $DBI::errstr)
+ and return undef;
+ $sth1->execute($key)
+ or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $DBI::errstr)
+ and return undef;
+ $value += ($sth1->fetchrow_array)[0];
+ $sth2->execute($value, $key)
+ or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q2, $DBI::errstr)
+ and return undef;
$value;
}
@@ -825,26 +834,19 @@
# This is pretty harmless, no?
return undef if ! defined $s->[$DBI];
unless ($s->[$CONFIG]{HAS_TRANSACTIONS}) {
- ::logError(
- "commit attempted on non-transaction database, returning success"
+ $s->log_error(
+ "commit attempted on non-transaction database %s, returning success",
+ $s->[$TABLE],
);
return 1;
}
-# if (! defined $s->[$DBI]) {
-# ::logError(
-# "commit attempted on non-open database handle for table: %s",
-# $s->[$TABLE],
-# );
-# return undef;
-# }
-
my $status;
eval {
$status = $s->[$DBI]->commit();
};
if($@) {
- ::logError("%s commit failed: %s", $s->[$TABLE], $@);
+ $s->log_error("%s commit failed: %s", $s->[$TABLE], $@);
}
return $status;
}
@@ -856,13 +858,13 @@
# This is pretty harmless, no?
return undef if ! defined $s->[$DBI];
-# if (! defined $s->[$DBI]) {
-# ::logError(
-# "rollback attempted on non-open database handle for table: %s",
-# $s->[$TABLE],
-# );
-# return undef;
-# }
+ unless ($s->[$CONFIG]{HAS_TRANSACTIONS}) {
+ $s->log_error(
+ "rollback attempted on non-transaction database %s, returning failure",
+ $s->[$TABLE],
+ );
+ return undef;
+ }
return $s->[$DBI]->rollback();
}
@@ -889,7 +891,8 @@
$column = $s->[$NAME][ $s->column_index($column) ];
my $q = "select $column from $s->[$TABLE] where $s->[$KEY] = ?";
my $sth = $s->[$DBI]->prepare($q)
- or die "field_accessor statement ($q) -- bad result.\n";
+ or $s->log_error("field_accessor statement (%s) -- bad result.", $q)
+ and return undef;
#::logDebug("binding sub to $q");
return sub {
my ($key) = @_;
@@ -978,29 +981,19 @@
$function = 'ALTER_CHANGE' unless $function;
my $template = $s->config($function);
if(! $template) {
- ::logError(
- $s->config(
- 'last_error',
- ::errmsg(
+ $s->log_error(
"No %s template defined for table %s. Skipping.",
$function,
$s->[$TABLE],
- ),
- ),
);
return undef;
}
if($function =~ /^(ALTER_CHANGE)$/ and ! $s->column_exists($column) ) {
- ::logError(
- $s->config(
- 'last_error',
- ::errmsg(
+ $s->log_error(
"Column '%s' doesn't exist in table %s. Skipping.",
$column,
$s->[$TABLE],
- ),
- ),
);
return undef;
}
@@ -1020,15 +1013,7 @@
};
if($@) {
- ::logError(
- $s->config(
- 'last_error',
- ::errmsg(
- "'%s' failed. Error: %s",
- $template,
- ),
- ),
- );
+ $s->log_error( "'%s' failed. Error: %s", $template,);
return undef;
}
@@ -1087,8 +1072,8 @@
my $olen;
my $errout;
- if( $action =~ /^truncate(?:_(\w+))$/i) {
- $errout = lc $1;
+ if( $action =~ /^truncate(?:_(\w+))?$/i) {
+ $errout = lc $1 || 'log';
$olen = length($data);
$data = substr($data,0,$slen);
}
@@ -1129,6 +1114,8 @@
::logError($msg1);
::logError($msg2);
}
+ Vend::Interpolate::push_warning($msg1);
+ Vend::Interpolate::push_warning($msg2);
}
return $data;
}
@@ -1165,7 +1152,7 @@
if($@) {
my $msg = $@;
- ::logError("failed %s::%s routine: %s", __PACKAGE__, 'get_slice', $msg);
+ $s->log_error("failed %s::%s routine: %s", __PACKAGE__, 'get_slice', $msg);
return undef;
}
@@ -1177,7 +1164,7 @@
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
- ::logError(
+ $s->log_error(
"Attempt to set slice of %s in read-only table %s",
$key,
$s->[$CONFIG]{name},
@@ -1210,7 +1197,8 @@
if($s->[$CONFIG]->{LENGTH_EXCEPTION_DEFAULT}) {
my $lcfg = $s->[$CONFIG]{FIELD_LENGTH_DATA}
- or die "No field length data!";
+ or $s->log_error("No field length data with LENGTH_EXCEPTION defined!")
+ and return undef;
for (my $i=0; $i < @$fary; $i++){
next unless defined $lcfg->{$fary->[$i]};
@@ -1266,14 +1254,14 @@
if($@) {
my $caller = caller();
- ::logGlobal(
+ $s->log_error(
"%s error as called by %s: %s\nquery was:%s\nvalues were:'%s'",
'set_slice',
$caller,
$@,
$sql,
join("','", @$vary),
- );
+ );
return undef;
}
@@ -1335,7 +1323,18 @@
if $s->record_exists();
$s->[$DBI]->do("insert into $s->[$TABLE] ($key_string) VALUES ($val_string)");
};
- die "$DBI::errstr\n" if $@;
+ if($@) {
+ my $caller = caller();
+ $s->log_error(
+ "%s error as called by %s: %s\nfields=%s\nvalues=%s",
+ 'set_row',
+ $caller,
+ $@,
+ $key_string,
+ $val_string,
+ );
+ return undef;
+ }
return $fields[0];
}
@@ -1366,15 +1365,20 @@
my $ins_string = join ", ", @ins_mark;
my $query = "INSERT INTO $s->[$TABLE]$fstring VALUES ($ins_string)";
#::logDebug("set_row query=$query");
- $cfg->{_Insert_h} = $s->[$DBI]->prepare($query);
- die "$DBI::errstr\n" if ! defined $cfg->{_Insert_h};
+ $cfg->{_Insert_h} = $s->[$DBI]->prepare($query)
+ or die $s->log_error(
+ "%s error on %s: $DBI::errstr",
+ 'set_row',
+ $query,
+ $DBI::errstr,
+ );
}
#::logDebug("set_row fields='" . join(',', @fields) . "'" );
$s->bind_entire_row($cfg->{_Insert_h}, @fields);
my $rc = $cfg->{_Insert_h}->execute()
- or die "$DBI::errstr\n";
+ or die $s->log_error("%s error: $DBI::errstr", 'set_row', $DBI::errstr);
$val = $cfg->{AUTO_SEQUENCE}
? $s->last_sequence_value($fields[$ki])
@@ -1416,25 +1420,26 @@
sub row {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
- $key = $s->[$DBI]->quote($key)
- unless exists $s->[$CONFIG]{NUMERIC}{$s->[$KEY]};
- my $sth = $s->[$DBI]->prepare(
- "select * from $s->[$TABLE] where $s->[$KEY] = $key");
- $sth->execute()
- or die("execute error: $DBI::errstr");
-
+ my $q = "select * from $s->[$TABLE] where $s->[$KEY] = ?";
+ my $sth = $s->[$DBI]->prepare($q)
+ or $s->log_error("%s prepare error for %s: %s", 'row', $q, $DBI::errstr)
+ and return undef;
+ $sth->execute($key)
+ or $s->log_error("%s execute error for %s: %s", 'row', $q, $DBI::errstr)
+ and return undef;
return @{$sth->fetchrow_arrayref()};
}
sub row_hash {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
- $key = $s->[$DBI]->quote($key)
- unless exists $s->[$CONFIG]{NUMERIC}{$s->[$KEY]};
- my $sth = $s->[$DBI]->prepare(
- "select * from $s->[$TABLE] where $s->[$KEY] = $key");
- $sth->execute()
- or die("execute error: $DBI::errstr");
+ my $q = "select * from $s->[$TABLE] where $s->[$KEY] = ?";
+ my $sth = $s->[$DBI]->prepare($q)
+ or $s->log_error("%s prepare error for %s: %s", 'row_hash', $q, $DBI::errstr)
+ and return undef;
+ $sth->execute($key)
+ or $s->log_error("%s execute error for %s: %s", 'row_hash', $q, $DBI::errstr)
+ and return undef;
return $sth->fetchrow_hashref()
unless $s->[$TYPE];
@@ -1464,7 +1469,8 @@
$s = $s->import_db() if ! defined $s->[$DBI];
my $q = "update $s->[$TABLE] SET $column = ? where $s->[$KEY] = ?";
my $sth = $s->[$DBI]->prepare($q)
- or Carp::croak errmsg("Unable to prepare query for field_settor: %s", $q);
+ or $s->log_error("Unable to prepare query for field_settor: %s", $q)
+ and return undef;
return sub {
my ($key, $value) = @_;
$sth->execute($value, $key);
@@ -1519,7 +1525,7 @@
}
}
else {
- ::logError("Bad single data query parameter type: %s", ref($qhash));
+ $s->log_error("Bad single data query parameter type: %s", ref($qhash));
return undef;
}
@@ -1562,7 +1568,7 @@
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to set %s in read-only table",
+ $s->log_error("Attempt to set %s in read-only table",
"$s->[$CONFIG]{name}::${column}::$key",
);
return undef;
@@ -1588,29 +1594,32 @@
my $rawkey = $key;
my $rawval = $value;
- $key = $s->quote($key, $s->[$KEY]);
- $value = $s->quote($value, $column);
-
- my $query;
+ my $q;
if(! $s->record_exists($rawkey)) {
if( $s->[$CONFIG]{AUTO_SEQUENCE} ) {
$key = 0 if ! $key;
- $query = qq{
- INSERT INTO $s->[$TABLE]
- ($s->[$KEY], $column)
- VALUES ($key, $value)
- };
+ $q = qq{INSERT INTO $s->[$TABLE] ($s->[$KEY], $column) VALUES (?,?)};
}
else {
#::logDebug("creating key '$rawkey' in table $s->[$TABLE]");
- $s->set_row($rawkey);
+ $s->set_row($$key);
}
+ }
+
+ my @args;
+ if(!$q) {
+ $q = qq{update $s->[$TABLE] SET $column = ? where $s->[$KEY] = ?};
+ @args = ($value, $key);
+ }
+ else {
+ @args = ($key, $key);
}
- $query = <<EOF unless $query;
-update $s->[$TABLE] SET $column = $value where $s->[$KEY] = $key
-EOF
- $s->[$DBI]->do($query)
- or die "$DBI::errstr\n";
+ my $sth = $s->[$DBI]->prepare($q)
+ or $s->log_error("%s prepare error for %s: %s", 'set_field', $q, $DBI::errstr)
+ and return undef;
+ $sth->execute(@args)
+ or $s->log_error("%s execute error for %s: %s", 'set_field', $q, $DBI::errstr)
+ and return undef;
return $rawval;
}
@@ -1651,7 +1660,7 @@
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to delete record '%s' from read-only database %s",
+ $s->log_error("Attempt to delete record '%s' from read-only database %s",
$key,
$s->[$CONFIG]{name},
);
@@ -1724,10 +1733,11 @@
my $q = "select * from $name";
$q .= " limit 1" if $config->{HAS_LIMIT};
my $sth = $db->prepare($q)
- or die $DBI::errstr;
+ or die ::errmsg("%s prepare on %s: %s", 'list_fields', $name, $DBI::errstr);
# Wish we didn't have to do this, but we cache the columns
- $sth->execute() or die "$DBI::errstr\n";
+ $sth->execute()
+ or die ::errmsg("%s execute on %s: %s", 'list_fields', $name, $DBI::errstr);
if($config and $config->{NAME_REQUIRES_FETCH}) {
$sth->fetch();
@@ -1779,8 +1789,9 @@
if $s->[$CONFIG]{Export_order};
($table, $db, $each) = @{$s}[$TABLE,$DBI,$EACH];
my $query = $db->prepare("select * from $table $qual")
- or die $DBI::errstr;
- $query->execute();
+ or die $s->log_error('prepare');
+ $query->execute()
+ or die $s->log_error('execute');
my $idx = $s->[$CONFIG]{KEY_INDEX};
$each = sub {
my $ref = $query->fetchrow_arrayref()
@@ -1821,8 +1832,9 @@
$qual .= "$rfield = '$Vend::Session->{$rsession}'";
}
my $query = $db->prepare("select * from $table " . ($qual || '') )
- or die $DBI::errstr;
- $query->execute();
+ or die $s->log_error('prepare');
+ $query->execute()
+ or die $s->log_error('execute');
my $idx = $s->[$CONFIG]{KEY_INDEX};
$each = sub {
my $ref = $query->fetchrow_arrayref()
@@ -1907,17 +1919,16 @@
eval {
if($update and $s->[$CONFIG]{Read_only}) {
- my $msg = ::errmsg(
+ $s->log_error(
"Attempt to do update on read-only table.\nquery: %s",
$query,
);
- ::logError($msg);
- die "$msg\n";
+ return undef;
}
$opt->{row_count} = 1 if $update;
- $sth = $db->prepare($query) or die $DBI::errstr;
+ $sth = $db->prepare($query) or die $s->log_error('prepare', $query);
#::logDebug("Query prepared OK. sth=$sth");
- $rc = $sth->execute() or die $DBI::errstr;
+ $rc = $sth->execute() or die $s->log_error('execute', $query);
#::logDebug("Query executed OK. rc=" . (defined $rc ? $rc : 'undef'));
if ($update) {
@@ -1932,7 +1943,7 @@
}
push @ary, $rowhashref;
}
- die $DBI::errstr if $sth->err();
+ die $s->log_error($DBI::errstr) if $sth->err();
$ref = $Vend::Interpolate::Tmp->{$opt->{hashref}} = \@ary;
}
else {
@@ -1941,7 +1952,7 @@
%nh = map { (lc $_, $i++) } @na;
$ref = $Vend::Interpolate::Tmp->{$opt->{arrayref}}
= $sth->fetchall_arrayref()
- or die $DBI::errstr;
+ or die $s->log_error($DBI::errstr);
}
};
if($@) {
@@ -1965,8 +1976,8 @@
$@,
$query,
);
+ $s->log_error($msg);
Carp::croak($msg) if $Vend::Try;
- ::logError($msg);
return undef;
}
if($newdb) {
@@ -1977,15 +1988,15 @@
qq{Unable to find base table in query: %s},
$query,
);
+ $s->log_error($msg);
Carp::croak($msg) if $Vend::Try;
- ::logError($msg);
return undef;
}
}
else {
my $msg = ::errmsg("SQL query failed: %s\nquery was: %s", $@, $query);
+ $s->log_error($msg);
Carp::croak($msg) if $Vend::Try;
- ::logError($msg);
return undef;
}
}
@@ -1999,7 +2010,7 @@
}
if (! defined $s || $tabs[0] ne $s->[$CONFIG]{name}) {
unless ($s = $Vend::Database{$tabs[0]}) {
- ::logError("Table %s not found in databases", $tabs[0]);
+ $s->log_error("Table %s not found in databases", $tabs[0]);
return $opt->{failure} || undef;
}
#::logDebug("rerouting to $tabs[0]");
@@ -2012,7 +2023,8 @@
if($stmt->command() ne 'SELECT') {
if(defined $s and $s->[$CONFIG]{Read_only}) {
- die ("Attempt to write read-only database $s->[$CONFIG]{name}");
+ $s->log_error("Attempt to write read-only database $s->[$CONFIG]{name}");
+ return undef;
}
$update = $stmt->command();
}
@@ -2057,7 +2069,7 @@
#::logDebug("ref returned: " . Vend::Util::uneval($ref));
#::logDebug("opt is: " . Vend::Util::uneval($opt));
if($@) {
- ::logError("SQL query failed for %s: %s\nQuery was: %s",
+ $s->log_error("SQL query failed for %s: %s\nQuery was: %s",
$s->[$TABLE],
$@,
$query,
@@ -2134,6 +2146,8 @@
*reset = \&Vend::Table::Common::reset;
*autonumber = \&Vend::Table::Common::autonumber;
+*log_error = \&Vend::Table::Common::log_error;
+*errstr = \&Vend::Table::Common::errstr;
1;
2.8 +4 -11 interchange/lib/Vend/Table/DB_File.pm
rev 2.8, prev_rev 2.7
Index: DB_File.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/DB_File.pm,v
retrieving revision 2.7
retrieving revision 2.8
diff -u -r2.7 -r2.8
--- DB_File.pm 6 Jul 2003 17:06:10 -0000 2.7
+++ DB_File.pm 12 Jul 2003 04:47:10 -0000 2.8
@@ -1,6 +1,6 @@
# Vend::Table::DB_File - Access an Interchange table stored in a DB file hash
#
-# $Id: DB_File.pm,v 2.7 2003/07/06 17:06:10 mheins Exp $
+# $Id: DB_File.pm,v 2.8 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -31,7 +31,7 @@
use Vend::Table::Common;
@ISA = qw(Vend::Table::Common);
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
sub create {
my ($class, $config, $columns, $filename) = @_;
@@ -39,23 +39,16 @@
$config = {} unless defined $config;
my $File_permission_mode = $config->{File_permission_mode} || 0666;
- die "columns argument $columns is not an array ref\n"
+ die ::errmsg("columns argument %s is not an array ref", $columns)
unless CORE::ref($columns) eq 'ARRAY';
- # my $column_file = "$filename.columns";
- # my @columns = @$columns;
- # open(COLUMNS, ">$column_file")
- # or die "Couldn't create '$column_file': $!";
- # print COLUMNS join("\t", @columns), "\n";
- # close(COLUMNS);
-
my $column_index = Vend::Table::Common::create_columns($columns, $config);
my $tie = {};
my $flags = O_RDWR | O_CREAT;
my $dbm = tie(%$tie, 'DB_File', $filename, $flags, $File_permission_mode)
- or die "Could not create '$filename': $!";
+ or die errmsg("%s %s: %s\n", errmsg("create"), $filename, $!);
$tie->{'c'} = join("\t", @$columns);
2.8 +4 -11 interchange/lib/Vend/Table/GDBM.pm
rev 2.8, prev_rev 2.7
Index: GDBM.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/GDBM.pm,v
retrieving revision 2.7
retrieving revision 2.8
diff -u -r2.7 -r2.8
--- GDBM.pm 6 Jul 2003 17:06:10 -0000 2.7
+++ GDBM.pm 12 Jul 2003 04:47:10 -0000 2.8
@@ -1,6 +1,6 @@
# Vend::Table::GDBM - Access an Interchange table stored in a GDBM file
#
-# $Id: GDBM.pm,v 2.7 2003/07/06 17:06:10 mheins Exp $
+# $Id: GDBM.pm,v 2.8 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -30,7 +30,7 @@
use Vend::Table::Common;
@ISA = qw(Vend::Table::Common);
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
sub new {
my ($class, $obj) = @_;
@@ -46,23 +46,16 @@
$File_permission_mode = 0666 unless defined $File_permission_mode;
$Fast_write = 1 unless defined $Fast_write;
- die "columns argument $columns is not an array ref\n"
+ die ::errmsg("columns argument %s is not an array ref", $columns)
unless CORE::ref($columns) eq 'ARRAY';
- # my $column_file = "$filename.columns";
- # my @columns = @$columns;
- # open(COLUMNS, ">$column_file")
- # or die "Couldn't create '$column_file': $!";
- # print COLUMNS join("\t", @columns), "\n";
- # close(COLUMNS);
-
my $column_index = Vend::Table::Common::create_columns($columns, $config);
my $tie = {};
my $flags = GDBM_NEWDB;
$flags |= GDBM_FAST if $Fast_write;
my $dbm = tie(%$tie, 'GDBM_File', $filename, $flags, $File_permission_mode)
- or die "Could not create '$filename': $!";
+ or die errmsg("%s %s: %s\n", errmsg("create"), $filename, $!);
$tie->{'c'} = join("\t", @$columns);
2.11 +8 -4 interchange/lib/Vend/Table/InMemory.pm
rev 2.11, prev_rev 2.10
Index: InMemory.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/InMemory.pm,v
retrieving revision 2.10
retrieving revision 2.11
diff -u -r2.10 -r2.11
--- InMemory.pm 18 Jun 2003 17:34:46 -0000 2.10
+++ InMemory.pm 12 Jul 2003 04:47:10 -0000 2.11
@@ -1,6 +1,6 @@
# Vend::Table::InMemory - Store an Interchange table in memory
#
-# $Id: InMemory.pm,v 2.10 2003/06/18 17:34:46 jon Exp $
+# $Id: InMemory.pm,v 2.11 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -26,7 +26,7 @@
package Vend::Table::InMemory;
use Vend::Table::Common qw(!config !columns);
@ISA = qw/Vend::Table::Common/;
-$VERSION = substr(q$Revision: 2.10 $, 10);
+$VERSION = substr(q$Revision: 2.11 $, 10);
use strict;
# 0: column names
@@ -71,7 +71,7 @@
undef $config->{Transactions};
- die "columns argument $columns is not an array ref\n"
+ die ::errmsg("columns argument %s is not an array ref", $columns)
unless CORE::ref($columns) eq 'ARRAY';
my $column_index = Vend::Table::Common::create_columns($columns, $config);
@@ -106,7 +106,11 @@
sub row {
my ($s, $key) = @_;
my $a = $s->[$TIE_HASH]{$key};
- die "There is no row with index '$key'" unless defined $a;
+ die $s->log_error(
+ "There is no row with index '%s' in database %s",
+ $key,
+ $s->[$FILENAME],
+ ) unless defined $a;
return @$a;
}
2.8 +63 -28 interchange/lib/Vend/Table/LDAP.pm
rev 2.8, prev_rev 2.7
Index: LDAP.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/LDAP.pm,v
retrieving revision 2.7
retrieving revision 2.8
diff -u -r2.7 -r2.8
--- LDAP.pm 18 Jun 2003 17:34:46 -0000 2.7
+++ LDAP.pm 12 Jul 2003 04:47:10 -0000 2.8
@@ -1,6 +1,6 @@
# Vend::Table::LDAP - Interchange LDAP pseudo-table access
#
-# $Id: LDAP.pm,v 2.7 2003/06/18 17:34:46 jon Exp $
+# $Id: LDAP.pm,v 2.8 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -25,7 +25,7 @@
package Vend::Table::LDAP;
@ISA = qw/Vend::Table::Common/;
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
use strict;
use vars qw(
@@ -100,7 +100,7 @@
$alt_index++;
redo DOCONNECT;
}
- die "Unable to connect to LDAP server $host:$port\n";
+ die ::errmsg("Unable to connect to LDAP server %s", $host:$port);
}
$ldap->bind(
dn => $config->{BIND_DN},
@@ -114,7 +114,7 @@
my $c = $m->count;
my $co = $m->code;
#::logDebug("count=$c code=$co");
-# die "Unable to find database $tablename count=$c code=$co)" unless ($m->count > 0);
+
my $e = $m->entry(0);
#::logDebug('after entry e=' . ::uneval($e));
$columns = $e->get('columns');
@@ -140,14 +140,16 @@
$config = {} unless defined $config;
- die "columns argument $columns is not an array ref\n"
+ die ::errmsg("columns argument %s is not an array ref", $columns)
unless CORE::ref($columns) eq 'ARRAY';
+
my $base = $config->{BASE_DN};
my $host = $config->{LDAP_HOST};
my $port = 389;
($host, $port) = split /:/, $host if ($host =~ /:/);
my $column_index = Vend::Table::Common::create_columns($columns, $config);
- my $ldap = Net::LDAP->new($host, port => $port) or die "Unable to connect to LDAP server $host:$port\n";
+ my $ldap = Net::LDAP->new($host, port => $port)
+ or die ::errmsg("Unable to connect to LDAP server %s", $host:$port);
#::logDebug("created object " . ::uneval($ldap));
$ldap->bind(
dn => $config->{BIND_DN},
@@ -195,7 +197,11 @@
base => "db=$n, $b",
filter => "(&(objectclass=mv_data)($ki=$key))",
);
- die "There is no row with index '$key'" unless ($m->count > 0);
+ die $s->log_error(
+ "There is no row with index '%s' in database %s",
+ $key,
+ $s->[$FILENAME],
+ ) unless ($m->count > 0);
my $e = $m->entry(0);
my $d = $e->get($column);
return (pop @$d);
@@ -221,7 +227,11 @@
base => "db=$n, $b",
filter => "(&(objectclass=mv_data)($ki=$key))",
);
- die "There is no row with index '$key'" unless ($m->count > 0);
+ die $s->log_error(
+ "There is no row with index '%s' in database %s",
+ $key,
+ $s->[$FILENAME],
+ ) unless ($m->count > 0);
my $e = $m->entry(0);
my %row;
my $c;
@@ -268,8 +278,13 @@
);
$code = $m->code;
}
- $code and die "Failed to set row $ki=$key: $code";
+ if($code) {
+ $s->log_error(
+ "Failed to set row %s=%s: %s",
+ $ki, $key, $s->[$FILENAME], $code,
+ );
return undef;
+ }
};
}
@@ -277,7 +292,7 @@
my ($s, $key, $fary, $vary) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
if($s->[$CONFIG]{Read_only}) {
- ::logError(
+ $s->log_error(
"Attempt to set %s in read-only table %s",
$key,
$s->[$CONFIG]{name},
@@ -295,7 +310,10 @@
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$TIE_HASH];
if($s->[$CONFIG]{Read_only}) {
- ::logError("Attempt to set $s->[$CONFIG]{name}::${column}::$key in read-only table");
+ $s->log_error(
+ "Attempt to write %s in read-only table",
+ "$s->[$CONFIG]{name}::${column}::$key",
+ );
return undef;
}
my %row;
@@ -324,7 +342,13 @@
);
$code = $m->code;
}
- $code and die "Failed to set row $ki=$key: $value errnum=$code errstr=" . $m->error() . "\n";;
+ if($code) {
+ $s->log_error(
+ "Failed to set row %s=%s: %s errnum=%s errstr=%s",
+ $ki, $key, $value, $code, $m->error(),
+ );
+ return undef;
+ }
$value;
}
@@ -367,8 +391,14 @@
);
$code = $m->code;
}
- $code and die "Failed to set row $ki=$key code=$code op=$op";
- $ki;
+ if($code) {
+ $s->log_error(
+ "Failed to set row %s=%s in %s, op=%s: %s",
+ $ki, $key, $s->[$FILENAME], $op, $code,
+ );
+ return undef;
+ }
+ return $ki;
}
sub inc_field {
@@ -522,8 +552,8 @@
};
if($@) {
my $msg = ::errmsg("SQL query failed: %s\nquery was: %s", $@, $query);
+ $s->log_error($msg);
Carp::croak($msg) if $Vend::Try;
- ::logError($msg);
return ($opt->{failure} || undef);
}
my @additions = grep length($_) == 2, keys %$opt;
@@ -531,26 +561,29 @@
@{$spec}{@additions} = @{$opt}{@additions};
}
}
- my @tabs = @{$spec->{fi}};
- for (@tabs) {
- s/\..*//;
- }
+ my @tabs = @{$spec->{rt} || $spec->{fi}};
+
if (! defined $s || $tabs[0] ne $s->[$CONFIG]{name}) {
- unless ($s = $Vend::Database{$tabs[0]}) {
- ::logError("Table %s not found in databases", $tabs[0]);
+ my $newdb = Vend::Data::database_exists_ref($tabs[0])
+ or do {
+ $s->log_error("Table %s not found in databases", $tabs[0]);
return $opt->{failure} || undef;
- }
+ };
#::logDebug("rerouting to $tabs[0]");
$opt->{STATEMENT} = $stmt;
$opt->{SPEC} = $spec;
- return $s->query($opt, $text);
+ return $newdb->query($opt, $text);
}
eval {
if($stmt->command() ne 'SELECT') {
if(defined $s and $s->[$CONFIG]{Read_only}) {
- die ("Attempt to write read-only database $s->[$CONFIG]{name}");
+ $s->log_error(
+ "Attempt to write read-only table %s",
+ $s->[$CONFIG]{name},
+ );
+ return undef;
}
$update = $stmt->command();
}
@@ -569,9 +602,6 @@
my $search;
if ("\L$opt->{st}" eq 'db' ) {
- for(@tabs) {
- s/\..*//;
- }
$search = new Vend::DbSearch;
#::logDebug("created DbSearch object: " . ::uneval($search));
}
@@ -631,7 +661,12 @@
#::logDebug("ref returned: " . substr(Vend::Util::uneval($ref), 0, 100));
#:logDebug("opt is: " . Vend::Util::uneval($opt));
if($@) {
- ::logError("MVSQL query failed for $opt->{table}: $@\nquery was: $query");
+ $s->log_error(
+ "MVSQL query failed for %s: %s\nquery was: %s",
+ $opt->{table},
+ $@,
+ $query,
+ );
$return = $opt->{failure} || undef;
}
2.8 +5 -12 interchange/lib/Vend/Table/SDBM.pm
rev 2.8, prev_rev 2.7
Index: SDBM.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/SDBM.pm,v
retrieving revision 2.7
retrieving revision 2.8
diff -u -r2.7 -r2.8
--- SDBM.pm 6 Jul 2003 17:06:10 -0000 2.7
+++ SDBM.pm 12 Jul 2003 04:47:10 -0000 2.8
@@ -1,6 +1,6 @@
# Vend::Table::SDBM - Access an Interchange table stored in Perl's internal SDBM
#
-# $Id: SDBM.pm,v 2.7 2003/07/06 17:06:10 mheins Exp $
+# $Id: SDBM.pm,v 2.8 2003/07/12 04:47:10 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -24,7 +24,7 @@
# MA 02111-1307 USA.
package Vend::Table::SDBM;
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
use strict;
use Fcntl;
use SDBM_File;
@@ -32,7 +32,7 @@
use Vend::Table::Common;
@ISA = qw(Vend::Table::Common);
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
sub create {
my ($class, $config, $columns, $filename) = @_;
@@ -41,16 +41,9 @@
#::logDebug("called create, config=" . ::uneval_it($config));
my $File_permission_mode = $config->{File_permission_mode} || 0666;
- die "columns argument $columns is not an array ref\n"
+ die ::errmsg("columns argument %s is not an array ref", $columns)
unless CORE::ref($columns) eq 'ARRAY';
- # my $column_file = "$filename.columns";
- # my @columns = @$columns;
- # open(COLUMNS, ">$column_file")
- # or die "Couldn't create '$column_file': $!";
- # print COLUMNS join("\t", @columns), "\n";
- # close(COLUMNS);
-
my $column_index = Vend::Table::Common::create_columns($columns, $config);
my $tie = {};
@@ -120,7 +113,7 @@
}
my $dbm = tie(%$tie, 'SDBM_File', $filename, $flags, 0600)
- or die "Could not open '$filename': $!";
+ or die errmsg("%s %s: %s\n", errmsg("open"), $filename, $!);
my $columns = [split(/\t/, $tie->{'c'})];
More information about the interchange-cvs
mailing list