[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