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             $key =~ s/(['\\])/\\$1/g;
 659             $s .= "'$key' => " . uneval_it($value) . ",";
 660         }
 661         $s .= "}";
 662     } else {
 663         $s = "'something else'";
 664     }
 665
 666     $s;
 667 }
 668
 669 use subs 'uneval_fast';
 670
 671 sub uneval_it_file {
 672         my ($ref, $fn) = @_;
 673         open(UNEV, ">$fn")
 674                 or die "Can't create $fn: $!\n";
 675         print UNEV uneval_fast($ref);
 676         close UNEV;
 677 }
 678
 679 sub eval_it_file {
 680         my ($fn) = @_;
 681         local($/) = undef;
 682         open(UNEV, "< $fn") or return undef;
 683         my $ref = evalr(<UNEV>);
 684         close UNEV;
 685         return $ref;
 686 }
 687
 688 # See if we have Storable and the user has OKed its use
 689 # If so, session storage/write will be about 5x faster
 690 eval {
 691         die unless $ENV{MINIVEND_STORABLE};
 692         require Storable;
 693         import Storable 'freeze';
 694
 695         if ($ENV{MINIVEND_STORABLE_CODE}) {
 696                 # allow code references to be stored to the session
 697                  $Storable::Deparse = 1;
 698                  $Storable::Eval = 1;
 699         }
 700
 701         $Fast_uneval     = \&Storable::freeze;
 702         $Fast_uneval_file  = \&Storable::store;
 703         $Eval_routine    = \&Storable::thaw;
 704         $Eval_routine_file = \&Storable::retrieve;
 705 };
 706
 707 # See if Data::Dumper is installed with XSUB
 708 # If it is, session writes will be about 25-30% faster
 709 eval {
 710                 die if $ENV{MINIVEND_NO_DUMPER};
 711                 require Data::Dumper;
 712                 import Data::Dumper 'DumperX';
 713                 $Data::Dumper::Indent = 1;
 714                 $Data::Dumper::Terse = 1;
 715                 $Data::Dumper::Deepcopy = 1;
 716                 if(defined $Fast_uneval) {
 717                         $Pretty_uneval = \&Data::Dumper::Dumper;
 718                 }
 719                 else {
 720                         $Pretty_uneval = \&Data::Dumper::DumperX;
 721                         $Fast_uneval = \&Data::Dumper::DumperX
 722                 }
 723 };
 724
 725 *uneval_fast = defined $Fast_uneval       ? $Fast_uneval       : \&uneval_it;
 726 *evalr       = defined $Eval_routine      ? $Eval_routine      : sub { eval shift };
 727 *eval_file   = defined $Eval_routine_file ? $Eval_routine_file : \&eval_it_file;
 728 *uneval_file = defined $Fast_uneval_file  ? $Fast_uneval_file  : \&uneval_it_file;
 729 *uneval      = defined $Pretty_uneval     ? $Pretty_uneval     : \&uneval_it;
 730
 731
 732
 733 # Log data fields to a data file.
 734
 735 sub logData {
 736     my($file,@msg) = @_;
 737     my $prefix = '';
 738
 739         $file = ">>$file" unless $file =~ /^[|>]/;
 740
 741         my $msg = tabbed @msg;
 742
 743     eval {
 744                 unless($file =~ s/^[|]\s*//) {
 745                         # We have checked for beginning > or | previously
 746                         open(MVLOGDATA, $file)          or die "open\n";
 747                         lockfile(\*MVLOGDATA, 1, 1)     or die "lock\n";
 748                         seek(MVLOGDATA, 0, 2)           or die "seek\n";
 749                         print(MVLOGDATA "$msg\n")       or die "write to\n";
 750                         unlockfile(\*MVLOGDATA)         or die "unlock\n";
 751                 }
 752                 else {
 753             my (@args) = grep /\S/, Text::ParseWords::shellwords($file);
 754                         open(MVLOGDATA, "|-") || exec @args;
 755                         print(MVLOGDATA "$msg\n") or die "pipe to\n";
 756                 }
 757                 close(MVLOGDATA) or die "close\n";
 758     };
 759     if ($@) {
 760
 761                 if($::Limit->{logdata_error_length} > 0) {
 762                         $msg = substr($msg, 0, $::Limit->{logdata_error_length});
 763                 }
 764
 765                 logError ("Could not %s log file '%s': %s\nto log this data:\n%s",
 766                                 $@,
 767                                 $file,
 768                                 $!,
 769                                 $msg,
 770                                 );
 771                 return 0;
 772     }
 773         1;
 774 }
 775
 776
 777
 778 sub quoted_comma_string {
 779         my ($text) = @_;
 780         my (@fields);
 781         push(@fields, $+) while $text =~ m{
 782    "([^\"\\]*(?:\\.[^\"\\]*)*)"[\s,]?  ## std quoted string, w/possible space-comma
 783    | ([^\s,]+)[\s,]?                   ## anything else, w/possible space-comma
 784    | [,\s]+                            ## any comma or whitespace
 785         }gx;
 786     @fields;
 787 }
 788
 789 # Modified from old, old module called Ref.pm
 790 sub copyref {
 791     my($x,$r) = @_;
 792
 793     my($z, $y);
 794
 795     my $rt = ref $x;
 796
 797     if ($rt =~ /SCALAR/) {
 798         # Would \$$x work?
 799         $z = $$x;
 800         return \$z;
 801     } elsif ($rt =~ /HASH/) {
 802         $r = {} unless defined $r;
 803         for $y (sort keys %$x) {
 804             $r->{$y} = &copyref($x->{$y}, $r->{$y});
 805         }
 806         return $r;
 807     } elsif ($rt =~ /ARRAY/) {
 808         $r = [] unless defined $r;
 809         for ($y = 0; $y <= $#{$x}; $y++) {
 810             $r->[$y] = &copyref($x->[$y]);
 811         }
 812         return $r;
 813     } elsif ($rt =~ /REF/) {
 814         $z = &copyref($x);
 815         return \$z;
 816     } elsif (! $rt) {
 817         return $x;
 818     } else {
 819         die "do not know how to copy $x";
 820     }
 821 }
 822
 823 sub check_gate {
 824         my($f, $gatedir) = @_;
 825
 826         my $gate;
 827         if ($gate = readfile("$gatedir/.access_gate") ) {
 828                 $f =~ s:.*/::;
 829                 $gate = Vend::Interpolate::interpolate_html($gate);
 830                 if($gate =~ m!^$f(?:\.html?)?[ \t]*:!m ) {
 831                         $gate =~ s!.*(\n|^)$f(?:\.html?)?[ \t]*:!!s;
 832                         $gate =~ s/\n[\S].*//s;
 833                         $gate =~ s/^\s+//;
 834                 }
 835                 elsif($gate =~ m{^\*(?:\.html?)?[: \t]+(.*)}m) {
 836                         $gate = $1;
 837                 }
 838                 else {
 839                         undef $gate;
 840                 }
 841         }
 842         return $gate;
 843 }
 844
 845 sub string_to_ref {
 846         my ($string) = @_;
 847         if($MVSAFE::Safe) {
 848                 return eval $string;
 849         }
 850         my $safe = $Vend::Interpolate::safe_safe || new Vend::Safe;
 851         return $safe->reval($string);
 852 }
 853
 854 sub is_hash {
 855         return ref($_[0]) eq 'HASH';
 856 }
 857
 858 # Verify that passed string is a valid IPv4 address.
 859 sub is_ipv4 {
 860     my $addr = shift or return;
 861     my @segs = split '.', $addr;
 862     return unless @segs == 4;
 863     foreach (@segs) {
 864         return unless /^\d{1,3}$/ && !/^0\d/;
 865         return unless $_ <= 255;
 866     }
 867     return 1;
 868 }
 869
 870 # Verify that passed string is a valid IPv6 address.
 871 sub is_ipv6 {
 872     my $addr = shift or return;
 873     my @segs = split ':', $addr;
 874
 875     my $quads = 8;
 876     # Check for IPv4 style ending
 877     if ($segs[-1] =~ /\./) {
 878         return unless is_ipv4(pop @segs);
 879         $quads = 6;
 880     }
 881
 882     # Check the special case of the :: abbreviation.
 883     if ($addr =~ /::/) {
 884         # Three :'s together is wrong, though.
 885         return if $addr =~ /:::/;
 886         # Also only one set of :: is allowed.
 887         return if $addr =~ /::.*::/;
 888         # Check that we don't have too many quads.
 889         return if @segs >= $quads;
 890     }
 891     else {
 892         # No :: abbreviation, so the number of quads must be exact.
 893         return unless @segs == $quads;
 894     }
 895
 896     # Check the validity of each quad
 897     foreach (@segs) {
 898         return unless /^[0-9a-f]{1,4}$/i;
 899     }
 900
 901     return 1;
 902 }
 903
 904 sub dotted_hash {
 905         my($hash, $key, $value, $delete_empty) = @_;
 906         $hash = get_option_hash($hash) unless is_hash($hash);
 907         unless (is_hash($hash)) {
 908                 return undef unless defined $value;
 909                 $hash = {};
 910         }
 911         my @keys = split /[\.:]+/, $key;
 912         my $final;
 913         my $ref;
 914
 915         if(! defined $value) {
 916                 # Retrieving
 917                 $ref = $hash->{shift @keys};
 918                 for(@keys) {
 919                         return undef unless is_hash($ref);
 920                         $ref = $ref->{$_};
 921                 }
 922                 return $ref;
 923         }
 924
 925         # Storing
 926         $final = pop @keys;
 927         $ref = $hash;
 928
 929         for(@keys) {
 930                 $ref->{$_} = {} unless is_hash($ref->{$_});
 931                 $ref = $ref->{$_};
 932         }
 933
 934         if($delete_empty and ! length($value)) {
 935                 delete $ref->{$final};
 936         }
 937         else {
 938                 $ref->{$final} = $value;
 939         }
 940
 941         $hash = uneval_it($hash);
 942         return $hash;
 943 }
 944
 945 sub get_option_hash {
 946         my $string = shift;
 947         my $merge = shift;
 948         if (ref $string eq 'HASH') {
 949                 my $ref = { %$string };
 950                 return $ref unless ref $merge;
 951                 for(keys %{$merge}) {
 952                         $ref->{$_} = $merge->{$_}
 953                                 unless defined $ref->{$_};
 954                 }
 955                 return $ref;
 956         }
 957         return {} unless $string and $string =~ /\S/;
 958         $string =~ s/^\s+//;
 959         $string =~ s/\s+$//;
 960         if($string =~ /^{/ and $string =~ /}/) {
 961                 return string_to_ref($string);
 962         }
 963
 964         my @opts;
 965         unless ($string =~ /,/) {
 966                 @opts = grep $_ ne "=", Text::ParseWords::shellwords($string);
 967                 for(@opts) {
 968                         s/^(\w[-\w]*\w)=(["'])(.*)\2$/$1$3/;
 969                 }
 970         }
 971         else {
 972                 @opts = split /\s*,\s*/, $string;
 973         }
 974
 975         my %hash;
 976         for(@opts) {
 977                 my ($k, $v) = split /[\s=]+/, $_, 2;
 978                 $k =~ s/-/_/g;
 979                 $hash{$k} = $v;
 980         }
 981         if($merge) {
 982                 return \%hash unless ref $merge;
 983                 for(keys %$merge) {
 984                         $hash{$_} = $merge->{$_}
 985                                 unless defined $hash{$_};
 986                 }
 987         }
 988         return \%hash;
 989 }
 990
 991 sub word2ary {
 992         my $val = shift;
 993         return $val if ref($val) eq 'ARRAY';
 994         my @ary = grep /\w/, split /[\s,\0]+/, $val;
 995         return \@ary;
 996 }
 997
 998 sub ary2word {
 999         my $val = shift;
1000         return $val if ref($val) ne 'ARRAY';
1001         @$val = grep /\w/, @$val;
1002         return join " ", @$val;
1003 }
1004
1005 ## Takes an IC scalar form value (parm=val\nparm2=val) and translates it
1006 ## to a reference
1007
1008 sub scalar_to_hash {
1009         my $val = shift;
1010
1011         $val =~ s/^\s+//mg;
1012         $val =~ s/\s+$//mg;
1013         my @args;
1014
1015         @args = split /\n+/, $val;
1016
1017         my $ref = {};
1018
1019         for(@args) {
1020                 m!([^=]+)=(.*)!
1021                         and $ref->{$1} = $2;
1022         }
1023         return $ref;
1024 }
1025
1026 ## Takes a form reference (i.e. from \%CGI::values) and makes into a
1027 ## scalar value value (i.e. parm=val\nparm2=val). Also translates it
1028 ## via HTML entities -- it is designed to make it into a hidden
1029 ## form value
1030
1031 sub hash_to_scalar {
1032         my $ref = shift
1033                 or return '';
1034
1035         unless (ref($ref) eq 'HASH') {
1036                 die __PACKAGE__ . " hash_to_scalar routine got bad reference.\n";
1037         }
1038
1039         my @parms;
1040         while( my($k, $v) = each %$ref ) {
1041                 $v =~ s/\r?\n/\r/g;
1042                 push @parms, HTML::Entities::encode("$k=$v");
1043         }
1044         return join "\n", @parms;
1045 }
1046
1047 ## This simply returns a hash of words, which may be quoted shellwords
1048 ## Replaces most of parse_hash in Vend::Config
1049 sub hash_string {
1050         my($settings, $ref) = @_;
1051
1052         return $ref if ! $settings or $settings !~ /\S/;
1053
1054         $ref ||= {};
1055
1056         $settings =~ s/^\s+//;
1057         $settings =~ s/\s+$//;
1058         my(@setting) = Text::ParseWords::shellwords($settings);
1059
1060         my $i;
1061         for ($i = 0; $i < @setting; $i += 2) {
1062                 $ref->{$setting[$i]} = $setting[$i + 1];
1063         }
1064         return $ref;
1065 }
1066
1067 ## READIN
1068
1069 my $Lang;
1070
1071 sub find_locale_bit {
1072         my $text = shift;
1073         unless (defined $Lang) {
1074                 $Lang = $::Scratch->{mv_locale} || $Vend::Cfg->{DefaultLocale};
1075         }
1076         $text =~ m{\[$Lang\](.*)\[/$Lang\]}s
1077                 and return $1;
1078         $text =~ s{\[(\w+)\].*\[/\1\].*}{}s;
1079         return $text;
1080 }
1081
1082 sub parse_locale {
1083         my ($input) = @_;
1084
1085         return if $::Pragma->{no_locale_parse};
1086
1087         # avoid copying big strings
1088         my $r = ref($input) ? $input : \$input;
1089
1090         if($Vend::Cfg->{Locale}) {
1091                 my $key;
1092                 $$r =~ s~\[L(\s+([^\]]+))?\]((?s:.)*?)\[/L\]~
1093                                                 $key = $2 || $3;
1094                                                 defined $Vend::Cfg->{Locale}{$key}
1095                                                 ?  ($Vend::Cfg->{Locale}{$key}) : $3 ~eg;
1096                 $$r =~ s~\[LC\]((?s:.)*?)\[/LC\]~
1097                                                 find_locale_bit($1) ~eg;
1098                 undef $Lang;
1099         }
1100         else {
1101                 $$r =~ s~\[L(?:\s+[^\]]+)?\]((?s:.)*?)\[/L\]~$1~g;
1102         }
1103
1104         # return scalar string if one get passed initially
1105         return ref($input) ? $input : $$r;
1106 }
1107
1108 sub teleport_name {
1109         my ($file, $teleport, $table) = @_;
1110         my $db;
1111         return $file
1112                 unless   $teleport
1113                         and  $db = Vend::Data::database_exists_ref($table);
1114
1115         my @f = qw/code base_code expiration_date show_date page_text/;
1116         my ($c, $bc, $ed, $sd, $pt) = @{$Vend::Cfg->{PageTableMap}}{@f};
1117         my $q = qq{
1118                 SELECT $c from $table
1119                 WHERE  $bc = '$file'
1120                 AND    $ed <  $teleport
1121                 AND    $sd >= $teleport
1122                 ORDER BY $sd DESC
1123         };
1124         my $ary = $db->query($q);
1125         if($ary and $ary->[0]) {
1126                 $file = $ary->[0][0];
1127         }
1128         return $file;
1129 }
1130
1131 # Reads in a page from the page directory with the name FILE and ".html"
1132 # appended. If the HTMLsuffix configuration has changed (because of setting in
1133 # catalog.cfg or Locale definitions) it will substitute that. Returns the
1134 # entire contents of the page, or undef if the file could not be read.
1135 # Substitutes Locale bits as necessary.
1136
1137 sub readin {
1138     my($file, $only, $locale) = @_;
1139
1140         ## We don't want to try if we are forcing a flypage
1141         return undef if $Vend::ForceFlypage;
1142
1143     my($fn, $contents, $gate, $pathdir, $dir, $level);
1144     local($/);
1145
1146         if($file =~ m{[\[<]}) {
1147                 ::logGlobal("Possible code/SQL injection attempt with file name '%s'", $file);
1148                 $file = escape_chars($file);
1149                 ::logGlobal("Suspect file changed to '%s'", $file);
1150         }
1151
1152         $Global::Variable->{MV_PREV_PAGE} = $Global::Variable->{MV_PAGE}
1153                 if defined $Global::Variable->{MV_PAGE};
1154         $Global::Variable->{MV_PAGE} = $file;
1155
1156         $file =~ s#^\s+##;
1157         $file =~ s#\s+$##;
1158         $file =~ s#\.html?$##;
1159         if($file =~ m{\.\.} and $file =~ /\.\..*\.\./) {
1160                 logError( "Too many .. in file path '%s' for security.", $file );
1161                 $file = find_special_page('violation');
1162         }
1163
1164         if(index($file, '/') < 0) {
1165                 $pathdir = '';
1166         }
1167         else {
1168                 $file =~ s#//+#/#g;
1169                 $file =~ s#/+$##g;
1170                 ($pathdir = $file) =~ s#/[^/]*$##;
1171                 $pathdir =~ s:^/+::;
1172         }
1173
1174         my $try;
1175         my $suffix = $Vend::Cfg->{HTMLsuffix};
1176         my $db_tried;
1177         $locale = 1 unless defined $locale;
1178         my $record;
1179   FINDPAGE: {
1180         ## If PageTables is set, we try to find the page in the table first
1181         ## but only once, without the suffix
1182         if(! $db_tried++ and $Vend::Cfg->{PageTables}) {
1183                 my $teleport = $Vend::Session->{teleport};
1184                 my $field = $Vend::Cfg->{PageTableMap}{page_text};
1185                 foreach my $t (@{$Vend::Cfg->{PageTables}}) {
1186                         my $db = Vend::Data::database_exists_ref($t);
1187                         next unless $db;
1188
1189                         if($teleport) {
1190                                 $file = teleport_name($file, $teleport, $t);
1191                         }
1192                         $record = $db->row_hash($file)
1193                                 or next;
1194                         $contents = $record->{$field};
1195                         last FINDPAGE if length $contents;
1196                         undef $contents;
1197                 }
1198         }
1199
1200         my @dirs = ($Vend::Cfg->{PreviewDir},
1201                                 $Vend::Cfg->{PageDir},
1202                                 @{$Vend::Cfg->{TemplateDir} || []},
1203                                 @{$Global::TemplateDir || []});
1204
1205         foreach $try (@dirs) {
1206                 next unless $try;
1207                 $dir = $try . "/" . $pathdir;
1208                 if (-f "$dir/.access") {
1209                         if (-s _) {
1210                                 $level = 3;
1211                         }
1212                         else {
1213                                 $level = '';
1214                         }
1215                         if(-f "$dir/.autoload") {
1216                                 my $status = ::interpolate_html( readfile("$dir/.autoload") );
1217                                 $status =~ s/\s+//g;
1218                                 undef $level if $status;
1219                         }
1220                         $gate = check_gate($file,$dir)
1221                                 if defined $level;
1222                 }
1223
1224                 if( defined $level and ! check_security($file, $level, $gate) ){
1225                         my $realm = $::Variable->{COMPANY} || $Vend::Cat;
1226                         if(-f "$try/violation$suffix") {
1227                                 $fn = "$try/violation$suffix";
1228                         }
1229                         else {
1230                                 $file = find_special_page('violation');
1231                                 $fn = $try . "/" . escape_chars($file) . $suffix;
1232                         }
1233                 }
1234                 else {
1235                         $fn = $try . "/" . escape_chars($file) . $suffix;
1236                 }
1237
1238                 if (open(MVIN, "< $fn")) {
1239                         binmode(MVIN) if $Global::Windows;
1240                         binmode(MVIN, ":utf8") if $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
1241                         undef $/;
1242                         $contents = <MVIN>;
1243                         close(MVIN);
1244                         last;
1245                 }
1246                 last if defined $only;
1247         }
1248         if(! defined $contents) {
1249                 last FINDPAGE if $suffix eq '.html';
1250                 $suffix = '.html';
1251                 redo FINDPAGE;
1252         }
1253   }
1254
1255         if(! defined $contents) {
1256                 $contents = readfile_db("pages/$file");
1257         }
1258
1259         return unless defined $contents;
1260
1261         parse_locale(\$contents);
1262
1263         return $contents unless wantarray;
1264         return ($contents, $record);
1265 }
1266
1267 sub is_yes {
1268     return( defined($_[0]) && ($_[0] =~ /^[yYtT1]/));
1269 }
1270
1271 sub is_no {
1272         return( !defined($_[0]) || ($_[0] =~ /^[nNfF0]/));
1273 }
1274
1275 # Returns a URL which will run the ordering system again.  Each URL
1276 # contains the session ID as well as a unique integer to avoid caching
1277 # of pages by the browser.
1278
1279 my @scratches = qw/
1280                                 add_dot_html
1281                                 add_source
1282                                 link_relative
1283                                 match_security
1284                                 no_count
1285                                 no_session
1286                                 /;
1287
1288 sub vendUrl {
1289     my($path, $arguments, $r, $opt) = @_;
1290
1291         $opt ||= {};
1292
1293         if($opt->{auto_format}) {
1294                 return $path if $path =~ m{^/};
1295                 $path =~ s:#([^/.]+)$::
1296             and $opt->{anchor} = $1;
1297                 $path =~ s/\.html?$//i
1298                         and $opt->{add_dot_html} = 1;
1299         }
1300
1301     $r = $Vend::Cfg->{VendURL}
1302                 unless defined $r;
1303
1304         my $secure;
1305         my @parms;
1306
1307         my %skip = qw/form 1 href 1 reparse 1/;
1308
1309         for(@scratches) {
1310                 next if defined $opt->{$_};
1311                 next unless defined $::Scratch->{"mv_$_"};
1312                 $skip{$_} = 1;
1313                 $opt->{$_} = $::Scratch->{"mv_$_"};
1314         }
1315
1316         my $extra;
1317         if($opt->{form}) {
1318                 $path = $Vend::Cfg->{ProcessPage} unless $path;
1319                 if($opt->{form} eq 'auto') {
1320                         my $form = '';
1321                         while( my ($k, $v) = each %$opt) {
1322                                 next if $skip{$k};
1323                                 $k =~ s/^__//;
1324                                 $form .= "$k=$v\n";
1325                         }
1326                         $opt->{form} = $form;
1327                 }
1328                 push @parms, Vend::Interpolate::escape_form($opt->{form});
1329         }
1330
1331         my($id, $ct);
1332         $id = $Vend::SessionID
1333                 unless $opt->{no_session_id}
1334                 or     ($Vend::Cookie and $::Scratch->{mv_no_session_id});
1335         $ct = ++$Vend::Session->{pageCount}
1336                 unless $opt->{no_count};
1337
1338         if($opt->{no_session} or $::Pragma->{url_no_session_id}) {
1339                 undef $id;
1340                 undef $ct;
1341         }
1342
1343         if($opt->{link_relative}) {
1344                 my $cur = $Global::Variable->{MV_PAGE};
1345                 $cur =~ s{/[^/]+$}{}
1346                         and $path = "$cur/$path";
1347         }
1348
1349         if($opt->{match_security}) {
1350                 $opt->{secure} = $CGI::secure;
1351         }
1352
1353         if($opt->{secure} or exists $Vend::Cfg->{AlwaysSecure}{$path}) {
1354                 $r = $Vend::Cfg->{SecureURL};
1355         }
1356
1357         $path = escape_chars_url($path)
1358                 if $path =~ $need_escape;
1359         $r .= '/' . $path;
1360         $r .= '.html' if $opt->{add_dot_html} and $r !~ m{(?:/|\.html?)$};
1361
1362         if($opt->{add_source} and $Vend::Session->{source}) {
1363                 my $sn = hexify($Vend::Session->{source});
1364                 push @parms, "$::VN->{mv_source}=$sn";
1365         }
1366
1367         push @parms, "$::VN->{mv_session_id}=$id"               if $id;
1368         push @parms, "$::VN->{mv_arg}=" . hexify($arguments)    if defined $arguments;
1369         push @parms, "$::VN->{mv_pc}=$ct"                       if $ct;
1370         push @parms, "$::VN->{mv_cat}=$Vend::Cat"               if $Vend::VirtualCat;
1371
1372         $r .= '?' . join($Global::UrlJoiner, @parms) if @parms;
1373         if($opt->{anchor}) {
1374                 $opt->{anchor} =~ s/^#//;
1375                 $r .= '#' . $opt->{anchor};
1376         }
1377
1378         # return full-path portion of the URL
1379         if ($opt->{path_only}) {
1380                 $r =~ s!^https?://[^/]*!!i;
1381         }
1382         return $r;
1383 }
1384
1385 sub secure_vendUrl {
1386         return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL}, $_[3]);
1387 }
1388
1389 my %strip_vars;
1390 my $strip_init;
1391
1392 sub change_url {
1393         my $url = shift;
1394         return $url if $url =~ m{^\w+:};
1395         return $url if $url =~ m{^/};
1396         if(! $strip_init) {
1397                 for(qw/mv_session_id mv_pc/) {
1398                         $strip_vars{$_} = 1;
1399                         $strip_vars{$::IV->{$_}} = 1;
1400                 }
1401         }
1402         my $arg;
1403         my @args;
1404         ($url, $arg) = split /[?&]/, $url, 2;
1405         @args = grep ! $strip_vars{$_}, split $Global::UrlSplittor, $arg;
1406         return Vend::Interpolate::tag_area( $url, '', {
1407                                                                                         form => join "\n", @args,
1408                                                                                 } );
1409 }
1410
1411 sub resolve_links {
1412         my $html = shift;
1413         $html =~ s/(<a\s+[^>]*href\s*=\s*)(["'])([^'"]+)\2/$1 . $2 . change_url($3) . $2/gei;
1414         return $html;
1415 }
1416
1417 ### flock locking
1418
1419 # sys/file.h:
1420 my $flock_LOCK_SH = 1;          # Shared lock
1421 my $flock_LOCK_EX = 2;          # Exclusive lock
1422 my $flock_LOCK_NB = 4;          # Don't block when locking
1423 my $flock_LOCK_UN = 8;          # Unlock
1424
1425 # Returns the total number of items ordered.
1426 # Uses the current cart if none specified.
1427
1428 sub tag_nitems {
1429         my($ref, $opt) = @_;
1430     my($cart, $total, $item);
1431
1432         if($ref) {
1433                  $cart = $::Carts->{$ref}
1434                         or return 0;
1435         }
1436         else {
1437                 $cart = $Vend::Items;
1438         }
1439
1440         my ($attr, $sub);
1441         if($opt->{qualifier}) {
1442                 $attr = $opt->{qualifier};
1443                 my $qr;
1444                 eval {
1445                         $qr = qr{$opt->{compare}} if $opt->{compare};
1446                 };
1447                 if($qr) {
1448                         $sub = sub {
1449                                                         $_[0] =~ $qr;
1450                                                 };
1451                 }
1452                 else {
1453                         $sub = sub { return $_[0] };
1454                 }
1455         }
1456
1457         if($opt->{lines}) {
1458                 return scalar(grep {! $attr or $sub->($_->{$attr})} @$cart);
1459         }
1460
1461     $total = 0;
1462     foreach $item (@$cart) {
1463                 next if $attr and ! $sub->($item->{$attr});
1464
1465                 if ($opt->{gift_cert} && $item->{$opt->{gift_cert}}) {
1466                     $total++;
1467                     next;
1468                 }
1469
1470                 $total += $item->{'quantity'};
1471     }
1472     $total;
1473 }
1474
1475 sub dump_structure {
1476         my ($ref, $name) = @_;
1477         my $save;
1478         $name =~ s/\.cfg$//;
1479         $name .= '.structure';
1480         open(UNEV, ">$name") or die "Couldn't write structure $name: $!\n";
1481         local($Data::Dumper::Indent);
1482         $Data::Dumper::Indent = 2;
1483         print UNEV uneval($ref);
1484         close UNEV;
1485 }
1486
1487 # Do an internal HTTP authorization check
1488 sub check_authorization {
1489         my($auth, $pwinfo) = @_;
1490
1491         $auth =~ s/^\s*basic\s+//i or return undef;
1492         my ($user, $pw) = split(
1493                                                 ":",
1494                                                 MIME::Base64::decode_base64($auth),
1495                                                 2,
1496                                                 );
1497         my $cmp_pw;
1498         my $use_crypt = 1;
1499         if(     $user eq $Vend::Cfg->{RemoteUser}       and
1500                         $Vend::Cfg->{Password}                                  )
1501         {
1502                 $cmp_pw = $Vend::Cfg->{Password};
1503                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1504         }
1505         else {
1506                 $pwinfo = $Vend::Cfg->{UserDatabase} unless $pwinfo;
1507                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1508                 $cmp_pw = Vend::Interpolate::tag_data($pwinfo, 'password', $user)
1509                         if defined $Vend::Cfg->{Database}{$pwinfo};
1510         }
1511
1512         return undef unless $cmp_pw;
1513
1514         if(! $use_crypt) {
1515                 return $user if $pw eq $cmp_pw;
1516         }
1517         else {
1518                 my $test = crypt($pw, $cmp_pw);
1519                 return $user
1520                         if $test eq $cmp_pw;
1521         }
1522         return undef;
1523 }
1524
1525 # Check that the user is authorized by one or all of the
1526 # configured security checks
1527 sub check_security {
1528         my($item, $reconfig, $gate) = @_;
1529
1530         my $msg;
1531         if(! $reconfig) {
1532 # If using the new USERDB access control you may want to remove this next line
1533 # for anyone with an HTTP basic auth will have access to everything
1534                 #return 1 if $CGI::user and ! $Global::Variable->{MV_USERDB};
1535                 if($gate) {
1536                         $gate =~ s/\s+//g;
1537                         return 1 if is_yes($gate);
1538                 }
1539                 elsif($Vend::Session->{logged_in}) {
1540                         return 1 if $::Variable->{MV_USERDB_REMOTE_USER};
1541                         my $db;
1542                         my $field;
1543                         if ($db = $::Variable->{MV_USERDB_ACL_TABLE}) {
1544                                 $field = $::Variable->{MV_USERDB_ACL_COLUMN};
1545                                 my $access = Vend::Data::database_field(
1546                                                                 $db,
1547                                                                 $Vend::Session->{username},
1548                                                                 $field,
1549                                                                 );
1550                                 return 1 if $access =~ m{(^|\s)$item(\s|$)};
1551                         }
1552                 }
1553                 if($Vend::Cfg->{UserDB} and $Vend::Cfg->{UserDB}{log_failed}) {
1554                         my $besthost = $CGI::remote_host || $CGI::remote_addr;
1555                         logError("auth error host=%s ip=%s script=%s page=%s",
1556                                                         $besthost,
1557                                                         $CGI::remote_addr,
1558                                                         $CGI::script_name,
1559                                                         $CGI::path_info,
1560                                                         );
1561                 }
1562         return '';
1563         }
1564         elsif($reconfig eq '1') {
1565                 $msg = 'reconfigure catalog';
1566         }
1567         elsif ($reconfig eq '2') {
1568                 $msg = "access protected database $item";
1569                 return 1 if is_yes($gate);
1570         }
1571         elsif ($reconfig eq '3') {
1572                 $msg = "access administrative function $item";
1573         }
1574
1575         # Check if host IP is correct when MasterHost is set to something
1576         if (    $Vend::Cfg->{MasterHost}
1577                                 and
1578                 (       $CGI::remote_host !~ /^($Vend::Cfg->{MasterHost})$/
1579                                 and
1580                         $CGI::remote_addr !~ /^($Vend::Cfg->{MasterHost})$/     )       )
1581         {
1582                         my $fmt = <<'EOF';
1583 ALERT: Attempt to %s at %s from:
1584
1585         REMOTE_ADDR  %s
1586         REMOTE_USER  %s
1587         USER_AGENT   %s
1588         SCRIPT_NAME  %s
1589         PATH_INFO    %s
1590 EOF
1591                 logGlobal({ level => 'warning' },
1592                                                 $fmt,
1593                                                 $msg,
1594                                                 $CGI::script_name,
1595                                                 $CGI::host,
1596                                                 $CGI::user,
1597                                                 $CGI::useragent,
1598                                                 $CGI::script_name,
1599                                                 $CGI::path_info,
1600                                                 );
1601                 return '';
1602         }
1603
1604         # Check to see if password enabled, then check
1605         if (
1606                 $reconfig eq '1'                and
1607                 !$CGI::user                             and
1608                 $Vend::Cfg->{Password}  and
1609                 crypt($CGI::reconfigure_catalog, $Vend::Cfg->{Password})
1610                 ne  $Vend::Cfg->{Password})
1611         {
1612                 ::logGlobal(
1613                                 { level => 'warning' },
1614                                 "ALERT: Password mismatch, attempt to %s at %s from %s",
1615                                 $msg,
1616                                 $CGI::script_name,
1617                                 $CGI::host,
1618                                 );
1619                         return '';
1620         }
1621
1622         # Finally check to see if remote_user match enabled, then check
1623         if ($Vend::Cfg->{RemoteUser} and
1624                 $CGI::user ne $Vend::Cfg->{RemoteUser})
1625         {
1626                 my $fmt = <<'EOF';
1627 ALERT: Attempt to %s %s per user name:
1628
1629         REMOTE_HOST  %s
1630         REMOTE_ADDR  %s
1631         REMOTE_USER  %s
1632         USER_AGENT   %s
1633         SCRIPT_NAME  %s
1634         PATH_INFO    %s
1635 EOF
1636
1637                 ::logGlobal(
1638                         { level => 'warning' },
1639                         $fmt,
1640                         $CGI::script_name,
1641                         $msg,
1642                         $CGI::remote_host,
1643                         $CGI::remote_addr,
1644                         $CGI::user,
1645                         $CGI::useragent,
1646                         $CGI::script_name,
1647                         $CGI::path_info,
1648                 );
1649                 return '';
1650         }
1651
1652         # Don't allow random reconfigures without one of the three checks
1653         unless ($Vend::Cfg->{MasterHost} or
1654                         $Vend::Cfg->{Password}   or
1655                         $Vend::Cfg->{RemoteUser})
1656         {
1657                 my $fmt = <<'EOF';
1658 Attempt to %s on %s, secure operations disabled.
1659
1660         REMOTE_ADDR  %s
1661         REMOTE_USER  %s
1662         USER_AGENT   %s
1663         SCRIPT_NAME  %s
1664         PATH_INFO    %s
1665 EOF
1666                 ::logGlobal(
1667                                 { level => 'warning' },
1668                                 $fmt,
1669                                 $msg,
1670                                 $CGI::script_name,
1671                                 $CGI::host,
1672                                 $CGI::user,
1673                                 $CGI::useragent,
1674                                 $CGI::script_name,
1675                                 $CGI::path_info,
1676                                 );
1677                         return '';
1678
1679         }
1680
1681         # Authorized if got here
1682         return 1;
1683 }
1684
1685
1686 # Checks the Locale for a special page definintion mv_special_$key and
1687 # returns it if found, otherwise goes to the default Vend::Cfg->{Special} array
1688 sub find_special_page {
1689     my $key = shift;
1690         my $dir = '';
1691         $dir = "../$Vend::Cfg->{SpecialPageDir}/"
1692                 if $Vend::Cfg->{SpecialPageDir};
1693     return $Vend::Cfg->{Special}{$key} || "$dir$key";
1694 }
1695
1696 ## ERROR
1697
1698 # Log the error MSG to the error file.
1699
1700 sub logDebug {
1701         return unless $Global::DebugFile;
1702
1703         if(my $re = $Vend::Cfg->{DebugHost}) {
1704                 return unless
1705                          Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
1706         }
1707
1708         if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
1709                 return unless $sub->();
1710         }
1711
1712         my $msg;
1713
1714         if (my $tpl = $Global::DebugTemplate) {
1715                 my %debug;
1716                 $tpl = POSIX::strftime($tpl, localtime());
1717                 $tpl =~ s/\s*$//;
1718                 $debug{page} = $Global::Variable->{MV_PAGE};
1719                 $debug{tag} = $Vend::CurrentTag;
1720                 $debug{host} = $CGI::host || $CGI::remote_addr;
1721                 $debug{remote_addr} = $CGI::remote_addr;
1722                 $debug{catalog} = $Vend::Cat;
1723         if($tpl =~ /\{caller\d+\}/i) {
1724             my @caller = caller();
1725             for(my $i = 0; $i < @caller; $i++) {
1726                 $debug{"caller$i"} = $caller[$i];
1727             }
1728         }
1729                 $debug{message} = errmsg(@_);
1730
1731                 $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
1732         }
1733         else {
1734                 $msg = caller() . ":debug: " . errmsg(@_);
1735         }
1736
1737         if ($Global::SysLog) {
1738                 logGlobal({ level => 'debug' }, $msg);
1739         }
1740         else {
1741                 print $msg, "\n";
1742         }
1743
1744         return;
1745 }
1746
1747 sub errmsg {
1748         my($fmt, @strings) = @_;
1749         my $location;
1750         if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
1751                 $location = $Vend::Cfg->{Locale};
1752         }
1753         elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
1754                 $location = $Global::Locale;
1755         }
1756         if($location) {
1757                 if(ref $location->{$fmt}) {
1758                         $fmt = $location->{$fmt}[0];
1759                         @strings = @strings[ @{ $location->{$fmt}[1] } ];
1760                 }
1761                 else {
1762                         $fmt = $location->{$fmt};
1763                 }
1764         }
1765         return scalar(@strings) ? sprintf $fmt, @strings : $fmt;
1766 }
1767
1768 *l = \&errmsg;
1769
1770 sub show_times {
1771         my $message = shift || 'time mark';
1772         my @times = times();
1773         for( my $i = 0; $i < @times; $i++) {
1774                 $times[$i] -= $Vend::Times[$i];
1775         }
1776         logDebug("$message: " . join " ", @times);
1777 }
1778
1779 # This %syslog_constant_map is an attempt to work around a strange problem
1780 # where the eval inside &Sys::Syslog::xlate fails, which then croaks.
1781 # The cause of this freakish problem is still to be determined.
1782
1783 my %syslog_constant_map;
1784
1785 sub setup_syslog_constant_map {
1786         for (
1787                 (map { "local$_" } (0..7)),
1788                 qw(
1789                         auth
1790                         authpriv
1791                         cron
1792                         daemon
1793                         ftp
1794                         kern
1795                         lpr
1796                         mail
1797                         news
1798                         syslog
1799                         user
1800                         uucp
1801
1802                         emerg
1803                         alert
1804                         crit
1805                         err
1806                         warning
1807                         notice
1808                         info
1809                         debug
1810                 )
1811         ) {
1812                 $syslog_constant_map{$_} = Sys::Syslog::xlate($_);
1813         }
1814         return;
1815 }
1816
1817 sub logGlobal {
1818         return 1 if $Vend::ExternalProgram;
1819
1820         my $opt;
1821         my $msg = shift;
1822         if (ref $msg) {
1823                 $opt = $msg;
1824                 $msg = shift;
1825         }
1826         else {
1827                 $opt = {};
1828         }
1829
1830         $msg = errmsg($msg, @_) if @_;
1831
1832         $Vend::Errors .= $msg . "\n" if $Global::DisplayErrors;
1833
1834         my $nl = $opt->{strip} ? '' : "\n";
1835         print "$msg$nl"
1836                 if $Global::Foreground
1837                         and ! $Vend::Log_suppress
1838                         and ! $Vend::Quiet
1839                         and ! $Global::SysLog;
1840
1841         my ($fn, $facility, $level);
1842         if ($Global::SysLog) {
1843                 $facility = $Global::SysLog->{facility} || 'local3';
1844                 $level    = $opt->{level} || 'info';
1845
1846                 # remap deprecated synonyms supported by logger(1)
1847                 my %level_map = (
1848                         error => 'err',
1849                         panic => 'emerg',
1850                         warn  => 'warning',
1851                 );
1852
1853                 # remap levels according to any user-defined global configuration
1854                 my $level_cfg;
1855                 if ($level_cfg = $Global::SysLog->{$level_map{$level} || $level}) {
1856                         if ($level_cfg =~ /(.+)\.(.+)/) {
1857                                 ($facility, $level) = ($1, $2);
1858                         }
1859                         else {
1860                                 $level = $level_cfg;
1861                         }
1862                 }
1863                 $level = $level_map{$level} if $level_map{$level};
1864
1865                 my $tag = $Global::SysLog->{tag} || 'interchange';
1866
1867                 my $socket = $opt->{socket} || $Global::SysLog->{socket};
1868
1869                 if ($Global::SysLog->{internal}) {
1870                         unless ($Vend::SysLogReady) {
1871                                 eval {
1872                                         use Sys::Syslog ();
1873                                         if ($socket) {
1874                                                 my ($socket_path, $types) = ($socket =~ /^(\S+)(?:\s+(.*))?/);
1875                                                 $types ||= 'native,tcp,udp,unix,pipe,stream,console';
1876                                                 my $type_array = [ grep /\S/, split /[,\s]+/, $types ];
1877                                                 Sys::Syslog::setlogsock($type_array, $socket_path) or die "Error calling setlogsock\n";
1878                                         }
1879                                         Sys::Syslog::openlog $tag, 'ndelay,pid', $facility;
1880                                 };
1881                                 if ($@) {
1882                                         print "\nError opening syslog: $@\n";
1883                                         print "to report this error:\n", $msg;
1884                                         exit 1;
1885                                 }
1886                                 setup_syslog_constant_map() unless %syslog_constant_map;
1887                                 $Vend::SysLogReady = 1;
1888                         }
1889                 }
1890                 else {
1891                         $fn = '|' . ($Global::SysLog->{command} || 'logger');
1892                         $fn .= " -p $facility.$level";
1893                         $fn .= " -t $tag" unless lc($tag) eq 'none';
1894                         $fn .= " -u $socket" if $socket;
1895                 }
1896         }
1897         else {
1898                 $fn = $Global::ErrorFile;
1899         }
1900
1901         if ($fn) {
1902                 my $lock;
1903                 if ($fn =~ s/^([^|>])/>>$1/) {
1904                         $lock = 1;
1905                         $msg = format_log_msg($msg);
1906                 }
1907
1908                 eval {
1909                         # We have checked for beginning > or | previously
1910                         open(MVERROR, $fn) or die "open\n";
1911                         if ($lock) {
1912                                 lockfile(\*MVERROR, 1, 1) or die "lock\n";
1913                                 seek(MVERROR, 0, 2) or die "seek\n";
1914                         }
1915                         print(MVERROR $msg, "\n") or die "write to\n";
1916                         if ($lock) {
1917                                 unlockfile(\*MVERROR) or die "unlock\n";
1918                         }
1919                         close(MVERROR) or die "close\n";
1920                 };
1921                 if ($@) {
1922                         chomp $@;
1923                         print "\nCould not $@ error file '$Global::ErrorFile':\n$!\n";
1924                         print "to report this error:\n", $msg, "\n";
1925                         exit 1;
1926                 }
1927
1928         }
1929         elsif ($Vend::SysLogReady) {
1930                 eval {
1931                         # avoid eval in Sys::Syslog::xlate() by using cached constants where possible
1932                         my $level_mapped = $syslog_constant_map{$level};
1933                         $level_mapped = $level unless defined $level_mapped;
1934                         my $facility_mapped = $syslog_constant_map{$facility};
1935                         $facility_mapped = $facility unless defined $facility_mapped;
1936                         my $priority = "$level_mapped|$facility_mapped";
1937                         Sys::Syslog::syslog $priority, $msg;
1938                 };
1939         }
1940
1941         return 1;
1942 }
1943
1944 sub logError {
1945         return unless $Vend::Cfg;
1946
1947         my $msg = shift;
1948         my $opt;
1949         if (ref $_[0]) {
1950                 $opt = shift;
1951         }
1952         else {
1953                 $opt = {};
1954         }
1955
1956         unless ($Global::SysLog) {
1957                 if (! $opt->{file}) {
1958                         my $tag = $opt->{tag} || $msg;
1959                         if (my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) {
1960                                 $opt->{file} = $dest;
1961                         }
1962                 }
1963                 $opt->{file} ||= $Vend::Cfg->{ErrorFile};
1964         }
1965
1966         $msg = errmsg($msg, @_) if @_;
1967
1968         print "$msg\n"
1969                 if $Global::Foreground
1970                         and ! $Vend::Log_suppress
1971                         and ! $Vend::Quiet
1972                         and ! $Global::SysLog;
1973
1974         $Vend::Session->{last_error} = $msg;
1975
1976         $msg = format_log_msg($msg) unless $msg =~ s/^\\//;
1977
1978         if ($Global::SysLog) {
1979                 logGlobal({ level => 'err' }, $msg);
1980                 return;
1981         }
1982
1983         $Vend::Errors .= $msg . "\n"
1984                 if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors;
1985
1986     my $reason;
1987     if (! allowed_file($opt->{file}, 1)) {
1988         $@ = 'access';
1989         $reason = 'prohibited by global configuration';
1990     }
1991     else {
1992         eval {
1993             open(MVERROR, '>>', $opt->{file})
1994                                         or die "open\n";
1995             lockfile(\*MVERROR, 1, 1)   or die "lock\n";
1996             seek(MVERROR, 0, 2)         or die "seek\n";
1997             print(MVERROR $msg, "\n")   or die "write to\n";
1998             unlockfile(\*MVERROR)       or die "unlock\n";
1999             close(MVERROR)              or die "close\n";
2000         };
2001     }
2002     if ($@) {
2003                 chomp $@;
2004                 logGlobal ({ level => 'info' },
2005                                         "Could not %s error file %s: %s\nto report this error: %s",
2006                                         $@,
2007                                         $opt->{file},
2008                                         $reason || $!,
2009                                         $msg,
2010                                 );
2011                 }
2012
2013         return;
2014 }
2015
2016 # Front-end to log routines that ignores repeated identical
2017 # log messages after the first occurrence
2018 my %logOnce_cache;
2019 my %log_sub_map = (
2020         data    => \&logData,
2021         debug   => \&logDebug,
2022         error   => \&logError,
2023         global  => \&logGlobal,
2024 );
2025
2026 # First argument should be log type (see above map).
2027 # Rest of arguments are same as if calling log routine directly.
2028 sub logOnce {
2029         my $tag = join "", @_;
2030         return if exists $logOnce_cache{$tag};
2031         my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error};
2032         my $status = $log_sub->(@_);
2033         $logOnce_cache{$tag} = 1;
2034         return $status;
2035 }
2036
2037
2038 # Here for convenience in calls
2039 sub set_cookie {
2040     my ($name, $value, $expire, $domain, $path, $secure) = @_;
2041
2042     # Set expire to now + some time if expire string is something like
2043     # "30 days" or "7 weeks" or even "60 minutes"
2044         if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
2045             $expire = adjust_time($expire);
2046         }
2047
2048         if (! $::Instance->{Cookies}) {
2049                 $::Instance->{Cookies} = []
2050         }
2051         else {
2052                 @{$::Instance->{Cookies}} =
2053                         grep $_->[0] ne $name, @{$::Instance->{Cookies}};
2054         }
2055     push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
2056     return;
2057 }
2058
2059 # Here for convenience in calls
2060 sub read_cookie {
2061         my ($lookfor, $string) = @_;
2062         $string = $CGI::cookie
2063                 unless defined $string;
2064     return cookies_hash($string) unless defined $lookfor && length($lookfor);
2065     return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
2066         return unescape_chars($1);
2067 }
2068
2069 sub cookies_hash {
2070     my $string = shift || $CGI::cookie;
2071     my %cookies = map {
2072         my ($k,$v) = split '=', $_, 2;
2073         $k => unescape_chars($v)
2074     } split(/;\s*/, $string);
2075     return \%cookies;
2076 }
2077
2078 sub send_mail {
2079         my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
2080
2081         if(ref $to) {
2082                 my $head = $to;
2083
2084                 for(my $i = $#$head; $i > 0; $i--) {
2085                         if($head->[$i] =~ /^\s/) {
2086                                 my $new = splice @$head, $i, 1;
2087                                 $head->[$i - 1] .= "\n$new";
2088                         }
2089                 }
2090
2091                 $body = $subject;
2092                 undef $subject;
2093                 for(@$head) {
2094                         s/\s+$//;
2095                         if (/^To:\s*(.+)/si) {
2096                                 $to = $1;
2097                         }
2098                         elsif (/^Reply-to:\s*(.+)/si) {
2099                                 $reply = $1;
2100                         }
2101                         elsif (/^subj(?:ect)?:\s*(.+)/si) {
2102                                 $subject = $1;
2103                         }
2104                         elsif($_) {
2105                                 push @extra_headers, $_;
2106                         }
2107                 }
2108         }
2109
2110         # If configured, intercept all outgoing email and re-route
2111         if (
2112                 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
2113                                 || $Global::Variable->{MV_EMAIL_INTERCEPT}
2114         ) {
2115                 my @info_headers;
2116                 $to = "To: $to";
2117                 for ($to, @extra_headers) {
2118                         next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
2119                         logError(
2120                                 "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
2121                                 $header, $value, $intercept
2122                         );
2123                         $_ = "$header: $intercept";
2124                         push @info_headers, "X-Intercepted-$header: $value";
2125                 }
2126                 $to =~ s/^To: //;
2127                 push @extra_headers, @info_headers;
2128         }
2129
2130         my($ok);
2131 #::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
2132
2133         unless (defined $use_mime) {
2134                 $use_mime = $::Instance->{MIME} || undef;
2135         }
2136
2137         if(!defined $reply) {
2138                 $reply = $::Values->{mv_email}
2139                                 ?  "Reply-To: $::Values->{mv_email}\n"
2140                                 : '';
2141         }
2142         elsif ($reply) {
2143                 $reply = "Reply-To: $reply\n"
2144                         unless $reply =~ /^reply-to:/i;
2145                 $reply =~ s/\s+$/\n/;
2146         }
2147
2148         $ok = 0;
2149         my $none;
2150         my $using = $Vend::Cfg->{SendMailProgram};
2151
2152         if($using =~ /^(none|Net::SMTP)$/i) {
2153                 $none = 1;
2154                 $ok = 1;
2155         }
2156
2157         SEND: {
2158 #::logDebug("testing sendmail send none=$none");
2159                 last SEND if $none;
2160 #::logDebug("in Sendmail send $using");
2161                 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
2162                 my $mime = '';
2163                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2164                 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
2165                         or last SEND;
2166                 for(@extra_headers) {
2167                         s/\s*$/\n/;
2168                         print MVMAIL $_
2169                                 or last SEND;
2170                 }
2171                 $mime =~ s/\s*$/\n/;
2172                 print MVMAIL $mime
2173                         or last SEND;
2174                 print MVMAIL $body
2175                                 or last SEND;
2176                 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
2177                         if $use_mime;
2178                 print MVMAIL "\r\n\cZ" if $Global::Windows;
2179                 close MVMAIL or last SEND;
2180                 $ok = ($? == 0);
2181         }
2182
2183         SMTP: {
2184                 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
2185                 my $helo =  $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
2186                 last SMTP unless $none and $mhost;
2187                 eval {
2188                         require Net::SMTP;
2189                 };
2190                 last SMTP if $@;
2191                 $ok = 0;
2192                 $using = "Net::SMTP (mail server $mhost)";
2193 #::logDebug("using $using");
2194                 undef $none;
2195
2196                 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP;
2197 #::logDebug("smtp object $smtp");
2198
2199                 my $from = $::Variable->{MV_MAILFROM}
2200                                 || $Global::Variable->{MV_MAILFROM}
2201                                 || $Vend::Cfg->{MailOrderTo};
2202
2203                 for(@extra_headers) {
2204                         s/\s*$/\n/;
2205                         next unless /^From:\s*(\S.+)$/mi;
2206                         $from = $1;
2207                 }
2208                 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
2209                 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
2210
2211                 my $mime = '';
2212                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2213                 $smtp->mail($from)
2214                         or last SMTP;
2215 #::logDebug("smtp accepted from=$from");
2216
2217                 my @to;
2218                 my @addr = split /\s*,\s*/, $to;
2219                 for (@addr) {
2220                         if(/\s/) {
2221                                 ## Uh-oh. Try to handle
2222                                 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
2223                                         push @to, $1
2224                                 }
2225                                 else {
2226                                         logError("Net::SMTP sender skipping unparsable address %s", $_);
2227                                 }
2228                         }
2229                         else {
2230                                 push @to, $_;
2231                         }
2232                 }
2233
2234                 @addr = $smtp->recipient(@to, { SkipBad => 1 });
2235                 if(scalar(@addr) != scalar(@to)) {
2236                         logError(
2237                                 "Net::SMTP not able to send to all addresses of %s",
2238                                 join(", ", @to),
2239                         );
2240                 }
2241
2242 #::logDebug("smtp accepted to=" . join(",", @addr));
2243
2244                 $smtp->data();
2245
2246                 push @extra_headers, $reply if $reply;
2247                 for ("To: $to", "Subject: $subject", @extra_headers) {
2248                         next unless $_;
2249                         s/\s*$/\n/;
2250 #::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
2251                         $smtp->datasend($_)
2252                                 or last SMTP;
2253                 }
2254
2255                 if($use_mime) {
2256                         $mime =~ s/\s*$/\n/;
2257                         $smtp->datasend($mime)
2258                                 or last SMTP;
2259                 }
2260                 $smtp->datasend("\n");
2261                 $smtp->datasend($body)
2262                         or last SMTP;
2263                 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
2264                         if $use_mime;
2265                 $smtp->dataend()
2266                         or last SMTP;
2267                 $ok = $smtp->quit();
2268         }
2269
2270         if ($none or !$ok) {
2271                 logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
2272                                 $using,
2273                                 $to,
2274                                 $subject,
2275                                 $reply,
2276                                 $body,
2277                 );
2278         }
2279
2280         $ok;
2281 }
2282
2283 sub codedef_routine {
2284         my ($tag, $routine, $modifier) = @_;
2285
2286         my $area = $Vend::Config::tagCanon{lc $tag}
2287                 or do {
2288                         logError("Unknown CodeDef type %s", $tag);
2289                         return undef;
2290                 };
2291
2292         $routine =~ s/-/_/g;
2293         my @tries;
2294         if ($tag eq 'UserTag') {
2295                 @tries = ($Vend::Cfg->{UserTag}, $Global::UserTag);
2296                 }
2297         else {
2298                 @tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area});
2299         }
2300
2301         no strict 'refs';
2302
2303         my $ref;
2304
2305         for my $base (@tries) {
2306                 next unless $base;
2307             $ref = $base->{Routine}{$routine}
2308                          and return $ref;
2309                 $ref = $base->{MapRoutine}{$routine}
2310                    and return \&{"$ref"};
2311         }
2312
2313         return undef unless $Global::AccumulateCode;
2314 #::logDebug("trying code_from file for area=$area routine=$routine");
2315         $ref = Vend::Config::code_from_file($area, $routine)
2316                 or return undef;
2317 #::logDebug("returning ref=$ref for area=$area routine=$routine");
2318         return $ref;
2319 }
2320
2321 sub codedef_options {
2322         my ($tag, $modifier) = @_;
2323
2324         my @out;
2325         my $empty;
2326
2327         my @keys = keys %{$Vend::Cfg->{CodeDef}};
2328         push @keys, keys %{$Global::CodeDef};
2329
2330         my %gate = ( public => 1 );
2331
2332         my @mod = grep /\w/, split /[\s\0,]+/, $modifier;
2333         for(@mod) {
2334                 if($_ eq 'all') {
2335                         $gate{private} = 1;
2336                 }
2337
2338                 if($_ eq 'empty') {
2339                         $empty = ['', errmsg('--select--')];
2340                 }
2341
2342                 if($_ eq 'admin') {
2343                         $gate{admin} = 1;
2344                 }
2345         }
2346
2347         for(@keys) {
2348                 if(lc($tag) eq lc($_)) {
2349                         $tag = $_;
2350                         last;
2351                 }
2352         }
2353
2354         my %seen;
2355
2356         for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) {
2357                 if(my $desc = $repos->{Description}) {
2358                         my $vis = $repos->{Visibility} || {};
2359                         my $help = $repos->{Help} || {};
2360                         while( my($k, $v) = each %$desc) {
2361                                 next if $seen{$k}++;
2362                                 if(my $perm = $vis->{$k}) {
2363                                         if($perm =~ /^with\s+([\w:]+)/) {
2364                                                 my $mod = $1;
2365                                                 no strict 'refs';
2366                                                 next unless ${$mod . "::VERSION"};
2367                                         }
2368                                         else {
2369                                                 next unless $gate{$perm};
2370                                         }
2371                                 }
2372                                 push @out, [$k, $v, $help->{$k}];
2373                         }
2374                 }
2375         }
2376
2377         if(@out) {
2378                 @out = sort { $a->[1] cmp $b->[1] } @out;
2379                 unshift @out, $empty if $empty;
2380         }
2381         else {
2382                 push @out, ['', errmsg('--none--') ];
2383         }
2384         return \@out;
2385 }
2386
2387
2388 # Adds a timestamp to the end of a binary timecard file. You can specify the timestamp
2389 # as the second arg (unixtime) or just leave it out (or undefined) and it will be set
2390 # to the current time.
2391 sub timecard_stamp {
2392         my ($filename,$timestamp) = @_;
2393         $timestamp ||= time;
2394
2395         open(FH, '>>', $filename) or die "Can't open $filename for append: $!";
2396         lockfile(\*FH, 1, 1);
2397         binmode FH;
2398         print FH pack('N',time);
2399         unlockfile(\*FH);
2400         close FH;
2401 }
2402
2403
2404 # Reads a timestamp from a binary timecard file.  If $index is negative indexes back from
2405 # the end of the file, otherwise indexes from the front of the file so that 0 is the first
2406 # (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if
2407 # the file doesn't exist or the index falls outside of the bounds of the timecard file.
2408 sub timecard_read {
2409         my ($filename,$index) = @_;
2410         $index *= 4;
2411         my $limit = $index >= 0 ? $index + 4 : $index * -1;
2412
2413         if (-f $filename && (stat(_))[7] % 4) {
2414             # The file is corrupt, delete it and start over.
2415             ::logError("Counter file $filename found to be corrupt, deleting.");
2416             unlink($filename);
2417             return;
2418         }
2419         return unless (-f _ && (stat(_))[7] > $limit);
2420
2421         # The file exists and is big enough to cover the $index. Seek to the $index
2422         # and return the timestamp from that position.
2423
2424         open (FH, '<', $filename) or die "Can't open $filename for read: $!";
2425         lockfile(\*FH, 0, 1);
2426         binmode FH;
2427         seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!";
2428         my $rtime;
2429         read(FH,$rtime,4) or die "Can't read from $filename: $!";
2430         unlockfile(\*FH);
2431         close FH;
2432
2433         return unpack('N',$rtime);
2434 }
2435
2436 #
2437 # Adjusts a unix time stamp (2nd arg) by the amount specified in the first arg.  First arg should be
2438 # a number (signed integer or float) followed by one of second(s), minute(s), hour(s), day(s)
2439 # week(s) month(s) or year(s).  Second arg defaults to the current time.  If the third arg is true
2440 # the time will be compensated for daylight savings time (so that an adjustment of 6 months will
2441 # still cause the same time to be displayed, even if it is transgressing the DST boundary).
2442 #
2443 # This will accept multiple adjustments strung together, so you can do: "-5 days, 2 hours, 6 mins"
2444 # and the time will have thost amounts subtracted from it.  You can also add and subtract in the
2445 # same line, "+2 years -3 days".  If you specify a sign (+ or -) then that sign will remain in
2446 # effect until a new sign is specified on the line (so you can do,
2447 # "+5 years, 6 months, 3 days, -4 hours, 7 minutes").  The comma (,) between adjustments is
2448 # optional.
2449 #
2450 sub adjust_time {
2451     my ($adjust, $time, $compensate_dst) = @_;
2452     $time ||= time;
2453
2454     unless ($adjust =~ /^(?:\s*[+-]?\s*[\d\.]+\s*[a-z]*\s*,?)+$/i) {
2455         ::logError("adjust_time(): bad format: $adjust");
2456         return $time;
2457     }
2458
2459     # @times: 0: sec, 1: min, 2: hour, 3: day, 4: month, 5: year, 8: isdst
2460     # 6,7: dow and doy, but mktime ignores these (and so do we).
2461
2462     # A note about isdst: localtime returns 1 if returned time is adjusted for dst and 0 otherwise.
2463     # mktime expects the same, but if this is set to -1 mktime will determine if the date should be
2464     # dst adjusted according to dst rules for the current timezone.  The way that we use this is we
2465     # leave it set to the return value from locatime and we end up with a time that is adjusted by
2466     # an absolute amount (so if you adjust by six months the actual time returned may be different
2467     # but only because of DST).  If we want mktime to compensate for dst then we set this to -1 and
2468     # mktime will make the appropriate adjustment for us (either add one hour or subtract one hour
2469     # or leave the time the same).
2470
2471     my @times = localtime($time);
2472     my $sign = 1;
2473
2474     foreach my $amount ($adjust =~ /([+-]?\s*[\d\.]+\s*[a-z]*)/ig) {
2475         my $unit = 'seconds';
2476         $amount =~ s/\s+//g;
2477
2478         if ($amount =~ s/^([+-])//)   { $sign = $1 eq '+' ? 1 : -1 }
2479         if ($amount =~ s/([a-z]+)$//) { $unit = lc $1 }
2480         $amount *= $sign;
2481
2482         # A week is simply 7 days.
2483         if ($unit =~ /^w/) {
2484             $unit = 'days';
2485             $amount *= 7;
2486         }
2487
2488         if ($unit =~ /^s/) { $times[0] += $amount }
2489         elsif ($unit =~ /^mo/) { $times[4] += $amount } # has to come before min
2490         elsif ($unit =~ /^m/) { $times[1] += $amount }
2491         elsif ($unit =~ /^h/) { $times[2] += $amount }
2492         elsif ($unit =~ /^d/) { $times[3] += $amount }
2493         elsif ($unit =~ /^y/) { $times[5] += $amount }
2494
2495         else {
2496             ::logError("adjust_time(): bad unit: $unit");
2497             return $time;
2498         }
2499     }
2500
2501     if ($compensate_dst) { $times[8] = -1 }
2502
2503     # mktime can only handle integers, so we need to convert real numbers:
2504     my @multip = (0, 60, 60, 24, 0, 12);
2505     my $monfrac = 0;
2506     foreach my $i (reverse 0..5) {
2507         if ($times[$i] =~ /\./) {
2508             if ($multip[$i]) {
2509                 $times[$i-1] += ($times[$i] - int $times[$i]) * $multip[$i];
2510             }
2511
2512             elsif ($i == 4) {
2513                 # Fractions of a month need some really extra special handling.
2514                 $monfrac = $times[$i] - int $times[$i];
2515             }
2516
2517             $times[$i] = int $times[$i]
2518         }
2519     }
2520
2521     $time = POSIX::mktime(@times);
2522
2523     # This is how we handle a fraction of a month:
2524     if ($monfrac) {
2525         $times[4] += $monfrac > 0 ? 1 : -1;
2526         my $timediff = POSIX::mktime(@times);
2527         $timediff = int(abs($timediff - $time) * $monfrac);
2528         $time += $timediff;
2529     }
2530
2531     return $time;
2532 }
2533
2534 sub backtrace {
2535     my $msg = "Backtrace:\n\n";
2536     my $frame = 1;
2537
2538     my $assertfile = '';
2539     my $assertline = 0;
2540
2541     while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) {
2542         $msg .= sprintf("   frame %d: $subroutine ($filename line $line)\n", $frame - 2);
2543         if ($subroutine =~ /assert$/) {
2544             $assertfile = $filename;
2545             $assertline = $line;
2546         }
2547     }
2548     if ($assertfile) {
2549         open(SRC, $assertfile) and do {
2550             my $line;
2551             my $line_n = 0;
2552
2553             $msg .= "\nProblem in $assertfile line $assertline:\n\n";
2554
2555             while ($line = <SRC>) {
2556                 $line_n++;
2557                 $msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10);
2558             }
2559             close(SRC);
2560         };
2561     }
2562
2563     ::logGlobal($msg);
2564     undef;
2565 }
2566
2567 sub header_data_scrub {
2568         my ($head_data) = @_;
2569
2570         ## "HTTP Response Splitting" Exploit Fix
2571         ## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html
2572         $head_data =~ s/(?:%0[da]|[\r\n]+)+//ig;
2573
2574         return $head_data;
2575 }
2576
2577 ### Provide stubs for former Vend::Util functions relocated to Vend::File
2578 *canonpath = \&Vend::File::canonpath;
2579 *catdir = \&Vend::File::catdir;
2580 *catfile = \&Vend::File::catfile;
2581 *exists_filename = \&Vend::File::exists_filename;
2582 *file_modification_time = \&Vend::File::file_modification_time;
2583 *file_name_is_absolute = \&Vend::File::file_name_is_absolute;
2584 *get_filename = \&Vend::File::get_filename;
2585 *lockfile = \&Vend::File::lockfile;
2586 *path = \&Vend::File::path;
2587 *readfile = \&Vend::File::readfile;
2588 *readfile_db = \&Vend::File::readfile_db;
2589 *set_lock_type = \&Vend::File::set_lock_type;
2590 *unlockfile = \&Vend::File::unlockfile;
2591 *writefile = \&Vend::File::writefile;
2592
2593 1;
2594 __END__