UserDB: log timestamps to second granularity
[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{catalog} = $Vend::Cat;
1751         if($tpl =~ /\{caller\d+\}/i) {
1752             my @caller = caller();
1753             for(my $i = 0; $i < @caller; $i++) {
1754                 $debug{"caller$i"} = $caller[$i];
1755             }
1756         }
1757                 $debug{message} = errmsg(@_);
1758
1759                 $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
1760         }
1761         else {
1762                 $msg = caller() . ":debug: " . errmsg(@_);
1763         }
1764
1765         if ($Global::SysLog) {
1766                 logGlobal({ level => 'debug' }, $msg);
1767         }
1768         else {
1769                 print $msg, "\n";
1770         }
1771
1772         return;
1773 }
1774
1775 sub errmsg {
1776         my($fmt, @strings) = @_;
1777         my $location;
1778         if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
1779                 $location = $Vend::Cfg->{Locale};
1780         }
1781         elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
1782                 $location = $Global::Locale;
1783         }
1784         if($location) {
1785                 if(ref $location->{$fmt}) {
1786                         $fmt = $location->{$fmt}[0];
1787                         @strings = @strings[ @{ $location->{$fmt}[1] } ];
1788                 }
1789                 else {
1790                         $fmt = $location->{$fmt};
1791                 }
1792         }
1793         return scalar(@strings) ? sprintf $fmt, @strings : $fmt;
1794 }
1795
1796 *l = \&errmsg;
1797
1798 sub show_times {
1799         my $message = shift || 'time mark';
1800         my @times = times();
1801         for( my $i = 0; $i < @times; $i++) {
1802                 $times[$i] -= $Vend::Times[$i];
1803         }
1804         logDebug("$message: " . join " ", @times);
1805 }
1806
1807 # This %syslog_constant_map is an attempt to work around a strange problem
1808 # where the eval inside &Sys::Syslog::xlate fails, which then croaks.
1809 # The cause of this freakish problem is still to be determined.
1810
1811 my %syslog_constant_map;
1812
1813 sub setup_syslog_constant_map {
1814         for (
1815                 (map { "local$_" } (0..7)),
1816                 qw(
1817                         auth
1818                         authpriv
1819                         cron
1820                         daemon
1821                         ftp
1822                         kern
1823                         lpr
1824                         mail
1825                         news
1826                         syslog
1827                         user
1828                         uucp
1829
1830                         emerg
1831                         alert
1832                         crit
1833                         err
1834                         warning
1835                         notice
1836                         info
1837                         debug
1838                 )
1839         ) {
1840                 $syslog_constant_map{$_} = Sys::Syslog::xlate($_);
1841         }
1842         return;
1843 }
1844
1845 sub logGlobal {
1846         return 1 if $Vend::ExternalProgram;
1847
1848         my $opt;
1849         my $msg = shift;
1850         if (ref $msg) {
1851                 $opt = $msg;
1852                 $msg = shift;
1853         }
1854         else {
1855                 $opt = {};
1856         }
1857
1858         $msg = errmsg($msg, @_) if @_;
1859
1860         $Vend::Errors .= $msg . "\n" if $Global::DisplayErrors;
1861
1862         my $nl = $opt->{strip} ? '' : "\n";
1863         print "$msg$nl"
1864                 if $Global::Foreground
1865                         and ! $Vend::Log_suppress
1866                         and ! $Vend::Quiet
1867                         and ! $Global::SysLog;
1868
1869         my ($fn, $facility, $level);
1870         if ($Global::SysLog) {
1871                 $facility = $Global::SysLog->{facility} || 'local3';
1872                 $level    = $opt->{level} || 'info';
1873
1874                 # remap deprecated synonyms supported by logger(1)
1875                 my %level_map = (
1876                         error => 'err',
1877                         panic => 'emerg',
1878                         warn  => 'warning',
1879                 );
1880
1881                 # remap levels according to any user-defined global configuration
1882                 my $level_cfg;
1883                 if ($level_cfg = $Global::SysLog->{$level_map{$level} || $level}) {
1884                         if ($level_cfg =~ /(.+)\.(.+)/) {
1885                                 ($facility, $level) = ($1, $2);
1886                         }
1887                         else {
1888                                 $level = $level_cfg;
1889                         }
1890                 }
1891                 $level = $level_map{$level} if $level_map{$level};
1892
1893                 my $tag = $Global::SysLog->{tag} || 'interchange';
1894
1895                 my $socket = $opt->{socket} || $Global::SysLog->{socket};
1896
1897                 if ($Global::SysLog->{internal}) {
1898                         unless ($Vend::SysLogReady) {
1899                                 eval {
1900                                         use Sys::Syslog ();
1901                                         if ($socket) {
1902                                                 my ($socket_path, $types) = ($socket =~ /^(\S+)(?:\s+(.*))?/);
1903                                                 $types ||= 'native,tcp,udp,unix,pipe,stream,console';
1904                                                 my $type_array = [ grep /\S/, split /[,\s]+/, $types ];
1905                                                 Sys::Syslog::setlogsock($type_array, $socket_path) or die "Error calling setlogsock\n";
1906                                         }
1907                                         Sys::Syslog::openlog $tag, 'ndelay,pid', $facility;
1908                                 };
1909                                 if ($@) {
1910                                         print "\nError opening syslog: $@\n";
1911                                         print "to report this error:\n", $msg;
1912                                         exit 1;
1913                                 }
1914                                 setup_syslog_constant_map() unless %syslog_constant_map;
1915                                 $Vend::SysLogReady = 1;
1916                         }
1917                 }
1918                 else {
1919                         $fn = '|' . ($Global::SysLog->{command} || 'logger');
1920                         $fn .= " -p $facility.$level";
1921                         $fn .= " -t $tag" unless lc($tag) eq 'none';
1922                         $fn .= " -u $socket" if $socket;
1923                 }
1924         }
1925         else {
1926                 $fn = $Global::ErrorFile;
1927         }
1928
1929         if ($fn) {
1930                 my $lock;
1931                 if ($fn =~ s/^([^|>])/>>$1/) {
1932                         $lock = 1;
1933                         $msg = format_log_msg($msg);
1934                 }
1935
1936                 eval {
1937                         # We have checked for beginning > or | previously
1938                         open(MVERROR, $fn) or die "open\n";
1939                         if ($lock) {
1940                                 lockfile(\*MVERROR, 1, 1) or die "lock\n";
1941                                 seek(MVERROR, 0, 2) or die "seek\n";
1942                         }
1943                         print(MVERROR $msg, "\n") or die "write to\n";
1944                         if ($lock) {
1945                                 unlockfile(\*MVERROR) or die "unlock\n";
1946                         }
1947                         close(MVERROR) or die "close\n";
1948                 };
1949                 if ($@) {
1950                         chomp $@;
1951                         print "\nCould not $@ error file '$Global::ErrorFile':\n$!\n";
1952                         print "to report this error:\n", $msg, "\n";
1953                         exit 1;
1954                 }
1955
1956         }
1957         elsif ($Vend::SysLogReady) {
1958                 eval {
1959                         # avoid eval in Sys::Syslog::xlate() by using cached constants where possible
1960                         my $level_mapped = $syslog_constant_map{$level};
1961                         $level_mapped = $level unless defined $level_mapped;
1962                         my $facility_mapped = $syslog_constant_map{$facility};
1963                         $facility_mapped = $facility unless defined $facility_mapped;
1964                         my $priority = "$level_mapped|$facility_mapped";
1965                         Sys::Syslog::syslog $priority, $msg;
1966                 };
1967         }
1968
1969         return 1;
1970 }
1971
1972 sub logError {
1973         return unless $Vend::Cfg;
1974
1975         my $msg = shift;
1976         my $opt;
1977         if (ref $_[0]) {
1978                 $opt = shift;
1979         }
1980         else {
1981                 $opt = {};
1982         }
1983
1984         unless ($Global::SysLog) {
1985                 if (! $opt->{file}) {
1986                         my $tag = $opt->{tag} || $msg;
1987                         if (my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) {
1988                                 $opt->{file} = $dest;
1989                         }
1990                 }
1991                 $opt->{file} ||= $Vend::Cfg->{ErrorFile};
1992         }
1993
1994         $msg = errmsg($msg, @_) if @_;
1995
1996         print "$msg\n"
1997                 if $Global::Foreground
1998                         and ! $Vend::Log_suppress
1999                         and ! $Vend::Quiet
2000                         and ! $Global::SysLog;
2001
2002         $Vend::Session->{last_error} = $msg;
2003
2004         $msg = format_log_msg($msg) unless $msg =~ s/^\\//;
2005
2006         if ($Global::SysLog) {
2007                 logGlobal({ level => 'err' }, $msg);
2008                 return;
2009         }
2010
2011         $Vend::Errors .= $msg . "\n"
2012                 if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors;
2013
2014     my $reason;
2015     if (! allowed_file($opt->{file}, 1)) {
2016         $@ = 'access';
2017         $reason = 'prohibited by global configuration';
2018     }
2019     else {
2020         eval {
2021             open(MVERROR, '>>', $opt->{file})
2022                                         or die "open\n";
2023             lockfile(\*MVERROR, 1, 1)   or die "lock\n";
2024             seek(MVERROR, 0, 2)         or die "seek\n";
2025             print(MVERROR $msg, "\n")   or die "write to\n";
2026             unlockfile(\*MVERROR)       or die "unlock\n";
2027             close(MVERROR)              or die "close\n";
2028         };
2029     }
2030     if ($@) {
2031                 chomp $@;
2032                 logGlobal ({ level => 'info' },
2033                                         "Could not %s error file %s: %s\nto report this error: %s",
2034                                         $@,
2035                                         $opt->{file},
2036                                         $reason || $!,
2037                                         $msg,
2038                                 );
2039                 }
2040
2041         return;
2042 }
2043
2044 # Front-end to log routines that ignores repeated identical
2045 # log messages after the first occurrence
2046 my %logOnce_cache;
2047 my %log_sub_map = (
2048         data    => \&logData,
2049         debug   => \&logDebug,
2050         error   => \&logError,
2051         global  => \&logGlobal,
2052 );
2053
2054 # First argument should be log type (see above map).
2055 # Rest of arguments are same as if calling log routine directly.
2056 sub logOnce {
2057         my $tag = join "", @_;
2058         return if exists $logOnce_cache{$tag};
2059         my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error};
2060         my $status = $log_sub->(@_);
2061         $logOnce_cache{$tag} = 1;
2062         return $status;
2063 }
2064
2065
2066 # Here for convenience in calls
2067 sub set_cookie {
2068     my ($name, $value, $expire, $domain, $path, $secure) = @_;
2069
2070     # Set expire to now + some time if expire string is something like
2071     # "30 days" or "7 weeks" or even "60 minutes"
2072         if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
2073             $expire = adjust_time($expire);
2074         }
2075
2076         if (! $::Instance->{Cookies}) {
2077                 $::Instance->{Cookies} = []
2078         }
2079         else {
2080                 @{$::Instance->{Cookies}} =
2081                         grep $_->[0] ne $name, @{$::Instance->{Cookies}};
2082         }
2083     push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
2084     return;
2085 }
2086
2087 # Here for convenience in calls
2088 sub read_cookie {
2089         my ($lookfor, $string) = @_;
2090         $string = $CGI::cookie
2091                 unless defined $string;
2092     return cookies_hash($string) unless defined $lookfor && length($lookfor);
2093     return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
2094         return unescape_chars($1);
2095 }
2096
2097 sub cookies_hash {
2098     my $string = shift || $CGI::cookie;
2099     my %cookies = map {
2100         my ($k,$v) = split '=', $_, 2;
2101         $k => unescape_chars($v)
2102     } split(/;\s*/, $string);
2103     return \%cookies;
2104 }
2105
2106 sub send_mail {
2107         my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
2108
2109         if(ref $to) {
2110                 my $head = $to;
2111
2112                 for(my $i = $#$head; $i > 0; $i--) {
2113                         if($head->[$i] =~ /^\s/) {
2114                                 my $new = splice @$head, $i, 1;
2115                                 $head->[$i - 1] .= "\n$new";
2116                         }
2117                 }
2118
2119                 $body = $subject;
2120                 undef $subject;
2121                 for(@$head) {
2122                         s/\s+$//;
2123                         if (/^To:\s*(.+)/si) {
2124                                 $to = $1;
2125                         }
2126                         elsif (/^Reply-to:\s*(.+)/si) {
2127                                 $reply = $1;
2128                         }
2129                         elsif (/^subj(?:ect)?:\s*(.+)/si) {
2130                                 $subject = $1;
2131                         }
2132                         elsif($_) {
2133                                 push @extra_headers, $_;
2134                         }
2135                 }
2136         }
2137
2138         # If configured, intercept all outgoing email and re-route
2139         if (
2140                 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
2141                                 || $Global::Variable->{MV_EMAIL_INTERCEPT}
2142         ) {
2143                 my @info_headers;
2144                 $to = "To: $to";
2145                 for ($to, @extra_headers) {
2146                         next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
2147                         logError(
2148                                 "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
2149                                 $header, $value, $intercept
2150                         );
2151                         $_ = "$header: $intercept";
2152                         push @info_headers, "X-Intercepted-$header: $value";
2153                 }
2154                 $to =~ s/^To: //;
2155                 push @extra_headers, @info_headers;
2156         }
2157
2158         my($ok);
2159 #::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
2160
2161         unless (defined $use_mime) {
2162                 $use_mime = $::Instance->{MIME} || undef;
2163         }
2164
2165         if(!defined $reply) {
2166                 $reply = $::Values->{mv_email}
2167                                 ?  "Reply-To: $::Values->{mv_email}\n"
2168                                 : '';
2169         }
2170         elsif ($reply) {
2171                 $reply = "Reply-To: $reply\n"
2172                         unless $reply =~ /^reply-to:/i;
2173                 $reply =~ s/\s+$/\n/;
2174         }
2175
2176         $ok = 0;
2177         my $none;
2178         my $using = $Vend::Cfg->{SendMailProgram};
2179
2180         if($using =~ /^(none|Net::SMTP)$/i) {
2181                 $none = 1;
2182                 $ok = 1;
2183         }
2184
2185         SEND: {
2186 #::logDebug("testing sendmail send none=$none");
2187                 last SEND if $none;
2188 #::logDebug("in Sendmail send $using");
2189                 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
2190                 my $mime = '';
2191                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2192                 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
2193                         or last SEND;
2194                 for(@extra_headers) {
2195                         s/\s*$/\n/;
2196                         print MVMAIL $_
2197                                 or last SEND;
2198                 }
2199                 $mime =~ s/\s*$/\n/;
2200                 print MVMAIL $mime
2201                         or last SEND;
2202                 print MVMAIL $body
2203                                 or last SEND;
2204                 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
2205                         if $use_mime;
2206                 print MVMAIL "\r\n\cZ" if $Global::Windows;
2207                 close MVMAIL or last SEND;
2208                 $ok = ($? == 0);
2209         }
2210
2211         SMTP: {
2212                 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
2213                 my $helo =  $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
2214                 last SMTP unless $none and $mhost;
2215                 eval {
2216                         require Net::SMTP;
2217                 };
2218                 last SMTP if $@;
2219                 $ok = 0;
2220                 $using = "Net::SMTP (mail server $mhost)";
2221 #::logDebug("using $using");
2222                 undef $none;
2223
2224                 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP;
2225 #::logDebug("smtp object $smtp");
2226
2227                 my $from = $::Variable->{MV_MAILFROM}
2228                                 || $Global::Variable->{MV_MAILFROM}
2229                                 || $Vend::Cfg->{MailOrderTo};
2230                 
2231                 for(@extra_headers) {
2232                         s/\s*$/\n/;
2233                         next unless /^From:\s*(\S.+)$/mi;
2234                         $from = $1;
2235                 }
2236                 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
2237                 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
2238
2239                 my $mime = '';
2240                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
2241                 $smtp->mail($from)
2242                         or last SMTP;
2243 #::logDebug("smtp accepted from=$from");
2244
2245                 my @to;
2246                 my @addr = split /\s*,\s*/, $to;
2247                 for (@addr) {
2248                         if(/\s/) {
2249                                 ## Uh-oh. Try to handle
2250                                 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
2251                                         push @to, $1
2252                                 }
2253                                 else {
2254                                         logError("Net::SMTP sender skipping unparsable address %s", $_);
2255                                 }
2256                         }
2257                         else {
2258                                 push @to, $_;
2259                         }
2260                 }
2261                 
2262                 @addr = $smtp->recipient(@to, { SkipBad => 1 });
2263                 if(scalar(@addr) != scalar(@to)) {
2264                         logError(
2265                                 "Net::SMTP not able to send to all addresses of %s",
2266                                 join(", ", @to),
2267                         );
2268                 }
2269
2270 #::logDebug("smtp accepted to=" . join(",", @addr));
2271
2272                 $smtp->data();
2273
2274                 push @extra_headers, $reply if $reply;
2275                 for ("To: $to", "Subject: $subject", @extra_headers) {
2276                         next unless $_;
2277                         s/\s*$/\n/;
2278 #::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
2279                         $smtp->datasend($_)
2280                                 or last SMTP;
2281                 }
2282
2283                 if($use_mime) {
2284                         $mime =~ s/\s*$/\n/;
2285                         $smtp->datasend($mime)
2286                                 or last SMTP;
2287                 }
2288                 $smtp->datasend("\n");
2289                 $smtp->datasend($body)
2290                         or last SMTP;
2291                 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
2292                         if $use_mime;
2293                 $smtp->dataend()
2294                         or last SMTP;
2295                 $ok = $smtp->quit();
2296         }
2297
2298         if ($none or !$ok) {
2299                 logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
2300                                 $using,
2301                                 $to,
2302                                 $subject,
2303                                 $reply,
2304                                 $body,
2305                 );
2306         }
2307
2308         $ok;
2309 }
2310
2311 sub codedef_routine {
2312         my ($tag, $routine, $modifier) = @_;
2313
2314         my $area = $Vend::Config::tagCanon{lc $tag}
2315                 or do {
2316                         logError("Unknown CodeDef type %s", $tag);
2317                         return undef;
2318                 };
2319
2320         $routine =~ s/-/_/g;
2321         my @tries;
2322         if ($tag eq 'UserTag') {
2323                 @tries = ($Vend::Cfg->{UserTag}, $Global::UserTag);
2324                 }
2325         else {
2326                 @tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area});
2327         }
2328
2329         no strict 'refs';
2330
2331         my $ref;
2332
2333         for my $base (@tries) {
2334                 next unless $base;
2335             $ref = $base->{Routine}{$routine}
2336                          and return $ref;
2337                 $ref = $base->{MapRoutine}{$routine}
2338                    and return \&{"$ref"};
2339         }
2340
2341         return undef unless $Global::AccumulateCode;
2342 #::logDebug("trying code_from file for area=$area routine=$routine");
2343         $ref = Vend::Config::code_from_file($area, $routine)
2344                 or return undef;
2345 #::logDebug("returning ref=$ref for area=$area routine=$routine");
2346         return $ref;
2347 }
2348
2349 sub codedef_options {
2350         my ($tag, $modifier) = @_;
2351
2352         my @out;
2353         my $empty;
2354
2355         my @keys = keys %{$Vend::Cfg->{CodeDef}};
2356         push @keys, keys %{$Global::CodeDef};
2357
2358         my %gate = ( public => 1 );
2359
2360         my @mod = grep /\w/, split /[\s\0,]+/, $modifier;
2361         for(@mod) {
2362                 if($_ eq 'all') {
2363                         $gate{private} = 1;
2364                 }
2365
2366                 if($_ eq 'empty') {
2367                         $empty = ['', errmsg('--select--')];
2368                 }
2369
2370                 if($_ eq 'admin') {
2371                         $gate{admin} = 1;
2372                 }
2373         }
2374
2375         for(@keys) {
2376                 if(lc($tag) eq lc($_)) {
2377                         $tag = $_;
2378                         last;
2379                 }
2380         }
2381
2382         my %seen;
2383
2384         for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) {
2385                 if(my $desc = $repos->{Description}) {
2386                         my $vis = $repos->{Visibility} || {};
2387                         my $help = $repos->{Help} || {};
2388                         while( my($k, $v) = each %$desc) {
2389                                 next if $seen{$k}++;
2390                                 if(my $perm = $vis->{$k}) {
2391                                         if($perm =~ /^with\s+([\w:]+)/) {
2392                                                 my $mod = $1;
2393                                                 no strict 'refs';
2394                                                 next unless ${$mod . "::VERSION"};
2395                                         }
2396                                         else {
2397                                                 next unless $gate{$perm};
2398                                         }
2399                                 }
2400                                 push @out, [$k, $v, $help->{$k}];
2401                         }
2402                 }
2403         }
2404
2405         if(@out) {
2406                 @out = sort { $a->[1] cmp $b->[1] } @out;
2407                 unshift @out, $empty if $empty;
2408         }
2409         else {
2410                 push @out, ['', errmsg('--none--') ];
2411         }
2412         return \@out;
2413 }
2414
2415
2416 # Adds a timestamp to the end of a binary timecard file. You can specify the timestamp
2417 # as the second arg (unixtime) or just leave it out (or undefined) and it will be set
2418 # to the current time.
2419 sub timecard_stamp {
2420         my ($filename,$timestamp) = @_;
2421         $timestamp ||= time;
2422
2423         open(FH, '>>', $filename) or die "Can't open $filename for append: $!";
2424         lockfile(\*FH, 1, 1);
2425         binmode FH;
2426         print FH pack('N',time);
2427         unlockfile(\*FH);
2428         close FH;
2429 }
2430
2431
2432 # Reads a timestamp from a binary timecard file.  If $index is negative indexes back from
2433 # the end of the file, otherwise indexes from the front of the file so that 0 is the first
2434 # (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if
2435 # the file doesn't exist or the index falls outside of the bounds of the timecard file.
2436 sub timecard_read {
2437         my ($filename,$index) = @_;
2438         $index *= 4;
2439         my $limit = $index >= 0 ? $index + 4 : $index * -1;
2440
2441         if (-f $filename && (stat(_))[7] % 4) {
2442             # The file is corrupt, delete it and start over.
2443             ::logError("Counter file $filename found to be corrupt, deleting.");
2444             unlink($filename);
2445             return;
2446         }
2447         return unless (-f _ && (stat(_))[7] > $limit);
2448
2449         # The file exists and is big enough to cover the $index. Seek to the $index
2450         # and return the timestamp from that position.
2451
2452         open (FH, '<', $filename) or die "Can't open $filename for read: $!";
2453         lockfile(\*FH, 0, 1);
2454         binmode FH;
2455         seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!";
2456         my $rtime;
2457         read(FH,$rtime,4) or die "Can't read from $filename: $!";
2458         unlockfile(\*FH);
2459         close FH;
2460
2461         return unpack('N',$rtime);
2462 }
2463
2464 #
2465 # Adjusts a unix time stamp (2nd arg) by the amount specified in the first arg.  First arg should be
2466 # a number (signed integer or float) followed by one of second(s), minute(s), hour(s), day(s)
2467 # week(s) month(s) or year(s).  Second arg defaults to the current time.  If the third arg is true
2468 # the time will be compensated for daylight savings time (so that an adjustment of 6 months will
2469 # still cause the same time to be displayed, even if it is transgressing the DST boundary).
2470 #
2471 # This will accept multiple adjustments strung together, so you can do: "-5 days, 2 hours, 6 mins"
2472 # and the time will have thost amounts subtracted from it.  You can also add and subtract in the
2473 # same line, "+2 years -3 days".  If you specify a sign (+ or -) then that sign will remain in
2474 # effect until a new sign is specified on the line (so you can do,
2475 # "+5 years, 6 months, 3 days, -4 hours, 7 minutes").  The comma (,) between adjustments is
2476 # optional.
2477 #
2478 sub adjust_time {
2479     my ($adjust, $time, $compensate_dst) = @_;
2480     $time ||= time;
2481
2482     unless ($adjust =~ /^(?:\s*[+-]?\s*[\d\.]+\s*[a-z]*\s*,?)+$/i) {
2483         ::logError("adjust_time(): bad format: $adjust");
2484         return $time;
2485     }
2486
2487     # @times: 0: sec, 1: min, 2: hour, 3: day, 4: month, 5: year, 8: isdst
2488     # 6,7: dow and doy, but mktime ignores these (and so do we).
2489
2490     # A note about isdst: localtime returns 1 if returned time is adjusted for dst and 0 otherwise.
2491     # mktime expects the same, but if this is set to -1 mktime will determine if the date should be
2492     # dst adjusted according to dst rules for the current timezone.  The way that we use this is we
2493     # leave it set to the return value from locatime and we end up with a time that is adjusted by
2494     # an absolute amount (so if you adjust by six months the actual time returned may be different
2495     # but only because of DST).  If we want mktime to compensate for dst then we set this to -1 and
2496     # mktime will make the appropriate adjustment for us (either add one hour or subtract one hour
2497     # or leave the time the same).
2498
2499     my @times = localtime($time);
2500     my $sign = 1;
2501
2502     foreach my $amount ($adjust =~ /([+-]?\s*[\d\.]+\s*[a-z]*)/ig) {
2503         my $unit = 'seconds';
2504         $amount =~ s/\s+//g;
2505
2506         if ($amount =~ s/^([+-])//)   { $sign = $1 eq '+' ? 1 : -1 }
2507         if ($amount =~ s/([a-z]+)$//) { $unit = lc $1 }
2508         $amount *= $sign;
2509
2510         # A week is simply 7 days.
2511         if ($unit =~ /^w/) {
2512             $unit = 'days';
2513             $amount *= 7;
2514         }
2515
2516         if ($unit =~ /^s/) { $times[0] += $amount }
2517         elsif ($unit =~ /^mo/) { $times[4] += $amount } # has to come before min
2518         elsif ($unit =~ /^m/) { $times[1] += $amount }
2519         elsif ($unit =~ /^h/) { $times[2] += $amount }
2520         elsif ($unit =~ /^d/) { $times[3] += $amount }
2521         elsif ($unit =~ /^y/) { $times[5] += $amount }
2522
2523         else {
2524             ::logError("adjust_time(): bad unit: $unit");
2525             return $time;
2526         }
2527     }
2528
2529     if ($compensate_dst) { $times[8] = -1 }
2530
2531     # mktime can only handle integers, so we need to convert real numbers:
2532     my @multip = (0, 60, 60, 24, 0, 12);
2533     my $monfrac = 0;
2534     foreach my $i (reverse 0..5) {
2535         if ($times[$i] =~ /\./) {
2536             if ($multip[$i]) {
2537                 $times[$i-1] += ($times[$i] - int $times[$i]) * $multip[$i];
2538             }
2539
2540             elsif ($i == 4) {
2541                 # Fractions of a month need some really extra special handling.
2542                 $monfrac = $times[$i] - int $times[$i];
2543             }
2544
2545             $times[$i] = int $times[$i]
2546         }
2547     }
2548
2549     $time = POSIX::mktime(@times);
2550
2551     # This is how we handle a fraction of a month:
2552     if ($monfrac) {
2553         $times[4] += $monfrac > 0 ? 1 : -1;
2554         my $timediff = POSIX::mktime(@times);
2555         $timediff = int(abs($timediff - $time) * $monfrac);
2556         $time += $timediff;
2557     }
2558
2559     return $time;
2560 }
2561
2562 sub backtrace {
2563     my $msg = "Backtrace:\n\n";
2564     my $frame = 1;
2565
2566     my $assertfile = '';
2567     my $assertline = 0;
2568
2569     while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) {
2570         $msg .= sprintf("   frame %d: $subroutine ($filename line $line)\n", $frame - 2);
2571         if ($subroutine =~ /assert$/) {
2572             $assertfile = $filename;
2573             $assertline = $line;
2574         }
2575     }
2576     if ($assertfile) {
2577         open(SRC, $assertfile) and do {
2578             my $line;
2579             my $line_n = 0;
2580
2581             $msg .= "\nProblem in $assertfile line $assertline:\n\n";
2582
2583             while ($line = <SRC>) {
2584                 $line_n++;
2585                 $msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10);
2586             }
2587             close(SRC);
2588         };
2589     }
2590
2591     ::logGlobal($msg);
2592     undef;
2593 }
2594
2595 sub header_data_scrub {
2596         my ($head_data) = @_;
2597
2598         ## "HTTP Response Splitting" Exploit Fix
2599         ## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html
2600         $head_data =~ s/(?:%0[da]|[\r\n]+)+//ig;
2601
2602         return $head_data;
2603 }
2604
2605 ### Provide stubs for former Vend::Util functions relocated to Vend::File
2606 *canonpath = \&Vend::File::canonpath;
2607 *catdir = \&Vend::File::catdir;
2608 *catfile = \&Vend::File::catfile;
2609 *exists_filename = \&Vend::File::exists_filename;
2610 *file_modification_time = \&Vend::File::file_modification_time;
2611 *file_name_is_absolute = \&Vend::File::file_name_is_absolute;
2612 *get_filename = \&Vend::File::get_filename;
2613 *lockfile = \&Vend::File::lockfile;
2614 *path = \&Vend::File::path;
2615 *readfile = \&Vend::File::readfile;
2616 *readfile_db = \&Vend::File::readfile_db;
2617 *set_lock_type = \&Vend::File::set_lock_type;
2618 *unlockfile = \&Vend::File::unlockfile;
2619 *writefile = \&Vend::File::writefile;
2620
2621 1;
2622 __END__