lib/Vend/Data.pm

   1 # Vend::Data - Interchange databases
   2 #
   3 # Copyright (C) 2002-2009 Interchange Development Group
   4 # Copyright (C) 1996-2002 Red Hat, Inc.
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation and modified by the Interchange license;
  12 # either version 2 of the License, or (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public
  20 # License along with this program; if not, write to the Free
  21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  22 # MA  02110-1301  USA.
  23
  24 package Vend::Data;
  25 require Exporter;
  26 @ISA = qw(Exporter);
  27 @EXPORT = qw(
  28
  29 close_database
  30 column_exists
  31 database_field
  32 database_ref
  33 database_exists_ref
  34 database_key_exists
  35 db_column_exists
  36 export_database
  37 import_database
  38 increment_field
  39 item_category
  40 item_common
  41 item_description
  42 item_field
  43 item_price
  44 item_subtotal
  45 open_database
  46 product_category
  47 product_code_exists_ref
  48 product_code_exists_tag
  49 product_description
  50 product_common
  51 product_field
  52 product_price
  53 product_row
  54 product_row_hash
  55 set_field
  56 update_data
  57
  58 );
  59 @EXPORT_OK = qw(update_productbase column_index);
  60
  61 use strict;
  62 no warnings qw(uninitialized numeric);
  63 use File::Basename;
  64 use Vend::Util;
  65 use Vend::Interpolate;
  66 use Vend::Table::Common qw(import_ascii_delimited);
  67
  68 File::Basename::fileparse_set_fstype($^O);
  69
  70 BEGIN {
  71 # SQL
  72         if($Global::DBI) {
  73                 require Vend::Table::DBI;
  74                 require Vend::Table::DBI_CompositeKey;
  75         }
  76 # END SQL
  77 # LDAP
  78         if($Global::LDAP) {
  79                 require Vend::Table::LDAP;
  80         }
  81 # END LDAP
  82         if($Global::GDBM) {
  83                 require Vend::Table::GDBM;
  84         }
  85         if($Global::DB_File) {
  86                 require Vend::Table::DB_File;
  87         }
  88         require Vend::Table::InMemory;
  89         require Vend::Table::Shadow;
  90 }
  91
  92 my ($Products, $Item_price);
  93
  94 sub instant_database {
  95         my($file) = @_;
  96         return undef unless $file =~ /\.(txt|asc)$/;
  97         my $dir   = File::Basename::dirname($file);
  98         my $fname = File::Basename::basename($file);
  99         my $dbname = $fname;
 100         $dbname =~ s:\W:_:g;
 101
 102         $Vend::Database{$dbname}
 103                 and return $Vend::Database{$dbname}->ref();
 104         $Vend::WriteDatabase{$file} and $Vend::WriteDatabase{$dbname} = 1;
 105         if( file_name_is_absolute($_[0]) ) {
 106                 my $msg = errmsg(
 107                                                 "Instant database (%s): no absolute file names.",
 108                                                 $_[0],
 109                                         );
 110                 logError($msg);
 111                 logGlobal($msg);
 112                 return undef;
 113         }
 114         elsif (! -f $_[0]) {
 115                 my $msg = errmsg(
 116                                                 "Instant database (%s): no file found.",
 117                                                 $_[0],
 118                                         );
 119                 logError($msg);
 120                 return undef;
 121         }
 122         return $Vend::Database{$dbname} = import_database({
 123                                                                                                         name => $dbname,
 124                                                                                                         DIR => $dir,
 125                                                                                                         type => 'AUTO',
 126                                                                                                         file => $fname,
 127                                                                                                         Class => 'TRANSIENT',
 128                                                                                                         EXPORT_ON_CLOSE => 1,
 129                                                                                                 });
 130 }
 131
 132 sub database_exists_ref {
 133         return unless $_[0];
 134         return $_[0]->ref() if ref $_[0];
 135         return $Vend::Interpolate::Db{$_[0]}
 136                         if $Vend::Interpolate::Db{$_[0]};
 137         $Vend::Database{$_[0]}
 138                 and return $Vend::Database{$_[0]}->ref();
 139         return instant_database(@_);
 140 }
 141
 142 sub database_key_exists {
 143     my ($db,$key) = @_;
 144     return $db->record_exists($key);
 145 }
 146
 147 sub product_code_exists_ref {
 148     my ($code, $base) = @_;
 149
 150     my($ref);
 151     if($base) {
 152         return undef unless $ref = $Vend::Productbase{$base};
 153         return $ref->ref() if $ref->record_exists($code);
 154     }
 155
 156     my $return;
 157     foreach $ref (@Vend::Productbase) {
 158         return ($return = $ref) if $ref->record_exists($code);
 159     }
 160     return undef;
 161 }
 162
 163 sub product_code_exists_tag {
 164     my ($code, $base) = @_;
 165         if($base) {
 166                 return undef unless $Vend::Productbase{$base};
 167                 return $base if $Vend::Productbase{$base}->record_exists($code);
 168                 return 0;
 169         }
 170
 171         foreach my $ref (@Vend::Productbase) {
 172                 return $Vend::Basefinder{$ref} if $ref->record_exists($code);
 173         }
 174         return undef;
 175 }
 176
 177 sub open_database {
 178         return tie_database() if $_[0] || $Global::AcrossLocks;
 179         dummy_database();
 180 }
 181
 182 sub update_productbase {
 183
 184         if(defined $_[0]) {
 185                 return unless defined $Vend::Productbase{$_[0]};
 186         }
 187         undef @Vend::Productbase;
 188         for(@{$Vend::Cfg->{ProductFiles}}) {
 189                 unless ($Vend::Database{$_}) {
 190                   die "$_ not a database, cannot use as products file\n";
 191                 }
 192                 $Vend::Productbase{$_} = $Vend::Database{$_};
 193                 $Vend::Basefinder{$Vend::Database{$_}} = $_;
 194                 push @Vend::Productbase, $Vend::Database{$_};
 195                 $Vend::OnlyProducts = $_;
 196         }
 197
 198         undef $Vend::OnlyProducts if scalar @Vend::Productbase > 1;
 199
 200         $Products = $Vend::Productbase[0];
 201 #::logError("Productbase: '@Vend::Productbase' --> " . uneval(\%Vend::Basefinder));
 202
 203 }
 204
 205 sub product_price {
 206     my ($code, $q, $base) = @_;
 207
 208         $base = $Vend::Basefinder{$base}
 209                 if ref $base;
 210
 211         return item_price(
 212                 {
 213                         code            => $code,
 214                         quantity        => $q || 1,
 215                         mv_ib           => $base || undef,
 216                 },
 217                 $q
 218         );
 219 }
 220
 221 sub product_category {
 222         my ($code, $base) = @_;
 223     return "" unless $base = product_code_exists_ref($code, $base || undef);
 224     return database_field($base, $code, $Vend::Cfg->{CategoryField});
 225 }
 226
 227 sub product_description {
 228     my ($code, $base) = @_;
 229     return "" unless $base = product_code_exists_ref($code, $base || undef);
 230     return database_field($base, $code, $Vend::Cfg->{DescriptionField});
 231 }
 232
 233 sub database_field {
 234     my ($db, $key, $field_name, $foreign) = @_;
 235 #::logDebug("database_field: " . uneval_it(\@_));
 236     $db = database_exists_ref($db) or return undef;
 237     return '' unless defined $db->test_column($field_name);
 238         $key = $db->foreign($key, $foreign) if $foreign;
 239     return '' unless $db->test_record($key);
 240     return $db->field($key, $field_name);
 241 }
 242
 243 sub database_row {
 244     my ($db, $key) = @_;
 245     $db = database_exists_ref($db) or return undef;
 246     return '' unless $db->test_record($key);
 247     return $db->row_hash($key);
 248 }
 249
 250 sub increment_field {
 251     my ($db, $key, $field_name, $adder) = @_;
 252         $db = $db->ref();
 253     return undef unless $db->test_record($key);
 254     return undef unless defined $db->test_column($field_name);
 255 #::logDebug(__PACKAGE__ . "increment_field: " . uneval_it(\@_));
 256     return $db->inc_field($key, $field_name, $adder);
 257 }
 258
 259 sub call_method {
 260         my($base, $method, @args) = @_;
 261
 262         my $db = ref $base ? $base : $Vend::Database{$base};
 263         $db = $db->ref();
 264
 265         no strict 'refs';
 266         $db->$method(@args);
 267 }
 268
 269 sub import_text {
 270         my ($table, $type, $options, $text) = @_;
 271 #::logDebug("Called import_text: table=$table type=$type opt=" . Data::Dumper::Dumper($options) . " text=$text");
 272         my ($delimiter, $record_delim) = find_delimiter($type);
 273         my $db = $Vend::Database{$table}
 274                 or die ("Non-existent table '$table'.\n");
 275         $db = $db->ref();
 276
 277         my @columns;
 278         @columns = ($db->columns());
 279
 280         if($options->{'continue'}) {
 281                 $options->{CONTINUE} = uc $options->{'continue'};
 282                 $options->{NOTES_SEPARATOR} = uc $options->{separator}
 283                         if defined $options->{separator};
 284         }
 285
 286         my $sub = sub { return $db };
 287         my $now = time();
 288         my $fn = $Vend::Cfg->{ScratchDir} . "/import.$$.$now";
 289         $text =~ s/^\s+//;
 290         $text =~ s/\s+$//;
 291
 292         if($delimiter eq 'CSV') {
 293                 my $add = '"';
 294                 $add .= join '","', @columns;
 295                 $add .= '"';
 296                 $text = "$add\n$text";
 297         }
 298         else {
 299                 $options->{field_names} = \@columns;
 300                 $options->{delimiter} = $options->{DELIMITER} = $delimiter;
 301         }
 302
 303         if($options->{file}) {
 304                 $fn = $options->{file};
 305                 Vend::File::allowed_file($fn)
 306                         or die ::errmsg("No absolute file names like '%s' allowed.\n", $fn);
 307         }
 308         else {
 309                 # data is already in memory, do not create a temporary file
 310                 $options->{scalar_ref} = 1;
 311                 $fn = \$text;
 312         }
 313
 314         my $save = $/;
 315         local($/) = $record_delim if defined $record_delim;
 316
 317         $options->{Object} = $db;
 318
 319         ## This is where the actual import happens
 320         Vend::Table::Common::import_ascii_delimited($fn, $options);
 321
 322         $/ = $save;
 323         unlink $fn unless $options->{'file'} or $options->{scalar_ref};
 324         return 1;
 325 }
 326
 327 sub set_field {
 328     my ($db, $key, $field_name, $value, $append, $foreign) = @_;
 329
 330         $db = database_exists_ref($db);
 331     return undef unless defined $db->test_column($field_name);
 332
 333         $key = $db->foreign($key, $foreign)
 334                 if $foreign;
 335
 336         # Create it if it doesn't exist
 337         unless ($db->record_exists($key)) {
 338                 $db->set_row($key);
 339         }
 340         elsif ($append) {
 341                 $value = $db->field($key, $field_name) . $value;
 342         }
 343     return $db->set_field($key, $field_name, $value);
 344 }
 345
 346 sub product_row {
 347         my ($code) = @_;
 348         my $db = product_code_exists_ref($code) or return;
 349         return $db->row($code);
 350 }
 351
 352 sub product_row_hash {
 353         my ($code) = @_;
 354         my $db = product_code_exists_ref($code) or return;
 355         return $db->row_hash($code);
 356 }
 357
 358 sub product_field {
 359     my ($field_name, $code, $base) = @_;
 360 #::logDebug("product_field: name=$field_name code=$code base=$base");
 361         return database_field($Vend::OnlyProducts, $code, $field_name)
 362                 if $Vend::OnlyProducts;
 363 #::logDebug("product_field: onlyproducts=$Vend::OnlyProducts");
 364         my ($db);
 365     $db = product_code_exists_ref($code, $base || undef)
 366                 or return '';
 367 #::logDebug("product_field: exists db=$db");
 368     return "" unless defined $db->test_column($field_name);
 369     return $db->field($code, $field_name);
 370 }
 371
 372
 373 sub product_common {
 374     my ($field_name, $code, $emptyok) = @_;
 375 #::logDebug("product_field: name=$field_name code=$code base=$base");
 376         my $result;
 377         for(@{$Vend::Cfg->{ProductFiles}}) {
 378                 my $db = database_exists_ref($_)
 379                         or next;
 380                 next unless defined $db->test_column($field_name);
 381                 $result = database_field($db, $code, $field_name);
 382                 last if $emptyok or length($result);
 383         }
 384     return $result;
 385 }
 386
 387 my %T;
 388
 389 TAGBUILD: {
 390
 391         my @th = (qw!
 392
 393                 arg
 394                 /arg
 395                 control
 396                 /control
 397                 query
 398                 /query
 399
 400         ! );
 401
 402         my $tag;
 403         for (@th) {
 404                 $tag = $_;
 405                 s/(\w)/[\u$1\l$1]/g;
 406                 s/[-_]/[-_]/g;
 407                 $T{$tag} = "\\[$_";
 408         }
 409 }
 410
 411 sub column_index {
 412     my ($field_name) = @_;
 413         $Products = $Products->ref();
 414     return undef unless defined $Products->test_column($field_name);
 415     return $Products->column_index($field_name);
 416 }
 417
 418 sub column_exists {
 419     my ($field_name) = @_;
 420     return defined $Products->test_column($field_name);
 421 }
 422
 423 sub db_column_exists {
 424     my ($db,$field_name) = @_;
 425     return defined $db->test_column($field_name);
 426 }
 427
 428 sub close_database {
 429         my $name;
 430         undef $Products;
 431         while( ($name)  = each %Vend::Database ) {
 432         $Vend::Database{$name}->close_table()
 433                         unless defined $Vend::Cfg->{SaveDatabase}{$name};
 434                 delete $Vend::Database{$name};
 435         }
 436         undef %Vend::Table::DBI::DBI_connect_bad;
 437         undef %Vend::TransactionDatabase;
 438         undef %Vend::WriteDatabase;
 439         undef %Vend::Basefinder;
 440         undef $Vend::VarDatabase;
 441 }
 442
 443 sub database_ref {
 444         my $db = $_[0] || $Products;
 445         return $db->ref() if $db;
 446         return undef;
 447 }
 448
 449 ## PRODUCTS
 450
 451 # Read in the shipping file.
 452
 453 *read_shipping = \&Vend::Interpolate::read_shipping;
 454
 455 # Read in the sales tax file.
 456 sub read_salestax {
 457     my($code, $percent);
 458
 459         return unless $Vend::Cfg->{SalesTax};
 460         return if $Vend::Cfg->{SalesTax} eq 'multi';
 461         my $file = $Vend::Cfg->{Special}{'salestax.asc'};
 462         $file = Vend::File::catfile($Vend::Cfg->{ProductDir}, "salestax.asc")
 463                 unless $file;
 464
 465         $Vend::Cfg->{SalesTaxTable} = {};
 466
 467         my @lines = split /\n/, readfile($file);
 468     for(@lines) {
 469                 tr/\r//d;
 470                 ($code, $percent) = split(/\s+/, $_, 2);
 471                 $Vend::Cfg->{SalesTaxTable}->{"\U$code"} = $percent;
 472     }
 473
 474         if(not defined $Vend::Cfg->{SalesTaxTable}->{DEFAULT}) {
 475                 $Vend::Cfg->{SalesTaxTable}->{DEFAULT} = 0;
 476         }
 477
 478         1;
 479 }
 480
 481 my %Delimiter = (
 482         2 => ["\n", "\n\n"],
 483         3 => ["\n%%\n", "\n%%%\n"],
 484         4 => ["CSV","\n"],
 485         5 => ['|', "\n"],
 486         6 => ["\t", "\n"],
 487         7 => ["\t", "\n"],
 488         8 => ["\t", "\n"],
 489         10 => ["\t", "\n"],
 490         LINE => ["\n", "\n\n"],
 491         '%%%' => ["\n%%\n", "\n%%%\n"],
 492         '%%' => ["\n%%\n", "\n%%%\n"],
 493         CSV => ["CSV","\n"],
 494         PIPE => ['|', "\n"],
 495         TAB => ["\t", "\n"],
 496         "\t" => ["\t", "\n"],
 497         '|'  => ['|', "\n"],
 498         "\n%%\n" => ["\n%%\n", "\n%%%\n"],
 499
 500         );
 501
 502 sub find_delimiter {
 503         my ($type) = @_;
 504         $type = $type || 1;
 505         return @{$Delimiter{$type}}
 506                 if defined $Delimiter{$type};
 507         return;
 508 }
 509
 510 sub auto_delimiter {
 511         my ($fn) = @_;
 512         my $fdelim = "\t";
 513         my $rdelim = "\n";
 514         my $tried_plain;
 515         my $type;
 516         open(AUTODELIM, $fn)
 517                 or die errmsg("Cannot open database text source file %s: %s\n", $fn, $!);
 518         local ($/);
 519         $/ = "\n";
 520         while(<AUTODELIM>) {
 521                 my $line = $_;
 522                 chomp;
 523                 if(! $tried_plain and $_) {
 524                         s/[^\t|,]//g;
 525                         s/[ (=)]+//g;
 526                         m/(.)/;
 527                         my $char = $1;
 528                         if (/^\Q$char\E+$/) {
 529                                 ($fdelim, $rdelim) = ($char, "\n");
 530                                 last;
 531                         }
 532                 }
 533                 $tried_plain++ or next;
 534                 if($_ eq '%%') {
 535                         $type = '%%';
 536                         last;
 537                 }
 538                 elsif ($_ eq '') {
 539                         $type = 'LINE';
 540                         last;
 541                 }
 542         }
 543         close AUTODELIM;
 544         $type = 'CSV' if $fdelim eq ',';
 545         if($type and defined $Delimiter{$type}) {
 546                 ($fdelim, $rdelim) =  @{$Delimiter{$type}};
 547         }
 548         return ($fdelim, $rdelim);
 549 }
 550
 551 use vars '%db_config';
 552
 553 %db_config = (
 554 # SQL
 555                 'DBI_CompositeKey' => {
 556                                 qw/
 557                                         Extension                        sql
 558                                         RestrictedImport         1
 559                                         Class                Vend::Table::DBI_CompositeKey
 560                                 /
 561                                 },
 562                 'DBI' => {
 563                                 qw/
 564                                         Extension                        sql
 565                                         RestrictedImport         1
 566                                         Class                Vend::Table::DBI
 567                                 /
 568                                 },
 569 # END SQL
 570                 'SHADOW' => {
 571                                 qw/
 572                                         Class                Vend::Table::Shadow
 573                                 /
 574                                 },
 575                 'TRANSIENT' => {
 576                                 qw/
 577                                         Cacheable                        0
 578                                         Tagged_write             1
 579                                         Class                Vend::Table::InMemory
 580                                         Export_on_close          1
 581                                 /
 582                                 },
 583                 'MEMORY' => {
 584                                 qw/
 585                                         Cacheable                        1
 586                                         Tagged_write             1
 587                                         Class                Vend::Table::InMemory
 588                                 /
 589                                 },
 590                 'GDBM' => {
 591                                 qw/
 592                                         TableExtension           .gdbm
 593                                         Extension                        gdbm
 594                                         Tagged_write             1
 595                                         Class                Vend::Table::GDBM
 596                                 /
 597                                 },
 598                 'DB_FILE' => {
 599                                 qw/
 600                                         TableExtension           .db
 601                                         Extension                        db
 602                                         Tagged_write             1
 603                                         Class                Vend::Table::DB_File
 604                                 /
 605                 },
 606                 'SDBM' => {
 607                                 qw/
 608                                         TableExtension           .sdbm
 609                                         Extension                        sdbm
 610                                         Tagged_write             1
 611                                         Class                Vend::Table::SDBM
 612                                 /,
 613                                 FileExtensions  => [ qw/dir pag/ ],
 614                 },
 615 # LDAP
 616                 'LDAP' => {
 617                                 qw/
 618                                         RestrictedImport         1
 619                                         Extension                        ldap
 620                                         Class                            Vend::Table::LDAP
 621                                 /
 622                 },
 623 # END LDAP
 624         );
 625
 626 sub tie_database {
 627         my ($name, $data);
 628         if($Global::Database) {
 629                 copyref($Global::Database, $Vend::Cfg->{Database});
 630         }
 631
 632         my @tables = keys %{$Vend::Cfg->{Database}};
 633
 634         my @delayed;
 635         my $redone;
 636
 637         TIEDB: {
 638
 639                 foreach $name (@tables) {
 640                         $data = $Vend::Cfg->{Database}{$name} || {};
 641                         if(! $redone and $data->{MIRROR}) {
 642 #::logDebug("mirror database $name, delaying");
 643                                 $data->{HOT} = 1;
 644                                 push @delayed, $name;
 645                                 next;
 646                         }
 647                         if(! $data->{name}) {
 648                                 next;
 649                         }
 650                         if( $data->{type} > 6 or $data->{HOT} or $data->{IMPORT_ONCE} ) {
 651                                 eval {
 652                                         $Vend::Database{$name} = import_database($data);
 653                                 };
 654                                 if($@) {
 655                                                 my $msg = "table '%s' failed: %s";
 656                                                 $msg = errmsg($msg, $name, $@);
 657                                                 logError($msg);
 658                                 }
 659                         }
 660                         else {
 661                                 if($data->{GUESS_NUMERIC}) {
 662                                         my $dir = $data->{DIR} || $Vend::Cfg->{ProductDir};
 663                                         my $fn = Vend::Util::catfile( $dir, $data->{file} );
 664                                         my @fields = grep /\S/, split /\s+/, readfile("$fn.numeric");
 665                                         $data->{NUMERIC} = {};
 666                                         for(@fields) {
 667                                                 $data->{NUMERIC}{$_} = 1;
 668                                         }
 669                                 }
 670                                 my $class = $db_config{$data->{Class}}->{Class};
 671                                 $Vend::Database{$name} = new $class ($data);
 672                         }
 673                 }
 674
 675                 # So mirrors will not happen until after mirror source
 676                 if(@delayed) {
 677                         @tables = @delayed;
 678                         @delayed = ();
 679                         $redone = 1;
 680                         redo TIEDB;
 681                 }
 682
 683         }
 684         update_productbase();
 685 }
 686
 687 sub dummy_database {
 688         my ($name, $data);
 689     while (($name,$data) = each %{$Vend::Cfg->{Database}}) {
 690                 if (defined $Vend::Cfg->{SaveDatabase}{$name}) {
 691                         $Vend::Database{$name} = $Vend::Cfg->{SaveDatabase}{$name};
 692                         next;
 693                 }
 694                 my $class = $db_config{$data->{Class}}->{Class};
 695                 eval {
 696                 $Vend::Database{$name} =
 697                                 new $class ($data);
 698                 };
 699                 if($@) {
 700                         logGlobal("Error creating dummy database for $name: $@");
 701                 }
 702         }
 703         update_productbase();
 704 }
 705
 706 my $tried_import;
 707
 708 sub create_empty_txt {
 709         my ($obj, $database_txt, $delimiter, $record_delim) = @_;
 710         return if -f $database_txt;
 711         return unless $obj->{CREATE_EMPTY_TXT};
 712         my $ary;
 713         if($obj->{CREATE_EMPTY_TXT} =~ /[\s,]\w/) {
 714                 $ary = [ grep /\S/, split /[\s,]+/, $obj->{CREATE_EMPTY_TXT} ];
 715         }
 716         else {
 717                 $ary = $obj->{NAME};
 718         }
 719         unless (ref($ary) eq 'ARRAY') {
 720                 logError("Cannot create text file with no database NAME parameter and no field names in CREATE_EMPTY_TXT");
 721         }
 722         else {
 723                 $delimiter ||= "\t";
 724                 $record_delim ||= "\n";
 725                 my $line = join $obj->{DELIMITER}, @$ary;
 726                 $line .= $record_delim;
 727                 Vend::Util::writefile($database_txt, $line);
 728         }
 729         return;
 730 }
 731
 732 sub import_database {
 733     my ($obj, $dummy) = @_;
 734
 735
 736         my $database = $obj->{'file'};
 737         my $type     = $obj->{'type'};
 738         my $name     = $obj->{'name'};
 739 #       if($type == 9) {
 740 #my @caller = caller();
 741 #::logDebug ("enter import_database: dummy=$dummy");
 742 #::logDebug("opening table table=$database config=" . uneval($obj) . " caller=@caller");
 743 #
 744 #::logDebug ("database=$database type=$type name=$name obj=" . uneval($obj));
 745 #::logDebug ("database=$database type=$type name=$name obj=" . uneval($obj)) if $obj->{HOT};
 746 #
 747 #       }
 748         return $Vend::Cfg->{SaveDatabase}->{$name}
 749                 if defined $Vend::Cfg->{SaveDatabase}->{$name};
 750
 751         my ($delimiter, $record_delim, $change_delimiter, $cacheable);
 752         my ($base,$path,$tail,$dir,$database_txt);
 753
 754         die "import_database: No database name!\n"
 755                 unless $database;
 756
 757
 758         my $database_dbm;
 759         my $new_database_dbm;
 760         my $table_name;
 761         my $new_table_name;
 762         my $class_config;
 763         my $db;
 764
 765         my $no_import = defined $Vend::Cfg->{NoImport}->{$name} || $obj->{NO_IMPORT};
 766
 767         if (defined $Vend::ForceImport{$name}) {
 768                 undef $no_import;
 769                 delete $Vend::ForceImport{$name};
 770         }
 771
 772         $base = $obj->{'name'};
 773         $dir = $obj->{DIR} if defined $obj->{DIR};
 774
 775         if ($obj->{OrigClass}) {
 776                 my $ref = $db_config{$obj->{OrigClass} || $Global::Default_database};
 777                 $class_config = {%$ref};
 778                 $class_config->{Class} = $db_config{$obj->{Class}}->{Class};
 779                 $class_config->{OrigClass} = $obj->{OrigClass};
 780         } else {
 781                 $class_config = $db_config{$obj->{Class} || $Global::Default_database};
 782         }
 783
 784 #::logDebug ("params=$database_txt path='$path' base='$base' tail='$tail' dir='$dir'") if $type == 9;
 785         $table_name     = $name;
 786         my $export;
 787
 788   IMPORT: {
 789         last IMPORT if $no_import and $obj->{DIR};
 790 #::logDebug ("no_import_check: once=$obj->{IMPORT_ONCE} dir=$obj->{DIR}");
 791         last IMPORT if defined $obj->{IMPORT_ONCE} and $obj->{DIR};
 792 #::logDebug ("first no_import_check: passed") if $type == 9;
 793
 794     $database_txt = $database;
 795
 796         ($base,$path,$tail) = fileparse $database_txt, '\.[^/.]+$';
 797
 798         if(Vend::Util::file_name_is_absolute($database_txt)) {
 799                 unless (allowed_file($database_txt)) {
 800                         my $msg = errmsg(
 801                                                         "Security violation, trying to import %s",
 802                                                         $database_txt,
 803                                                         );
 804                         logError( $msg );
 805                         die "Security violation.\n";
 806                 }
 807                 $dir = $path;
 808         }
 809         else {
 810                 $dir = $obj->{DIR} || $Vend::Cfg->{ProductDir} || $Global::ConfigDir;
 811                 $database_txt = Vend::Util::catfile($dir,$database_txt);
 812         }
 813
 814         $obj->{DIR} = $dir;
 815
 816         $obj->{ObjectType} = $class_config->{Class};
 817
 818         my $dot = $obj->{HIDE_AUTO_FILES} ? '.' : '';
 819
 820         $obj->{AUTO_NUMBER_FILE} = Vend::File::make_absolute_file(
 821                 $obj->{AUTO_NUMBER_FILE} || "$dir/$dot$obj->{name}.autonumber"
 822         );
 823
 824         if($class_config->{Extension}) {
 825                 $database_dbm = Vend::Util::catfile(
 826                                                                                                 $dir,
 827                                                                                                 "$dot$base."     .
 828                                                                                                 $class_config->{Extension}
 829                                                                                         );
 830                 $new_database_dbm =  Vend::Util::catfile(
 831                                                                                                 $dir,
 832                                                                                                 "new_$base."     .
 833                                                                                                 $class_config->{Extension}
 834                                                                                         );
 835         }
 836
 837         if($class_config->{TableExtension}) {
 838                 $table_name     = $database_dbm;
 839                 $new_table_name = $new_database_dbm;
 840         }
 841         else {
 842                 $table_name = $new_table_name = $base;
 843         }
 844
 845         $cacheable = $class_config->{Cacheable} || undef;
 846
 847         if ($class_config->{RestrictedImport}) {
 848                 $obj->{db_file_extended} = $database_dbm;
 849                 if (
 850                         $Vend::Cfg->{NoImportExternal}
 851                         or -f $database_dbm
 852                         or (! $obj->{CREATE_EMPTY_TXT} and ! -f $database_txt)
 853                         )
 854                 {
 855                         $no_import = 1;
 856                 }
 857                 else {
 858                         open(Vend::Data::TMP, ">$new_database_dbm");
 859                         print Vend::Data::TMP "\n";
 860                         close(Vend::Data::TMP);
 861                 }
 862         }
 863
 864         if($obj->{MIRROR}) {
 865                 if($obj->{Mirror_complete}) {
 866                         $no_import = 1;
 867                 }
 868                 else {
 869 #::logDebug ("table $new_table_name: undeffing $database_dbm, hot=$obj->{HOT}");
 870                         undef $database_dbm;
 871                         undef $no_import;
 872                 }
 873         }
 874
 875         last IMPORT if $no_import;
 876 #::logDebug ("moving to import") if $type == 9;
 877
 878         $change_delimiter = $obj->{DELIMITER} if defined $obj->{DELIMITER};
 879
 880         my $txt_time;
 881         my $dbm_time;
 882     if (
 883                 ! defined $database_dbm
 884                 or ! -e $database_dbm
 885                 or $obj->{MIRROR}
 886         or ($txt_time = file_modification_time($database_txt, $obj->{PRELOAD}))
 887                                 >
 888            ($dbm_time = file_modification_time($database_dbm))
 889                 )
 890         {
 891         warn "Importing $obj->{'name'} table from $database_txt\n"
 892                         unless $Vend::Quiet;
 893
 894                 $type = 1 unless $type;
 895                 ($delimiter, $record_delim) = find_delimiter($change_delimiter || $type);
 896
 897                 if(! $delimiter) {
 898                         ($delimiter, $record_delim) = auto_delimiter($database_txt);
 899                 }
 900
 901                 $obj->{delimiter} = $obj->{DELIMITER} = $delimiter;
 902
 903                 my $save = $/;
 904
 905                 local($/) = $record_delim if defined $record_delim;
 906
 907                 if($obj->{CREATE_EMPTY_TXT}) {
 908                         create_empty_txt($obj, $database_txt, $delimiter, $record_delim);
 909                 }
 910
 911                 if($obj->{MIRROR}) {
 912                         $db = Vend::Table::Common::import_from_ic_db(
 913                                                         $database_txt,
 914                                                         $obj,
 915                                                         $new_table_name,
 916                                 );
 917                 }
 918                 else {
 919         $db = Vend::Table::Common::import_ascii_delimited(
 920                                                         $database_txt,
 921                                                         $obj,
 922                                                         $new_table_name,
 923                                 );
 924                 }
 925
 926                 $/ = $save;
 927                 if(defined $database_dbm) {
 928                         $db->close_table() if defined $db;
 929                         undef $db;
 930                         unlink $database_dbm if $Global::Windows;
 931                         if($class_config->{FileExtensions}) {
 932                                 open(TOUCH, ">>$database_dbm")
 933                                         or die "Couldn't freshen $database_dbm: $_";
 934                                 close TOUCH
 935                                         or die "Couldn't freshen $database_dbm: $_";
 936                                 for(@{$class_config->{FileExtensions}}) {
 937                                         my ($old, $new) = ("$new_database_dbm.$_", "$database_dbm.$_");
 938                                         rename($old, $new)
 939                                                 or die
 940                                                         "Couldn't move '$old' to '$new': $!\n";
 941                                 }
 942                         }
 943                         else {
 944                                 rename($new_database_dbm, $database_dbm)
 945                                         or die "Couldn't move '$new_database_dbm' to '$database_dbm': $!\n";
 946                         }
 947                 }
 948     }
 949         elsif ($obj->{AUTO_EXPORT} and $dbm_time > $txt_time) {
 950                 $obj->{export_now} = 1;
 951         }
 952
 953   }
 954
 955         my $read_only;
 956
 957         if($obj->{WRITE_CONTROL}) {
 958                 if($obj->{READ_ONLY}) {
 959                         $obj->{Read_only} = 1;
 960                 }
 961                 elsif($obj->{WRITE_ALWAYS}) {
 962                         $obj->{Read_only} = 0;
 963                 }
 964                 elsif($obj->{WRITE_CATALOG}) {
 965                         $obj->{Read_only} = $obj->{WRITE_CATALOG}{$Vend::Cat}
 966                                         ? (! defined $Vend::WriteDatabase{$name})
 967                                         : 1;
 968                 }
 969                 elsif(! defined $obj->{WRITE_TAGGED} or $obj->{WRITE_TAGGED}) {
 970                         $obj->{Read_only} = ! defined $Vend::WriteDatabase{$name};
 971                 }
 972         }
 973         else {
 974                 $obj->{Read_only} = ! defined $Vend::WriteDatabase{$name}
 975                         if $class_config->{Tagged_write};
 976         }
 977
 978         $obj->{Transactions} = 1 if $Vend::TransactionDatabase{$name};
 979
 980     if($class_config->{Extension}) {
 981
 982                 $obj->{db_file} = $table_name unless $obj->{db_file};
 983                 $obj->{db_text} = $database_txt unless $obj->{db_text};
 984                 no strict 'refs';
 985 #::logDebug("ready to try opening db $table_name") if ! $db;
 986                 eval {
 987                         if($MVSAFE::Safe) {
 988                 if (exists $Vend::Interpolate::Db{$class_config->{Class}}) {
 989                                     $db = $Vend::Interpolate::Db{$table_name}->open_table( $obj, $obj->{db_file} );
 990                 } else {
 991                     die errmsg("no access for database %s", $table_name);
 992                 }
 993                         }
 994                         else {
 995                                 $db = $class_config->{Class}->open_table( $obj, $obj->{db_file} );
 996                         }
 997                         $obj->{NAME} = $db->[$Vend::Table::Common::COLUMN_INDEX]
 998                                 unless defined $obj->{NAME};
 999 #::logDebug("didn't die but no db") if ! $db;
1000                 };
1001
1002 #::logDebug("db=$db, \$\!='$!' \$\@='$@' (" . length($@) . ")\n") if ! $db;
1003                 if($@) {
1004 #::logDebug("Dieing of $@");
1005                         die $@ unless $no_import;
1006                         die $@ if $tried_import++;
1007                         if(! -f $database_dbm) {
1008                                 $Vend::ForceImport{$obj->{name}} = 1;
1009                                 return import_database($obj);
1010                         }
1011                         die $@;
1012                 }
1013                 undef $tried_import;
1014 #::logDebug("Opening $obj->{name}: RO=$obj->{Read_only} WC=$obj->{WRITE_CONTROL} WA=$obj->{WRITE_ALWAYS}");
1015         }
1016
1017         if(defined $cacheable) {
1018                 $Vend::Cfg->{SaveDatabase}->{$name} = $db;
1019         }
1020
1021         $Vend::Basefinder{$db} = $name;
1022
1023         return $db;
1024 }
1025
1026 sub index_database {
1027         my($dbname, $opt) = @_;
1028
1029         return undef unless defined $dbname;
1030
1031         my $db;
1032         $db = database_exists_ref($dbname)
1033                 or do {
1034                         logError("Vend::Data export: non-existent database %s", $dbname);
1035                         return undef;
1036                 };
1037
1038         $db = $db->ref();
1039
1040         my $ext = $opt->{extension} || 'idx';
1041
1042         my $db_fn = $db->config('db_file');
1043         my $bx_fn = $opt->{basefile} || $db->config('db_text');
1044         my $ix_fn = "$bx_fn.$ext";
1045         my $type  = $opt->{type} || $db->config('type');
1046
1047 #::logDebug(
1048 #       "dbname=$dbname db_fn=$db_fn bx_fn=$bx_fn ix_fn=$ix_fn\n" .
1049 #       "options: " . uneval($opt) . "\n"
1050 #       );
1051
1052         if(             ! -f $bx_fn
1053                                 or
1054                         file_modification_time($db_fn)
1055                                 >
1056             file_modification_time($bx_fn)              )
1057         {
1058                 export_database($dbname, $bx_fn, $type);
1059         }
1060
1061         return if $opt->{export_only};
1062
1063         if(             -f $ix_fn
1064                                 and
1065                         file_modification_time($ix_fn)
1066                                 >=
1067             file_modification_time($bx_fn)              )
1068         {
1069                 # We didn't need to index if got here
1070                 return;
1071         }
1072
1073         if(! $opt->{spec}) {
1074                 $opt->{fn} = $opt->{fn} || $opt->{fields} || $opt->{col} || $opt->{columns};
1075                 my $key = $db->config('KEY');
1076                 my @fields = grep $_ ne $key, split /[\0,\s]+/, $opt->{fn};
1077                 my $sort = join ",", @fields;
1078                 if(! $opt->{fn}) {
1079                         logError(errmsg("index attempted on table '%s' with no fields, no search spec", $dbname));
1080                         return undef;
1081                 }
1082                 $opt->{spec} = <<EOF;
1083 ra=1
1084 rf=$opt->{fn}
1085 tf=$sort
1086 EOF
1087         }
1088
1089         my $scan = Vend::Interpolate::escape_scan($opt->{spec});
1090         $scan =~ s:^scan/::;
1091
1092         my $c = {
1093                                 mv_list_only        => 1,
1094                                 mv_search_file          => $bx_fn,
1095                         };
1096
1097         Vend::Scan::find_search_params($c, $scan);
1098
1099         $c->{mv_matchlimit} = 100000
1100                 unless defined $c->{mv_matchlimit};
1101         my $f_delim = $c->{mv_return_delim} || "\t";
1102         my $r_delim = $c->{mv_record_delim} || "\n";
1103
1104         my @fn;
1105         if($c->{mv_return_fields}) {
1106                 @fn = split /\s*[\0,]+\s*/, $c->{mv_return_fields};
1107         }
1108
1109 #::logDebug( "search options: " . uneval($c) . "\n");
1110
1111         open(Vend::Data::INDEX, "+<$ix_fn") or
1112                 open(Vend::Data::INDEX, "+>$ix_fn") or
1113                         die "Couldn't open $ix_fn: $!\n";
1114         lockfile(\*Vend::Data::INDEX, 1, 1)
1115                 or die "Couldn't exclusive lock $ix_fn: $!\n";
1116         open(Vend::Data::INDEX, "+>$ix_fn") or
1117                 die "Couldn't write $ix_fn: $!\n";
1118
1119         if(@fn) {
1120                 print INDEX " ";
1121                 print INDEX join $f_delim, @fn;
1122                 print INDEX $r_delim;
1123         }
1124
1125         my $ref = Vend::Scan::perform_search($c);
1126         for(@$ref) {
1127                 print INDEX join $f_delim, @$_;
1128                 print INDEX $r_delim;
1129         }
1130
1131         unlockfile(\*Vend::Data::INDEX)
1132                 or die "Couldn't unlock $ix_fn: $!\n";
1133         close(Vend::Data::INDEX)
1134                 or die "Couldn't close $ix_fn: $!\n";
1135         return 1 if $opt->{show_status};
1136         return;
1137 }
1138
1139 sub export_database {
1140         my($db, $file, $type, $opt) = @_;
1141         return undef unless defined $db;
1142
1143         my (@data, $field, $delete);
1144
1145         $field  = $opt->{field}         if $opt->{field};
1146         $delete = $opt->{delete}                if $opt->{delete};
1147
1148         $db = database_exists_ref($db)
1149                 or do {
1150                         logError("Vend::Data export: non-existent database %s" , $db);
1151                         return undef;
1152                 };
1153
1154         $db = $db->ref();
1155
1156         if ($Vend::Cfg->{NoExportExternal} and !$opt->{force}) {
1157                 # Skip export only for "external" tables (currently SQL and LDAP),
1158                 # just like NoImportExternal does
1159                 my $class = $db->config('Class');
1160                 my $class_config = $db_config{$class || $Global::Default_database};
1161                 return 1 if $class_config->{RestrictedImport};
1162         }
1163
1164         my $table_name = $db->config('name');
1165
1166         return 1 if $Vend::Cfg->{NoExport}{$table_name} and !$opt->{force};
1167
1168         my $qual;
1169         if($qual = $opt->{where}) {
1170                 if(ref $qual) {
1171                         my @out;
1172                         for(keys %$qual) {
1173                                 my $val = $db->quote($qual->{$_}, $_);
1174                                 push @out, "$_ = $val";
1175                         }
1176                         $qual = 'WHERE ' . join(" AND ", @out);
1177                 }
1178                 elsif($qual !~ /^\s*where\s+/i) {
1179                         $qual = "WHERE $qual";
1180                 }
1181         }
1182
1183         my $notes;
1184         if("\U$type" eq 'NOTES') {
1185                 $type = 2;
1186                 $notes = 1;
1187         }
1188
1189         my ($delim, $record_delim) = find_delimiter($type || $db->config('type'));
1190         $delim or ($delim, $record_delim) = find_delimiter($db->config('DELIMITER'));
1191         $delim or ($delim, $record_delim) = find_delimiter('TAB');
1192
1193         $file = $file || $db->config('file');
1194         my $dir = $db->config('DIR');
1195
1196         $file = Vend::Util::catfile( $dir, $file)
1197                 unless Vend::Util::file_name_is_absolute($file);
1198
1199         my @cols = $db->columns();
1200
1201         my ($notouch, $nuke);
1202         if ($field and ! $delete) {
1203 #::logDebug("Trying for add field=$field delete=$delete");
1204                 if($db->column_exists($field)) {
1205                         logError(
1206                                 "Can't define column '%s' twice in table '%s'",
1207                                 $field,
1208                                 $table_name,
1209                         );
1210                         return undef;
1211                 }
1212                 logError("Adding column %s to table %s" , $field, $table_name);
1213                 push @cols, $field;
1214                 $notouch = 1;
1215         }
1216         elsif ($field) {
1217 #::logDebug("Trying for delete field=$field delete=$delete");
1218                 if(! $db->column_exists($field)) {
1219                         logError(
1220                                 "Can't delete non-existent column '%s' in table '%s'",
1221                                 $field,
1222                                 $table_name,
1223                         );
1224                         return undef;
1225                 }
1226                 logError("Deleting column %s from table %s" , $field, $table_name);
1227                 my @new = @cols;
1228                 @cols = ();
1229                 my $i = 0;
1230                 for(@new) {
1231                         unless ($_ eq $field) {
1232                                 push @cols, $_;
1233                         }
1234                         else {
1235                                 $nuke = $i;
1236                                 $notouch = 1;
1237                                 logError("Deleting field %s" , $_ );
1238                         }
1239                         $i++;
1240                 }
1241         }
1242
1243         my $tempdata;
1244         open(EXPORT, "+<$file") or
1245            open(EXPORT, "+>$file") or
1246                         die "Couldn't open $file: $!\n";
1247         lockfile(\*EXPORT, 1, 1)
1248                 or die "Couldn't exclusive lock $file: $!\n";
1249         open(EXPORT, "+>$file") or
1250                 die "Couldn't write $file: $!\n";
1251
1252 #::logDebug("EXPORT_SORT=" . $db->config('EXPORT_SORT'));
1253         if($opt->{sort} ||= $db->config('EXPORT_SORT')) {
1254 #::logDebug("Found EXPORT_SORT=$opt->{sort}");
1255                 my ($sort_field, $sort_option) = split /:/, $opt->{sort};
1256 #::logDebug("Found sort_field=$sort_field sort_option=$sort_option");
1257                 $db->sort_each($sort_field, $sort_option);
1258         }
1259
1260         if($delim eq 'CSV') {
1261                 $delim = '","';
1262                 print EXPORT '"';
1263                 print EXPORT join $delim, @cols;
1264                 print EXPORT qq%"\n%;
1265                 while( (undef, @data) = $db->each_record($qual) ) {
1266                         print EXPORT '"';
1267                         splice(@data, $nuke, 1) if defined $nuke;
1268                         $tempdata = join $delim, @data;
1269                         $tempdata =~ tr/\n/\r/;
1270                         print EXPORT $tempdata;
1271                         print EXPORT qq%"\n%;
1272                 }
1273         }
1274         elsif ($delim eq "\n" and $notes || $db->config('CONTINUE') eq 'NOTES') {
1275                 my $sep;
1276                 my $nf_col;
1277                 my $nf;
1278                 if($db->config('CONTINUE') eq 'NOTES') {
1279                         $sep    = $db->config('NOTES_SEPARATOR');
1280                         $nf_col = $#cols;
1281                         $nf             = pop @cols;
1282                 }
1283                 else {
1284                         $sep = $opt->{notes_separator} || "\f";
1285                         $nf = $opt->{notes_field} || 'notes_field';
1286                         for( my $i = 0; $i < @cols; $i++ ) {
1287                                 next unless $cols[$i] eq $nf;
1288                                 $nf_col = $i;
1289                                 last;
1290                         }
1291                         $nf_col = scalar @cols if ! defined $nf_col;
1292                         splice(@cols, $nf_col, 1);
1293                 }
1294                 print EXPORT join "\n", @cols;
1295                 print EXPORT "\n$nf $sep\n\n";
1296                 my $i;
1297                 while( (undef, @data) = $db->each_record($qual) ) {
1298                         splice(@data, $nuke, 1) if defined $nuke;
1299                         my $nd = splice(@data, $nf_col, 1);
1300                         # Yes, we don't want the last field yet. 8-)
1301                         for($i = 0; $i < $#data; $i++) {
1302                                 next if $data[$i] eq '';
1303                                 $data[$i] =~ tr/\n/\r/;
1304                                 print EXPORT
1305                                         "$cols[$i]: $data[$i]\n" unless $data[$i] eq '';
1306                         }
1307                         print EXPORT "\n$nd\n$sep\n";
1308                 }
1309         }
1310         elsif($record_delim eq "\n") {
1311                 print EXPORT join $delim, @cols;
1312                 print EXPORT $record_delim;
1313                 my $detab = ($delim eq "\t") ? 1 : 0;
1314                 if(defined $nuke) {
1315                         while( (undef, @data) = $db->each_record($qual) ) {
1316                                 splice(@data, $nuke, 1);
1317                                 if ($detab) { s/\t/ /g for @data; }
1318                                 $tempdata = join $delim, @data;
1319                                 $tempdata =~ s/\r?\n/\r/g;
1320                                 print EXPORT $tempdata, $record_delim;
1321                         }
1322                 }
1323                 else {
1324                         while( (undef, @data) = $db->each_record($qual) ) {
1325                                 if ($detab) { s/\t/ /g for @data; }
1326                                 $tempdata = join $delim, @data;
1327                                 $tempdata =~ s/\r?\n/\r/g;
1328                                 print EXPORT $tempdata, $record_delim;
1329                         }
1330                 }
1331         }
1332         else {
1333                 print EXPORT join $delim, @cols;
1334                 print EXPORT $record_delim;
1335                 my $detab = ($delim eq "\t" or $record_delim eq "\t") ? 1 : 0;
1336                 while( (undef, @data) = $db->each_record($qual) ) {
1337                         splice(@data, $nuke, 1) if defined $nuke;
1338                         if ($detab) { s/\t/ /g for @data; }
1339                         print EXPORT join($delim, @data);
1340                         print EXPORT $record_delim;
1341                 }
1342         }
1343         unlockfile(\*EXPORT)
1344                 or die "Couldn't unlock $file: $!\n";
1345         close(EXPORT)
1346                 or die "Couldn't close $file: $!\n";
1347         if(defined $notouch) {
1348                 my $f = $db->config('db_file_extended');
1349                 unlink $f if $f;
1350         }
1351         else {
1352                 $db->touch();
1353         }
1354         if (my $subs = $db->config('POSTEXPORT')) {
1355                 # Make a copy of the options once to hand off to each sub.
1356                 my $options = { %$opt, delim => $delim, record_delim => $record_delim };
1357                 for my $name (@$subs) {
1358                         my $sub = $Vend::Cfg->{Sub}{$name} || $Global::GlobalSub->{$name}
1359                                 or do {
1360                                         logError("Unknown POSTEXPORT sub '%s' on database '%s'.", $name, $db->name);
1361                                         next;
1362                                 };
1363                         $sub->($db->name, $file, $options)
1364                                 or logError("Failed call to POSTEXPORT sub '%s' on database '%s'!", $name, $db->name);
1365                 }
1366         }
1367         1;
1368 }
1369
1370 my $opt_remap = 0;
1371 my %opt_map;
1372
1373 sub remap_options {
1374         return if not defined $opt_remap;
1375         my $record = shift;
1376         if($opt_remap and $record) {
1377                 my %rec;
1378                 my @del;
1379                 my ($k, $v);
1380                 while (($k, $v) = each %opt_map) {
1381                         next unless defined $record->{$v};
1382                         $rec{$k} = $record->{$v};
1383                         push @del, $v;
1384                 }
1385                 delete @{$record}{@del};
1386                 @{$record}{keys %rec} = (values %rec);
1387         }
1388         elsif($::Variable->{MV_OPTION_TABLE_MAP}) {
1389                 $opt_remap = $::Variable->{MV_OPTION_TABLE_MAP};
1390                 $opt_remap =~ s/^\s+//;
1391                 $opt_remap =~ s/\s+$//;
1392                 map { m{(.*?)=(.*)} and $opt_map{$2} = $1} split /[\0,\s]+/, $opt_remap;
1393                 $opt_remap = 1;
1394                 remap_options($record);
1395         }
1396         else {
1397                 undef $opt_remap;
1398         }
1399         return;
1400 }
1401
1402 sub chain_cost {
1403         my ($item, $raw) = @_;
1404
1405         return $raw if $raw =~ /^[\d.]*$/;
1406         my $price;
1407         my $final = 0;
1408         my $its = 0;
1409         my @p;
1410         $raw =~ s/^\s+//;
1411         $raw =~ s/\s+$//;
1412         if($raw =~ /^\[\B/ and $raw =~ /\]$/) {
1413                 my $ref = Vend::Interpolate::tag_calc($raw);
1414                 @p = ref $ref ? @{$ref} : $ref;
1415         }
1416         else {
1417                 @p = Text::ParseWords::shellwords($raw);
1418         }
1419         if(scalar @p > ($::Limit->{chained_cost_levels} || 64)) {
1420                 logError('Too many chained cost levels for item ' .  uneval($item) );
1421                 return undef;
1422         }
1423
1424 #::logDebug("chain_cost item = " . uneval ($item) . "\np=" . uneval(\@p) );
1425         my ($chain, $percent);
1426         my $passed_key;
1427         my $want_key;
1428 CHAIN:
1429         foreach $price (@p) {
1430                 next if ! length($price);
1431                 if($its++ > ($::Limit->{chained_cost_levels} || 64)) {
1432                         logError('Too many chained cost levels for item ' .  uneval($item) );
1433                         last CHAIN;
1434                 }
1435                 $price =~ s/^\s+//;
1436                 $price =~ s/\s+$//;
1437                 if ($want_key) {
1438                         $passed_key = $price;
1439                         undef $want_key;
1440                         next CHAIN;
1441                 }
1442                 if ($price =~ s/^;//) {
1443                         next if $final;
1444                 }
1445                 $price =~ s/,$// and $chain = 1;
1446                 if ($price =~ /^ \(  \s*  (.*)  \s* \) \s* $/x) {
1447                         $price = $1;
1448                         $want_key = 1;
1449                 }
1450                 if ($price =~ s/^([^-+\d.].*)//s) {
1451                         my $mod = $1;
1452                         if($mod =~ s/^\$(\d|$)/$1/) {
1453                                 $price = $item->{mv_price} || $mod;
1454                                 if($price =~ /^\s*free\s*$/i) {
1455                                         $final = 0;
1456                                         last CHAIN;
1457                                 }
1458                                 redo CHAIN;
1459                         }
1460                         elsif($mod =~ /^(\w*):([^:]*)(?::(\S*))?$/) {
1461                                 my ($table, $field, $key) = ($1, $2, $3);
1462 #::logDebug("field begins as '$field'");
1463                                 $field = $Vend::Cfg->{PriceDefault} if ! $field;
1464                                 if($passed_key) {
1465                                         (! $key   and $key   = $passed_key)
1466                                                 or
1467                                         (! $field and $field = $passed_key)
1468                                                 or
1469                                         (! $table and $table = $passed_key);
1470                                         undef $passed_key;
1471                                 }
1472                                 $table = $item->{mv_ib} || $Vend::Cfg->{ProductFiles}[0]
1473                                         if ! $table;
1474                                 if($key and defined $item->{$key}) {
1475                                         $key = $item->{$key};
1476                                 }
1477                                 my @breaks;
1478                                 if($field =~ /,/ || $field =~ /\.\./) {
1479                                         my (@tmp) = split /,/, $field;
1480                                         for(@tmp) {
1481                                                 if (/(.+?)(\d+)\.\.+.+?(\d+)/) {
1482                                                         push @breaks, map { "$1$_" } $2 .. $3;
1483                                                 }
1484                                                 else {
1485                                                         push @breaks, $_;
1486                                                 }
1487                                         }
1488                                 }
1489                                 if(@breaks) {
1490 #::logDebug("price breaks: " . join(',', @breaks));
1491                                         my $quantity;
1492                                         my $attribute;
1493                                         $attribute = shift @breaks  if $breaks[0] !~ /\d/;
1494                                         if (! $attribute || ! $item->{$attribute}) {
1495                                                 $quantity = $item->{quantity};
1496                                         }
1497                                         else {
1498                                                 my $regex;
1499                                                 $regex = $item->{$attribute}
1500                                                         unless $item->{$attribute} =~ /^[\d.]+$/;
1501                                                 $quantity = Vend::Util::tag_nitems(
1502                                                                         undef,
1503                                                                         {
1504                                                                                 qualifier => $attribute,
1505                                                                                 compare   => $regex || undef,
1506                                                                         },
1507                                                 );
1508                                         }
1509
1510                                         $field = shift @breaks;
1511                                         my $test = $field;
1512                                         $test =~ s/\D+//;
1513                                         redo CHAIN if $quantity < $test;
1514
1515                                         my $t = $table || $item->{mv_ib} || $Vend::Cfg->{ProductFiles}[0];
1516                                         my $k = $key || $item->{code};
1517                                         my $row = database_row($t, $k);
1518 #::logDebug("database reference to price breaks found table=$t key=$k row=" . ::uneval($row));
1519                                         redo CHAIN if ref $row ne 'HASH';
1520
1521                                         my $keep;
1522                                         $keep = $row->{$field}
1523                                                 if length($row->{$field}) && $row->{$field} != 0;
1524                                         for (@breaks) {
1525                                                 next unless exists $row->{$_};
1526                                                 $test = $_;
1527                                                 $test =~ s/\D+//;
1528                                                 last if $test > $quantity;
1529                                                 $field = $_;
1530                                                 $keep = $row->{$field} if $row->{$field} != 0;
1531                                         }
1532 #::logDebug("price=$keep") if $keep;
1533                                         $price = $keep if $keep;
1534                                         redo CHAIN;
1535                                 }
1536                                 $price = database_field(
1537                                                 ($table || $item->{mv_ib} || $Vend::Cfg->{ProductFiles}[0]),
1538                                                 ($key || $item->{code}),
1539                                                 $field
1540                                                 );
1541 #::logDebug("database reference found table=$table field=$field key=$key|$item->{$key}|$item->{code} price=$price");
1542                                 redo CHAIN;
1543                         }
1544                         elsif ($mod =~ s/(\w+)=(.*)//) {
1545                                 my $tag = $1;
1546                                 my(@args) = split /:/, $2;
1547                                 my $sub =   # $intrinsic_price{$tag} ||
1548                                                         $Vend::Cfg->{Sub}{$tag} || $Global::GlobalSub->{$tag};
1549
1550                                 my %i = %$item;
1551
1552                                 for(@args) {
1553                                         my($k, $v) = split /=/, $_;
1554                                         $i{$k} = $v;
1555                                 }
1556
1557                                 $i{final} = $final;
1558                                 $i{passed_key} = $passed_key if $passed_key;
1559
1560                                 if ($sub) {
1561                                         $price = $sub->(\%i);
1562                                 }
1563                                 else {
1564                                         $price = Vend::Tags->$tag(\%i);
1565                                 }
1566                                 redo CHAIN;
1567                         }
1568                         elsif ($mod =~ s/^[&]//) {
1569                                 $Vend::Interpolate::item = $item;
1570                                 $Vend::Interpolate::s = $final;
1571                                 $Vend::Interpolate::q = $item->{quantity};
1572                                 $price = Vend::Interpolate::tag_calc($mod);
1573                                 undef $Vend::Interpolate::item;
1574                                 redo CHAIN;
1575                         }
1576                         elsif ($mod =~ s/^=([\d.]*)=([^=]+)//) {
1577                                 $final += $1 if $1;
1578                                 my ($attribute, $table, $field, $key) = split /:/, $2;
1579                                 if($attribute) {
1580                                         $key = $field ? $item->{$attribute} : $item->{code}
1581                                                 unless $key;
1582                                         $price = database_field( ( $table ||
1583                                                                                                 $item->{mv_ib} ||
1584                                                                                                 $Vend::Cfg->{ProductFiles}[0]),
1585                                                                                         $key,
1586                                                                                         ($field || $item->{$attribute})
1587                                                                         );
1588                                         redo CHAIN;
1589                                 }
1590                                 elsif ($table) {
1591 #::logDebug("before option_cost price=$price final=$final");
1592                                         my ($p, $f);
1593                                         ($p, $f) = Vend::Options::option_cost($item, $table, $final);
1594                                         $final = $f if defined $f;
1595                                         $price = $p || '';
1596 #::logDebug("option_cost returned p=$p f=$f, price=$price final=$final");
1597                                         redo CHAIN;
1598                                 }
1599                         }
1600                         elsif($mod =~ /^\s*[[_]+/) {
1601                                 $::Scratch->{mv_item_object} = $Vend::Interpolate::item = $item;
1602                                 $Vend::Interpolate::s = $final;
1603                                 $Vend::Interpolate::q = $item->{quantity};
1604                                 $price = Vend::Interpolate::interpolate_html($mod);
1605                                 undef $::Scratch->{mv_item_object};
1606                                 undef $Vend::Interpolate::item;
1607                                 redo CHAIN;
1608                         }
1609                         elsif($mod =~ s/^>>+//) {
1610                                 # This can point to a new mode for shipping
1611                                 # or taxing
1612                                 $final = $mod;
1613                                 last CHAIN;
1614                         }
1615                         else {
1616                                 $passed_key = $mod;
1617                                 next CHAIN;
1618                         }
1619                 }
1620                 elsif($price =~ s/%$//) {
1621                         $price = $final * ($price / 100);
1622                 }
1623                 elsif($price =~ s/\s*\*$//) {
1624                         $final *= $price;
1625                         undef $price;
1626                 }
1627                 $final += $price if $price;
1628                 last if ($final and !$chain);
1629                 undef $chain;
1630                 undef $passed_key;
1631 #::logDebug("chain_cost intermediate '$final'");
1632         }
1633 #::logDebug("chain_cost returning '$final'");
1634         return $final;
1635 }
1636
1637
1638 sub item_price {
1639         my($item, $quantity, $noformat) = @_;
1640
1641 #::logDebug("item_price initial call: " . (ref $item ? $item->{code} : $item));
1642
1643         return $item->{mv_cache_price}
1644                 if ! $quantity and defined $item->{mv_cache_price};
1645
1646         $item = { 'code' => $item } unless ref $item;
1647         $item->{quantity} = 1 if ! defined $item->{quantity};
1648
1649         if(     !       $item->{mv_ib}
1650                 and     $Vend::Cfg->{AutoModifier}
1651                 and     $item->{mv_ib} = product_code_exists_tag($item->{code})
1652                 )
1653         {
1654                 foreach my $i (@{$Vend::Cfg->{AutoModifier}}) {
1655                         my $attr;
1656                         my ($table,$key,$foreign) = split /:+/, $i, 3;
1657
1658                         if($table =~ /=/) {
1659                                 ($attr, $table) = split /\s*=\s*/, $table, 2;
1660                         }
1661
1662                         if(! $key and ! $foreign) {
1663                                 $attr ||= $table;
1664                                 $item->{$attr} = item_common($item, $table);
1665                                 next;
1666                         }
1667
1668                         unless ($key) {
1669                                 $key = $table;
1670                                 $table = $item->{mv_ib};
1671                         }
1672
1673                         $attr ||= $key;
1674                         $table ||= $Vend::Cfg->{ProductFiles}[0];
1675
1676                         my $select = $foreign ? $item->{$foreign} : $item->{code};
1677                         $select ||= $item->{code};
1678
1679 #::logDebug("attr=$attr table=$table key=$key select=$select foreign=$foreign");
1680                         $item->{$attr} = ::tag_data($table, $key, $select);
1681 #::logDebug("item->$attr=$item->{$attr}");
1682                 }
1683 #::logDebug("item=" . ::uneval($item));
1684         }
1685
1686         my $master;
1687
1688         my @items;
1689
1690         if ($item->{mv_mp}) {
1691                 return 0 if $item->{mv_si};
1692                 $master = $item;
1693                 my $mv_mp = $item->{mv_mi}
1694                         or do {
1695                                 logError("Bad modular item %s: ", uneval_it($item));
1696                                 return 0;
1697                         };
1698                 for(@$Vend::Items) {
1699                         next unless $_->{mv_si} and $_->{mv_mi} eq $mv_mp;
1700 #::logDebug("pushing item $_->{code}, mv_mi=$item->{mv_mi}, mv_mp=$item->{mv_mp}, mv_si=$item->{mv_si}");
1701                         push @items, $_;
1702                 }
1703         }
1704
1705
1706         my $final = 0;
1707         do {
1708                 my $price;
1709
1710                 if ($Vend::Cfg->{PriceField}) {
1711                         my $base;
1712                         if (not $base = $item->{mv_ib}) {
1713                                 $base = product_code_exists_tag($item->{code})
1714                                         or ($Vend::Cfg->{OnFly} && 'mv_fly')
1715                                         or return undef;
1716                         }
1717                         $price = database_field($base, $item->{code}, $Vend::Cfg->{PriceField});
1718                 }
1719
1720 #::logDebug("price for item before chain $item->{code}=$price PriceField=$Vend::Cfg->{PriceField}");
1721                 $price = chain_cost($item,$price || $Vend::Cfg->{CommonAdjust});
1722                 if($Vend::Cfg->{PriceDivide} == 0) {
1723                         my $msg = "Locale %s PriceDivide non-numeric or zero [%s].";
1724                         $msg .= " Possibly bad locale data.",
1725                         logError(
1726                                 $msg,
1727                                 $::Scratch->{mv_currency} || $::Scratch->{mv_locale},
1728                                 $Vend::Cfg->{PriceDivide},
1729                         );
1730                         $Vend::Cfg->{PriceDivide} = 1;
1731                 }
1732                 $price = $price / $Vend::Cfg->{PriceDivide};
1733
1734                 $item->{mv_cache_price} = $price
1735                         if ! $quantity and exists $item->{mv_cache_price};
1736 #::logDebug("price for item $item->{code}=$price item=" . ::uneval_it($item)) if $price != 0;
1737                 $final += $price;
1738         } while ($item = shift @items);
1739 #::logDebug("#### final price for item $master->{code}=$final item=" . ::uneval($master)) if $master;
1740         $master->{mv_cache_price} = $final
1741                         if $master and ! $quantity and exists $master->{mv_cache_price};
1742 #::logDebug("final price in item $master->{code} is $master->{mv_cache_price}") if $master;
1743         return $final;
1744 }
1745
1746 sub item_category {
1747         my $item = shift;
1748         my $base = $Vend::Database{$item->{mv_ib}} || $Products;
1749         return database_field($base, $item->{code}, $Vend::Cfg->{CategoryField});
1750 }
1751
1752 sub item_description {
1753         my $item = shift;
1754         my $base = $Vend::Database{$item->{mv_ib}} || $Products;
1755         return database_field($base, $item->{code}, $Vend::Cfg->{DescriptionField});
1756 }
1757
1758 sub item_common {
1759         my ($item, $field, $emptyok) = @_;
1760         my $base = $item->{mv_ib};
1761         my %seen;
1762         my $res;
1763         foreach my $code ($item->{code}, $item->{mv_sku}) {
1764                 next if ! length($code);
1765                 for my $dbname ($base, @{$Vend::Cfg->{ProductFiles}} ) {
1766                         next if ! $dbname;
1767                         next if $seen{$dbname}++;
1768                         my $db = database_exists_ref($dbname)
1769                                 or next;
1770                         last unless defined $db->test_column($field);
1771                         $res = database_field($db, $code, $field);
1772                         return $res if $emptyok or length($res);
1773                 }
1774         }
1775 }
1776
1777 sub item_field {
1778         my ($item, $field) = @_;
1779         my $base = $Vend::Database{$item->{mv_ib}} || $Products;
1780         my $res = database_field($base, $item->{code}, $field);
1781         return $res if length($res);
1782         return database_field($base, $item->{mv_sku}, $field);
1783 }
1784
1785 sub item_subtotal {
1786         item_price($_[0]) * ($_[0]->{quantity} || 0);
1787 }
1788
1789 sub set_db {
1790         my ($base, $thing) = @_;
1791         return ($base, $thing) unless $thing =~ /^(\w+):+(.*)/;
1792         my $t = $1;
1793         my $c = $2;
1794
1795         # Security handled before this in update_data
1796         $Vend::WriteDatabase{$t} = 1;
1797
1798         my $db = database_exists_ref($t);
1799         return undef unless $db;
1800         return ($db->ref(), $c);
1801 }
1802
1803 ## Update the user-entered fields.
1804 sub update_data {
1805         my($key,$value);
1806         my @cgi_keys = keys %CGI::values;
1807     # Update a database record
1808         # Check to see if this is allowed
1809 #::logDebug("mv_data_enable=$::Scratch->{mv_data_enable}");
1810         if(! $::Scratch->{mv_data_enable}) {
1811                 logError(
1812                          "Attempted database update without permission, table=%s key=%s.",
1813                          $CGI::values{mv_data_table},
1814                          $CGI::values{$CGI::values{mv_data_key}},
1815                 );
1816                 return undef;
1817         }
1818         unless (defined $CGI::values{mv_data_table} and
1819                     defined $CGI::values{mv_data_key}      ) {
1820                 logError("Attempted database operation without table, fields, or key.\n" .
1821                                          "Table: '%s'\n" .
1822                                          "Fields:'%s'\n" .
1823                                          "Key:   '%s'\n",
1824                                          $CGI::values{mv_data_table},
1825                                          $CGI::values{mv_data_fields},
1826                                          $CGI::values{mv_data_key},
1827                                  );
1828
1829                 return undef;
1830         }
1831
1832         my $function    = lc (delete $CGI::values{mv_data_function});
1833         if($function eq 'delete' and ! delete $CGI::values{mv_data_verify}) {
1834                 logError("update_data: DELETE without VERIFY, abort");
1835                 return undef;
1836         }
1837         my $table               = $CGI::values{mv_data_table};
1838         my $prikey              = $CGI::values{mv_data_key};
1839         my $decode              = is_yes($CGI::values{mv_data_decode});
1840
1841         my $en_col;
1842 #::logDebug("data_enable=$::Scratch->{mv_data_enable}, checking");
1843         if($::Scratch->{mv_data_enable} =~ /^(\w+):(.*?):/s) {
1844                 # check for single key and possible set of columns
1845                 my $en_table = $1;
1846                 $en_col   = $2;
1847                 my $en_key   = $::Scratch->{mv_data_enable_key};
1848 #::logDebug("en_table=$en_table en_col=$en_col, en_key=$en_key, checking");
1849                 if(  $en_table ne $table
1850                          or
1851                          ($en_key and $CGI::values{$prikey} ne $en_key)
1852                         )
1853                 {
1854                         logError("Attempted database operation without permission:\n" .
1855                                                  "Permission: '%s' (key='$en_key')\n" .
1856                                                  "Table: '%s'\n" .
1857                                                  "Fields:'%s'\n" .
1858                                                  "Key:   '%s'\n",
1859                                                  $::Scratch->{mv_data_enable},
1860                                                  $CGI::values{mv_data_table},
1861                                                  $CGI::values{mv_data_fields},
1862                                                  $CGI::values{$CGI::values{mv_data_key}},
1863                                  );
1864                         return undef;
1865                 }
1866         }
1867
1868
1869         $Vend::WriteDatabase{$table} = 1;
1870
1871     my $base_db = database_exists_ref($table)
1872         or die "Not a defined database '$table': $!\n";
1873     $base_db = $base_db->ref();
1874
1875         my @fields              = grep $_ && $_ ne $prikey,
1876                                                 split /[\s\0,]+/, $CGI::values{mv_data_fields};
1877         unshift(@fields, $prikey);
1878
1879     my @file_fields = split /[\s\0,]+/, $CGI::values{mv_data_file_field};
1880     my @file_paths = split /\0/, $CGI::values{mv_data_file_path};
1881     my @file_name_from = split /\0/, $CGI::values{mv_data_file_name_from};
1882     my @file_oldfiles = split /\0/, $CGI::values{mv_data_file_oldfile};
1883
1884         if($en_col) {
1885                 $en_col =~ s/^\s+//;
1886                 $en_col =~ s/\s+$//;
1887                 my %col_present;
1888                 @col_present{ grep /\S/, split /[\s\0,]+/, $en_col } = ();
1889                 $col_present{$prikey} = 1;
1890                 for(@fields, $CGI::values{mv_blob_field}, $CGI::values{mv_blob_pointer}) {
1891                         next unless $_;
1892                         next if exists $col_present{$_};
1893                         next if /:/ and $::Scratch->{mv_data_enable} =~ / $_ /;
1894                         logError("Attempted database operation without permission:\n" .
1895                                                  "Permission: '%s'\n" .
1896                                                  "Table: '%s'\n" .
1897                                                  "Fields:'%s'\n" .
1898                                                  "Key:   '%s'\n",
1899                                                  $::Scratch->{mv_data_enable},
1900                                                  $CGI::values{mv_data_table},
1901                                                  $CGI::values{mv_data_fields},
1902                                                  $CGI::values{$CGI::values{mv_data_key}},
1903                                  );
1904                         return undef;
1905                 }
1906         }
1907         $function = 'update' unless $function;
1908
1909         my %data;
1910         my %sneakdata;
1911         for(@fields) {
1912                 $data{$_} = [];
1913         }
1914
1915         my $count;
1916         my $multi = $CGI::values{$prikey} =~ tr/\0/\0/;
1917         my $max = 0;
1918         my $min = 9999;
1919         my ($minname, $maxname);
1920
1921         while (($key, $value) = each %CGI::values) {
1922                 next unless defined $data{$key};
1923                 if($CGI::values{"mv_data_prep_$key"}) {
1924                         $value = Vend::Interpolate::filter_value(
1925                                                  $CGI::values{"mv_data_prep_$key"},
1926                                                  $value
1927                                                  );
1928                 }
1929                 $count = (@{$data{$key}} = split /\0/, $value, -1);
1930                 $max = $count, $maxname = $key if $count > $max;
1931                 $min = $count, $minname = $key if $count < $min;
1932         }
1933
1934         if( $multi and ($max - $min) > 1 and ! $CGI::values{mv_data_force}) {
1935                 logError("probable bad form -- number of values min=%s (%s) max=%s (%s)", $min, $minname, $max, $maxname);
1936                 return;
1937         }
1938
1939         my $autonumber;
1940 #::logDebug("function=$function auto_number=" . $base_db->config('_Auto_number'));
1941         if ($CGI::values{mv_data_auto_number}) {
1942                 $autonumber = 1;
1943                 my $ref = $data{$prikey};
1944                 while (scalar @$ref < $max) {
1945                         push @$ref, '';
1946                 }
1947                 $base_db->config('AUTO_NUMBER', '000001')
1948                         if ! $base_db->config('_Auto_number');
1949                 $CGI::values{mv_data_return_key} = $prikey
1950                         unless $CGI::values{mv_data_return_key};
1951         }
1952         elsif($function eq 'insert' and $base_db->config('_Auto_number') ) {
1953                         $autonumber = 1;
1954         }
1955 #::logDebug("autonumber=$autonumber");
1956
1957         my $multikey = $base_db->config('COMPOSITE_KEY');
1958
1959         if(@file_fields) {
1960                 my $Tag = new Vend::Tags;
1961                 my $acl_func;
1962                 my $outfile;
1963                 if($Vend::Session->{logged_in} and $Vend::admin) {
1964                         $acl_func = sub {
1965                                 return $Tag->if_mm('files', shift);
1966                         };
1967                 }
1968                 elsif($Vend::Session->{logged_in} and ! $Vend::admin) {
1969                         $acl_func = sub {
1970                                 my $file = shift;
1971                                 return 1 if $::Scratch->{$file} == 1;
1972                                 return $Tag->userdb(
1973                                                                 function => 'check_file_acl',
1974                                                                 location => $file,
1975                                                                 mode => 'w'
1976                                                                 );
1977                         };
1978                 }
1979                 else {
1980                         $acl_func = sub { return $::Scratch->{shift(@_)} == 1 }
1981                 }
1982
1983                 for (my $i = 0; $i < @file_fields; $i++) {
1984                         my $nm = $file_fields[$i];
1985
1986                         next if $nm =~ /__\d+$/;
1987                         my $dref;
1988                         my $dmain;
1989                         my $ntag = '';
1990                         if($nm =~ m{^(\d+)_} and $CGI::values{$nm}) {
1991                                 $ntag = $1;
1992                                 $ntag .= "_";
1993                                 $sneakdata{$nm}->[0] =  $CGI::values{$nm};
1994                                 for(qw/ mv_data_file_name_to_ mv_data_file_size_to_ /) {
1995                                         my $t = $_ . $nm;
1996                                         my $fld = $CGI::values{$t}
1997                                                 or next;
1998                                         $fld = "$ntag$fld";
1999                                         $sneakdata{$fld}->[0] = $CGI::values{$fld};
2000                                 }
2001                                 $dref = $sneakdata{$nm};
2002                                 $dmain = \%sneakdata;
2003                         }
2004                         else {
2005                                 $dref = $data{$nm};
2006                                 $dmain = \%data;
2007                         }
2008
2009                         unless (length($dref->[0])) {
2010                                 # no need for a file update
2011                                 if($file_oldfiles[$i]) {
2012                                         $dref->[0] = $file_oldfiles[$i];
2013                                 }
2014                                 next;
2015                         }
2016
2017                         # remove path components
2018                         $dref->[0] =~ s:.*/::;
2019                         $dref->[0] =~ s:.*\\::;
2020
2021                         if(my $switch = $file_name_from[$i]) {
2022                                 my $new;
2023                                 if($data{$switch} and $new = $data{$switch}->[0]) {
2024                                         my $ext = $dref->[0];
2025                                         if($ext =~ s/.*\.//) {
2026                                                 $dref->[0] = join '.', $new, $ext;
2027                                         }
2028                                         else {
2029                                                 $dref->[0] = $new;
2030                                         }
2031                                 }
2032                         }
2033
2034                         if (length ($file_paths[$i])) {
2035                                 # real file upload
2036                                 $outfile = join('/', $file_paths[$i], $dref->[0]);
2037                                 my $ok;
2038                                 if (-f $outfile) {
2039                                         eval {
2040                                                 $ok = $acl_func->($outfile);
2041                                         };
2042                                 } else {
2043                                         eval {
2044                                                 $ok = $acl_func->($file_paths[$i]);
2045                                         };
2046                                 }
2047                                 if (! $ok) {
2048                                         if($@) {
2049                                                 logError ("ACL function failed on '%s': %s", $outfile, $@);
2050                                         }
2051                                         else {
2052                                                 logError ("Not allowed to upload \"%s\"", $outfile);
2053                                         }
2054                                         next;
2055                                 }
2056                                 my $err;
2057                                 Vend::Interpolate::tag_value_extended(
2058                                                                                 $nm,
2059                                                                                 {
2060                                                                                         test => 'isfile'
2061                                                                                 }
2062                                                                                 )
2063                                         or do {
2064                                                  logError("%s is not a file (does form allow file upload?).", $dref->[0]);
2065                                                  next;
2066                                         };
2067                                 Vend::Interpolate::tag_value_extended(
2068                                                 $nm,
2069                                                 {
2070                                                         outfile => $outfile,
2071                                                         umask => $::Scratch->{mv_create_umask} || '022',
2072                                                         auto_create_dir => $::Scratch->{mv_auto_create_dir},
2073                                                         yes => '1',
2074                                                 }
2075                                         )
2076                                         or do {
2077                                                  logError("failed to write %s: %s", $outfile, $!);
2078                                                  next;
2079                                         };
2080                         }
2081                         else {
2082                                 # preparing to dump file contents into database column
2083                                 if(my $nfield = $CGI::values{"mv_data_file_name_to_$nm"}) {
2084                                         $dmain->{"$ntag$nfield"}->[0] = $dmain->{$nm}->[0];
2085                                 }
2086                                 $dmain->{$nm}->[0]
2087                                         = Vend::Interpolate::tag_value_extended ($nm,
2088                                                 {file_contents => 1});
2089                                 if(my $sfield = $CGI::values{"mv_data_file_size_to_$nm"}) {
2090                                         $dmain->{"$ntag$sfield"}->[0] = length $dmain->{$nm}->[0];
2091                                 }
2092                         }
2093                 }
2094         }
2095
2096         if (not defined $data{$prikey}) {
2097                 logError("No key '%s' in field specifier %s", $prikey, 'mv_data_fields');
2098                 return undef;
2099         }
2100         elsif ( ! @{$data{$prikey}}) {
2101                 if($autonumber) {
2102                         @{$data{$prikey}} = map { '' } @{ $data{$fields[1]} };
2103                 }
2104                 else {
2105                         logError("No key '%s' found for function='%s' table='%s'",
2106                                                 $prikey, $function, $CGI::values{mv_data_table},
2107                                                 );
2108                         return undef;
2109                 }
2110         }
2111
2112         my ($query,$i);
2113         my (@k);
2114         my (@v);
2115         my (@c);
2116         my (@rows_set);
2117         my (@email_rows);
2118
2119         my $safe;
2120         my $blob_field;
2121         my $blob_nick;
2122         my $blob_ptr;
2123
2124         # Fields to set in database despite mv_blob_only
2125         my %blob_exception;
2126
2127         if($CGI::values{mv_blob_field} and $CGI::values{mv_blob_nick}) {
2128 #::logDebug("update_data: blob processing enabled");
2129                 $blob_field = $CGI::values{mv_blob_field};
2130                 $blob_nick  = $CGI::values{mv_blob_nick};
2131                 $blob_ptr   = $CGI::values{mv_blob_pointer};
2132
2133                 %blob_exception   =
2134                                 map { ($_, 1) } split /[\s,\0]+/, $CGI::values{mv_blob_exception};
2135
2136                 if( ! $base_db->column_exists($blob_field) ) {
2137                         undef $blob_field;
2138                         undef $blob_nick;
2139                         logError("No blob field '%s' found for table='%s', skipping blob save.",
2140                                                 $CGI::values{mv_blob_field}, $CGI::values{mv_data_table},
2141                                                 );
2142                 }
2143                 elsif ($MVSAFE::Safe) {
2144                         $safe = $Vend::Interpolate::ready_safe;
2145                 }
2146                 else {
2147                         $safe = new Vend::Safe;
2148                 }
2149                 $base_db->column_exists($blob_ptr)
2150                         or undef $blob_ptr;
2151 #::logDebug("update_data: blob safe object=$safe");
2152         }
2153
2154         my @multis;
2155         my $multiqual = $CGI::values{mv_data_multiple_qual} || $prikey;
2156         if($CGI::values{mv_data_multiple}) {
2157                 my $re = qr/^\d+_$prikey$/;
2158                 @multis = grep $_ =~ $re, @cgi_keys;
2159                 for(@multis) {
2160                         s/_.*//;
2161                 }
2162                 @multis = sort { $a <=> $b } @multis;
2163         }
2164
2165 #::logDebug("update_data:db=$base_db key=$prikey VALUES=" . ::uneval(\%CGI::values));
2166 #::logDebug("update_data:db=$base_db key=$prikey data=" . ::uneval(\%data));
2167         my $select_key;
2168  SETDATA: {
2169         for($i = 0; $i < @{$data{$prikey}}; $i++) {
2170 #::logDebug("iteration of update_data:db=$base_db key=$prikey data=" . ::uneval(\%data));
2171                 @k = (); @v = ();
2172                 for(keys %data) {
2173                         next unless (length($value = $data{$_}->[$i]) || $CGI::values{mv_update_empty} );
2174                         push(@k, $_);
2175 # LEGACY
2176                         HTML::Entities::decode($value) if $decode;
2177 # END LEGACY
2178                         if($CGI::values{"mv_data_filter_$_"}) {
2179                                 $value = Vend::Interpolate::filter_value(
2180                                                          $CGI::values{"mv_data_filter_$_"},
2181                                                          $value,
2182                                                          $i,
2183                                                          );
2184                         }
2185                         $select_key = $value if $_ eq $prikey;
2186                         not defined $value and $value = '';
2187                         push(@v, $value);
2188                 }
2189
2190                 if(! length($select_key) ) {
2191                         next if  defined $CGI::values{mv_update_empty_key}
2192                                          and   ! $CGI::values{mv_update_empty_key};
2193                 }
2194
2195                 if($function eq 'delete') {
2196                         $base_db->delete_record($select_key);
2197                 }
2198                 else {
2199                         my $field;
2200                         $key = $data{$prikey}->[$i];
2201                         if(! length($key) and ! $autonumber) {
2202                                 ## KEY IS possibly SET HERE
2203                                 $key = $base_db->set_row($key);
2204                         }
2205                         push(@rows_set, $key);
2206
2207                         # allow form submissions to go to database and to mail
2208                         if ($CGI::values{mv_data_email}) {
2209                                 push( @email_rows,
2210                                         [ errmsg("### Form Submission from %s", $key), $blob_nick, ],
2211                                         [ $prikey, $key, ],
2212                                 );
2213                         }
2214
2215                         my $qd = {};
2216                         my $qf = {};
2217                         my $qv = {};
2218                         my $qret;
2219
2220                         my $blob;
2221                         my $brec;
2222                         if($blob_field) {
2223                                 my $string = $base_db->field($key, $blob_field);
2224 #::logDebug("update_data: blob string=$string");
2225                                 $blob = $safe->reval($string);
2226 #::logDebug("update_data: blob object=$blob");
2227                                 $blob = {} unless ref($blob) eq 'HASH';
2228                                 $brec = $blob;
2229                                 my @keys = split /::/, $blob_nick;
2230                                 for(@keys) {
2231                                         unless ( ref($brec->{$_}) eq 'HASH') {
2232                                                 $brec->{$_} = {};
2233                                         }
2234                                         $brec = $brec->{$_};
2235                                 }
2236                         }
2237                         while($field = shift @k) {
2238                                 $value = shift @v;
2239                                 next if $field eq $prikey and ! $multikey;
2240
2241                                 ## DATA IS SET HERE
2242                                 # We are going to set the field unless it is only for
2243                                 # storing in a blob (and possibly emailing)
2244                                 my  ($d, $f);
2245                                 if ($CGI::values{mv_blob_only} and ! $blob_exception{$field}) {
2246 #::logDebug("$field not storing, only blob");
2247                                         $f = $field;
2248                                 }
2249                                 else {
2250 #::logDebug("storing d=$d $field blob_only=$CGI::values{mv_blob_only}");
2251                                         ($d, $f) = set_db($base_db, $field);
2252 #::logDebug("storing table=$table d=$d f=$f key=$key");
2253
2254                                         if(! $value and ! length($value)) {
2255                                                 $value = $CGI::values{"mv_data_undef:$field"} ? undef : '';
2256                                         }
2257
2258                                         if(! defined $qd->{$d}) {
2259                                                 $qd->{$d} = $d;
2260                                                 $qf->{$d} = [$f];
2261                                                 $qv->{$d} = [$value];
2262                                         }
2263                                         else {
2264                                                 push @{$qf->{$d}}, $f;
2265                                                 push @{$qv->{$d}}, $value;
2266                                         }
2267                                         #$d->set_field($key, $f, $value);
2268                                 }
2269
2270                                 push(@email_rows, [$f, $value])
2271                                         if $CGI::values{mv_data_email};
2272 #::logDebug("update_data:db=$d key=$key field=$f value=$value");
2273                                 $brec->{$f} = $value if $brec;
2274                         }
2275
2276                         my $dml = { dml => 'upsert' };
2277                         $dml->{dml} = $function
2278                                 if $::Pragma->{dml} eq 'strict'
2279                                         || $function eq 'insert' && $::Pragma->{dml} eq 'preserve';
2280
2281                         for(keys %$qd) {
2282 #::logDebug("update_data: Getting ready to set_slice");
2283                                 my $k = $multikey ? undef : $key;
2284                                 $qret = $qd->{$_}->set_slice([$dml, $k], $qf->{$_}, $qv->{$_});
2285                                 $rows_set[$i] = $qret unless $rows_set[$i];
2286                         }
2287                         if($blob && $rows_set[$i]) {
2288                                 $brec->{mv_data_fields} = join " ", @fields;
2289                                 my $string =  uneval_it($blob);
2290 #::logDebug("update_data: blob saving string=$string");
2291                                 $base_db->set_field($key, $blob_field, $string);
2292                                 if($blob_ptr) {
2293                                         $base_db->set_field($key, $blob_ptr, $blob_nick);
2294                                 }
2295                         }
2296                         push(
2297                                         @email_rows,
2298                                         [ errmsg("### END FORM SUBMISSION %s", $key), $blob_nick, ]
2299                                 )
2300                                 if $CGI::values{mv_data_email};
2301                 }
2302         }
2303
2304         if(my $new = shift(@multis)) {
2305                 last SETDATA unless length $CGI::values{"${new}_$multiqual"};
2306                 for(@fields) {
2307                         my $t = $new . "_$_";
2308                         if($sneakdata{$t}) {
2309                                 $data{$_} = delete $sneakdata{$t};
2310                         }
2311                         else {
2312                                 $data{$_} = [ $CGI::values{$_} = $CGI::values{$t} ];
2313
2314                         }
2315                 }
2316                 redo SETDATA;
2317         }
2318  } # end SETDATA
2319
2320         if($CGI::values{mv_data_return_key}) {
2321                 my @keys = split /\0/, $CGI::values{mv_data_return_key};
2322                 for(@keys) {
2323                         $CGI::values{$_} = join("\0", @rows_set);
2324                 }
2325         }
2326
2327         if($CGI::values{mv_auto_export}) {
2328                 Vend::Data::export_database($table);
2329         }
2330
2331         if($CGI::values{mv_data_email}) {
2332                 push @email_rows, [ 'mv_data_fields', \@fields ];
2333                 Vend::Interpolate::tag_mail('', { log_error => 1 }, \@email_rows);
2334         }
2335
2336         # Allow setting in one then returning to another
2337         if($CGI::values{mv_return_table}) {
2338                 $CGI::values{mv_data_table} = $CGI::values{mv_return_table};
2339         }
2340
2341         my @reloads = grep /^mv_data_table__\d+$/, keys %CGI::values;
2342         if(@reloads) {
2343                 @reloads = map { m/.*__(\d+)$/; $1 } @reloads;
2344                 @reloads = sort { $a <=> $b } @reloads;
2345                 my $new = shift @reloads;
2346                 my $this = qr{__$new$};
2347                 my $some = qr{__\d+$};
2348 #::logDebug("Reloading, new=$new this=$this some=$some");
2349                 my %cgiset;
2350                 my @death_row;
2351                 for(@cgi_keys) {
2352                         push(@death_row, $_), next unless $_ =~ $some;
2353                         if($_ =~ $this) {
2354                                 my $k = $_;
2355                                 $k =~ s/$this//;
2356                                 $cgiset{$k} = delete $CGI::values{$_};
2357                         }
2358                 }
2359
2360                 my @file_death;
2361                 my %filekill;
2362                 my %filemove;
2363
2364                 for(my $i = 0; $i < @file_fields; $i++) {
2365                         push(@file_death, $i), next unless $file_fields[$i] =~ $some;
2366                         if($file_fields[$i] =~ $this) {
2367                                 my $k = $file_fields[$i];
2368                                 $k =~ s/$this//;
2369                                 $filemove{$file_fields[$i]} = $k;
2370                         }
2371                 }
2372
2373                 my $i;
2374                 while (defined($i = pop @file_death)) {
2375                         splice @file_fields, $i, 1;
2376                         splice @file_paths, $i, 1;
2377                         splice @file_oldfiles, $i, 1;
2378                 }
2379
2380                 for(@file_fields) {
2381                         if(my $new = $filemove{$_}) {
2382                                 $_ = $new;
2383                         }
2384
2385                 }
2386
2387                 while(my ($k,$v) = each %filemove) {
2388                         $CGI::file{$v} = delete $CGI::file{$k};
2389                 }
2390
2391
2392                 $::Scratch->{mv_data_enable} = delete $::Scratch->{"mv_data_enable__$new"};
2393                 delete $::Scratch->{mv_data_enable_key};
2394
2395                 for(@death_row) {
2396                         next unless /^mv_(data|blob|update)_/ or $data{$_}; # Reprieve!
2397                         delete $CGI::values{$_};
2398                 }
2399
2400                 @CGI::values{keys %cgiset} = values %cgiset;
2401                 $CGI::values{mv_data_file_field} = join "\0", @file_fields;
2402                 $CGI::values{mv_data_file_path} = join "\0", @file_paths;
2403                 $CGI::values{mv_data_file_oldfiles} = join "\0", @file_oldfiles;
2404 #::logDebug("Reloading, function=$CGI::values{mv_data_function}");
2405                 update_data();
2406         }
2407
2408         return;
2409 }
2410
2411 1;
2412
2413 __END__