Add new AlwaysSecureGlob directive
[interchange.git] / lib / Vend / Util.pm
1 # Vend::Util - Interchange utility functions
2 #
3 # Copyright (C) 2002-2017 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.129';
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         my $asg = $Vend::Cfg->{AlwaysSecureGlob};
1386         if ($opt->{secure}
1387                 or exists $Vend::Cfg->{AlwaysSecure}{$path}
1388                 or ($asg and $path =~ $asg)
1389         ) {
1390                 $r = $Vend::Cfg->{SecureURL};
1391         }
1392
1393         $path = escape_chars_url($path)
1394                 if $path =~ $need_escape;
1395         $r .= '/' . $path;
1396         $r .= '.html' if $opt->{add_dot_html} and $r !~ m{(?:/|\.html?)$};
1397
1398         if($opt->{add_source} and $Vend::Session->{source}) {
1399                 my $sn = hexify($Vend::Session->{source});
1400                 push @parms, "$::VN->{mv_source}=$sn";
1401         }
1402
1403         push @parms, "$::VN->{mv_session_id}=$id"               if $id;
1404         push @parms, "$::VN->{mv_arg}=" . hexify($arguments)    if defined $arguments;
1405         push @parms, "$::VN->{mv_pc}=$ct"                       if $ct;
1406         push @parms, "$::VN->{mv_cat}=$Vend::Cat"               if $Vend::VirtualCat;
1407
1408         $r .= '?' . join($Global::UrlJoiner, @parms) if @parms;
1409         if($opt->{anchor}) {
1410                 $opt->{anchor} =~ s/^#//;
1411                 $r .= '#' . $opt->{anchor};
1412         }
1413
1414         # return full-path portion of the URL
1415         if ($opt->{path_only}) {
1416                 $r =~ s!^https?://[^/]*!!i;
1417         }
1418         return $r;
1419
1420
1421 sub secure_vendUrl {
1422         return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL}, $_[3]);
1423 }
1424
1425 my %strip_vars;
1426 my $strip_init;
1427
1428 sub change_url {
1429         my $url = shift;
1430         return $url if $url =~ m{^\w+:};
1431         return $url if $url =~ m{^/};
1432         if(! $strip_init) {
1433                 for(qw/mv_session_id mv_pc/) {
1434                         $strip_vars{$_} = 1;
1435                         $strip_vars{$::IV->{$_}} = 1;
1436                 }
1437         }
1438         my $arg;
1439         my @args;
1440         ($url, $arg) = split /[?&]/, $url, 2;
1441         @args = grep ! $strip_vars{$_}, split $Global::UrlSplittor, $arg;
1442         return Vend::Interpolate::tag_area( $url, '', {
1443                                                                                         form => join "\n", @args,
1444                                                                                 } );
1445 }
1446
1447 sub resolve_links {
1448         my $html = shift;
1449         $html =~ s/(<a\s+[^>]*href\s*=\s*)(["'])([^'"]+)\2/$1 . $2 . change_url($3) . $2/gei;
1450         return $html;
1451 }
1452
1453 ### flock locking
1454
1455 # sys/file.h:
1456 my $flock_LOCK_SH = 1;          # Shared lock
1457 my $flock_LOCK_EX = 2;          # Exclusive lock
1458 my $flock_LOCK_NB = 4;          # Don't block when locking
1459 my $flock_LOCK_UN = 8;          # Unlock
1460
1461 # Returns the total number of items ordered.
1462 # Uses the current cart if none specified.
1463
1464 sub tag_nitems {
1465         my($ref, $opt) = @_;
1466     my($cart, $total, $item);
1467         
1468         if($ref) {
1469                  $cart = $::Carts->{$ref}
1470                         or return 0;
1471         }
1472         else {
1473                 $cart = $Vend::Items;
1474         }
1475
1476         my ($attr, $sub);
1477         if($opt->{qualifier}) {
1478                 $attr = $opt->{qualifier};
1479                 my $qr;
1480                 eval { 
1481                         $qr = qr{$opt->{compare}} if $opt->{compare};
1482                 };
1483                 if($qr) {
1484                         $sub = sub { 
1485                                                         $_[0] =~ $qr;
1486                                                 };
1487                 }
1488                 else {
1489                         $sub = sub { return $_[0] };
1490                 }
1491         }
1492
1493         if($opt->{lines}) {
1494                 return scalar(grep {! $attr or $sub->($_->{$attr})} @$cart);
1495         }
1496
1497     $total = 0;
1498     foreach $item (@$cart) {
1499                 next if $attr and ! $sub->($item->{$attr});
1500
1501                 if ($opt->{gift_cert} && $item->{$opt->{gift_cert}}) {
1502                     $total++;
1503                     next;
1504                 }
1505
1506                 $total += $item->{'quantity'};
1507     }
1508     $total;
1509 }
1510
1511 sub dump_structure {
1512         my ($ref, $name) = @_;
1513         my $save;
1514         $name =~ s/\.cfg$//;
1515         $name .= '.structure';
1516         open(UNEV, ">$name") or die "Couldn't write structure $name: $!\n";
1517         local($Data::Dumper::Indent);
1518         $Data::Dumper::Indent = 2;
1519         print UNEV uneval($ref);
1520         close UNEV;
1521 }
1522
1523 # Do an internal HTTP authorization check
1524 sub check_authorization {
1525         my($auth, $pwinfo) = @_;
1526
1527         $auth =~ s/^\s*basic\s+//i or return undef;
1528         my ($user, $pw) = split(
1529                                                 ":",
1530                                                 MIME::Base64::decode_base64($auth),
1531                                                 2,
1532                                                 );
1533         my $cmp_pw;
1534         my $use_crypt = 1;
1535         if(     $user eq $Vend::Cfg->{RemoteUser}       and
1536                         $Vend::Cfg->{Password}                                  )
1537         {
1538                 $cmp_pw = $Vend::Cfg->{Password};
1539                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1540         }
1541         else {
1542                 $pwinfo = $Vend::Cfg->{UserDatabase} unless $pwinfo;
1543                 undef $use_crypt if $::Variable->{MV_NO_CRYPT};
1544                 $cmp_pw = Vend::Interpolate::tag_data($pwinfo, 'password', $user)
1545                         if defined $Vend::Cfg->{Database}{$pwinfo};
1546         }
1547
1548         return undef unless $cmp_pw;
1549
1550         if(! $use_crypt) {
1551                 return $user if $pw eq $cmp_pw;
1552         }
1553         else {
1554                 my $test = crypt($pw, $cmp_pw);
1555                 return $user
1556                         if $test eq $cmp_pw;
1557         }
1558         return undef;
1559 }
1560
1561 # Check that the user is authorized by one or all of the
1562 # configured security checks
1563 sub check_security {
1564         my($item, $reconfig, $gate) = @_;
1565
1566         my $msg;
1567         if(! $reconfig) {
1568 # If using the new USERDB access control you may want to remove this next line
1569 # for anyone with an HTTP basic auth will have access to everything
1570                 #return 1 if $CGI::user and ! $Global::Variable->{MV_USERDB};
1571                 if($gate) {
1572                         $gate =~ s/\s+//g;
1573                         return 1 if is_yes($gate);
1574                 }
1575                 elsif($Vend::Session->{logged_in}) {
1576                         return 1 if $::Variable->{MV_USERDB_REMOTE_USER};
1577                         my $db;
1578                         my $field;
1579                         if ($db = $::Variable->{MV_USERDB_ACL_TABLE}) {
1580                                 $field = $::Variable->{MV_USERDB_ACL_COLUMN};
1581                                 my $access = Vend::Data::database_field(
1582                                                                 $db,
1583                                                                 $Vend::Session->{username},
1584                                                                 $field,
1585                                                                 );
1586                                 return 1 if $access =~ m{(^|\s)$item(\s|$)};
1587                         }
1588                 }
1589                 if($Vend::Cfg->{UserDB} and $Vend::Cfg->{UserDB}{log_failed}) {
1590                         my $besthost = $CGI::remote_host || $CGI::remote_addr;
1591                         logError("auth error host=%s ip=%s script=%s page=%s",
1592                                                         $besthost,
1593                                                         $CGI::remote_addr,
1594                                                         $CGI::script_name,
1595                                                         $CGI::path_info,
1596                                                         );
1597                 }
1598         return '';  
1599         }
1600         elsif($reconfig eq '1') {
1601                 $msg = 'reconfigure catalog';
1602         }
1603         elsif ($reconfig eq '2') {
1604                 $msg = "access protected database $item";
1605                 return 1 if is_yes($gate);
1606         }
1607         elsif ($reconfig eq '3') {
1608                 $msg = "access administrative function $item";
1609         }
1610
1611         # Check if host IP is correct when MasterHost is set to something
1612         if (    $Vend::Cfg->{MasterHost}
1613                                 and
1614                 (       $CGI::remote_host !~ /^($Vend::Cfg->{MasterHost})$/
1615                                 and
1616                         $CGI::remote_addr !~ /^($Vend::Cfg->{MasterHost})$/     )       )
1617         {
1618                         my $fmt = <<'EOF';
1619 ALERT: Attempt to %s at %s from:
1620
1621         REMOTE_ADDR  %s
1622         REMOTE_USER  %s
1623         USER_AGENT   %s
1624         SCRIPT_NAME  %s
1625         PATH_INFO    %s
1626 EOF
1627                 logGlobal({ level => 'warning' },
1628                                                 $fmt,
1629                                                 $msg,
1630                                                 $CGI::script_name,
1631                                                 $CGI::host,
1632                                                 $CGI::user,
1633                                                 $CGI::useragent,
1634                                                 $CGI::script_name,
1635                                                 $CGI::path_info,
1636                                                 );
1637                 return '';
1638         }
1639
1640         # Check to see if password enabled, then check
1641         if (
1642                 $reconfig eq '1'                and
1643                 !$CGI::user                             and
1644                 $Vend::Cfg->{Password}  and
1645                 crypt($CGI::reconfigure_catalog, $Vend::Cfg->{Password})
1646                 ne  $Vend::Cfg->{Password})
1647         {
1648                 ::logGlobal(
1649                                 { level => 'warning' },
1650                                 "ALERT: Password mismatch, attempt to %s at %s from %s",
1651                                 $msg,
1652                                 $CGI::script_name,
1653                                 $CGI::host,
1654                                 );
1655                         return '';
1656         }
1657
1658         # Finally check to see if remote_user match enabled, then check
1659         if ($Vend::Cfg->{RemoteUser} and
1660                 $CGI::user ne $Vend::Cfg->{RemoteUser})
1661         {
1662                 my $fmt = <<'EOF';
1663 ALERT: Attempt to %s %s per user name:
1664
1665         REMOTE_HOST  %s
1666         REMOTE_ADDR  %s
1667         REMOTE_USER  %s
1668         USER_AGENT   %s
1669         SCRIPT_NAME  %s
1670         PATH_INFO    %s
1671 EOF
1672
1673                 ::logGlobal(
1674                         { level => 'warning' },
1675                         $fmt,
1676                         $CGI::script_name,
1677                         $msg,
1678                         $CGI::remote_host,
1679                         $CGI::remote_addr,
1680                         $CGI::user,
1681                         $CGI::useragent,
1682                         $CGI::script_name,
1683                         $CGI::path_info,
1684                 );
1685                 return '';
1686         }
1687
1688         # Don't allow random reconfigures without one of the three checks
1689         unless ($Vend::Cfg->{MasterHost} or
1690                         $Vend::Cfg->{Password}   or
1691                         $Vend::Cfg->{RemoteUser})
1692         {
1693                 my $fmt = <<'EOF';
1694 Attempt to %s on %s, secure operations disabled.
1695
1696         REMOTE_ADDR  %s
1697         REMOTE_USER  %s
1698         USER_AGENT   %s
1699         SCRIPT_NAME  %s
1700         PATH_INFO    %s
1701 EOF
1702                 ::logGlobal(
1703                                 { level => 'warning' },
1704                                 $fmt,
1705                                 $msg,
1706                                 $CGI::script_name,
1707                                 $CGI::host,
1708                                 $CGI::user,
1709                                 $CGI::useragent,
1710                                 $CGI::script_name,
1711                                 $CGI::path_info,
1712                                 );
1713                         return '';
1714
1715         }
1716
1717         # Authorized if got here
1718         return 1;
1719 }
1720
1721
1722 # Checks the Locale for a special page definintion mv_special_$key and
1723 # returns it if found, otherwise goes to the default Vend::Cfg->{Special} array
1724 sub find_special_page {
1725     my $key = shift;
1726         my $dir = '';
1727         $dir = "../$Vend::Cfg->{SpecialPageDir}/"
1728                 if $Vend::Cfg->{SpecialPageDir};
1729     return $Vend::Cfg->{Special}{$key} || "$dir$key";
1730 }
1731
1732 ## ERROR
1733
1734 # Log the error MSG to the error file.
1735
1736 sub logDebug {
1737         return unless $Global::DebugFile;
1738
1739         if(my $re = $Vend::Cfg->{DebugHost}) {
1740                 return unless
1741                          Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
1742         }
1743
1744         if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
1745                 return unless $sub->();
1746         }
1747
1748         my $msg;
1749
1750         if (my $tpl = $Global::DebugTemplate) {
1751                 my %debug;
1752                 $tpl = POSIX::strftime($tpl, localtime());
1753                 $tpl =~ s/\s*$//;
1754                 $debug{page} = $Global::Variable->{MV_PAGE};
1755                 $debug{tag} = $Vend::CurrentTag;
1756                 $debug{host} = $CGI::host || $CGI::remote_addr;
1757                 $debug{remote_addr} = $CGI::remote_addr;
1758                 $debug{request_method} = $CGI::request_method;
1759                 $debug{request_uri} = $CGI::request_uri;
1760                 $debug{catalog} = $Vend::Cat;
1761         if($tpl =~ /\{caller\d+\}/i) {
1762             my @caller = caller();
1763             for(my $i = 0; $i < @caller; $i++) {
1764                 $debug{"caller$i"} = $caller[$i];
1765             }
1766         }
1767         $tpl =~ s/\{session\.([^}|]+)(.*?)\}/
1768                 $debug{"session_\L$1"} = $Vend::Session->{$1};
1769                 "{SESSION_\U$1$2}"
1770             /iegx;
1771                 $debug{message} = errmsg(@_);
1772
1773                 $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
1774         }
1775         else {
1776                 $msg = caller() . ":debug: " . errmsg(@_);
1777         }
1778
1779         if ($Global::SysLog) {
1780                 logGlobal({ level => 'debug' }, $msg);
1781         }
1782         else {
1783                 print $msg, "\n";
1784         }
1785
1786         return;
1787 }
1788
1789 sub errmsg {
1790         my($fmt, @strings) = @_;
1791         my $location;
1792         if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
1793                 $location = $Vend::Cfg->{Locale};
1794         }
1795         elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
1796                 $location = $Global::Locale;
1797         }
1798         if($location) {
1799                 if(ref $location->{$fmt}) {
1800                         $fmt = $location->{$fmt}[0];
1801                         @strings = @strings[ @{ $location->{$fmt}[1] } ];
1802                 }
1803                 else {
1804                         $fmt = $location->{$fmt};
1805                 }
1806         }
1807         return scalar(@strings) ? sprintf $fmt, @strings : $fmt;
1808 }
1809
1810 *l = \&errmsg;
1811
1812 sub show_times {
1813         my $message = shift || 'time mark';
1814         my @times = times();
1815         for( my $i = 0; $i < @times; $i++) {
1816                 $times[$i] -= $Vend::Times[$i];
1817         }
1818         logDebug("$message: " . join " ", @times);
1819 }
1820
1821 # This %syslog_constant_map is an attempt to work around a strange problem
1822 # where the eval inside &Sys::Syslog::xlate fails, which then croaks.
1823 # The cause of this freakish problem is still to be determined.
1824
1825 my %syslog_constant_map;
1826
1827 sub setup_syslog_constant_map {
1828         for (
1829                 (map { "local$_" } (0..7)),
1830                 qw(
1831                         auth
1832                         authpriv
1833                         cron
1834                         daemon
1835                         ftp
1836                         kern
1837                         lpr
1838                         mail
1839                         news
1840                         syslog
1841                         user
1842                         uucp
1843
1844                         emerg
1845                         alert
1846                         crit
1847                         err
1848                         warning
1849                         notice
1850                         info
1851                         debug
1852                 )
1853         ) {
1854                 $syslog_constant_map{$_} = Sys::Syslog::xlate($_);
1855         }
1856         return;
1857 }
1858
1859 sub logGlobal {
1860         return 1 if $Vend::ExternalProgram;
1861
1862         my $opt;
1863         my $msg = shift;
1864         if (ref $msg) {
1865                 $opt = $msg;
1866                 $msg = shift;
1867         }
1868         else {
1869                 $opt = {};
1870         }
1871
1872         $msg = errmsg($msg, @_) if @_;
1873
1874         $Vend::Errors .= $msg . "\n" if $Global::DisplayErrors;
1875
1876         my $nl = $opt->{strip} ? '' : "\n";
1877         print "$msg$nl"
1878                 if $Global::Foreground
1879                         and ! $Vend::Log_suppress
1880                         and ! $Vend::Quiet
1881                         and ! $Global::SysLog;
1882
1883         my ($fn, $facility, $level);
1884         if ($Global::SysLog) {
1885                 $facility = $Global::SysLog->{facility} || 'local3';
1886                 $level    = $opt->{level} || 'info';
1887
1888                 # remap deprecated synonyms supported by logger(1)
1889                 my %level_map = (
1890                         error => 'err',
1891                         panic => 'emerg',
1892                         warn  => 'warning',
1893                 );
1894
1895                 # remap levels according to any user-defined global configuration
1896                 my $level_cfg;
1897                 if ($level_cfg = $Global::SysLog->{$level_map{$level} || $level}) {
1898                         if ($level_cfg =~ /(.+)\.(.+)/) {
1899                                 ($facility, $level) = ($1, $2);
1900                         }
1901                         else {
1902                                 $level = $level_cfg;
1903                         }
1904                 }
1905                 $level = $level_map{$level} if $level_map{$level};
1906
1907                 my $tag = $Global::SysLog->{tag} || 'interchange';
1908
1909                 my $socket = $opt->{socket} || $Global::SysLog->{socket};
1910
1911                 if ($Global::SysLog->{internal}) {
1912                         unless ($Vend::SysLogReady) {
1913                                 eval {
1914                                         use Sys::Syslog ();
1915                                         if ($socket) {
1916                                                 my ($socket_path, $types) = ($socket =~ /^(\S+)(?:\s+(.*))?/);
1917                                                 $types ||= 'native,tcp,udp,unix,pipe,stream,console';
1918                                                 my $type_array = [ grep /\S/, split /[,\s]+/, $types ];
1919                                                 Sys::Syslog::setlogsock($type_array, $socket_path) or die "Error calling setlogsock\n";
1920                                         }
1921                                         Sys::Syslog::openlog $tag, 'ndelay,pid', $facility;
1922                                 };
1923                                 if ($@) {
1924                                         print "\nError opening syslog: $@\n";
1925                                         print "to report this error:\n", $msg;
1926                                         exit 1;
1927                                 }
1928                                 setup_syslog_constant_map() unless %syslog_constant_map;
1929                                 $Vend::SysLogReady = 1;
1930                         }
1931                 }
1932                 else {
1933                         $fn = '|' . ($Global::SysLog->{command} || 'logger');
1934                         $fn .= " -p $facility.$level";
1935                         $fn .= " -t $tag" unless lc($tag) eq 'none';
1936                         $fn .= " -u $socket" if $socket;
1937                 }
1938         }
1939         else {
1940                 $fn = $Global::ErrorFile;
1941         }
1942
1943         if ($fn) {
1944                 my $lock;
1945                 if ($fn =~ s/^([^|>])/>>$1/) {
1946                         $lock = 1;
1947                         $msg = format_log_msg($msg);
1948                 }
1949
1950                 eval {
1951                         # We have checked for beginning > or | previously
1952                         open(MVERROR, $fn) or die "open\n";
1953                         if ($lock) {
1954                                 lockfile(\*MVERROR, 1, 1) or die "lock\n";
1955                                 seek(MVERROR, 0, 2) or die "seek\n";
1956                         }
1957                         print(MVERROR $msg, "\n") or die "write to\n";
1958                         if ($lock) {
1959                                 unlockfile(\*MVERROR) or die "unlock\n";
1960                         }
1961                         close(MVERROR) or die "close\n";
1962                 };
1963                 if ($@) {
1964                         chomp $@;
1965                         print "\nCould not $@ error file '$Global::ErrorFile':\n$!\n";
1966                         print "to report this error:\n", $msg, "\n";
1967                         exit 1;
1968                 }
1969
1970         }
1971         elsif ($Vend::SysLogReady) {
1972                 eval {
1973                         # avoid eval in Sys::Syslog::xlate() by using cached constants where possible
1974                         my $level_mapped = $syslog_constant_map{$level};
1975                         $level_mapped = $level unless defined $level_mapped;
1976                         my $facility_mapped = $syslog_constant_map{$facility};
1977                         $facility_mapped = $facility unless defined $facility_mapped;
1978                         my $priority = "$level_mapped|$facility_mapped";
1979                         Sys::Syslog::syslog $priority, $msg;
1980                 };
1981         }
1982
1983         return 1;
1984 }
1985
1986 sub logError {
1987         return unless $Vend::Cfg;
1988
1989         my $msg = shift;
1990         my $opt;
1991         if (ref $_[0]) {
1992                 $opt = shift;
1993         }
1994         else {
1995                 $opt = {};
1996         }
1997
1998         unless ($Global::SysLog) {
1999                 if (! $opt->{file}) {
2000                         my $tag = $opt->{tag} || $msg;
2001                         if (my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) {
2002                                 $opt->{file} = $dest;
2003                         }
2004                 }
2005                 $opt->{file} ||= $Vend::Cfg->{ErrorFile};
2006         }
2007
2008         $msg = errmsg($msg, @_) if @_;
2009
2010         print "$msg\n"
2011                 if $Global::Foreground
2012                         and ! $Vend::Log_suppress
2013                         and ! $Vend::Quiet
2014                         and ! $Global::SysLog;
2015
2016         $Vend::Session->{last_error} = $msg;
2017
2018         $msg = format_log_msg($msg) unless $msg =~ s/^\\//;
2019
2020         if ($Global::SysLog) {
2021                 logGlobal({ level => 'err' }, $msg);
2022                 return;
2023         }
2024
2025         $Vend::Errors .= $msg . "\n"
2026                 if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors;
2027
2028     my $reason;
2029     if (! allowed_file($opt->{file}, 1)) {
2030         $@ = 'access';
2031         $reason = 'prohibited by global configuration';
2032     }
2033     else {
2034         eval {
2035             open(MVERROR, '>>', $opt->{file})
2036                                         or die "open\n";
2037             lockfile(\*MVERROR, 1, 1)   or die "lock\n";
2038             seek(MVERROR, 0, 2)         or die "seek\n";
2039             print(MVERROR $msg, "\n")   or die "write to\n";
2040             unlockfile(\*MVERROR)       or die "unlock\n";
2041             close(MVERROR)              or die "close\n";
2042         };
2043     }
2044     if ($@) {
2045                 chomp $@;
2046                 logGlobal ({ level => 'info' },
2047                                         "Could not %s error file %s: %s\nto report this error: %s",
2048                                         $@,
2049                                         $opt->{file},
2050                                         $reason || $!,
2051                                         $msg,
2052                                 );
2053                 }
2054
2055         return;
2056 }
2057
2058 # Front-end to log routines that ignores repeated identical
2059 # log messages after the first occurrence
2060 my %logOnce_cache;
2061 my %log_sub_map = (
2062         data    => \&logData,
2063         debug   => \&logDebug,
2064         error   => \&logError,
2065         global  => \&logGlobal,
2066 );
2067
2068 # First argument should be log type (see above map).
2069 # Rest of arguments are same as if calling log routine directly.
2070 sub logOnce {
2071         my $tag = join "", @_;
2072         return if exists $logOnce_cache{$tag};
2073         my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error};
2074         my $status = $log_sub->(@_);
2075         $logOnce_cache{$tag} = 1;
2076         return $status;
2077 }
2078
2079
2080 # Here for convenience in calls
2081 sub set_cookie {
2082     my ($name, $value, $expire, $domain, $path, $secure) = @_;
2083
2084     # Set expire to now + some time if expire string is something like
2085     # "30 days" or "7 weeks" or even "60 minutes"
2086         if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
2087             $expire = adjust_time($expire);
2088         }
2089
2090         if (! $::Instance->{Cookies}) {
2091                 $::Instance->{Cookies} = []
2092         }
2093         else {
2094                 @{$::Instance->{Cookies}} =
2095                         grep $_->[0] ne $name, @{$::Instance->{Cookies}};
2096         }
2097     push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
2098     return;
2099 }
2100
2101 # Here for convenience in calls
2102 sub read_cookie {
2103         my ($lookfor, $string) = @_;
2104         $string = $CGI::cookie
2105                 unless defined $string;
2106     return cookies_hash($string) unless defined $lookfor && length($lookfor);
2107     return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
2108         return unescape_chars($1);
2109 }
2110
2111 sub cookies_hash {
2112     my $string = shift || $CGI::cookie;
2113     my %cookies = map {
2114         my ($k,$v) = split '=', $_, 2;
2115         $k => unescape_chars($v)
2116     } split(/;\s*/, $string);
2117     return \%cookies;
2118 }
2119
2120 sub send_mail {
2121         my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
2122
2123         if(ref $to) {
2124                 my $head = $to;
2125
2126                 for(my $i = $#$head; $i > 0; $i--) {
2127                         if($head->[$i] =~ /^\s/) {
2128                                 my $new = splice @$head, $i, 1;
2129                                 $head->[$i - 1] .= "\n$new";
2130                         }
2131                 }
2132
2133                 $body = $subject;
2134                 undef $subject;
2135                 for(@$head) {
2136                         s/\s+$//;
2137                         if (/^To:\s*(.+)/si) {
2138                                 $to = $1;
2139                         }
2140                         elsif (/^Reply-to:\s*(.+)/si) {
2141                                 $reply = $1;
2142                         }
2143                         elsif (/^subj(?:ect)?:\s*(.+)/si) {
2144                                 $subject = $1;
2145                         }
2146                         elsif($_) {
2147                                 push @extra_headers, $_;
2148                         }
2149                 }
2150         }
2151
2152         # If configured, intercept all outgoing email and re-route
2153         if (
2154                 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
2155                                 || $Global::Variable->{MV_EMAIL_INTERCEPT}
2156         ) {
2157                 my @info_headers;
2158                 $to = "To: $to";
2159                 for ($to, @extra_headers) {
2160                         next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
2161                         logError(
2162                                 "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
2163                                 $header, $value, $intercept
2164                         );
2165                         $_ = "$header: $intercept";
2166                         push @info_headers, "X-Intercepted-$header: $value";
2167                 }
2168                 $to =~ s/^To: //;
2169                 push @extra_headers, @info_headers;
2170         }
2171
2172         my($ok);
2173 #::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
2174
2175         unless (defined $use_mime) {
2176                 $use_mime = $::Instance->{MIME} || undef;
2177         }
2178
2179         if(!defined $reply) {
2180                 $reply = $::Values->{mv_email}
2181                                 ?  "Reply-To: $::Values->{mv_email}\n"
2182                                 : '';
2183         }
2184         elsif ($reply) {
2185                 $reply = "Reply-To: $reply\n"
2186                         unless $reply =~ /^reply-to:/i;
2187                 $reply =~ s/\s+$/\n/;
2188         }
2189
2190         $ok = 0;
2191         my $none;
2192         my $using = $Vend::Cfg->{SendMailProgram};
2193
2194         if($using =~ /^(none|Net::SMTP)$/i) {
2195                 $none = 1;
2196                 $ok = 1;
2197         }
2198
2199         SEND: {
2200 #::logDebug("testing sendmail send none=$none");
2201                 last SEND if $none;
2202 #::logDebug("in Sendmail send $using");
2203                 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
2204                 my $mime = '';
2205                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2206                 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
2207                         or last SEND;
2208                 for(@extra_headers) {
2209                         s/\s*$/\n/;
2210                         print MVMAIL $_
2211                                 or last SEND;
2212                 }
2213                 $mime =~ s/\s*$/\n/;
2214                 print MVMAIL $mime
2215                         or last SEND;
2216                 print MVMAIL $body
2217                                 or last SEND;
2218                 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
2219                         if $use_mime;
2220                 print MVMAIL "\r\n\cZ" if $Global::Windows;
2221                 close MVMAIL or last SEND;
2222                 $ok = ($? == 0);
2223         }
2224
2225         SMTP: {
2226                 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
2227                 my $helo =  $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
2228                 last SMTP unless $none and $mhost;
2229                 eval {
2230                         require Net::SMTP;
2231                 };
2232                 last SMTP if $@;
2233                 $ok = 0;
2234                 $using = "Net::SMTP (mail server $mhost)";
2235 #::logDebug("using $using");
2236                 undef $none;
2237
2238                 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP;
2239 #::logDebug("smtp object $smtp");
2240
2241                 my $from = $::Variable->{MV_MAILFROM}
2242                                 || $Global::Variable->{MV_MAILFROM}
2243                                 || $Vend::Cfg->{MailOrderTo};
2244                 
2245                 for(@extra_headers) {
2246                         s/\s*$/\n/;
2247                         next unless /^From:\s*(\S.+)$/mi;
2248                         $from = $1;
2249                 }
2250                 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
2251                 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
2252
2253                 my $mime = '';
2254                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2255                 $smtp->mail($from)
2256                         or last SMTP;
2257 #::logDebug("smtp accepted from=$from");
2258
2259                 my @to;
2260                 my @addr = split /\s*,\s*/, $to;
2261                 for (@addr) {
2262                         if(/\s/) {
2263                                 ## Uh-oh. Try to handle
2264                                 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
2265                                         push @to, $1
2266                                 }
2267                                 else {
2268                                         logError("Net::SMTP sender skipping unparsable address %s", $_);
2269                                 }
2270                         }
2271                         else {
2272                                 push @to, $_;
2273                         }
2274                 }
2275                 
2276                 @addr = $smtp->recipient(@to, { SkipBad => 1 });
2277                 if(scalar(@addr) != scalar(@to)) {
2278                         logError(
2279                                 "Net::SMTP not able to send to all addresses of %s",
2280                                 join(", ", @to),
2281                         );
2282                 }
2283
2284 #::logDebug("smtp accepted to=" . join(",", @addr));
2285
2286                 $smtp->data();
2287
2288                 push @extra_headers, $reply if $reply;
2289                 for ("To: $to", "Subject: $subject", @extra_headers) {
2290                         next unless $_;
2291                         s/\s*$/\n/;
2292 #::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
2293                         $smtp->datasend($_)
2294                                 or last SMTP;
2295                 }
2296
2297                 if($use_mime) {
2298                         $mime =~ s/\s*$/\n/;
2299                         $smtp->datasend($mime)
2300                                 or last SMTP;
2301                 }
2302                 $smtp->datasend("\n");
2303                 $smtp->datasend($body)
2304                         or last SMTP;
2305                 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
2306                         if $use_mime;
2307                 $smtp->dataend()
2308                         or last SMTP;
2309                 $ok = $smtp->quit();
2310         }
2311
2312         if ($none or !$ok) {
2313                 logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
2314                                 $using,
2315                                 $to,
2316                                 $subject,
2317                                 $reply,
2318                                 $body,
2319                 );
2320         }
2321
2322         $ok;
2323 }
2324
2325 sub codedef_routine {
2326         my ($tag, $routine, $modifier) = @_;
2327
2328         my $area = $Vend::Config::tagCanon{lc $tag}
2329                 or do {
2330                         logError("Unknown CodeDef type %s", $tag);
2331                         return undef;
2332                 };
2333
2334         $routine =~ s/-/_/g;
2335         my @tries;
2336         if ($tag eq 'UserTag') {
2337                 @tries = ($Vend::Cfg->{UserTag}, $Global::UserTag);
2338                 }
2339         else {
2340                 @tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area});
2341         }
2342
2343         no strict 'refs';
2344
2345         my $ref;
2346
2347         for my $base (@tries) {
2348                 next unless $base;
2349             $ref = $base->{Routine}{$routine}
2350                          and return $ref;
2351                 $ref = $base->{MapRoutine}{$routine}
2352                    and return \&{"$ref"};
2353         }
2354
2355         return undef unless $Global::AccumulateCode;
2356 #::logDebug("trying code_from file for area=$area routine=$routine");
2357         $ref = Vend::Config::code_from_file($area, $routine)
2358                 or return undef;
2359 #::logDebug("returning ref=$ref for area=$area routine=$routine");
2360         return $ref;
2361 }
2362
2363 sub codedef_options {
2364         my ($tag, $modifier) = @_;
2365
2366         my @out;
2367         my $empty;
2368
2369         my @keys = keys %{$Vend::Cfg->{CodeDef}};
2370         push @keys, keys %{$Global::CodeDef};
2371
2372         my %gate = ( public => 1 );
2373
2374         my @mod = grep /\w/, split /[\s\0,]+/, $modifier;
2375         for(@mod) {
2376                 if($_ eq 'all') {
2377                         $gate{private} = 1;
2378                 }
2379
2380                 if($_ eq 'empty') {
2381                         $empty = ['', errmsg('--select--')];
2382                 }
2383
2384                 if($_ eq 'admin') {
2385                         $gate{admin} = 1;
2386                 }
2387         }
2388
2389         for(@keys) {
2390                 if(lc($tag) eq lc($_)) {
2391                         $tag = $_;
2392                         last;
2393                 }
2394         }
2395
2396         my %seen;
2397
2398         for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) {
2399                 if(my $desc = $repos->{Description}) {
2400                         my $vis = $repos->{Visibility} || {};
2401                         my $help = $repos->{Help} || {};
2402                         while( my($k, $v) = each %$desc) {
2403                                 next if $seen{$k}++;
2404                                 if(my $perm = $vis->{$k}) {
2405                                         if($perm =~ /^with\s+([\w:]+)/) {
2406                                                 my $mod = $1;
2407                                                 no strict 'refs';
2408                                                 next unless ${$mod . "::VERSION"};
2409                                         }
2410                                         else {
2411                                                 next unless $gate{$perm};
2412                                         }
2413                                 }
2414                                 push @out, [$k, $v, $help->{$k}];
2415                         }
2416                 }
2417         }
2418
2419         if(@out) {
2420                 @out = sort { $a->[1] cmp $b->[1] } @out;
2421                 unshift @out, $empty if $empty;
2422         }
2423         else {
2424                 push @out, ['', errmsg('--none--') ];
2425         }
2426         return \@out;
2427 }
2428
2429
2430 # Adds a timestamp to the end of a binary timecard file. You can specify the timestamp
2431 # as the second arg (unixtime) or just leave it out (or undefined) and it will be set
2432 # to the current time.
2433 sub timecard_stamp {
2434         my ($filename,$timestamp) = @_;
2435         $timestamp ||= time;
2436
2437         open(FH, '>>', $filename) or die "Can't open $filename for append: $!";
2438         lockfile(\*FH, 1, 1);
2439         binmode FH;
2440         print FH pack('N',time);
2441         unlockfile(\*FH);
2442         close FH;
2443 }
2444
2445
2446 # Reads a timestamp from a binary timecard file.  If $index is negative indexes back from
2447 # the end of the file, otherwise indexes from the front of the file so that 0 is the first
2448 # (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if
2449 # the file doesn't exist or the index falls outside of the bounds of the timecard file.
2450 sub timecard_read {
2451         my ($filename,$index) = @_;
2452         $index *= 4;
2453         my $limit = $index >= 0 ? $index + 4 : $index * -1;
2454
2455         if (-f $filename && (stat(_))[7] % 4) {
2456             # The file is corrupt, delete it and start over.
2457             ::logError("Counter file $filename found to be corrupt, deleting.");
2458             unlink($filename);
2459             return;
2460         }
2461         return unless (-f _ && (stat(_))[7] > $limit);
2462
2463         # The file exists and is big enough to cover the $index. Seek to the $index
2464         # and return the timestamp from that position.
2465
2466         open (FH, '<', $filename) or die "Can't open $filename for read: $!";
2467         lockfile(\*FH, 0, 1);
2468         binmode FH;
2469         seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!";
2470         my $rtime;
2471         read(FH,$rtime,4) or die "Can't read from $filename: $!";
2472         unlockfile(\*FH);
2473         close FH;
2474
2475         return unpack('N',$rtime);
2476 }
2477
2478 #
2479 # Adjusts a unix time stamp (2nd arg) by the amount specified in the first arg.  First arg should be
2480 # a number (signed integer or float) followed by one of second(s), minute(s), hour(s), day(s)
2481 # week(s) month(s) or year(s).  Second arg defaults to the current time.  If the third arg is true
2482 # the time will be compensated for daylight savings time (so that an adjustment of 6 months will
2483 # still cause the same time to be displayed, even if it is transgressing the DST boundary).
2484 #
2485 # This will accept multiple adjustments strung together, so you can do: "-5 days, 2 hours, 6 mins"
2486 # and the time will have thost amounts subtracted from it.  You can also add and subtract in the
2487 # same line, "+2 years -3 days".  If you specify a sign (+ or -) then that sign will remain in
2488 # effect until a new sign is specified on the line (so you can do,
2489 # "+5 years, 6 months, 3 days, -4 hours, 7 minutes").  The comma (,) between adjustments is
2490 # optional.
2491 #
2492 sub adjust_time {
2493     my ($adjust, $time, $compensate_dst) = @_;
2494     $time ||= time;
2495
2496     unless ($adjust =~ /^(?:\s*[+-]?\s*[\d\.]+\s*[a-z]*\s*,?)+$/i) {
2497         ::logError("adjust_time(): bad format: $adjust");
2498         return $time;
2499     }
2500
2501     # @times: 0: sec, 1: min, 2: hour, 3: day, 4: month, 5: year, 8: isdst
2502     # 6,7: dow and doy, but mktime ignores these (and so do we).
2503
2504     # A note about isdst: localtime returns 1 if returned time is adjusted for dst and 0 otherwise.
2505     # mktime expects the same, but if this is set to -1 mktime will determine if the date should be
2506     # dst adjusted according to dst rules for the current timezone.  The way that we use this is we
2507     # leave it set to the return value from locatime and we end up with a time that is adjusted by
2508     # an absolute amount (so if you adjust by six months the actual time returned may be different
2509     # but only because of DST).  If we want mktime to compensate for dst then we set this to -1 and
2510     # mktime will make the appropriate adjustment for us (either add one hour or subtract one hour
2511     # or leave the time the same).
2512
2513     my @times = localtime($time);
2514     my $sign = 1;
2515
2516     foreach my $amount ($adjust =~ /([+-]?\s*[\d\.]+\s*[a-z]*)/ig) {
2517         my $unit = 'seconds';
2518         $amount =~ s/\s+//g;
2519
2520         if ($amount =~ s/^([+-])//)   { $sign = $1 eq '+' ? 1 : -1 }
2521         if ($amount =~ s/([a-z]+)$//) { $unit = lc $1 }
2522         $amount *= $sign;
2523
2524         # A week is simply 7 days.
2525         if ($unit =~ /^w/) {
2526             $unit = 'days';
2527             $amount *= 7;
2528         }
2529
2530         if ($unit =~ /^s/) { $times[0] += $amount }
2531         elsif ($unit =~ /^mo/) { $times[4] += $amount } # has to come before min
2532         elsif ($unit =~ /^m/) { $times[1] += $amount }
2533         elsif ($unit =~ /^h/) { $times[2] += $amount }
2534         elsif ($unit =~ /^d/) { $times[3] += $amount }
2535         elsif ($unit =~ /^y/) { $times[5] += $amount }
2536
2537         else {
2538             ::logError("adjust_time(): bad unit: $unit");
2539             return $time;
2540         }
2541     }
2542
2543     if ($compensate_dst) { $times[8] = -1 }
2544
2545     # mktime can only handle integers, so we need to convert real numbers:
2546     my @multip = (0, 60, 60, 24, 0, 12);
2547     my $monfrac = 0;
2548     foreach my $i (reverse 0..5) {
2549         if ($times[$i] =~ /\./) {
2550             if ($multip[$i]) {
2551                 $times[$i-1] += ($times[$i] - int $times[$i]) * $multip[$i];
2552             }
2553
2554             elsif ($i == 4) {
2555                 # Fractions of a month need some really extra special handling.
2556                 $monfrac = $times[$i] - int $times[$i];
2557             }
2558
2559             $times[$i] = int $times[$i]
2560         }
2561     }
2562
2563     $time = POSIX::mktime(@times);
2564
2565     # This is how we handle a fraction of a month:
2566     if ($monfrac) {
2567         $times[4] += $monfrac > 0 ? 1 : -1;
2568         my $timediff = POSIX::mktime(@times);
2569         $timediff = int(abs($timediff - $time) * $monfrac);
2570         $time += $timediff;
2571     }
2572
2573     return $time;
2574 }
2575
2576 sub backtrace {
2577     my $msg = "Backtrace:\n\n";
2578     my $frame = 1;
2579
2580     my $assertfile = '';
2581     my $assertline = 0;
2582
2583     while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) {
2584         $msg .= sprintf("   frame %d: $subroutine ($filename line $line)\n", $frame - 2);
2585         if ($subroutine =~ /assert$/) {
2586             $assertfile = $filename;
2587             $assertline = $line;
2588         }
2589     }
2590     if ($assertfile) {
2591         open(SRC, $assertfile) and do {
2592             my $line;
2593             my $line_n = 0;
2594
2595             $msg .= "\nProblem in $assertfile line $assertline:\n\n";
2596
2597             while ($line = <SRC>) {
2598                 $line_n++;
2599                 $msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10);
2600             }
2601             close(SRC);
2602         };
2603     }
2604
2605     ::logGlobal($msg);
2606     undef;
2607 }
2608
2609 sub header_data_scrub {
2610         my ($head_data) = @_;
2611
2612         ## "HTTP Response Splitting" Exploit Fix
2613         ## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html
2614         $head_data =~ s/(?:%0[da]|[\r\n]+)+//ig;
2615
2616         return $head_data;
2617 }
2618
2619 ### Provide stubs for former Vend::Util functions relocated to Vend::File
2620 *canonpath = \&Vend::File::canonpath;
2621 *catdir = \&Vend::File::catdir;
2622 *catfile = \&Vend::File::catfile;
2623 *exists_filename = \&Vend::File::exists_filename;
2624 *file_modification_time = \&Vend::File::file_modification_time;
2625 *file_name_is_absolute = \&Vend::File::file_name_is_absolute;
2626 *get_filename = \&Vend::File::get_filename;
2627 *lockfile = \&Vend::File::lockfile;
2628 *path = \&Vend::File::path;
2629 *readfile = \&Vend::File::readfile;
2630 *readfile_db = \&Vend::File::readfile_db;
2631 *set_lock_type = \&Vend::File::set_lock_type;
2632 *unlockfile = \&Vend::File::unlockfile;
2633 *writefile = \&Vend::File::writefile;
2634
2635 1;
2636 __END__