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