lib/Vend/Util.pm

   1 # Vend::Util - Interchange utility functions
   2 #
   3 # Copyright (C) 2002-2009 Interchange Development Group
   4 # Copyright (C) 1996-2002 Red Hat, Inc.
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; 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::Util;
  25 require Exporter;
  26
  27 unless( $ENV{MINIVEND_DISABLE_UTF8} ) {
  28         require Encode;
  29         import Encode qw( is_utf8 encode_utf8 );
  30 }
  31
  32 @ISA = qw(Exporter);
  33
  34 @EXPORT = qw(
  35         adjust_time
  36         catfile
  37         check_security
  38         copyref
  39         currency
  40         dbref
  41         dump_structure
  42         errmsg
  43         escape_chars
  44         evalr
  45         dotted_hash
  46         file_modification_time
  47         file_name_is_absolute
  48         find_special_page
  49         format_log_msg
  50         generate_key
  51         get_option_hash
  52         hash_string
  53         header_data_scrub
  54         hexify
  55         is_hash
  56         is_ipv4
  57         is_ipv6
  58         is_no
  59         is_yes
  60         l
  61         lockfile
  62         logData
  63         logDebug
  64         logError
  65         logGlobal
  66         logOnce
  67         logtime
  68         random_string
  69         readfile
  70         readin
  71         round_to_frac_digits
  72         secure_vendUrl
  73         send_mail
  74         setup_escape_chars
  75         set_lock_type
  76         show_times
  77         string_to_ref
  78         tag_nitems
  79         timecard_stamp
  80         timecard_read
  81         backtrace
  82         uneval
  83         uneval_it
  84         uneval_fast
  85         unhexify
  86         unlockfile
  87         vendUrl
  88 );
  89
  90 use strict;
  91 no warnings qw(uninitialized numeric);
  92 use Config;
  93 use Fcntl;
  94 use Errno;
  95 use Text::ParseWords;
  96 require HTML::Entities;
  97 use Vend::Safe;
  98 use Vend::File;
  99 use subs qw(logError logGlobal);
 100 use vars qw($VERSION @EXPORT @EXPORT_OK);
 101 $VERSION = substr(q$Revision: 2.127 $, 10);
 102
 103 my $Eval_routine;
 104 my $Eval_routine_file;
 105 my $Pretty_uneval;
 106 my $Fast_uneval;
 107 my $Fast_uneval_file;
 108
 109 ### END CONFIGURABLE MODULES
 110
 111 ## ESCAPE_CHARS
 112
 113 $ESCAPE_CHARS::ok_in_filename =
 114                 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
 115                 'abcdefghijklmnopqrstuvwxyz' .
 116                 '0123456789'                             .
 117                 '-:_.$/'
 118         ;
 119
 120 $ESCAPE_CHARS::ok_in_url =
 121                 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
 122                 'abcdefghijklmnopqrstuvwxyz' .
 123                 '0123456789'                             .
 124                 '-_./~='
 125         ;
 126
 127 ## This is a character class for HTML::Entities
 128 $ESCAPE_CHARS::std = qq{^\n\t\X !\#\$%\'-;=?-Z\\\]-~};
 129
 130 ## Some standard error templates
 131
 132 ## This is an alias for a commonly-used function
 133 *dbref = \&Vend::Data::database_exists_ref;
 134
 135 my $need_escape;
 136
 137 sub setup_escape_chars {
 138     my($ok, $i, $a, $t);
 139
 140         ## HTML::Entities caches this, let's get it cached right away so
 141         ## each child doesn't have to re-eval
 142         my $junk = ">>>123<<<";
 143         HTML::Entities::encode($junk, $ESCAPE_CHARS::std);
 144
 145     foreach $i (0..255) {
 146         $a = chr($i);
 147         if (index($ESCAPE_CHARS::ok_in_filename,$a) == -1) {
 148                         $t = '%' . sprintf( "%02X", $i );
 149         }
 150                 else {
 151                         $t = $a;
 152         }
 153         $ESCAPE_CHARS::translate[$i] = $t;
 154         if (index($ESCAPE_CHARS::ok_in_url,$a) == -1) {
 155                         $t = '%' . sprintf( "%02X", $i );
 156         }
 157                 else {
 158                         $t = $a;
 159         }
 160         $ESCAPE_CHARS::translate_url[$i] = $t;
 161     }
 162
 163         my $string = "[^$ESCAPE_CHARS::ok_in_url]";
 164         $need_escape = qr{$string};
 165 }
 166
 167 # Replace any characters that might not be safe in a filename (especially
 168 # shell metacharacters) with the %HH notation.
 169
 170 sub escape_chars {
 171     my($in) = @_;
 172     my($c, $r);
 173
 174     $r = '';
 175     foreach $c (split(m{}, $in)) {
 176                 $r .= $ESCAPE_CHARS::translate[ord($c)];
 177     }
 178
 179     # safe now
 180     return $r;
 181 }
 182
 183 # Replace any characters that might not be safe in an URL
 184 # with the %HH notation.
 185
 186 sub escape_chars_url {
 187     my($in) = @_;
 188         return $in unless $in =~ $need_escape;
 189     my($c, $r);
 190
 191     $r = '';
 192     foreach $c (split(m{}, $in)) {
 193                 $r .= $ESCAPE_CHARS::translate_url[ord($c)];
 194     }
 195
 196     # safe now
 197     return $r;
 198 }
 199
 200 # Returns its arguments as a string of tab-separated fields.  Tabs in the
 201 # argument values are converted to spaces.
 202
 203 sub tabbed {
 204     return join("\t", map { $_ = '' unless defined $_;
 205                             s/\t/ /g;
 206                             $_;
 207                           } @_);
 208 }
 209
 210 # Returns time in HTTP common log format
 211 sub logtime {
 212     return POSIX::strftime("[%d/%B/%Y:%H:%M:%S %z]", localtime());
 213 }
 214
 215 sub format_log_msg {
 216         my($msg) = @_;
 217         my(@params);
 218
 219         # IP, Session, REMOTE_USER (if any) and time
 220     push @params, ($CGI::remote_host || $CGI::remote_addr || '-');
 221         push @params, ($Vend::SessionName || '-');
 222         push @params, ($CGI::user || '-');
 223         push @params, logtime() unless $Global::SysLog;
 224
 225         # Catalog name
 226         my $string = ! defined $Vend::Cfg ? '-' : ($Vend::Cat || '-');
 227         push @params, $string;
 228
 229         # Path info and script
 230         $string = $CGI::script_name || '-';
 231         $string .= $CGI::path_info || '';
 232         push @params, $string;
 233
 234         # Message, quote newlined area
 235         $msg =~ s/\n/\n> /g;
 236         push @params, $msg;
 237         return join " ", @params;
 238 }
 239
 240 sub round_to_frac_digits {
 241         my ($num, $digits) = @_;
 242         if (defined $digits) {
 243                 # use what we were given
 244         }
 245         elsif ( $Vend::Cfg->{Locale} ) {
 246                 $digits = $Vend::Cfg->{Locale}{frac_digits};
 247                 $digits = 2 if ! defined $digits;
 248         }
 249         else {
 250                 $digits = 2;
 251         }
 252         my @frac;
 253         $num =~ /^(-?)(\d*)(?:\.(\d+))?$/
 254                 or return $num;
 255         my $sign = $1 || '';
 256         my $int = $2;
 257         @frac = split(m{}, ($3 || 0));
 258         local($^W) = 0;
 259         my $frac = join "", @frac[0 .. $digits - 1];
 260         if($frac[$digits] > 4) {
 261                 $frac++;
 262         }
 263         if(length($frac) > $digits) {
 264                 $int++;
 265                 $frac = 0 x $digits;
 266         }
 267         $frac .= '0' while length($frac) < $digits;
 268         return "$sign$int.$frac";
 269 }
 270
 271 use vars qw/%MIME_type/;
 272 %MIME_type = (qw|
 273                         jpg             image/jpeg
 274                         gif             image/gif
 275                         jpeg    image/jpeg
 276                         png             image/png
 277                         xpm             image/xpm
 278                         htm             text/html
 279                         html    text/html
 280                         txt             text/plain
 281                         asc             text/plain
 282                         csv             text/plain
 283                         xls             application/vnd.ms-excel
 284                         default application/octet-stream
 285                 |
 286                 );
 287 # Return a mime type based on either catalog configuration or some defaults
 288 sub mime_type {
 289         my ($val) = @_;
 290         $val =~ s:.*\.::s;
 291
 292         ! length($val) and return $Vend::Cfg->{MimeType}{default} || 'text/plain';
 293
 294         $val = lc $val;
 295
 296         return $Vend::Cfg->{MimeType}{$val}
 297                                 || $MIME_type{$val}
 298                                 || $Vend::Cfg->{MimeType}{default}
 299                                 || $MIME_type{default};
 300 }
 301
 302 # Return AMOUNT formatted as currency.
 303 sub commify {
 304     local($_) = shift;
 305         my $sep = shift || ',';
 306     1 while s/^(-?\d+)(\d{3})/$1$sep$2/;
 307     return $_;
 308 }
 309
 310 my %safe_locale = (
 311                                                 C     => 1,
 312                                                 en_US => 1,
 313                                                 en_UK => 1,
 314                                                 en_GB => 1,
 315                                         );
 316
 317 sub safe_sprintf {
 318         # need to supply $fmt as a scalar to prevent prototype problems
 319         my $fmt = shift;
 320
 321         # query the locale
 322         my $save = POSIX::setlocale (&POSIX::LC_NUMERIC);
 323
 324         # This should be faster than doing set every time....but when
 325         # is locale C anymore? Should we set this by default?
 326         return sprintf($fmt, @_) if $safe_locale{$save};
 327
 328         # Need to set.
 329         POSIX::setlocale (&POSIX::LC_NUMERIC, 'C');
 330         my $val = sprintf($fmt, @_);
 331         POSIX::setlocale (&POSIX::LC_NUMERIC, $save);
 332         return $val;
 333 }
 334
 335 sub picture_format {
 336         my($amount, $pic, $sep, $point) = @_;
 337     $pic        = reverse $pic;
 338         $point  = '.' unless defined $point;
 339         $sep    = ',' unless defined $sep;
 340         my $len = $pic =~ /(#+)\Q$point/
 341                 ? length($1)
 342                 : 0
 343         ;
 344         $amount = sprintf('%.' . $len . 'f', $amount);
 345         $amount =~ tr/0-9//cd;
 346         my (@dig) = split m{}, $amount;
 347         $pic =~ s/#/pop(@dig)/eg;
 348         $pic =~ s/\Q$sep\E+(?!\d)//;
 349         $pic =~ s/\d/*/g if @dig;
 350         $amount = reverse $pic;
 351         return $amount;
 352 }
 353
 354 sub setlocale {
 355     my ($locale, $currency, $opt) = @_;
 356 #::logDebug("original locale " . (defined $locale ? $locale : 'undef') );
 357 #::logDebug("default locale  " . (defined $::Scratch->{mv_locale} ? $::Scratch->{mv_locale} : 'undef') );
 358
 359         if($opt->{get}) {
 360             my $loc     = $Vend::Cfg->{Locale_repository} or return;
 361             my $currloc = $Vend::Cfg->{Locale} or return;
 362             for(keys %$loc) {
 363                         return $_ if $loc->{$_} eq $currloc;
 364             }
 365             return;
 366         }
 367
 368     $locale = $::Scratch->{mv_locale} unless defined $locale;
 369 #::logDebug("locale is now   " . (defined $locale ? $locale : 'undef') );
 370
 371     if ( $locale and not defined $Vend::Cfg->{Locale_repository}{$locale}) {
 372         ::logError( "attempt to set non-existant locale '%s'" , $locale );
 373         return '';
 374     }
 375
 376     if ( $currency and not defined $Vend::Cfg->{Locale_repository}{$currency}) {
 377         ::logError("attempt to set non-existant currency '%s'" , $currency);
 378         return '';
 379     }
 380
 381     if($locale) {
 382         my $loc = $Vend::Cfg->{Locale} = $Vend::Cfg->{Locale_repository}{$locale};
 383
 384         for(@Vend::Config::Locale_directives_scalar) {
 385             $Vend::Cfg->{$_} = $loc->{$_}
 386                 if defined $loc->{$_};
 387         }
 388
 389         for(@Vend::Config::Locale_directives_ary) {
 390             @{$Vend::Cfg->{$_}} = split (/\s+/, $loc->{$_})
 391                 if $loc->{$_};
 392         }
 393
 394         for(@Vend::Config::Locale_directives_code) {
 395                         next unless $loc->{$_->[0]};
 396                         my ($routine, $args) = @{$_}[1,2];
 397                         if($args) {
 398                                 $routine->(@$args);
 399                         }
 400                         else {
 401                                 $routine->();
 402                         }
 403         }
 404
 405                 no strict 'refs';
 406                 for(qw/LC_COLLATE LC_CTYPE LC_TIME/) {
 407                         next unless $loc->{$_};
 408                         POSIX::setlocale(&{"POSIX::$_"}, $loc->{$_});
 409                 }
 410     }
 411
 412     if ($currency) {
 413         my $curr = $Vend::Cfg->{Currency_repository}{$currency};
 414
 415         for(@Vend::Config::Locale_directives_currency) {
 416             $Vend::Cfg->{$_} = $curr->{$_}
 417                 if defined $curr->{$_};
 418         }
 419
 420         for(@Vend::Config::Locale_keys_currency) {
 421             $Vend::Cfg->{Locale}{$_} = $curr->{$_}
 422                 if defined $curr->{$_};
 423         }
 424     }
 425
 426         if(my $ref = $Vend::Cfg->{CodeDef}{LocaleChange}) {
 427                 $ref = $ref->{Routine};
 428                 if($ref->{all}) {
 429                         $ref->{all}->($locale, $opt);
 430                 }
 431                 if($ref->{lc $locale}) {
 432                         $ref->{lc $locale}->($locale, $opt);
 433                 }
 434         }
 435
 436     if($opt->{persist}) {
 437                 $::Scratch->{mv_locale}   = $locale             if $locale;
 438                 delete $::Scratch->{mv_currency_tmp};
 439                 delete $::Scratch->{mv_currency};
 440                 $::Scratch->{mv_currency} = $currency if $currency;
 441         }
 442         elsif($currency) {
 443                 Vend::Interpolate::set_tmp('mv_currency_tmp')
 444                         unless defined $::Scratch->{mv_currency_tmp};
 445                 $::Scratch->{mv_currency_tmp} = $currency;
 446         }
 447         else {
 448                 delete $::Scratch->{mv_currency_tmp};
 449                 delete $::Scratch->{mv_currency};
 450         }
 451
 452     return '';
 453 }
 454
 455
 456 sub currency {
 457         my($amount, $noformat, $convert, $opt) = @_;
 458         $opt = {} unless $opt;
 459         $convert ||= $opt->{convert};
 460
 461         my $pd = $Vend::Cfg->{PriceDivide};
 462         if($opt->{locale}) {
 463                 $convert = 1 unless length($convert);
 464                 $pd = $Vend::Cfg->{Locale_repository}{$opt->{locale}}{PriceDivide};
 465         }
 466
 467         if($pd and $convert) {
 468                 $amount = $amount / $pd;
 469         }
 470
 471         my $hash;
 472         if(
 473                 $noformat =~ /\w+=\w\w/
 474                         and
 475                 ref($hash = get_option_hash($noformat)) eq 'HASH'
 476         )
 477         {
 478                 $opt->{display} ||= $hash->{display};
 479                 $noformat = $opt->{noformat} = $hash->{noformat};
 480         }
 481
 482         return $amount if $noformat;
 483         my $sep;
 484         my $dec;
 485         my $fmt;
 486         my $precede = '';
 487         my $succede = '';
 488
 489         my $loc = $opt->{locale}
 490                         || $::Scratch->{mv_currency_tmp}
 491                         || $::Scratch->{mv_currency}
 492                         || $Vend::Cfg->{Locale};
 493
 494         if(ref($loc)) {
 495                 ## Do nothing, is a hash reference
 496         }
 497         elsif($loc) {
 498                 $loc = $Vend::Cfg->{Locale_repository}{$loc};
 499         }
 500
 501         if (! $loc) {
 502                 $fmt = "%.2f";
 503         }
 504         else {
 505                 $sep = $loc->{mon_thousands_sep} || $loc->{thousands_sep} || ',';
 506                 $dec = $loc->{mon_decimal_point} || $loc->{decimal_point} || '.';
 507                 return picture_format($amount, $loc->{price_picture}, $sep, $dec)
 508                         if defined $loc->{price_picture};
 509                 if (defined $loc->{frac_digits}) {
 510                         $fmt = "%." . $loc->{frac_digits} .  "f";
 511                 } else {
 512                         $fmt = "%.2f";
 513                 }
 514                 my $cs;
 515                 my $display = lc($opt->{display}) || 'symbol';
 516                 my $sep_by_space = $loc->{p_sep_by_space};
 517                 my $cs_precedes = $loc->{p_cs_precedes};
 518
 519                 if( $loc->{int_currency_symbol} && $display eq 'text' ) {
 520                         $cs = $loc->{int_currency_symbol};
 521                         $cs_precedes = 1;
 522
 523                         if (length($cs) > 3 || $cs =~ /\W$/) {
 524                                 $sep_by_space = 0;
 525                         }
 526                         else {
 527                                 $sep_by_space = 1;
 528                         }
 529                 }
 530                 elsif ( $display eq 'none' ) {
 531                         $cs = '';
 532                 }
 533                 elsif ( $display eq 'symbol' ) {
 534                         $cs = $loc->{currency_symbol} || '';
 535                 }
 536                 if($cs) {
 537                         if ($cs_precedes) {
 538                                 $precede = $cs;
 539                                 $precede = "$precede " if $sep_by_space;
 540                         }
 541                         else {
 542                                 $succede = $cs;
 543                                 $succede = " $succede" if $sep_by_space;
 544                         }
 545                 }
 546         }
 547
 548         $amount = safe_sprintf($fmt, $amount);
 549         $amount =~ s/\./$dec/ if defined $dec;
 550         $amount = commify($amount, $sep || undef)
 551                 if $Vend::Cfg->{PriceCommas};
 552         return "$precede$amount$succede";
 553 }
 554
 555 ## random_string
 556
 557 # leaving out 0, O and 1, l
 558 my $random_chars = "ABCDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz23456789";
 559
 560 # Return a string of random characters.
 561
 562 sub random_string {
 563     my ($len) = @_;
 564     $len = 8 unless $len;
 565     my ($r, $i);
 566
 567     $r = '';
 568     for ($i = 0;  $i < $len;  ++$i) {
 569                 $r .= substr($random_chars, int(rand(length($random_chars))), 1);
 570     }
 571     $r;
 572 }
 573
 574 # To generate a unique key for caching
 575 # Not very good without MD5
 576 #
 577 my $Md;
 578 my $Keysub;
 579
 580 eval {require Digest::MD5 };
 581
 582 if(! $@) {
 583         $Md = new Digest::MD5;
 584         $Keysub = sub {
 585                                         @_ = time() unless @_;
 586                                         $Md->reset();
 587                                         if($Global::UTF8) {
 588                                                 $Md->add(map encode_utf8($_), @_);
 589                                         }
 590                                         else {
 591                                                 $Md->add(@_);
 592                                         }
 593                                         $Md->hexdigest();
 594                                 };
 595 }
 596 else {
 597         $Keysub = sub {
 598                 my $out = '';
 599                 @_ = time() unless @_;
 600                 for(@_) {
 601                         $out .= unpack "%32c*", $_;
 602                         $out .= unpack "%32c*", substr($_,5);
 603                         $out .= unpack "%32c*", substr($_,-1,5);
 604                 }
 605                 $out;
 606         };
 607 }
 608
 609 sub generate_key { &$Keysub(@_) }
 610
 611 sub hexify {
 612     my $string = shift;
 613     $string =~ s/(\W)/sprintf '%%%02x', ord($1)/ge;
 614     return $string;
 615 }
 616
 617 sub unhexify {
 618     my $s = shift;
 619     $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
 620     return $s;
 621 }
 622
 623 *unescape_chars = \&unhexify;
 624
 625 sub unescape_full {
 626     my $url = shift;
 627     $url =~ tr/+/ /;
 628     $url =~ s/<!--.*?-->//sg;
 629     return unhexify($url);
 630 }
 631
 632 ## UNEVAL
 633
 634 # Returns a string representation of an anonymous array, hash, or scaler
 635 # that can be eval'ed to produce the same value.
 636 # uneval([1, 2, 3, [4, 5]]) -> '[1,2,3,[4,5,],]'
 637 # Uses either Storable::freeze or Data::Dumper::DumperX or uneval
 638 # in
 639
 640 sub uneval_it {
 641     my($o) = @_;                # recursive
 642     my($r, $s, $i, $key, $value);
 643
 644         local($^W) = 0;
 645     $r = ref $o;
 646     if (!$r) {
 647         $o =~ s/([\\"\$@])/\\$1/g;
 648         $s = '"' . $o . '"';
 649     } elsif ($r eq 'ARRAY') {
 650         $s = "[";
 651         foreach $i (0 .. $#$o) {
 652             $s .= uneval_it($o->[$i]) . ",";
 653         }
 654         $s .= "]";
 655     } elsif ($r eq 'HASH') {
 656         $s = "{";
 657         while (($key, $value) = each %$o) {
 658             $s .= "'$key' => " . uneval_it($value) . ",";
 659         }
 660         $s .= "}";
 661     } else {
 662         $s = "'something else'";
 663     }
 664
 665     $s;
 666 }
 667
 668 use subs 'uneval_fast';
 669
 670 sub uneval_it_file {
 671         my ($ref, $fn) = @_;
 672         open(UNEV, ">$fn")
 673                 or die "Can't create $fn: $!\n";
 674         print UNEV uneval_fast($ref);
 675         close UNEV;
 676 }
 677
 678 sub eval_it_file {
 679         my ($fn) = @_;
 680         local($/) = undef;
 681         open(UNEV, "< $fn") or return undef;
 682         my $ref = evalr(<UNEV>);
 683         close UNEV;
 684         return $ref;
 685 }
 686
 687 # See if we have Storable and the user has OKed its use
 688 # If so, session storage/write will be about 5x faster
 689 eval {
 690         die unless $ENV{MINIVEND_STORABLE};
 691         require Storable;
 692         import Storable 'freeze';
 693
 694         if ($ENV{MINIVEND_STORABLE_CODE}) {
 695                 # allow code references to be stored to the session
 696                  $Storable::Deparse = 1;
 697                  $Storable::Eval = 1;
 698         }
 699
 700         $Fast_uneval     = \&Storable::freeze;
 701         $Fast_uneval_file  = \&Storable::store;
 702         $Eval_routine    = \&Storable::thaw;
 703         $Eval_routine_file = \&Storable::retrieve;
 704 };
 705
 706 # See if Data::Dumper is installed with XSUB
 707 # If it is, session writes will be about 25-30% faster
 708 eval {
 709                 die if $ENV{MINIVEND_NO_DUMPER};
 710                 require Data::Dumper;
 711                 import Data::Dumper 'DumperX';
 712                 $Data::Dumper::Indent = 1;
 713                 $Data::Dumper::Terse = 1;
 714                 $Data::Dumper::Deepcopy = 1;
 715                 if(defined $Fast_uneval) {
 716                         $Pretty_uneval = \&Data::Dumper::Dumper;
 717                 }
 718                 else {
 719                         $Pretty_uneval = \&Data::Dumper::DumperX;
 720                         $Fast_uneval = \&Data::Dumper::DumperX
 721                 }
 722 };
 723
 724 *uneval_fast = defined $Fast_uneval       ? $Fast_uneval       : \&uneval_it;
 725 *evalr       = defined $Eval_routine      ? $Eval_routine      : sub { eval shift };
 726 *eval_file   = defined $Eval_routine_file ? $Eval_routine_file : \&eval_it_file;
 727 *uneval_file = defined $Fast_uneval_file  ? $Fast_uneval_file  : \&uneval_it_file;
 728 *uneval      = defined $Pretty_uneval     ? $Pretty_uneval     : \&uneval_it;
 729
 730
 731
 732 # Log data fields to a data file.
 733
 734 sub logData {
 735     my($file,@msg) = @_;
 736     my $prefix = '';
 737
 738         $file = ">>$file" unless $file =~ /^[|>]/;
 739
 740         my $msg = tabbed @msg;
 741
 742     eval {
 743                 unless($file =~ s/^[|]\s*//) {
 744                         # We have checked for beginning > or | previously
 745                         open(MVLOGDATA, $file)          or die "open\n";
 746                         lockfile(\*MVLOGDATA, 1, 1)     or die "lock\n";
 747                         seek(MVLOGDATA, 0, 2)           or die "seek\n";
 748                         print(MVLOGDATA "$msg\n")       or die "write to\n";
 749                         unlockfile(\*MVLOGDATA)         or die "unlock\n";
 750                 }
 751                 else {
 752             my (@args) = grep /\S/, Text::ParseWords::shellwords($file);
 753                         open(MVLOGDATA, "|-") || exec @args;
 754                         print(MVLOGDATA "$msg\n") or die "pipe to\n";
 755                 }
 756                 close(MVLOGDATA) or die "close\n";
 757     };
 758     if ($@) {
 759
 760                 if($::Limit->{logdata_error_length} > 0) {
 761                         $msg = substr($msg, 0, $::Limit->{logdata_error_length});
 762                 }
 763
 764                 logError ("Could not %s log file '%s': %s\nto log this data:\n%s",
 765                                 $@,
 766                                 $file,
 767                                 $!,
 768                                 $msg,
 769                                 );
 770                 return 0;
 771     }
 772         1;
 773 }
 774
 775
 776
 777 sub quoted_comma_string {
 778         my ($text) = @_;
 779         my (@fields);
 780         push(@fields, $+) while $text =~ m{
 781    "([^\"\\]*(?:\\.[^\"\\]*)*)"[\s,]?  ## std quoted string, w/possible space-comma
 782    | ([^\s,]+)[\s,]?                   ## anything else, w/possible space-comma
 783    | [,\s]+                            ## any comma or whitespace
 784         }gx;
 785     @fields;
 786 }
 787
 788 # Modified from old, old module called Ref.pm
 789 sub copyref {
 790     my($x,$r) = @_;
 791
 792     my($z, $y);
 793
 794     my $rt = ref $x;
 795
 796     if ($rt =~ /SCALAR/) {
 797         # Would \$$x work?
 798         $z = $$x;
 799         return \$z;
 800     } elsif ($rt =~ /HASH/) {
 801         $r = {} unless defined $r;
 802         for $y (sort keys %$x) {
 803             $r->{$y} = &copyref($x->{$y}, $r->{$y});
 804         }
 805         return $r;
 806     } elsif ($rt =~ /ARRAY/) {
 807         $r = [] unless defined $r;
 808         for ($y = 0; $y <= $#{$x}; $y++) {
 809             $r->[$y] = &copyref($x->[$y]);
 810         }
 811         return $r;
 812     } elsif ($rt =~ /REF/) {
 813         $z = &copyref($x);
 814         return \$z;
 815     } elsif (! $rt) {
 816         return $x;
 817     } else {
 818         die "do not know how to copy $x";
 819     }
 820 }
 821
 822 sub check_gate {
 823         my($f, $gatedir) = @_;
 824
 825         my $gate;
 826         if ($gate = readfile("$gatedir/.access_gate") ) {
 827                 $f =~ s:.*/::;
 828                 $gate = Vend::Interpolate::interpolate_html($gate);
 829                 if($gate =~ m!^$f(?:\.html?)?[ \t]*:!m ) {
 830                         $gate =~ s!.*(\n|^)$f(?:\.html?)?[ \t]*:!!s;
 831                         $gate =~ s/\n[\S].*//s;
 832                         $gate =~ s/^\s+//;
 833                 }
 834                 elsif($gate =~ m{^\*(?:\.html?)?[: \t]+(.*)}m) {
 835                         $gate = $1;
 836                 }
 837                 else {
 838                         undef $gate;
 839                 }
 840         }
 841         return $gate;
 842 }
 843
 844 sub string_to_ref {
 845         my ($string) = @_;
 846         if($MVSAFE::Safe) {
 847                 return eval $string;
 848         }
 849         my $safe = $Vend::Interpolate::safe_safe || new Vend::Safe;
 850         return $safe->reval($string);
 851 }
 852
 853 sub is_hash {
 854         return ref($_[0]) eq 'HASH';
 855 }
 856
 857 # Verify that passed string is a valid IPv4 address.
 858 sub is_ipv4 {
 859     my $addr = shift or return;
 860     my @segs = split '.', $addr;
 861     return unless @segs == 4;
 862     foreach (@segs) {
 863         return unless /^\d{1,3}$/ && !/^0\d/;
 864         return unless $_ <= 255;
 865     }
 866     return 1;
 867 }
 868
 869 # Verify that passed string is a valid IPv6 address.
 870 sub is_ipv6 {
 871     my $addr = shift or return;
 872     my @segs = split ':', $addr;
 873
 874     my $quads = 8;
 875     # Check for IPv4 style ending
 876     if ($segs[-1] =~ /\./) {
 877         return unless is_ipv4(pop @segs);
 878         $quads = 6;
 879     }
 880
 881     # Check the special case of the :: abbreviation.
 882     if ($addr =~ /::/) {
 883         # Three :'s together is wrong, though.
 884         return if $addr =~ /:::/;
 885         # Also only one set of :: is allowed.
 886         return if $addr =~ /::.*::/;
 887         # Check that we don't have too many quads.
 888         return if @segs >= $quads;
 889     }
 890     else {
 891         # No :: abbreviation, so the number of quads must be exact.
 892         return unless @segs == $quads;
 893     }
 894
 895     # Check the validity of each quad
 896     foreach (@segs) {
 897         return unless /^[0-9a-f]{1,4}$/i;
 898     }
 899
 900     return 1;
 901 }
 902
 903 sub dotted_hash {
 904         my($hash, $key, $value, $delete_empty) = @_;
 905         $hash = get_option_hash($hash) unless is_hash($hash);
 906         unless (is_hash($hash)) {
 907                 return undef unless defined $value;
 908                 $hash = {};
 909         }
 910         my @keys = split /[\.:]+/, $key;
 911         my $final;
 912         my $ref;
 913
 914         if(! defined $value) {
 915                 # Retrieving
 916                 $ref = $hash->{shift @keys};
 917                 for(@keys) {
 918                         return undef unless is_hash($ref);
 919                         $ref = $ref->{$_};
 920                 }
 921                 return $ref;
 922         }
 923
 924         # Storing
 925         $final = pop @keys;
 926         $ref = $hash;
 927
 928         for(@keys) {
 929                 $ref->{$_} = {} unless is_hash($ref->{$_});
 930                 $ref = $ref->{$_};
 931         }
 932
 933         if($delete_empty and ! length($value)) {
 934                 delete $ref->{$final};
 935         }
 936         else {
 937                 $ref->{$final} = $value;
 938         }
 939
 940         $hash = uneval_it($hash);
 941         return $hash;
 942 }
 943
 944 sub get_option_hash {
 945         my $string = shift;
 946         my $merge = shift;
 947         if (ref $string eq 'HASH') {
 948                 my $ref = { %$string };
 949                 return $ref unless ref $merge;
 950                 for(keys %{$merge}) {
 951                         $ref->{$_} = $merge->{$_}
 952                                 unless defined $ref->{$_};
 953                 }
 954                 return $ref;
 955         }
 956         return {} unless $string and $string =~ /\S/;
 957         $string =~ s/^\s+//;
 958         $string =~ s/\s+$//;
 959         if($string =~ /^{/ and $string =~ /}/) {
 960                 return string_to_ref($string);
 961         }
 962
 963         my @opts;
 964         unless ($string =~ /,/) {
 965                 @opts = grep $_ ne "=", Text::ParseWords::shellwords($string);
 966                 for(@opts) {
 967                         s/^(\w[-\w]*\w)=(["'])(.*)\2$/$1$3/;
 968                 }
 969         }
 970         else {
 971                 @opts = split /\s*,\s*/, $string;
 972         }
 973
 974         my %hash;
 975         for(@opts) {
 976                 my ($k, $v) = split /[\s=]+/, $_, 2;
 977                 $k =~ s/-/_/g;
 978                 $hash{$k} = $v;
 979         }
 980         if($merge) {
 981                 return \%hash unless ref $merge;
 982                 for(keys %$merge) {
 983                         $hash{$_} = $merge->{$_}
 984                                 unless defined $hash{$_};
 985                 }
 986         }
 987         return \%hash;
 988 }
 989
 990 sub word2ary {
 991         my $val = shift;
 992         return $val if ref($val) eq 'ARRAY';
 993         my @ary = grep /\w/, split /[\s,\0]+/, $val;
 994         return \@ary;
 995 }
 996
 997 sub ary2word {
 998         my $val = shift;
 999         return $val if ref($val) ne 'ARRAY';
1000         @$val = grep /\w/, @$val;
1001         return join " ", @$val;
1002 }
1003
1004 ## Takes an IC scalar form value (parm=val\nparm2=val) and translates it
1005 ## to a reference
1006
1007 sub scalar_to_hash {
1008         my $val = shift;
1009
1010         $val =~ s/^\s+//mg;
1011         $val =~ s/\s+$//mg;
1012         my @args;
1013
1014         @args = split /\n+/, $val;
1015
1016         my $ref = {};
1017
1018         for(@args) {
1019                 m!([^=]+)=(.*)!
1020                         and $ref->{$1} = $2;
1021         }
1022         return $ref;
1023 }
1024
1025 ## Takes a form reference (i.e. from \%CGI::values) and makes into a
1026 ## scalar value value (i.e. parm=val\nparm2=val). Also translates it
1027 ## via HTML entities -- it is designed to make it into a hidden
1028 ## form value
1029
1030 sub hash_to_scalar {
1031         my $ref = shift
1032                 or return '';
1033
1034         unless (ref($ref) eq 'HASH') {
1035                 die __PACKAGE__ . " hash_to_scalar routine got bad reference.\n";
1036         }
1037
1038         my @parms;
1039         while( my($k, $v) = each %$ref ) {
1040                 $v =~ s/\r?\n/\r/g;
1041                 push @parms, HTML::Entities::encode("$k=$v");
1042         }
1043         return join "\n", @parms;
1044 }
1045
1046 ## This simply returns a hash of words, which may be quoted shellwords
1047 ## Replaces most of parse_hash in Vend::Config
1048 sub hash_string {
1049         my($settings, $ref) = @_;
1050
1051         return $ref if ! $settings or $settings !~ /\S/;
1052
1053         $ref ||= {};
1054
1055         $settings =~ s/^\s+//;
1056         $settings =~ s/\s+$//;
1057         my(@setting) = Text::ParseWords::shellwords($settings);
1058
1059         my $i;
1060         for ($i = 0; $i < @setting; $i += 2) {
1061                 $ref->{$setting[$i]} = $setting[$i + 1];
1062         }
1063         return $ref;
1064 }
1065
1066 ## READIN
1067
1068 my $Lang;
1069
1070 sub find_locale_bit {
1071         my $text = shift;
1072         unless (defined $Lang) {
1073                 $Lang = $::Scratch->{mv_locale} || $Vend::Cfg->{DefaultLocale};
1074         }
1075         $text =~ m{\[$Lang\](.*)\[/$Lang\]}s
1076                 and return $1;
1077         $text =~ s{\[(\w+)\].*\[/\1\].*}{}s;
1078         return $text;
1079 }
1080
1081 sub parse_locale {
1082         my ($input) = @_;
1083
1084         return if $::Pragma->{no_locale_parse};
1085
1086         # avoid copying big strings
1087         my $r = ref($input) ? $input : \$input;
1088
1089         if($Vend::Cfg->{Locale}) {
1090                 my $key;
1091                 $$r =~ s~\[L(\s+([^\]]+))?\]((?s:.)*?)\[/L\]~
1092                                                 $key = $2 || $3;
1093                                                 defined $Vend::Cfg->{Locale}{$key}
1094                                                 ?  ($Vend::Cfg->{Locale}{$key}) : $3 ~eg;
1095                 $$r =~ s~\[LC\]((?s:.)*?)\[/LC\]~
1096                                                 find_locale_bit($1) ~eg;
1097                 undef $Lang;
1098         }
1099         else {
1100                 $$r =~ s~\[L(?:\s+[^\]]+)?\]((?s:.)*?)\[/L\]~$1~g;
1101         }
1102
1103         # return scalar string if one get passed initially
1104         return ref($input) ? $input : $$r;
1105 }
1106
1107 sub teleport_name {
1108         my ($file, $teleport, $table) = @_;
1109         my $db;
1110         return $file
1111                 unless   $teleport
1112                         and  $db = Vend::Data::database_exists_ref($table);
1113
1114         my @f = qw/code base_code expiration_date show_date page_text/;
1115         my ($c, $bc, $ed, $sd, $pt) = @{$Vend::Cfg->{PageTableMap}}{@f};
1116         my $q = qq{
1117                 SELECT $c from $table
1118                 WHERE  $bc = '$file'
1119                 AND    $ed <  $teleport
1120                 AND    $sd >= $teleport
1121                 ORDER BY $sd DESC
1122         };
1123         my $ary = $db->query($q);
1124         if($ary and $ary->[0]) {
1125                 $file = $ary->[0][0];
1126         }
1127         return $file;
1128 }
1129
1130 # Reads in a page from the page directory with the name FILE and ".html"
1131 # appended. If the HTMLsuffix configuration has changed (because of setting in
1132 # catalog.cfg or Locale definitions) it will substitute that. Returns the
1133 # entire contents of the page, or undef if the file could not be read.
1134 # Substitutes Locale bits as necessary.
1135
1136 sub readin {
1137     my($file, $only, $locale) = @_;
1138
1139         ## We don't want to try if we are forcing a flypage
1140         return undef if $Vend::ForceFlypage;
1141
1142     my($fn, $contents, $gate, $pathdir, $dir, $level);
1143     local($/);
1144
1145         if($file =~ m{[\[<]}) {
1146                 ::logGlobal("Possible code/SQL injection attempt with file name '%s'", $file);
1147                 $file = escape_chars($file);
1148                 ::logGlobal("Suspect file changed to '%s'", $file);
1149         }
1150
1151         $Global::Variable->{MV_PREV_PAGE} = $Global::Variable->{MV_PAGE}
1152                 if defined $Global::Variable->{MV_PAGE};
1153         $Global::Variable->{MV_PAGE} = $file;
1154
1155         $file =~ s#^\s+##;
1156         $file =~ s#\s+$##;
1157         $file =~ s#\.html?$##;
1158         if($file =~ m{\.\.} and $file =~ /\.\..*\.\./) {
1159                 logError( "Too many .. in file path '%s' for security.", $file );
1160                 $file = find_special_page('violation');
1161         }
1162
1163         if(index($file, '/') < 0) {
1164                 $pathdir = '';
1165         }
1166         else {
1167                 $file =~ s#//+#/#g;
1168                 $file =~ s#/+$##g;
1169                 ($pathdir = $file) =~ s#/[^/]*$##;
1170                 $pathdir =~ s:^/+::;
1171         }
1172
1173         my $try;
1174         my $suffix = $Vend::Cfg->{HTMLsuffix};
1175         my $db_tried;
1176         $locale = 1 unless defined $locale;
1177         my $record;
1178   FINDPAGE: {
1179         ## If PageTables is set, we try to find the page in the table first
1180         ## but only once, without the suffix
1181         if(! $db_tried++ and $Vend::Cfg->{PageTables}) {
1182                 my $teleport = $Vend::Session->{teleport};
1183                 my $field = $Vend::Cfg->{PageTableMap}{page_text};
1184                 foreach my $t (@{$Vend::Cfg->{PageTables}}) {
1185                         my $db = Vend::Data::database_exists_ref($t);
1186                         next unless $db;
1187
1188                         if($teleport) {
1189                                 $file = teleport_name($file, $teleport, $t);
1190                         }
1191                         $record = $db->row_hash($file)
1192                                 or next;
1193                         $contents = $record->{$field};
1194                         last FINDPAGE if length $contents;
1195                         undef $contents;
1196                 }
1197         }
1198
1199         my @dirs = ($Vend::Cfg->{PreviewDir},
1200                                 $Vend::Cfg->{PageDir},
1201                                 @{$Vend::Cfg->{TemplateDir} || []},
1202                                 @{$Global::TemplateDir || []});
1203
1204         foreach $try (@dirs) {
1205                 next unless $try;
1206                 $dir = $try . "/" . $pathdir;
1207                 if (-f "$dir/.access") {
1208                         if (-s _) {
1209                                 $level = 3;
1210                         }
1211                         else {
1212                                 $level = '';
1213                         }
1214                         if(-f "$dir/.autoload") {
1215                                 my $status = ::interpolate_html( readfile("$dir/.autoload") );
1216                                 $status =~ s/\s+//g;
1217                                 undef $level if $status;
1218                         }
1219                         $gate = check_gate($file,$dir)
1220                                 if defined $level;
1221                 }
1222
1223                 if( defined $level and ! check_security($file, $level, $gate) ){
1224                         my $realm = $::Variable->{COMPANY} || $Vend::Cat;
1225                         if(-f "$try/violation$suffix") {
1226                                 $fn = "$try/violation$suffix";
1227                         }
1228                         else {
1229                                 $file = find_special_page('violation');
1230                                 $fn = $try . "/" . escape_chars($file) . $suffix;
1231                         }
1232                 }
1233                 else {
1234                         $fn = $try . "/" . escape_chars($file) . $suffix;
1235                 }
1236
1237                 if (open(MVIN, "< $fn")) {
1238                         binmode(MVIN) if $Global::Windows;
1239                         binmode(MVIN, ":utf8") if $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
1240                         undef $/;
1241                         $contents = <MVIN>;
1242                         close(MVIN);
1243                         last;
1244                 }
1245                 last if defined $only;
1246         }
1247         if(! defined $contents) {
1248                 last FINDPAGE if $suffix eq '.html';
1249                 $suffix = '.html';
1250                 redo FINDPAGE;
1251         }
1252   }
1253
1254         if(! defined $contents) {
1255                 $contents = readfile_db("pages/$file");
1256         }
1257
1258         return unless defined $contents;
1259
1260         parse_locale(\$contents);
1261
1262         return $contents unless wantarray;
1263         return ($contents, $record);
1264 }
1265
1266 sub is_yes {
1267     return( defined($_[0]) && ($_[0] =~ /^[yYtT1]/));
1268 }
1269
1270 sub is_no {
1271         return( !defined($_[0]) || ($_[0] =~ /^[nNfF0]/));
1272 }
1273
1274 # Returns a URL which will run the ordering system again.  Each URL
1275 # contains the session ID as well as a unique integer to avoid caching
1276 # of pages by the browser.
1277
1278 my @scratches = qw/
1279                                 add_dot_html
1280                                 add_source
1281                                 link_relative
1282                                 match_security
1283                                 no_count
1284                                 no_session
1285                                 /;
1286
1287 sub vendUrl {
1288     my($path, $arguments, $r, $opt) = @_;
1289
1290         $opt ||= {};
1291
1292         if($opt->{auto_format}) {
1293                 return $path if $path =~ m{^/};
1294                 $path =~ s:#([^/.]+)$::
1295             and $opt->{anchor} = $1;
1296                 $path =~ s/\.html?$//i
1297                         and $opt->{add_dot_html} = 1;
1298         }
1299
1300     $r = $Vend::Cfg->{VendURL}
1301                 unless defined $r;
1302
1303         my $secure;
1304         my @parms;
1305
1306         my %skip = qw/form 1 href 1 reparse 1/;
1307
1308         for(@scratches) {
1309                 next if defined $opt->{$_};
1310                 next unless defined $::Scratch->{"mv_$_"};
1311                 $skip{$_} = 1;
1312                 $opt->{$_} = $::Scratch->{"mv_$_"};
1313         }
1314
1315         my $extra;
1316         if($opt->{form}) {
1317                 $path = $Vend::Cfg->{ProcessPage} unless $path;
1318                 if($opt->{form} eq 'auto') {
1319                         my $form = '';
1320                         while( my ($k, $v) = each %$opt) {
1321                                 next if $skip{$k};
1322                                 $k =~ s/^__//;
1323                                 $form .= "$k=$v\n";
1324                         }
1325                         $opt->{form} = $form;
1326                 }
1327                 push @parms, Vend::Interpolate::escape_form($opt->{form});
1328         }
1329
1330         my($id, $ct);
1331         $id = $Vend::SessionID
1332                 unless $opt->{no_session_id}
1333                 or     ($Vend::Cookie and $::Scratch->{mv_no_session_id});
1334         $ct = ++$Vend::Session->{pageCount}
1335                 unless $opt->{no_count};
1336
1337         if($opt->{no_session} or $::Pragma->{url_no_session_id}) {
1338                 undef $id;
1339                 undef $ct;
1340         }
1341
1342         if($opt->{link_relative}) {
1343                 my $cur = $Global::Variable->{MV_PAGE};
1344                 $cur =~ s{/[^/]+$}{}
1345                         and $path = "$cur/$path";
1346         }
1347
1348         if($opt->{match_security}) {
1349                 $opt->{secure} = $CGI::secure;
1350         }
1351
1352         if($opt->{secure} or exists $Vend::Cfg->{AlwaysSecure}{$path}) {
1353                 $r = $Vend::Cfg->{SecureURL};
1354         }
1355
1356         $path = escape_chars_url($path)
1357                 if $path =~ $need_escape;
1358         $r .= '/' . $path;
1359         $r .= '.html' if $opt->{add_dot_html} and $r !~ m{(?:/|\.html?)$};
1360
1361         if($opt->{add_source} and $Vend::Session->{source}) {
1362                 my $sn = hexify($Vend::Session->{source});
1363                 push @parms, "$::VN->{mv_source}=$sn";
1364         }
1365
1366         push @parms, "$::VN->{mv_session_id}=$id"               if $id;
1367         push @parms, "$::VN->{mv_arg}=" . hexify($arguments)    if defined $arguments;
1368         push @parms, "$::VN->{mv_pc}=$ct"                       if $ct;
1369         push @parms, "$::VN->{mv_cat}=$Vend::Cat"               if $Vend::VirtualCat;
1370
1371         $r .= '?' . join($Global::UrlJoiner, @parms) if @parms;
1372         if($opt->{anchor}) {
1373                 $opt->{anchor} =~ s/^#//;
1374                 $r .= '#' . $opt->{anchor};
1375         }
1376
1377         # return full-path portion of the URL
1378         if ($opt->{path_only}) {
1379                 $r =~ s!^https?://[^/]*!!i;
1380         }
1381         return $r;
1382 }
1383
1384 sub secure_vendUrl {
1385         return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL}, $_[3]);
1386 }
1387
1388 my %strip_vars;
1389 my $strip_init;
1390
1391 sub change_url {
1392         my $url = shift;
1393         return $url if $url =~ m{^\w+:};
1394         return $url if $url =~ m{^/};
1395         if(! $strip_init) {
1396                 for(qw/mv_session_id mv_pc/) {
1397                         $strip_vars{$_} = 1;
1398                         $strip_vars{$::IV->{$_}} = 1;
1399                 }
1400         }
1401         my $arg;
1402         my @args;
1403         ($url, $arg) = split /[?&]/, $url, 2;
1404         @args = grep ! $strip_vars{$_}, split $Global::UrlSplittor, $arg;
1405         return Vend::Interpolate::tag_area( $url, '', {
1406                                                                                         form => join "\n", @args,
1407                                                                                 } );
1408 }
1409
1410 sub resolve_links {
1411         my $html = shift;
1412         $html =~ s/(<a\s+[^>]*href\s*=\s*)(["'])([^'"]+)\2/$1 . $2 . change_url($3) . $2/gei;
1413         return $html;
1414 }
1415
1416 ### flock locking
1417
1418 # sys/file.h:
1419 my $flock_LOCK_SH = 1;          # Shared lock
1420 my $flock_LOCK_EX = 2;          # Exclusive lock
1421 my $flock_LOCK_NB = 4;          # Don't block when locking
1422 my $flock_LOCK_UN = 8;          # Unlock
1423
1424 # Returns the total number of items ordered.
1425 # Uses the current cart if none specified.
1426
1427 sub tag_nitems {
1428         my($ref, $opt) = @_;
1429     my($cart, $total, $item);
1430
1431         if($ref) {
1432                  $cart = $::Carts->{$ref}
1433                         or return 0;
1434         }
1435         else {
1436                 $cart = $Vend::Items;
1437         }
1438
1439         my ($attr, $sub);
1440         if($opt->{qualifier}) {
1441                 $attr = $opt->{qualifier};
1442                 my $qr;
1443                 eval {
1444                         $qr = qr{$opt->{compare}} if $opt->{compare};
1445                 };
1446                 if($qr) {
1447                         $sub = sub {
1448                                                         $_[0] =~ $qr;
1449                                                 };
1450                 }
1451                 else {
1452                         $sub = sub { return $_[0] };
1453                 }
1454         }
1455
1456         if($opt->{lines}) {
1457                 return scalar(grep {! $attr or $sub->($_->{$attr})} @$cart);
1458         }
1459
1460     $total = 0;
1461     foreach $item (@$cart) {
1462                 next if $attr and ! $sub->($item->{$attr});
1463                 $total += $item->{'quantity'};
1464     }
1465     $total;
1466 }
1467
1468 sub dump_structure {
1469         my ($ref, $name) = @_;
1470         my $save;
1471         $name =~ s/\.cfg$//;
1472         $name .= '.structure';
1473         open(UNEV, ">$name") or die "Couldn't write structure $name: $!\n";
1474         local($Data::Dumper::Indent);
1475         $Data::Dumper::Indent = 2;
1476         print UNEV uneval($ref);
1477         close UNEV;
1478 }
1479
1480 # Do an internal HTTP authorization check
1481 sub check_authorization {
1482         my($auth, $pwinfo) = @_;
1483
1484         $auth =~ s/^\s*basic\s+//i or return undef;
1485         my ($user, $pw) = split(
1486                                                 ":",
1487                                                 MIME::Base64::decode_base64($auth),
1488                                                 2,
1489                                                 );
1490         my $cmp_pw;
1491         my $use_crypt = 1;
1492         if(     $user eq $Vend::Cfg->{RemoteUser}       and
1493                         $Vend::Cfg->{Password}                                  )
1494         {
1495                 $cmp_pw = $Vend::Cfg->{Password};
1496                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1497         }
1498         else {
1499                 $pwinfo = $Vend::Cfg->{UserDatabase} unless $pwinfo;
1500                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1501                 $cmp_pw = Vend::Interpolate::tag_data($pwinfo, 'password', $user)
1502                         if defined $Vend::Cfg->{Database}{$pwinfo};
1503         }
1504
1505         return undef unless $cmp_pw;
1506
1507         if(! $use_crypt) {
1508                 return $user if $pw eq $cmp_pw;
1509         }
1510         else {
1511                 my $test = crypt($pw, $cmp_pw);
1512                 return $user
1513                         if $test eq $cmp_pw;
1514         }
1515         return undef;
1516 }
1517
1518 # Check that the user is authorized by one or all of the
1519 # configured security checks
1520 sub check_security {
1521         my($item, $reconfig, $gate) = @_;
1522
1523         my $msg;
1524         if(! $reconfig) {
1525 # If using the new USERDB access control you may want to remove this next line
1526 # for anyone with an HTTP basic auth will have access to everything
1527                 #return 1 if $CGI::user and ! $Global::Variable->{MV_USERDB};
1528                 if($gate) {
1529                         $gate =~ s/\s+//g;
1530                         return 1 if is_yes($gate);
1531                 }
1532                 elsif($Vend::Session->{logged_in}) {
1533                         return 1 if $::Variable->{MV_USERDB_REMOTE_USER};
1534                         my $db;
1535                         my $field;
1536                         if ($db = $::Variable->{MV_USERDB_ACL_TABLE}) {
1537                                 $field = $::Variable->{MV_USERDB_ACL_COLUMN};
1538                                 my $access = Vend::Data::database_field(
1539                                                                 $db,
1540                                                                 $Vend::Session->{username},
1541                                                                 $field,
1542                                                                 );
1543                                 return 1 if $access =~ m{(^|\s)$item(\s|$)};
1544                         }
1545                 }
1546                 if($Vend::Cfg->{UserDB} and $Vend::Cfg->{UserDB}{log_failed}) {
1547                         my $besthost = $CGI::remote_host || $CGI::remote_addr;
1548                         logError("auth error host=%s ip=%s script=%s page=%s",
1549                                                         $besthost,
1550                                                         $CGI::remote_addr,
1551                                                         $CGI::script_name,
1552                                                         $CGI::path_info,
1553                                                         );
1554                 }
1555         return '';
1556         }
1557         elsif($reconfig eq '1') {
1558                 $msg = 'reconfigure catalog';
1559         }
1560         elsif ($reconfig eq '2') {
1561                 $msg = "access protected database $item";
1562                 return 1 if is_yes($gate);
1563         }
1564         elsif ($reconfig eq '3') {
1565                 $msg = "access administrative function $item";
1566         }
1567
1568         # Check if host IP is correct when MasterHost is set to something
1569         if (    $Vend::Cfg->{MasterHost}
1570                                 and
1571                 (       $CGI::remote_host !~ /^($Vend::Cfg->{MasterHost})$/
1572                                 and
1573                         $CGI::remote_addr !~ /^($Vend::Cfg->{MasterHost})$/     )       )
1574         {
1575                         my $fmt = <<'EOF';
1576 ALERT: Attempt to %s at %s from:
1577
1578         REMOTE_ADDR  %s
1579         REMOTE_USER  %s
1580         USER_AGENT   %s
1581         SCRIPT_NAME  %s
1582         PATH_INFO    %s
1583 EOF
1584                 logGlobal({ level => 'warning' },
1585                                                 $fmt,
1586                                                 $msg,
1587                                                 $CGI::script_name,
1588                                                 $CGI::host,
1589                                                 $CGI::user,
1590                                                 $CGI::useragent,
1591                                                 $CGI::script_name,
1592                                                 $CGI::path_info,
1593                                                 );
1594                 return '';
1595         }
1596
1597         # Check to see if password enabled, then check
1598         if (
1599                 $reconfig eq '1'                and
1600                 !$CGI::user                             and
1601                 $Vend::Cfg->{Password}  and
1602                 crypt($CGI::reconfigure_catalog, $Vend::Cfg->{Password})
1603                 ne  $Vend::Cfg->{Password})
1604         {
1605                 ::logGlobal(
1606                                 { level => 'warning' },
1607                                 "ALERT: Password mismatch, attempt to %s at %s from %s",
1608                                 $msg,
1609                                 $CGI::script_name,
1610                                 $CGI::host,
1611                                 );
1612                         return '';
1613         }
1614
1615         # Finally check to see if remote_user match enabled, then check
1616         if ($Vend::Cfg->{RemoteUser} and
1617                 $CGI::user ne $Vend::Cfg->{RemoteUser})
1618         {
1619                 my $fmt = <<'EOF';
1620 ALERT: Attempt to %s %s per user name:
1621
1622         REMOTE_HOST  %s
1623         REMOTE_ADDR  %s
1624         REMOTE_USER  %s
1625         USER_AGENT   %s
1626         SCRIPT_NAME  %s
1627         PATH_INFO    %s
1628 EOF
1629
1630                 ::logGlobal(
1631                         { level => 'warning' },
1632                         $fmt,
1633                         $CGI::script_name,
1634                         $msg,
1635                         $CGI::remote_host,
1636                         $CGI::remote_addr,
1637                         $CGI::user,
1638                         $CGI::useragent,
1639                         $CGI::script_name,
1640                         $CGI::path_info,
1641                 );
1642                 return '';
1643         }
1644
1645         # Don't allow random reconfigures without one of the three checks
1646         unless ($Vend::Cfg->{MasterHost} or
1647                         $Vend::Cfg->{Password}   or
1648                         $Vend::Cfg->{RemoteUser})
1649         {
1650                 my $fmt = <<'EOF';
1651 Attempt to %s on %s, secure operations disabled.
1652
1653         REMOTE_ADDR  %s
1654         REMOTE_USER  %s
1655         USER_AGENT   %s
1656         SCRIPT_NAME  %s
1657         PATH_INFO    %s
1658 EOF
1659                 ::logGlobal(
1660                                 { level => 'warning' },
1661                                 $fmt,
1662                                 $msg,
1663                                 $CGI::script_name,
1664                                 $CGI::host,
1665                                 $CGI::user,
1666                                 $CGI::useragent,
1667                                 $CGI::script_name,
1668                                 $CGI::path_info,
1669                                 );
1670                         return '';
1671
1672         }
1673
1674         # Authorized if got here
1675         return 1;
1676 }
1677
1678
1679 # Checks the Locale for a special page definintion mv_special_$key and
1680 # returns it if found, otherwise goes to the default Vend::Cfg->{Special} array
1681 sub find_special_page {
1682     my $key = shift;
1683         my $dir = '';
1684         $dir = "../$Vend::Cfg->{SpecialPageDir}/"
1685                 if $Vend::Cfg->{SpecialPageDir};
1686     return $Vend::Cfg->{Special}{$key} || "$dir$key";
1687 }
1688
1689 ## ERROR
1690
1691 # Log the error MSG to the error file.
1692
1693 sub logDebug {
1694         return unless $Global::DebugFile;
1695
1696         if(my $re = $Vend::Cfg->{DebugHost}) {
1697                 return unless
1698                          Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
1699         }
1700
1701         if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
1702                 return unless $sub->();
1703         }
1704
1705         my $msg;
1706
1707         if (my $tpl = $Global::DebugTemplate) {
1708                 my %debug;
1709                 $tpl = POSIX::strftime($tpl, localtime());
1710                 $tpl =~ s/\s*$//;
1711                 $debug{page} = $Global::Variable->{MV_PAGE};
1712                 $debug{tag} = $Vend::CurrentTag;
1713                 $debug{host} = $CGI::host || $CGI::remote_addr;
1714                 $debug{remote_addr} = $CGI::remote_addr;
1715                 $debug{catalog} = $Vend::Cat;
1716         if($tpl =~ /\{caller\d+\}/i) {
1717             my @caller = caller();
1718             for(my $i = 0; $i < @caller; $i++) {
1719                 $debug{"caller$i"} = $caller[$i];
1720             }
1721         }
1722                 $debug{message} = errmsg(@_);
1723
1724                 $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
1725         }
1726         else {
1727                 $msg = caller() . ":debug: " . errmsg(@_);
1728         }
1729
1730         if ($Global::SysLog) {
1731                 logGlobal({ level => 'debug' }, $msg);
1732         }
1733         else {
1734                 print $msg, "\n";
1735         }
1736
1737         return;
1738 }
1739
1740 sub errmsg {
1741         my($fmt, @strings) = @_;
1742         my $location;
1743         if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
1744                 $location = $Vend::Cfg->{Locale};
1745         }
1746         elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
1747                 $location = $Global::Locale;
1748         }
1749         if($location) {
1750                 if(ref $location->{$fmt}) {
1751                         $fmt = $location->{$fmt}[0];
1752                         @strings = @strings[ @{ $location->{$fmt}[1] } ];
1753                 }
1754                 else {
1755                         $fmt = $location->{$fmt};
1756                 }
1757         }
1758         return scalar(@strings) ? sprintf $fmt, @strings : $fmt;
1759 }
1760
1761 *l = \&errmsg;
1762
1763 sub show_times {
1764         my $message = shift || 'time mark';
1765         my @times = times();
1766         for( my $i = 0; $i < @times; $i++) {
1767                 $times[$i] -= $Vend::Times[$i];
1768         }
1769         logDebug("$message: " . join " ", @times);
1770 }
1771
1772 # This %syslog_constant_map is an attempt to work around a strange problem
1773 # where the eval inside &Sys::Syslog::xlate fails, which then croaks.
1774 # The cause of this freakish problem is still to be determined.
1775
1776 my %syslog_constant_map;
1777
1778 sub setup_syslog_constant_map {
1779         for (
1780                 (map { "local$_" } (0..7)),
1781                 qw(
1782                         auth
1783                         authpriv
1784                         cron
1785                         daemon
1786                         ftp
1787                         kern
1788                         lpr
1789                         mail
1790                         news
1791                         syslog
1792                         user
1793                         uucp
1794
1795                         emerg
1796                         alert
1797                         crit
1798                         err
1799                         warning
1800                         notice
1801                         info
1802                         debug
1803                 )
1804         ) {
1805                 $syslog_constant_map{$_} = Sys::Syslog::xlate($_);
1806         }
1807         return;
1808 }
1809
1810 sub logGlobal {
1811         return 1 if $Vend::ExternalProgram;
1812
1813         my $opt;
1814         my $msg = shift;
1815         if (ref $msg) {
1816                 $opt = $msg;
1817                 $msg = shift;
1818         }
1819         else {
1820                 $opt = {};
1821         }
1822
1823         $msg = errmsg($msg, @_) if @_;
1824
1825         $Vend::Errors .= $msg . "\n" if $Global::DisplayErrors;
1826
1827         my $nl = $opt->{strip} ? '' : "\n";
1828         print "$msg$nl"
1829                 if $Global::Foreground
1830                         and ! $Vend::Log_suppress
1831                         and ! $Vend::Quiet
1832                         and ! $Global::SysLog;
1833
1834         my ($fn, $facility, $level);
1835         if ($Global::SysLog) {
1836                 $facility = $Global::SysLog->{facility} || 'local3';
1837                 $level    = $opt->{level} || 'info';
1838
1839                 # remap deprecated synonyms supported by logger(1)
1840                 my %level_map = (
1841                         error => 'err',
1842                         panic => 'emerg',
1843                         warn  => 'warning',
1844                 );
1845
1846                 # remap levels according to any user-defined global configuration
1847                 my $level_cfg;
1848                 if ($level_cfg = $Global::SysLog->{$level_map{$level} || $level}) {
1849                         if ($level_cfg =~ /(.+)\.(.+)/) {
1850                                 ($facility, $level) = ($1, $2);
1851                         }
1852                         else {
1853                                 $level = $level_cfg;
1854                         }
1855                 }
1856                 $level = $level_map{$level} if $level_map{$level};
1857
1858                 my $tag = $Global::SysLog->{tag} || 'interchange';
1859
1860                 my $socket = $opt->{socket} || $Global::SysLog->{socket};
1861
1862                 if ($Global::SysLog->{internal}) {
1863                         unless ($Vend::SysLogReady) {
1864                                 eval {
1865                                         use Sys::Syslog ();
1866                                         if ($socket) {
1867                                                 my ($socket_path, $types) = ($socket =~ /^(\S+)(?:\s+(.*))?/);
1868                                                 $types ||= 'native,tcp,udp,unix,pipe,stream,console';
1869                                                 my $type_array = [ grep /\S/, split /[,\s]+/, $types ];
1870                                                 Sys::Syslog::setlogsock($type_array, $socket_path) or die "Error calling setlogsock\n";
1871                                         }
1872                                         Sys::Syslog::openlog $tag, 'ndelay,pid', $facility;
1873                                 };
1874                                 if ($@) {
1875                                         print "\nError opening syslog: $@\n";
1876                                         print "to report this error:\n", $msg;
1877                                         exit 1;
1878                                 }
1879                                 setup_syslog_constant_map() unless %syslog_constant_map;
1880                                 $Vend::SysLogReady = 1;
1881                         }
1882                 }
1883                 else {
1884                         $fn = '|' . ($Global::SysLog->{command} || 'logger');
1885                         $fn .= " -p $facility.$level";
1886                         $fn .= " -t $tag" unless lc($tag) eq 'none';
1887                         $fn .= " -u $socket" if $socket;
1888                 }
1889         }
1890         else {
1891                 $fn = $Global::ErrorFile;
1892         }
1893
1894         if ($fn) {
1895                 my $lock;
1896                 if ($fn =~ s/^([^|>])/>>$1/) {
1897                         $lock = 1;
1898                         $msg = format_log_msg($msg);
1899                 }
1900
1901                 eval {
1902                         # We have checked for beginning > or | previously
1903                         open(MVERROR, $fn) or die "open\n";
1904                         if ($lock) {
1905                                 lockfile(\*MVERROR, 1, 1) or die "lock\n";
1906                                 seek(MVERROR, 0, 2) or die "seek\n";
1907                         }
1908                         print(MVERROR $msg, "\n") or die "write to\n";
1909                         if ($lock) {
1910                                 unlockfile(\*MVERROR) or die "unlock\n";
1911                         }
1912                         close(MVERROR) or die "close\n";
1913                 };
1914                 if ($@) {
1915                         chomp $@;
1916                         print "\nCould not $@ error file '$Global::ErrorFile':\n$!\n";
1917                         print "to report this error:\n", $msg, "\n";
1918                         exit 1;
1919                 }
1920
1921         }
1922         elsif ($Vend::SysLogReady) {
1923                 eval {
1924                         # avoid eval in Sys::Syslog::xlate() by using cached constants where possible
1925                         my $level_mapped = $syslog_constant_map{$level};
1926                         $level_mapped = $level unless defined $level_mapped;
1927                         my $facility_mapped = $syslog_constant_map{$facility};
1928                         $facility_mapped = $facility unless defined $facility_mapped;
1929                         my $priority = "$level_mapped|$facility_mapped";
1930                         Sys::Syslog::syslog $priority, $msg;
1931                 };
1932         }
1933
1934         return 1;
1935 }
1936
1937 sub logError {
1938         return unless $Vend::Cfg;
1939
1940         my $msg = shift;
1941         my $opt;
1942         if (ref $_[0]) {
1943                 $opt = shift;
1944         }
1945         else {
1946                 $opt = {};
1947         }
1948
1949         unless ($Global::SysLog) {
1950                 if (! $opt->{file}) {
1951                         my $tag = $opt->{tag} || $msg;
1952                         if (my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) {
1953                                 $opt->{file} = $dest;
1954                         }
1955                 }
1956                 $opt->{file} ||= $Vend::Cfg->{ErrorFile};
1957         }
1958
1959         $msg = errmsg($msg, @_) if @_;
1960
1961         print "$msg\n"
1962                 if $Global::Foreground
1963                         and ! $Vend::Log_suppress
1964                         and ! $Vend::Quiet
1965                         and ! $Global::SysLog;
1966
1967         $Vend::Session->{last_error} = $msg;
1968
1969         $msg = format_log_msg($msg) unless $msg =~ s/^\\//;
1970
1971         if ($Global::SysLog) {
1972                 logGlobal({ level => 'err' }, $msg);
1973                 return;
1974         }
1975
1976         $Vend::Errors .= $msg . "\n"
1977                 if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors;
1978
1979     my $reason;
1980     if (! allowed_file($opt->{file}, 1)) {
1981         $@ = 'access';
1982         $reason = 'prohibited by global configuration';
1983     }
1984     else {
1985         eval {
1986             open(MVERROR, '>>', $opt->{file})
1987                                         or die "open\n";
1988             lockfile(\*MVERROR, 1, 1)   or die "lock\n";
1989             seek(MVERROR, 0, 2)         or die "seek\n";
1990             print(MVERROR $msg, "\n")   or die "write to\n";
1991             unlockfile(\*MVERROR)       or die "unlock\n";
1992             close(MVERROR)              or die "close\n";
1993         };
1994     }
1995     if ($@) {
1996                 chomp $@;
1997                 logGlobal ({ level => 'info' },
1998                                         "Could not %s error file %s: %s\nto report this error: %s",
1999                                         $@,
2000                                         $opt->{file},
2001                                         $reason || $!,
2002                                         $msg,
2003                                 );
2004                 }
2005
2006         return;
2007 }
2008
2009 # Front-end to log routines that ignores repeated identical
2010 # log messages after the first occurrence
2011 my %logOnce_cache;
2012 my %log_sub_map = (
2013         data    => \&logData,
2014         debug   => \&logDebug,
2015         error   => \&logError,
2016         global  => \&logGlobal,
2017 );
2018
2019 # First argument should be log type (see above map).
2020 # Rest of arguments are same as if calling log routine directly.
2021 sub logOnce {
2022         my $tag = join "", @_;
2023         return if exists $logOnce_cache{$tag};
2024         my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error};
2025         my $status = $log_sub->(@_);
2026         $logOnce_cache{$tag} = 1;
2027         return $status;
2028 }
2029
2030
2031 # Here for convenience in calls
2032 sub set_cookie {
2033     my ($name, $value, $expire, $domain, $path, $secure) = @_;
2034
2035     # Set expire to now + some time if expire string is something like
2036     # "30 days" or "7 weeks" or even "60 minutes"
2037         if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
2038             $expire = adjust_time($expire);
2039         }
2040
2041         if (! $::Instance->{Cookies}) {
2042                 $::Instance->{Cookies} = []
2043         }
2044         else {
2045                 @{$::Instance->{Cookies}} =
2046                         grep $_->[0] ne $name, @{$::Instance->{Cookies}};
2047         }
2048     push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
2049     return;
2050 }
2051
2052 # Here for convenience in calls
2053 sub read_cookie {
2054         my ($lookfor, $string) = @_;
2055         $string = $CGI::cookie
2056                 unless defined $string;
2057     return cookies_hash($string) unless defined $lookfor && length($lookfor);
2058     return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
2059         return unescape_chars($1);
2060 }
2061
2062 sub cookies_hash {
2063     my $string = shift || $CGI::cookie;
2064     my %cookies = map {
2065         my ($k,$v) = split '=', $_, 2;
2066         $k => unescape_chars($v)
2067     } split(/;\s*/, $string);
2068     return \%cookies;
2069 }
2070
2071 sub send_mail {
2072         my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
2073
2074         if(ref $to) {
2075                 my $head = $to;
2076
2077                 for(my $i = $#$head; $i > 0; $i--) {
2078                         if($head->[$i] =~ /^\s/) {
2079                                 my $new = splice @$head, $i, 1;
2080                                 $head->[$i - 1] .= "\n$new";
2081                         }
2082                 }
2083
2084                 $body = $subject;
2085                 undef $subject;
2086                 for(@$head) {
2087                         s/\s+$//;
2088                         if (/^To:\s*(.+)/si) {
2089                                 $to = $1;
2090                         }
2091                         elsif (/^Reply-to:\s*(.+)/si) {
2092                                 $reply = $1;
2093                         }
2094                         elsif (/^subj(?:ect)?:\s*(.+)/si) {
2095                                 $subject = $1;
2096                         }
2097                         elsif($_) {
2098                                 push @extra_headers, $_;
2099                         }
2100                 }
2101         }
2102
2103         # If configured, intercept all outgoing email and re-route
2104         if (
2105                 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
2106                                 || $Global::Variable->{MV_EMAIL_INTERCEPT}
2107         ) {
2108                 my @info_headers;
2109                 $to = "To: $to";
2110                 for ($to, @extra_headers) {
2111                         next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
2112                         logError(
2113                                 "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
2114                                 $header, $value, $intercept
2115                         );
2116                         $_ = "$header: $intercept";
2117                         push @info_headers, "X-Intercepted-$header: $value";
2118                 }
2119                 $to =~ s/^To: //;
2120                 push @extra_headers, @info_headers;
2121         }
2122
2123         my($ok);
2124 #::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
2125
2126         unless (defined $use_mime) {
2127                 $use_mime = $::Instance->{MIME} || undef;
2128         }
2129
2130         if(!defined $reply) {
2131                 $reply = $::Values->{mv_email}
2132                                 ?  "Reply-To: $::Values->{mv_email}\n"
2133                                 : '';
2134         }
2135         elsif ($reply) {
2136                 $reply = "Reply-To: $reply\n"
2137                         unless $reply =~ /^reply-to:/i;
2138                 $reply =~ s/\s+$/\n/;
2139         }
2140
2141         $ok = 0;
2142         my $none;
2143         my $using = $Vend::Cfg->{SendMailProgram};
2144
2145         if($using =~ /^(none|Net::SMTP)$/i) {
2146                 $none = 1;
2147                 $ok = 1;
2148         }
2149
2150         SEND: {
2151 #::logDebug("testing sendmail send none=$none");
2152                 last SEND if $none;
2153 #::logDebug("in Sendmail send $using");
2154                 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
2155                 my $mime = '';
2156                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2157                 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
2158                         or last SEND;
2159                 for(@extra_headers) {
2160                         s/\s*$/\n/;
2161                         print MVMAIL $_
2162                                 or last SEND;
2163                 }
2164                 $mime =~ s/\s*$/\n/;
2165                 print MVMAIL $mime
2166                         or last SEND;
2167                 print MVMAIL $body
2168                                 or last SEND;
2169                 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
2170                         if $use_mime;
2171                 print MVMAIL "\r\n\cZ" if $Global::Windows;
2172                 close MVMAIL or last SEND;
2173                 $ok = ($? == 0);
2174         }
2175
2176         SMTP: {
2177                 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
2178                 my $helo =  $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
2179                 last SMTP unless $none and $mhost;
2180                 eval {
2181                         require Net::SMTP;
2182                 };
2183                 last SMTP if $@;
2184                 $ok = 0;
2185                 $using = "Net::SMTP (mail server $mhost)";
2186 #::logDebug("using $using");
2187                 undef $none;
2188
2189                 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP;
2190 #::logDebug("smtp object $smtp");
2191
2192                 my $from = $::Variable->{MV_MAILFROM}
2193                                 || $Global::Variable->{MV_MAILFROM}
2194                                 || $Vend::Cfg->{MailOrderTo};
2195
2196                 for(@extra_headers) {
2197                         s/\s*$/\n/;
2198                         next unless /^From:\s*(\S.+)$/mi;
2199                         $from = $1;
2200                 }
2201                 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
2202                 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
2203
2204                 my $mime = '';
2205                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2206                 $smtp->mail($from)
2207                         or last SMTP;
2208 #::logDebug("smtp accepted from=$from");
2209
2210                 my @to;
2211                 my @addr = split /\s*,\s*/, $to;
2212                 for (@addr) {
2213                         if(/\s/) {
2214                                 ## Uh-oh. Try to handle
2215                                 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
2216                                         push @to, $1
2217                                 }
2218                                 else {
2219                                         logError("Net::SMTP sender skipping unparsable address %s", $_);
2220                                 }
2221                         }
2222                         else {
2223                                 push @to, $_;
2224                         }
2225                 }
2226
2227                 @addr = $smtp->recipient(@to, { SkipBad => 1 });
2228                 if(scalar(@addr) != scalar(@to)) {
2229                         logError(
2230                                 "Net::SMTP not able to send to all addresses of %s",
2231                                 join(", ", @to),
2232                         );
2233                 }
2234
2235 #::logDebug("smtp accepted to=" . join(",", @addr));
2236
2237                 $smtp->data();
2238
2239                 push @extra_headers, $reply if $reply;
2240                 for ("To: $to", "Subject: $subject", @extra_headers) {
2241                         next unless $_;
2242                         s/\s*$/\n/;
2243 #::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
2244                         $smtp->datasend($_)
2245                                 or last SMTP;
2246                 }
2247
2248                 if($use_mime) {
2249                         $mime =~ s/\s*$/\n/;
2250                         $smtp->datasend($mime)
2251                                 or last SMTP;
2252                 }
2253                 $smtp->datasend("\n");
2254                 $smtp->datasend($body)
2255                         or last SMTP;
2256                 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
2257                         if $use_mime;
2258                 $smtp->dataend()
2259                         or last SMTP;
2260                 $ok = $smtp->quit();
2261         }
2262
2263         if ($none or !$ok) {
2264                 logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
2265                                 $using,
2266                                 $to,
2267                                 $subject,
2268                                 $reply,
2269                                 $body,
2270                 );
2271         }
2272
2273         $ok;
2274 }
2275
2276 sub codedef_routine {
2277         my ($tag, $routine, $modifier) = @_;
2278
2279         my $area = $Vend::Config::tagCanon{lc $tag}
2280                 or do {
2281                         logError("Unknown CodeDef type %s", $tag);
2282                         return undef;
2283                 };
2284
2285         $routine =~ s/-/_/g;
2286         my @tries;
2287         if ($tag eq 'UserTag') {
2288                 @tries = ($Vend::Cfg->{UserTag}, $Global::UserTag);
2289                 }
2290         else {
2291                 @tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area});
2292         }
2293
2294         no strict 'refs';
2295
2296         my $ref;
2297
2298         for my $base (@tries) {
2299                 next unless $base;
2300             $ref = $base->{Routine}{$routine}
2301                          and return $ref;
2302                 $ref = $base->{MapRoutine}{$routine}
2303                    and return \&{"$ref"};
2304         }
2305
2306         return undef unless $Global::AccumulateCode;
2307 #::logDebug("trying code_from file for area=$area routine=$routine");
2308         $ref = Vend::Config::code_from_file($area, $routine)
2309                 or return undef;
2310 #::logDebug("returning ref=$ref for area=$area routine=$routine");
2311         return $ref;
2312 }
2313
2314 sub codedef_options {
2315         my ($tag, $modifier) = @_;
2316
2317         my @out;
2318         my $empty;
2319
2320         my @keys = keys %{$Vend::Cfg->{CodeDef}};
2321         push @keys, keys %{$Global::CodeDef};
2322
2323         my %gate = ( public => 1 );
2324
2325         my @mod = grep /\w/, split /[\s\0,]+/, $modifier;
2326         for(@mod) {
2327                 if($_ eq 'all') {
2328                         $gate{private} = 1;
2329                 }
2330
2331                 if($_ eq 'empty') {
2332                         $empty = ['', errmsg('--select--')];
2333                 }
2334
2335                 if($_ eq 'admin') {
2336                         $gate{admin} = 1;
2337                 }
2338         }
2339
2340         for(@keys) {
2341                 if(lc($tag) eq lc($_)) {
2342                         $tag = $_;
2343                         last;
2344                 }
2345         }
2346
2347         my %seen;
2348
2349         for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) {
2350                 if(my $desc = $repos->{Description}) {
2351                         my $vis = $repos->{Visibility} || {};
2352                         my $help = $repos->{Help} || {};
2353                         while( my($k, $v) = each %$desc) {
2354                                 next if $seen{$k}++;
2355                                 if(my $perm = $vis->{$k}) {
2356                                         if($perm =~ /^with\s+([\w:]+)/) {
2357                                                 my $mod = $1;
2358                                                 no strict 'refs';
2359                                                 next unless ${$mod . "::VERSION"};
2360                                         }
2361                                         else {
2362                                                 next unless $gate{$perm};
2363                                         }
2364                                 }
2365                                 push @out, [$k, $v, $help->{$k}];
2366                         }
2367                 }
2368         }
2369
2370         if(@out) {
2371                 @out = sort { $a->[1] cmp $b->[1] } @out;
2372                 unshift @out, $empty if $empty;
2373         }
2374         else {
2375                 push @out, ['', errmsg('--none--') ];
2376         }
2377         return \@out;
2378 }
2379
2380
2381 # Adds a timestamp to the end of a binary timecard file. You can specify the timestamp
2382 # as the second arg (unixtime) or just leave it out (or undefined) and it will be set
2383 # to the current time.
2384 sub timecard_stamp {
2385         my ($filename,$timestamp) = @_;
2386         $timestamp ||= time;
2387
2388         open(FH, '>>', $filename) or die "Can't open $filename for append: $!";
2389         lockfile(\*FH, 1, 1);
2390         binmode FH;
2391         print FH pack('N',time);
2392         unlockfile(\*FH);
2393         close FH;
2394 }
2395
2396
2397 # Reads a timestamp from a binary timecard file.  If $index is negative indexes back from
2398 # the end of the file, otherwise indexes from the front of the file so that 0 is the first
2399 # (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if
2400 # the file doesn't exist or the index falls outside of the bounds of the timecard file.
2401 sub timecard_read {
2402         my ($filename,$index) = @_;
2403         $index *= 4;
2404         my $limit = $index >= 0 ? $index + 4 : $index * -1;
2405
2406         if (-f $filename && (stat(_))[7] % 4) {
2407             # The file is corrupt, delete it and start over.
2408             ::logError("Counter file $filename found to be corrupt, deleting.");
2409             unlink($filename);
2410             return;
2411         }
2412         return unless (-f _ && (stat(_))[7] > $limit);
2413
2414         # The file exists and is big enough to cover the $index. Seek to the $index
2415         # and return the timestamp from that position.
2416
2417         open (FH, '<', $filename) or die "Can't open $filename for read: $!";
2418         lockfile(\*FH, 0, 1);
2419         binmode FH;
2420         seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!";
2421         my $rtime;
2422         read(FH,$rtime,4) or die "Can't read from $filename: $!";
2423         unlockfile(\*FH);
2424         close FH;
2425
2426         return unpack('N',$rtime);
2427 }
2428
2429 #
2430 # Adjusts a unix time stamp (2nd arg) by the amount specified in the first arg.  First arg should be
2431 # a number (signed integer or float) followed by one of second(s), minute(s), hour(s), day(s)
2432 # week(s) month(s) or year(s).  Second arg defaults to the current time.  If the third arg is true
2433 # the time will be compensated for daylight savings time (so that an adjustment of 6 months will
2434 # still cause the same time to be displayed, even if it is transgressing the DST boundary).
2435 #
2436 # This will accept multiple adjustments strung together, so you can do: "-5 days, 2 hours, 6 mins"
2437 # and the time will have thost amounts subtracted from it.  You can also add and subtract in the
2438 # same line, "+2 years -3 days".  If you specify a sign (+ or -) then that sign will remain in
2439 # effect until a new sign is specified on the line (so you can do,
2440 # "+5 years, 6 months, 3 days, -4 hours, 7 minutes").  The comma (,) between adjustments is
2441 # optional.
2442 #
2443 sub adjust_time {
2444     my ($adjust, $time, $compensate_dst) = @_;
2445     $time ||= time;
2446
2447     unless ($adjust =~ /^(?:\s*[+-]?\s*[\d\.]+\s*[a-z]*\s*,?)+$/i) {
2448         ::logError("adjust_time(): bad format: $adjust");
2449         return $time;
2450     }
2451
2452     # @times: 0: sec, 1: min, 2: hour, 3: day, 4: month, 5: year, 8: isdst
2453     # 6,7: dow and doy, but mktime ignores these (and so do we).
2454
2455     # A note about isdst: localtime returns 1 if returned time is adjusted for dst and 0 otherwise.
2456     # mktime expects the same, but if this is set to -1 mktime will determine if the date should be
2457     # dst adjusted according to dst rules for the current timezone.  The way that we use this is we
2458     # leave it set to the return value from locatime and we end up with a time that is adjusted by
2459     # an absolute amount (so if you adjust by six months the actual time returned may be different
2460     # but only because of DST).  If we want mktime to compensate for dst then we set this to -1 and
2461     # mktime will make the appropriate adjustment for us (either add one hour or subtract one hour
2462     # or leave the time the same).
2463
2464     my @times = localtime($time);
2465     my $sign = 1;
2466
2467     foreach my $amount ($adjust =~ /([+-]?\s*[\d\.]+\s*[a-z]*)/ig) {
2468         my $unit = 'seconds';
2469         $amount =~ s/\s+//g;
2470
2471         if ($amount =~ s/^([+-])//)   { $sign = $1 eq '+' ? 1 : -1 }
2472         if ($amount =~ s/([a-z]+)$//) { $unit = lc $1 }
2473         $amount *= $sign;
2474
2475         # A week is simply 7 days.
2476         if ($unit =~ /^w/) {
2477             $unit = 'days';
2478             $amount *= 7;
2479         }
2480
2481         if ($unit =~ /^s/) { $times[0] += $amount }
2482         elsif ($unit =~ /^mo/) { $times[4] += $amount } # has to come before min
2483         elsif ($unit =~ /^m/) { $times[1] += $amount }
2484         elsif ($unit =~ /^h/) { $times[2] += $amount }
2485         elsif ($unit =~ /^d/) { $times[3] += $amount }
2486         elsif ($unit =~ /^y/) { $times[5] += $amount }
2487
2488         else {
2489             ::logError("adjust_time(): bad unit: $unit");
2490             return $time;
2491         }
2492     }
2493
2494     if ($compensate_dst) { $times[8] = -1 }
2495
2496     # mktime can only handle integers, so we need to convert real numbers:
2497     my @multip = (0, 60, 60, 24, 0, 12);
2498     my $monfrac = 0;
2499     foreach my $i (reverse 0..5) {
2500         if ($times[$i] =~ /\./) {
2501             if ($multip[$i]) {
2502                 $times[$i-1] += ($times[$i] - int $times[$i]) * $multip[$i];
2503             }
2504
2505             elsif ($i == 4) {
2506                 # Fractions of a month need some really extra special handling.
2507                 $monfrac = $times[$i] - int $times[$i];
2508             }
2509
2510             $times[$i] = int $times[$i]
2511         }
2512     }
2513
2514     $time = POSIX::mktime(@times);
2515
2516     # This is how we handle a fraction of a month:
2517     if ($monfrac) {
2518         $times[4] += $monfrac > 0 ? 1 : -1;
2519         my $timediff = POSIX::mktime(@times);
2520         $timediff = int(abs($timediff - $time) * $monfrac);
2521         $time += $timediff;
2522     }
2523
2524     return $time;
2525 }
2526
2527 sub backtrace {
2528     my $msg = "Backtrace:\n\n";
2529     my $frame = 1;
2530
2531     my $assertfile = '';
2532     my $assertline = 0;
2533
2534     while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) {
2535         $msg .= sprintf("   frame %d: $subroutine ($filename line $line)\n", $frame - 2);
2536         if ($subroutine =~ /assert$/) {
2537             $assertfile = $filename;
2538             $assertline = $line;
2539         }
2540     }
2541     if ($assertfile) {
2542         open(SRC, $assertfile) and do {
2543             my $line;
2544             my $line_n = 0;
2545
2546             $msg .= "\nProblem in $assertfile line $assertline:\n\n";
2547
2548             while ($line = <SRC>) {
2549                 $line_n++;
2550                 $msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10);
2551             }
2552             close(SRC);
2553         };
2554     }
2555
2556     ::logGlobal($msg);
2557     undef;
2558 }
2559
2560 sub header_data_scrub {
2561         my ($head_data) = @_;
2562
2563         ## "HTTP Response Splitting" Exploit Fix
2564         ## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html
2565         $head_data =~ s/(?:%0[da]|[\r\n]+)+//ig;
2566
2567         return $head_data;
2568 }
2569
2570 ### Provide stubs for former Vend::Util functions relocated to Vend::File
2571 *canonpath = \&Vend::File::canonpath;
2572 *catdir = \&Vend::File::catdir;
2573 *catfile = \&Vend::File::catfile;
2574 *exists_filename = \&Vend::File::exists_filename;
2575 *file_modification_time = \&Vend::File::file_modification_time;
2576 *file_name_is_absolute = \&Vend::File::file_name_is_absolute;
2577 *get_filename = \&Vend::File::get_filename;
2578 *lockfile = \&Vend::File::lockfile;
2579 *path = \&Vend::File::path;
2580 *readfile = \&Vend::File::readfile;
2581 *readfile_db = \&Vend::File::readfile_db;
2582 *set_lock_type = \&Vend::File::set_lock_type;
2583 *unlockfile = \&Vend::File::unlockfile;
2584 *writefile = \&Vend::File::writefile;
2585
2586 1;
2587 __END__