[interchange-cvs] interchange - heins modified 22 files
interchange-core@icdevgroup.org
interchange-core@icdevgroup.org
Mon Sep 16 19:07:01 2002
User: heins
Date: 2002-09-16 23:06:33 GMT
Modified: . MANIFEST
Modified: code/UI_Tag db_hash.coretag dump_session.coretag
Modified: write_shipping.coretag
Modified: code/UserTag var.tag
Modified: lib/Vend Accounting.pm Config.pm Control.pm Data.pm Error.pm
Modified: Interpolate.pm Order.pm SOAP.pm Search.pm Server.pm
Modified: Session.pm UserDB.pm Util.pm
Modified: lib/Vend/Accounting SQL_Ledger.pm
Modified: lib/Vend/Payment MCVE.pm
Modified: lib/Vend/Table DBI.pm
Modified: scripts interchange.PL
Log:
* Move most all code out of bin/interchange. The only routines
that remain are:
dontwarn
version
usage
catch_warnings
parse_options
main_loop
Once the initial startup for Interchange is done, this code
is completely out of the picture.
* Create new Vend::Dispatch module which contains the bulk of the
code removed from bin/interchange.
* Move the important update_data() subroutine to Vend::Data.
* Move the session-related routines to Vend::Session.
* Move the order-related routines do_order() and update_quantity()
to Vend::Order.
* Change many ::uneval() calls to plain uneval() or Vend::Util::uneval().
* Remove various unused tags and routines....
Revision Changes Path
2.62 +1 -5 interchange/MANIFEST
rev 2.62, prev_rev 2.61
Index: MANIFEST
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/MANIFEST,v
retrieving revision 2.61
retrieving revision 2.62
diff -u -r2.61 -r2.62
--- MANIFEST 13 Sep 2002 20:46:17 -0000 2.61
+++ MANIFEST 16 Sep 2002 23:06:30 -0000 2.62
@@ -147,16 +147,12 @@
code/UI_Tag/list_glob.coretag
code/UI_Tag/list_keys.coretag
code/UI_Tag/list_pages.coretag
-code/UI_Tag/load_templates.coretag
code/UI_Tag/meta_record.coretag
code/UI_Tag/mm_locale.coretag
code/UI_Tag/mm_value.coretag
code/UI_Tag/newer.coretag
code/UI_Tag/quick_table.coretag
-code/UI_Tag/read_page.coretag
code/UI_Tag/read_shipping.coretag
-code/UI_Tag/read_ui_page.coretag
-code/UI_Tag/read_ui_template.coretag
code/UI_Tag/reconfig.coretag
code/UI_Tag/reconfig_time.coretag
code/UI_Tag/reconfig_wait.coretag
@@ -918,7 +914,6 @@
dist/lib/UI/pages/admin/bug_report.html
dist/lib/UI/pages/admin/build_related.html
dist/lib/UI/pages/admin/button_builder.html
-dist/lib/UI/pages/admin/compedit.html
dist/lib/UI/pages/admin/content.html
dist/lib/UI/pages/admin/content_editor.html
dist/lib/UI/pages/admin/content_preview.html
@@ -1174,6 +1169,7 @@
lib/Vend/CounterFile.pm
lib/Vend/Data.pm
lib/Vend/DbSearch.pm
+lib/Vend/Dispatch.pm
lib/Vend/Document.pm
lib/Vend/Error.pm
lib/Vend/External.pm
1.2 +2 -4 interchange/code/UI_Tag/db_hash.coretag
rev 1.2, prev_rev 1.1
Index: db_hash.coretag
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/code/UI_Tag/db_hash.coretag,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- db_hash.coretag 29 Jan 2002 05:52:40 -0000 1.1
+++ db_hash.coretag 16 Sep 2002 23:06:31 -0000 1.2
@@ -6,10 +6,9 @@
my($table, $col, $key, $opt) =3D @_;
$col =3D~ s/:+(.*)//s;
my $out;
- #$out .=3D ::uneval(\@_);
my $rest =3D $1;
my $val =3D ::tag_data($table,$col,$key);
- #$out .=3D "val=3D$val";
+
my $ref;
if ($val !~ /\S/) {
$ref =3D {};
@@ -28,7 +27,6 @@
my $final =3D pop @extra;
my $curr =3D $ref;
$out .=3D "Original key request: $rest\n";
- #$out .=3D ::uneval($ref);
$out .=3D "\nFinal key: $final\n";
for(@extra) {
$out .=3D "key --> $_\n";
@@ -47,7 +45,7 @@
}
else {
$curr->{$final} =3D $opt->{value};
- tag_data($table, $col, $key, { value =3D> ::uneval_it($ref) });
+ tag_data($table, $col, $key, { value =3D> uneval_it($ref) });
return $curr->{$final};
}
}
1.2 +1 -1 interchange/code/UI_Tag/dump_session.coretag
rev 1.2, prev_rev 1.1
Index: dump_session.coretag
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/code/UI_Tag/dump_session.coretag,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- dump_session.coretag 29 Jan 2002 05:52:40 -0000 1.1
+++ dump_session.coretag 16 Sep 2002 23:06:31 -0000 1.2
@@ -30,7 +30,7 @@
else {
my $fn =3D Vend::Util::get_filename($name, 2, 1, $Vend::Cfg->{SessionDat=
abase});
return '' unless -f $fn;
- return ::uneval(Vend::Util::eval_file($fn));
+ return uneval(Vend::Util::eval_file($fn));
}
}
EOR
1.2 +1 -1 interchange/code/UI_Tag/write_shipping.coretag
rev 1.2, prev_rev 1.1
Index: write_shipping.coretag
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/code/UI_Tag/write_shipping.coretag,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- write_shipping.coretag 29 Jan 2002 05:52:40 -0000 1.1
+++ write_shipping.coretag 16 Sep 2002 23:06:31 -0000 1.2
@@ -16,7 +16,7 @@
my @line =3D @$_;
my $opt =3D '';
if (ref($line[7]) =3D~ /HASH/) {
- $line[7] =3D ::uneval_it($line[7]);
+ $line[7] =3D uneval_it($line[7]);
}
push @outlines, \@line;
}
1.2 +7 -3 interchange/code/UserTag/var.tag
rev 1.2, prev_rev 1.1
Index: var.tag
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/code/UserTag/var.tag,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- var.tag 29 Jan 2002 05:52:42 -0000 1.1
+++ var.tag 16 Sep 2002 23:06:31 -0000 1.2
@@ -18,9 +18,13 @@
return $Vend::Cfg->{Member}{$key}
if $Vend::Session->{logged_in}
&& defined $Vend::Cfg->{Member}{$key};
- if($global) {
- return Vend::Interpolate::dynamic_var($key) || $Global::Variable->{$key};
+
+ if($::Pragma->{dynamic_variables}) {
+ return Vend::Interpolate::dynamic_var($key) || $Global::Variable->{$key}
+ if $global;
+ return Vend::Interpolate::dynamic_var($key);
}
- return Vend::Interpolate::dynamic_var($key);
+ return $::Variable->{$key} || $Global::Variable if $global;
+ return $::Variable->{$key};
}
EOR
2.2 +5 -5 interchange/lib/Vend/Accounting.pm
rev 2.2, prev_rev 2.1
Index: Accounting.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Accounting.pm,v
retrieving revision 2.1
retrieving revision 2.2
diff -u -r2.1 -r2.2
--- Accounting.pm 11 Jun 2002 20:30:58 -0000 2.1
+++ Accounting.pm 16 Sep 2002 23:06:31 -0000 2.2
@@ -1,6 +1,6 @@
# Vend::Accounting - Interchange payment processing routines
#
-# $Id: Accounting.pm,v 2.1 2002/06/11 20:30:58 mheins Exp $
+# $Id: Accounting.pm,v 2.2 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 2002 Mike Heins, <mike@heins.net>
#
@@ -21,7 +21,7 @@
=20
package Vend::Accounting;
=20
-$VERSION =3D substr(q$Revision: 2.1 $, 10);
+$VERSION =3D substr(q$Revision: 2.2 $, 10);
=20
use Vend::Util;
use LWP::UserAgent;
@@ -224,7 +224,7 @@
my %result;
if($Have_Net_SSLeay) {
#::logDebug("placing Net::SSLeay request: host=3D$server, port=3D$port, sc=
ript=3D$script");
-#::logDebug("values: " . ::uneval($query) );
+#::logDebug("values: " . uneval($query) );
my ($page, $response, %reply_headers)
=3D post_https(
$server, $port, $script,
@@ -247,7 +247,7 @@
my @query =3D %{$query};
my $ua =3D new LWP::UserAgent;
my $req =3D POST($submit_url, \@query, %header);
-#::logDebug("placing LWP request: " . ::uneval_it($req) );
+#::logDebug("placing LWP request: " . uneval_it($req) );
my $resp =3D $ua->request($req);
$result{status_line} =3D $resp->status_line();
$result{status_line} =3D~ /(\d+)/
@@ -257,7 +257,7 @@
#::logDebug("received LWP header: $header_string");
$result{result_page} =3D $resp->content();
}
-#::logDebug("returning thing: " . ::uneval_it(\%result) );
+#::logDebug("returning thing: " . uneval_it(\%result) );
return \%result;
}
=20
2.71 +155 -9 interchange/lib/Vend/Config.pm
rev 2.71, prev_rev 2.70
Index: Config.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Config.pm,v
retrieving revision 2.70
retrieving revision 2.71
diff -u -r2.70 -r2.71
--- Config.pm 7 Sep 2002 20:05:10 -0000 2.70
+++ Config.pm 16 Sep 2002 23:06:31 -0000 2.71
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.70 2002/09/07 20:05:10 mheins Exp $
+# $Id: Config.pm,v 2.71 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -27,7 +27,7 @@
=20
@ISA =3D qw(Exporter);
=20
-@EXPORT =3D qw( config global_config );
+@EXPORT =3D qw( config global_config config_named_catalog );
=20
@EXPORT_OK =3D qw( get_catalog_default get_global_default parse_time parse=
_database);
=20
@@ -43,8 +43,9 @@
use Fcntl;
use Vend::Parse;
use Vend::Util;
+use Vend::Data;
=20
-$VERSION =3D substr(q$Revision: 2.70 $, 10);
+$VERSION =3D substr(q$Revision: 2.71 $, 10);
=20
my %CDname;
=20
@@ -176,7 +177,7 @@
warn "$msg\n" unless $Vend::Quiet;
}
else {
- ::logGlobal({level =3D> 'warn'}, $msg);
+ logGlobal({level =3D> 'warn'}, $msg);
die "$msg\n";
}
}
@@ -972,6 +973,146 @@
return $value;
}
=20
+sub config_named_catalog {
+ my ($cat_name, $source, $db_only, $dbconfig) =3D @_;
+ my ($g,$c);
+
+ $g =3D $Global::Catalog{$cat_name};
+ unless (defined $g) {
+ logGlobal( "Can't find catalog '%s'" , $cat_name );
+ return undef;
+ }
+
+ $Vend::Log_suppress =3D 1;
+
+ unless ($db_only or $Vend::Quiet) {
+ logGlobal( "Config '%s' %s%s", $g->{'name'}, $source );
+ }
+ undef $Vend::Log_suppress;
+
+ chdir $g->{'dir'}
+ or die "Couldn't change to $g->{'dir'}: $!\n";
+
+ if($db_only) {
+ logGlobal(
+ "Config table '%s' (file %s) for catalog %s from %s",
+ $db_only,
+ $dbconfig,
+ $g->{'name'},
+ $source,
+ );
+ my $cfg =3D $Global::Selector{$g->{script}}
+ or die errmsg("'%s' not a catalog (%s).", $g->{name}, $g->{script});
+ undef $cfg->{Database}{$db_only};
+ $Vend::Cfg =3D config(
+ $g->{name},
+ $g->{dir},
+ undef,
+ undef,
+ $cfg,
+ $dbconfig,
+ )
+ or die errmsg("error configuring catalog %s table %s: %s",
+ $g->{name},
+ $db_only,
+ $@,
+ );
+ open_database();
+ close_database();
+ return $Vend::Cfg;
+ }
+
+ eval {
+ $c =3D config($g->{'name'},
+ $g->{'dir'},
+ undef,
+ $g->{'base'} || undef,
+# OPTION_EXTENSION
+# $Vend::CommandLine->{$g->{'name'}} || undef
+# END OPTION_EXTENSION
+ );
+ };
+
+ if($@) {
+ my $msg =3D $@;
+ logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
+ return undef;
+ }
+
+ if (defined $g->{base}) {
+ open_database(1);
+ dump_structure($c, $g->{name}) if $Global::DumpStructure;
+ return $c;
+ }
+
+ eval {
+ $Vend::Cfg =3D $c;=09
+ $::Variable =3D $Vend::Cfg->{Variable};
+ $::Pragma =3D $Vend::Cfg->{Pragma};
+ Vend::Data::read_salestax();
+ Vend::Data::read_shipping();
+ open_database(1);
+ my $db;
+
+ LREAD: {
+ last LREAD unless $db =3D $Vend::Cfg->{LocaleDatabase};
+ $db =3D database_exists_ref($db)
+ or last LREAD;
+ $db =3D $db->ref();
+ my ($k, @f); # key and fields
+ my @l; # refs to locale repository
+ my @n; # names of locales
+
+ @n =3D $db->columns();
+ my $extra;
+ for(@n) {
+ $Vend::Cfg->{Locale_repository}{$_} =3D {}
+ unless $Vend::Cfg->{Locale_repository}{$_};
+ push @l, $Vend::Cfg->{Locale_repository}{$_};
+ }
+ my $i;
+ while( ($k , @f ) =3D $db->each_record) {
+ for ($i =3D 0; $i < @f; $i++) {
+ next unless length($f[$i]);
+ $l[$i]->{$k} =3D $f[$i];
+ }
+ }
+ unless ($Vend::Cfg->{Locale}) {
+ for(@n) {
+ next unless $Vend::Cfg->{Locale_repository}{$_}{'default'};
+ $Vend::Cfg->{DefaultLocale} =3D $_;
+ $Vend::Cfg->{Locale} =3D $Vend::Cfg->{Locale_repository}{$_};
+ last;
+ }
+ unless ($Vend::Cfg->{Locale}) {
+ $Vend::Cfg->{Locale} =3D $Vend::Cfg->{Locale_repository}{$n[0]};
+ $Vend::Cfg->{DefaultLocale} =3D $n[0];
+ }
+ }
+ }
+
+ close_database();
+ };
+
+ undef $Vend::Cfg;
+ if($@) {
+ my $msg =3D $@;
+ $msg =3D~ s/\s+$//;
+ logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
+ return undef;
+ }
+
+ dump_structure($c, $g->{name}) if $Global::DumpStructure;
+
+ my $stime =3D scalar localtime();
+ Vend::Util::writefile(">$Global::RunDir/status.$g->{name}", "$stime\n");
+ Vend::Util::writefile(">$c->{ConfDir}/status.$g->{name}", "$stime\n");
+
+ return $c;
+
+}
+
+
use File::Find;
=20
my %extmap =3D qw/
@@ -1331,7 +1472,7 @@
push @{$C->{Tie_Watch}}, $name;
=20
my ($ref, $orig);
-#::logDebug("Contents of $name: " . ::uneval_it($C->{$name}));
+#::logDebug("Contents of $name: " . uneval_it($C->{$name}));
if(ref($C->{$name}) =3D~ /ARRAY/) {
#::logDebug("watch ref=3Darray");
$ref =3D $C->{$name};
@@ -1783,7 +1924,7 @@
print $msg;
}
else {
- ::logGlobal({level =3D> 'info', strip =3D> $strip },
+ logGlobal({level =3D> 'info', strip =3D> $strip },
errmsg($val,
$name,
$.,
@@ -2130,6 +2271,11 @@
}
return 1;
},
+ Glimpse =3D> sub {
+ return 1 unless shift;
+ require Vend::Glimpse;
+ return 1;
+ },
SOAP_Socket =3D> sub {
shift;
return 1 if $Have_set_global_defaults;
@@ -2615,7 +2761,7 @@
$cat->{$key} =3D $value;
}
=20
-#::logDebug ("parsing catalog $name =3D " . ::uneval_it($cat));
+#::logDebug ("parsing catalog $name =3D " . uneval_it($cat));
=20
$Global::Catalog{$name} =3D $cat;
=20
@@ -2744,7 +2890,7 @@
}
}
=20
-#::logDebug("d object: " . ::uneval_it($d));
+#::logDebug("d object: " . uneval_it($d));
if($d->{ACTIVE} and ! $d->{OBJECT}) {
my $name =3D $d->{'name'};
$d->{OBJECT} =3D Vend::Data::import_database($d)
@@ -2940,7 +3086,7 @@
config_warn(
"Bad $var value '%s': %s\n%s",
"Database $table $file $type",
- ::uneval($C->{Database}),
+ uneval($C->{Database}),
);
return '';
}
2.5 +5 -5 interchange/lib/Vend/Control.pm
rev 2.5, prev_rev 2.4
Index: Control.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Control.pm,v
retrieving revision 2.4
retrieving revision 2.5
diff -u -r2.4 -r2.5
--- Control.pm 19 Jul 2002 05:13:16 -0000 2.4
+++ Control.pm 16 Sep 2002 23:06:31 -0000 2.5
@@ -1,6 +1,6 @@
# Vend::Control - Routines that alter the running Interchange daemon
#=20
-# $Id: Control.pm,v 2.4 2002/07/19 05:13:16 mheins Exp $
+# $Id: Control.pm,v 2.5 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -45,7 +45,7 @@
my (@cats) =3D @_;
for(@cats) {
my $ref =3D $Global::Catalog{$_}
- or die ::errmsg("Unknown catalog '%s'. Stopping.\n", $_);
+ or die errmsg("Unknown catalog '%s'. Stopping.\n", $_);
Vend::Util::writefile("$Global::RunDir/reconfig", "$ref->{script}\n");
}
}
@@ -111,7 +111,7 @@
}
my $msg;
if($mode eq 'cron') {
- $msg =3D ::errmsg(
+ $msg =3D errmsg(
"Dispatching jobs=3D%s for cat %s to Interchange server %s with %s.\n=
",
$Vend::CronJob,
$Vend::CronCat,
@@ -120,7 +120,7 @@
);
}
else {
- $msg =3D ::errmsg(
+ $msg =3D errmsg(
"Killing Interchange server %s with %s.\n",
$pid,
$sig,
@@ -140,7 +140,7 @@
my @aliases;
=20
unless(defined $g) {
- ::logGlobal( {level =3D> 'error'}, "Attempt to remove non-existant catal=
og %s." , $name );
+ logGlobal( {level =3D> 'error'}, "Attempt to remove non-existant catalog=
%s." , $name );
return undef;
}
=20
2.16 +568 -22 interchange/lib/Vend/Data.pm
rev 2.16, prev_rev 2.15
Index: Data.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Data.pm,v
retrieving revision 2.15
retrieving revision 2.16
diff -u -r2.15 -r2.16
--- Data.pm 10 Aug 2002 02:30:26 -0000 2.15
+++ Data.pm 16 Sep 2002 23:06:31 -0000 2.16
@@ -1,6 +1,6 @@
# Vend::Data - Interchange databases
#
-# $Id: Data.pm,v 2.15 2002/08/10 02:30:26 mheins Exp $
+# $Id: Data.pm,v 2.16 2002/09/16 23:06:31 mheins Exp $
#=20
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -55,6 +55,7 @@
product_row
product_row_hash
set_field
+update_data
=20
);
@EXPORT_OK =3D qw(update_productbase column_index);
@@ -196,7 +197,7 @@
undef $Vend::OnlyProducts if scalar @Vend::Productbase > 1;
=20
$Products =3D $Vend::Productbase[0];
-#::logError("Productbase: '@Vend::Productbase' --> " . ::uneval(\%Vend::Ba=
sefinder));
+#::logError("Productbase: '@Vend::Productbase' --> " . uneval(\%Vend::Base=
finder));
=20
}
=20
@@ -230,7 +231,7 @@
=20
sub database_field {
my ($db, $key, $field_name, $foreign) =3D @_;
-#::logDebug("database_field: " . ::uneval_it(\@_));
+#::logDebug("database_field: " . uneval_it(\@_));
$db =3D database_exists_ref($db) or return undef;
return '' unless defined $db->test_column($field_name);
$key =3D $db->foreign($key, $foreign) if $foreign;
@@ -251,7 +252,7 @@
$db =3D $db->ref();
return undef unless $db->test_record($key);
return undef unless defined $db->test_column($field_name);
-#::logDebug(__PACKAGE__ . "increment_field: " . ::uneval_it(\@_));
+#::logDebug(__PACKAGE__ . "increment_field: " . uneval_it(\@_));
return $db->inc_field($key, $field_name, $adder);
}
=20
@@ -742,15 +743,15 @@
};
if($@) {
my $msg =3D "table '%s' failed: %s";
- $msg =3D ::errmsg($msg, $name, $@);
- ::logError($msg);
+ $msg =3D errmsg($msg, $name, $@);
+ logError($msg);
}
}
else {
if($data->{GUESS_NUMERIC}) {
my $dir =3D $data->{DIR} || $Vend::Cfg->{ProductDir};
my $fn =3D Vend::Util::catfile( $dir, $data->{file} );
- my @fields =3D grep /\S/, split /\s+/, ::readfile("$fn.numeric");
+ my @fields =3D grep /\S/, split /\s+/, readfile("$fn.numeric");
$data->{NUMERIC} =3D {};
for(@fields) {
$data->{NUMERIC}{$_} =3D 1;
@@ -799,10 +800,10 @@
# if($type =3D=3D 9) {
#my @caller =3D caller();
#::logDebug ("enter import_database: dummy=3D$dummy");
-#::logDebug("opening table table=3D$database config=3D" . ::uneval($obj) .=
" caller=3D@caller");
+#::logDebug("opening table table=3D$database config=3D" . uneval($obj) . "=
caller=3D@caller");
#
-#::logDebug ("database=3D$database type=3D$type name=3D$name obj=3D" . ::u=
neval($obj));
-#::logDebug ("database=3D$database type=3D$type name=3D$name obj=3D" . ::u=
neval($obj)) if $obj->{HOT};
+#::logDebug ("database=3D$database type=3D$type name=3D$name obj=3D" . une=
val($obj));
+#::logDebug ("database=3D$database type=3D$type name=3D$name obj=3D" . une=
val($obj)) if $obj->{HOT};
#=09
# }
return $Vend::Cfg->{SaveDatabase}->{$name}
@@ -1096,7 +1097,7 @@
=20
#::logDebug(
# "dbname=3D$dbname db_fn=3D$db_fn bx_fn=3D$bx_fn ix_fn=3D$ix_fn\n" .
-# "options: " . Vend::Util::uneval($opt) . "\n"
+# "options: " . uneval($opt) . "\n"
# );
=20
if( ! -f $bx_fn
@@ -1126,7 +1127,7 @@
my @fields =3D grep $_ ne $key, split /[\0,\s]+/, $opt->{fn};
my $sort =3D join ",", @fields;
if(! $opt->{fn}) {
- ::logError(errmsg("index attempted on table '%s' with no fields, no sea=
rch spec", $dbname));
+ logError(errmsg("index attempted on table '%s' with no fields, no searc=
h spec", $dbname));
return undef;
}
$opt->{spec} =3D <<EOF;
@@ -1156,7 +1157,7 @@
@fn =3D split /\s*[\0,]+\s*/, $c->{mv_return_fields};
}
=20
-#::logDebug( "search options: " . Vend::Util::uneval($c) . "\n");
+#::logDebug( "search options: " . uneval($c) . "\n");
=20
open(Vend::Data::INDEX, "+<$ix_fn") or
open(Vend::Data::INDEX, "+>$ix_fn") or
@@ -1419,7 +1420,7 @@
=20
my $db =3D database_exists_ref($table);
if(! $db) {
- ::logError('Non-existent price option table %s', $table);
+ logError('Non-existent price option table %s', $table);
return;
}
#::logDebug("database $table exists");
@@ -1445,7 +1446,7 @@
#::logDebug("called option_cost");
my $db =3D database_exists_ref($table);
if(! $db) {
- ::logError('Non-existent price option table %s', $table);
+ logError('Non-existent price option table %s', $table);
return;
}
=20
@@ -1493,7 +1494,7 @@
my $f;
=20
foreach $ref (@$ary) {
-#::logDebug("checking option " . ::uneval_it($ref));
+#::logDebug("checking option " . uneval_it($ref));
next unless defined $item->{$ref->[0]};
$ref->[1] =3D~ s/^\s+//;
$ref->[1] =3D~ s/\s+$//;
@@ -1536,11 +1537,11 @@
@p =3D Text::ParseWords::shellwords($raw);
}
if(scalar @p > ($Vend::Cfg->{Limit}{chained_cost_levels} || 64)) {
- ::logError('Too many chained cost levels for item ' . uneval($item) );
+ logError('Too many chained cost levels for item ' . uneval($item) );
return undef;
}
=20
-#::logDebug("chain_cost item =3D " . uneval ($item) . "\np=3D" . ::uneval(=
\@p) );
+#::logDebug("chain_cost item =3D " . uneval ($item) . "\np=3D" . uneval(\@=
p) );
my ($chain, $percent);
my $passed_key;
my $want_key;
@@ -1548,7 +1549,7 @@
foreach $price (@p) {
next if ! length($price);
if($its++ > ($Vend::Cfg->{Limit}{chained_cost_levels} || 64)) {
- ::logError('Too many chained cost levels for item ' . uneval($item) );
+ logError('Too many chained cost levels for item ' . uneval($item) );
last CHAIN;
}
$price =3D~ s/^\s+//;
@@ -1640,6 +1641,30 @@
#::logDebug("database referenc found table=3D$table field=3D$field key=3D$=
key|$item->{$key}|$item->{code} price=3D$price");
redo CHAIN;
}
+ elsif ($mod =3D~ s/(\w+)=3D(.*)//) {
+ my $tag =3D $1;
+ my(@args) =3D split /:/, $2;
+ my $sub =3D # $intrinsic_price{$tag} ||
+ $Vend::Cfg->{Sub}{$tag} || $Global::GlobalSub->{$tag};
+
+ my %i =3D %$item;
+=09=09=09
+ for(@args) {
+ my($k, $v) =3D split /=3D/, $_;
+ $i{$k} =3D $v;
+ }
+
+ $i{final} =3D $final;
+ $i{passed_key} =3D $passed_key if $passed_key;
+
+ if ($sub) {
+ $price =3D $sub->(\%i);
+ }
+ else {
+ $price =3D Vend::Tags->$tag(\%i);
+ }
+ redo CHAIN;
+ }
elsif ($mod =3D~ s/^[&]//) {
$Vend::Interpolate::item =3D $item;
$Vend::Interpolate::s =3D $final;
@@ -1652,7 +1677,7 @@
$final +=3D $1 if $1;
my ($attribute, $table, $field, $key) =3D split /:/, $2;
if($item->{$attribute}) {
- $key =3D $field ? $item->{$attribute} : $item->{'code'}
+ $key =3D $field ? $item->{$attribute} : $item->{code}
unless $key;
$price =3D database_field( ( $table ||
$item->{mv_ib} ||
@@ -1734,7 +1759,7 @@
$master =3D $item;
my $mv_mp =3D $item->{mv_mi}
or do {
- ::logError("Bad modular item %s: ", ::uneval_it($item));
+ logError("Bad modular item %s: ", uneval_it($item));
return 0;
};
for(@$Vend::Items) {
@@ -1763,7 +1788,7 @@
if($Vend::Cfg->{PriceDivide} =3D=3D 0) {
my $msg =3D "Locale %s PriceDivide non-numeric or zero [%s].";
$msg .=3D " Possibly bad locale data.",
- ::logError(
+ logError(
$msg,
$::Scratch->{mv_currency} || $::Scratch->{mv_locale},
$Vend::Cfg->{PriceDivide},
@@ -1824,6 +1849,527 @@
sub item_subtotal {
item_price($_[0]) * $_[0]->{quantity};
}
+
+sub set_db {
+ my ($base, $thing) =3D @_;
+ return ($base, $thing) unless $thing =3D~ /^(\w+):+(.*)/;
+ my $t =3D $1;
+ my $c =3D $2;
+
+ # Security handled before this in update_data
+ $Vend::WriteDatabase{$t} =3D 1;
+
+ my $db =3D database_exists_ref($t);
+ return undef unless $db;
+ return ($db->ref(), $c);
+}
+
+## Update the user-entered fields.
+sub update_data {
+ my($key,$value);
+ my @cgi_keys =3D keys %CGI::values;
+ # Update a database record
+ # Check to see if this is allowed
+#::logDebug("mv_data_enable=3D$::Scratch->{mv_data_enable}");
+ if(! $::Scratch->{mv_data_enable}) {
+ logError(
+ "Attempted database update without permission, table=3D%s key=3D%s.",
+ $CGI::values{mv_data_table},
+ $CGI::values{$CGI::values{mv_data_key}},
+ );
+ return undef;
+ }
+ unless (defined $CGI::values{mv_data_table} and=20
+ defined $CGI::values{mv_data_key} ) {
+ logError("Attempted database operation without table, fields, or key.\n"=
.
+ "Table: '%s'\n" .
+ "Fields:'%s'\n" .
+ "Key: '%s'\n",
+ $CGI::values{mv_data_table},
+ $CGI::values{mv_data_fields},
+ $CGI::values{mv_data_key},
+ );
+
+ return undef;
+ }
+
+ my $function =3D lc (delete $CGI::values{mv_data_function});
+ if($function eq 'delete' and ! delete $CGI::values{mv_data_verify}) {
+ logError("update_data: DELETE without VERIFY, abort");
+ return undef;
+ }
+ my $table =3D $CGI::values{mv_data_table};
+ my $prikey =3D $CGI::values{mv_data_key};
+ my $decode =3D is_yes($CGI::values{mv_data_decode});
+ my ($ref, $db, $database);
+
+ my $en_col;
+#::logDebug("data_enable=3D$::Scratch->{mv_data_enable}, checking");
+ if($::Scratch->{mv_data_enable} =3D~ /^(\w+):(.*?):/) {
+ # check for single key and possible set of columns
+ my $en_table =3D $1;
+ $en_col =3D $2;
+ my $en_key =3D $::Scratch->{mv_data_enable_key};
+#::logDebug("en_table=3D$en_table en_col=3D$en_col, en_key=3D$en_key, chec=
king");
+ if( $en_table ne $table
+ or=20
+ ($en_key and $CGI::values{$prikey} ne $en_key)
+ )
+ {
+ logError("Attempted database operation without permission:\n" .
+ "Permission: '%s' (key=3D'$en_key')\n" .
+ "Table: '%s'\n" .
+ "Fields:'%s'\n" .
+ "Key: '%s'\n",
+ $::Scratch->{mv_data_enable},
+ $CGI::values{mv_data_table},
+ $CGI::values{mv_data_fields},
+ $CGI::values{$CGI::values{mv_data_key}},
+ );
+ return undef;
+ }
+ }
+
+
+ $Vend::WriteDatabase{$table} =3D 1;
+
+ my $base_db =3D database_exists_ref($table)
+ or die "Not a defined database '$table': $!\n";
+ $base_db =3D $base_db->ref();
+
+ my @fields =3D grep $_ && $_ ne $prikey,
+ split /[\s\0,]+/, $CGI::values{mv_data_fields};
+ unshift(@fields, $prikey);
+
+ my @file_fields =3D split /[\s\0,]+/, $CGI::values{mv_data_file_field};
+ my @file_paths =3D split /[\s\0,]+/, $CGI::values{mv_data_file_path};
+ my @file_oldfiles =3D split /[\s\0,]+/, $CGI::values{mv_data_file_oldf=
ile};
+
+ if($en_col) {
+ $en_col =3D~ s/^\s+//;
+ $en_col =3D~ s/\s+$//;
+ my %col_present;
+ @col_present{ grep /\S/, split /[\s\0,]+/, $en_col } =3D ();
+ $col_present{$prikey} =3D 1;
+ for(@fields, $CGI::values{mv_blob_field}, $CGI::values{mv_blob_pointer})=
{
+ next unless $_;
+ next if exists $col_present{$_};
+ next if /:/ and $::Scratch->{mv_data_enable} =3D~ / $_ /;
+ logError("Attempted database operation without permission:\n" .
+ "Permission: '%s'\n" .
+ "Table: '%s'\n" .
+ "Fields:'%s'\n" .
+ "Key: '%s'\n",
+ $::Scratch->{mv_data_enable},
+ $CGI::values{mv_data_table},
+ $CGI::values{mv_data_fields},
+ $CGI::values{$CGI::values{mv_data_key}},
+ );
+ return undef;
+ }
+ }
+ $function =3D 'update' unless $function;
+
+ my (%data);
+ for(@fields) {
+ $data{$_} =3D [];
+ }
+
+ my $count;
+ my $multi =3D $CGI::values{$prikey} =3D~ tr/\0/\0/;
+ my $max =3D 0;
+ my $min =3D 9999;
+ my ($minname, $maxname);
+
+ while (($key, $value) =3D each %CGI::values) {
+ next unless defined $data{$key};
+ if($CGI::values{"mv_data_prep_$key"}) {
+ $value =3D Vend::Interpolate::filter_value(
+ $CGI::values{"mv_data_prep_$key"},
+ $value
+ );
+ }
+ $count =3D (@{$data{$key}} =3D split /\0/, $value, -1);
+ $max =3D $count, $maxname =3D $key if $count > $max;
+ $min =3D $count, $minname =3D $key if $count < $min;
+ }
+
+ if( $multi and ($max - $min) > 1 and ! $CGI::values{mv_data_force}) {
+ logError("probable bad form -- number of values min=3D%s (%s) max=3D%s (=
%s)", $min, $minname, $max, $maxname);
+ return;
+ }
+
+ my $autonumber;
+ if ($CGI::values{mv_data_auto_number}) {
+ $autonumber =3D 1;
+ my $ref =3D $data{$prikey};
+ while (scalar @$ref < $max) {
+ push @$ref, '';
+ }
+ $base_db->config('AUTO_NUMBER', '000001')
+ if ! $base_db->config('_Auto_number');
+ $CGI::values{mv_data_return_key} =3D $prikey
+ unless $CGI::values{mv_data_return_key};
+ }
+ elsif($function eq 'insert' and $base_db->config('_Auto_number') ) {
+ $autonumber =3D 1;
+ }
+=20
+
+ if(@file_fields) {
+ my $Tag =3D new Vend::Tags;
+ my $acl_func;
+ my $outfile;
+ if($Vend::Session->{logged_in} and $Vend::admin) {
+ $acl_func =3D sub {
+ return $Tag->if_mm('files', shift);
+ };
+ }
+ elsif($Vend::Session->{logged_in} and ! $Vend::admin) {
+ $acl_func =3D sub {
+ my $file =3D shift;
+ return 1 if $::Scratch->{$file} =3D=3D 1;
+ return $Tag->userdb(
+ function =3D> 'check_file_acl',
+ location =3D> $file,
+ mode =3D> 'w'
+ );
+ };
+ }
+ else {
+ $acl_func =3D sub { return $::Scratch->{shift(@_)} =3D=3D 1 }
+ }
+
+ for (my $i =3D 0; $i < @file_fields; $i++) {
+ unless (length($data{$file_fields[$i]}->[0])) {
+ # no need for a file update
+ $data{$file_fields[$i]}->[0] =3D $file_oldfiles[$i];
+ next;
+ }
+
+ # remove path components
+ $data{$file_fields[$i]}->[0] =3D~ s:.*/::;=20
+ $data{$file_fields[$i]}->[0] =3D~ s:.*\\::;=20
+
+ if (length ($file_paths[$i])) {
+ # real file upload
+ $outfile =3D join('/', $file_paths[$i], $data{$file_fields[$i]}->[0]);
+#::logDebug("file upload: field=3D$file_fields[$i] path=3D$file_paths[$i] =
outfile=3D$outfile");
+ my $ok;
+ if (-f $outfile) {
+ eval {
+ $ok =3D $acl_func->($outfile);
+ };
+ } else {
+ eval {
+ $ok =3D $acl_func->($file_paths[$i]);
+ };
+ }
+ if (! $ok) {
+ if($@) {
+ logError ("ACL function failed on '%s': %s", $outfile, $@);
+ }
+ else {
+ logError ("Not allowed to upload \"%s\"", $outfile);
+ }
+ next;
+ }=20
+ my $err;
+ Vend::Interpolate::tag_value_extended(
+ $file_fields[$i],
+ {
+ test =3D> 'isfile'
+ }
+ )
+ or do {
+ logError("%s is not a file.", $data{$file_fields[$i]}->[0]);
+ next;
+ };
+ Vend::Interpolate::tag_value_extended(
+ $file_fields[$i],
+ {
+ outfile =3D> $outfile,
+ umask =3D> '022',
+ yes =3D> '1',
+ }
+ )
+ or do {
+ logError("failed to write %s: %s", $outfile, $!);
+ next;
+ };
+ }
+ else {
+ # preparing to dump file contents into database column
+ $data{$file_fields[$i]}->[0]
+ =3D Vend::Interpolate::tag_value_extended ($file_fields[$i],
+ {file_contents =3D> 1});
+ }
+ }
+ }
+
+ if (not defined $data{$prikey}) {
+ logError("No key '%s' in field specifier %s", $prikey, 'mv_data_fields');
+ return undef;
+ }
+ elsif ( ! @{$data{$prikey}}) {
+ if($autonumber) {
+ @{$data{$prikey}} =3D map { '' } @{ $data{$fields[1]} };
+ }
+ else {
+ logError("No key '%s' found for function=3D'%s' table=3D'%s'",
+ $prikey, $function, $CGI::values{mv_data_table},
+ );
+ return undef;
+ }
+ }
+
+ my ($query,$i);
+ my (@k);
+ my (@v);
+ my (@c);
+ my (@rows_set);
+ my (@email_rows);
+
+ my $safe;
+ my $blob_field;
+ my $blob_nick;
+ my $blob_ptr;
+
+ # Fields to set in database despite mv_blob_only
+ my %blob_exception;
+
+ if($CGI::values{mv_blob_field} and $CGI::values{mv_blob_nick}) {
+#::logDebug("update_data: blob processing enabled");
+ $blob_field =3D $CGI::values{mv_blob_field};
+ $blob_nick =3D $CGI::values{mv_blob_nick};
+ $blob_ptr =3D $CGI::values{mv_blob_pointer};
+
+ %blob_exception =3D
+ map { ($_, 1) } split /[\s,\0]+/, $CGI::values{mv_blob_exception};
+
+ if( ! $base_db->column_exists($blob_field) ) {
+ undef $blob_field;
+ undef $blob_nick;
+ logError("No blob field '%s' found for table=3D'%s', skipping blob save=
",
+ $CGI::values{mv_blob_field}, $CGI::values{mv_data_table},
+ );
+ }
+ elsif ($MVSAFE::Safe) {
+ $safe =3D $Vend::Interpolate::ready_safe;
+ }
+ else {
+ $safe =3D new Safe;
+ }
+ $base_db->column_exists($blob_ptr)
+ or undef $blob_ptr;
+#::logDebug("update_data: blob safe object=3D$safe");
+ }
+
+ my @multis;
+ if($CGI::values{mv_data_multiple}) {
+ my $re =3D qr/^\d+_$prikey$/;
+ @multis =3D grep $_ =3D~ $re, @cgi_keys;
+ for(@multis) {
+ s/_.*//;
+ }
+ @multis =3D sort { $a <=3D> $b } @multis;
+ }
+
+#::logDebug("update_data:db=3D$db key=3D$prikey VALUES=3D" . ::uneval(\%CG=
I::values));
+#::logDebug("update_data:db=3D$db key=3D$prikey data=3D" . ::uneval(\%data=
));
+ my $select_key;
+ SETDATA: {
+ for($i =3D 0; $i < @{$data{$prikey}}; $i++) {
+#::logDebug("iteration of update_data:db=3D$db key=3D$prikey data=3D" . ::=
uneval(\%data));
+ @k =3D (); @v =3D ();
+ for(keys %data) {
+#::logDebug("iteration of field $_");
+
+ next unless (length($value =3D $data{$_}->[$i]) || $CGI::values{mv_upda=
te_empty} );
+ push(@k, $_);
+# LEGACY
+ HTML::Entities::decode($value) if $decode;
+# END LEGACY
+ if($CGI::values{"mv_data_filter_$_"}) {
+ $value =3D Vend::Interpolate::filter_value(
+ $CGI::values{"mv_data_filter_$_"},
+ $value,
+ $i,
+ );
+ }
+ $select_key =3D $value if $_ eq $prikey;
+ push(@v, $value);
+ }
+
+ if(! length($select_key) ) {
+ next if defined $CGI::values{mv_update_empty_key}
+ and ! $CGI::values{mv_update_empty_key};
+ }
+
+ if($function eq 'delete') {
+ $base_db->delete_record($select_key);
+ }
+ else {
+ my $field;
+ $key =3D $data{$prikey}->[$i];
+ if(! length($key) and $autonumber) {
+ ## KEY IS possibly SET HERE=20
+ $key =3D $base_db->set_row($key);
+ }
+ push(@rows_set, $key);
+
+ # allow form submissions to go to database and to mail
+ if ($CGI::values{mv_data_email}) {
+ push( @email_rows,
+ [ errmsg("### Form Submission from %s", $key), $blob_nick, ],
+ [ $prikey, $key, ],
+ );
+ }
+
+ my $qd =3D {};
+ my $qf =3D {};
+ my $qv =3D {};
+ my $qret;
+
+ my $blob;
+ my $brec;
+ if($blob_field) {
+ my $string =3D $base_db->field($key, $blob_field);
+#::logDebug("update_data: blob string=3D$string");
+ $blob =3D $safe->reval($string);
+#::logDebug("update_data: blob object=3D$blob");
+ $blob =3D {} unless ref($blob) eq 'HASH';
+ $brec =3D $blob;
+ my @keys =3D split /::/, $blob_nick;
+ for(@keys) {
+ unless ( ref($brec->{$_}) eq 'HASH') {
+ $brec->{$_} =3D {};
+ }
+ $brec =3D $brec->{$_};
+ }
+ }
+ while($field =3D shift @k) {
+ $value =3D shift @v;
+ next if $field eq $prikey;
+=09=09=09=09
+ ## DATA IS SET HERE
+ # We are going to set the field unless it is only for
+ # storing in a blob (and possibly emailing)
+ my ($d, $f);
+ if ($CGI::values{mv_blob_only} and ! $blob_exception{$field}) {
+#::logDebug("$field not storing, only blob");
+ $f =3D $field;
+ }
+ else {
+#::logDebug("storing d=3D$d $field blob_only=3D$CGI::values{mv_blob_only}"=
);
+ ($d, $f) =3D set_db($base_db, $field);
+#::logDebug("storing table=3D$table d=3D$d f=3D$f key=3D$key");
+ if(! defined $qd->{$d}) {
+ $qd->{$d} =3D $d;
+ $qf->{$d} =3D [$f];
+ $qv->{$d} =3D [$value];
+ }
+ else {
+ push @{$qf->{$d}}, $f;
+ push @{$qv->{$d}}, $value;
+ }
+ #$d->set_field($key, $f, $value);
+ }
+
+ push(@email_rows, [$f, $value])
+ if $CGI::values{mv_data_email};
+#::logDebug("update_data:db=3D$d key=3D$key field=3D$f value=3D$value");
+ $brec->{$f} =3D $value if $brec;
+ }
+
+ for(keys %$qd) {
+ $qret =3D $qd->{$_}->set_slice($key, $qf->{$_}, $qv->{$_});
+ $rows_set[$i] =3D $qret unless $rows_set[$i];
+ }
+ if($blob) {
+ $brec->{mv_data_fields} =3D join " ", @fields;
+ my $string =3D uneval_it($blob);
+#::logDebug("update_data: blob saving string=3D$string");
+ $base_db->set_field($key, $blob_field, $string);
+ if($blob_ptr) {
+ $base_db->set_field($key, $blob_ptr, $blob_nick);
+ }
+ }
+ push(
+ @email_rows,
+ [ errmsg("### END FORM SUBMISSION %s", $key), $blob_nick, ]
+ )
+ if $CGI::values{mv_data_email};
+ }
+ }
+ if(my $new =3D shift(@multis)) {
+#::logDebug("Doing multi for $new");
+ last SETDATA unless length $CGI::values{"${new}_$prikey"};
+ for(@fields) {
+ my $value =3D $CGI::values{$_} =3D $CGI::values{"${new}_$_"};
+ $data{$_} =3D [ $value ];
+ }
+ redo SETDATA;
+ }
+ } # end SETDATA
+
+ if($CGI::values{mv_data_return_key}) {
+ my @keys =3D split /\0/, $CGI::values{mv_data_return_key};
+ for(@keys) {
+#::logDebug("return_key, setting $_");
+ $CGI::values{$_} =3D join("\0", @rows_set);
+ }
+ }
+
+ if($CGI::values{mv_auto_export}) {
+ Vend::Data::export_database($table);
+ }
+
+ if($CGI::values{mv_data_email}) {
+ push @email_rows, [ 'mv_data_fields', \@fields ];
+ Vend::Interpolate::tag_mail('', { log_error =3D> 1 }, \@email_rows);
+ }
+
+ # Allow setting in one then returning to another
+ if($CGI::values{mv_return_table}) {
+ $CGI::values{mv_data_table} =3D $CGI::values{mv_return_table};
+ }
+
+ my @reloads =3D grep /^mv_data_table__\d+$/, keys %CGI::values;
+ if(@reloads) {
+ @reloads =3D map { m/.*__(\d+)$/; $1 } @reloads;
+ @reloads =3D sort { $a <=3D> $b } @reloads;
+ my $new =3D shift @reloads;
+ my $this =3D qr{__$new$};
+ my $some =3D qr{__\d+$};
+#::logDebug("Reloading, new=3D$new this=3D$this some=3D$some");
+ my %cgiset;
+ my @death_row;
+ for(@cgi_keys) {
+ push(@death_row, $_), next unless $_ =3D~ $some;
+ if($_ =3D~ $this) {
+ my $k =3D $_;
+ $k =3D~ s/$this//;
+ $cgiset{$k} =3D delete $CGI::values{$_};
+ }
+ }
+
+ $::Scratch->{mv_data_enable} =3D delete $::Scratch->{"mv_data_enable__$n=
ew"};
+ delete $::Scratch->{mv_data_enable_key};
+
+ for(@death_row) {
+ next unless /^mv_(data|blob|update)_/ or $data{$_}; # Reprieve!
+ delete $CGI::values{$_};
+ }
+
+ @CGI::values{keys %cgiset} =3D values %cgiset;
+ update_data();
+ }
+
+ return;
+}
+
+*dbref =3D \&database_exists_ref;
=20
1;
=20
2.5 +7 -7 interchange/lib/Vend/Error.pm
rev 2.5, prev_rev 2.4
Index: Error.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Error.pm,v
retrieving revision 2.4
retrieving revision 2.5
diff -u -r2.4 -r2.5
--- Error.pm 21 Jul 2002 01:15:02 -0000 2.4
+++ Error.pm 16 Sep 2002 23:06:31 -0000 2.5
@@ -1,6 +1,6 @@
# Vend::Error - Handle Interchange error pages and messages
#=20
-# $Id: Error.pm,v 2.4 2002/07/21 01:15:02 mheins Exp $
+# $Id: Error.pm,v 2.5 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -37,7 +37,7 @@
=20
use vars qw/$VERSION/;
=20
-$VERSION =3D substr(q$Revision: 2.4 $, 10);
+$VERSION =3D substr(q$Revision: 2.5 $, 10);
=20
sub get_locale_message {
my ($code, $message, @arg) =3D @_;
@@ -112,7 +112,7 @@
my $out =3D '';
if($portion) {
$out .=3D "###### SESSION ($portion) #####\n";
- $out .=3D ::uneval($Vend::Session->{$portion});
+ $out .=3D uneval($Vend::Session->{$portion});
$out .=3D "\n###### END SESSION #####\n";
$out =3D~ s/\0/\\0/g;
return $out;
@@ -122,17 +122,17 @@
local($Data::Dumper::Indent) =3D 2;
$out .=3D "###### ENVIRONMENT #####\n";
if(my $h =3D ::http()) {
- $out .=3D ::uneval($h->{env});
+ $out .=3D uneval($h->{env});
}
else {
- $out .=3D ::uneval(\%ENV);
+ $out .=3D uneval(\%ENV);
}
$out .=3D "\n###### END ENVIRONMENT #####\n";
$out .=3D "###### CGI VALUES #####\n";
- $out .=3D ::uneval(\%CGI::values);
+ $out .=3D uneval(\%CGI::values);
$out .=3D "\n###### END CGI VALUES #####\n";
$out .=3D "###### SESSION #####\n";
- $out .=3D ::uneval($Vend::Session);
+ $out .=3D uneval($Vend::Session);
$out .=3D "\n###### END SESSION #####\n";
$out =3D~ s/\0/\\0/g;
return $out;
2.110 +107 -107 interchange/lib/Vend/Interpolate.pm
rev 2.110, prev_rev 2.109
Index: Interpolate.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Interpolate.pm,v
retrieving revision 2.109
retrieving revision 2.110
diff -u -r2.109 -r2.110
--- Interpolate.pm 7 Sep 2002 18:45:41 -0000 2.109
+++ Interpolate.pm 16 Sep 2002 23:06:31 -0000 2.110
@@ -1,6 +1,6 @@
# Vend::Interpolate - Interpret Interchange tags
#=20
-# $Id: Interpolate.pm,v 2.109 2002/09/07 18:45:41 mheins Exp $
+# $Id: Interpolate.pm,v 2.110 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -27,7 +27,7 @@
require Exporter;
@ISA =3D qw(Exporter);
=20
-$VERSION =3D substr(q$Revision: 2.109 $, 10);
+$VERSION =3D substr(q$Revision: 2.110 $, 10);
=20
@EXPORT =3D qw (
=20
@@ -455,7 +455,7 @@
## If post_page routine processor returns true, return. Otherwise,
## continue image rewrite
if($::Pragma->{post_page}) {
- ::run_macro($::Pragma->{post_page}, $text)
+ Vend::Dispatch::run_macro($::Pragma->{post_page}, $text)
and return;
}
=20
@@ -524,7 +524,7 @@
$parse->parse($html);
while($parse->{_buf}) {
substitute_image(\$parse->{OUT});
- ::response( \$parse->{OUT});
+ Vend::Dispatch::response( \$parse->{OUT});
$full .=3D $parse->{OUT};
$parse->{OUT} =3D '';
$parse->parse('');
@@ -586,7 +586,7 @@
undef $Vend::PageInit unless $::Pragma->{init_page};
=20
if(defined $Vend::PageInit and ! $Vend::PageInit++) {
- ::run_macro($::Pragma->{init_page}, $html);
+ Vend::Dispatch::run_macro($::Pragma->{init_page}, $html);
}
=20
# Substitute in Variable values
@@ -605,7 +605,7 @@
}
=20
if($::Pragma->{pre_page}) {
- ::run_macro($::Pragma->{pre_page}, $html);
+ Vend::Dispatch::run_macro($::Pragma->{pre_page}, $html);
}
=20
# Strip out [comment] [/comment] blocks
@@ -629,7 +629,7 @@
defined $::Variable->{MV_AUTOLOAD}
and $html =3D~ s/^/$::Variable->{MV_AUTOLOAD}/;
=20
-#::logDebug("opt=3D" . ::uneval($opt));
+#::logDebug("opt=3D" . uneval($opt));
vars_and_comments(\$html)
unless $opt and $opt->{onfly};
=20
@@ -679,7 +679,7 @@
next;
}
unless (defined $Filter{$_}) {
- ::logError ("Unknown filter '%s'", $_);
+ logError ("Unknown filter '%s'", $_);
next;
}
unshift @args, $value, $tag;
@@ -784,7 +784,7 @@
return $db->delete_column($field, $opt->{value});
}
else {
- ::logError("alter function '%s' not found", $opt->{alter});
+ logError("alter function '%s' not found", $opt->{alter});
return undef;
}
}
@@ -999,7 +999,7 @@
},
'crypt' =3D> sub {
my $val =3D shift;
- return crypt($val, ::random_string(2));
+ return crypt($val, random_string(2));
},
'html2text' =3D> sub {
my $val =3D shift;
@@ -1125,7 +1125,7 @@
=20
loc =3D> sub {
my $val =3D shift;
- return ::errmsg($val);
+ return errmsg($val);
},
=20
restrict_html =3D> sub {
@@ -1147,7 +1147,7 @@
=20
sub input_filter_do {
my($varname, $opt, $routine) =3D @_;
-#::logDebug("filter var=3D$varname opt=3D" . ::uneval_it($opt));
+#::logDebug("filter var=3D$varname opt=3D" . uneval_it($opt));
return undef unless defined $CGI::values{$varname};
#::logDebug("before filter=3D$CGI::values{$varname}");
$routine =3D $opt->{routine} || ''
@@ -1345,7 +1345,7 @@
elsif($base eq 'validcc') {
$CacheInvalid =3D 1;
no strict 'refs';
- $status =3D ::validate_whole_cc($term, $operator, $comp);
+ $status =3D Vend::Order::validate_whole_cc($term, $operator, $comp);
}
elsif($base eq 'config') {
$op =3D qq%$Vend::Cfg->{$term}%;
@@ -1515,7 +1515,7 @@
=20
sub tag_profile {
my($profile, $opt) =3D @_;
-#::logDebug("in tag_profile=3D$profile opt=3D" . ::uneval_it($opt));
+#::logDebug("in tag_profile=3D$profile opt=3D" . uneval_it($opt));
=20
$opt =3D {} if ! $opt;
my $tag =3D $opt->{tag} || 'default';
@@ -1543,7 +1543,7 @@
}
=20
if( "$profile$tag" =3D~ /\W/ ) {
- ::logError(
+ logError(
"profile: invalid characters (tag=3D%s profile=3D%s), must be [A-Za-z_]=
+",
$tag,
$profile,
@@ -1555,7 +1555,7 @@
#::logDebug("running profile=3D$profile tag=3D$tag");
my $prof =3D $Vend::Cfg->{Profile_repository}{$profile};
if (not $prof) {
- ::logError( "profile %s (%s) non-existant.", $profile, $tag );
+ logError( "profile %s (%s) non-existant.", $profile, $tag );
return $opt->{failure};
}=20
#::logDebug("found profile=3D$profile");
@@ -1586,10 +1586,10 @@
}
}
else {
- ::logError( "profile: cannot handle object of type %s.",
+ logError( "profile: cannot handle object of type %s.",
$Vend::Cfg->{$one},
);
- ::logError("profile: profile for $one not changed.");
+ logError("profile: profile for $one not changed.");
next;
}
=20
@@ -1597,7 +1597,7 @@
$val =3D $ready_safe->reval($string) if $string;
=20
if($@) {
- ::logError( "profile: bad object %s: %s", $one, $string );
+ logError( "profile: bad object %s: %s", $one, $string );
next;
}
$Vend::Session->{Profile_save}{$one} =3D $Vend::Cfg->{$one}
@@ -1627,7 +1627,7 @@
}
$al =3D [] if ! $al;
push @$al, "$tag-$profile";
-#::logDebug("profile=3D$profile Autoload=3D" . ::uneval_it($al));
+#::logDebug("profile=3D$profile Autoload=3D" . uneval_it($al));
$Vend::Session->{Autoload} =3D $al;
=20
return $opt->{success};
@@ -1931,7 +1931,7 @@
or next;
my @new =3D $1 .. $2;
if(@new > $max) {
- ::logError(
+ logError(
"Refuse to add %d options to option list via range, max %d.",
scalar(@new),
$max,
@@ -1959,7 +1959,7 @@
}
=20
# Had extra if got here
-#::logDebug("tag_accessories: code=3D$code opt=3D" . ::uneval_it($opt) . "=
item=3D" . ::uneval_it($item) . " extra=3D$extra");
+#::logDebug("tag_accessories: code=3D$code opt=3D" . uneval_it($opt) . " i=
tem=3D" . uneval_it($item) . " extra=3D$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt =3D {} if ! $opt;
if($extra) {
@@ -2034,22 +2034,22 @@
sub tag_perl {
my ($tables, $opt,$body) =3D @_;
my ($result,@share);
-#::logDebug("tag_perl MVSAFE=3D$MVSAFE::Safe opts=3D" . ::uneval($opt));
+#::logDebug("tag_perl MVSAFE=3D$MVSAFE::Safe opts=3D" . uneval($opt));
=20
if($Vend::NoInterpolate) {
- ::logGlobal({ level =3D> 'alert' },
+ logGlobal({ level =3D> 'alert' },
"Attempt to interpolate perl/ITL from RPC, no permissions."
);
return undef;
}
=20
if ($MVSAFE::Safe) {
- ::logGlobal({ level =3D> 'alert' }, "Attempt to call perl from within Sa=
fe.");
+ logGlobal({ level =3D> 'alert' }, "Attempt to call perl from within Safe=
");
return undef;
}
=20
-#::logDebug("tag_perl: tables=3D$tables opt=3D" . ::uneval($opt) . " body=
=3D$body");
-#::logDebug("tag_perl initialized=3D$Vend::Calc_initialized: carts=3D" . :=
:uneval($::Carts));
+#::logDebug("tag_perl: tables=3D$tables opt=3D" . uneval($opt) . " body=3D=
$body");
+#::logDebug("tag_perl initialized=3D$Vend::Calc_initialized: carts=3D" . u=
neval($::Carts));
if($opt->{subs} || (defined $opt->{arg} and $opt->{arg} =3D~ /\bsub\b/)) {
no strict 'refs';
for(keys %{$Global::GlobalSub}) {
@@ -2097,7 +2097,7 @@
if($Vend::Cfg->{Tie_Watch}) {
eval {
for(@{$Vend::Cfg->{Tie_Watch}}) {
- ::logGlobal("touching $_");
+ logGlobal("touching $_");
my $junk =3D $Config->{$_};
}
};
@@ -2167,7 +2167,7 @@
}
return $opt->{failure};
}
-#::logDebug("tag_perl initialized=3D$Vend::Calc_initialized: carts=3D" . :=
:uneval($::Carts));
+#::logDebug("tag_perl initialized=3D$Vend::Calc_initialized: carts=3D" . u=
neval($::Carts));
=20
if ($opt->{no_return}) {
$Vend::Session->{mv_perl_result} =3D $result;
@@ -2223,7 +2223,7 @@
my $fmt =3D $opt->{status} || '';
my @status;
=20
-#::logDebug("tag flag=3D$flag text=3D$text value=3D$value opt=3D". ::uneva=
l_it($opt));
+#::logDebug("tag flag=3D$flag text=3D$text value=3D$value opt=3D". uneval_=
it($opt));
if($flag eq 'write' || $flag eq 'read') {
my $arg =3D $opt->{table} || $text;
$value =3D 0 if $flag eq 'read';
@@ -2279,11 +2279,11 @@
next unless $db->isopen();
next unless $db->config('Transactions');
if( ! $db ) {
- ::logError("attempt to $method on unknown database: %s", $dbname);
+ logError("attempt to $method on unknown database: %s", $dbname);
return undef;
}
if( ! $db->$method() ) {
- ::logError("problem doing $method for table: %s", $dbname);
+ logError("problem doing $method for table: %s", $dbname);
return undef;
}
}
@@ -2347,7 +2347,7 @@
=20
my $out;
=20
-#::logDebug("mime call, opt=3D" . ::uneval($opt));
+#::logDebug("mime call, opt=3D" . uneval($opt));
$Vend::TIMESTAMP =3D POSIX::strftime("%y%m%d%H%M%S", localtime())
unless defined $Vend::TIMESTAMP;
=20
@@ -2551,7 +2551,7 @@
my $table =3D shift;
my $opt =3D shift;
$opt->{search} =3D "ra=3Dyes\nst=3Ddb\nml=3D100000\nfi=3D$table";
-#::logDebug("tag each: table=3D$table opt=3D" . ::uneval($opt));
+#::logDebug("tag each: table=3D$table opt=3D" . uneval($opt));
return tag_loop_list('', $opt, shift);
},
MIME =3D> \&mime,
@@ -2560,10 +2560,10 @@
=20
sub do_tag {
my $op =3D uc $_[0];
-#::logDebug("tag op: op=3D$op opt=3D" . ::uneval(\@_));
+#::logDebug("tag op: op=3D$op opt=3D" . uneval(\@_));
return $_[3] if ! defined $Tag_op_map{$op};
shift;
-#::logDebug("tag args now: op=3D$op opt=3D" . ::uneval(\@_));
+#::logDebug("tag args now: op=3D$op opt=3D" . uneval(\@_));
return &{$Tag_op_map{$op}}(@_);
}
=20
@@ -2704,14 +2704,14 @@
}
}
if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) {
- ::logError(
+ logError(
"Uploaded file write of %s bytes greater than maxsize %s. Aborted.",
length($CGI::file{$var}),
$opt->{maxsize},
);
return $opt->{no} || '';
}
-#::logDebug(">$file \$CGI::file{$var}" . ::uneval($opt));=20
+#::logDebug(">$file \$CGI::file{$var}" . uneval($opt));=20
Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt)
and return $opt->{yes} || '';
return $opt->{'no'} || '';
@@ -2743,7 +2743,7 @@
@ary =3D @$val;
}
else {
- ::logError( "value-extended %s: passed non-scalar, non-array object", $v=
ar);
+ logError( "value-extended %s: passed non-scalar, non-array object", $var=
);
}
=20
return join " ", 0 .. $#ary if $opt->{elements};
@@ -2751,7 +2751,7 @@
eval {
@ary =3D @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index =
)];
};
- ::logError("value-extended $var: bad index") if $@;
+ logError("value-extended $var: bad index") if $@;
=20
if($opt->{filter}) {
for(@ary) {
@@ -2764,7 +2764,7 @@
sub format_auto_transmission {
my $ref =3D shift;
=20
- ## Auto-transmission from ::update_data
+ ## Auto-transmission from Vend::Data::update_data
## Looking for structure like:
##
## [ '### BEGIN submission from', 'ckirk' ],
@@ -2842,13 +2842,13 @@
=20
unless($opt->{raw}) {
for my $header (@todo) {
- ::logError("invalid email header: %s", $header)
+ logError("invalid email header: %s", $header)
if $header =3D~ /[^-\w]/;
my $key =3D lc $header;
$key =3D~ tr/-/_/;
my $val =3D $opt->{$key} || $setsub->($key);=20
if($key eq 'subject' and ! length($val) ) {
- $val =3D ::errmsg('<no subject>');
+ $val =3D errmsg('<no subject>');
}
next unless length $val;
$found{$key} =3D $val;
@@ -2915,7 +2915,7 @@
# Returns the text of a user entered field named VAR.
sub tag_value {
my($var,$opt) =3D @_;
-#::logDebug("called value args=3D" . ::uneval(\@_));
+#::logDebug("called value args=3D" . uneval(\@_));
my($value);
=20
local($^W) =3D 0;
@@ -2972,8 +2972,8 @@
$scan =3D Vend::Scan::sql_statement($scan, $ref || \%CGI::values)
};
if($@) {
- my $msg =3D ::errmsg("SQL query failed: %s\nquery was: %s", $@, $scan);
- ::logError($msg);
+ my $msg =3D errmsg("SQL query failed: %s\nquery was: %s", $@, $scan);
+ logError($msg);
$scan =3D 'se=3DBAD_SQL';
}
}
@@ -3192,7 +3192,7 @@
my($body) =3D @_;
my $result;
if($Vend::NoInterpolate) {
- ::logGlobal({ level =3D> 'alert' },
+ logGlobal({ level =3D> 'alert' },
"Attempt to interpolate perl/ITL from RPC, no permissions."
);
}
@@ -3287,7 +3287,7 @@
$_[1] =3D~ s:^/(.*)/$:$1:;
eval { $re =3D qr/$_[1]/ };
if($@) {
- ::logError("bad regex %s in if-PREFIX-data", $_[1]);
+ logError("bad regex %s in if-PREFIX-data", $_[1]);
return undef;
}
return $_[0] =3D~ $re;
@@ -3297,7 +3297,7 @@
$_[1] =3D~ s:^/(.*)/$:$1:;
eval { $re =3D qr/$_[1]/ };
if($@) {
- ::logError("bad regex %s in if-PREFIX-data", $_[1]);
+ logError("bad regex %s in if-PREFIX-data", $_[1]);
return undef;
}
return $_[0] !~ $re;
@@ -3310,7 +3310,7 @@
my ($op, $rhs) =3D split /\s+/, $cond;
$rhs =3D~ s/^(["'])(.*)\1$/$2/;
if(! defined $cond_op{$op} ) {
- ::logError("bad conditional operator %s in if-PREFIX-data", $op);
+ logError("bad conditional operator %s in if-PREFIX-data", $op);
return pull_else($string, $reverse);
}
return $cond_op{$op}->($lhs, $rhs)
@@ -3368,7 +3368,7 @@
my($opts, $list) =3D (@_);=20
$opts =3D~ s/^\s+//;=20
$opts =3D~ s/\s+$//;=20
-#::logDebug("tag_sort_ary: opts=3D$opts list=3D" . ::uneval($list));
+#::logDebug("tag_sort_ary: opts=3D$opts list=3D" . uneval($list));
my @codes;
my $key =3D 0;
=20
@@ -3441,7 +3441,7 @@
if(defined $num) {
splice(@codes, $num);
}
-#::logDebug("tag_sort_ary routine returns: " . ::uneval(\@codes));
+#::logDebug("tag_sort_ary routine returns: " . uneval(\@codes));
return \@codes;
}
=20
@@ -3449,7 +3449,7 @@
my($opts, $list) =3D (@_);=20
$opts =3D~ s/^\s+//;=20
$opts =3D~ s/\s+$//;=20
-#::logDebug("tag_sort_hash: opts=3D$opts list=3D" . ::uneval($list));
+#::logDebug("tag_sort_hash: opts=3D$opts list=3D" . uneval($list));
my @codes;
my $key =3D 'code';
=20
@@ -3489,7 +3489,7 @@
}
=20
if (! defined $list->[0]->{$key}) {
- ::logError("sort key '$key' not defined in list. Skipping sort.");
+ logError("sort key '$key' not defined in list. Skipping sort.");
return $list;
}
=20
@@ -3527,7 +3527,7 @@
if(defined $num) {
splice(@codes, $num);
}
-#::logDebug("tag_sort_hash routine returns: " . ::uneval(\@codes));
+#::logDebug("tag_sort_hash routine returns: " . uneval(\@codes));
return \@codes;
}
=20
@@ -3723,7 +3723,7 @@
$first_anchor =3D $1;
}
else {
- $first_anchor =3D ::errmsg('First');
+ $first_anchor =3D errmsg('First');
}
unless ($first_anchor eq 'none') {
$arg =3D $session;
@@ -3738,7 +3738,7 @@
$prev_anchor =3D $1;
}
else {
- $prev_anchor =3D ::errmsg('Previous');
+ $prev_anchor =3D errmsg('Previous');
}
}
elsif ($prev_anchor ne 'none') {
@@ -3766,7 +3766,7 @@
$next_anchor =3D $1;
}
else {
- $next_anchor =3D ::errmsg('Next');
+ $next_anchor =3D errmsg('Next');
}
}
else {
@@ -3782,7 +3782,7 @@
$last_anchor =3D $1;
}
else {
- $last_anchor =3D ::errmsg('Last');
+ $last_anchor =3D errmsg('Last');
}
unless ($last_anchor eq 'none') {
$last =3D $total - 1;
@@ -3809,7 +3809,7 @@
=20
$page_anchor =3D~ s/\$(MIN|MAX)?PAGE\$/__${1}PAGE__/g;
=20
- my $more_string =3D ::errmsg('more');
+ my $more_string =3D errmsg('more');
my ($decade_next, $decade_prev, $decade_div);
if( $q->{mv_more_decade} or $r =3D~ m:\[decade[-_]next\]:) {
$r =3D~ s:\[decade[-_]next\]($All)\[/decade[-_]next\]::i
@@ -4005,7 +4005,7 @@
$Safe_data =3D 1 if $opt->{safe_data};
=20
# if($opt->{prefix} eq 'item') {
-#::logDebug("labeled list: opt:\n" . ::uneval($opt) . "\nobj:" . ::uneval(=
$obj) . "text:" . substr($text,0,100));
+#::logDebug("labeled list: opt:\n" . uneval($opt) . "\nobj:" . uneval($obj=
) . "text:" . substr($text,0,100));
# }
$Orig_prefix =3D $Prefix =3D $opt->{prefix} || 'item';
=20
@@ -4125,7 +4125,7 @@
if(! ref $hash) {
$hash =3D string_to_ref($hash);
if($@) {
- ::logDebug("eval error: $@");
+ logDebug("eval error: $@");
}
return undef if ! ref $hash;
}
@@ -4198,7 +4198,7 @@
%$addr =3D %{ $::Values };
}
=20
-#::logDebug("addr=3D" . ::uneval($addr));
+#::logDebug("addr=3D" . uneval($addr));
=20
$addr->{mv_an} =3D $nick;
my @nick =3D sort keys %$blob;
@@ -4358,7 +4358,7 @@
}
else {
$attrhash->{body} =3D $this_tag unless defined $attrhash->{body};
-#::logDebug("calling do_tag tag=3D$tag this_tag=3D$this_tag attrhash=3D" .=
::uneval($attrhash));
+#::logDebug("calling do_tag tag=3D$tag this_tag=3D$this_tag attrhash=3D" .=
uneval($attrhash));
$Tag ||=3D new Vend::Tags;
$out =3D $Tag->$tag($attrhash);
}
@@ -4461,7 +4461,7 @@
=20
my ($run, $row, $code, $return);
my $once =3D 0;
-#::logDebug("iterating array $i to $end. count=3D$count opt_select=3D$opt_=
select ary=3D" . ::uneval($ary));
+#::logDebug("iterating array $i to $end. count=3D$count opt_select=3D$opt_=
select ary=3D" . uneval($ary));
if($text =3D~ m/^$B$QR{_line}\s*$/is) {
my $i =3D $1 || 0;
my $count =3D scalar values %$fh;
@@ -4474,7 +4474,7 @@
my $name =3D $1;
my $routine =3D $2;
## Not necessary?
- ## $Vend::Cfg->{Sub}{''} =3D sub { ::errmsg('undefined sub') }
+ ## $Vend::Cfg->{Sub}{''} =3D sub { errmsg('undefined sub') }
## unless defined $Vend::Cfg->{Sub}{''};
$routine =3D 'sub { ' . $routine . ' }' unless $routine =3D~ /^\s*sub\s*=
{/;
my $sub;
@@ -4482,8 +4482,8 @@
$sub =3D $ready_safe->reval($routine);
};
if($@) {
- ::logError( ::errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
- $sub =3D sub { ::errmsg('ERROR') };
+ logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
+ $sub =3D sub { errmsg('ERROR') };
}
#::logDebug("sub $name: $sub --> $routine");
$Vend::Cfg->{Sub}{$name} =3D $sub;
@@ -4520,9 +4520,9 @@
$run =3D $text;
if(! $opt->{ignore_undefined}) {
$run =3D~ s#$B$QR{_param}# defined $fh->{$1} ||
- ::logOnce(@field_msg, $1, "$Orig_prefix-param") #ige;
+ logOnce(@field_msg, $1, "$Orig_prefix-param") #ige;
$run =3D~ s#$IB$QR{_param_if}# defined $fh->{$3} ||
- ::logOnce(@field_msg, $3, "if-$Orig_prefix-param") #ige;
+ logOnce(@field_msg, $3, "if-$Orig_prefix-param") #ige;
}
=20
for( ; $i <=3D $end ; $i++, $count++ ) {
@@ -4548,7 +4548,7 @@
? pull_if($5,$2,$4,$row->[$3])
: pull_else($5,$2,$4,$row->[$3])#ige;
$run =3D~ s#$B$QR{_pos}#ed($row->[$1])#ige;
-#::logDebug("fh: " . ::uneval($fh) . ::uneval($row)) unless $once++;
+#::logDebug("fh: " . uneval($fh) . uneval($row)) unless $once++;
1 while $run =3D~ s#$IB$QR{_field_if}$IE[-_]field\1\]#
my $tmp =3D product_field($3, $code);
$tmp ? pull_if($5,$2,$4,$tmp)
@@ -4626,12 +4626,12 @@
=20
$nc and local(@Hash_code{keys %$nc}) =3D values %$nc;
=20
-#::logDebug("iterating hash $i to $end. count=3D$count opt_select=3D$opt_s=
elect hash=3D" . ::uneval($hash));
+#::logDebug("iterating hash $i to $end. count=3D$count opt_select=3D$opt_s=
elect hash=3D" . uneval($hash));
while($text =3D~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) {
my $name =3D $1;
my $routine =3D $2;
## Not necessary?
- ## $Vend::Cfg->{Sub}{''} =3D sub { ::errmsg('undefined sub') }
+ ## $Vend::Cfg->{Sub}{''} =3D sub { errmsg('undefined sub') }
## unless defined $Vend::Cfg->{Sub}{''};
$routine =3D 'sub { ' . $routine . ' }' unless $routine =3D~ /^\s*sub\s*=
{/;
my $sub;
@@ -4639,8 +4639,8 @@
$sub =3D $ready_safe->reval($routine);
};
if($@) {
- ::logError( ::errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
- $sub =3D sub { ::errmsg('ERROR') };
+ logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
+ $sub =3D sub { errmsg('ERROR') };
}
$Vend::Cfg->{Sub}{$name} =3D $sub;
}
@@ -4814,7 +4814,7 @@
my $msg =3D errmsg(@args);
$msg =3D "$opt->{error_id}: $msg" if $opt->{error_id};
if($opt->{log_error}) {
- ::logError($msg);
+ logError($msg);
}
return $msg if $opt->{show_error};
return undef;
@@ -5005,7 +5005,7 @@
find_search_params();
delete $CGI::values{mv_more_matches};
=20
- #::logDebug("more object =3D " . ::uneval($c));
+#::logDebug("more object =3D " . uneval($c));
=20
}
elsif ($opt->{search}) {
@@ -5063,7 +5063,7 @@
$mprefix =3D "";
}
=20
-#::logDebug("region: opt:\n" . ::uneval($opt) . "\npage:" . substr($page,0=
,100));
+#::logDebug("region: opt:\n" . uneval($opt) . "\npage:" . substr($page,0,1=
00));
=20
if($opt->{ml} and ! defined $obj->{mv_matchlimit} ) {
$obj->{mv_matchlimit} =3D $opt->{ml};
@@ -5121,7 +5121,7 @@
$opt->{label} =3D "loop" . $List_it++ . $Global::Variable->{MV_PAGE}
unless defined $opt->{label};
=20
-#::logDebug("list is: " . ::uneval($list) );
+#::logDebug("list is: " . uneval($list) );
=20
## Thanks to Kaare Rasmussen for this suggestion
## about passing embedded Perl objects to a list
@@ -5135,9 +5135,9 @@
# [loop list=3D`$Scratch->{ary}`] [loop-code]
# [/loop]
if (ref $list) {
-#::logDebug("opt->list in: " . ::uneval($list) );
+#::logDebug("opt->list in: " . uneval($list) );
unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') {
- ::logError("loop was passed invalid list=3D`...` argument");
+ logError("loop was passed invalid list=3D`...` argument");
return;
}
my ($ary, $fh, $fa) =3D @$list;
@@ -5199,7 +5199,7 @@
push @rows, [ $o, $l ];
}
};
-#::logDebug("rows:" . ::uneval(\@rows));
+#::logDebug("rows:" . uneval(\@rows));
}
elsif($opt->{quoted}) {
#::logDebug("loop resolve quoted");
@@ -5220,7 +5220,7 @@
}
=20
if($@) {
- ::logError("bad split delimiter in loop list: $@");
+ logError("bad split delimiter in loop list: $@");
#::logDebug("loop resolve error $@");
}
=20
@@ -5239,7 +5239,7 @@
mv_field_names =3D> $fn,
};
=20=09
-#::logDebug("loop object: " . ::uneval($opt));
+#::logDebug("loop object: " . uneval($opt));
return region($opt, $text);
}
=20
@@ -5568,7 +5568,7 @@
$line[OPT]->{$k} =3D $v;
}
};
- ::logError(
+ logError(
"bad shipping index %s for mode %s in $file",
$k,
$line[0],
@@ -5580,7 +5580,7 @@
if @line;
=20
if($waiting) {
- ::logError(
+ logError(
"Failed to find end-of-line termination '%s' in shipping read",
$waiting,
);
@@ -5781,7 +5781,7 @@
if($saved_file) {
$file =3D $saved_file;
$file =3D~ s:^scan/::;
- $file =3D ::generate_key($file);
+ $file =3D generate_key($file);
$file =3D "scan/$file";
}
else {
@@ -5812,7 +5812,7 @@
$opt->{umask} =3D '22' unless defined $opt->{umask};
Vend::Util::writefile(">$file", $out, $opt );
# STATICPAGE
- if ($Vend::Cfg->{StaticDBM} and ::tie_static_dbm(1) ) {
+ if ($Vend::Cfg->{StaticDBM} and Vend::Session::tie_static_dbm(1) ) {
if ($opt->{scan}) {
$saved_file =3D~ s!=3D([^/]+)=3D!=3D$1%3d!g;
$saved_file =3D~ s!=3D([^/]+)-!=3D$1%2d!g;
@@ -5834,7 +5834,7 @@
sub update {
my ($func, $opt) =3D @_;
if($func eq 'quantity') {
- ::update_quantity();
+ Vend::Order::update_quantity();
}
elsif($func eq 'cart') {
my $cart;
@@ -5848,13 +5848,13 @@
Vend::Cart::toss_cart($cart, $opt->{name});
}
elsif ($func eq 'process') {
- ::do_process();
+ Vend::Dispatch::do_process();
}
elsif ($func eq 'values') {
- ::update_user();
+ Vend::Dispatch::update_user();
}
elsif ($func eq 'data') {
- ::update_data();
+ Vend::Data::update_data();
}
return;
}
@@ -5891,7 +5891,7 @@
else {
@bin =3D @$Vend::Items;
}
-#::logDebug("doing shipping, mode=3D$mode bin=3D" . ::uneval(\@bin));
+#::logDebug("doing shipping, mode=3D$mode bin=3D" . uneval(\@bin));
=20
$Vend::Session->{ship_message} =3D '' if $opt->{reset_message};
=20
@@ -5932,7 +5932,7 @@
my @lines;
@lines =3D grep $_->[0] =3D~ /^$mode/, @{$Vend::Cfg->{Shipping_line}};
goto SHIPFORMAT unless @lines;
-#::logDebug("shipping lines selected: " . ::uneval(\@lines));
+#::logDebug("shipping lines selected: " . uneval(\@lines));
my $q;
if($lines[0][QUERY]) {
my $q =3D interpolate_html($lines[0][QUERY]);
@@ -5941,7 +5941,7 @@
my $ary =3D query($q, { wantarray =3D> 1 });
if(ref $ary) {
@lines =3D @$ary;
-#::logDebug("shipping lines reselected with SQL: " . ::uneval(\@lines));
+#::logDebug("shipping lines reselected with SQL: " . uneval(\@lines));
}
else {
#::logDebug("shipping lines failed reselect with SQL query '$q'");
@@ -5950,7 +5950,7 @@
=20
my $o =3D get_option_hash($lines[0][OPT]) || {};
=20
-#::logDebug("shipping opt=3D" . ::uneval($o));
+#::logDebug("shipping opt=3D" . uneval($o));
=20
if($o->{limit}) {
$o->{filter} =3D '(?i)\s*[1ty]' if ! $o->{filter};
@@ -5962,7 +5962,7 @@
=20
tag_cart('mv_shipping');
=20
-#::logDebug("Check 2, must get to FINAL. Vend::Items=3D" . ::uneval($Vend:=
:Items) . " main=3D" . ::uneval($::Carts->{main}) . " mv_shipping=3D" . ::u=
neval($::Carts->{mv_shipping}));
+#::logDebug("Check 2, must get to FINAL. Vend::Items=3D" . uneval($Vend::I=
tems) . " main=3D" . uneval($::Carts->{main}) . " mv_shipping=3D" . uneval(=
$::Carts->{mv_shipping}));
=20
if($o->{perl}) {
$Vend::Interpolate::Shipping =3D $lines[0];
@@ -6189,7 +6189,7 @@
$Vend::Items =3D $save;
#::logDebug("Check FINAL. Vend::Items=3D$Vend::Items main=3D$::Carts->{mai=
n}");
last SHIPFORMAT unless defined $final;
-#::logDebug("ship options: " . ::uneval($o) );
+#::logDebug("ship options: " . uneval($o) );
$final /=3D $Vend::Cfg->{PriceDivide}
if $o->{PriceDivide} and $Vend::Cfg->{PriceDivide} !=3D 0;
unless ($o->{free}) {
@@ -6219,7 +6219,7 @@
}
else {
return $final unless $opt->{label};
-#::logDebug("actual options: " . ::uneval($o));
+#::logDebug("actual options: " . uneval($o));
$number =3D Vend::Util::currency(=20
$final,
$opt->{noformat},
@@ -6423,7 +6423,7 @@
=20
sub tax_vat {
my($type, $opt) =3D @_;
-#::logDebug("entering VAT, opts=3D" . ::uneval($opt));
+#::logDebug("entering VAT, opts=3D" . uneval($opt));
my $cfield =3D $::Variable->{MV_COUNTRY_FIELD} || 'country';
my $country =3D $opt->{country} || $::Values->{$cfield};
=20
@@ -6475,9 +6475,9 @@
$ary =3D $db->query($q);
};
if($@) {
- ::logError("error on state tax query %s", $q);
+ logError("error on state tax query %s", $q);
}
-#::logDebug("query returns " . ::uneval($ary));
+#::logDebug("query returns " . uneval($ary));
return 0 unless ref $ary;
for(@$ary) {
next unless $_->[0];
@@ -6515,7 +6515,7 @@
else {
$tax =3D Vend::Util::get_option_hash($t);
}
-#::logDebug("tax hash=3D" . ::uneval($tax));
+#::logDebug("tax hash=3D" . uneval($tax));
my $pfield =3D $opt->{tax_category_field}
|| $::Variable->{MV_TAX_CATEGORY_FIELD}
|| 'tax_category';
@@ -6568,11 +6568,11 @@
}
elsif($Vend::Cfg->{SalesTaxFunction}) {
$tax_hash =3D tag_calc($Vend::Cfg->{SalesTaxFunction});
-#::logDebug("found custom tax function: " . ::uneval($tax_hash));
+#::logDebug("found custom tax function: " . uneval($tax_hash));
}
else {
$tax_hash =3D $Vend::Cfg->{SalesTaxTable};
-#::logDebug("looking for tax function: " . ::uneval($tax_hash));
+#::logDebug("looking for tax function: " . uneval($tax_hash));
}
=20
# if we have a cost from previous routines, return it
@@ -6585,7 +6585,7 @@
$cost =3D fly_tax();
}
=20
-#::logDebug("got to tax function: " . ::uneval($tax_hash));
+#::logDebug("got to tax function: " . uneval($tax_hash));
my $amount =3D taxable_amount();
my($r, $code);
# Make it upper case for state and overseas postal
@@ -6728,7 +6728,7 @@
my(@fieldnames);
my($i,$point,$zone);
=20
-#::logDebug("tag_ups: type=3D$type zip=3D$zip weight=3D$weight code=3D$cod=
e opt=3D" . ::uneval($opt));
+#::logDebug("tag_ups: type=3D$type zip=3D$zip weight=3D$weight code=3D$cod=
e opt=3D" . uneval($opt));
$code =3D 'u' unless $code;
=20
unless (defined $Vend::Database{$type}) {
2.32 +172 -2 interchange/lib/Vend/Order.pm
rev 2.32, prev_rev 2.31
Index: Order.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Order.pm,v
retrieving revision 2.31
retrieving revision 2.32
diff -u -r2.31 -r2.32
--- Order.pm 10 Sep 2002 15:38:49 -0000 2.31
+++ Order.pm 16 Sep 2002 23:06:31 -0000 2.32
@@ -1,6 +1,6 @@
# Vend::Order - Interchange order routing routines
#
-# $Id: Order.pm,v 2.31 2002/09/10 15:38:49 mheins Exp $
+# $Id: Order.pm,v 2.32 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -28,12 +28,13 @@
package Vend::Order;
require Exporter;
=20
-$VERSION =3D substr(q$Revision: 2.31 $, 10);
+$VERSION =3D substr(q$Revision: 2.32 $, 10);
=20
@ISA =3D qw(Exporter);
=20
@EXPORT =3D qw (
add_items
+ do_order
check_order
check_required
cyber_charge
@@ -41,6 +42,7 @@
mail_order
onfly
route_order
+ update_quantity
validate_whole_cc
);
=20
@@ -1819,6 +1821,174 @@
return ($status, $::Values->{mv_order_number}, $main);
}
return (undef, $::Values->{mv_order_number}, $main);
+}
+
+## DO ORDER
+
+# Order an item
+sub do_order {
+ my($path) =3D @_;
+ my $code =3D $CGI::values{mv_arg};
+#::logDebug("do_order: path=3D$path");
+ my $cart;
+ my $page;
+# LEGACY
+ if($path =3D~ s:/(.*)::) {
+ $cart =3D $1;
+ if($cart =3D~ s:/(.*)::) {
+ $page =3D $1;
+ }
+ }
+# END LEGACY
+ if(defined $CGI::values{mv_pc} and $CGI::values{mv_pc} =3D~ /_(\d+)/) {
+ $CGI::values{mv_order_quantity} =3D $1;
+ }
+ $CGI::values{mv_cartname} =3D $cart if $cart;
+ $CGI::values{mv_nextpage} =3D $page if $page;
+# LEGACY
+ $CGI::values{mv_nextpage} =3D $CGI::values{mv_orderpage}
+ || find_special_page('order')
+ if ! $CGI::values{mv_nextpage};
+# END LEGACY
+ add_items($code);
+ return 1;
+}
+
+my @Scan_modifiers =3D qw/
+ mv_ad
+ mv_an
+ mv_bd
+ mv_bd
+/;
+
+# Returns undef if interaction error
+sub update_quantity {
+ return 1 unless defined $CGI::values{"quantity0"}
+ || $CGI::values{mv_quantity_update};
+ my($h, $i, $quantity, $modifier, $cart);
+
+ if ($CGI::values{mv_cartname}) {
+ $cart =3D $::Carts->{$CGI::values{mv_cartname}} ||=3D [];
+ }
+ else {
+ $cart =3D $Vend::Items;
+ }
+
+ my @mods;
+ @mods =3D @{$Vend::Cfg->{UseModifier}} if $Vend::Cfg->{UseModifier};
+
+#::logDebug("adding modifiers");
+ push(@mods, (grep $_ !~ /^mv_/, split /\0/, $CGI::values{mv_item_option}))
+ if defined $CGI::values{mv_item_option};
+
+ my %seen;
+ push @mods, grep defined $CGI::values{"${_}0"}, @Scan_modifiers;
+ @mods =3D grep ! $seen{$_}++, @mods;
+
+ foreach $h (@mods) {
+ delete @{$::Values}{grep /^$h\d+$/, keys %$::Values};
+ foreach $i (0 .. $#$cart) {
+#::logDebug("updating line $i modifiers: " . ::uneval($cart->[$i]));
+#::logDebug(qq{CGI value=3D$CGI::values{"$h$i"}});
+ $modifier =3D $CGI::values{"$h$i"}
+ || (defined $cart->[$i]{$h} ? '' : undef);
+#::logDebug("line $i modifier $h now $modifier");
+ if (defined($modifier)) {
+ $modifier =3D~ s/\0+/\0/g;
+ $modifier =3D~ s/\0$//;
+ $modifier =3D~ s/^\0//;
+ $modifier =3D~ s/\0/, /g;
+ $cart->[$i]->{$h} =3D $modifier;
+ $::Values->{"$h$i"} =3D $modifier;
+ delete $CGI::values{"$h$i"};
+ }
+ }
+ }
+
+ foreach $i (0 .. $#$cart) {
+#::logDebug("updating line $i quantity: " . ::uneval($cart->[$i]));
+ my $line =3D $cart->[$i];
+ $line->{mv_ip} =3D $i;
+ $quantity =3D $CGI::values{"quantity$i"};
+ next unless defined $quantity;
+ if ($quantity =3D~ m/^\d*$/) {
+ $line->{'quantity'} =3D $quantity || 0;
+ }
+ elsif ($quantity =3D~ m/^[\d.]+$/
+ and $Vend::Cfg->{FractionalItems} ) {
+ $line->{'quantity'} =3D $quantity;
+ }
+ # This allows a last-positioned input of item quantity to
+ # remove the item
+ elsif ($quantity =3D~ s/.*\00$/0/) {
+ $CGI::values{"quantity$i"} =3D $quantity;
+ redo;
+ }
+ # This allows a multiple input of item quantity to
+ # pass -- FIRST ONE CONTROLS
+ elsif ($quantity =3D~ s/\0.*//) {
+ $CGI::values{"quantity$i"} =3D $quantity;
+ redo;
+ }
+ else {
+ my $item =3D $line->{'code'};
+ $line->{quantity} =3D int $line->{quantity};
+ $Vend::Session->{errors}{mv_order_quantity} =3D
+ errmsg("'%s' for item %s is not numeric/integer", $quantity, $item);
+ }
+ $::Values->{"quantity$i"} =3D delete $CGI::values{"quantity$i"};
+ SKUSET: {
+ my $sku;
+ my $found_option;
+ last SKUSET unless $sku =3D delete $CGI::values{"mv_sku$i"};
+ my @sku =3D split /\0/, $sku, -1;
+ for(@sku[1..$#sku]) {
+ if (not length $_) {
+ $_ =3D $::Variable->{MV_VARIANT_JOINER} || '0';
+ next;
+ }
+ $found_option++;
+ }
+
+ if(@sku > 1 and ! $found_option) {
+ splice @sku, 1;
+ }
+
+ $sku =3D join "-", @sku;
+
+ my $ib;
+ unless($ib =3D ::product_code_exists_tag($sku)) {
+ push @{$Vend::Session->{warnings} ||=3D []},
+ errmsg("Not a valid option combination: %s", $sku);
+ last SKUSET;
+ }
+
+ $line->{mv_ib} =3D $ib;
+
+ if($sku ne $line->{code}) {
+ if($line->{mv_mp}) {
+ $line->{mv_sku} =3D $line->{code} =3D $sku;
+ }
+ elsif (! $line->{mv_sku}) {
+ $line->{mv_sku} =3D $line->{code};
+ $line->{code} =3D $sku;
+ }
+ else {
+ $line->{code} =3D $sku;
+ }
+ }
+ }
+ }
+#::logDebug("after update, cart is: " . ::uneval($cart));
+
+ # If the user has put in "0" for any quantity, delete that item
+ # from the order list. Handles sub-items.
+ Vend::Cart::toss_cart($cart, $CGI::values{mv_cartname});
+
+#::logDebug("after toss, cart is: " . ::uneval($cart));
+
+ 1;
+
}
=20
sub add_items {
2.2 +3 -3 interchange/lib/Vend/SOAP.pm
rev 2.2, prev_rev 2.1
Index: SOAP.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/SOAP.pm,v
retrieving revision 2.1
retrieving revision 2.2
diff -u -r2.1 -r2.2
--- SOAP.pm 17 Jun 2002 22:24:08 -0000 2.1
+++ SOAP.pm 16 Sep 2002 23:06:31 -0000 2.2
@@ -1,6 +1,6 @@
# Vend::SOAP - Handle SOAP connections for Interchange
#
-# $Id: SOAP.pm,v 2.1 2002/06/17 22:24:08 jon Exp $
+# $Id: SOAP.pm,v 2.2 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -34,7 +34,7 @@
use strict;
=20
use vars qw($VERSION @ISA $AUTOLOAD);
-$VERSION =3D substr(q$Revision: 2.1 $, 10);
+$VERSION =3D substr(q$Revision: 2.2 $, 10);
@ISA =3D qw/SOAP::Server/;
=20
my %Allowed_tags;
@@ -99,7 +99,7 @@
my $self =3D shift;
my @args =3D @_;
return "hello from the Vend::SOAP server, pid $$, world!\nreceived args:\=
n"
- . ::uneval(\@args);
+ . uneval(\@args);
}
=20
sub soaptest {
2.12 +9 -9 interchange/lib/Vend/Search.pm
rev 2.12, prev_rev 2.11
Index: Search.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Search.pm,v
retrieving revision 2.11
retrieving revision 2.12
diff -u -r2.11 -r2.12
--- Search.pm 1 Sep 2002 23:19:51 -0000 2.11
+++ Search.pm 16 Sep 2002 23:06:31 -0000 2.12
@@ -1,6 +1,6 @@
# Vend::Search - Base class for search engines
#
-# $Id: Search.pm,v 2.11 2002/09/01 23:19:51 mheins Exp $
+# $Id: Search.pm,v 2.12 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -21,7 +21,7 @@
=20
package Vend::Search;
=20
-$VERSION =3D substr(q$Revision: 2.11 $, 10);
+$VERSION =3D substr(q$Revision: 2.12 $, 10);
=20
use strict;
use vars qw($VERSION);
@@ -213,15 +213,15 @@
$msg,
$s->{mv_coordinate},
scalar @$specs,
- ::uneval($specs),
+ Vend::Util::uneval($specs),
scalar @{$s->{mv_search_field}},
- ::uneval($s->{mv_search_field}),
+ Vend::Util::uneval($s->{mv_search_field}),
scalar @{$s->{mv_column_op}},
- ::uneval($s->{mv_column_op}),
+ Vend::Util::uneval($s->{mv_column_op}),
scalar @{$s->{mv_numeric}},
- ::uneval($s->{mv_numeric}),
+ Vend::Util::uneval($s->{mv_numeric}),
scalar @{$s->{mv_negate}},
- ::uneval($s->{mv_negate}),
+ Vend::Util::uneval($s->{mv_negate}),
;
}
=20
@@ -988,7 +988,7 @@
for (@save) {
$return->{$_} =3D $s->{$_};
}
- ::uneval_fast($return);
+ Vend::Util::uneval_fast($return);
}
=20
sub dump_options {
@@ -998,7 +998,7 @@
$Data::Dumper::Indent =3D 3;
$Data::Dumper::Terse =3D 1;
}
- return ::uneval($s);
+ return Vend::Util::uneval($s);
}
=20
sub search_error {
2.14 +9 -5 interchange/lib/Vend/Server.pm
rev 2.14, prev_rev 2.13
Index: Server.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Server.pm,v
retrieving revision 2.13
retrieving revision 2.14
diff -u -r2.13 -r2.14
--- Server.pm 7 Sep 2002 20:05:10 -0000 2.13
+++ Server.pm 16 Sep 2002 23:06:31 -0000 2.14
@@ -1,6 +1,6 @@
# Vend::Server - Listen for Interchange CGI requests as a background server
#
-# $Id: Server.pm,v 2.13 2002/09/07 20:05:10 mheins Exp $
+# $Id: Server.pm,v 2.14 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -25,7 +25,7 @@
package Vend::Server;
=20
use vars qw($VERSION);
-$VERSION =3D substr(q$Revision: 2.13 $, 10);
+$VERSION =3D substr(q$Revision: 2.14 $, 10);
=20
use POSIX qw(setsid strftime);
use Vend::Util;
@@ -1058,8 +1058,12 @@
}
=20
eval {
- $c =3D ::config_named_catalog($cat->{CatalogName},
- "from running server ($$)", $table, $c=
file);
+ $c =3D Vend::Config::config_named_catalog(
+ $cat->{CatalogName},
+ "from running server ($$)",
+ $table,
+ $cfile
+ );
};
=20
if (defined $c) {
@@ -2225,7 +2229,7 @@
sub cron_job {
my ($cat, @jobs) =3D @_;
for my $job (@jobs) {
- ::run_in_catalog($cat, $job);
+ Vend::Dispatch::run_in_catalog($cat, $job);
}
}
=20
2.7 +59 -4 interchange/lib/Vend/Session.pm
rev 2.7, prev_rev 2.6
Index: Session.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Session.pm,v
retrieving revision 2.6
retrieving revision 2.7
diff -u -r2.6 -r2.7
--- Session.pm 15 Jul 2002 14:20:00 -0000 2.6
+++ Session.pm 16 Sep 2002 23:06:31 -0000 2.7
@@ -1,6 +1,6 @@
# Vend::Session - Interchange session routines
#
-# $Id: Session.pm,v 2.6 2002/07/15 14:20:00 mheins Exp $
+# $Id: Session.pm,v 2.7 2002/09/16 23:06:31 mheins Exp $
#=20
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -26,7 +26,7 @@
require Exporter;
=20
use vars qw($VERSION);
-$VERSION =3D substr(q$Revision: 2.6 $, 10);
+$VERSION =3D substr(q$Revision: 2.7 $, 10);
=20
@ISA =3D qw(Exporter);
=20
@@ -38,9 +38,12 @@
close_session
get_session
init_session
+is_retired
new_session
put_session
+retire_id
session_name
+tie_static_dbm
=20
);
=20
@@ -205,6 +208,25 @@
return Vend::CounterFile->new($fn)->value();
}
=20
+sub is_retired {
+ my $id =3D shift;
+ mkdir "$Vend::Cfg->{ScratchDir}/retired", 0777
+ unless -d "$Vend::Cfg->{ScratchDir}/retired";
+ my $fn =3D Vend::Util::get_filename($id, 2, 1, "$Vend::Cfg->{ScratchDir}/=
retired");
+ return -f $fn ? 1 : 0;
+}
+
+sub retire_id {
+ my $id =3D shift;
+ return unless $id =3D~ /^\w+$/;
+ mkdir "$Vend::Cfg->{ScratchDir}/retired", 0777
+ unless -d "$Vend::Cfg->{ScratchDir}/retired";
+ my $fn =3D Vend::Util::get_filename($id, 2, 1, "$Vend::Cfg->{ScratchDir}/=
retired");
+ open(TMPRET, ">$fn")
+ or die "retire id open: $!\n";
+ close(TMPRET);
+ return;
+}
=20
sub new_session {
my($seed) =3D @_;
@@ -218,8 +240,8 @@
undef $Vend::CookieID;
}
undef $seed;
- if (::is_retired($Vend::SessionID)) {
- ::retire_id($Vend::SessionID);
+ if (is_retired($Vend::SessionID)) {
+ retire_id($Vend::SessionID);
next;
}
$name =3D session_name();
@@ -544,6 +566,39 @@
=20
return ($expire > $time);
}=09
+
+sub tie_static_dbm {
+ my $rw =3D shift;
+ untie(%Vend::StaticDBM) if $rw;
+ if($Global::GDBM) {
+ my $flags =3D $rw ? &GDBM_WRITER : &GDBM_READER;
+ $flags =3D &GDBM_NEWDB
+ if $rw && (! -f "$Vend::Cfg->{StaticDBM}.gdbm");
+ tie(%Vend::StaticDBM,
+ 'GDBM_File',
+ "$Vend::Cfg->{StaticDBM}.gdbm",
+ $flags,
+ $Vend::Cfg->{'FileCreationMask'},
+ )
+ or $Vend::Cfg->{SaveStaticDBM} =3D delete $Vend::Cfg->{StaticDBM};
+ }
+ elsif ($Global::DB_File) {
+ tie(%Vend::StaticDBM,
+ 'DB_File',
+ "$Vend::Cfg->{StaticDBM}.db",
+ ($rw ? &O_RDWR | &O_CREAT : &O_RDONLY),
+ $Vend::Cfg->{'FileCreationMask'},
+ )
+ or undef $Vend::Cfg->{StaticDBM};
+ }
+ else {
+ $Vend::Cfg->{SaveStaticDBM} =3D delete $Vend::Cfg->{StaticDBM};
+ }
+ ::logError("Failed to create StaticDBM %s", $Vend::Cfg->{StaticDBM})
+ if $rw && ! $Vend::Cfg->{StaticDBM};
+ return $Vend::Cfg->{StaticDBM} || undef;
+}
+
=20
1;
=20
2.10 +5 -5 interchange/lib/Vend/UserDB.pm
rev 2.10, prev_rev 2.9
Index: UserDB.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/UserDB.pm,v
retrieving revision 2.9
retrieving revision 2.10
diff -u -r2.9 -r2.10
--- UserDB.pm 20 Jul 2002 14:43:28 -0000 2.9
+++ UserDB.pm 16 Sep 2002 23:06:31 -0000 2.10
@@ -1,6 +1,6 @@
# Vend::UserDB - Interchange user database functions
#
-# $Id: UserDB.pm,v 2.9 2002/07/20 14:43:28 mheins Exp $
+# $Id: UserDB.pm,v 2.10 2002/09/16 23:06:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -16,7 +16,7 @@
=20
package Vend::UserDB;
=20
-$VERSION =3D substr(q$Revision: 2.9 $, 10);
+$VERSION =3D substr(q$Revision: 2.10 $, 10);
=20
use vars qw!
$VERSION
@@ -500,7 +500,7 @@
else {
$f->{$options{location}} =3D $options{mode} || 'rw';
}
- my $return =3D $self->{DB}->set_field( $self->{USERNAME}, $loc, Vend::Uti=
l::uneval_it($f) );
+ my $return =3D $self->{DB}->set_field( $self->{USERNAME}, $loc, uneval_it=
($f) );
return $return if $options{show};
return;
}
@@ -897,7 +897,7 @@
return undef;
}
=20
- my $s =3D ::uneval_it($self->{$name});
+ my $s =3D uneval_it($self->{$name});
=20
$self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
=20
@@ -935,7 +935,7 @@
return undef;
}
=20
- my $s =3D ::uneval_it($self->{$name});
+ my $s =3D uneval_it($self->{$name});
=20
$self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
=20
2.36 +8 -2 interchange/lib/Vend/Util.pm
rev 2.36, prev_rev 2.35
Index: Util.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Util.pm,v
retrieving revision 2.35
retrieving revision 2.36
diff -u -r2.35 -r2.36
--- Util.pm 13 Sep 2002 20:46:21 -0000 2.35
+++ Util.pm 16 Sep 2002 23:06:31 -0000 2.36
@@ -1,6 +1,6 @@
# Vend::Util - Interchange utility functions
#
-# $Id: Util.pm,v 2.35 2002/09/13 20:46:21 mheins Exp $
+# $Id: Util.pm,v 2.36 2002/09/16 23:06:31 mheins Exp $
#=20
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -32,6 +32,7 @@
check_security
copyref
currency
+ dbref
dump_structure
errmsg
escape_chars
@@ -82,7 +83,7 @@
use Safe;
use subs qw(logError logGlobal);
use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION =3D substr(q$Revision: 2.35 $, 10);
+$VERSION =3D substr(q$Revision: 2.36 $, 10);
=20
BEGIN {
eval {
@@ -113,6 +114,11 @@
'0123456789' .
'-_./~=3D'
;
+
+## This is an alias for a commonly-used function
+sub dbref {
+ return Vend::Data::database_exists_ref(@_);
+}
=20
## This is a character class for HTML::Entities
$ESCAPE_CHARS::std =3D "^\n\t !\#\$%\'-;=3D?-Z\\\]-~";
1.7 +12 -12 interchange/lib/Vend/Accounting/SQL_Ledger.pm
rev 1.7, prev_rev 1.6
Index: SQL_Ledger.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Accounting/SQL_Ledger.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- SQL_Ledger.pm 28 Jul 2002 05:15:28 -0000 1.6
+++ SQL_Ledger.pm 16 Sep 2002 23:06:32 -0000 1.7
@@ -73,7 +73,7 @@
$cfg->{counter} =3D "$tab:id";
}
bless $self, $class;
-#::logDebug("Accounting self=3D" . ::uneval($self) );
+#::logDebug("Accounting self=3D" . uneval($self) );
return $self;
}
=20
@@ -276,7 +276,7 @@
logError($msg);
#::logDebug($msg);
}
-#::logDebug("passing rec=3D" . ::uneval($rec));
+#::logDebug("passing rec=3D" . uneval($rec));
$self->save_customer_data($id, $rec);
my $on =3D $rec->{order_number};
my $query =3D "select * from $tab where order_number =3D '$on'";
@@ -322,7 +322,7 @@
handling =3D> $rec->{handling} || 0,
total_cost =3D> $rec->{total_cost} || 0,
};
-#::logDebug("Getting ready to create order entry: " . ::uneval($o));
+#::logDebug("Getting ready to create order entry: " . uneval($o));
$obj->create_order_entry($o);
$count++;
}
@@ -397,11 +397,11 @@
=20
=20
my @charges;
-#::logDebug("Levies=3D" . ::uneval($Vend::Cfg->{Levies}));
+#::logDebug("Levies=3D" . uneval($Vend::Cfg->{Levies}));
if($Vend::Cfg->{Levies}) {
$Tag->levies(1);
my $lcart =3D $::Levies;
-#::logDebug("levy cart=3D" . ::uneval($lcart));
+#::logDebug("levy cart=3D" . uneval($lcart));
for my $levy (@$lcart) {
my $pid =3D $levy->{part_number};
$pid ||=3D uc($levy->{group} || $levy->{type});
@@ -410,7 +410,7 @@
description =3D> $levy->{description},
mv_price =3D> $levy->{cost},
};
-#::logDebug("levy result=3D" . ::uneval($lresult));
+#::logDebug("levy result=3D" . uneval($lresult));
push @charges, $lresult;
}
}
@@ -679,7 +679,7 @@
$res->{currency},
);
=20=09
-#::logDebug("ready to execute tquery=3D$tq with values=3D" . ::uneval(\@va=
ls));
+#::logDebug("ready to execute tquery=3D$tq with values=3D" . uneval(\@vals=
));
$tsth->execute(@vals)=20
or die errmsg("Statement '%s' failed.", $tq);
=20
@@ -720,7 +720,7 @@
}
=20=09=09
$res->{rowcount} =3D $idx;
-#::logDebug("past accounting, ready to return res=3D" . ::uneval($res));
+#::logDebug("past accounting, ready to return res=3D" . uneval($res));
=20
if($opt->{do_payment}) {
$res->{paid_1} =3D $opt->{total_cost};
@@ -962,7 +962,7 @@
=20
sub enter_payment {
my ($self, $string) =3D @_;
- my $datastuff =3D ::uneval(\@_);
+ my $datastuff =3D uneval(\@_);
`echo "This is a enter_customer_payment test... $datastuff" >> testlog.tx=
t`;
return $string;
}
@@ -975,7 +975,7 @@
my $myconfig =3D $self->myconfig();
my $cfg =3D $self->{Config};
=20
-#::logDebug("have myconfig=3D" . ::uneval($myconfig));
+#::logDebug("have myconfig=3D" . uneval($myconfig));
$form->{AR} ||=3D $cfg->{default_ar} || 1200;
$form->{AR_paid} ||=3D $cfg->{default_ar_paid} || 1060;
$form->{fxgain_accno} ||=3D $cfg->{default_fxgain_accno}|| 4450;
@@ -1003,9 +1003,9 @@
$form->{"shipto$key"} =3D~ s/"/"/g;
}
=20
-#::logDebug("customer details back, form set up=3D" . ::uneval($form));
+#::logDebug("customer details back, form set up=3D" . uneval($form));
my $status =3D IS->post_invoice($myconfig, $form);
-#::logDebug("post_status=3D$status, form now=3D" . ::uneval($form));
+#::logDebug("post_status=3D$status, form now=3D" . uneval($form));
return $form;
}
=20
1.2 +5 -5 interchange/lib/Vend/Payment/MCVE.pm
rev 1.2, prev_rev 1.1
Index: MCVE.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Payment/MCVE.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- MCVE.pm 24 Jul 2002 15:30:58 -0000 1.1
+++ MCVE.pm 16 Sep 2002 23:06:32 -0000 1.2
@@ -1,6 +1,6 @@
# Vend::Payment::MCVE - Interchange MCVE support
#
-# $Id: MCVE.pm,v 1.1 2002/07/24 15:30:58 kwalsh Exp $
+# $Id: MCVE.pm,v 1.2 2002/09/16 23:06:32 mheins Exp $
#
# Author: Tom Friedel (tom@readyink.com) for Carlc Internet Services (http=
://www.carlc.com)
#
@@ -22,11 +22,11 @@
package Vend::Payment::MCVE;
=20
use vars qw($VERSION);
-$VERSION =3D substr(q$Revision: 1.1 $, 10);
+$VERSION =3D substr(q$Revision: 1.2 $, 10);
=20
=3Dhead1 Interchange MCVE support
=20
-Vend::Payment::MCVE $Revision: 1.1 $
+Vend::Payment::MCVE $Revision: 1.2 $
=20
=3Dhead1 SYNOPSIS
=20
@@ -217,7 +217,7 @@
sub mcve {
my ($opt) =3D @_;
=20
- ::logDebug("mcve called, args=3D" . ::uneval(\@_));
+#::logDebug("mcve called, args=3D" . ::uneval(\@_));
=20
my $sess;
my %result;
@@ -471,7 +471,7 @@
&MCVE::MCVE_DestroyConn($conn);
&MCVE::MCVE_DestroyEngine();
=20
- ::logDebug("mcve returns, result=3D" . ::uneval(\%result));
+#::logDebug("mcve returns, result=3D" . ::uneval(\%result));
return %result;
}
=20
2.32 +4 -4 interchange/lib/Vend/Table/DBI.pm
rev 2.32, prev_rev 2.31
Index: DBI.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/lib/Vend/Table/DBI.pm,v
retrieving revision 2.31
retrieving revision 2.32
diff -u -r2.31 -r2.32
--- DBI.pm 10 Sep 2002 17:29:09 -0000 2.31
+++ DBI.pm 16 Sep 2002 23:06:32 -0000 2.32
@@ -1,6 +1,6 @@
# Vend::Table::DBI - Access a table stored in an DBI/DBD database
#
-# $Id: DBI.pm,v 2.31 2002/09/10 17:29:09 mheins Exp $
+# $Id: DBI.pm,v 2.32 2002/09/16 23:06:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -20,7 +20,7 @@
# MA 02111-1307 USA.
=20
package Vend::Table::DBI;
-$VERSION =3D substr(q$Revision: 2.31 $, 10);
+$VERSION =3D substr(q$Revision: 2.32 $, 10);
=20
use strict;
=20
@@ -647,8 +647,8 @@
$config->{KEY_INDEX} =3D $config->{COLUMN_INDEX}{lc $key}
if ! $config->{KEY_INDEX};
die ::errmsg("Bad key specification: %s" .
- ::uneval_it($config->{NAME}) .
- ::uneval_it($config->{COLUMN_INDEX}),
+ Vend::Util::uneval_it($config->{NAME}) .
+ Vend::Util::uneval_it($config->{COLUMN_INDEX}),
$key
)
if ! defined $config->{KEY_INDEX};
2.59 +3 -2270 interchange/scripts/interchange.PL
rev 2.59, prev_rev 2.58
Index: interchange.PL
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/scripts/interchange.PL,v
retrieving revision 2.58
retrieving revision 2.59
diff -u -r2.58 -r2.59
--- interchange.PL 12 Sep 2002 15:56:32 -0000 2.58
+++ interchange.PL 16 Sep 2002 23:06:33 -0000 2.59
@@ -3,7 +3,7 @@
#
# Interchange version 4.9.3
#
-# $Id: interchange.PL,v 2.58 2002/09/12 15:56:32 mheins Exp $
+# $Id: interchange.PL,v 2.59 2002/09/16 23:06:33 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. and others.
# http://www.icdevgroup.org/
@@ -258,10 +258,6 @@
=20
# END AUTOUSE
=20
-# GLIMPSE
-use Vend::Glimpse;
-# END GLIMPSE
-
# TRACK
use Vend::Track;
# END TRACK
@@ -272,6 +268,7 @@
use Vend::Interpolate;
use Vend::Page;
use Vend::CounterFile;
+use Vend::Dispatch;
=20
if($ENV{INTERCHANGE_REQUIRE}) {
my @mods =3D split /[;\s]+/, $ENV{INTERCHANGE_REQUIRE};
@@ -306,2236 +303,6 @@
## would act properly by default
undef $Vend::ExternalProgram;
=20
-my $H;
-sub http {
- return $H;
-}
-
-sub response {
- my ($output) =3D @_;
- my $out =3D ref $output ? $output : \$output;
- if (defined $Vend::CheckHTML) {
- require Vend::External;
- Vend::External::check_html($out);
- }
- $H->respond($out);
-}
-
-## DO ORDER
-
-# Order an item with product code CODE.
-
-sub do_order {
- my($path) =3D @_;
- my $code =3D $CGI::values{mv_arg};
-#::logDebug("do_order: path=3D$path");
- my $cart;
- my $page;
-# LEGACY
- if($path =3D~ s:/(.*)::) {
- $cart =3D $1;
- if($cart =3D~ s:/(.*)::) {
- $page =3D $1;
- }
- }
-# END LEGACY
- if(defined $CGI::values{mv_pc} and $CGI::values{mv_pc} =3D~ /_(\d+)/) {
- $CGI::values{mv_order_quantity} =3D $1;
- }
- $CGI::values{mv_cartname} =3D $cart if $cart;
- $CGI::values{mv_nextpage} =3D $page if $page;
-# LEGACY
- $CGI::values{mv_nextpage} =3D $CGI::values{mv_orderpage}
- || find_special_page('order')
- if ! $CGI::values{mv_nextpage};
-# END LEGACY
- add_items($code);
- return 1;
-}
-
-my @Scan_modifiers =3D qw/
- mv_ad
- mv_an
- mv_bd
- mv_bd
-/;
-
-# Returns undef if interaction error
-sub update_quantity {
- return 1 unless defined $CGI::values{"quantity0"}
- || $CGI::values{mv_quantity_update};
- my($h, $i, $quantity, $modifier, $cart);
-
- if ($CGI::values{mv_cartname}) {
- $cart =3D $::Carts->{$CGI::values{mv_cartname}} ||=3D [];
- }
- else {
- $cart =3D $Vend::Items;
- }
-
- my @mods;
- @mods =3D @{$Vend::Cfg->{UseModifier}} if $Vend::Cfg->{UseModifier};
-
-#::logDebug("adding modifiers");
- push(@mods, (grep $_ !~ /^mv_/, split /\0/, $CGI::values{mv_item_option}))
- if defined $CGI::values{mv_item_option};
-
- my %seen;
- push @mods, grep defined $CGI::values{"${_}0"}, @Scan_modifiers;
- @mods =3D grep ! $seen{$_}++, @mods;
-
- foreach $h (@mods) {
- delete @{$::Values}{grep /^$h\d+$/, keys %$::Values};
- foreach $i (0 .. $#$cart) {
-#::logDebug("updating line $i modifiers: " . ::uneval($cart->[$i]));
-#::logDebug(qq{CGI value=3D$CGI::values{"$h$i"}});
- $modifier =3D $CGI::values{"$h$i"}
- || (defined $cart->[$i]{$h} ? '' : undef);
-#::logDebug("line $i modifier $h now $modifier");
- if (defined($modifier)) {
- $modifier =3D~ s/\0+/\0/g;
- $modifier =3D~ s/\0$//;
- $modifier =3D~ s/^\0//;
- $modifier =3D~ s/\0/, /g;
- $cart->[$i]->{$h} =3D $modifier;
- $::Values->{"$h$i"} =3D $modifier;
- delete $CGI::values{"$h$i"};
- }
- }
- }
-
- foreach $i (0 .. $#$cart) {
-#::logDebug("updating line $i quantity: " . ::uneval($cart->[$i]));
- my $line =3D $cart->[$i];
- $line->{mv_ip} =3D $i;
- $quantity =3D $CGI::values{"quantity$i"};
- next unless defined $quantity;
- if ($quantity =3D~ m/^\d*$/) {
- $line->{'quantity'} =3D $quantity || 0;
- }
- elsif ($quantity =3D~ m/^[\d.]+$/
- and $Vend::Cfg->{FractionalItems} ) {
- $line->{'quantity'} =3D $quantity;
- }
- # This allows a last-positioned input of item quantity to
- # remove the item
- elsif ($quantity =3D~ s/.*\00$/0/) {
- $CGI::values{"quantity$i"} =3D $quantity;
- redo;
- }
- # This allows a multiple input of item quantity to
- # pass -- FIRST ONE CONTROLS
- elsif ($quantity =3D~ s/\0.*//) {
- $CGI::values{"quantity$i"} =3D $quantity;
- redo;
- }
- else {
- my $item =3D $line->{'code'};
- $line->{quantity} =3D int $line->{quantity};
- $Vend::Session->{errors}{mv_order_quantity} =3D
- errmsg("'%s' for item %s is not numeric/integer", $quantity, $item);
- }
- $::Values->{"quantity$i"} =3D delete $CGI::values{"quantity$i"};
- SKUSET: {
- my $sku;
- my $found_option;
- last SKUSET unless $sku =3D delete $CGI::values{"mv_sku$i"};
- my @sku =3D split /\0/, $sku, -1;
- for(@sku[1..$#sku]) {
- if (not length $_) {
- $_ =3D $::Variable->{MV_VARIANT_JOINER} || '0';
- next;
- }
- $found_option++;
- }
-
- if(@sku > 1 and ! $found_option) {
- splice @sku, 1;
- }
-
- $sku =3D join "-", @sku;
-
- my $ib;
- unless($ib =3D ::product_code_exists_tag($sku)) {
- push @{$Vend::Session->{warnings} ||=3D []},
- errmsg("Not a valid option combination: %s", $sku);
- last SKUSET;
- }
-
- $line->{mv_ib} =3D $ib;
-
- if($sku ne $line->{code}) {
- if($line->{mv_mp}) {
- $line->{mv_sku} =3D $line->{code} =3D $sku;
- }
- elsif (! $line->{mv_sku}) {
- $line->{mv_sku} =3D $line->{code};
- $line->{code} =3D $sku;
- }
- else {
- $line->{code} =3D $sku;
- }
- }
- }
- }
-#::logDebug("after update, cart is: " . ::uneval($cart));
-
- # If the user has put in "0" for any quantity, delete that item
- # from the order list. Handles sub-items.
- Vend::Cart::toss_cart($cart, $CGI::values{mv_cartname});
-
-#::logDebug("after toss, cart is: " . ::uneval($cart));
-
- 1;
-
-}
-
-sub set_db {
- my ($base, $thing) =3D @_;
- return ($base, $thing) unless $thing =3D~ /^(\w+):+(.*)/;
- my $t =3D $1;
- my $c =3D $2;
-
- # Security handled before this in update_data
- $Vend::WriteDatabase{$t} =3D 1;
-
- my $db =3D ::database_exists_ref($t);
- return undef unless $db;
- return ($db->ref(), $c);
-}
-
-## Update the user-entered fields.
-sub update_data {
- my($key,$value);
- my @cgi_keys =3D keys %CGI::values;
- # Update a database record
- # Check to see if this is allowed
-#::logDebug("mv_data_enable=3D$::Scratch->{mv_data_enable}");
- if(! $::Scratch->{mv_data_enable}) {
- logError(
- "Attempted database update without permission, table=3D%s key=3D%s.",
- $CGI::values{mv_data_table},
- $CGI::values{$CGI::values{mv_data_key}},
- );
- return undef;
- }
- unless (defined $CGI::values{mv_data_table} and=20
- defined $CGI::values{mv_data_key} ) {
- logError("Attempted database operation without table, fields, or key.\n"=
.
- "Table: '%s'\n" .
- "Fields:'%s'\n" .
- "Key: '%s'\n",
- $CGI::values{mv_data_table},
- $CGI::values{mv_data_fields},
- $CGI::values{mv_data_key},
- );
-
- return undef;
- }
-
- my $function =3D lc (delete $CGI::values{mv_data_function});
- if($function eq 'delete' and ! delete $CGI::values{mv_data_verify}) {
- logError("update_data: DELETE without VERIFY, abort");
- return undef;
- }
- my $table =3D $CGI::values{mv_data_table};
- my $prikey =3D $CGI::values{mv_data_key};
- my $decode =3D is_yes($CGI::values{mv_data_decode});
- my ($ref, $db, $database);
-
- my $en_col;
-#::logDebug("data_enable=3D$::Scratch->{mv_data_enable}, checking");
- if($::Scratch->{mv_data_enable} =3D~ /^(\w+):(.*?):/) {
- # check for single key and possible set of columns
- my $en_table =3D $1;
- $en_col =3D $2;
- my $en_key =3D $::Scratch->{mv_data_enable_key};
-#::logDebug("en_table=3D$en_table en_col=3D$en_col, en_key=3D$en_key, chec=
king");
- if( $en_table ne $table
- or=20
- ($en_key and $CGI::values{$prikey} ne $en_key)
- )
- {
- logError("Attempted database operation without permission:\n" .
- "Permission: '%s' (key=3D'$en_key')\n" .
- "Table: '%s'\n" .
- "Fields:'%s'\n" .
- "Key: '%s'\n",
- $::Scratch->{mv_data_enable},
- $CGI::values{mv_data_table},
- $CGI::values{mv_data_fields},
- $CGI::values{$CGI::values{mv_data_key}},
- );
- return undef;
- }
- }
-
-
- $Vend::WriteDatabase{$table} =3D 1;
-
- my $base_db =3D database_exists_ref($table)
- or die "Not a defined database '$table': $!\n";
- $base_db =3D $base_db->ref();
-
- my @fields =3D grep $_ && $_ ne $prikey,
- split /[\s\0,]+/, $CGI::values{mv_data_fields};
- unshift(@fields, $prikey);
-
- my @file_fields =3D split /[\s\0,]+/, $CGI::values{mv_data_file_field};
- my @file_paths =3D split /[\s\0,]+/, $CGI::values{mv_data_file_path};
- my @file_oldfiles =3D split /[\s\0,]+/, $CGI::values{mv_data_file_oldf=
ile};
-
- if($en_col) {
- $en_col =3D~ s/^\s+//;
- $en_col =3D~ s/\s+$//;
- my %col_present;
- @col_present{ grep /\S/, split /[\s\0,]+/, $en_col } =3D ();
- $col_present{$prikey} =3D 1;
- for(@fields, $CGI::values{mv_blob_field}, $CGI::values{mv_blob_pointer})=
{
- next unless $_;
- next if exists $col_present{$_};
- next if /:/ and $::Scratch->{mv_data_enable} =3D~ / $_ /;
- logError("Attempted database operation without permission:\n" .
- "Permission: '%s'\n" .
- "Table: '%s'\n" .
- "Fields:'%s'\n" .
- "Key: '%s'\n",
- $::Scratch->{mv_data_enable},
- $CGI::values{mv_data_table},
- $CGI::values{mv_data_fields},
- $CGI::values{$CGI::values{mv_data_key}},
- );
- return undef;
- }
- }
- $function =3D 'update' unless $function;
-
- my (%data);
- for(@fields) {
- $data{$_} =3D [];
- }
-
- my $count;
- my $multi =3D $CGI::values{$prikey} =3D~ tr/\0/\0/;
- my $max =3D 0;
- my $min =3D 9999;
- my ($minname, $maxname);
-
- while (($key, $value) =3D each %CGI::values) {
- next unless defined $data{$key};
- if($CGI::values{"mv_data_prep_$key"}) {
- $value =3D Vend::Interpolate::filter_value(
- $CGI::values{"mv_data_prep_$key"},
- $value
- );
- }
- $count =3D (@{$data{$key}} =3D split /\0/, $value, -1);
- $max =3D $count, $maxname =3D $key if $count > $max;
- $min =3D $count, $minname =3D $key if $count < $min;
- }
-
- if( $multi and ($max - $min) > 1 and ! $CGI::values{mv_data_force}) {
- logError("probable bad form -- number of values min=3D%s (%s) max=3D%s (=
%s)", $min, $minname, $max, $maxname);
- return;
- }
-
- my $autonumber;
- if ($CGI::values{mv_data_auto_number}) {
- $autonumber =3D 1;
- my $ref =3D $data{$prikey};
- while (scalar @$ref < $max) {
- push @$ref, '';
- }
- $base_db->config('AUTO_NUMBER', '000001')
- if ! $base_db->config('_Auto_number');
- $CGI::values{mv_data_return_key} =3D $prikey
- unless $CGI::values{mv_data_return_key};
- }
- elsif($function eq 'insert' and $base_db->config('_Auto_number') ) {
- $autonumber =3D 1;
- }
-=20
-
- if(@file_fields) {
- my $Tag =3D new Vend::Tags;
- my $acl_func;
- my $outfile;
- if($Vend::Session->{logged_in} and $Vend::admin) {
- $acl_func =3D sub {
- return $Tag->if_mm('files', shift);
- };
- }
- elsif($Vend::Session->{logged_in} and ! $Vend::admin) {
- $acl_func =3D sub {
- my $file =3D shift;
- return 1 if $::Scratch->{$file} =3D=3D 1;
- return $Tag->userdb(
- function =3D> 'check_file_acl',
- location =3D> $file,
- mode =3D> 'w'
- );
- };
- }
- else {
- $acl_func =3D sub { return $::Scratch->{shift(@_)} =3D=3D 1 }
- }
-
- for (my $i =3D 0; $i < @file_fields; $i++) {
- unless (length($data{$file_fields[$i]}->[0])) {
- # no need for a file update
- $data{$file_fields[$i]}->[0] =3D $file_oldfiles[$i];
- next;
- }
-
- # remove path components
- $data{$file_fields[$i]}->[0] =3D~ s:.*/::;=20
- $data{$file_fields[$i]}->[0] =3D~ s:.*\\::;=20
-
- if (length ($file_paths[$i])) {
- # real file upload
- $outfile =3D join('/', $file_paths[$i], $data{$file_fields[$i]}->[0]);
-#::logDebug("file upload: field=3D$file_fields[$i] path=3D$file_paths[$i] =
outfile=3D$outfile");
- my $ok;
- if (-f $outfile) {
- eval {
- $ok =3D $acl_func->($outfile);
- };
- } else {
- eval {
- $ok =3D $acl_func->($file_paths[$i]);
- };
- }
- if (! $ok) {
- if($@) {
- ::logError ("ACL function failed on '%s': %s", $outfile, $@);
- }
- else {
- ::logError ("Not allowed to upload \"%s\"", $outfile);
- }
- next;
- }=20
- my $err;
- Vend::Interpolate::tag_value_extended(
- $file_fields[$i],
- {
- test =3D> 'isfile'
- }
- )
- or do {
- ::logError("%s is not a file.", $data{$file_fields[$i]}->[0]);
- next;
- };
- Vend::Interpolate::tag_value_extended(
- $file_fields[$i],
- {
- outfile =3D> $outfile,
- umask =3D> '022',
- yes =3D> '1',
- }
- )
- or do {
- ::logError("failed to write %s: %s", $outfile, $!);
- next;
- };
- }
- else {
- # preparing to dump file contents into database column
- $data{$file_fields[$i]}->[0]
- =3D Vend::Interpolate::tag_value_extended ($file_fields[$i],
- {file_contents =3D> 1});
- }
- }
- }
-
- if (not defined $data{$prikey}) {
- logError("No key '%s' in field specifier %s", $prikey, 'mv_data_fields');
- return undef;
- }
- elsif ( ! @{$data{$prikey}}) {
- if($autonumber) {
- @{$data{$prikey}} =3D map { '' } @{ $data{$fields[1]} };
- }
- else {
- logError("No key '%s' found for function=3D'%s' table=3D'%s'",
- $prikey, $function, $CGI::values{mv_data_table},
- );
- return undef;
- }
- }
-
- my ($query,$i);
- my (@k);
- my (@v);
- my (@c);
- my (@rows_set);
- my (@email_rows);
-
- my $safe;
- my $blob_field;
- my $blob_nick;
- my $blob_ptr;
-
- # Fields to set in database despite mv_blob_only
- my %blob_exception;
-
- if($CGI::values{mv_blob_field} and $CGI::values{mv_blob_nick}) {
-#::logDebug("update_data: blob processing enabled");
- $blob_field =3D $CGI::values{mv_blob_field};
- $blob_nick =3D $CGI::values{mv_blob_nick};
- $blob_ptr =3D $CGI::values{mv_blob_pointer};
-
- %blob_exception =3D
- map { ($_, 1) } split /[\s,\0]+/, $CGI::values{mv_blob_exception};
-
- if( ! $base_db->column_exists($blob_field) ) {
- undef $blob_field;
- undef $blob_nick;
- logError("No blob field '%s' found for table=3D'%s', skipping blob save=
",
- $CGI::values{mv_blob_field}, $CGI::values{mv_data_table},
- );
- }
- elsif ($MVSAFE::Safe) {
- $safe =3D $Vend::Interpolate::ready_safe;
- }
- else {
- $safe =3D new Safe;
- }
- $base_db->column_exists($blob_ptr)
- or undef $blob_ptr;
-#::logDebug("update_data: blob safe object=3D$safe");
- }
-
- my @multis;
- if($CGI::values{mv_data_multiple}) {
- my $re =3D qr/^\d+_$prikey$/;
- @multis =3D grep $_ =3D~ $re, @cgi_keys;
- for(@multis) {
- s/_.*//;
- }
- @multis =3D sort { $a <=3D> $b } @multis;
- }
-
-#::logDebug("update_data:db=3D$db key=3D$prikey VALUES=3D" . ::uneval(\%CG=
I::values));
-#::logDebug("update_data:db=3D$db key=3D$prikey data=3D" . ::uneval(\%data=
));
- my $select_key;
- SETDATA: {
- for($i =3D 0; $i < @{$data{$prikey}}; $i++) {
-#::logDebug("iteration of update_data:db=3D$db key=3D$prikey data=3D" . ::=
uneval(\%data));
- @k =3D (); @v =3D ();
- for(keys %data) {
-#::logDebug("iteration of field $_");
-
- next unless (length($value =3D $data{$_}->[$i]) || $CGI::values{mv_upda=
te_empty} );
- push(@k, $_);
-# LEGACY
- HTML::Entities::decode($value) if $decode;
-# END LEGACY
- if($CGI::values{"mv_data_filter_$_"}) {
- $value =3D Vend::Interpolate::filter_value(
- $CGI::values{"mv_data_filter_$_"},
- $value,
- $i,
- );
- }
- $select_key =3D $value if $_ eq $prikey;
- push(@v, $value);
- }
-
- if(! length($select_key) ) {
- next if defined $CGI::values{mv_update_empty_key}
- and ! $CGI::values{mv_update_empty_key};
- }
-
- if($function eq 'delete') {
- $base_db->delete_record($select_key);
- }
- else {
- my $field;
- $key =3D $data{$prikey}->[$i];
- if(! length($key) and $autonumber) {
- ## KEY IS possibly SET HERE=20
- $key =3D $base_db->set_row($key);
- }
- push(@rows_set, $key);
-
- # allow form submissions to go to database and to mail
- if ($CGI::values{mv_data_email}) {
- push( @email_rows,
- [ ::errmsg("### Form Submission from %s", $key), $blob_nick, ],
- [ $prikey, $key, ],
- );
- }
-
- my $qd =3D {};
- my $qf =3D {};
- my $qv =3D {};
- my $qret;
-
- my $blob;
- my $brec;
- if($blob_field) {
- my $string =3D $base_db->field($key, $blob_field);
-#::logDebug("update_data: blob string=3D$string");
- $blob =3D $safe->reval($string);
-#::logDebug("update_data: blob object=3D$blob");
- $blob =3D {} unless ref($blob) eq 'HASH';
- $brec =3D $blob;
- my @keys =3D split /::/, $blob_nick;
- for(@keys) {
- unless ( ref($brec->{$_}) eq 'HASH') {
- $brec->{$_} =3D {};
- }
- $brec =3D $brec->{$_};
- }
- }
- while($field =3D shift @k) {
- $value =3D shift @v;
- next if $field eq $prikey;
-=09=09=09=09
- ## DATA IS SET HERE
- # We are going to set the field unless it is only for
- # storing in a blob (and possibly emailing)
- my ($d, $f);
- if ($CGI::values{mv_blob_only} and ! $blob_exception{$field}) {
-#::logDebug("$field not storing, only blob");
- $f =3D $field;
- }
- else {
-#::logDebug("storing d=3D$d $field blob_only=3D$CGI::values{mv_blob_only}"=
);
- ($d, $f) =3D set_db($base_db, $field);
-#::logDebug("storing table=3D$table d=3D$d f=3D$f key=3D$key");
- if(! defined $qd->{$d}) {
- $qd->{$d} =3D $d;
- $qf->{$d} =3D [$f];
- $qv->{$d} =3D [$value];
- }
- else {
- push @{$qf->{$d}}, $f;
- push @{$qv->{$d}}, $value;
- }
- #$d->set_field($key, $f, $value);
- }
-
- push(@email_rows, [$f, $value])
- if $CGI::values{mv_data_email};
-#::logDebug("update_data:db=3D$d key=3D$key field=3D$f value=3D$value");
- $brec->{$f} =3D $value if $brec;
- }
-
- for(keys %$qd) {
- $qret =3D $qd->{$_}->set_slice($key, $qf->{$_}, $qv->{$_});
- $rows_set[$i] =3D $qret unless $rows_set[$i];
- }
- if($blob) {
- $brec->{mv_data_fields} =3D join " ", @fields;
- my $string =3D ::uneval_it($blob);
-#::logDebug("update_data: blob saving string=3D$string");
- $base_db->set_field($key, $blob_field, $string);
- if($blob_ptr) {
- $base_db->set_field($key, $blob_ptr, $blob_nick);
- }
- }
- push(
- @email_rows,
- [ ::errmsg("### END FORM SUBMISSION %s", $key), $blob_nick, ]
- )
- if $CGI::values{mv_data_email};
- }
- }
- if(my $new =3D shift(@multis)) {
-#::logDebug("Doing multi for $new");
- last SETDATA unless length $CGI::values{"${new}_$prikey"};
- for(@fields) {
- my $value =3D $CGI::values{$_} =3D $CGI::values{"${new}_$_"};
- $data{$_} =3D [ $value ];
- }
- redo SETDATA;
- }
- } # end SETDATA
-
- if($CGI::values{mv_data_return_key}) {
- my @keys =3D split /\0/, $CGI::values{mv_data_return_key};
- for(@keys) {
-#::logDebug("return_key, setting $_");
- $CGI::values{$_} =3D join("\0", @rows_set);
- }
- }
-
- if($CGI::values{mv_auto_export}) {
- Vend::Data::export_database($table);
- }
-
- if($CGI::values{mv_data_email}) {
- push @email_rows, [ 'mv_data_fields', \@fields ];
- Vend::Interpolate::tag_mail('', { log_error =3D> 1 }, \@email_rows);
- }
-
- # Allow setting in one then returning to another
- if($CGI::values{mv_return_table}) {
- $CGI::values{mv_data_table} =3D $CGI::values{mv_return_table};
- }
-
- my @reloads =3D grep /^mv_data_table__\d+$/, keys %CGI::values;
- if(@reloads) {
- @reloads =3D map { m/.*__(\d+)$/; $1 } @reloads;
- @reloads =3D sort { $a <=3D> $b } @reloads;
- my $new =3D shift @reloads;
- my $this =3D qr{__$new$};
- my $some =3D qr{__\d+$};
-#::logDebug("Reloading, new=3D$new this=3D$this some=3D$some");
- my %cgiset;
- my @death_row;
- for(@cgi_keys) {
- push(@death_row, $_), next unless $_ =3D~ $some;
- if($_ =3D~ $this) {
- my $k =3D $_;
- $k =3D~ s/$this//;
- $cgiset{$k} =3D delete $CGI::values{$_};
- }
- }
-
- $::Scratch->{mv_data_enable} =3D delete $::Scratch->{"mv_data_enable__$n=
ew"};
- delete $::Scratch->{mv_data_enable_key};
-
- for(@death_row) {
- next unless /^mv_(data|blob|update)_/ or $data{$_}; # Reprieve!
- delete $CGI::values{$_};
- }
-
- @CGI::values{keys %cgiset} =3D values %cgiset;
- update_data();
- }
-
- return;
-}
-
-# Parse the mv_click and mv_check special variables
-sub parse_click {
- my ($ref, $click, $extra) =3D @_;
- my($codere) =3D '[-\w_#/.]+';
- my $params;
-
-#::logDebug("Looking for click $click");
- if($params =3D $::Scratch->{$click}) {
- # Do nothing, we found the click
-#::logDebug("Found scratch click $click =3D |$params|");
- }
- elsif(defined ($params =3D $Vend::Cfg->{OrderProfileName}{$click}) ) {
- # Do nothing, we found the click
- $params =3D $Vend::Cfg->{OrderProfile}[$params];
-#::logDebug("Found profile click $click =3D |$params|");
- }
- elsif(defined ($params =3D $Global::ProfilesName->{$click}) ) {
- # Do nothing, we found the click
- $params =3D $Global::Profiles->[$params];
-#::logDebug("Found profile click $click =3D |$params|");
- }
- elsif($params =3D $::Scratch->{"mv_click $click"}) {
- $::Scratch->{mv_click_arg} =3D $click;
- }
- elsif($params =3D $::Scratch->{mv_click}) {
- $::Scratch->{mv_click_arg} =3D $click;
- }
- else {
-#::logDebug("Found NO click $click");
- return 1;
- } # No click processor
-
- my($var,$val,$parameter);
- $params =3D interpolate_html($params);
- my(@param) =3D split /\n+/, $params;
-
- for(@param) {
- next unless /\S/;
- next if /^\s*#/;
- s/^[\r\s]+//;
- s/[\r\s]+$//;
- $parameter =3D $_;
- ($var,$val) =3D split /[\s=3D]+/, $parameter, 2;
- $val =3D~ s/&#(\d+);/chr($1)/ge;
- $ref->{$var} =3D $val;
- $extra->{$var} =3D $val
- if defined $extra;
- }
-}
-
-# This is the set of CGI-passed variables to ignore, in other words
-# never set in the user session. If set in the mv_check pass, though,
-# they will stick.
-%Global::Ignore =3D qw(
- mv_todo 1
- mv_todo.submit.x 1
- mv_todo.submit.y 1
- mv_todo.return.x 1
- mv_todo.return.y 1
- mv_todo.checkout.x 1
- mv_todo.checkout.y 1
- mv_todo.todo.x 1
- mv_todo.todo.y 1
- mv_todo.map 1
- mv_doit 1
- mv_check 1
- mv_click 1
- mv_nextpage 1
- mv_failpage 1
- mv_successpage 1
- mv_more_ip 1
- mv_credit_card_number 1
- mv_credit_card_cvv2 1
- );
-
-sub update_values {
-
- my (@keys) =3D @_;
-
- my $set;
- if(@keys) {
- $set =3D {};
- @{$set}{@keys} =3D @CGI::values{@keys};
- }
- else {
- $set =3D \%CGI::values;
-
- if( $Vend::Cfg->{CreditCardAuto} and $CGI::values{mv_credit_card_number}=
) {
- (
- @{$::Values}{
- qw/
- mv_credit_card_valid
- mv_credit_card_info
- mv_credit_card_exp_month
- mv_credit_card_exp_year
- mv_credit_card_exp_all
- mv_credit_card_type
- mv_credit_card_reference
- mv_credit_card_error
- / }
- ) =3D encrypt_standard_cc(\%CGI::values);
- }=09
- }
-
- my $restrict;
- if($restrict =3D $Vend::Session->{restrict_html} and ! ref $restrict) {
- $restrict =3D [ map { lc $_ } split /\s+/, $restrict ];
- $Vend::Session->{restrict_html} =3D $restrict;
- }
-
- while (my ($key, $value) =3D each %$set) {
- # values explicly ignored in configuration
- next if defined $Global::Ignore{$key};
- next if defined $Vend::Cfg->{FormIgnore}{$key};
-
-#LEGACY
- # We add any checkbox ordered items, but don't update --=20
- # we don't want to order them twice
- next if ($key =3D~ m/^quantity\d+$/);
-#END LEGACY
-
- # Admins should know what they are doing
- if($Vend::admin) {
- $::Values->{$key} =3D $value;
- next;
- }
- elsif ($restrict and $value =3D~ /</) {
- # Allow designer to allow only certain HTML tags from trusted users
- # Will go away when current session ends...
- # [ script start character handled in [value ...] ITL tag
- $value =3D Vend::Interpolate::filter_value(
- 'restrict_html',
- $value,
- undef,
- @$restrict,
- );
- $::Values->{$key} =3D $value;
- next;
- }
- $value =3D~ tr/<[//d;
- $value =3D~ s/<//ig;
- $value =3D~ s/[//g;
- $::Values->{$key} =3D $value;
- }
-}
-
-sub update_user {
- my($key,$value);
- # Update the user-entered fields.
-
- add_items() if defined $CGI::values{mv_order_item};
- update_values();
-
- if($CGI::values{mv_check}) {
- my(@checks) =3D split /\s*[,\0]+\s*/, delete $CGI::values{mv_check};
- my($check);
- foreach $check (@checks) {
- parse_click $::Values, $check, \%CGI::values;=09
- }
- }
-
- check_save if defined $CGI::values{mv_save_session};
-
-}
-
-## DO PROCESS
-
-sub do_click {
- my($click, @clicks);
- do {
- if($CGI::values{mv_click}) {
- @clicks =3D split /\s*[\0]+\s*/, delete $CGI::values{mv_click};
- }
-
- if(defined $CGI::values{mv_click_map}) {
- my(@map) =3D split /\s*[\0]+\s*/, delete $CGI::values{mv_click_map};
- foreach $click (@map) {
- push (@clicks, $click)
- if defined $CGI::values{"mv_click.$click.x"}
- or defined $CGI::values{"$click.x"}
- or $click =3D $CGI::values{"mv_click_$click"};
- }
- }
-
- foreach $click (@clicks) {
- parse_click \%CGI::values, $click;
- }
- } while $CGI::values{mv_click};
- return 1;
-}
-
-sub do_deliver {
- my $file =3D $CGI::values{mv_data_file};
- my $mode =3D $CGI::values{mv_acl_mode} || '';
- if($::Scratch->{mv_deliver} !~ m{(^|\s)$file(\s|$)}
- and=20
- ! Vend::UserDB::userdb(
- 'check_file_acl',
- location =3D> $file,
- mode =3D> $mode,
- )
- )
- {
- $Vend::StatusLine =3D "Status: 403\nContent-Type: text/html";
- my $msg =3D get_locale_message(403, <<EOF);
-<B>Authorization Required<B>
-<P>
-This server could not verify that you are authorized to access the document
-requested.=20
-EOF
- ::response($msg);
- return 0;
- }
-
- if (! -f $file) {
- $Vend::StatusLine =3D "Status: 404\nContent-Type: text/html";
- my $msg =3D get_locale_message(404, <<EOF, $file);
-<B>Not Found<B>
-<P>
-The requested file %s was not found on this server.
-
-EOF
- ::response($msg);
- return 0;
- }
-
- $Vend::StatusLine =3D "Content-Type: " .
- ($CGI::values{mv_content_type} || 'application/octet-stream');
- ::response( Vend::Util::readfile (
- $CGI::values{mv_data_file},
- $Global::NoAbsolute,
- )
- );
- return 0;
-}
-
-my %form_action =3D (
-
- search =3D> \&do_search,
- deliver =3D> \&do_deliver,
- submit =3D>
- sub {
- update_user();
- update_quantity()
- or return interaction_error("quantities");
- my $ok;
- my($missing,$next,$status,$final,$result_hash);
-
- # Set shopping cart if necessary
- # Vend::Items is tied, remember!
- $Vend::Items =3D $CGI::values{mv_cartname}
- if $CGI::values{mv_cartname};
-
-#::logDebug("Default order route=3D$::Values->{mv_order_route}");
- ## Determine the master order route, if routes
- ## are not set in CGI values (4.7.x default)
- if(
- $Vend::Cfg->{Route}
- and ! defined $::Values->{mv_order_route}
- )
- {
- my $curr =3D $Vend::Cfg->{Route};
- my $repos =3D $Vend::Cfg->{Route_repository};
-
- if($curr->{master}) {
- # Default route is master
-
- for(keys %$repos) {
- next unless $curr eq $repos->{$_};
- $::Values->{mv_order_route} =3D $_;
- last;
- }
- }
- else {
- for(keys %$repos) {
- next unless $repos->{$_}->{master};
- $::Values->{mv_order_route} =3D $_;
- last;
- }
- }
- }
-
-#::logDebug("Default order route=3D$::Values->{mv_order_route}");
-
- CHECK_ORDER: {
-
- # If the user sets this later, will be used
- delete $Vend::Session->{mv_order_number};
-
- if (defined $CGI::values{mv_order_profile}) {
- ($status,$final,$missing) =3D
- check_order($CGI::values{mv_order_profile});
- }
- else {
- $status =3D $final =3D 1;
- }
-#::logDebug("Profile status status=3D$status final=3D$final errors=3D$miss=
ing");
-
- my $provisional;
- if ($status and defined $::Values->{mv_order_route}) {
- # This checks only route order profiles
-#::logDebug("Routing order, pre-check");
- ($status, $provisional, $missing)
- =3D route_order(
- $::Values->{mv_order_route},
- $Vend::Items,
- 'check',
- );
- }=20
-
- $final =3D $provisional if ! $final;
-
-#::logDebug("Routing status status=3D$status final=3D$final errors=3D$miss=
ing");
- if($status) {
- $CGI::values{mv_nextpage} =3D $CGI::values{mv_successpage}=20
- if $CGI::values{mv_successpage};
- $CGI::values{mv_nextpage} =3D $::Values->{mv_orderpage}=20
- if ! $CGI::values{mv_nextpage};
- }
- else {
- $CGI::values{mv_nextpage} =3D $CGI::values{mv_failpage}
- if $CGI::values{mv_failpage};
- $CGI::values{mv_nextpage} =3D find_special_page('needfield')
- if ! $CGI::values{mv_nextpage};
- undef $final;
- }
-
- return 1 unless $final;
-
- my $order_no;
- if (defined $::Values->{mv_order_route}) {
- # $ok will not be defined unless Route "supplant" was set
- # $order_no will come back so we don't issue two of them
-#::logDebug("Routing order $::Values->{mv_order_route}");
- ($ok, $order_no, $result_hash) =3D route_order(
- $::Values->{mv_order_route},
- $Vend::Items
- );
- return 1 unless $ok;
- }
-
- $result_hash =3D {} unless $result_hash;
-
-# TRACK
- $Vend::Track->finish_order ();
-# END TRACK
- # This function (followed down) now does the rudimentary
- # backend ordering with AsciiTrack and the order report.
- # If the "supplant" option was set in order routing it will
- # not be used ($ok would have been defined)
-
-
-#::logDebug("Order number=3D$order_no\n");
- $ok =3D mail_order(undef, $order_no || undef) unless defined $ok;
-#::logDebug("Order number=3D$order_no, result_hash=3D" . ::uneval($result_=
hash));
-
- # Display a receipt if configured
-
- my $not_displayed =3D 1;
-
- if(! $ok) {
- display_special_page(
- find_special_page('failed'),
- errmsg('Error transmitting order(%s): %s', $!, $@),
- );
- }
- elsif (! $result_hash->{no_receipt} ) {
- eval {
-
- my $receipt =3D $result_hash->{receipt}
- || $::Values->{mv_order_receipt}
- || find_special_page('receipt');
-#::logDebug("selected receipt=3D$receipt");
- display_special_page($receipt);
- };
- $not_displayed =3D 0;
-#::logDebug("not_displayed=3D$not_displayed");
- if($@) {
- my $msg =3D $@;
- ::logError(=20
- 'Display of receipt on order number %s failed: %s',
- $::Values->{mv_order_number},
- $msg,
- );
- }
- }
-
- # Remove the items
- @$Vend::Items =3D ();
-#::logDebug("returning order_number=3D$order_no, not_displayed=3D$not_disp=
layed");
- return $not_displayed;
- }
- },
- refresh =3D> sub {
- update_quantity()
- or return interaction_error("quantities");
-# LEGACY
- $CGI::values{mv_nextpage} =3D $CGI::values{mv_orderpage}
- if $CGI::values{mv_orderpage};
-# END LEGACY
- $CGI::values{mv_nextpage} =3D $CGI::values{mv_orderpage}
- || find_special_page('order')
- if ! $CGI::values{mv_nextpage};
- update_user();
- return 1;
- },
- set =3D> sub {
- update_user() unless $CGI::values{mv_data_auto_number};
- update_data();
- update_user() if $CGI::values{mv_data_auto_number};
- return 1;
- },
- autoset =3D> sub {
- update_data();
- update_user();
- return 1;
- },
- back =3D> sub { return 1 },
- return =3D> sub {
- update_user();
- update_quantity()
- or return interaction_error("quantities");
- return 1;
- },
- cancel =3D> sub {
- put_session();
- get_session();
- init_session();
- $CGI::values{mv_nextpage} =3D find_special_page('canceled')
- if ! $CGI::values{mv_nextpage};
- return 1;
- },
-);
-
-$form_action{go} =3D $form_action{return};
-
-# Process the completed order or search page.
-
-sub do_process {
-
- if($CGI::values{mv_form_profile}) {
-#::logDebug("checking form profile $CGI::values{mv_form_profile} =3D $::Sc=
ratch->{$CGI::values{mv_form_profile}}");
- my ($status) =3D check_order($CGI::values{mv_form_profile}, \%CGI::value=
s);
-#::logDebug("checked form profile=3D" . (defined $status ? $status : 'unde=
f') );
- return 1 if defined $status and ! $status;
- }
-
-#::logDebug("todo=3D$CGI::values{mv_todo} prior to mv_click=3D" . join ","=
, split /\0/, $CGI::values{mv_click});
-
- my $orig_todo =3D $CGI::values{mv_todo};
-
- do_click();
-
- my $todo =3D $CGI::values{mv_todo};
-
-#::logDebug("todo=3D$todo after mv_click");
-
- # Maybe we have an imagemap input, if not, use $doit
- if($orig_todo ne $todo) {
- # Don't mess with it, changed in click
- }
- elsif (defined $CGI::values{'mv_todo.x'}) {
- my $x =3D $CGI::values{'mv_todo.x'};
- my $y =3D $CGI::values{'mv_todo.y'};
- my $map =3D $CGI::values{'mv_todo.map'};
- # Called with action_map and not package id
- # since "autouse" is possibly in force...found
- # by Jeff Carnahan
- $todo =3D action_map($x,$y,$map);
- }
- elsif( my @todo =3D grep /^mv_todo\.\w+(?:\.x)?$/, keys %CGI::values ) {
- # Only one todo!
- for(@todo) {
- delete $CGI::values{$_};
- s/^mv_todo\.(\w+)(?:\.[xy])?$/$1/;
- }
- $todo =3D shift @todo;
- }
-
- $todo =3D $CGI::values{mv_doit} || 'back' if ! $todo;
-
-#::logDebug("todo=3D$todo after mv_click");
-
- my ($sub, $status);
- #Now determine the action on the todo
- if (defined $Vend::Cfg->{FormAction}{$todo}) {
- $sub =3D $Vend::Cfg->{FormAction}{$todo};
- }
- elsif (not $sub =3D $form_action{$todo} ) {
- interaction_error("No action passed for processing\n");
- return;
- }
- eval {
- $status =3D $sub->($todo);
- };
- if($@) {
- undef $status;
- my $err =3D $@;
- my $template =3D <<EOF;
-Sorry, there was an error in processing this form action. Please=20
-report the error or try again later.
-EOF
- $template .=3D "\n\nError: %s\n"
- if $Global::DisplayErrors && $Vend::Cfg->{DisplayErrors}
- ;
- $template =3D get_locale_message(500, $template, $err);
- $template .=3D "($err)";
- ::logError($err);
- ::response($template);
- }
-
- return $status;
-}
-
-sub run_in_catalog {
- my ($cat, $job, $itl) =3D @_;
- my ($g,$c);
-
-#::logGlobal("running job in cat=3D$cat");
- $g =3D $Global::Catalog{$cat};
- unless (defined $g) {
- logGlobal( "Can't find catalog '%s'" , $cat );
- return undef;
- }
-
- #$Vend::Log_suppress =3D 1;
-
- unless ($Vend::Quiet) {
- logGlobal("Run catalog '%s' cron group=3D%s", $cat, $job || 'INTERNAL');
- }
- #undef $Vend::Log_suppress;
-
- open_cat($cat);
-
- logError("Run cron group=3D%s", $job || 'INTERNAL');
-
- my $croncfg =3D $Vend::Cfg->{Cron};
-
- my $dir;
- my @itl;
- if($job) {
- my $ct =3D $croncfg->{base_directory} || 'etc/cron';
- my $gt =3D '';
- $gt =3D "$Global::ConfDir/$ct" if $croncfg->{use_global};
-
- for my $d ($ct, $gt) {
-#::logGlobal("check directory=3D$d for $job");
- next unless $d;
- next unless -d "$d/$job";
- $dir =3D "$d/$job";
- last;
- }
- if($dir) {
- my @f =3D glob("$dir/*");
- @f =3D grep ! -d $_, @f;
- @f =3D grep $_ !~ /$Vend::Cfg->{HTMLsuffix}$/, @f;
- for(@f) {
-#::logGlobal("found cron piece file=3D$_");
- push @itl, [$_, readfile($_)];
- }
- }
- }
-
- if ($itl) {
- push @itl, ["Passed ITL", $itl];
- }
-
- my @out;
-
- if(@itl) {
- # Run once at beginning
- run_macro($croncfg->{initialize});
-
- # initialize or autoload can create session
- # but must handle all aspects
- init_session() unless $Vend::Session;
-
- $CGI::remote_addr ||=3D 'none';
- $CGI::useragent ||=3D 'commandline';
-
- for(@itl) {
- # Run once at beginning of each job
- run_macro($croncfg->{autoload});
-
- push @out, interpolate_html($_->[1]);
- }
- }
- else {
- logGlobal("Empty cron job=3D%s", $job);
- }
- my $out =3D join "", @out;
- $out =3D~ s/^\s+//;
- $out =3D~ s/\s+$/\n/;
- $out .=3D full_dump() if $croncfg->{add_session};
-=09
- close_cat();
-
- # don't send email and/or write log entry if cron job returns
- # no output (in spirit of the real cron)
- return unless $out;
-=09
- if(my $addr =3D $Vend::CronEmail || $croncfg->{email}) {
- my $subject =3D $croncfg->{subject} || 'Interchange cron results for job=
: %s';
- $subject =3D errmsg($subject, $job);
- my $from =3D $croncfg->{from} || $Vend::Cfg->{MailOrderTo};
- Vend::Interpolate::tag_mail($addr,
- {
- from =3D> $from,
- to =3D> $addr,
- subject =3D> $subject,
- reply_to =3D> $croncfg->{reply_to},
- mailer =3D> "Interchange $::VERSION",
- extra =3D> $croncfg->{extra_headers},
- log_error =3D> 1,
- },
- $out,
- );
- }
-
- if($croncfg->{log}) {
- logData($croncfg->{log}, $out);
- }
-
- return $out;
-}
-
-sub config_named_catalog {
- my ($cat_name, $source, $db_only, $dbconfig) =3D @_;
- my ($g,$c);
-
- $g =3D $Global::Catalog{$cat_name};
- unless (defined $g) {
- logGlobal( "Can't find catalog '%s'" , $cat_name );
- return undef;
- }
-
- $Vend::Log_suppress =3D 1;
-
- unless ($db_only or $Vend::Quiet) {
- logGlobal( "Config '%s' %s%s", $g->{'name'}, $source );
- }
- undef $Vend::Log_suppress;
-
- chdir $g->{'dir'}
- or die "Couldn't change to $g->{'dir'}: $!\n";
-
- if($db_only) {
- logGlobal(
- "Config table '%s' (file %s) for catalog %s from %s",
- $db_only,
- $dbconfig,
- $g->{'name'},
- $source,
- );
- my $cfg =3D $Global::Selector{$g->{script}}
- or die errmsg("'%s' not a catalog (%s).", $g->{name}, $g->{script});
- undef $cfg->{Database}{$db_only};
- $Vend::Cfg =3D config(
- $g->{name},
- $g->{dir},
- undef,
- undef,
- $cfg,
- $dbconfig,
- )
- or die errmsg("error configuring catalog %s table %s: %s",
- $g->{name},
- $db_only,
- $@,
- );
- open_database();
- close_database();
- return $Vend::Cfg;
- }
-
- eval {
- $c =3D config($g->{'name'},
- $g->{'dir'},
- undef,
- $g->{'base'} || undef,
-# OPTION_EXTENSION
-# $Vend::CommandLine->{$g->{'name'}} || undef
-# END OPTION_EXTENSION
- );
- };
-
- if($@) {
- my $msg =3D $@;
- logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
- return undef;
- }
-
- if (defined $g->{base}) {
- open_database(1);
- dump_structure($c, $g->{name}) if $Global::DumpStructure;
- return $c;
- }
-
- eval {
- $Vend::Cfg =3D $c;=09
- $::Variable =3D $Vend::Cfg->{Variable};
- $::Pragma =3D $Vend::Cfg->{Pragma};
- Vend::Data::read_salestax();
- Vend::Data::read_shipping();
- open_database(1);
- my $db;
-
- LREAD: {
- last LREAD unless $db =3D $Vend::Cfg->{LocaleDatabase};
- $db =3D database_exists_ref($db)
- or last LREAD;
- $db =3D $db->ref();
- my ($k, @f); # key and fields
- my @l; # refs to locale repository
- my @n; # names of locales
-
- @n =3D $db->columns();
- my $extra;
- for(@n) {
- $Vend::Cfg->{Locale_repository}{$_} =3D {}
- unless $Vend::Cfg->{Locale_repository}{$_};
- push @l, $Vend::Cfg->{Locale_repository}{$_};
- }
- my $i;
- while( ($k , @f ) =3D $db->each_record) {
- for ($i =3D 0; $i < @f; $i++) {
- next unless length($f[$i]);
- $l[$i]->{$k} =3D $f[$i];
- }
- }
- unless ($Vend::Cfg->{Locale}) {
- for(@n) {
- next unless $Vend::Cfg->{Locale_repository}{$_}{'default'};
- $Vend::Cfg->{DefaultLocale} =3D $_;
- $Vend::Cfg->{Locale} =3D $Vend::Cfg->{Locale_repository}{$_};
- last;
- }
- unless ($Vend::Cfg->{Locale}) {
- $Vend::Cfg->{Locale} =3D $Vend::Cfg->{Locale_repository}{$n[0]};
- $Vend::Cfg->{DefaultLocale} =3D $n[0];
- }
- }
- }
-
- close_database();
- };
-
- undef $Vend::Cfg;
- if($@) {
- my $msg =3D $@;
- $msg =3D~ s/\s+$//;
- logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
- return undef;
- }
-
- dump_structure($c, $g->{name}) if $Global::DumpStructure;
-
- my $stime =3D scalar localtime();
- Vend::Util::writefile(">$Global::RunDir/status.$g->{name}", "$stime\n");
- Vend::Util::writefile(">$c->{ConfDir}/status.$g->{name}", "$stime\n");
-
- return $c;
-
-}
-
-sub is_retired {
- my $id =3D shift;
- mkdir "$Vend::Cfg->{ScratchDir}/retired", 0777
- unless -d "$Vend::Cfg->{ScratchDir}/retired";
- my $fn =3D Vend::Util::get_filename($id, 2, 1, "$Vend::Cfg->{ScratchDir}/=
retired");
- return -f $fn ? 1 : 0;
-}
-
-sub retire_id {
- my $id =3D shift;
- return unless $id =3D~ /^\w+$/;
- mkdir "$Vend::Cfg->{ScratchDir}/retired", 0777
- unless -d "$Vend::Cfg->{ScratchDir}/retired";
- my $fn =3D Vend::Util::get_filename($id, 2, 1, "$Vend::Cfg->{ScratchDir}/=
retired");
- open(TMPRET, ">$fn")
- or die "retire id open: $!\n";
- close(TMPRET);
- return;
-}
-
-sub tie_static_dbm {
- my $rw =3D shift;
- untie(%Vend::StaticDBM) if $rw;
- if($Global::GDBM) {
- my $flags =3D $rw ? &GDBM_WRITER : &GDBM_READER;
- $flags =3D &GDBM_NEWDB
- if $rw && (! -f "$Vend::Cfg->{StaticDBM}.gdbm");
- tie(%Vend::StaticDBM,
- 'GDBM_File',
- "$Vend::Cfg->{StaticDBM}.gdbm",
- $flags,
- $Vend::Cfg->{'FileCreationMask'},
- )
- or $Vend::Cfg->{SaveStaticDBM} =3D delete $Vend::Cfg->{StaticDBM};
- }
- elsif ($Global::DB_File) {
- tie(%Vend::StaticDBM,
- 'DB_File',
- "$Vend::Cfg->{StaticDBM}.db",
- ($rw ? &O_RDWR | &O_CREAT : &O_RDONLY),
- $Vend::Cfg->{'FileCreationMask'},
- )
- or undef $Vend::Cfg->{StaticDBM};
- }
- else {
- $Vend::Cfg->{SaveStaticDBM} =3D delete $Vend::Cfg->{StaticDBM};
- }
- ::logError("Failed to create StaticDBM %s", $Vend::Cfg->{StaticDBM})
- if $rw && ! $Vend::Cfg->{StaticDBM};
- return $Vend::Cfg->{StaticDBM} || undef;
-}
-
-
-sub adjust_cgi {
-
- my($host);
-
- die "REQUEST_METHOD is not defined" unless defined $CGI::request_method
- or @Global::argv;
-
- # The great and really final AOL fix
- #
- $host =3D $CGI::remote_host;
- $CGI::ip =3D $CGI::remote_addr;
-
- if($Global::DomainTail and $host) {
- $host =3D~ s/.*?([-A-Za-z0-9]+\.[A-Za-z]+)$/$1/;
- }
- elsif($Global::IpHead) {
- $host =3D $Global::IpQuad =3D=3D 0 ? 'nobody' : '';
- my @ip;
- @ip =3D split /\./, $CGI::ip;
- $CGI::ip =3D '';
- $CGI::ip =3D join ".", @ip[0 .. ($Global::IpQuad - 1)] if $Global::IpQua=
d;
- }
- #
- # end AOL fix
-
- # Fix Cobalt/CGIwrap problem
- if($Global::Variable->{CGIWRAP_WORKAROUND}) {
- $CGI::path_info =3D~ s!^$CGI::script_name!!;
- }
-
- $CGI::host =3D $host || $CGI::ip;
-
- $CGI::user =3D $CGI::remote_user if $CGI::remote_user;
- undef $CGI::authorization if $CGI::remote_user;
-
- unless ($Global::FullUrl) {
- $CGI::script_name =3D $CGI::script_path;
- }
- else {
- if($CGI::server_port eq '80') { $CGI::server_port =3D ''; }
- else { $CGI::server_port =3D ":$CGI::server_port"; }
- $CGI::script_name =3D $CGI::server_name .
- $CGI::server_port .
- $CGI::script_path;
- }
-}
-
-sub url_history {
- $Vend::Session->{History} =3D []
- unless defined $Vend::Session->{History};
- shift @{$Vend::Session->{History}}
- if $#{$Vend::Session->{History}} >=3D $Vend::Cfg->{History};
- if(
- ($CGI::pragma =3D~ /\bno-cache\b/ and ! $CGI::values{mv_force_cache})
- or $CGI::values{mv_no_cache}
- )
- {
- push (@{$Vend::Session->{History}}, [ 'expired', {} ]);
- }
- else {
- my $save_number =3D delete $CGI::values{mv_credit_card_number};
- my $save_cvv2 =3D delete $CGI::values{mv_credit_card_cvv2};
- push (@{$Vend::Session->{History}}, [ $CGI::path_info, \%CGI::values ]);
- $CGI::values{mv_credit_card_number} =3D $save_number if length($save_num=
ber);
- $CGI::values{mv_credit_card_cvv2} =3D $save_cvv2 if length($save_cvv=
2);
- }
- return;
-}
-
-## DISPATCH
-
-# Parse the invoking URL and dispatch to the handling subroutine.
-
-my %action =3D (
- process =3D> \&do_process,
- ui =3D> sub {=20
- &UI::Primitive::ui_acl_global();
- &do_process(@_);
- },
- scan =3D> \&do_scan,
- search =3D> \&do_search,
- order =3D> \&do_order,
- obtain =3D> \&do_order,
- silent =3D> sub {
- $Vend::StatusLine =3D "Status: 204 No content";
- my $extra_click =3D $Vend::FinalPath;
- $extra_click =3D~ s:/:\0:g;
- $CGI::values{mv_click} =3D $CGI::values{mv_click}
- ? "$CGI::values{mv_click}\0$extra_click"
- : $extra_click;
- do_process(@_);
- ::respond('');
- return 0;
- },
-);
-
-sub open_cat {
- my $cat =3D shift;
-
- if($cat) {
- %CGI::values =3D ();
- if($Global::Catalog{$cat}) {
- $CGI::script_path =3D $Global::Catalog{$cat}->{script};
- $CGI::script_name =3D $CGI::script_path;
- }
- }
-
- unless (defined $Global::Selector{$CGI::script_name}) {
- my $msg =3D get_locale_message(
- 404,
- "Undefined catalog: %s",
- $CGI::script_name || $cat,
- );
- $Vend::StatusLine =3D <<EOF;
-Status: 404 Not Found
-Content-Type: text/plain
-EOF
- if($H) {
- ::response($msg);
- }
- logGlobal($msg);
- # No close_cat() necessary
- return;
- }
-
- if($Global::Foreground) {
- my %hash;
- tie %hash, 'Tie::ShadowHash', $Global::Selector{$CGI::script_name} ;
- $Vend::Cfg =3D \%hash;
- }
- else {
- $Vend::Cfg =3D $Global::Selector{$CGI::script_name};
- }
-
- $Vend::Cat =3D $Vend::Cfg->{CatalogName};
- my $catref =3D $Global::Catalog{$Vend::Cat};
- if(! $Global::Foreground and defined $catref->{directive}) {
- no strict 'refs';
- my ($key, $val);
- while ( ($key, $val) =3D each %{$catref->{directive}}) {
-#::logDebug("directive key=3D$key val=3D" . ::uneval($val));
- ${"Global::$key"} =3D $val;
- }
- }
-
- # See if it is a subcatalog
- if (defined $Vend::Cfg->{BaseCatalog}) {
- my $name =3D $Vend::Cfg->{BaseCatalog};
- my $ref =3D $Global::Catalog{$name};
- my $c =3D $Vend::Cfg;
- $Vend::Cfg =3D $Global::Selector{$ref->{'script'}};
- for(keys %{$c->{Replace}}) {
- undef $Vend::Cfg->{$_};
- }
- copyref $c, $Vend::Cfg;
- if($Vend::Cfg->{Variable}{MV_LANG}) {
- my $loc =3D $Vend::Cfg->{Variable}{MV_LANG};
- $Vend::Cfg->{Locale} =3D $Vend::Cfg->{Locale_repository}{$loc}
- if defined $Vend::Cfg->{Locale_repository}{$loc};
- }
- $Vend::Cfg->{StaticPage} =3D {}
- unless $Vend::Cfg->{Static};
- }
- $::Variable =3D $Vend::Cfg->{Variable};
- $::Pragma =3D { %{ $Vend::Cfg->{Pragma} } };
-
- if (defined $Global::SelectorAlias{$CGI::script_name}
- and ! defined $Vend::InternalHTTP )
- {
- my $real =3D $Global::SelectorAlias{$CGI::script_name};
- unless ( $CGI::secure or
- $Vend::Cfg->{SecureURL} =3D~ m{$CGI::script_name$} and
- $Vend::Cfg->{VendURL} !~ m{/nph-[^/]+$} and
- $Vend::Cfg->{VendURL} !~ m{$CGI::script_name$} )
- {
- $Vend::Cfg->{VendURL} =3D~ s!$real!$CGI::script_name!;
- $Vend::Cfg->{SecureURL} =3D~ s!$real!$CGI::script_name!;
- }
- }
- elsif ($Vend::InternalHTTP) {
- $Vend::Cfg->{VendURL} =3D "http://" .
- $CGI::http_host .
- $CGI::script_path;
- $Vend::Cfg->{ImageDir} =3D $Vend::Cfg->{ImageDirInternal}
- if $Vend::Cfg->{ImageDirInternal};
- }
-
- if($Global::HitCount and ! $cat) {
- my $ctr =3D new Vend::CounterFile
- "$Global::ConfDir/hits.$Vend::Cat";
- $ctr->inc();
- }
-
- if ($Vend::Cfg->{SetGroup}) {
- eval {
- $) =3D "$Vend::Cfg->{SetGroup} $Vend::Cfg->{SetGroup}";
- };
- if ($@) {
- my $msg =3D $@;
- logGlobal( "Can't set group to GID %s: %s",
- $Vend::Cfg->{SetGroup}, $msg
- );
- logError("Can't set group to GID %s: %s",
- $Vend::Cfg->{SetGroup}, $msg
- );
- }
- }
-
- chdir $Vend::Cfg->{VendRoot}=20
- or die "Couldn't change to $Vend::Cfg->{VendRoot}: $!\n";
- set_file_permissions();
-# STATICPAGE
- tie_static_dbm() if $Vend::Cfg->{StaticDBM};
-# END STATICPAGE
- umask $Vend::Cfg->{Umask};
-
-#show_times("end cgi and config mapping") if $Global::ShowTimes;
- open_database();
-#show_times("end open_database") if $Global::ShowTimes;
-}
-
-sub close_cat {
- put_session() if $Vend::HaveSession;
- close_session() if $Vend::SessionOpen;
- close_database();
-}
-
-sub run_macro {
- my $macro =3D shift
- or return;
- my $content_ref =3D shift;
-
- my @mac;
- if(ref $macro eq 'ARRAY') {
- @mac =3D @$macro;
- }
- elsif ($macro =3D~ /^[-\s\w,]+$/) {
- @mac =3D grep /\S/, split /[\s,]+/, $macro;
- }
- else {
- push @mac, $macro;
- }
-
- for my $m (@mac) {
- if ($m =3D~ /^\w+$/) {
- my $sub =3D $Vend::Cfg->{Sub}{$m} || $Global::GlobalSub->{$m}
- or do {
- logError("Unknown Autoload macro '%s'.", $macro);
- next;
- };
- $sub->($content_ref);
- }
- elsif($m =3D~ /^\w+-\w+$/) {
- Vend::Interpolate::tag_profile($m);
- }
- else {
- interpolate_html($m);
- }
- }
-}
-
-sub dispatch {
- my($http) =3D @_;
- $H =3D $http;
-
- adjust_cgi();
-
- open_cat();
-
- $CGI::user =3D Vend::Util::check_authorization($CGI::authorization)
- if defined $CGI::authorization;
-
- my($sessionid, $seed);
-
- $sessionid =3D $CGI::values{mv_session_id} || undef;
- $sessionid =3D~ s/\0.*//s;
-
- $::Instance->{CookieName} =3D $Vend::Cfg->{CookieName};
-
- if($CGI::values{mv_tmp_session}) {
-#::logDebug("setting tmp_session");
- $Vend::tmp_session =3D $Vend::new_session =3D 1;
- $sessionid =3D 'nsession';
- $Vend::Cookie =3D 1;
- $Vend::Cfg->{ScratchDefault}{mv_no_count} =3D 1;
- $Vend::Cfg->{ScratchDefault}{mv_no_session_id} =3D 1;
- }
- elsif ($::Instance->{CookieName} and defined $CGI::cookie) {
- $CGI::cookie =3D~ m{$::Instance->{CookieName}=3D($Vend::Cfg->{CookiePatt=
ern})};
- $seed =3D $sessionid =3D $1;
- $::Instance->{ExternalCookie} =3D $sessionid || 1;
- $Vend::CookieID =3D $Vend::Cookie =3D 1;
- }
- elsif (defined $CGI::cookie and
- $CGI::cookie =3D~ /\bMV_SESSION_ID=3D(\w{8,32})
- [:_] (
- ( \d{1,3}\. # An IP ADDRESS
- \d{1,3}\.
- \d{1,3}\.
- \d{1,3})
- # A user name or domain
- | ([A-Za-z0-9][-\@A-Za-z.0-9]+) )?
- \b/x)
- {
- $sessionid =3D $1
- unless defined $CGI::values{mv_pc} and $CGI::values{mv_pc} eq 'RESET';
- $CGI::cookiehost =3D $3;
- $CGI::cookieuser =3D $4;
- $Vend::CookieID =3D $Vend::Cookie =3D 1;
- }
-
- $::Instance->{CookieName} =3D 'MV_SESSION_ID' if ! $::Instance->{CookieNa=
me};
-
- $CGI::host =3D 'nobody' if $Vend::Cfg->{WideOpen};
-
- if(! $sessionid) {
- my $id =3D $::Variable->{MV_SESSION_ID};
- $sessionid =3D $CGI::values{$id} if $CGI::values{$id};
- if (! $sessionid and $Vend::Cfg->{FallbackIP}) {
- $sessionid =3D generate_key($CGI::remote_addr . $CGI::useragent);
- }
- }
- elsif (! $::Instance->{ExternalCookie} and $sessionid !~ /^\w+$/) {
- my $msg =3D get_locale_message(
- 403,
- "Unauthorized for that session %s. Logged.",
- $sessionid,
- );
- $Vend::StatusLine =3D <<EOF;
-Status: 403 Unauthorized
-Content-Type: text/plain
-EOF
- ::response($msg);
- logGlobal($msg);
- close_cat();
- return;
- }
-
-# DEBUG
-#::logDebug ("session=3D'$sessionid' cookie=3D'$CGI::cookie' chost=3D'$CGI=
::cookiehost'");
-# END DEBUG
-
-RESOLVEID: {
- if ($sessionid) {
- $Vend::SessionID =3D $sessionid;
- $Vend::SessionName =3D session_name();
- if($Vend::tmp_session) {
- $Vend::Session =3D {};
- init_session;
- last RESOLVEID;
- }
- # get_session will return a value if a session is read,
- # if not it will return false and a new session has been created.
- # The IP address will be counted for robot_resolution
- if(! get_session($seed) and ! $::Instance->{ExternalCookie}) {
- retire_id($sessionid);
- last RESOLVEID;
- }
- my $now =3D time;
- if(! $Vend::CookieID) {
- if( is_retired($sessionid) ) {
- new_session();
- last RESOLVEID;
- }
- my $compare_host =3D $CGI::secure
- ? ($Vend::Session->{shost})
- : ($Vend::Session->{ohost});
-
- if($Vend::Cfg->{WideOpen}) {
- # do nothing, no host checking
- }
- elsif(! $compare_host) {
- new_session($seed) unless $CGI::secure;
- init_session();
- $Vend::Session->{shost} =3D $CGI::remote_addr;
- }
- elsif ($compare_host ne $CGI::remote_addr) {
- new_session($seed);
- init_session();
- }
- }
- if ($now - $Vend::Session->{'time'} > $Vend::Cfg->{SessionExpire}) {
- if($::Instance->{ExternalCookie}) {
- init_session();
- }
- else {
- retire_id($sessionid);
- new_session();
- }
- last RESOLVEID;
- }
- elsif($Vend::Cfg->{RobotLimit}) {
- if ($now - $Vend::Session->{'time'} > 30) {
- $Vend::Session->{accesses} =3D 0;
- }
- else {
- $Vend::Session->{accesses}++;
-#::logDebug("accesses=3D$Vend::Session->{accesses} admin=3D$Vend::admin");
- if($Vend::Session->{accesses} > $Vend::Cfg->{RobotLimit}
- and ! $Vend::admin
- )
- {
- my $msg =3D errmsg(
- "WARNING: POSSIBLE BAD ROBOT. %s accesses with no 30 second pause.",
- $Vend::Session->{accesses},
- );
- do_lockout($msg);
- }
- }
- }
- }
- else {
- if($Vend::Cfg->{RobotLimit}) {
- if (Vend::Session::count_ip() > $Vend::Cfg->{RobotLimit}) {
- my $msg;
- # Here they can get it back if they pass expiration time
- my $wait =3D $Global::Variable->{MV_ROBOT_EXPIRE} || 86400;
- $wait /=3D 3600;
- $msg =3D errmsg(<<EOF, $wait);=20
-Too many new ID assignments for this IP address. Please wait at least %d h=
ours
-before trying again. Only waiting that period will allow access. Terminati=
ng.
-EOF
- $msg =3D Vend::Page::get_locale_message(403, $msg);
- do_lockout($msg);
- $Vend::StatusLine =3D <<EOF;
-Status: 403 Forbidden
-Content-Type: text/plain
-EOF
- ::response($msg);
- close_cat();
- return;
- }
- }
- new_session();
- }
-}
-
-#::logDebug("session name=3D'$Vend::SessionName'\n");
-
- $Vend::Calc_initialized =3D 0;
- $CGI::values{mv_session_id} =3D $Vend::Session->{id} =3D $Vend::SessionID;
-
- if($Vend::Cfg->{CookieLogin}) {
- COOKIELOGIN: {
- last COOKIELOGIN if $Vend::Session->{logged_in};
- last COOKIELOGIN if defined $CGI::values{mv_username};
- last COOKIELOGIN unless
- $CGI::values{mv_username} =3D Vend::Util::read_cookie('MV_USERNAME');
- my $password;
- last COOKIELOGIN unless
- $password =3D Vend::Util::read_cookie('MV_PASSWORD');
- $CGI::values{mv_password} =3D $password;
- my $profile =3D Vend::Util::read_cookie('MV_USERPROFILE');
- local(%SIG);
- undef $SIG{__DIE__};
- eval {
- Vend::UserDB::userdb('login', profile =3D> $profile );
- };
- if($@) {
- $Vend::Session->{failure} .=3D $@;
- }
- }
- }
-
- $Vend::Session->{'arg'} =3D $Vend::Argument =3D ($CGI::values{mv_arg} || =
undef);
-
- if ($CGI::values{mv_pc} =3D~ /\D/) {
- $Vend::Session->{source} =3D $CGI::values{mv_pc} eq 'RESET'
- ? ''
- : $CGI::values{mv_pc};
- }
- elsif($CGI::values{mv_source}) {
- $Vend::Session->{source} =3D $CGI::values{mv_source};
- }
-
- $Vend::Session->{'user'} =3D $CGI::user;
-
- undef $Vend::Cookie if=20
- $Vend::Session->{logged_in} && ! $Vend::Cfg->{StaticLogged};
-
- $CGI::pragma =3D 'no-cache'
- if delete $::Scratch->{mv_no_cache};
-#show_times("end session get") if $Global::ShowTimes;
-
- $Vend::FinalPath =3D $Vend::Session->{last_url} =3D $CGI::path_info;
-
- if( defined $Vend::Session->{path_alias}{$Vend::FinalPath} ) {
- $CGI::path_info
- =3D $Vend::FinalPath
- =3D $Vend::Session->{path_alias}{$Vend::FinalPath};
- delete $Vend::Session->{path_alias}{$Vend::FinalPath}
- if delete $Vend::Session->{one_time_path_alias}{$Vend::FinalPath};
- }
-
- url_history($Vend::FinalPath) if $Vend::Cfg->{History};
-
-# TRACK
- $Vend::Track =3D new Vend::Track;
-# END TRACK
-
- if($Vend::Cfg->{DisplayErrors} and $Global::DisplayErrors) {
- $SIG{"__DIE__"} =3D sub {
- my $msg =3D shift;
- put_session() if $Vend::HaveSession;
- my $content =3D get_locale_message(500, <<EOF, $msg);
-<HTML><HEAD><TITLE>Fatal Interchange Error</TITLE></HEAD><BODY>
-<H1>FATAL error</H1>
-<PRE>%s</PRE>
-</BODY></HTML>
-EOF
- ::response(\$content);
- exit 0;
- };
- }
-
- # Do it here so we can use autoloads and such
- Vend::Interpolate::reset_calc() if $Global::Foreground;
- Vend::Interpolate::init_calc();
- new Vend::Tags;
-# LEGACY
- ROUTINES: {
- last ROUTINES unless index($Vend::FinalPath, '/process/') =3D=3D 0;
- while ($Vend::FinalPath =3D~ s:/process/(locale|language|currency)/([^/]=
*)/:/process/:) {
- $::Scratch->{"mv_$1"} =3D $2;
- }
- $Vend::FinalPath =3D~ s:/process/page/:/:;
- }
- my $locale;
- if($locale =3D $::Scratch->{mv_language}) {
- $Global::Variable->{LANG}
- =3D $::Variable->{LANG} =3D $locale;
- }
-
- if ($Vend::Cfg->{Locale} and
- $locale =3D $::Scratch->{mv_locale} and
- defined $Vend::Cfg->{Locale_repository}->{$locale}
- )
- {=20
- $Global::Variable->{LANG}
- =3D $::Variable->{LANG}
- =3D $::Scratch->{mv_language}
- =3D $locale
- if ! $::Scratch->{mv_language};
- Vend::Util::setlocale( $locale,
- ($::Scratch->{mv_currency} || undef),
- { persist =3D> 1 }
- );
- }
-# END LEGACY
-
- run_macro($Vend::Cfg->{Autoload});
-#show_times("end global Autoload macro") if $Global::ShowTimes;
-
- for my $macro ( $Vend::Cfg->{Filter}, $Vend::Session->{Filter}) {
- next unless $macro;
- if (ref($macro) ne 'HASH') {
- logError("Bad CGI filter '%s'", $macro);
- }
- for(keys %$macro) {
- Vend::Interpolate::input_filter_do($_, { op =3D> $macro->{$_} } );
- }
- }
-
- run_macro($Vend::Session->{Autoload});
-#show_times("end session Autoload macro") if $Global::ShowTimes;
-
- # If the cgi-bin program was invoked with no extra path info,
- # just display the catalog page.
- if (! $Vend::FinalPath || $Vend::FinalPath =3D~ m:^/+$:) {
- $Vend::FinalPath =3D find_special_page('catalog');
- }
-
- $Vend::FinalPath =3D~ s:^/+::;
- $Vend::FinalPath =3D~ s/(\.html?)$//;
-
- my $record;
- my $adb;
-
- if(ref $Vend::Session->{alias_table}) {
- $record =3D $Vend::Session->{alias_table}{$Vend::FinalPath};
- $Vend::Cfg->{AliasTable} ||=3D 'alias';
- }
-
- if(
- $Vend::Cfg->{AliasTable}
- and
- $record=20
- or=20
- (
- $adb =3D database_exists_ref($Vend::Cfg->{AliasTable})
- and=20
- $record =3D $adb->row_hash($Vend::FinalPath)
- )
- )
- {
- $Vend::FinalPath =3D $record->{real_page};
-
- # This prevents filesystem access when we never want it
- # If base page is not passed we allow normal resolution
- $record->{base_page}
- and $Vend::ForceFlypage =3D $record->{base_page};
-
- my $ref;
-
- ## Here we populate CGI variables if desired
- ## Explicitly passed variables override this
- if(
- $record->{base_control}
- and
- $ref =3D get_option_hash($record->{base_control})
- )
- {
- for(keys %$ref) {
- next if defined $CGI::values{$_};
- $CGI::values{$_} =3D $ref->{$_};
- }
- }
-
- }
-
- $Vend::Session->{extension} =3D $1 || '';
-#::logDebug("path=3D$Vend::FinalPath");
-
- DOACTION: {
- my @path =3D split('/', $Vend::FinalPath, 2);
- if (defined $CGI::values{mv_action}) {
- $CGI::values{mv_todo} =3D $CGI::values{mv_action}
- if ! defined $CGI::values{mv_todo}
- and ! defined $CGI::values{mv_doit};
- $Vend::Action =3D 'process';
- $CGI::values{mv_nextpage} =3D $Vend::FinalPath
- if ! defined $CGI::values{mv_nextpage};
- }
- else {
- $Vend::Action =3D shift @path;
- }
-
-#::logGlobal("action=3D$Vend::Action path=3D$Vend::FinalPath");
- my ($sub, $status, $action);
- if(defined $Vend::Cfg->{ActionMap}{$Vend::Action}) {
- $sub =3D $Vend::Cfg->{ActionMap}{$Vend::Action};
- $CGI::values{mv_nextpage} =3D $Vend::FinalPath
- if ! defined $CGI::values{mv_nextpage};
- new Vend::Parse;
- }
- elsif ( defined ($sub =3D $action{$Vend::Action}) ) {
- $Vend::FinalPath =3D join "", @path;
- }
-
-#show_times("end path/action resolve") if $Global::ShowTimes;
-
- eval {
- if(defined $sub) {
- $status =3D $sub->($Vend::FinalPath);
-#show_times("end action") if $Global::ShowTimes;
- }
- else {
- $status =3D 1;
- }
- };
- (undef $Vend::RedoAction, redo DOACTION) if $Vend::RedoAction;
-
- if($@) {
- undef $status;
- my $err =3D $@;
- my $template =3D <<EOF;
-Sorry, there was an error in processing this form action. Please=20
-report the error or try again later.
-EOF
- $template .=3D "\n\nError: %s\n"
- if $Global::DisplayErrors && $Vend::Cfg->{DisplayErrors}
- ;
- $template =3D get_locale_message(500, $template, $err);
- $template .=3D "($err)";
- ::response($template);
- }
-
- $CGI::values{mv_nextpage} =3D $Vend::FinalPath
- if ! defined $CGI::values{mv_nextpage};
-
- do_page() if $status;
-#show_times("end page display") if $Global::ShowTimes;
-
-
- if(my $macro =3D $Vend::Cfg->{AutoEnd}) {
- if($macro =3D~ /\[\w+/) {
- interpolate_html($macro);
- }
- elsif ($macro =3D~ /^\w+$/) {
- $sub =3D $Vend::Cfg->{Sub}{$macro} || $Global::GlobalSub->{$macro};
- $sub->();
- }
-#show_times("end AutoEnd macro") if $Global::ShowTimes;
- }
- }
-
-# TRACK
- $Vend::Track->filetrack();
-# END TRACK
-
- close_cat();
-
- undef $H;
-
-#show_times("end dispatch cleanup") if $Global::ShowTimes;
-
- return 1;
-}
-
## DEBUG
=20
sub dontwarn {
@@ -2565,16 +332,6 @@
1;
}
=20
-sub dump_env {
- my($var, $value);
-
- open(Vend::E, ">$Vend::Cfg->{'VendRoot'}/env");
- while(($var, $value) =3D each %ENV) {
- print Vend::E "export $var=3D'$value'\n";
- }
- close Vend::E;
-}
-
sub version {
print "Interchange version $VERSION copyright 1996-2002 Red Hat, Inc. and=
others.\n";
}
@@ -2802,27 +559,6 @@
END
}
=20
-## FILE PERMISSIONS
-
-sub set_file_permissions {
- my($r, $w, $p, $u);
-
- $r =3D $Vend::Cfg->{'ReadPermission'};
- if ($r eq 'user') { $p =3D 0400; $u =3D 0277; }
- elsif ($r eq 'group') { $p =3D 0440; $u =3D 0227; }
- elsif ($r eq 'world') { $p =3D 0444; $u =3D 0222; }
- else { die "Invalid value for ReadPermission\n"; }
-
- $w =3D $Vend::Cfg->{'WritePermission'};
- if ($w eq 'user') { $p +=3D 0200; $u &=3D 0577; }
- elsif ($w eq 'group') { $p +=3D 0220; $u &=3D 0557; }
- elsif ($w eq 'world') { $p +=3D 0222; $u &=3D 0555; }
- else { die "Invalid value for WritePermission\n"; }
-
- $Vend::Cfg->{'FileCreationMask'} =3D $p;
- $Vend::Cfg->{'Umask'} =3D $u;
-}
-
## MAIN
=20
sub catch_warnings {
@@ -3067,10 +803,7 @@
# Select locking mode
set_lock_type();
=20
- @action{keys %{$Global::ActionMap}} =3D (values %{$Global::ActionMap})
- if $Global::ActionMap;
- @form_action{keys %{$Global::FormAction}} =3D (values %{$Global::FormActi=
on})
- if $Global::FormAction;
+ Vend::Dispatch::update_global_actions();
=20
#::logDebug(::uneval(\%Global::Catalog));
=20