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