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