[interchange-cvs] interchange - heins modified 7 files
interchange-cvs at icdevgroup.org
interchange-cvs at icdevgroup.org
Sun Apr 11 01:05:50 EDT 2004
User: heins
Date: 2004-04-11 05:05:50 GMT
Modified: lib/Vend Data.pm Config.pm
Modified: lib/Vend/Table Editor.pm
Modified: dist/lib/UI/profiles db_maintenance
Modified: code/UI_Tag flex_select.coretag import_fields.coretag
Added: lib/Vend/Table DBI_CompositeKey.pm
Log:
* Add new Class DBI_CompositeKey which allows multiple-key tables to
be used in Interchange in the majority of ways other tables are
used.
Setup is simple. Just use a normal DBI looking table, then
add
Database foo MULTIPLE_KEYS key1 key2 key3
This implies:
Database foo Class DBI_CompositeKey
If you have not already set up the table as a DBI type
(i.e. "Database foo foo.txt dbi:mysql:foobase") then
this will fail.
You should definitely have a COLUMN_DEF for each key. CREATE_SQL
or using NoImport works fine, too.
If you want a unique constraint you have to add it. If you
don't have unique set, you may get anomalous behavior.
-- Keys are passed via arrays, hashes, or null-separation. For
instance:
[data table=foo col=value1 key.0=foo key.1=bar key.2=baz]
[data table=foo col=value1 key.key1=foo key.key2=bar key.key3=baz]
[data table=foo col=value1 key=` join "\0", qw/foo bar baz/`]
All three of the above will return the same thing, as will:
[perl tables=foo]
my $db = $Db{foo};
my @key = qw/foo bar baz/;
my %key = (
key1 => 'foo',
key2 => 'bar',
key3 => 'baz',
);
my $try1 = $db->field(\@key, 'value1');
my $try2 = $db->field(\%key, 'value1');
my $try3 = $db->field( join("\0", @key), 'value1');
if($try1 eq $try2 and $try1 eq $try3) {
return "Access methods returned same value.";
}
else {
return "ERROR: Access methods returned differing values.";
}
[/perl]
-- [import-fields table=foo] works, but the {cleanse} option is
not allowed.
-- [import table=foo ...] works.
-- Exports work.
-- Imports from text files work, i.e. removing .sql file.
-- Table editor works.
-- Flex-select works. There is not as yet a batch delete, but that
should be possible in the future. "Edit keys in sequence" is unlikely
to ever work.
-- Autonumbering and AUTO_SEQUENCE are obviously moot.
-- $db->set_slice(), $db->get_slice work. So does $db->delete_record().
All use the same key types as other access methods.
-- $db->set_row() works, but doesn't do the one-field insert behavior.
Probably a plus. 8-) It should set _Default_ary, but that is not
tested.
Revision Changes Path
2.37 +15 -3 interchange/lib/Vend/Data.pm
rev 2.37, prev_rev 2.36
Index: Data.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Data.pm,v
retrieving revision 2.36
retrieving revision 2.37
diff -u -r2.36 -r2.37
--- Data.pm 2 Apr 2004 17:37:46 -0000 2.36
+++ Data.pm 11 Apr 2004 05:05:49 -0000 2.37
@@ -1,6 +1,6 @@
# Vend::Data - Interchange databases
#
-# $Id: Data.pm,v 2.36 2004/04/02 17:37:46 mheins Exp $
+# $Id: Data.pm,v 2.37 2004/04/11 05:05:49 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -73,6 +73,7 @@
# SQL
if($Global::DBI) {
require Vend::Table::DBI;
+ require Vend::Table::DBI_CompositeKey;
}
# END SQL
# LDAP
@@ -550,6 +551,7 @@
6 => ["\t", "\n"],
7 => ["\t", "\n"],
8 => ["\t", "\n"],
+ 10 => ["\t", "\n"],
LINE => ["\n", "\n\n"],
'%%%' => ["\n%%\n", "\n%%%\n"],
'%%' => ["\n%%\n", "\n%%%\n"],
@@ -615,6 +617,13 @@
%db_config = (
# SQL
+ 'DBI_CompositeKey' => {
+ qw/
+ Extension sql
+ RestrictedImport 1
+ Class Vend::Table::DBI_CompositeKey
+ /
+ },
'DBI' => {
qw/
Extension sql
@@ -1947,6 +1956,8 @@
}
#::logDebug("autonumber=$autonumber");
+ my $multikey = $base_db->config('MULTIPLE_KEYS');
+
if(@file_fields) {
my $Tag = new Vend::Tags;
my $acl_func;
@@ -2184,7 +2195,7 @@
}
while($field = shift @k) {
$value = shift @v;
- next if $field eq $prikey;
+ next if $field eq $prikey and ! $multikey;
## DATA IS SET HERE
# We are going to set the field unless it is only for
@@ -2218,7 +2229,8 @@
for(keys %$qd) {
#::logDebug("update_data: Getting ready to set_slice");
- $qret = $qd->{$_}->set_slice($key, $qf->{$_}, $qv->{$_});
+ my $k = $multikey ? undef : $key;
+ $qret = $qd->{$_}->set_slice($k, $qf->{$_}, $qv->{$_});
$rows_set[$i] = $qret unless $rows_set[$i];
}
if($blob) {
2.137 +18 -2 interchange/lib/Vend/Config.pm
rev 2.137, prev_rev 2.136
Index: Config.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Config.pm,v
retrieving revision 2.136
retrieving revision 2.137
diff -u -r2.136 -r2.137
--- Config.pm 2 Apr 2004 17:19:21 -0000 2.136
+++ Config.pm 11 Apr 2004 05:05:49 -0000 2.137
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.136 2004/04/02 17:19:21 mheins Exp $
+# $Id: Config.pm,v 2.137 2004/04/11 05:05:49 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
@@ -48,7 +48,7 @@
use Vend::File;
use Vend::Data;
-$VERSION = substr(q$Revision: 2.136 $, 10);
+$VERSION = substr(q$Revision: 2.137 $, 10);
my %CDname;
my %CPname;
@@ -3298,6 +3298,22 @@
my(@v) = Text::ParseWords::shellwords($val);
$d->{$p} = [] unless defined $d->{$p};
push @{$d->{$p}}, @v;
+ }
+ elsif ($p eq 'MULTIPLE_KEYS') {
+ ## Magic hardcode
+ if($d->{type} == 8) {
+ $d->{Class} = 'DBI_CompositeKey';
+ $d->{$p} = $val;
+ }
+ else {
+ config_warn(
+ 'Database %s parameter in type with no handling. Ignored.',
+ $p,
+ );
+ }
+ }
+ elsif ($p eq 'CLASS') {
+ $d->{Class} = $val;
}
elsif ($p =~ /^(MEMORY|SDBM|GDBM|DB_FILE|LDAP)$/i) {
$d->{Class} = uc $p;
1.54 +7 -5 interchange/lib/Vend/Table/Editor.pm
rev 1.54, prev_rev 1.53
Index: Editor.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Table/Editor.pm,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- Editor.pm 8 Mar 2004 21:06:50 -0000 1.53
+++ Editor.pm 11 Apr 2004 05:05:49 -0000 1.54
@@ -1,6 +1,6 @@
# Vend::Table::Editor - Swiss-army-knife table editor for Interchange
#
-# $Id: Editor.pm,v 1.53 2004/03/08 21:06:50 racke Exp $
+# $Id: Editor.pm,v 1.54 2004/04/11 05:05:49 mheins Exp $
#
# Copyright (C) 2002-2003 Interchange Development Group
# Copyright (C) 2002 Mike Heins <mike at perusion.net>
@@ -26,7 +26,7 @@
package Vend::Table::Editor;
use vars qw($VERSION);
-$VERSION = substr(q$Revision: 1.53 $, 10);
+$VERSION = substr(q$Revision: 1.54 $, 10);
use Vend::Util;
use Vend::Interpolate;
@@ -1682,11 +1682,13 @@
if($opt->{cgi}) {
$key ||= $CGI->{item_id};
- $opt->{item_id_left} ||= $CGI::values{item_id_left};
- $opt->{ui_sequence_edit} ||= $CGI::values{ui_sequence_edit};
+ unless($opt->{ui_multi_key} = $CGI->{ui_multi_key}) {
+ $opt->{item_id_left} ||= $CGI::values{item_id_left};
+ $opt->{ui_sequence_edit} ||= $CGI::values{ui_sequence_edit};
+ }
}
- if($opt->{ui_sequence_edit}) {
+ if($opt->{ui_sequence_edit} and ! $opt->{ui_multi_key}) {
delete $opt->{ui_sequence_edit};
my $left = delete $opt->{item_id_left};
1.1 interchange/lib/Vend/Table/DBI_CompositeKey.pm
rev 1.1, prev_rev 1.0
Index: DBI_CompositeKey.pm
===================================================================
# Vend::Table::DBI - Access a table stored in an DBI/DBD database
#
# $Id: DBI_CompositeKey.pm,v 1.1 2004/04/11 05:05:49 mheins Exp $
#
# Copyright (C) 2002-2004 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
package Vend::Table::DBI_CompositeKey;
$VERSION = substr(q$Revision: 1.1 $, 10);
use strict;
# 0: dummy open object
# 1: table name
# 2: key name
# 3: Configuration hash
# 4: Array of column names
# 5: database object
# 6: each reference (transitory)
use vars qw/
$CONFIG
$TABLE
$KEY
$NAME
$TYPE
$DBI
$EACH
$TIE_HASH
%DBI_connect_cache
%DBI_connect_count
%DBI_connect_bad
/;
($CONFIG, $TABLE, $KEY, $NAME, $TYPE, $DBI, $EACH) = (0 .. 6);
$TIE_HASH = $DBI;
sub create {
my ($class, $config, $columns, $tablename) = @_;
#::logDebug("DBI_CompositeKey trying create table $tablename");
if(! $config->{MULTIPLE_KEYS}) {
die ::errmsg(
"Class %s: requires MULTIPLE_KEYS setting\n",
$class,
);
}
if(! $config->{_Key_columns}) {
my @keycols = grep length($_), split /[\s,\0]+/, $config->{MULTIPLE_KEYS};
$config->{_Key_columns} = \@keycols;
$config->{_Key_where} = 'WHERE ';
my $hash = {};
my @what;
for(@keycols) {
push @what, "$_ = ?";
$hash->{$_} = 1;
}
$config->{_Key_where} .= join " AND ", @what;
$config->{_Key_is} = $hash;
if($config->{KEY_SPLITTOR}) {
$config->{_Key_splittor} = qr($config->{KEY_SPLITTOR});
}
else {
$config->{_Key_splittor} = qr([\0,]);
}
}
#::logDebug("open_table config=" . ::uneval($config));
return Vend::Table::DBI::create($class, $config, $columns, $tablename);
}
sub open_table {
my ($class, $config, $tablename) = @_;
#::logDebug("DBI_CompositeKey trying to open table $tablename");
if(! $config->{MULTIPLE_KEYS}) {
die ::errmsg(
"Class %s: requires MULTIPLE_KEYS setting\n",
$class,
);
}
if(! $config->{_Key_columns}) {
my @keycols = grep length($_), split /[\s,\0]+/, $config->{MULTIPLE_KEYS};
$config->{_Key_columns} = \@keycols;
$config->{_Key_where} = 'WHERE ';
my $hash = {};
my @what;
for(@keycols) {
push @what, "$_ = ?";
$hash->{$_} = 1;
}
$config->{_Key_where} .= join " AND ", @what;
$config->{_Key_is} = $hash;
if($config->{KEY_SPLITTOR}) {
$config->{_Key_splittor} = qr($config->{KEY_SPLITTOR});
}
else {
$config->{_Key_splittor} = qr([\0,]);
}
}
#::logDebug("open_table config=" . ::uneval($config));
return Vend::Table::DBI::open_table($class, $config, $tablename);
}
sub new {
my ($class, $obj) = @_;
$obj->{type} = 11;
#::logDebug("DBI_CompositeKey new object of" . ::uneval($obj));
bless [$obj], $class;
}
sub key_values {
my $s = shift;
my $key = shift;
my @key;
if(ref($key) eq 'HASH') {
for(@{$s->[$CONFIG]{_Key_columns}}) {
push @key, $key->{$_};
}
}
elsif(! ref($key)) {
@key = split $s->[$CONFIG]{_Key_splittor}, $key;
}
else {
@key = @$key;
}
#::logDebug("DBI_CompositeKey keys = " . ::uneval(\@key));
return @key;
}
sub inc_field {
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
$column = $s->[$NAME][ $s->column_index($column) ];
my @key = $s->key_values($key);
my $q1 = "select $column from $s->[$TABLE] $s->[$CONFIG]->{_Key_where}";
my $q2 = "update $s->[$TABLE] set $column = ? $s->[$CONFIG]->{_Key_where}";
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;
}
sub field_accessor {
my ($s, $column) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
$column = $s->[$NAME][ $s->column_index($column) ];
my $q = "select $column from $s->[$TABLE] $s->[$CONFIG]{_Key_where}";
my $sth = $s->[$DBI]->prepare($q)
or $s->log_error("field_accessor statement (%s) -- bad result.", $q)
and return undef;
#::logDebug("binding sub to $q");
return sub {
my ($key) = @_;
my @key = $s->key_values($key);
$sth->execute(@key);
my ($return) = $sth->fetchrow_array();
return $return;
};
}
sub clone_row {
my ($s, $old, $new, $change) = @_;
#::logDebug("called clone_row old=$old new=$new change=$change");
$s = $s->ref();
my @old = $s->key_values($old);
return undef unless $s->record_exists(@old);
my @ary = $s->row(@old);
#::logDebug("called clone_row ary=" . join "|", @ary);
if($change and ref $change) {
for (keys %$change) {
my $pos = $s->column_index($_)
or next;
$ary[$pos] = $change->{$_};
}
}
my @new = $s->key_values($new);
for(@{$s->[$CONFIG]{_Key_columns}}) {
my $i = $s->column_index($_);
$ary[$i] = shift @new;
}
$ary[$s->[$CONFIG]{KEY_INDEX}] = $new;
#::logDebug("called clone_row now=" . join "|", @ary);
my $k = $s->set_row(@ary);
#::logDebug("cloned, key=$k");
return $k;
}
sub clone_set {
#### Can't yet be used
my ($s, $col, $old, $new) = @_;
#::logDebug("called clone_set col=$col old=$old new=$new");
return unless $s->column_exists($col);
my $sel = $s->quote($old, $col);
my $name = $s->[$CONFIG]{name};
my ($ary, $nh, $na) = $s->query("select * from $name where $col = $sel");
my $fpos = $nh->{$col} || return undef;
$s->config('AUTO_NUMBER', '000001') unless $s->config('AUTO_NUMBER');
for(@$ary) {
my $line = $_;
$line->[$s->[$CONFIG]{KEY_INDEX}] = '';
$line->[$fpos] = $new;
my $k = $s->set_row(@$line);
#::logDebug("cloned, key=$k");
}
return $new;
}
sub get_slice {
my ($s, $key, $fary) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
my $tkey;
my $sql;
my @key = $s->key_values($key);
#::logDebug("key values for get_slice=" . ::uneval(\@key));
return undef unless $s->record_exists(\@key);
#::logDebug("tkey now $tkey");
# Better than failing on a bad ref...
if(ref $fary ne 'ARRAY') {
shift; shift;
$fary = [ @_ ];
}
my $fstring = join ",", @$fary;
$sql = "SELECT $fstring from $s->[$TABLE] $s->[$CONFIG]{_Key_where}";
#::logDebug("get_slice query: $sql");
#::logDebug("get_slice key/fields:\nkey=$key\n" . ::uneval($fary));
my $sth;
my $ary;
eval {
$sth = $s->[$DBI]->prepare($sql)
or die ::errmsg("prepare %s: %s", $sql, $DBI::errstr);
$sth->execute(@key);
};
if($@) {
my $msg = $@;
$s->log_error("failed %s::%s routine: %s", __PACKAGE__, 'get_slice', $msg);
return undef;
}
return wantarray ? $sth->fetchrow_array() : $sth->fetchrow_arrayref();
}
sub set_slice {
my ($s, $key, $fin, $vin) = @_;
my ($fary, $vary);
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
$s->log_error(
"Attempt to set slice of %s in read-only table %s",
$key,
$s->[$CONFIG]{name},
);
return undef;
}
my @key;
my $exists;
if($key) {
@key = $s->key_values($key);
$exists = $s->record_exists($key);
}
my $sql;
if (ref $fin eq 'ARRAY') {
$fary = [@$fin];
$vary = [@$vin];
}
else {
my $href = $fin;
if(ref $href ne 'HASH') {
$href = { splice (@_, 2) };
}
if(! $key) {
@key = ();
for( @{$s->[$CONFIG]{_Key_columns}} ) {
push @key, delete $href->{$_};
}
$key = \@key;
$exists = $s->record_exists(\@key);
}
$vary = [ values %$href ];
$fary = [ keys %$href ];
}
if(! $key) {
for my $kp (@{$s->[$CONFIG]{_Key_columns}}) {
my $idx;
my $i = -1;
for(@$fary) {
$i++;
next unless $_ eq $kp;
$idx = $i;
last;
}
if(! defined $idx) {
my $caller = caller();
$s->log_error(
'%s error as called by %s: %s',
'set_slice',
$caller,
'unable to find key in field array',
);
return undef;
}
push @key, $vary->[$idx];
}
#::logDebug("No key, key now=" . ::uneval(\@key));
$exists = $s->record_exists(\@key);
}
if ($s->[$CONFIG]->{PREFER_NULL}) {
my $prefer_null = $s->[$CONFIG]->{PREFER_NULL};
my $i = 0;
for (@$fary) {
undef $vary->[$i]
if exists $prefer_null->{$_} and $vary->[$i] eq '';
++$i;
}
}
if($s->[$CONFIG]->{LENGTH_EXCEPTION_DEFAULT}) {
my $lcfg = $s->[$CONFIG]{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]};
$vary->[$i] = $s->length_exception($fary->[$i], $vary->[$i])
if length($vary->[$i]) > $lcfg->{$fary->[$i]}{LENGTH};
}
}
if ( $exists ) {
my $fstring = join ",", map { "$_=?" } @$fary;
$sql = "update $s->[$TABLE] SET $fstring $s->[$CONFIG]{_Key_where}";
}
else {
my $found;
my %found;
for(my $i = 0; $i < @$fary; $i++) {
next unless $s->[$CONFIG]{_Key_is}{$fary->[$i]};
$found{$fary->[$i]} = 1;
}
for(@{$s->[$CONFIG]{_Key_columns}}) {
if($found{$_}) {
shift(@key);
}
else {
unshift @$fary, $_;
unshift @$vary, shift(@key);
}
}
my $fstring = join ",", @$fary;
my $vstring = join ",", map {"?"} @$vary;
$sql = "insert into $s->[$TABLE] ($fstring) VALUES ($vstring)";
}
#::logDebug("exists=$exists set_slice query: $sql");
#::logDebug("set_slice key/fields/values:\nkey=$key\n" . ::uneval($fary, $vary));
my $val;
eval {
my $sth = $s->[$DBI]->prepare($sql)
or die ::errmsg("prepare %s: %s", $sql, $DBI::errstr);
my $rc = $sth->execute(@$vary, at key)
or die ::errmsg("execute %s: %s", $sql, $DBI::errstr);
$val = $key;
};
#::logDebug("set_slice key: $val");
if($@) {
my $caller = caller();
$s->log_error(
"%s error as called by %s: %s\nquery was:%s\nvalues were:'%s'",
'set_slice',
$caller,
$@,
$sql,
join("','", @$vary),
);
return undef;
}
return $val;
}
sub set_row {
my ($s, @fields) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
my $cfg = $s->[$CONFIG];
my $ki = $cfg->{KEY_INDEX};
$s->filter(\@fields, $s->[$CONFIG]{COLUMN_INDEX}, $s->[$CONFIG]{FILTER_TO})
if $cfg->{FILTER_TO};
if ($cfg->{PREFER_NULL}) {
for (keys %{$cfg->{PREFER_NULL}}) {
my $i = $cfg->{COLUMN_INDEX}{$_};
undef $fields[$i] if $fields[$i] eq '';
}
}
my $val;
my @key;
my @vals;
my @flds;
my $force_key;
if(scalar @fields == 1) {
$force_key = 1;
@key = $s->key_values($fields[0]);
for(@{$cfg->{_Key_columns}}) {
$vals[$s->column_index($_)] = shift @key;
}
}
else {
for(@{$cfg->{_Key_columns}}) {
push @key, $fields[$s->column_index($_)];
}
}
if($force_key) {
my $key_string;
my $val_string;
my $ary;
if($cfg->{_Default_ary} || $cfg->{_Default_session_ary}) {
my $ary = $cfg->{_Default_ary} || [];
my $sary = $cfg->{_Default_session_ary} || [];
my $max = $#$ary > $#$sary ? $#$ary : $#$sary;
for (my $i = 0; $i <= $max; $i++) {
if($sary->[$i] and ! defined $vals[$i]) {
push @flds, $s->[$NAME][$i];
@vals[$i], $sary->[$i]->($s);
next;
}
next unless defined $ary->[$i];
$flds[$i] = $s->[$NAME][$i];
$vals[$i] = $ary->[$i];
}
}
my @f;
my @v;
for( my $i = 0; $i < @flds; $i++) {
next unless $flds[$i];
push @f, $flds[$i];
push @v, $vals[$i];
}
$key_string = join ",", @f;
$val_string = join ",", @v;
#::logDebug("def_ary query will be: insert into $s->[$TABLE] ($key_string) VALUES ($val_string)");
eval {
$s->delete_record(\@key);
$s->[$DBI]->do("insert into $s->[$TABLE] ($key_string) VALUES ($val_string)");
};
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 \@key;
}
if (! $s->[$CONFIG]{Clean_start}) {
eval {
$s->delete_record(\@key);
};
}
#::logDebug("set_row fields='" . join(',', @fields) . "'" );
if(! $cfg->{_Insert_h}) {
my (@ins_mark);
my $i = 0;
for(@{$s->[$NAME]}) {
push @ins_mark, '?';
$i++;
}
my $fstring = '';
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)
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 $s->log_error("%s error: $DBI::errstr", 'set_row', $DBI::errstr);
#::logDebug("set_row rc=$rc key=" . ::uneval_it(\@key));
return \@key;
}
sub last_sequence_value {
die ::errmsg("No last_sequence_value with DBI_CompositeKey");
}
sub row {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
my $q = "select * from $s->[$TABLE] $s->[$CONFIG]{_Key_where}";
my @key = $s->key_values($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];
my $q = "select * from $s->[$TABLE] $s->[$CONFIG]{_Key_where}";
my @key = $s->key_values($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];
my $ref;
if($s->config('UPPERCASE')) {
my $aref = $sth->fetchrow_arrayref()
or return undef;
$ref = {};
my @nm = @{$sth->{NAME}};
for ( my $i = 0; $i < @$aref; $i++) {
$ref->{$nm[$i]} = $ref->{lc $nm[$i]} = $aref->[$i];
}
}
else {
$ref = $sth->fetchrow_hashref();
}
return $ref unless $s->[$CONFIG]{FIELD_ALIAS};
my ($k, $v);
while ( ($k, $v) = each %{ $s->[$CONFIG]{FIELD_ALIAS} } ) {
$ref->{$v} = $ref->{$k};
}
return $ref;
}
sub field_settor {
my ($s, $column) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
my $q = "update $s->[$TABLE] SET $column = ? $s->[$CONFIG]{_Key_where}";
my $sth = $s->[$DBI]->prepare($q)
or $s->log_error("Unable to prepare query for field_settor: %s", $q)
and return undef;
return sub {
my ($key, $value) = @_;
my @key = $s->key_values($key);
$sth->execute($value, @key);
};
}
sub foreign {
die "Foreign keys not supported for multiple-key database tables\n";
}
sub field {
my ($s, $key, $column) = @_;
#::logDebug("Called DBI_CompositeKey field");
$s = $s->import_db() if ! defined $s->[$DBI];
my @key = $s->key_values($key);
my $idx;
if( $s->[$TYPE] and $idx = $s->column_index($column) ) {
$column = $s->[$NAME][$idx];
}
my $query = "select $column from $s->[$TABLE] $s->[$CONFIG]{_Key_where}";
#::logDebug("DBI field: key=$key column=$column query=$query");
my $sth;
eval {
$sth = $s->[$DBI]->prepare($query);
$sth->execute(@key);
};
if($@) {
$s->log_error("field: failed to execute %s", $query);
return '';
}
my $data = ($sth->fetchrow_array())[0];
return '' unless $data =~ /\S/;
$data;
}
sub set_field {
my ($s, $key, $column, $value) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
$s->log_error("Attempt to set %s in read-only table",
"$s->[$CONFIG]{name}::${column}::$key",
);
return undef;
}
my $lcfg;
if(
$s->[$CONFIG]->{LENGTH_EXCEPTION_DEFAULT}
and $s->[$CONFIG]{FIELD_LENGTH_DATA}
and $lcfg = $s->[$CONFIG]{FIELD_LENGTH_DATA}{$column}
and $lcfg->{LENGTH} < length($value)
)
{
$value = $s->length_exception($column, $value);
}
my @key = $s->key_values($key);
undef $value if $value eq '' and exists $s->[$CONFIG]{PREFER_NULL}{$column};
$s->set_slice($key, [$column], [$value]);
}
sub ref {
return $_[0] if defined $_[0]->[$DBI];
return $_[0]->import_db();
}
sub test_record {
1;
}
sub record_exists {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
my @key = $s->key_values($key);
my $query;
# Does any SQL allow empty key?
return '' if ! length($key) and ! $s->[$CONFIG]{ALLOW_EMPTY_KEY};
my $mainkey = $s->[$CONFIG]{_Key_columns}[0];
#::logDebug("record_exists for mainkey=$mainkey key=" . ::uneval(\@key));
$query = $s->[$CONFIG]{Exists_handle}
or
$query = $s->[$DBI]->prepare(
"select $mainkey from $s->[$TABLE] $s->[$CONFIG]{_Key_where}"
)
and
$s->[$CONFIG]{Exists_handle} = $query;
my $status;
#::logDebug("record_exists query=$query");
eval {
$status = defined $s->[$DBI]->selectrow_array($query, undef, @key);
};
if($@) {
$s->log_error("Bad execution of record_exists query");
return undef;
}
#::logDebug("record_exists status=$status");
return $status;
}
sub delete_record {
my ($s, $key) = @_;
$s = $s->import_db() if ! defined $s->[$DBI];
if($s->[$CONFIG]{Read_only}) {
$s->log_error("Attempt to delete record '%s' from read-only database %s",
$key,
$s->[$CONFIG]{name},
);
return undef;
}
my @key = $s->key_values($key);
my $sth = $s->[$DBI]->prepare("delete from $s->[$TABLE] $s->[$CONFIG]{_Key_where}");
my $rc = $sth->execute(@key);
return $rc > 0 ? $rc : 0;
}
*import_db = \&Vend::Table::DBI::import_db;
*suicide = \&Vend::Table::DBI::suicide;
*close_table = \&Vend::Table::DBI::close_table;
*dbh = \&Vend::Table::DBI::dbh;
*name = \&Vend::Table::DBI::name;
*columns = \&Vend::Table::DBI::columns;
*test_column = \&Vend::Table::DBI::test_column;
*quote = \&Vend::Table::DBI::quote;
*numeric = \&Vend::Table::DBI::numeric;
*filter = \&Vend::Table::DBI::filter;
*commit = \&Vend::Table::DBI::commit;
*rollback = \&Vend::Table::DBI::rollback;
*isopen = \&Vend::Table::DBI::isopen;
*column_index = \&Vend::Table::DBI::column_index;
*column_exists = \&Vend::Table::DBI::column_exists;
*bind_entire_row = \&Vend::Table::DBI::bind_entire_row;
*length_exception = \&Vend::Table::DBI::length_exception;
*fields_index = \&Vend::Table::DBI::fields_index;
*list_fields = \&Vend::Table::DBI::list_fields;
*touch = \&Vend::Table::DBI::touch;
*sort_each = \&Vend::Table::DBI::sort_each;
*each_record = \&Vend::Table::DBI::each_record;
*each_nokey = \&Vend::Table::DBI::each_nokey;
*sprintf_substitute = \&Vend::Table::DBI::sprintf_substitute;
*hash_query = \&Vend::Table::DBI::hash_query;
*query = \&Vend::Table::DBI::query;
*auto_config = \&Vend::Table::DBI::auto_config;
*config = \&Vend::Table::DBI::config;
*reset = \&Vend::Table::Common::reset;
*log_error = \&Vend::Table::Common::log_error;
*errstr = \&Vend::Table::Common::errstr;
1;
__END__
2.3 +77 -34 interchange/dist/lib/UI/profiles/db_maintenance
rev 2.3, prev_rev 2.2
Index: db_maintenance
===================================================================
RCS file: /var/cvs/interchange/dist/lib/UI/profiles/db_maintenance,v
retrieving revision 2.2
retrieving revision 2.3
diff -u -r2.2 -r2.3
--- db_maintenance 14 Mar 2004 15:30:56 -0000 2.2
+++ db_maintenance 11 Apr 2004 05:05:50 -0000 2.3
@@ -120,53 +120,96 @@
my @deltables = split /[\s0,]/, $CGI->{ui_delete_tables};
unshift @deltables, $CGI->{mv_data_table};
my @out;
- for(@{$CGI_array->{$idp}}) {
- my $key = $_;
- my $db;
- for(@deltables) {
- my ($t, $col) = split /:/, $_;
- next unless $t;
+ if(@deltables == 1 and $deltables[0] !~ /:/) {
+#Debug("In simple case");
+ ## Simple case
+ DELREC: {
+ my $t = $deltables[0];
+#Debug("simple case table=$t");
if ( $Tag->if_mm('!tables', "$t=d") ) {
push @errors,
errmsg("Not authorized to delete from table %s", $t);
- next;
+ last DELREC;
}
- unless ($db = $Db{$t}) {
- push @errors, errmsg("Table %s not available.", $t);
- next;
- }
- if($col) {
- next unless length ($key);
- my $k = $db->quote($key, $col);
- my $num = $db->query("delete from $t where $col = $k");
- if($num > 0) {
- push @out, errmsg(
- "deleted %s records from %s where %s = %s",
- $num,
- $t,
- $col,
- $k,
- );
+
+ my $db = $Db{$t};
+ if($db->config('MULTIPLE_KEYS')) {
+ $CGI->{$idp} =~ s/-_NULL_-/\0/g;
+ my $key = $CGI->{$idp};
+ $key =~ s/\0/,/g;
+#Debug("simple case multiple key=$key");
+ my $rc = $db->delete_record($CGI->{$idp});
+ if($rc) {
+ push @out, errmsg("Deleted %s from %s", $key, $t);
}
else {
- push @errors, errmsg(
- "No records in %s where %s = %s",
+ push @errors, errmsg("Unable to delete %s: %s", $key, $@);
+ }
+ }
+ else {
+ for(@{$CGI_array->{$idp}}) {
+#Debug("simple case regular key=$_");
+ my $rc = $db->delete_record($_);
+ if($rc) {
+ push @out, errmsg("Deleted %s from %s", $_, $t);
+ }
+ else {
+ push @errors, errmsg("Unable to delete %s from %s: %s", $_, $t, $@);
+ }
+ }
+ }
+ }
+ }
+ else {
+ for(@{$CGI_array->{$idp}}) {
+ my $key = $_;
+ my $db;
+ for(@deltables) {
+ my ($t, $col) = split /:/, $_;
+ next unless $t;
+ if ( $Tag->if_mm('!tables', "$t=d") ) {
+ push @errors,
+ errmsg("Not authorized to delete from table %s", $t);
+ next;
+ }
+ unless ($db = $Db{$t}) {
+ push @errors, errmsg("Table %s not available.", $t);
+ next;
+ }
+ if($col) {
+ next unless length ($key);
+ my $k = $db->quote($key, $col);
+ my $num = $db->query("delete from $t where $col = $k");
+ if($num > 0) {
+ push @out, errmsg(
+ "deleted %s records from %s where %s = %s",
+ $num,
$t,
$col,
$k,
);
+ }
+ else {
+ push @errors, errmsg(
+ "No records in %s where %s = %s",
+ $t,
+ $col,
+ $k,
+ );
+ }
+ }
+ else {
+ next unless $db->record_exists($key);
+ $db->delete_record($key)
+ or do {
+ push @errors, $@;
+ next;
+ };
+ push @out, errmsg("Deleted %s from %s", $key, $t);
}
- }
- else {
- next unless $db->record_exists($key);
- $db->delete_record($key)
- or do {
- push @errors, $@;
- next;
- };
- push @out, errmsg("Deleted %s from %s", $key, $t);
}
}
+
}
if(@errors) {
my $str = '<ul><li>';
1.7 +35 -4 interchange/code/UI_Tag/flex_select.coretag
rev 1.7, prev_rev 1.6
Index: flex_select.coretag
===================================================================
RCS file: /var/cvs/interchange/code/UI_Tag/flex_select.coretag,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- flex_select.coretag 22 Feb 2004 20:05:29 -0000 1.6
+++ flex_select.coretag 11 Apr 2004 05:05:50 -0000 1.7
@@ -82,6 +82,11 @@
$ts->{large} = 1;
}
+ if( $db->config('MULTIPLE_KEYS') ) {
+ $ts->{multikey} = 1;
+ $ts->{key_columns} = $db->config('_Key_columns');
+ }
+
DELETE: {
last DELETE unless $CGI->{item_id};
last DELETE unless delete $CGI->{deleterecords};
@@ -638,6 +643,7 @@
}
$opt->{ui_style} = 1 unless defined $opt->{ui_style};
+ $opt->{no_checkbox} = 1 if $ts->{multikey};
my $show_meta;
my $meta_anchor;
@@ -772,6 +778,15 @@
start_at=extended.ui_more_alpha
EOF
+ my %mkey;
+ if($ts->{multikey}) {
+ for(@{$ts->{key_columns}}) {
+ $mkey{$_} = 1;
+ }
+ }
+
+ my @mcol;
+
my $idx = 0;
foreach my $col (@cols) {
my $mcol = $col;
@@ -783,6 +798,11 @@
## $cc is set in header_cell_class
my $m = $cc->{$mcol};
+ if($mkey{$col}) {
+::logDebug("col=$col index=$idx");
+ push @mcol, $idx - 1;
+ }
+
push @head, <<EOF;
<td$td_extra>
<table align="left" class="$opt->{group_class}" cellspacing=$opt->{group_spacing} cellpadding=$opt->{group_padding} width="$opt->{group_width}">
@@ -938,6 +958,8 @@
}
push @head, "</tr>";
+ shift @mcol;
+
my $ncols = $idx;
$ncols++ if $opt->{explicit_edit};
$ncols++ if $opt->{number_list};
@@ -1052,12 +1074,21 @@
$code_pre = $code_post = '';
}
else {
+ my @what;
+ push @what, "$edit_parm=$code";
+ if($ts->{multikey}) {
+ unshift @what, 'ui_multi_key=1';
+ for(@mcol) {
+ push @what, "$edit_parm=$line->[$_]";
+ }
+
+ }
+
+ my $ep_string = join "\n", @what, $edit_extra;
+
my $edit_url = $Tag->area({
href => $edit_page,
- form => qq{
- $edit_parm=$code
- $edit_extra
- }
+ form => $ep_string,
});
my $msg = errmsg('edit %s', $ecode);
$code_pre = qq{<a href="$edit_url" title="$msg">};
1.9 +56 -17 interchange/code/UI_Tag/import_fields.coretag
rev 1.9, prev_rev 1.8
Index: import_fields.coretag
===================================================================
RCS file: /var/cvs/interchange/code/UI_Tag/import_fields.coretag,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- import_fields.coretag 2 Apr 2004 14:49:06 -0000 1.8
+++ import_fields.coretag 11 Apr 2004 05:05:50 -0000 1.9
@@ -1,6 +1,6 @@
UserTag import_fields Order table
UserTag import_fields addAttr
-UserTag import_fields Version $Revision: 1.8 $
+UserTag import_fields Version $Revision: 1.9 $
UserTag import_fields Routine <<EOR
sub {
my($table, $opt) = @_;
@@ -236,6 +236,9 @@
die "Invalid key '$key' for table $table (wrong file format ?)\n";
}
+ my $multikey = $db->config('MULTIPLE_KEYS') ? 1 : 0;
+
+
if ($opt->{ignore_fields}) {
my %fmap;
for (my $ct = 0; $ct < @names; $ct++) {
@@ -250,6 +253,27 @@
@names = grep {exists $fmap{$_}} @names;
}
+ # We skip the whole table if bad field is found
+ my $skipping;
+
+ if($multikey) {
+ my %fmap;
+ @fmap{$key, at names} = ($key, at names);
+ my $not_all_there;
+ for(@{$db->config('_Key_columns')}) {
+ next if $fmap{$_};
+ $not_all_there = 1;
+ }
+ if($not_all_there) {
+ $out .= errmsg(
+ "Table %s: not all key columns present. Skipping table.",
+ $table,
+ );
+
+ $skipping = 1;
+ }
+ }
+
######### Filters
##
## Done with so many data items for speed when empty....
@@ -264,8 +288,6 @@
##
######### Filters
- # We skip the whole table if bad field is found
- my $skipping;
for(@names) {
my $test = $db->column_index($_);
#::logDebug("checking name=$_");
@@ -327,6 +349,7 @@
if(! $k and ! length($k)) {
if ($f[0] eq 'DELETE') {
next if ! $opt->{delete};
+ next if $multikey;
$out .= "${tmsg}Deleting record '$f[1]'.\n" if $verbose;
$db->delete_record($f[1]);
$count++;
@@ -337,7 +360,31 @@
$ignore_sub->(\@f) if $ignore_sub;
$out .= "${tmsg}Record '$k' had too many fields, ignored.\n"
if @f > $idx;
- if ( ! length($k) or ! $db->record_exists($k)) {
+
+ my %hash;
+ @hash{@names} = @f;
+ if($found_filter) {
+ for(@filters) {
+ $change{$_}->(\$hash{$_});
+ }
+ }
+
+ if($multikey) {
+ $hash{$key} = $k;
+ if(! $db->record_exists(\%hash)) {
+ if($opt->{add}) {
+ $out .= "${tmsg}Adding multiple-key record.\n" if $verbose;
+ }
+ else {
+ $out .= "${tmsg}Non-existent record '$k', skipping.\n";
+ next;
+ }
+ }
+ $db->set_slice(undef, \%hash);
+ $count++;
+ next;
+ }
+ elsif ( ! length($k) or ! $db->record_exists($k)) {
if ($opt->{add}) {
if( ! length($k) and ! $opt->{autonumber}) {
$out .= "${tmsg}Blank key, no autonumber option, skipping.\n";
@@ -352,21 +399,13 @@
next;
}
}
- for ($i = 0; $i < $idx; $i++) {
- if ($opt->{cleanse}) {
- delete $keys{$k};
- }
- }
- if(@names) {
- my %hash;
- @hash{@names} = @f;
- if($found_filter) {
- for(@filters) {
- $change{$_}->(\$hash{$_});
- }
- }
- $db->set_slice($k, \%hash);
+
+ if ($opt->{cleanse}) {
+ delete $keys{$k};
}
+
+ $db->set_slice($k, \%hash) if @names;
+
if($@) {
my $msg = ::errmsg("error on update: %s", $@);
::logError($msg);
More information about the interchange-cvs
mailing list