lib/Vend/Dispatch.pm

   1 # Vend::Dispatch - Handle Interchange page requests
   2 #
   3 # Copyright (C) 2002-2009 Interchange Development Group
   4 # Copyright (C) 2002 Mike Heins <mike@perusion.net>
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public
  20 # License along with this program; if not, write to the Free
  21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  22 # MA  02110-1301  USA.
  23
  24 package Vend::Dispatch;
  25
  26 use vars qw($VERSION);
  27 $VERSION = '1.113';
  28
  29 use POSIX qw(strftime);
  30 use Vend::Util;
  31 use Vend::Interpolate;
  32 use Vend::Data;
  33 use Vend::Config;
  34 use autouse 'Vend::Error' => qw/get_locale_message interaction_error do_lockout full_dump/;
  35 use Vend::Order;
  36 use Vend::Session;
  37 use Vend::Page;
  38 use Vend::UserDB;
  39 use Vend::CounterFile;
  40 no warnings qw(uninitialized numeric);
  41
  42 # TRACK
  43 use Vend::Track;
  44 # END TRACK
  45
  46 require Exporter;
  47
  48 @ISA = qw(Exporter);
  49
  50 @EXPORT = qw(
  51
  52                                 config_named_catalog
  53                                 dispatch
  54                                 do_process
  55                                 http
  56                                 response
  57                                 run_macro
  58                                 tie_static_dbm
  59                                 update_user
  60                                 update_values
  61                         );
  62
  63 use strict;
  64
  65 my $H;
  66 sub http {
  67         return $H;
  68 }
  69
  70 sub response {
  71         my $possible = shift;
  72         return if $Vend::Sent;
  73
  74         if (defined $possible and ! $::Pragma->{download}) {
  75                 push @Vend::Output, (ref $possible ? $possible : \$possible);
  76         }
  77
  78         if($::Pragma->{download}) {
  79                 $H->respond(ref $possible ? $possible : \$possible);
  80         }
  81         elsif($Vend::MultiOutput) {
  82                 for my $space (keys %Vend::OutPtr) {
  83                         my $things = $Vend::OutPtr{$space} || [];
  84                         for my $ptr (@$things) {
  85                                 my $subs = $Vend::OutFilter{$space} || [];
  86                                 for my $sub (@$subs) {
  87                                         $sub->($Vend::Output[$ptr]);
  88                                 }
  89                         }
  90                 }
  91                 for(grep $_, @Vend::Output) {
  92                         $H->respond($_);
  93                 }
  94         }
  95         else {
  96                 for(@Vend::Output) {
  97                         Vend::Interpolate::substitute_image($_);
  98                         $H->respond($_);
  99                 }
 100         }
 101         @Vend::Output = ();
 102 }
 103
 104 # Parse the mv_click and mv_check special variables
 105 sub parse_click {
 106         my ($ref, $click, $extra) = @_;
 107     my($codere) = '[-\w_#/.]+';
 108         my $params;
 109
 110 #::logDebug("Looking for click $click");
 111         if($params = $::Scratch->{$click}) {
 112                 # Do nothing, we found the click
 113 #::logDebug("Found scratch click $click = |$params|");
 114         }
 115         elsif(defined ($params = $Vend::Cfg->{OrderProfileName}{$click}) ) {
 116                 # Do nothing, we found the click
 117                 $params = $Vend::Cfg->{OrderProfile}[$params];
 118 #::logDebug("Found profile click $click = |$params|");
 119         }
 120         elsif(defined ($params = $Global::ProfilesName->{$click}) ) {
 121                 # Do nothing, we found the click
 122                 $params = $Global::Profiles->[$params];
 123 #::logDebug("Found profile click $click = |$params|");
 124         }
 125         elsif($params = $::Scratch->{"mv_click $click"}) {
 126                 $::Scratch->{mv_click_arg} = $click;
 127         }
 128         elsif($params = $::Scratch->{mv_click}) {
 129                 $::Scratch->{mv_click_arg} = $click;
 130         }
 131         else {
 132 #::logDebug("Found NO click $click");
 133                 return 1;
 134         } # No click processor
 135
 136         my($var,$val,$parameter);
 137         $params = interpolate_html($params);
 138         my(@param) = split /\n+/, $params;
 139
 140         for(@param) {
 141                 next unless /\S/;
 142                 next if /^\s*#/;
 143                 s/^[\r\s]+//;
 144                 s/[\r\s]+$//;
 145                 $parameter = $_;
 146                 ($var,$val) = split /[\s=]+/, $parameter, 2;
 147                 $val =~ s/&#(\d+);/chr($1)/ge;
 148                 $ref->{$var} = $val;
 149                 $extra->{$var} = $val
 150                         if defined $extra;
 151         }
 152 }
 153
 154 ## This is the set of variables we don't want to dump or save in
 155 ## sessions for security reasons.
 156 @Global::HideCGI = qw(
 157                                                 mv_password
 158                                                 mv_verify
 159                                                 mv_password_old
 160                                                 mv_credit_card_number
 161                                                 mv_credit_card_cvv2
 162                                         );
 163
 164 # This is the set of CGI-passed variables to ignore, in other words
 165 # never set in the user session.  If set in the mv_check pass, though,
 166 # they will stick.
 167 %Global::Ignore = qw(
 168         mv_todo  1
 169         mv_todo.submit.x  1
 170         mv_todo.submit.y  1
 171         mv_todo.return.x  1
 172         mv_todo.return.y  1
 173         mv_todo.checkout.x  1
 174         mv_todo.checkout.y  1
 175         mv_todo.todo.x  1
 176         mv_todo.todo.y  1
 177         mv_todo.map  1
 178         mv_doit  1
 179         mv_check  1
 180         mv_click  1
 181         mv_nextpage  1
 182         mv_failpage  1
 183         mv_password  1
 184         mv_verify  1
 185         mv_password_old  1
 186         mv_successpage  1
 187         mv_more_ip  1
 188         mv_credit_card_number  1
 189         mv_credit_card_cvv2  1
 190         );
 191
 192
 193 ## FILE PERMISSIONS
 194 sub set_file_permissions {
 195         my($r, $w, $p, $u);
 196
 197         $r = $Vend::Cfg->{'ReadPermission'};
 198         if    ($r eq 'user')  { $p = 0400;   $u = 0277; }
 199         elsif ($r eq 'group') { $p = 0440;   $u = 0227; }
 200         elsif ($r eq 'world') { $p = 0444;   $u = 0222; }
 201         else                  { die "Invalid value for ReadPermission\n"; }
 202
 203         $w = $Vend::Cfg->{'WritePermission'};
 204         if    ($w eq 'user')  { $p += 0200;  $u &= 0577; }
 205         elsif ($w eq 'group') { $p += 0220;  $u &= 0557; }
 206         elsif ($w eq 'world') { $p += 0222;  $u &= 0555; }
 207         else                  { die "Invalid value for WritePermission\n"; }
 208
 209         $Vend::Cfg->{'FileCreationMask'} = $p;
 210         $Vend::Cfg->{'Umask'} = $u;
 211 }
 212
 213 sub update_values {
 214
 215         my (@keys) = @_;
 216
 217         my $set;
 218         if(@keys) {
 219                 $set = {};
 220                 @{$set}{@keys} = @CGI::values{@keys};
 221         }
 222         else {
 223                 $set = \%CGI::values;
 224
 225                 if( $Vend::Cfg->{CreditCardAuto} and $CGI::values{mv_credit_card_number} ) {
 226                         (
 227                                 @{$::Values}{
 228                                         qw/
 229                                                         mv_credit_card_valid
 230                                                         mv_credit_card_info
 231                                                         mv_credit_card_exp_month
 232                                                         mv_credit_card_exp_year
 233                                                         mv_credit_card_exp_all
 234                                                         mv_credit_card_type
 235                                                         mv_credit_card_reference
 236                                                         mv_credit_card_error
 237                                         / }
 238                         ) = encrypt_standard_cc(\%CGI::values);
 239                 }
 240         }
 241
 242         my $restrict;
 243         if($restrict = $Vend::Session->{restrict_html} and ! ref $restrict) {
 244                 $restrict = [ map { lc $_ } split /\s+/, $restrict ];
 245                 $Vend::Session->{restrict_html} = $restrict;
 246         }
 247
 248     while (my ($key, $value) = each %$set) {
 249                 # values explicly ignored in configuration
 250         next if defined $Global::Ignore{$key};
 251         next if defined $Vend::Cfg->{FormIgnore}{$key};
 252
 253 #LEGACY
 254                 # We add any checkbox ordered items, but don't update --
 255                 # we don't want to order them twice
 256         next if ($key =~ m/^quantity\d+$/);
 257 #END LEGACY
 258
 259                 # Admins should know what they are doing
 260                 if($Vend::admin) {
 261                         $::Values->{$key} = $value;
 262                         next;
 263                 }
 264                 elsif ($restrict and $value =~ /</) {
 265                         # Allow designer to allow only certain HTML tags from trusted users
 266                         # Will go away when current session ends...
 267                         # [ script start character handled in [value ...] ITL tag
 268                         $value = Vend::Interpolate::filter_value(
 269                                                 'restrict_html',
 270                                                 $value,
 271                                                 undef,
 272                                                 @$restrict,
 273                                         );
 274                         $::Values->{$key} = $value;
 275                         next;
 276                 }
 277                 $value =~ tr/<[//d;
 278                 $value =~ s/&lt;//ig;
 279                 $value =~ s/&#91;//g;
 280         $::Values->{$key} = $value;
 281     }
 282 }
 283
 284 sub update_user {
 285         my($key,$value);
 286     # Update the user-entered fields.
 287
 288         add_items() if defined $CGI::values{mv_order_item};
 289         update_values();
 290
 291         if($CGI::values{mv_check}) {
 292                 my(@checks) = split /\s*[,\0]+\s*/, delete $CGI::values{mv_check};
 293                 my($check);
 294                 foreach $check (@checks) {
 295                                 parse_click $::Values, $check, \%CGI::values;
 296                 }
 297         }
 298
 299         check_save if defined $CGI::values{mv_save_session};
 300
 301 }
 302
 303 ## DO PROCESS
 304
 305 sub do_click {
 306         my($click, @clicks);
 307         do {
 308                 if($CGI::values{mv_click}) {
 309                         @clicks = split /\s*[\0]+\s*/, delete $CGI::values{mv_click};
 310                 }
 311
 312                 if(defined $CGI::values{mv_click_map}) {
 313                         my(@map) = split /\s*[\0]+\s*/, delete $CGI::values{mv_click_map};
 314                         foreach $click (@map) {
 315                                 push (@clicks, $click)
 316                                         if defined $CGI::values{"mv_click.$click.x"}
 317                                         or defined $CGI::values{"$click.x"}
 318                                         or $click = $CGI::values{"mv_click_$click"};
 319                         }
 320                 }
 321
 322                 foreach $click (@clicks) {
 323                         parse_click \%CGI::values, $click;
 324                 }
 325         } while $CGI::values{mv_click};
 326         return 1;
 327 }
 328
 329 sub do_deliver {
 330         my $file = $CGI::values{mv_data_file};
 331         my $mode = $CGI::values{mv_acl_mode} || '';
 332         if($::Scratch->{mv_deliver} !~ m{(^|\s)$file(\s|$)}
 333                 and
 334                 ! Vend::UserDB::userdb(
 335                                                         'check_file_acl',
 336                                                         location => $file,
 337                                                         mode => $mode,
 338                                                         )
 339                 )
 340         {
 341                 $Vend::StatusLine = "Status: 403\nContent-Type: text/html";
 342                 my $msg = get_locale_message(403, <<EOF);
 343 <b>Authorization Required</b>
 344 <p>
 345 This server could not verify that you are authorized to access the document
 346 requested.
 347 </p>
 348 EOF
 349                 response($msg);
 350                 return 0;
 351         }
 352
 353         if (! -f $file) {
 354                 $Vend::StatusLine = "Status: 404\nContent-Type: text/html";
 355                 my $msg = get_locale_message(404, <<EOF, $file);
 356 <b>Not Found</b>
 357 <p>
 358 The requested file %s was not found on this server.
 359 </p>
 360 EOF
 361                 response($msg);
 362                 return 0;
 363         }
 364
 365         my $size = -s $CGI::values{mv_data_file};
 366         $CGI::values{mv_content_type} ||=  'application/octet-stream';
 367         $Vend::StatusLine = <<EOF;
 368 Content-Type: $CGI::values{mv_content_type}
 369 Content-Length: $size
 370 EOF
 371         ::response(
 372         Vend::Util::readfile($CGI::values{mv_data_file}, undef, undef,
 373                                                          {encoding => 'raw'}));
 374
 375         return 0;
 376 }
 377
 378 my %form_action = (
 379
 380         search  => \&do_search,
 381         deliver => \&do_deliver,
 382         submit  =>
 383                                 sub {
 384                                         update_user();
 385                                         update_quantity()
 386                                                 or return interaction_error("quantities");
 387                                         my $ok;
 388                                         my($missing,$next,$status,$final,$result_hash);
 389
 390                                         # Set shopping cart if necessary
 391                                         # Vend::Items is tied, remember!
 392                                         $Vend::Items = $CGI::values{mv_cartname}
 393                                                 if $CGI::values{mv_cartname};
 394
 395 #::logDebug("Default order route=$::Values->{mv_order_route}");
 396                                         ## Determine the master order route, if routes
 397                                         ## are not set in CGI values (4.7.x default)
 398                                         if(
 399                                                 $Vend::Cfg->{Route}
 400                                                 and ! defined $::Values->{mv_order_route}
 401                                                 )
 402                                         {
 403                                                 my $curr = $Vend::Cfg->{Route};
 404                                                 my $repos = $Vend::Cfg->{Route_repository};
 405
 406                                                 if($curr->{master}) {
 407                                                         # Default route is master
 408
 409                                                         for(keys %$repos) {
 410                                                                 next unless $curr eq $repos->{$_};
 411                                                                 $::Values->{mv_order_route} = $_;
 412                                                                 last;
 413                                                         }
 414                                                 }
 415                                                 else {
 416                                                         for(keys %$repos) {
 417                                                                 next unless $repos->{$_}->{master};
 418                                                                 $::Values->{mv_order_route} = $_;
 419                                                                 last;
 420                                                         }
 421                                                 }
 422                                         }
 423
 424 #::logDebug("Default order route=$::Values->{mv_order_route}");
 425
 426                                   CHECK_ORDER: {
 427
 428                                         # If the user sets this later, will be used
 429                                         delete $Vend::Session->{mv_order_number};
 430
 431                                         if (defined $CGI::values{mv_order_profile}) {
 432                                                 ($status,$final,$missing) =
 433                                                         check_order($CGI::values{mv_order_profile});
 434                                         }
 435                                         else {
 436                                                 $status = $final = 1;
 437                                         }
 438 #::logDebug("Profile status status=$status final=$final errors=$missing");
 439
 440                                         my $provisional;
 441                                         if ($status and defined $::Values->{mv_order_route}) {
 442                                                 # This checks only route order profiles
 443 #::logDebug("Routing order, pre-check");
 444                                                 ($status, $provisional, $missing)
 445                                                                                 = route_order(
 446                                                                                                 $::Values->{mv_order_route},
 447                                                                                                 $Vend::Items,
 448                                                                                                 'check',
 449                                                                                         );
 450                                         }
 451
 452                                         $final = $provisional if ! $final;
 453
 454 #::logDebug("Routing status status=$status final=$final errors=$missing");
 455                                         if($status) {
 456                                                 $CGI::values{mv_nextpage} = $CGI::values{mv_successpage}
 457                                                         if $CGI::values{mv_successpage};
 458                                                 $CGI::values{mv_nextpage} = $::Values->{mv_orderpage}
 459                                                         if ! $CGI::values{mv_nextpage};
 460                                         }
 461                                         else {
 462                                                 $CGI::values{mv_nextpage} = $CGI::values{mv_failpage}
 463                                                         if $CGI::values{mv_failpage};
 464                                                 $CGI::values{mv_nextpage} = find_special_page('needfield')
 465                                                         if ! $CGI::values{mv_nextpage};
 466                                                 undef $final;
 467                                         }
 468
 469                                         return 1 unless $final;
 470
 471                                         my $order_no;
 472                                         if (defined $::Values->{mv_order_route}) {
 473                                                 # $ok will not be defined unless Route "supplant" was set
 474                                                 # $order_no will come back so we don't issue two of them
 475 #::logDebug("Routing order $::Values->{mv_order_route}");
 476                                                 ($ok, $order_no, $result_hash) = route_order(
 477                                                                                         $::Values->{mv_order_route},
 478                                                                                         $Vend::Items
 479                                                                                         );
 480                                                 return 1 unless $ok;
 481                                         }
 482
 483                                         $result_hash = {} unless $result_hash;
 484
 485 # TRACK
 486                     $Vend::Track->finish_order () if $Vend::Track;
 487 # END TRACK
 488                                         # This function (followed down) now does the rudimentary
 489                                         # backend ordering with AsciiTrack and the order report.
 490                                         # If the "supplant" option was set in order routing it will
 491                                         # not be used ($ok would have been defined)
 492
 493
 494 #::logDebug("Order number=$order_no\n");
 495                                         $ok = mail_order(undef, $order_no || undef) unless defined $ok;
 496 #::logDebug("Order number=$order_no, result_hash=" . ::uneval($result_hash));
 497
 498                                         # Display a receipt if configured
 499
 500                                         my $not_displayed = 1;
 501
 502                                         if(! $ok) {
 503                                                 display_special_page(
 504                                                                 find_special_page('failed'),
 505                                                                 errmsg('Error transmitting order(%s): %s', $!, $@),
 506                                                 );
 507                                         }
 508                                         elsif (! $result_hash->{no_receipt} ) {
 509                                                 eval {
 510
 511                                                         my $receipt = $result_hash->{receipt}
 512                                                                                 || $::Values->{mv_order_receipt}
 513                                                                                 || find_special_page('receipt');
 514 #::logDebug("selected receipt=$receipt");
 515                                                         display_special_page($receipt);
 516                                                 };
 517                                                 $not_displayed = 0;
 518 #::logDebug("not_displayed=$not_displayed");
 519                                                 if($@) {
 520                                                         my $msg = $@;
 521                                                         logError(
 522                                                                 'Display of receipt on order number %s failed: %s',
 523                                                                 $::Values->{mv_order_number},
 524                                                                 $msg,
 525                                                         );
 526                                                 }
 527                                         }
 528
 529                                         # Do order cleanup
 530                                         run_macro($Vend::Cfg->{OrderCleanup});
 531
 532                                         # Remove the items
 533                                         @$Vend::Items = ();
 534 #::logDebug("returning order_number=$order_no, not_displayed=$not_displayed");
 535                                         return $not_displayed;
 536                                   }
 537                         },
 538         refresh => sub {
 539                                         update_quantity()
 540                                                 or return interaction_error("quantities");
 541 # LEGACY
 542                                         $CGI::values{mv_nextpage} = $CGI::values{mv_orderpage}
 543                                                 if $CGI::values{mv_orderpage};
 544 # END LEGACY
 545                                         $CGI::values{mv_nextpage} = $CGI::values{mv_orderpage}
 546                                                                                                 || find_special_page('order')
 547                                                 if ! $CGI::values{mv_nextpage};
 548                                         update_user();
 549                                         return 1;
 550                                 },
 551         set             => sub {
 552                                         update_user() unless $CGI::values{mv_data_auto_number};
 553                                         update_data();
 554                                         update_user() if $CGI::values{mv_data_auto_number};
 555                                         return 1;
 556                                 },
 557         autoset => sub {
 558                                         update_data();
 559                                         update_user();
 560                                         return 1;
 561                                 },
 562         back    => sub { return 1 },
 563         return  => sub {
 564                                         update_user();
 565                                         update_quantity()
 566                                                 or return interaction_error("quantities");
 567                                         return 1;
 568                                 },
 569         cancel  => sub {
 570                                         put_session();
 571                                         get_session();
 572                                         init_session();
 573                                         $CGI::values{mv_nextpage} = find_special_page('canceled')
 574                                                 if ! $CGI::values{mv_nextpage};
 575                                         return 1;
 576                                 },
 577 );
 578
 579 $form_action{go} = $form_action{return};
 580
 581 # Process the completed order or search page.
 582
 583 sub do_process {
 584
 585         # Prevent using keys operation more than once
 586     my @cgikeys = keys %CGI::values;
 587
 588     my @multis = grep /^mv\d\d?_/, @cgikeys;
 589
 590         ## Only operates on up to 100 items to prevent "amplification"
 591         ## which could result in DOS attacks
 592         MULTIS:
 593         if(@multis) {
 594                 my %hash;
 595                 for(@multis) {
 596                         my $val = delete $CGI::values{$_};
 597                         # Have to handle nulls somehow....
 598                         $val =~ s/\0/::/g;
 599                         m{^mv\d+\d?_(.*)};
 600                         my $idx = $1;
 601                         my $key = $2;
 602                         $hash{$key} ||= [];
 603                         $hash{$key}[$idx] = $val;
 604                 }
 605                 while (my ($k, $v) = each %hash) {
 606                         $CGI::values{$k} = join "\0", @$v;
 607                 }
 608         }
 609
 610     my @filters = grep /^[mu][vi]_filter:/, @cgikeys;
 611
 612         FILTERS: {
 613                 last FILTERS unless @filters;
 614                 foreach my $key (@filters) {
 615                         next unless $key =~ /^ui_|^mv_/;
 616                         my $val = delete $CGI::values{$key};
 617                         $key =~ s/^.._filter://;
 618                         next unless $val;
 619                         if($val =~ /checkbox/) {
 620                                 $CGI::values{$key} = $Tag->filter($val, $CGI::values{$key}, $key);
 621                         }
 622                         else {
 623                                 next unless defined $CGI::values{$key};
 624                                 $CGI::values{$key} = $Tag->filter($val, $CGI::values{$key}, $key);
 625                         }
 626                 }
 627         }
 628
 629         if($CGI::values{mv_form_profile}) {
 630                 my ($status) = check_order(
 631                                                         $CGI::values{mv_form_profile},
 632                                                         \%CGI::values,
 633                                                         $CGI::values{mv_individual_profile},
 634                                                         );
 635                 return 1 if defined $status and ! $status;
 636         }
 637
 638     my $orig_todo = $CGI::values{mv_todo};
 639
 640         do_click();
 641
 642     my $todo = $CGI::values{mv_todo};
 643
 644         # Maybe we have an imagemap input, if not, use $doit
 645         if($orig_todo ne $todo) {
 646                 # Don't mess with it, changed in click
 647         }
 648         elsif (defined $CGI::values{'mv_todo.x'}) {
 649                 my $x = $CGI::values{'mv_todo.x'};
 650                 my $y = $CGI::values{'mv_todo.y'};
 651                 my $map = $CGI::values{'mv_todo.map'};
 652                 # Called with action_map and not package id
 653                 # since "autouse" is possibly in force...found
 654                 # by Jeff Carnahan
 655                 $todo = action_map($x,$y,$map);
 656         }
 657         elsif( my @todo = grep /^mv_todo\.\w+(?:\.x)?$/, @cgikeys ) {
 658                 # Only one todo!
 659                 for(@todo) {
 660                         delete $CGI::values{$_};
 661                         s/^mv_todo\.(\w+)(?:\.[xy])?$/$1/;
 662                 }
 663                 $todo = shift @todo;
 664         }
 665
 666         $todo = $CGI::values{mv_doit} || 'back' if ! $todo;
 667
 668 #::logDebug("todo=$todo after mv_click");
 669
 670         my ($sub, $status);
 671         #Now determine the action on the todo
 672     if (defined $Vend::Cfg->{FormAction}{$todo}) {
 673                 $sub = $Vend::Cfg->{FormAction}{$todo};
 674         }
 675     elsif (not $sub = $form_action{$todo} ) {
 676                 unless ($sub = Vend::Util::codedef_routine('FormAction', $todo)) {
 677                 interaction_error(::errmsg("Invalid action %s passed for processing.\n", $todo));
 678                 return;
 679     }
 680     }
 681         eval {
 682                 $status = $sub->($todo);
 683         };
 684         if($@) {
 685                 undef $status;
 686                 my $err = $@;
 687                 my $template = <<EOF;
 688 Sorry, there was an error in processing this form action. Please
 689 report the error or try again later.
 690 EOF
 691                 $template .= "\n\nError: %s\n"
 692                                 if $Global::DisplayErrors && $Vend::Cfg->{DisplayErrors}
 693                         ;
 694                 $template = get_locale_message(500, $template, $err);
 695                 $template .= "($err)";
 696                 logError($err);
 697                 response($template);
 698         }
 699
 700         if($CGI::values{mv_cleanup}) {
 701                 my(@checks) = split /\s*[,\0]+\s*/, delete $CGI::values{mv_cleanup};
 702                 my($check);
 703                 foreach $check (@checks) {
 704                                 parse_click $::Values, $check, \%CGI::values;
 705                 }
 706         }
 707
 708         return $status;
 709 }
 710
 711 sub run_in_catalog {
 712         my ($cat, $job, $itl, $parms) = @_;
 713         my ($g,$c);
 714
 715 #::logGlobal("running job in cat=$cat");
 716         $parms ||= {};
 717
 718         $g = $Global::Catalog{$cat};
 719         unless (defined $g) {
 720                 logGlobal( "Can't find catalog '%s' for jobs group %s" , $cat, $job );
 721                 return undef;
 722         }
 723
 724         open_cat($cat);
 725
 726         logError("Run jobs group=%s pid=%s", $job || 'INTERNAL', $$);
 727
 728         Vend::Server::set_process_name("job $cat $job");
 729
 730         my $jobscfg = $Vend::Cfg->{Jobs};
 731
 732         my $dir;
 733         my @itl;
 734         if($job) {
 735                 my @jobdirs = ([$jobscfg->{base_directory} || 'etc/jobs', 0]);
 736
 737                 if (is_yes($jobscfg->{use_global}) || is_yes($Global::Jobs->{UseGlobal})) {
 738                         push (@jobdirs, ["$Global::ConfDir/jobs", 1]);
 739                 }
 740
 741                 my $global_dir;
 742                 for my $r (@jobdirs) {
 743                         my $d;
 744                         ($d, $global_dir) = @$r;
 745 #::logGlobal("check directory=$d for $job");
 746                         next unless $d;
 747                         next unless -d "$d/$job";
 748                         $dir = "$d/$job";
 749                         last;
 750                 }
 751
 752                 if($dir) {
 753                         my $tmp;
 754                         if ($global_dir) {
 755                                 $tmp = $Global::AllowedFileRegex->{$cat};
 756                                 $Global::AllowedFileRegex->{$cat} = qr{^$dir};
 757                         }
 758
 759                         my @f = glob("$dir/*");
 760                         @f = grep ! -d $_, @f;
 761                         @f = grep $_ !~ /$Vend::Cfg->{HTMLsuffix}$/, @f;
 762                         @f = grep $_ =~ /$jobscfg->{suffix}$/, @f;
 763                         for(@f) {
 764 #::logGlobal("found jobs piece file=$_");
 765                                 push @itl, [$_, readfile($_)];
 766                         }
 767
 768                         if ($global_dir) {
 769                                 $Global::AllowedFileRegex->{$cat} = $tmp;
 770                         }
 771                 }
 772         }
 773
 774         if ($itl) {
 775                 push @itl, ["Passed ITL", $itl];
 776         }
 777
 778         my (@out, $errors, $failure);
 779
 780         # remove bogus session created by logError
 781         undef $Vend::Session;
 782
 783         if(@itl) {
 784                 # Track job
 785                 my ($trackdb, $trackid);
 786
 787                 if ($jobscfg->{trackdb}) {
 788                         if ($trackdb = database_exists_ref($jobscfg->{trackdb})) {
 789                                 $trackid = $trackdb->set_slice('', [qw(name begin_run pid)],
 790                                                                                            [$job, Vend::Interpolate::mvtime(undef, {}, '%Y-%m-%d %H:%M'), $$]);
 791                         }
 792                         else {
 793                                 ::logError ("Invalid jobs tracking database $jobscfg->{trackdb}");
 794                         }
 795                 }
 796
 797                 eval {
 798                         # Run once at beginning
 799                         run_macro($jobscfg->{initialize});
 800
 801                         # initialize or autoload can create session
 802                         # but must handle all aspects
 803                         unless ($Vend::Session) {
 804                                 $CGI::values{mv_tmp_session} = 1;
 805                                 init_session();
 806                         }
 807
 808                         $CGI::remote_addr ||= 'none';
 809                         $CGI::useragent   ||= 'commandline';
 810
 811                         for(@itl) {
 812                                 # Run once at beginning of each job
 813                                 run_macro($jobscfg->{autoload});
 814
 815                                 push @out, interpolate_html($_->[1]);
 816
 817                                 # Run once at end of each job
 818                                 run_macro($jobscfg->{autoend});
 819                         }
 820                 };
 821
 822                 if ($@) {
 823                         # job terminated due to an error
 824                         $errors = 1;
 825
 826                         $failure = errmsg('Job terminated with an error: %s', $@);
 827                         logError ("Job group=%s pid=%s terminated with an error: %s", $job || 'INTERNAL', $$, $@);
 828
 829                         # remove flag for this job
 830                         Vend::Server::flag_job($$, $cat, 'furl');
 831                 }
 832
 833                 if ($trackid) {
 834                         $trackdb->set_field($trackid, 'end_run',
 835                                                                 Vend::Interpolate::mvtime(undef, {}, '%Y-%m-%d %H:%M'));
 836                 }
 837         }
 838         else {
 839                 logError("Empty job=%s", $job);
 840         }
 841         my $out = join "", @out;
 842         my $filter = $jobscfg->{filter} || 'strip';
 843         $out = Vend::Interpolate::filter_value($filter, $out);
 844         if ($errors && is_no($jobscfg->{ignore_errors})) {
 845                 $out = join("\n\n", $failure, $out);
 846         }
 847         $out .= full_dump() if is_yes($jobscfg->{add_session});
 848
 849         logError("Finished jobs group=%s pid=%s", $job || 'INTERNAL', $$);
 850
 851         close_cat();
 852
 853         # don't send email and/or write log entry if job returns
 854         # no output (in spirit of the cron daemon)
 855         return unless $out;
 856
 857         if(my $addr = $parms->{email} || $jobscfg->{email}) {
 858                 my $subject = $jobscfg->{subject} || 'Interchange results for job: %s';
 859                 $subject = errmsg($subject, $job);
 860                 my $from = $jobscfg->{from} || $Vend::Cfg->{MailOrderTo};
 861                 Vend::Interpolate::tag_mail($addr,
 862                                                                         {
 863                                                                                 from => $from,
 864                                                                                 to => $addr,
 865                                                                                 subject => $subject,
 866                                                                                 reply_to => $jobscfg->{reply_to},
 867                                                                                 mailer => "Interchange $::VERSION",
 868                                                                                 extra => $jobscfg->{extra_headers},
 869                                                                             log_error => 1,
 870                                                                         },
 871                                                                         $out,
 872                                                                 );
 873         }
 874
 875         if($jobscfg->{log}) {
 876                 logData($jobscfg->{log}, $out);
 877         }
 878
 879         return $out;
 880 }
 881
 882 sub adjust_cgi {
 883
 884     my($host);
 885
 886     die "REQUEST_METHOD is not defined" unless defined $CGI::request_method
 887                 or @Global::argv;
 888
 889         if ($Global::HostnameLookups && !$CGI::remote_host && $CGI::remote_addr && !$CGI::values{mv_tmp_session}) {
 890                 $CGI::remote_host = gethostbyaddr(Socket::inet_aton($CGI::remote_addr),Socket::AF_INET);
 891         }
 892
 893         # The great and really final AOL fix
 894         #
 895     $host      = $CGI::remote_host;
 896     $CGI::ip   = $CGI::remote_addr;
 897
 898         if($Global::DomainTail and $host) {
 899                 $host =~ /\.([A-Za-z]+)$/;
 900                 my $tld = $1;
 901
 902                 my $level = (defined($Global::CountrySubdomains->{$tld}) && $host =~ $Global::CountrySubdomains->{$tld}) ? 2 : 1;
 903
 904                 $host =~ s/.*?((?:[-A-Za-z0-9]+\.){$level}[A-Za-z]+)$/$1/;
 905         }
 906         elsif($Global::IpHead) {
 907                 $host = $Global::IpQuad == 0 ? 'nobody' : '';
 908                 my @ip;
 909                 @ip = split /\./, $CGI::ip;
 910                 $CGI::ip = '';
 911                 $CGI::ip = join ".", @ip[0 .. ($Global::IpQuad - 1)] if $Global::IpQuad;
 912         }
 913         #
 914         # end AOL fix
 915
 916         # Fix Cobalt/CGIwrap problem
 917     if($Global::Variable->{CGIWRAP_WORKAROUND}) {
 918         $CGI::path_info =~ s!^$CGI::script_name!!;
 919     }
 920
 921     $CGI::host = $host || $CGI::ip;
 922
 923     $CGI::user = $CGI::remote_user, undef $CGI::authorization
 924         if $CGI::remote_user;
 925
 926     if ($Global::FullUrl) {
 927         if ($Global::FullUrlIgnorePort or $CGI::server_port eq '80') {
 928             $CGI::server_port = '';
 929         }
 930         else {
 931             $CGI::server_port = ":$CGI::server_port";
 932         }
 933         $CGI::script_name = $CGI::server_name . $CGI::server_port . $CGI::script_path;
 934     }
 935     else {
 936         $CGI::script_name = $CGI::script_path;
 937     }
 938 }
 939
 940 use vars qw/@NoHistory/;
 941
 942 @NoHistory= qw/
 943                                         mv_credit_card_number
 944                                         mv_credit_card_cvv2
 945                                         mv_password
 946                                         mv_verify
 947                                 /;
 948
 949 sub url_history {
 950         $Vend::Session->{History} = []
 951                 unless defined $Vend::Session->{History};
 952         shift @{$Vend::Session->{History}}
 953                 if $#{$Vend::Session->{History}} >= $Vend::Cfg->{History};
 954         if( $CGI::values{mv_no_cache} ) {
 955                 push (@{$Vend::Session->{History}},  [ 'expired', {} ]);
 956         }
 957         else {
 958                 my @save;
 959                 for(@NoHistory) {
 960                         push @save, delete $CGI::values{$_};
 961                 }
 962
 963                 push (@{$Vend::Session->{History}},  [ $CGI::path_info, { %CGI::values } ]);
 964
 965                 for(my $i = 0; $i < @NoHistory; $i++) {
 966                         next unless defined $save[$i];
 967                         $CGI::values{$NoHistory[$i]} = $save[$i];
 968                 }
 969         }
 970         return;
 971 }
 972
 973 ## DISPATCH
 974
 975 # Parse the invoking URL and dispatch to the handling subroutine.
 976
 977 my %action = (
 978     process     => \&do_process,
 979         ui              => sub {
 980                                         &UI::Primitive::ui_acl_global();
 981                                         &do_process(@_);
 982                                    },
 983     scan        => \&do_scan,
 984     search      => \&do_search,
 985     order       => \&do_order,
 986     obtain      => \&do_order,
 987     silent      => sub {
 988                                                 $Vend::StatusLine = "Status: 204 No content";
 989                                                 my $extra_click = $Vend::FinalPath;
 990                                                 $extra_click =~ s:/:\0:g;
 991                                                 $CGI::values{mv_click} =  $CGI::values{mv_click}
 992                                                                                         ? "$CGI::values{mv_click}\0$extra_click"
 993                                                                                         :  $extra_click;
 994                                                 do_process(@_);
 995                                                 response('');
 996                                                 return 0;
 997                                         },
 998 );
 999
1000 sub update_global_actions {
1001         @action{keys %{$Global::ActionMap}} = (values %{$Global::ActionMap})
1002                 if $Global::ActionMap;
1003         @form_action{keys %{$Global::FormAction}} = (values %{$Global::FormAction})
1004                 if $Global::FormAction;
1005 }
1006
1007 sub open_cat {
1008         my ($cat, $http) = @_;
1009
1010         if($cat) {
1011                 %CGI::values = ();
1012                 if($Global::Catalog{$cat}) {
1013                         $CGI::script_path = $Global::Catalog{$cat}->{script};
1014                         $CGI::script_name = $CGI::script_path;
1015                 }
1016         }
1017
1018         unless (defined $Global::Selector{$CGI::script_name}) {
1019                 my $msg = get_locale_message(
1020                                                 404,
1021                                                 "Undefined catalog: %s",
1022                                                 $CGI::script_name || $cat,
1023                                                 );
1024                 $Vend::StatusLine = <<EOF;
1025 Status: 404 Not Found
1026 Content-Type: text/plain
1027 EOF
1028                 if($H) {
1029                         response($msg);
1030                 }
1031                 logGlobal($msg);
1032                 # No close_cat() necessary
1033                 return;
1034         }
1035
1036         if($Global::Foreground) {
1037                 my %hash;
1038                 tie %hash, 'Tie::ShadowHash', $Global::Selector{$CGI::script_name} ;
1039                 $Vend::Cfg = \%hash;
1040         }
1041         else {
1042                 $Vend::Cfg = $Global::Selector{$CGI::script_name};
1043         }
1044
1045         $Vend::Cat = $Vend::Cfg->{CatalogName};
1046         $Vend::ReadOnlyCfg = $Global::ReadOnlyCfg{$Vend::Cat};
1047
1048         my $catref = $Global::Catalog{$Vend::Cat};
1049         if(! $Global::Foreground and defined $catref->{directive}) {
1050                 no strict 'refs';
1051                 my ($key, $val);
1052                 while ( ($key, $val) = each %{$catref->{directive}}) {
1053 #::logDebug("directive key=$key val=" . ::uneval($val));
1054                         ${"Global::$key"} = $val;
1055                 }
1056         }
1057
1058         # See if it is a subcatalog
1059         if (defined $Vend::Cfg->{BaseCatalog}) {
1060                 my $name = $Vend::Cfg->{BaseCatalog};
1061                 my $ref = $Global::Catalog{$name};
1062                 my $c = $Vend::Cfg;
1063                 $Vend::Cfg = $Global::Selector{$ref->{'script'}};
1064                 for(keys %{$c->{Replace}}) {
1065                         undef $Vend::Cfg->{$_};
1066                 }
1067                 copyref $c, $Vend::Cfg;
1068                 if($Vend::Cfg->{Variable}{MV_LANG}) {
1069                         my $loc = $Vend::Cfg->{Variable}{MV_LANG};
1070                         $Vend::Cfg->{Locale} = $Vend::Cfg->{Locale_repository}{$loc}
1071                                         if defined $Vend::Cfg->{Locale_repository}{$loc};
1072                 }
1073         }
1074
1075         if ($Global::Foreground) {
1076                 my %hash;
1077                 tie %hash, 'Tie::ShadowHash', $Vend::Cfg->{Variable};
1078                 $::Variable = \%hash;
1079                 $::Pragma = { %{ $Vend::Cfg->{Pragma} } };
1080         }
1081         else {
1082                 $::Variable = $Vend::Cfg->{Variable};
1083                 $::Pragma = $Vend::Cfg->{Pragma};
1084         }
1085
1086         my $mt;
1087         if($Vend::Cfg->{DeliverImage}
1088                 and $CGI::request_method eq 'GET'
1089                 and $CGI::path_info =~ /\.(\w+)$/
1090                 and $mt = Vend::Util::mime_type($CGI::path_info)
1091                 and $mt =~ m{^image/}
1092           )
1093         {
1094
1095                 my $imgdir = $Vend::Cfg->{ImageDir};
1096                 my $fn = $CGI::path_info;
1097 #::logDebug("deliver image: method=$CGI::request_method type=$mt fn=$fn");
1098                 $fn =~ s:^/+::;
1099                 ## Won't resend any images beginning with admin/
1100                 $fn =~ s{^admin/}{};
1101                 if($CGI::secure) {
1102                          $imgdir = $Vend::Cfg->{ImageDirSecure}
1103                                 if $Vend::Cfg->{ImageDirSecure};
1104                 }
1105                 $Vend::tmp_session = 1;
1106                 Vend::Tags->deliver($mt, { location => "$imgdir$fn" } );
1107                 return;
1108         }
1109
1110         if (defined $Global::SelectorAlias{$CGI::script_name}) {
1111                 my $real = $Global::SelectorAlias{$CGI::script_name};
1112                 unless (        $CGI::secure                                        or
1113                                         $Vend::Cfg->{SecureURL} =~ m{$CGI::script_name$}     and
1114                                         $Vend::Cfg->{VendURL}   !~ m{/nph-[^/]+$}                    and
1115                                         $Vend::Cfg->{VendURL}   !~ m{$CGI::script_name$}                )
1116                 {
1117                         $Vend::Cfg->{VendURL}   =~ s!$real!$CGI::script_name!;
1118                         $Vend::Cfg->{SecureURL} =~ s!$real!$CGI::script_name!;
1119                 }
1120         }
1121
1122         if($Global::HitCount and ! $cat) {
1123                 my $ctr = new Vend::CounterFile
1124                                         "$Global::ConfDir/hits.$Vend::Cat";
1125         $ctr->inc();
1126         }
1127
1128         if ($Vend::Cfg->{SetGroup}) {
1129                 eval {
1130                         $) = "$Vend::Cfg->{SetGroup} $Vend::Cfg->{SetGroup}";
1131                 };
1132                 if ($@) {
1133                         my $msg = $@;
1134                         logGlobal( "Can't set group to GID %s: %s",
1135                                                 $Vend::Cfg->{SetGroup}, $msg
1136                                         );
1137                         logError("Can't set group to GID %s: %s",
1138                                                 $Vend::Cfg->{SetGroup}, $msg
1139                                         );
1140                 }
1141         }
1142
1143         if($Vend::Cfg->{XHTML}) {
1144                 $Vend::Xtrailer = ' /';
1145                 $Vend::Xquote = '"';
1146         }
1147         else {
1148                 $Vend::Xtrailer = '';
1149                 $Vend::Xquote = '';
1150         }
1151
1152         $::Limit = $Vend::Cfg->{Limit} || {};
1153
1154         chdir $Vend::Cfg->{VendRoot}
1155                 or die "Couldn't change to $Vend::Cfg->{VendRoot}: $!\n";
1156         POSIX::setlocale(POSIX::LC_ALL, $Vend::Cfg->{ExecutionLocale});
1157         set_file_permissions();
1158         umask $Vend::Cfg->{Umask};
1159
1160         Vend::Server::parse_cgi($http) unless $Global::mod_perl;
1161
1162 #show_times("end cgi and config mapping") if $Global::ShowTimes;
1163         open_database();
1164
1165         if (my $subname = $Vend::Cfg->{SpecialSub}{request_init}) {
1166 #::logDebug(errmsg("running subroutine '%s' for %s", $subname, 'request_init'));
1167                 my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
1168                 my $status;
1169                 eval {
1170                         $status = $sub->();
1171                 };
1172
1173                 if($@) {
1174                         ::logError("Error running %s subroutine %s: %s", 'request_init', $subname, $@);
1175                 }
1176         }
1177
1178 #show_times("end open_database") if $Global::ShowTimes;
1179         return 1;
1180 }
1181
1182 sub close_cat {
1183         put_session() if $Vend::HaveSession;
1184         close_session() if $Vend::SessionOpen;
1185         close_database();
1186         return;
1187 }
1188
1189 sub run_macro {
1190         my $macro = shift
1191                 or return;
1192         my $content_ref = shift;
1193         my $inspect_sub = shift;
1194
1195         my @mac;
1196         if(ref $macro eq 'ARRAY') {
1197                 @mac = @$macro;
1198         }
1199         elsif ($macro =~ /^[-\s\w,]+$/) {
1200                 @mac = grep /\S/, split /[\s,]+/, $macro;
1201         }
1202         else {
1203                 push @mac, $macro;
1204         }
1205
1206         for my $m (@mac) {
1207                 my $ret;
1208
1209                 if ($m =~ /^\w+$/) {
1210                         my $sub = $Vend::Cfg->{Sub}{$m} || $Global::GlobalSub->{$m}
1211                                 or do {
1212                                         my $call = join(',', caller());
1213
1214                                         my $msg = errmsg("Unknown macro '%s' from %s.", $m, $call);
1215                                         if($Vend::Cfg->{CatalogName}) {
1216                                                 logError($msg);
1217                                         }
1218                                         else {
1219                                                 logGlobal($msg);
1220                                         }
1221                                         next;
1222                                 };
1223                         $ret = $sub->($content_ref);
1224                 }
1225                 elsif($m =~ /^\w+-\w+$/) {
1226                         $ret = Vend::Interpolate::tag_profile($m);
1227                 }
1228                 else {
1229                         $ret = interpolate_html($m);
1230                 }
1231
1232                 if ($inspect_sub) {
1233                         unless ($inspect_sub->($m, $ret)) {
1234                                 last;
1235                         }
1236                 }
1237         }
1238 }
1239
1240 sub dispatch {
1241         my($http) = @_;
1242         $H = $http;
1243
1244         adjust_cgi();
1245
1246         ## If returns false then was a 404 no catalog or a delivered image
1247         open_cat('', $http) or return 1;
1248
1249         Vend::Server::set_process_name("$Vend::Cat $CGI::host");
1250
1251         run_macro($Vend::Cfg->{Preload});
1252
1253         $CGI::user = Vend::Util::check_authorization($CGI::authorization)
1254                 if defined $CGI::authorization;
1255
1256         my($sessionid, $seed);
1257
1258         $sessionid = $CGI::values{mv_session_id} || undef
1259                 and $sessionid =~ s/\0.*//s;
1260
1261         # save for robot check with explicit session id
1262         my $sessionid_from_cgi = $sessionid;
1263
1264         $::Instance->{CookieName} = $Vend::Cfg->{CookieName};
1265
1266         if($CGI::values{mv_tmp_session}) {
1267 #::logDebug("setting tmp_session");
1268                 $Vend::tmp_session = $Vend::new_session = 1;
1269                 $sessionid = 'nsession';
1270                 $Vend::Cookie = 1;
1271                 $Vend::Cfg->{ScratchDefault}{mv_no_count} = 1;
1272                 $Vend::Cfg->{ScratchDefault}{mv_no_session_id} = 1;
1273         }
1274         elsif ($sessionid and $CGI::values{mv_force_session}) {
1275                 # do nothing
1276         }
1277         elsif ($::Instance->{CookieName} and defined $CGI::cookie) {
1278                 $CGI::cookie =~ m{$::Instance->{CookieName}=($Vend::Cfg->{CookiePattern})};
1279                 $seed = $sessionid = $1;
1280                 $::Instance->{ExternalCookie} = $sessionid || 1;
1281                 $Vend::CookieID = $Vend::Cookie = 1;
1282         }
1283         elsif (defined $CGI::cookie and $CGI::cookie =~ /\bMV_SESSION_ID=(\w{8,32})[:_]([-\@.:A-Za-z0-9]+?)\b/) {
1284           SESSION_COOKIE: {
1285               my $id = $1;
1286               my $host = $2;
1287               if (is_ipv4($host) || is_ipv6($host)) {
1288                   $CGI::cookiehost = $host;
1289               }
1290               elsif ($host =~ /[A-Za-z0-9][-\@A-Za-z.0-9]+/) {
1291                   $CGI::cookieuser = $host;
1292               }
1293               else {
1294                   last SESSION_COOKIE;
1295               }
1296
1297               $sessionid = $id;
1298               $Vend::CookieID = $Vend::Cookie = 1;
1299             }
1300         }
1301
1302         Vend::Server::set_process_name("$Vend::Cat $CGI::host $sessionid");
1303
1304         $::Instance->{CookieName} = 'MV_SESSION_ID' if ! $::Instance->{CookieName};
1305
1306         $CGI::host = 'nobody' if $Vend::Cfg->{WideOpen};
1307
1308         if(! $sessionid) {
1309                 if(my $id = $::Variable->{MV_SESSION_ID}) {
1310                         $sessionid = $CGI::values{$id} if $CGI::values{$id};
1311                 }
1312
1313                 if(! $sessionid and $CGI::redirect_status and $Vend::Cfg->{RedirectCache}) {
1314                         $Vend::tmp_session = $Vend::new_session = 1;
1315                         $sessionid = 'nsession';
1316                         $Vend::Cookie = 1;
1317                         $Vend::Cfg->{ScratchDefault}{mv_no_count} = 1;
1318                         $Vend::Cfg->{ScratchDefault}{mv_no_session_id} = 1;
1319                         $Vend::write_redirect = 1;
1320                 }
1321
1322                 if (! $sessionid and $Vend::Cfg->{FallbackIP}) {
1323                         $sessionid = generate_key($CGI::remote_addr . $CGI::useragent);
1324                 }
1325
1326         }
1327         elsif (! $::Instance->{ExternalCookie} and $sessionid !~ /^\w+$/) {
1328                 my $msg = get_locale_message(
1329                                                 403,
1330                                                 "Malformed session identifier",
1331                                                 );
1332                 $Vend::StatusLine = <<EOF;
1333 Status: 403 Unauthorized
1334 Content-Type: text/plain
1335 EOF
1336                 response($msg);
1337                 logGlobal("$msg: $sessionid");
1338                 close_cat();
1339                 return;
1340         }
1341
1342 # DEBUG
1343 #::logDebug ("session='$sessionid' cookie='$CGI::cookie' chost='$CGI::cookiehost'");
1344 # END DEBUG
1345
1346 RESOLVEID: {
1347     if ($sessionid) {
1348                 $Vend::SessionID = $sessionid;
1349         $Vend::SessionName = session_name();
1350                 if($Vend::tmp_session) {
1351                         $Vend::Session = {};
1352                         init_session;
1353                         last RESOLVEID;
1354                 }
1355                 # get_session will return a value if a session is read,
1356                 # if not it will return false and a new session has been created.
1357                 # The IP address will be counted for robot_resolution
1358                 if(! get_session($seed) and ! $::Instance->{ExternalCookie}) {
1359                         retire_id($sessionid);
1360                         last RESOLVEID;
1361                 }
1362                 my $now = time;
1363                 if(! $Vend::CookieID) {
1364                         if( is_retired($sessionid) ) {
1365                                 new_session();
1366                                 last RESOLVEID;
1367                         }
1368                         my $compare_host        = $CGI::secure
1369                                                                 ? ($Vend::Session->{shost})
1370                                                                 : ($Vend::Session->{ohost});
1371
1372                         if($Vend::Cfg->{WideOpen}) {
1373                                 # do nothing, no host checking
1374                         }
1375                         elsif(! $compare_host) {
1376                                 if ($CGI::secure) {
1377                                     $Vend::Session->{shost} = $CGI::remote_addr;
1378                                 }
1379                                 else {
1380                                     new_session($seed);
1381                                     init_session();
1382                                 }
1383                         }
1384                         elsif ($compare_host ne $CGI::remote_addr) {
1385                                 new_session($seed);
1386                                 init_session();
1387                         }
1388                 }
1389                 if ($now - $Vend::Session->{'time'} > $Vend::Cfg->{SessionExpire}) {
1390                         if($::Instance->{ExternalCookie}) {
1391                                 init_session();
1392                         }
1393                         else {
1394                                 retire_id($sessionid);
1395                                 new_session();
1396                         }
1397                         last RESOLVEID;
1398                 }
1399                 elsif($Vend::Cfg->{RobotLimit}) {
1400                         if ($now - $Vend::Session->{'time'} > ($::Limit->{lockout_reset_seconds} || 30) ) {
1401                                 $Vend::Session->{accesses} = 0;
1402                         }
1403                         else {
1404                                 $Vend::Session->{accesses}++;
1405 #::logDebug("accesses=$Vend::Session->{accesses} admin=$Vend::admin");
1406                                 if($Vend::Session->{accesses} > $Vend::Cfg->{RobotLimit}
1407                                         and ! $Vend::admin
1408                                         )
1409                                 {
1410                                         do_lockout();
1411                                 }
1412                         }
1413                 }
1414         } else {
1415             if (Vend::Session::count_ip() && !do_lockout()) {
1416                 my $msg;
1417                 # Here they can get it back if they pass expiration time
1418                 my $wait = $::Limit->{robot_expire} || 1;
1419                 $wait *= 24;
1420                 $msg = errmsg(<<EOF, $wait);
1421 Too many new ID assignments for this IP address. Please wait at least %d hours
1422 before trying again. Only waiting that period will allow access. Terminating.
1423 EOF
1424                 $msg = get_locale_message(403, $msg);
1425
1426                 ::logError('Too many IDs, %d hour wait enforced.', $wait);
1427
1428                 $Vend::StatusLine = <<EOF;
1429 Status: 403 Forbidden
1430 Content-Type: text/plain
1431 EOF
1432                 response($msg);
1433                 close_cat();
1434                 return;
1435             }
1436             new_session();
1437         }
1438
1439 }
1440
1441 #::logDebug("session name='$Vend::SessionName'\n");
1442
1443         $Vend::Calc_initialized = 0;
1444         $CGI::values{mv_session_id} = $Vend::Session->{id} = $Vend::SessionID;
1445
1446         if($Vend::admin and my $subname = $Vend::Cfg->{SpecialSub}{admin_init}) {
1447                 my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
1448                 eval {
1449                         $sub->();
1450                 };
1451
1452                 if($@) {
1453                         ::logError("Error running %s subroutine %s: %s", 'admin_init', $subname, $@);
1454                 }
1455         }
1456
1457         if(my $vspace = $CGI::values{mv_values_space}) {
1458                 $::Values = $Vend::Session->{values_repository}{$vspace} ||= {};
1459                 $Vend::ValuesSpace = $vspace;
1460         }
1461
1462         $Vend::Session->{'arg'} = $Vend::Argument = ($CGI::values{mv_arg} || undef);
1463
1464         my ($new_source, $already_expired);
1465       SOURCEPRIORITY: {
1466      if ($CGI::values{mv_pc} and $CGI::values{mv_pc} eq 'RESET') {
1467          $Vend::Session->{source} = '';
1468
1469          # Expire cookie, if applicable.
1470          if ( length ($Vend::Cfg->{SourceCookie}{name}) ) {
1471              my $sc = $Vend::Cfg->{SourceCookie};
1472              Vend::Util::set_cookie(
1473                 $sc->{name},
1474                 '',
1475                 1,
1476                 @{$sc}{qw(domain path secure)}
1477             );
1478             $already_expired = 1;
1479          }
1480
1481          last SOURCEPRIORITY;
1482      }
1483
1484 #::logDebug('$Session->{source} before SourcePriority loop: %s', $Vend::Session->{source});
1485      foreach (@{$Vend::Cfg->{SourcePriority}}) {
1486 #::logDebug("Looking at $_");
1487          if ($_ eq 'mv_pc') {
1488 #::logDebug('$CGI::values{mv_pc} is %s', $CGI::values{mv_pc});
1489             if ($CGI::values{mv_pc} and $CGI::values{mv_pc} =~ /\D/) {
1490                 $new_source = $CGI::values{mv_pc};
1491                 $new_source =~ s/[\r\n\t]//g;
1492                 $Vend::Session->{source} = $new_source;
1493                 last SOURCEPRIORITY;
1494             }
1495          }
1496
1497          elsif (/^cookie-(.+)/) {
1498              my $cookie_source = Vend::Util::read_cookie($1);
1499 #::logDebug("Cookie $1 is $cookie_source");
1500              if (length $cookie_source) {
1501                  $cookie_source =~ s/[\r\n\t]//g;
1502                  $Vend::Session->{source} = $cookie_source;
1503                  last SOURCEPRIORITY;
1504             }
1505          }
1506
1507          elsif ($_ eq 'session') {
1508 #::logDebug('$sessionid is %s', $sessionid);
1509             if ($sessionid) {
1510                 last SOURCEPRIORITY;
1511             }
1512          }
1513
1514          elsif (/^session-(.+)/) {
1515 #::logDebug('$Session->{%s} is %s', $1, $Vend::Session->{$1});
1516             if (length $Vend::Session->{$1}) {
1517                 last SOURCEPRIORITY;
1518             }
1519          }
1520
1521          else {
1522 #::logDebug('$CGI::values{%s} is %s', $_, $CGI::values{$_});
1523             if (length $CGI::values{$_}) {
1524                 $new_source = $CGI::values{$_};
1525                 $new_source =~ s/[\r\n\t]//g;
1526                 $Vend::Session->{source} = $new_source;
1527                 last SOURCEPRIORITY;
1528             }
1529          }
1530      }
1531     } #SOURCEPRIORITY
1532 #::logDebug('$Session->{source} after SourcePriority loop: %s', $Vend::Session->{source});
1533
1534     # Set a cookie if applicable.
1535     if (
1536         # Obviously must be true
1537         length ($Vend::Cfg->{SourceCookie}{name})
1538         and
1539
1540         # and, we didn't already clear it in SOURCEPRIORITY
1541         ! $already_expired
1542         and
1543
1544             # any time we have a new source, we want to
1545             # reset--even if it's unchanged from the last
1546             # value to reset the expiration
1547             length ($new_source)
1548             ||
1549
1550             # or, our cookie is different from $Session->{source},
1551             # whatever the reason
1552             Vend::Util::read_cookie($Vend::Cfg->{SourceCookie}{name})
1553                 ne
1554             $Vend::Session->{source}
1555             ||
1556
1557             # or
1558             (
1559                 # there's something in source worth preserving,
1560                 length ($Vend::Session->{source})
1561                 &&
1562
1563                 # and we want the expiration reset with every access,
1564                 $Vend::Cfg->{SourceCookie}{autoreset}
1565             )
1566     ) {
1567
1568         my $sc = $Vend::Cfg->{SourceCookie};
1569 #::logDebug('Resetting SourceCookie %s to %s', $sc->{name}, $Vend::Session->{source});
1570         Vend::Util::set_cookie(
1571             $sc->{name},
1572             $Vend::Session->{source},
1573             @{$sc}{qw(expire domain path secure)}
1574         );
1575     }
1576
1577         if (
1578                 ($new_source
1579                 and $CGI::request_method eq 'GET'
1580                 and ($Vend::Cfg->{BounceReferrals} or
1581              ($Vend::Robot and $Vend::Cfg->{BounceReferralsRobot}))) or
1582                 ($Vend::Robot and $sessionid_from_cgi and $Vend::Cfg->{BounceRobotSessionURL})
1583         ) {
1584                 my $path = $CGI::path_info;
1585                 $path =~ s:^/::;
1586                 my $form =
1587                         join '',
1588                         map { "$_=$CGI::values{$_}\n" }
1589                         grep { !$Vend::Cfg->{BounceReferrals_hide}->{$_} }
1590                         sort keys %CGI::values;
1591                 my $url = vendUrl($path eq '' ? $Vend::Cfg->{DirectoryIndex} : $path, undef, undef, { form => $form, match_security => 1 });
1592                 $url = header_data_scrub($url);
1593                 my $msg = get_locale_message(
1594                         301,
1595                         "Redirected to %s.",
1596                         $url,
1597                 );
1598                 $Vend::StatusLine = <<EOF;
1599 Status: 301 Moved
1600 Location: $url
1601 Content-Type: text/plain
1602
1603 Redirecting to $url
1604 EOF
1605                 response($msg);
1606 #::logDebug("bouncing to $url");
1607                 close_cat();
1608                 return;
1609         }
1610
1611         $Vend::Session->{'user'} = $CGI::user;
1612
1613         Vend::Server::set_process_name("$Vend::Cat $CGI::host $sessionid " . $Vend::Session->{username} || '-');
1614
1615         $CGI::pragma = 'no-cache'
1616                 if delete $::Scratch->{mv_no_cache};
1617 #show_times("end session get") if $Global::ShowTimes;
1618
1619         $Vend::FinalPath = $Vend::Session->{last_url} = $CGI::path_info;
1620
1621         if( defined $Vend::Session->{path_alias}{$Vend::FinalPath}      ) {
1622                 $CGI::path_info
1623                                         = $Vend::FinalPath
1624                                         = $Vend::Session->{path_alias}{$Vend::FinalPath};
1625                 delete $Vend::Session->{path_alias}{$Vend::FinalPath}
1626                         if delete $Vend::Session->{one_time_path_alias}{$Vend::FinalPath};
1627         }
1628
1629         url_history($Vend::FinalPath) if $Vend::Cfg->{History};
1630
1631         Vend::Server::set_process_name("$Vend::Cat $CGI::host $sessionid " . ($Vend::Session->{username} || '-') . " $Vend::FinalPath");
1632
1633 # TRACK
1634         $Vend::Track = Vend::Track->new
1635                 if ($Vend::Cfg->{UserTrack} or $Vend::Cfg->{TrackFile})
1636                         and not ($Vend::admin and ! $::Variable->{MV_TRACK_ADMIN});
1637 # END TRACK
1638
1639         if($Vend::Cfg->{DisplayErrors} and $Global::DisplayErrors) {
1640                 $SIG{"__DIE__"} = sub {
1641                                                         my $msg = shift;
1642                                                         put_session() if $Vend::HaveSession;
1643                                                         my $content = get_locale_message(500, <<EOF, $msg);
1644 <html><head><title>Fatal Interchange Error</title></head><body>
1645 <h1>FATAL error</h1>
1646 <pre>%s</pre>
1647 </body></html>
1648 EOF
1649                                                         response(\$content);
1650                                                         exit 0;
1651                 };
1652         }
1653
1654         # Do it here so we can use autoloads and such
1655         Vend::Interpolate::reset_calc() if $Global::Foreground;
1656         Vend::Interpolate::init_calc();
1657         new Vend::Tags;
1658         new Vend::Parse;        # enable catalog usertags within dispatch routines
1659 # LEGACY
1660         ROUTINES: {
1661                 last ROUTINES unless index($Vend::FinalPath, "/$Vend::Cfg->{ProcessPage}/") == 0;
1662                 while ($Vend::FinalPath =~ s{/$Vend::Cfg->{ProcessPage}/(locale|language|currency)/([^/]*)/}{/$Vend::Cfg->{ProcessPage}/}) {
1663                         $::Scratch->{"mv_$1"} = $2;
1664                 }
1665                 $Vend::FinalPath =~ s{/$Vend::Cfg->{ProcessPage}/page/}{/};
1666         }
1667
1668         if(my $locale = $::Scratch->{mv_language}) {
1669                 $Global::Variable->{LANG}
1670                         = $::Variable->{LANG} = $locale;
1671         }
1672 # END LEGACY
1673
1674         for my $routine (@{$Vend::Cfg->{DispatchRoutines}}) {
1675                 $routine->();
1676                 if ($Vend::Sent) {
1677                         close_cat();
1678                         return;
1679                 }
1680         }
1681 #show_times("end DispatchRoutines") if $Global::ShowTimes;
1682
1683         for my $macro ( $Vend::Cfg->{Filter}, $Vend::Session->{Filter}) {
1684                 next unless $macro;
1685                 if (ref($macro) ne 'HASH') {
1686                         logError("Bad CGI filter '%s'", $macro);
1687                         next;
1688                 }
1689                 for(keys %$macro) {
1690                         Vend::Interpolate::input_filter_do($_, { op => $macro->{$_} } );
1691                 }
1692         }
1693
1694         ## Here we initialize new features
1695         if(my $ary = $Vend::Cfg->{Init}) {
1696                 undef $Vend::Cfg->{Init};
1697                 for(@$ary) {
1698                         my ($source, $touch) = @$_;
1699                         next if -f $touch;
1700                         open INITOUT, "> $touch"
1701                                 or do {
1702                                         ::logError(
1703                                                 "Unable to open init file %s for feature init", $touch,
1704                                                 );
1705                                         next;
1706                                 };
1707                         my $out;
1708                         eval {
1709                                 $out = Vend::Interpolate::interpolate_html(
1710                                                                         Vend::Util::readfile($source)
1711                                                   );
1712                         };
1713                         if($@) {
1714                                 $out .= $@;
1715                         }
1716                         print INITOUT errmsg(
1717                                                         "Results of init at %s: ",
1718                                                         POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime()),
1719                                                         );
1720                         print INITOUT $out;
1721                         close INITOUT;
1722                 }
1723         }
1724
1725         run_macro($Vend::Session->{Autoload});
1726 #show_times("end session Autoload macro") if $Global::ShowTimes;
1727
1728     # If the cgi-bin program was invoked with no extra path info,
1729     # just display the catalog page.
1730     if (! $Vend::FinalPath || $Vend::FinalPath =~ m:^/+$:) {
1731 #::logDebug("request_uri=$CGI::request_uri script_path=$CGI::script_path");
1732         if($CGI::request_uri !~ /^$CGI::script_path/) {
1733             $Vend::FinalPath = $CGI::request_uri;
1734             # remove any trailing query string
1735             $Vend::FinalPath =~ s/\?.*//;
1736 #::logDebug("FinalPath now $Vend::FinalPath");
1737         }
1738         else {
1739             $Vend::FinalPath = find_special_page('catalog');
1740         }
1741     }
1742
1743         if($CGI::put_ref and my $act = $Vend::Cfg->{Special}{put_handler} ) {
1744                 $Vend::FinalPath =~ s:^/*:$act/:;
1745         }
1746
1747         $Vend::FinalPath =~ s:^/+::;
1748         $Vend::FinalPath =~ s/(\.html?)$//
1749                 and $Vend::Extension = $1;
1750         $Vend::Session->{extension} = $1 || '';
1751
1752         my $record;
1753         my $adb;
1754
1755         if(ref $Vend::Session->{alias_table}) {
1756                 $record = $Vend::Session->{alias_table}{$Vend::FinalPath};
1757                 $Vend::Cfg->{AliasTable} ||= 'alias';
1758         }
1759
1760         if(
1761                 $Vend::Cfg->{AliasTable}
1762                         and
1763                 $record
1764                         or
1765                 (
1766                         $adb = database_exists_ref($Vend::Cfg->{AliasTable})
1767                           and
1768                         $record = $adb->row_hash($Vend::FinalPath)
1769                 )
1770          )
1771         {
1772                 $Vend::FinalPath = $record->{real_page};
1773
1774                 # This prevents filesystem access when we never want it
1775                 # If base page is not passed we allow normal resolution
1776                 $record->{base_page}
1777                         and $Vend::ForceFlypage = $record->{base_page};
1778
1779                 my $ref;
1780
1781                 ## Here we populate CGI variables if desired
1782                 ## Explicitly passed variables override this
1783                 if(
1784                         $record->{base_control}
1785                                 and
1786                         $ref = get_option_hash($record->{base_control})
1787                   )
1788                 {
1789                         for(keys %$ref) {
1790                                 next if defined $CGI::values{$_};
1791                                 $CGI::values{$_} = $ref->{$_};
1792                         }
1793                 }
1794
1795         }
1796
1797 #::logDebug("path=$Vend::FinalPath mv_action=$CGI::values{mv_action}");
1798
1799   DOACTION: {
1800         if (defined $CGI::values{mv_action}) {
1801                 $CGI::values{mv_todo} = $CGI::values{mv_action}
1802                         if ! defined $CGI::values{mv_todo}
1803                         and ! defined $CGI::values{mv_doit};
1804                 $Vend::Action = $CGI->{mv_ui} ? 'ui' : 'process';
1805                 $CGI::values{mv_nextpage} = $Vend::FinalPath
1806                         if ! defined $CGI::values{mv_nextpage};
1807         }
1808         else {
1809                 ($Vend::Action) = $Vend::FinalPath =~ m{\A([^/]*)};
1810                 $Vend::Action =~ s/-/_/g; # allow hyphens as synonyms for underscores for SEO prettiness
1811         }
1812
1813 #::logGlobal("action=$Vend::Action path=$Vend::FinalPath");
1814         my ($sub, $status);
1815         if(defined $Vend::Cfg->{ActionMap}{$Vend::Action}) {
1816                 $sub = $Vend::Cfg->{ActionMap}{$Vend::Action};
1817                 $CGI::values{mv_nextpage} = $Vend::FinalPath
1818                         if ! defined $CGI::values{mv_nextpage};
1819                 new Vend::Parse;
1820         }
1821         else {
1822                 $sub = $action{$Vend::Action};
1823         }
1824
1825 #show_times("end path/action resolve") if $Global::ShowTimes;
1826
1827         eval {
1828                 if(defined $sub) {
1829                         $status = $sub->($Vend::FinalPath);
1830 #show_times("end action") if $Global::ShowTimes;
1831                 }
1832                 else {
1833                         $status = 1;
1834                 }
1835         };
1836         (undef $Vend::RedoAction, redo DOACTION) if $Vend::RedoAction;
1837
1838         if($@) {
1839                 undef $status;
1840                 my $err = $@;
1841                 my $template = <<EOF;
1842 Sorry, there was an error in processing this form action. Please
1843 report the error or try again later.
1844 EOF
1845                 $template .= "\n\nError: %s\n"
1846                                 if $Global::DisplayErrors && $Vend::Cfg->{DisplayErrors}
1847                         ;
1848                 $template = get_locale_message(500, $template, $err);
1849                 $template .= "($err)";
1850                 undef $Vend::write_redirect;
1851                 response($template);
1852         }
1853
1854         $CGI::values{mv_nextpage} = $Vend::FinalPath
1855                 if ! defined $CGI::values{mv_nextpage};
1856
1857         do_page() if $status;
1858 #show_times("end page display") if $Global::ShowTimes;
1859
1860         for my $routine (@{$Vend::Cfg->{CleanupRoutines}}) {
1861                 $routine->();
1862         }
1863   }
1864
1865 # TRACK
1866         $Vend::Track->filetrack() if $Vend::Track;
1867 # END TRACK
1868
1869         close_cat();
1870
1871         Vend::Server::set_process_name('done');
1872
1873         undef $H;
1874
1875 #show_times("end dispatch cleanup") if $Global::ShowTimes;
1876
1877         return 1;
1878 }
1879
1880 1;
1881 __END__
1882