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