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