Convert README to Markdown for nice GitHub viewing
[interchange.git] / lib / Vend / Table / Common.pm
1 # Vend::Table::Common - Common access methods for Interchange databases
2 #
3 # Copyright (C) 2002-2016 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; either version 2 of the License, or
12 # (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 $VERSION = '2.52';
25 use strict;
26
27 package Vend::Table::Common;
28 require Vend::DbSearch;
29 require Vend::TextSearch;
30 require Vend::CounterFile;
31 no warnings qw(uninitialized numeric);
32 use Symbol;
33 use Vend::Util;
34
35 our $Has_Encode = 0;
36
37 if ($ENV{MINIVEND_DISABLE_UTF8}) {
38         # stub routines to pass-thru data if disabled
39         *encode_utf8 = sub {@_};
40         *decode_utf8 = sub {@_};
41 }
42 else {
43         require Encode;
44         import Encode qw( encode_utf8 decode_utf8 );
45         $Has_Encode = 1;
46 }
47
48 use Exporter;
49 use vars qw($Storable $VERSION @EXPORT @EXPORT_OK);
50 @EXPORT = qw(create_columns import_ascii_delimited import_csv config columns);
51 @EXPORT_OK = qw(import_quoted read_quoted_fields);
52
53 use vars qw($FILENAME
54                         $COLUMN_NAMES
55                         $COLUMN_INDEX
56                         $KEY_INDEX
57                         $TIE_HASH
58                         $DBM
59                         $EACH
60                         $CONFIG);
61 (
62         $CONFIG,
63         $FILENAME,
64         $COLUMN_NAMES,
65         $COLUMN_INDEX,
66         $KEY_INDEX,
67         $TIE_HASH,
68         $DBM,
69         $EACH,
70         ) = (0 .. 7);
71
72 # See if we can do Storable
73 BEGIN {
74         eval {
75                 die unless $ENV{MINIVEND_STORABLE_DB};
76                 require Storable;
77                 $Storable = 1;
78         };
79 }
80
81 my @Hex_string;
82 {
83     my $i;
84     foreach $i (0..255) {
85         $Hex_string[$i] = sprintf("%%%02X", $i);
86     }
87 }
88
89 sub create_columns {
90         my ($columns, $config) = @_;
91         $config = {} unless $config;
92     my $column_index = {};
93         my $key;
94 #::logDebug("create_columns: " . ::uneval($config));
95
96         if($config->{KEY}) {
97                 $key = $config->{KEY};
98         }
99         elsif (! defined $config->{KEY_INDEX}) {
100                 $config->{KEY_INDEX} = 0;
101                 $config->{KEY} = $columns->[0];
102         }
103     my $i;
104         my $alias = $config->{FIELD_ALIAS} || {};
105 #::logDebug("field_alias: " . ::uneval($alias)) if $config->{FIELD_ALIAS};
106     for ($i = 0;  $i < @$columns;  ++$i) {
107         $column_index->{$columns->[$i]} = $i;
108                 defined $alias->{$columns->[$i]}
109                         and $column_index->{ $alias->{ $columns->[$i] } } = $i;
110                 next unless defined $key and $key eq $columns->[$i];
111                 $config->{KEY_INDEX} = $i;
112                 undef $key;
113 #::logDebug("set KEY_INDEX to $i: " . ::uneval($config));
114     }
115
116     die errmsg(
117                         "Cannot find key column %s in %s (%s): %s",
118                         $config->{KEY},
119                         $config->{name},
120                         $config->{file},
121                         $!,
122             ) unless defined $config->{KEY_INDEX};
123
124         return $column_index;
125 }
126
127 sub separate_definitions {
128         my ($options, $fields) = @_;
129         for(@$fields) {
130 #::logDebug("separating '$_'");
131                 next unless s/\s+(.*)//;
132 #::logDebug("needed separation: '$_'");
133                 my $def = $1;
134                 my $fn = $_;
135                 unless(defined $options->{COLUMN_DEF}{$fn}) {
136                         $options->{COLUMN_DEF}{$fn} = $def;
137                 }
138         }
139         return;
140 }
141
142 sub clear_lock {
143         my $s = shift;
144         return unless $s->[$CONFIG]{IC_LOCKING};
145         if($s->[$CONFIG]{_lock_handle}) {
146                 close $s->[$CONFIG]{_lock_handle};
147                 delete $s->[$CONFIG]{_lock_handle};
148         }
149 }
150
151 sub lock_table {
152         my $s = shift;
153         return unless $s->[$CONFIG]{IC_LOCKING};
154         my $lockhandle;
155         if(not $lockhandle = $s->[$CONFIG]{_lock_handle}) {
156                 my $lf = $s->[$CONFIG]{file} . '.lock';
157                 unless($lf =~ m{/}) {
158                         $lf = ($s->[$CONFIG]{dir} || $Vend::Cfg->{ProductDir}) . "/$lf";
159                 }
160                 $lockhandle = gensym;
161                 $s->[$CONFIG]{_lock_file} = $lf;
162                 $s->[$CONFIG]{_lock_handle} = $lockhandle;
163                 open $lockhandle, ">> $lf"
164                         or die errmsg("Cannot lock table %s (%s): %s", $s->[$CONFIG]{name}, $lf, $!);
165         }
166 #::logDebug("lock handle=$lockhandle");
167         Vend::Util::lockfile($lockhandle);
168 }
169
170 sub unlock_table {
171         my $s = shift;
172         return unless $s->[$CONFIG]{IC_LOCKING};
173         Vend::Util::unlockfile($s->[$CONFIG]{_lock_handle});
174 }
175
176 sub stuff {
177     my ($val) = @_;
178     $val = encode_utf8($val)
179         if $Has_Encode && ($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8});
180     $val =~ s,([\t\%]),$Hex_string[ord($1)],eg;
181     return $val;
182 }
183
184 sub unstuff {
185     my ($val) = @_;
186     $val =~ s,%(..),chr(hex($1)),eg;
187     $val = decode_utf8($val)
188         if $Has_Encode && ($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8});
189     return $val;
190 }
191
192 sub autonumber {
193         my $s = shift;
194         my $start;
195         my $cfg = $s->[$CONFIG];
196
197         return $s->autosequence() if $cfg->{AUTO_SEQUENCE};
198
199         return '' if not $start = $cfg->{AUTO_NUMBER};
200         local($/) = "\n";
201         my $c = $s->[$CONFIG];
202         if(! defined $c->{AutoNumberCounter}) {
203                 $c->{AutoNumberCounter} = new Vend::CounterFile
204                                                                         $cfg->{AUTO_NUMBER_FILE},
205                                                                         $start,
206                                                                         $c->{AUTO_NUMBER_DATE},
207                                                                         ;
208         }
209         my $num;
210         do {
211                 $num = $c->{AutoNumberCounter}->inc();
212         } while $s->record_exists($num);
213         return $num;
214 }
215
216 # These don't work in non-DBI databases
217 sub commit   { 1 }
218 sub rollback { 0 }
219
220 sub numeric {
221         return exists $_[0]->[$CONFIG]->{NUMERIC}->{$_[1]};
222 }
223
224 sub quote {
225         my($s, $value, $field) = @_;
226         return $value if $s->numeric($field);
227         $value =~ s/'/\\'/g;
228         return "'$value'";
229 }
230
231 sub config {
232         my ($s, $key, $value) = @_;
233         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
234         return $s->[$CONFIG]{$key} unless defined $value;
235         $s->[$CONFIG]{$key} = $value;
236 }
237
238 sub import_db {
239         my($s) = @_;
240         my $db = Vend::Data::import_database($s->[0], 1);
241         return undef if ! $db;
242         $Vend::Database{$s->[0]{name}} = $db;
243         Vend::Data::update_productbase($s->[0]{name});
244         if($db->[$CONFIG]{export_now}) {
245                 Vend::Data::export_database($db);
246                 delete $db->[$CONFIG]{export_now};
247         }
248         return $db;
249 }
250
251 sub close_table {
252     my ($s) = @_;
253         return 1 if ! defined $s->[$TIE_HASH];
254 #::logDebug("closing table $s->[$FILENAME]");
255         undef $s->[$DBM];
256         $s->clear_lock();
257     untie %{$s->[$TIE_HASH]}
258                 or $s->log_error("%s %s: %s", errmsg("untie"), $s->[$FILENAME], $!);
259         undef $s->[$TIE_HASH];
260 #::logDebug("closed table $s->[$FILENAME], self=" . ::uneval($s));
261 }
262
263 sub filter {
264         my ($s, $ary, $col, $filter) = @_;
265         my $column;
266         for(keys %$filter) {
267                 next unless defined ($column = $col->{$_});
268                 $ary->[$column] = Vend::Interpolate::filter_value(
269                                                                 $filter->{$_},
270                                                                 $ary->[$column],
271                                                                 $_,
272                                                   );
273         }
274 }
275
276 sub columns {
277     my ($s) = @_;
278         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
279     return @{$s->[$COLUMN_NAMES]};
280 }
281
282 sub column_exists {
283         return defined test_column(@_);
284 }
285
286 sub test_column {
287     my ($s, $column) = @_;
288         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
289     return $s->[$COLUMN_INDEX]{$column};
290 }
291
292 sub column_index {
293     my ($s, $column) = @_;
294         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
295     my $i = $s->[$COLUMN_INDEX]{$column};
296     die $s->log_error(
297                                 "There is no column named '%s' in %s",
298                                 $column,
299                                 $s->[$FILENAME],
300                         ) unless defined $i;
301     return $i;
302 }
303
304 *test_record = \&record_exists;
305
306 sub record_exists {
307     my ($s, $key) = @_;
308         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
309     my $r = $s->[$DBM]->EXISTS("k$key");
310     return $r;
311 }
312
313 sub name {
314         my ($s) = shift;
315         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
316         return $s->[$CONFIG]{name};
317 }
318
319 sub row_hash {
320     my ($s, $key) = @_;
321         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
322         return undef unless $s->record_exists($key);
323         my %row;
324     @row{ @{$s->[$COLUMN_NAMES]} } = $s->row($key);
325         return \%row;
326 }
327
328 sub unstuff_row {
329     my ($s, $key) = @_;
330         $s->lock_table() if $s->[$CONFIG]{IC_LOCKING};
331     my $line = $s->[$TIE_HASH]{"k$key"};
332         $s->unlock_table() if $s->[$CONFIG]{IC_LOCKING};
333     die $s->log_error(
334                                         "There is no row with index '%s' in database %s",
335                                         $key,
336                                         $s->[$FILENAME],
337                         ) unless defined $line;
338     return map(unstuff($_), split(/\t/, $line, 9999))
339                 unless $s->[$CONFIG]{FILTER_FROM};
340         my @f = map(unstuff($_), split(/\t/, $line, 9999));
341         $s->filter(\@f, $s->[$COLUMN_INDEX], $s->[$CONFIG]{FILTER_FROM});
342         return @f;
343 }
344
345 sub thaw_row {
346     my ($s, $key) = @_;
347         $s->lock_table() if $s->[$CONFIG]{IC_LOCKING};
348     my $line = $s->[$TIE_HASH]{"k$key"};
349         $s->unlock_table() if $s->[$CONFIG]{IC_LOCKING};
350     die $s->log_error( "There is no row with index '%s'", $key,)
351                 unless defined $line;
352     return (@{ Storable::thaw($line) })
353                 unless $s->[$CONFIG]{FILTER_FROM};
354 #::logDebug("filtering.");
355         my $f = Storable::thaw($line);
356         $s->filter($f, $s->[$COLUMN_INDEX], $s->[$CONFIG]{FILTER_FROM});
357         return @{$f};
358 }
359
360 sub field_accessor {
361     my ($s, $column) = @_;
362         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
363     my $index = $s->column_index($column);
364     return sub {
365         my ($key) = @_;
366         return ($s->row($key))[$index];
367     };
368 }
369
370 sub row_settor {
371     my ($s, @cols) = @_;
372         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
373         my @index;
374         my $key_idx = $s->[$KEY_INDEX] || 0;
375         #shift(@cols);
376         for(@cols) {
377         push @index, $s->column_index($_);
378         }
379 #::logDebug("settor index=@index");
380     return sub {
381         my (@vals) = @_;
382                 my @row;
383                 my $key = $vals[$key_idx];
384                 eval {
385                         @row = $s->row($key);
386                 };
387         @row[@index] = @vals;
388 #::logDebug("setting $key indices '@index' to '@vals'");
389         $s->set_row(@row);
390     };
391 }
392
393 sub get_slice {
394     my ($s, $key, $fary) = @_;
395         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
396
397         return undef unless $s->record_exists($key);
398
399         if(ref $fary ne 'ARRAY') {
400                 shift; shift;
401                 $fary = [ @_ ];
402         }
403
404         my @result = ($s->row($key))[ map { $s->column_index($_) } @$fary ];
405         return wantarray ? @result : \@result;
406 }
407
408 sub set_slice {
409         my ($s, $key, $fary, $vary) = @_;
410         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
411
412     if($s->[$CONFIG]{Read_only}) {
413                 $s->log_error(
414                         "Attempt to set slice of %s in read-only table %s",
415                         $key,
416                         $s->[$CONFIG]{name},
417                 );
418                 return undef;
419         }
420
421         my $opt;
422         if (ref ($key) eq 'ARRAY') {
423                 $opt = shift @$key;
424                 $key = shift @$key;
425         }
426         $opt = {}
427                 unless ref ($opt) eq 'HASH';
428
429         $opt->{dml} = 'upsert'
430                 unless defined $opt->{dml};
431
432         if(ref $fary ne 'ARRAY') {
433                 my $href = $fary;
434                 if(ref $href ne 'HASH') {
435                         $href = { splice (@_, 2) };
436                 }
437                 $vary = [ values %$href ];
438                 $fary = [ keys   %$href ];
439         }
440
441         my $keyname = $s->[$CONFIG]{KEY};
442
443         my ($found_key) = grep $_ eq $keyname, @$fary;
444
445         if(! $found_key) {
446                 unshift @$fary, $keyname;
447                 unshift @$vary, $key;
448         }
449
450         my @current;
451
452         if ($s->record_exists($key)) {
453                 if ($opt->{dml} eq 'insert') {
454                         $s->log_error(
455                                 "Duplicate key on set_slice insert for key '$key' on table %s",
456                                 $s->[$CONFIG]{name},
457                         );
458                         return undef;
459                 }
460                 @current = $s->row($key);
461         }
462         elsif ($opt->{dml} eq 'update') {
463                 $s->log_error(
464                         "No record to update set_slice for key '$key' on table %s",
465                         $s->[$CONFIG]{name},
466                 );
467                 return undef;
468         }
469
470         @current[ map { $s->column_index($_) } @$fary ] = @$vary;
471
472         $key = $s->set_row(@current);
473         length($key) or
474                 $s->log_error(
475                         "Did set_slice with empty key on table %s",
476                         $s->[$CONFIG]{name},
477                 );
478
479         return $key;
480 }
481
482 sub field_settor {
483     my ($s, $column) = @_;
484         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
485     my $index = $s->column_index($column);
486     return sub {
487         my ($key, $value) = @_;
488         my @row = $s->row($key);
489         $row[$index] = $value;
490         $s->set_row(@row);
491     };
492 }
493
494 sub clone_row {
495         my ($s, $old, $new) = @_;
496         return undef unless $s->record_exists($old);
497         my @ary = $s->row($old);
498         $ary[$s->[$KEY_INDEX]] = $new;
499         $s->set_row(@ary);
500         return $new;
501 }
502
503 sub clone_set {
504         my ($s, $col, $old, $new) = @_;
505         return unless $s->column_exists($col);
506         my $sel = $s->quote($old, $col);
507         my $name = $s->[$CONFIG]{name};
508         my ($ary, $nh, $na) = $s->query("select * from $name where $col = $sel");
509         my $fpos = $nh->{$col} || return undef;
510         $s->config('AUTO_NUMBER', '000001') unless $s->config('AUTO_NUMBER');
511         for(@$ary) {
512                 my $line = $_;
513                 $line->[$s->[$KEY_INDEX]] = '';
514                 $line->[$fpos] = $new;
515                 $s->set_row(@$line);
516         }
517         return $new;
518 }
519
520 sub stuff_row {
521     my ($s, @fields) = @_;
522         my $key = $fields[$s->[$KEY_INDEX]];
523
524 #::logDebug("stuff key=$key");
525         $fields[$s->[$KEY_INDEX]] = $key = $s->autonumber()
526                 if ! length($key);
527         $s->filter(\@fields, $s->[$COLUMN_INDEX], $s->[$CONFIG]{FILTER_TO})
528                 if $s->[$CONFIG]{FILTER_TO};
529         $s->lock_table();
530
531     $s->[$TIE_HASH]{"k$key"} = join("\t", map(stuff($_), @fields));
532
533         $s->unlock_table();
534         return $key;
535 }
536
537 sub freeze_row {
538     my ($s, @fields) = @_;
539         my $key = $fields[$s->[$KEY_INDEX]];
540 #::logDebug("freeze key=$key");
541         $fields[$s->[$KEY_INDEX]] = $key = $s->autonumber()
542                 if ! length($key);
543         $s->filter(\@fields, $s->[$COLUMN_INDEX], $s->[$CONFIG]{FILTER_TO})
544                 if $s->[$CONFIG]{FILTER_TO};
545         $s->lock_table();
546         $s->[$TIE_HASH]{"k$key"} = Storable::freeze(\@fields);
547         $s->unlock_table();
548         return $key;
549 }
550
551 if($Storable) {
552         *set_row = \&freeze_row;
553         *row = \&thaw_row;
554 }
555 else {
556         *set_row = \&stuff_row;
557         *row = \&unstuff_row;
558 }
559
560 sub foreign {
561     my ($s, $key, $foreign) = @_;
562         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
563         $key = $s->quote($key, $foreign);
564     my $q = "select $s->[$CONFIG]{KEY} from $s->[$CONFIG]{name} where $foreign = $key";
565 #::logDebug("foreign key query = $q");
566     my $ary = $s->query({ sql => $q });
567 #::logDebug("foreign key query returned" . ::uneval($ary));
568         return undef unless $ary and $ary->[0];
569         return $ary->[0][0];
570 }
571
572 sub field {
573     my ($s, $key, $column) = @_;
574         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
575     return ($s->row($key))[$s->column_index($column)];
576 }
577
578 sub set_field {
579     my ($s, $key, $column, $value) = @_;
580         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
581     if($s->[$CONFIG]{Read_only}) {
582                 $s->log_error(
583                         "Attempt to write %s in read-only table",
584                         "$s->[$CONFIG]{name}::${column}::$key",
585                 );
586                 return undef;
587         }
588     my @row;
589         if($s->record_exists($key)) {
590                 @row = $s->row($key);
591         }
592         else {
593                 $row[$s->[$KEY_INDEX]] = $key;
594         }
595     $row[$s->column_index($column)] = $value
596                 if $column;
597     $s->set_row(@row);
598         $value;
599 }
600
601 sub inc_field {
602     my ($s, $key, $column, $adder) = @_;
603         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
604     my($value);
605     if($s->[$CONFIG]{Read_only}) {
606                 $s->log_error(
607                         "Attempt to write %s in read-only table",
608                         "$s->[$CONFIG]{name}::${column}::$key",
609                 );
610                 return undef;
611         }
612     my @row = $s->row($key);
613         my $idx = $s->column_index($column);
614 #::logDebug("ready to increment key=$key column=$column adder=$adder idx=$idx row=" . ::uneval(\@row));
615     $value = $row[$s->column_index($column)] += $adder;
616     $s->set_row(@row);
617     return $value;
618 }
619
620 sub create_sql {
621     return undef;
622 }
623
624 sub touch {
625     my ($s) = @_;
626         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
627     my $now = time();
628     utime $now, $now, $s->[$FILENAME];
629 }
630
631 sub ref {
632         my $s = shift;
633         return $s if defined $s->[$TIE_HASH];
634         return $s->import_db() if $s->can('import_db');
635         die errmsg("no access for database. Have you opened the database before trying to access it? You can try inserting [perl name_of_table_you_are_accessing][/perl] in your page before the data access or adding the following to your catalog.cfg: AutoLoad [perl name_of_table_you_are_accessing][/perl]");
636 }
637
638 sub sort_each {
639         my($s, $sort_field, $sort_option) = @_;
640         if(length $sort_field) {
641                 my $opt = {};
642                 $opt->{to} = $sort_option
643                         if $sort_option;
644                 $opt->{ml} = 99999;
645                 $opt->{st} = 'db';
646                 $opt->{tf} = $sort_field;
647                 $opt->{query} = "select * from $s->[$CONFIG]{name}";
648                 $s->[$EACH] = $s->query($opt);
649                 return;
650         }
651 }
652
653 sub each_sorted {
654         my $s = shift;
655         if(! defined $s->[$EACH][0]) {
656                 undef $s->[$EACH];
657                 return ();
658         }
659         my $k = $s->[$EACH][0][$s->[$KEY_INDEX]];
660         return ($k, @{shift @{ $s->[$EACH] } });
661 }
662
663 sub each_record {
664     my ($s) = @_;
665         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
666     my $key;
667
668         return $s->each_sorted() if defined $s->[$EACH];
669     for (;;) {
670         $key = each %{$s->[$TIE_HASH]};
671         if (defined $key) {
672             if ($key =~ s/^k//) {
673                 return ($key, $s->row($key));
674             }
675         }
676         else {
677             return ();
678         }
679     }
680 }
681
682 my $sup;
683 my $restrict;
684 my $rfield;
685 my $hfield;
686 my $rsession;
687
688 sub each_nokey {
689     my ($s, $qual) = @_;
690         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
691     my ($key, $hf);
692
693         if (! defined $restrict) {
694                 # Support hide_field
695                 if($qual) {
696 #::logDebug("Found qual=$qual");
697                         $hfield = $qual;
698                         if($hfield =~ s/^\s+WHERE\s+(\w+)\s*!=\s*1($|\s+)//) {
699                                 $hf = $1;
700 #::logDebug("Found hf=$hf");
701                                 $s->test_column($hf) and $hfield = $s->column_index($hf);
702                         }
703                         else {
704                                 undef $hfield;
705                         }
706
707 #::logDebug("hf index=$hfield");
708                 }
709                 if($restrict = ($Vend::Cfg->{TableRestrict}{$s->config('name')} || 0)) {
710 #::logDebug("restricted?");
711                 $sup =  ! defined $Global::SuperUserFunction
712                                         ||
713                                 $Global::SuperUserFunction->();
714                 if($sup) {
715                         $restrict = 0;
716                 }
717                 else {
718                         ($rfield, $rsession) = split /\s*=\s*/, $restrict;
719                         $s->test_column($rfield) and $rfield = $s->column_index($rfield)
720                                 or $restrict = 0;
721                         $rsession = $Vend::Session->{$rsession};
722                 }
723         }
724
725                 $restrict = 1 if $hfield and $s->[$CONFIG]{HIDE_FIELD} eq $hf;
726
727         }
728
729     for (;;) {
730         $key = each %{$s->[$TIE_HASH]};
731 #::logDebug("each_nokey: $key field=$rfield sup=$sup");
732                 if(! defined $key) {
733                         undef $restrict;
734                         return ();
735                 }
736                 $key =~ s/^k// or next;
737                 if($restrict) {
738                         my (@row) = $s->row($key);
739 #::logDebug("each_nokey: rfield='$row[$rfield]' eq '$rsession' ??") if defined $rfield;
740 #::logDebug("each_nokey: hfield='$row[$hfield]'") if defined $hfield;
741                         next if defined $hfield and $row[$hfield];
742                         next if defined $rfield and $row[$rfield] ne $rsession;
743                         return \@row;
744                 }
745                 return [ $s->row($key) ];
746     }
747 }
748
749 sub suicide { 1 }
750
751 sub isopen {
752         return defined $_[0]->[$TIE_HASH];
753 }
754
755 sub delete_record {
756     my ($s, $key) = @_;
757         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
758     if($s->[$CONFIG]{Read_only}) {
759                 $s->log_error(
760                         "Attempt to delete row '$key' in read-only table %s",
761                         $key,
762                         $s->[$CONFIG]{name},
763                 );
764                 return undef;
765         }
766
767 #::logDebug("delete row $key from $s->[$FILENAME]");
768     delete $s->[$TIE_HASH]{"k$key"};
769         1;
770 }
771
772 sub sprintf_substitute {
773         my ($s, $query, $fields, $cols) = @_;
774         return sprintf $query, @$fields;
775 }
776
777 sub hash_query {
778         my ($s, $query, $opt) = @_;
779         $opt ||= {};
780         $opt->{query} = $query;
781         $opt->{hashref} = 1;
782         return scalar $s->query($opt);
783 }
784
785 sub query {
786     my($s, $opt, $text, @arg) = @_;
787
788     if(! CORE::ref($opt)) {
789         unshift @arg, $text if defined $text;
790         $text = $opt;
791         $opt = {};
792     }
793
794         $s = $s->import_db() if ! defined $s->[$TIE_HASH];
795         $opt->{query} = $opt->{sql} || $text if ! $opt->{query};
796
797 #::logDebug("receieved query. object=" . ::uneval_it($opt));
798
799         if(defined $opt->{values}) {
800                 @arg = $opt->{values} =~ /['"]/
801                                 ? ( Text::ParseWords::shellwords($opt->{values})  )
802                                 : (grep /\S/, split /\s+/, $opt->{values});
803                 @arg = @{$::Values}{@arg};
804         }
805
806         if($opt->{type}) {
807                 $opt->{$opt->{type}} = 1 unless defined $opt->{$opt->{type}};
808         }
809
810         my $query;
811     $query = ! scalar @arg
812                         ? $opt->{query}
813                         : sprintf_substitute ($s, $opt->{query}, \@arg);
814
815         my $codename = defined $s->[$CONFIG]{KEY} ? $s->[$CONFIG]{KEY} : 'code';
816         my $ref;
817         my $relocate;
818         my $return;
819         my $spec;
820         my $stmt;
821         my $update = '';
822         my %nh;
823         my @na;
824         my @update_fields;
825         my @out;
826
827         if($opt->{STATEMENT}) {
828                  $stmt = $opt->{STATEMENT};
829                  $spec = $opt->{SPEC};
830 #::logDebug('rerouted. Command is ' . $stmt->command());
831         }
832         else {
833                 eval {
834                         ($spec, $stmt) = Vend::Scan::sql_statement($query, $opt);
835                 };
836                 if($@) {
837                         my $msg = errmsg("SQL query failed: %s\nquery was: %s", $@, $query);
838                         $s->log_error($msg);
839                         Carp::croak($msg) if $Vend::Try;
840                         return ($opt->{failure} || undef);
841                 }
842                 my @additions = grep length($_) == 2, keys %$opt;
843                 for(@additions) {
844                         next unless length $opt->{$_};
845                         $spec->{$_} = $opt->{$_};
846                 }
847         }
848         my @tabs = @{$spec->{rt} || $spec->{fi}};
849
850         my $reroute;
851         my $tname = $s->[$CONFIG]{name};
852         if ($tabs[0] ne $tname) {
853                 if("$tabs[0]_txt" eq $tname or "$tabs[0]_asc" eq $tname) {
854                         $tabs[0] = $spec->{fi}[0] = $tname;
855                 }
856                 else {
857                         $reroute = 1;
858                 }
859         }
860
861         if($reroute) {
862                 unless ($reroute = $Vend::Database{$tabs[0]}) {
863                         $s->log_error("Table %s not found in databases", $tabs[0]);
864                         return $opt->{failure} || undef;
865                 }
866                 $s = $reroute;
867 #::logDebug("rerouting to $tabs[0]");
868                 $opt->{STATEMENT} = $stmt;
869                 $opt->{SPEC} = $spec;
870                 return $s->query($opt, $text);
871         }
872
873 eval {
874
875         my @vals;
876         if($stmt->command() ne 'SELECT') {
877                 if(defined $s and $s->[$CONFIG]{Read_only}) {
878                         $s->log_error(
879                                         "Attempt to write read-only table %s",
880                                         $s->[$CONFIG]{name},
881                         );
882                         return undef;
883                 }
884                 $update = $stmt->command();
885                 @vals = $stmt->row_values();
886 #::logDebug("row_values returned=" . ::uneval(\@vals));
887         }
888
889
890         @na = @{$spec->{rf}}     if $spec->{rf};
891
892 #::logDebug("spec->{ml}=$spec->{ml} opt->{ml}=$opt->{ml}");
893         $spec->{ml} = $opt->{ml} if $opt->{ml};
894         $spec->{ml} ||= '1000';
895         $spec->{fn} = [$s->columns];
896
897         my $sub;
898
899         if($update eq 'INSERT') {
900                 if(! $spec->{rf} or  $spec->{rf}[0] eq '*') {
901                         @update_fields = @{$spec->{fn}};
902                 }
903                 else {
904                         @update_fields = @{$spec->{rf}};
905                 }
906 #::logDebug("update fields: " . uneval(\@update_fields));
907                 @na = $codename;
908                 $sub = $s->row_settor(@update_fields);
909         }
910         elsif($update eq 'UPDATE') {
911                 @update_fields = @{$spec->{rf}};
912 #::logDebug("update fields: " . uneval(\@update_fields));
913                 my $key = $s->config('KEY');
914                 @na = ($codename);
915                 $sub = sub {
916                                         my $key = shift;
917                                         $s->set_slice($key, [@update_fields], \@_);
918                                 };
919         }
920         elsif($update eq 'DELETE') {
921                 @na = $codename;
922                 $sub = sub { delete_record($s, @_) };
923         }
924         else {
925                 @na = @{$spec->{fn}}   if ! scalar(@na) || $na[0] eq '*';
926         }
927
928         $spec->{rf} = [@na];
929
930 #::logDebug("tabs='@tabs' columns='@na' vals='@vals' uf=@update_fields update=$update"); 
931
932     my $search;
933     if (! defined $opt->{st} or "\L$opt->{st}" eq 'db' ) {
934                 for(@tabs) {
935                         s/\..*//;
936                 }
937         $search = new Vend::DbSearch;
938 #::logDebug("created DbSearch object: " . ::uneval_it($search));
939         }
940         else {
941         $search = new Vend::TextSearch;
942 #::logDebug("created TextSearch object: " . ::uneval_it($search));
943     }
944
945         my %fh;
946         my $i = 0;
947         %nh = map { (lc $_, $i++) } @na;
948         $i = 0;
949         %fh = map { ($_, $i++) } @{$spec->{fn}};
950
951 #::logDebug("field hash: " . Vend::Util::uneval_it(\%fh)); 
952         for ( qw/rf sf/ ) {
953                 next unless defined $spec->{$_};
954                 map { $_ = $fh{$_} } @{$spec->{$_}};
955         }
956
957         if($update) {
958                 $opt->{row_count} = 1;
959                 die "Reached update query without object"
960                         if ! $s;
961 #::logDebug("Update operation is $update, sub=$sub");
962                 die "Bad row settor for columns @na"
963                         if ! $sub;
964                 if($update eq 'INSERT') {
965                         $sub->(@vals);
966                         $ref = [[ $vals[0] ]];
967                 }
968                 else {
969                         $ref = $search->array($spec);
970                         for(@$ref) {
971 #::logDebug("returned =" . uneval($_) . ", update values: " . uneval(\@vals));
972                                 $sub->($_->[0], @vals);
973                         }
974                 }
975         }
976         elsif ($opt->{hashref}) {
977                 $ref = $Vend::Interpolate::Tmp->{$opt->{hashref}} = $search->hash($spec);
978         }
979         else {
980 #::logDebug(    " \$Vend::Interpolate::Tmp->{$opt->{arrayref}}");
981                 $ref = $Vend::Interpolate::Tmp->{$opt->{arrayref} || ''}
982                          = $search->array($spec);
983                 $opt->{object} = $search;
984                 $opt->{prefix} = 'sql' unless defined $opt->{prefix};
985         }
986 };
987 #::logDebug("search spec: " . Vend::Util::uneval($spec));
988 #::logDebug("name hash: " . Vend::Util::uneval(\%nh));
989 #::logDebug("ref returned: " . substr(Vend::Util::uneval($ref), 0, 100));
990 #::logDebug("opt is: " . Vend::Util::uneval($opt));
991         if($@) {
992                 $s->log_error(
993                                 "MVSQL query failed for %s: %s\nquery was: %s",
994                                 $opt->{table},
995                                 $@,
996                                 $query,
997                         );
998                 $return = $opt->{failure} || undef;
999         }
1000
1001         if($opt->{search_label}) {
1002                 $::Instance->{SearchObject}{$opt->{search_label}} = {
1003                         mv_results => $ref,
1004                         mv_field_names => \@na,
1005                 };
1006         }
1007
1008         if ($opt->{row_count}) {
1009                 my $rc = $ref ? scalar @$ref : 0;
1010                 return $rc unless $opt->{list};
1011                 $ref = [ [ $rc ] ];
1012                 @na = [ 'row_count' ];
1013                 %nh = ( 'rc' => 0, 'count' => 0, 'row_count' => 0 );
1014         }
1015
1016         return Vend::Interpolate::tag_sql_list($text, $ref, \%nh, $opt, \@na)
1017                 if $opt->{list};
1018         return Vend::Interpolate::html_table($opt, $ref, \@na)
1019                 if $opt->{html};
1020         return Vend::Util::uneval($ref)
1021                 if $opt->{textref};
1022         return wantarray ? ($ref, \%nh, \@na) : $ref;
1023 }
1024
1025 *import_quoted = *import_csv = \&import_ascii_delimited;
1026
1027 my %Sort = (
1028
1029     ''  => sub { $a cmp $b              },
1030     none    => sub { $a cmp $b              },
1031     f   => sub { (lc $a) cmp (lc $b)    },
1032     fr  => sub { (lc $b) cmp (lc $a)    },
1033     n   => sub { $a <=> $b              },
1034     nr  => sub { $b <=> $a              },
1035     r   => sub { $b cmp $a              },
1036     rf  => sub { (lc $b) cmp (lc $a)    },
1037     rn  => sub { $b <=> $a              },
1038 );
1039
1040 my $fafh;
1041 sub file_access {
1042         my $function = shift;
1043         return <$fafh> 
1044 }
1045
1046 sub import_ascii_delimited {
1047     my ($infile, $options, $table_name) = @_;
1048         my ($format, $csv);
1049
1050         my $delimiter = quotemeta($options->{'delimiter'});
1051
1052         if  ($delimiter eq 'CSV') {
1053                 $csv = 1;
1054                 $format = 'CSV';
1055         }
1056         elsif ($options->{CONTINUE}) {
1057                 $format = uc $options->{CONTINUE};
1058         }
1059         else {
1060                 $format = 'NONE';
1061         }
1062
1063         my $realfile;
1064         if($options->{PRELOAD}) {
1065                 # do not preload if $infile is a scalar reference
1066                 if ($options->{scalar_ref} or 
1067                         (-f $infile and $options->{PRELOAD_EMPTY_ONLY})) {
1068                         # Do nothing, no preload
1069                 }
1070                 else {
1071                         $realfile = -f $infile ? $infile : '';
1072                         $infile = $options->{PRELOAD};
1073                         $infile = "$Global::VendRoot/$infile" if ! -f $infile;
1074                         ($infile = $realfile, undef $realfile) if ! -f $infile;
1075                 }
1076         }
1077
1078         if(! defined $realfile) {
1079                 if($options->{scalar_ref}){
1080                         open(IN, '+<', $infile)
1081                                 or die errmsg("%s %s: %s\n", errmsg("open scalar reference"), *$infile, $!);
1082                         # locking of scalar reference filehandles in unsupported
1083                 }
1084                 else{
1085                         open(IN, "+<$infile")
1086                                 or die errmsg("%s %s: %s\n", errmsg("open read/write"), $infile, $!);
1087                         lockfile(\*IN, 1, 1)
1088                                 or die errmsg("%s %s: %s\n", errmsg("lock"), $infile, $!);
1089                 }
1090
1091         }
1092         else {
1093                 open(IN, "<$infile")
1094                         or die errmsg("%s %s: %s\n", errmsg("open"), $infile, $!);
1095         }
1096
1097         new_filehandle(\*IN);
1098
1099         # we should be inputting as UTF8 if we're so configured
1100         binmode(\*IN, ':utf8') if $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
1101
1102         my $field_hash;
1103         my $para_sep;
1104         my $codere = '[\w-_#/.]+';
1105         my $idx = 0;
1106
1107         my($field_count, @field_names);
1108         
1109         if($options->{hs}) {
1110                 my $i = 0;
1111                 <IN> while $i++ < $options->{hs};
1112         }
1113         if($options->{field_names}) {
1114                 @field_names = @{$options->{field_names}};
1115
1116                 # This pulls COLUMN_DEF out of a field name
1117                 # remains in ASCII file, though
1118                 separate_definitions($options,\@field_names);
1119
1120                 if($options->{CONTINUE} eq 'NOTES') {
1121                         $para_sep = $options->{NOTES_SEPARATOR} ||$options->{SEPARATOR} || "\f";
1122                         $field_hash = {};
1123                         for(@field_names) {
1124                                 $field_hash->{$_} = $idx++;
1125                         }
1126                         $idx = $#field_names;
1127                 }
1128         }
1129         else {
1130                 my $field_names;
1131                 if ($csv) {
1132                         @field_names = read_quoted_fields(\*IN);
1133                 }
1134                 else {
1135                         $field_names = <IN>;
1136                         chomp $field_names;
1137                         $field_names =~ s/\s+$// unless $format eq 'NOTES';
1138                         @field_names = split(/$delimiter/, $field_names);
1139                 }
1140
1141                 # This pulls COLUMN_DEF out of a field name
1142                 # remains in ASCII file, though
1143                 separate_definitions($options,\@field_names);
1144
1145 #::logDebug("field names: @field_names");
1146                 if($format eq 'NOTES') {
1147                         $field_hash = {};
1148                         for(@field_names) {
1149                                 s/:.*//;        
1150                                 if(/\S[ \t]+/) {
1151                                         die "Only one notes field allowed in NOTES format.\n"
1152                                                 if $para_sep;
1153                                         $para_sep = $_;
1154                                         $_ = '';
1155                                 }
1156                                 else {
1157                                         $field_hash->{$_} = $idx++;
1158                                 }
1159                         }
1160                         my $msg;
1161                         @field_names = grep $_, @field_names;
1162                         $para_sep =~ s/($codere)[\t ]*(.)/$2/;
1163                         push(@field_names, ($1 || 'notes_field'));
1164                         $idx = $#field_names;
1165                         $para_sep = $options->{NOTES_SEPARATOR} || "\f";
1166                 }
1167         }
1168
1169         local($/) = "\n" . $para_sep ."\n"
1170                 if $para_sep;
1171
1172         $field_count = scalar @field_names;
1173
1174         no strict 'refs';
1175     my $out;
1176         if($options->{ObjectType}) {
1177                 $out = &{"$options->{ObjectType}::create"}(
1178                                                                         $options->{ObjectType},
1179                                                                         $options,
1180                                                                         \@field_names,
1181                                                                         $table_name,
1182                                                                 );
1183         }
1184         else {
1185                 $out = $options->{Object};
1186         }
1187
1188         if(! $out) {
1189                 die errmsg(q{No database object for table: %s
1190
1191 Probable mismatch of Database directive to database type,
1192 for example calling DBI without proper modules or database
1193 access.
1194 },
1195                                         $table_name,
1196                                         );
1197         }
1198         my $fields;
1199     my (@fields, $key);
1200         my @addl;
1201         my $excel = '';
1202         my $excel_addl = '';
1203
1204         if($options->{EXCEL}) {
1205         #Fix for quoted includes supplied by Larry Lesczynski
1206                 $excel = <<'EndOfExcel';
1207                         if(/"[^\t]*(?:,|"")/) {
1208                                 for (@fields) {
1209                                         next unless /[,"]/;
1210                                         s/^"//;
1211                                         s/"$//;
1212                                         s/""/"/g;
1213                                 }
1214                         }
1215 EndOfExcel
1216                 $excel_addl = <<'EndOfExcel';
1217                         if(/"[^\t]*(?:,|"")/) {
1218                                 for (@addl) {
1219                                         next unless /,/;
1220                                         s/^"//;
1221                                         s/"$//;
1222                                 }
1223                         }
1224 EndOfExcel
1225         }
1226         
1227         my $index = '';
1228         my @fh; # Array of file handles for sort
1229         my @fc; # Array of file handles for copy when symlink fails
1230         my @i;  # Array of field names for sort
1231         my @o;  # Array of sort options
1232         my %comma;
1233         if($options->{INDEX} and ! $options->{NO_ASCII_INDEX}) {
1234                 my @f; my $f;
1235                 my @n;
1236                 my $i;
1237                 @f = @{$options->{INDEX}};
1238                 foreach $f (@f) {
1239                         my $found = 0;
1240                         $i = 0;
1241                         if( $f =~ s/:(.*)//) {
1242                                 my $option = $1;
1243                                 push @o, $1;
1244                         }
1245                         elsif (exists $options->{INDEX_OPTIONS}{$f}) {
1246
1247                                 push @o, $options->{INDEX_OPTIONS}{$f};
1248                         }
1249                         else {
1250                                 push @o, '';
1251                         }
1252                         for(@field_names) {
1253                                 if($_ eq $f) {
1254                                         $found++;
1255                                         push(@i, $i);
1256                                         push(@n, $f);
1257                                         last;
1258                                 }
1259                                 $i++;
1260                         }
1261                         (pop(@o), next) unless $found;
1262                 }
1263                 if(@i) {
1264                         require IO::File;
1265                         my $fh;
1266                         my $f_string = join ",", @i;
1267                         @f = ();
1268                         for($i = 0; $i < @i; $i++) {
1269                                 my $fnum = $i[$i];
1270                                 $fh = new IO::File "> $infile.$i[$i]";
1271                                 die errmsg("%s %s: %s\n", errmsg("create"), "$infile.$i[$i]",
1272                                 $!) unless defined $fh;
1273
1274                                 new_filehandle($fh);
1275
1276                                 eval {
1277                                         unlink "$infile.$n[$i]" if -l "$infile.$n[$i]";
1278                                         symlink "$infile.$i[$i]", "$infile.$n[$i]";
1279                                 };
1280                                 push @fc, ["$infile.$i[$i]", "$infile.$n[$i]"]
1281                                         if $@;
1282                                 push @fh, $fh;
1283                                 if($o[$i] =~ s/c//) {
1284                                         $index .= <<EndOfIndex;
1285                         map { print { \$fh[$i] } "\$_\\t\$fields[0]\\n" } split /\\s*,\\s*/, \$fields[$fnum];
1286 EndOfIndex
1287                                 }
1288                                 elsif($o[$i] =~ s/s//) {
1289                                         $index .= <<EndOfIndex;
1290                         map { print { \$fh[$i] } "\$_\\t\$fields[0]\\n" } split /\\s*;\\s*/, \$fields[$fnum];
1291 EndOfIndex
1292                                 }
1293                                 else {
1294                                         $index .= <<EndOfIndex;
1295                         print { \$fh[$i] } "\$fields[$fnum]\\t\$fields[0]\\n";
1296 EndOfIndex
1297                                 }
1298                         }
1299                 }
1300         }
1301
1302         my $numeric_guess = '';
1303         my $numeric_clean = '';
1304         my %non_numeric;
1305         my @empty;
1306         my @possible;
1307         my $clean;
1308
1309         if($options->{GUESS_NUMERIC} and $options->{type} ne '8') {
1310                 @possible = (0 .. $#field_names);
1311                 @empty = map { 1 } (0 .. $#field_names);
1312                 
1313                 $numeric_guess = <<'EOF';
1314                         for (@possible) {
1315                                 ($empty[$_] = 0, next) if $fields[$_] =~ /^-?\d+\.?\d*$/;
1316                                 next if $empty[$_] && ! length($fields[$_]);
1317                                 $empty[$_] = undef;
1318                                 $clean = 1;
1319                                 $non_numeric{$_} = 1;
1320                         }
1321 EOF
1322                 $numeric_clean = <<'EOF';
1323                         next unless $clean;
1324                         undef $clean;
1325                         @possible = grep ! $non_numeric{$_}, @possible;
1326                         %non_numeric = ();
1327 EOF
1328         }
1329
1330 my %format = (
1331
1332         NOTES => <<EndOfRoutine,
1333         while (<IN>) {
1334             chomp;
1335                         \@fields = ();
1336                         s/\\r?\\n\\r?\\n((?s:.)*)//
1337                                 and \$fields[$idx] = \$1;
1338
1339                         while(s!($codere):[ \\t]*(.*)\\n?!!) {
1340                                 next unless defined \$field_hash->{\$1};
1341                                 \$fields[\$field_hash->{\$1}] = \$2;
1342                         }
1343                         $index
1344                         $numeric_guess
1345             \$out->set_row(\@fields);
1346                         $numeric_clean
1347         }
1348 EndOfRoutine
1349
1350         LINE => <<EndOfRoutine,
1351         while (<IN>) {
1352             chomp;
1353                         \$fields = \@fields = split(/$delimiter/, \$_, $field_count);
1354                         $index
1355                         push (\@fields, '') until \$fields++ >= $field_count;
1356                         $numeric_guess
1357             \$out->set_row(\@fields);
1358                         $numeric_clean
1359         }
1360 EndOfRoutine
1361
1362         CSV => <<EndOfRoutine,
1363                 while (\@fields = read_quoted_fields(\\*IN)) {
1364             \$fields = scalar \@fields;
1365                         $index
1366             push (\@fields, '') until \$fields++ >= $field_count;
1367                         $numeric_guess
1368             \$out->set_row(\@fields);
1369                         $numeric_clean
1370         }
1371 EndOfRoutine
1372
1373         NONE => <<EndOfRoutine,
1374         while (<IN>) {
1375             chomp;
1376             \$fields = \@fields = split(/$delimiter/, \$_, 99999);
1377                         $excel
1378                         $index
1379             push (\@fields, '') until \$fields++ >= $field_count;
1380                         $numeric_guess
1381             \$out->set_row(\@fields);
1382                         $numeric_clean
1383         }
1384 EndOfRoutine
1385
1386         UNIX => <<EndOfRoutine,
1387         while (<IN>) {
1388             chomp;
1389                         if(s/\\\\\$//) {
1390                                 \$_ .= <IN>;
1391                                 redo;
1392                         }
1393                         elsif (s/<<(\\w+)\$//) {
1394                                 my \$mark = \$1;
1395                                 my \$line = \$_;
1396                                 \$line .= Vend::Config::read_here(\\*IN, \$mark);
1397                                 \$_ = \$line;
1398                                 redo;
1399                         }
1400
1401             \$fields = \@fields = split(/$delimiter/, \$_, 99999);
1402                         $excel
1403                         $index
1404             push (\@fields, '') until \$fields++ >= $field_count;
1405                         $numeric_guess
1406             \$out->set_row(\@fields);
1407                         $numeric_clean
1408         }
1409 EndOfRoutine
1410
1411         DITTO => <<EndOfRoutine,
1412         while (<IN>) {
1413             chomp;
1414                         if(/^$delimiter/) {
1415                                 \$fields = \@addl = split /$delimiter/, \$_, 99999;
1416                                 shift \@addl;
1417                                 $excel_addl
1418                                 my \$i;
1419                                 for(\$i = 0; \$i < \@addl; \$i++) {
1420                                         \$fields[\$i] .= "\n\$addl[\$i]"
1421                                                 if \$addl[\$i] ne '';
1422                                 }
1423                         }
1424                         else {
1425                                 \$fields = \@fields = split(/$delimiter/, \$_, 99999);
1426                                 $excel
1427                                 $index
1428                                 push (\@fields, '') until \$fields++ >= $field_count;
1429                         }
1430                         $numeric_guess
1431             \$out->set_row(\@fields);
1432                         $numeric_clean
1433         }
1434 EndOfRoutine
1435
1436 );
1437
1438     eval $format{$format};
1439         die errmsg("%s import into %s failed: %s", $options->{name}, $options->{table}, $@) if $@;
1440     if($realfile) {
1441                 close IN
1442                         or die errmsg("%s %s: %s\n", errmsg("close"), $infile, $!);
1443                 if(-f $realfile) {
1444                         open(IN, "+<$realfile")
1445                                 or die
1446                                         errmsg("%s %s: %s\n", errmsg("open read/write"), $realfile, $!);
1447                         lockfile(\*IN, 1, 1)
1448                                 or die errmsg("%s %s: %s\n", errmsg("lock"), $realfile, $!);
1449                         new_filehandle(\*IN);
1450                         <IN>;
1451                         eval $format{$format};
1452                         die errmsg("%s %s: %s\n", errmsg("import"), $options->{name}, $!) if $@;
1453                 }
1454                 elsif (! open(IN, ">$realfile") && new_filehandle(\*IN) ) {
1455                                 die errmsg("%s %s: %s\n", errmsg("create"), $realfile, $!);
1456                 } 
1457                 else {
1458                         print IN join($options->{DELIMITER}, @field_names);
1459                         print IN $/;
1460                         close IN;
1461                 }
1462         }
1463         if(@fh) {
1464                 my $no_sort;
1465                 my $sort_sub;
1466                 my $ftest = Vend::Util::catfile($Vend::Cfg->{ScratchDir}, 'sort.test');
1467                 my $cmd = "echo you_have_no_sort_but_we_will_cope | sort -f -n -o $ftest";
1468                 system $cmd;
1469                 $no_sort = 1 if ! -f $ftest;
1470                 
1471                 my $fh;
1472                 my $i;
1473                 for ($i = 0; $i < @fh; $i++) {
1474                         close $fh[$i] or die "close: $!";
1475                         unless ($no_sort) {
1476                                 $o[$i] = "-$o[$i]" if $o[$i];
1477                                 $cmd = "sort $o[$i] -o $infile.$i[$i] $infile.$i[$i]";
1478                                 system $cmd;
1479                         }
1480                         else {
1481                                 $fh = new IO::File "$infile.$i[$i]";
1482                                 new_filehandle($fh);
1483                                 my (@lines) = <$fh>;
1484                                 close $fh or die "close: $!";
1485                                 my $option = $o[$i] || 'none';
1486                                 @lines = sort { &{$Sort{$option}} } @lines;
1487                                 $fh = new IO::File ">$infile.$i[$i]";
1488                                 new_filehandle($fh);
1489                                 print $fh @lines;
1490                                 close $fh or die "close: $!";
1491                         }
1492                 }
1493         }
1494         if(@fc) {
1495                 require File::Copy;
1496                 for(@fc) {
1497                         File::Copy::copy(@{$_});
1498                 }
1499         }
1500
1501         unless($options->{no_commit}) {
1502                 $out->commit() if $out->config('HAS_TRANSACTIONS');
1503         }
1504         delete $out->[$CONFIG]{Clean_start};
1505         delete $out->[$CONFIG]{_Dirty};
1506         unless($options->{scalar_ref}){
1507                 unlockfile(\*IN) or die "unlock\n";
1508         }
1509     close(IN);
1510         my $dot = $out->[$CONFIG]{HIDE_AUTO_FILES} ? '.' : '';
1511         if($numeric_guess) {
1512                 my $fn = Vend::Util::catfile($out->[$CONFIG]{DIR}, "$dot$out->[$CONFIG]{file}");
1513                 Vend::Util::writefile(
1514                                         ">$fn.numeric",
1515                                         join " ", map { $field_names[$_] } @possible,
1516                 );
1517         }
1518     return $out;
1519 }
1520
1521 sub import_from_ic_db {
1522     my ($infile, $options, $table_name) = @_;
1523
1524         my $tname = $options->{MIRROR}
1525                 or die errmsg(
1526                                 "Memory mirror table not specified for table %s.",
1527                                 $table_name,
1528                         );
1529 #::logDebug("Importing mirrored $table_name from $tname");
1530
1531         $Vend::Database{$tname} =
1532                 Vend::Data::import_database($Vend::Cfg->{Database}{$tname})
1533                         unless $Vend::Database{$tname};
1534
1535         my $idb = Vend::Data::database_exists_ref($tname)
1536                 or die errmsg(
1537                                 "Memory mirror table %s does not exist (yet) to create mirror %s.\n",
1538                                 $tname,
1539                                 $table_name,
1540                         );
1541
1542         my @field_names = $idb->columns;
1543
1544         my $odb;
1545
1546         if($options->{ObjectType}) {
1547                 no strict 'refs';
1548                 $odb = &{"$options->{ObjectType}::create"}(
1549                                                                         $options->{ObjectType},
1550                                                                         $options,
1551                                                                         \@field_names,
1552                                                                         $table_name,
1553                                                                 );
1554         }
1555         else {
1556                 $odb = $options->{Object};
1557         }
1558
1559 #::logDebug("idb=$idb odb=$odb");
1560         eval {
1561                 my $f;
1562                 while($f = $idb->each_nokey($options->{MIRROR_QUAL})) {
1563 #::logDebug("importing key=$f->[0]");
1564                         $odb->set_row(@$f);
1565                 }
1566         };
1567
1568         if($@) {
1569                 die errmsg(
1570                                 "Problem with mirror import from source %s to target %s\n",
1571                                 $tname,
1572                                 $table_name,
1573                                 );
1574         }
1575         
1576         $odb->[$CONFIG]{Mirror_complete} = 1;
1577         delete $odb->[$CONFIG]{Clean_start};
1578     return $odb;
1579 }
1580
1581 my $white = ' \t';
1582
1583 sub read_quoted_fields {
1584     my ($filehandle) = @_;
1585     local ($_, $.);
1586     while(<$filehandle>) {
1587         s/[\r\n\cZ]+$//g;           # ms-dos cruft
1588         next if m/^[$white]*$/o;     # skip blank lines
1589         my @f = parse($_, $.);
1590 #::logDebug("read: '" . join("','", @f) . "'");
1591         return parse($_, $.);
1592     }
1593     return ();
1594 }
1595
1596 sub parse {
1597     local $_ = $_[0];
1598     my $linenum = $_[1];
1599
1600     my $expect = 1;
1601     my @a = ();
1602     my $x;
1603     while ($_ ne '') {
1604         if    (m# \A ([$white]+) (.*) #ox) { }
1605         elsif (m# \A (,[$white]*) (.*) #ox) {
1606             push @a, '' if $expect;
1607             $expect = 1;
1608         }
1609         elsif (m# \A ([^",$white] (?:[$white]* [^,$white]+)*) (.*) #ox) {
1610             push @a, $1;
1611             $expect = 0;
1612         }
1613         elsif (m# \A " ((?:[^"] | (?:""))*) " (?!") (.*) #x) {
1614             ($x = $1) =~ s/""/"/g;
1615             push @a, $x;
1616             $expect = 0;
1617         }
1618         elsif (m# \A " #x) {
1619             die "Unterminated quote at line $linenum\n";
1620         }
1621         else { die "Can't happen: '$_'" }
1622         $_ = $2;
1623     }
1624     $expect and push @a, '';
1625     return @a;
1626 }
1627
1628 sub reset {
1629         undef $restrict;
1630 }
1631
1632 sub errstr {
1633         return shift(@_)->[$CONFIG]{last_error};
1634 }
1635
1636 sub log_error {
1637         my ($s, $tpl, @args) = @_;
1638         if($tpl =~ /^(prepare|execute)$/) {
1639                 if(!@args) {
1640                         $tpl = "Statement $tpl failed: %s";
1641                 }
1642                 elsif (@args == 1) {
1643                         $tpl = "Statement $tpl failed: %s\nQuery was: %s";
1644                 }
1645                 else {
1646                         $tpl = "Statement $tpl failed: %s\nQuery was: %s";
1647                         $tpl .= "\nAdditional: %s" for (2 .. scalar(@args));
1648                 }
1649                 unshift @args, $DBI::errstr;
1650         }
1651         my $msg = errmsg($tpl, @args);
1652         my $ekey = 'table ' . $s->[$CONFIG]{name};
1653         my $cfg = $s->[$CONFIG];
1654         unless(defined $cfg->{LOG_ERROR_CATALOG} and ! $cfg->{LOG_ERROR_CATALOG}) {
1655                 logError($msg);
1656         }
1657         if($cfg->{LOG_ERROR_GLOBAL}) {
1658                 logGlobal($msg);
1659         }
1660         if($Vend::admin or ! defined($cfg->{LOG_ERROR_SESSION}) or $cfg->{LOG_ERROR_SESSION}) {
1661                 $Vend::Session->{errors} = {} unless CORE::ref($Vend::Session->{errors}) eq 'HASH';
1662                 $Vend::Session->{errors}{$ekey} = $msg;
1663         }
1664         die $msg if $cfg->{DIE_ERROR};
1665         return $cfg->{last_error} = $msg;
1666 }
1667
1668 sub new_filehandle {
1669         my $fh = shift;
1670         binmode($fh, ":utf8") if $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
1671         return $fh;
1672 }
1673
1674 1;
1675
1676 __END__