Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2595 lines (2229 sloc) 60.459 kB
# Vend::Util - Interchange utility functions
#
# Copyright (C) 2002-2009 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
#
# This program was originally based on Vend 0.2 and 0.3
# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301 USA.
package Vend::Util;
require Exporter;
unless( $ENV{MINIVEND_DISABLE_UTF8} ) {
require Encode;
import Encode qw( is_utf8 encode_utf8 );
}
@ISA = qw(Exporter);
@EXPORT = qw(
adjust_time
catfile
check_security
copyref
currency
dbref
dump_structure
errmsg
escape_chars
evalr
dotted_hash
file_modification_time
file_name_is_absolute
find_special_page
format_log_msg
generate_key
get_option_hash
hash_string
header_data_scrub
hexify
is_hash
is_ipv4
is_ipv6
is_no
is_yes
l
lockfile
logData
logDebug
logError
logGlobal
logOnce
logtime
random_string
readfile
readin
round_to_frac_digits
secure_vendUrl
send_mail
setup_escape_chars
set_lock_type
show_times
string_to_ref
tag_nitems
timecard_stamp
timecard_read
backtrace
uneval
uneval_it
uneval_fast
unhexify
unlockfile
vendUrl
);
use strict;
no warnings qw(uninitialized numeric);
use Config;
use Fcntl;
use Errno;
use Text::ParseWords;
require HTML::Entities;
use Vend::Safe;
use Vend::File;
use subs qw(logError logGlobal);
use vars qw($VERSION @EXPORT @EXPORT_OK);
$VERSION = substr(q$Revision: 2.127 $, 10);
my $Eval_routine;
my $Eval_routine_file;
my $Pretty_uneval;
my $Fast_uneval;
my $Fast_uneval_file;
### END CONFIGURABLE MODULES
## ESCAPE_CHARS
$ESCAPE_CHARS::ok_in_filename =
'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
'abcdefghijklmnopqrstuvwxyz' .
'0123456789' .
'-:_.$/'
;
$ESCAPE_CHARS::ok_in_url =
'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
'abcdefghijklmnopqrstuvwxyz' .
'0123456789' .
'-_./~='
;
## This is a character class for HTML::Entities
$ESCAPE_CHARS::std = qq{^\n\t\X !\#\$%\'-;=?-Z\\\]-~};
## Some standard error templates
## This is an alias for a commonly-used function
*dbref = \&Vend::Data::database_exists_ref;
my $need_escape;
sub setup_escape_chars {
my($ok, $i, $a, $t);
## HTML::Entities caches this, let's get it cached right away so
## each child doesn't have to re-eval
my $junk = ">>>123<<<";
HTML::Entities::encode($junk, $ESCAPE_CHARS::std);
foreach $i (0..255) {
$a = chr($i);
if (index($ESCAPE_CHARS::ok_in_filename,$a) == -1) {
$t = '%' . sprintf( "%02X", $i );
}
else {
$t = $a;
}
$ESCAPE_CHARS::translate[$i] = $t;
if (index($ESCAPE_CHARS::ok_in_url,$a) == -1) {
$t = '%' . sprintf( "%02X", $i );
}
else {
$t = $a;
}
$ESCAPE_CHARS::translate_url[$i] = $t;
}
my $string = "[^$ESCAPE_CHARS::ok_in_url]";
$need_escape = qr{$string};
}
# Replace any characters that might not be safe in a filename (especially
# shell metacharacters) with the %HH notation.
sub escape_chars {
my($in) = @_;
my($c, $r);
$r = '';
foreach $c (split(m{}, $in)) {
$r .= $ESCAPE_CHARS::translate[ord($c)];
}
# safe now
return $r;
}
# Replace any characters that might not be safe in an URL
# with the %HH notation.
sub escape_chars_url {
my($in) = @_;
return $in unless $in =~ $need_escape;
my($c, $r);
$r = '';
foreach $c (split(m{}, $in)) {
$r .= $ESCAPE_CHARS::translate_url[ord($c)];
}
# safe now
return $r;
}
# Returns its arguments as a string of tab-separated fields. Tabs in the
# argument values are converted to spaces.
sub tabbed {
return join("\t", map { $_ = '' unless defined $_;
s/\t/ /g;
$_;
} @_);
}
# Returns time in HTTP common log format
sub logtime {
return POSIX::strftime("[%d/%B/%Y:%H:%M:%S %z]", localtime());
}
sub format_log_msg {
my($msg) = @_;
my(@params);
# IP, Session, REMOTE_USER (if any) and time
push @params, ($CGI::remote_host || $CGI::remote_addr || '-');
push @params, ($Vend::SessionName || '-');
push @params, ($CGI::user || '-');
push @params, logtime() unless $Global::SysLog;
# Catalog name
my $string = ! defined $Vend::Cfg ? '-' : ($Vend::Cat || '-');
push @params, $string;
# Path info and script
$string = $CGI::script_name || '-';
$string .= $CGI::path_info || '';
push @params, $string;
# Message, quote newlined area
$msg =~ s/\n/\n> /g;
push @params, $msg;
return join " ", @params;
}
sub round_to_frac_digits {
my ($num, $digits) = @_;
if (defined $digits) {
# use what we were given
}
elsif ( $Vend::Cfg->{Locale} ) {
$digits = $Vend::Cfg->{Locale}{frac_digits};
$digits = 2 if ! defined $digits;
}
else {
$digits = 2;
}
my @frac;
$num =~ /^(-?)(\d*)(?:\.(\d+))?$/
or return $num;
my $sign = $1 || '';
my $int = $2;
@frac = split(m{}, ($3 || 0));
local($^W) = 0;
my $frac = join "", @frac[0 .. $digits - 1];
if($frac[$digits] > 4) {
$frac++;
}
if(length($frac) > $digits) {
$int++;
$frac = 0 x $digits;
}
$frac .= '0' while length($frac) < $digits;
return "$sign$int.$frac";
}
use vars qw/%MIME_type/;
%MIME_type = (qw|
jpg image/jpeg
gif image/gif
jpeg image/jpeg
png image/png
xpm image/xpm
htm text/html
html text/html
txt text/plain
asc text/plain
csv text/plain
xls application/vnd.ms-excel
default application/octet-stream
|
);
# Return a mime type based on either catalog configuration or some defaults
sub mime_type {
my ($val) = @_;
$val =~ s:.*\.::s;
! length($val) and return $Vend::Cfg->{MimeType}{default} || 'text/plain';
$val = lc $val;
return $Vend::Cfg->{MimeType}{$val}
|| $MIME_type{$val}
|| $Vend::Cfg->{MimeType}{default}
|| $MIME_type{default};
}
# Return AMOUNT formatted as currency.
sub commify {
local($_) = shift;
my $sep = shift || ',';
1 while s/^(-?\d+)(\d{3})/$1$sep$2/;
return $_;
}
my %safe_locale = (
C => 1,
en_US => 1,
en_UK => 1,
en_GB => 1,
);
sub safe_sprintf {
# need to supply $fmt as a scalar to prevent prototype problems
my $fmt = shift;
# query the locale
my $save = POSIX::setlocale (&POSIX::LC_NUMERIC);
# This should be faster than doing set every time....but when
# is locale C anymore? Should we set this by default?
return sprintf($fmt, @_) if $safe_locale{$save};
# Need to set.
POSIX::setlocale (&POSIX::LC_NUMERIC, 'C');
my $val = sprintf($fmt, @_);
POSIX::setlocale (&POSIX::LC_NUMERIC, $save);
return $val;
}
sub picture_format {
my($amount, $pic, $sep, $point) = @_;
$pic = reverse $pic;
$point = '.' unless defined $point;
$sep = ',' unless defined $sep;
my $len = $pic =~ /(#+)\Q$point/
? length($1)
: 0
;
$amount = sprintf('%.' . $len . 'f', $amount);
$amount =~ tr/0-9//cd;
my (@dig) = split m{}, $amount;
$pic =~ s/#/pop(@dig)/eg;
$pic =~ s/\Q$sep\E+(?!\d)//;
$pic =~ s/\d/*/g if @dig;
$amount = reverse $pic;
return $amount;
}
sub setlocale {
my ($locale, $currency, $opt) = @_;
#::logDebug("original locale " . (defined $locale ? $locale : 'undef') );
#::logDebug("default locale " . (defined $::Scratch->{mv_locale} ? $::Scratch->{mv_locale} : 'undef') );
if($opt->{get}) {
my $loc = $Vend::Cfg->{Locale_repository} or return;
my $currloc = $Vend::Cfg->{Locale} or return;
for(keys %$loc) {
return $_ if $loc->{$_} eq $currloc;
}
return;
}
$locale = $::Scratch->{mv_locale} unless defined $locale;
#::logDebug("locale is now " . (defined $locale ? $locale : 'undef') );
if ( $locale and not defined $Vend::Cfg->{Locale_repository}{$locale}) {
::logError( "attempt to set non-existant locale '%s'" , $locale );
return '';
}
if ( $currency and not defined $Vend::Cfg->{Locale_repository}{$currency}) {
::logError("attempt to set non-existant currency '%s'" , $currency);
return '';
}
if($locale) {
my $loc = $Vend::Cfg->{Locale} = $Vend::Cfg->{Locale_repository}{$locale};
for(@Vend::Config::Locale_directives_scalar) {
$Vend::Cfg->{$_} = $loc->{$_}
if defined $loc->{$_};
}
for(@Vend::Config::Locale_directives_ary) {
@{$Vend::Cfg->{$_}} = split (/\s+/, $loc->{$_})
if $loc->{$_};
}
for(@Vend::Config::Locale_directives_code) {
next unless $loc->{$_->[0]};
my ($routine, $args) = @{$_}[1,2];
if($args) {
$routine->(@$args);
}
else {
$routine->();
}
}
no strict 'refs';
for(qw/LC_COLLATE LC_CTYPE LC_TIME/) {
next unless $loc->{$_};
POSIX::setlocale(&{"POSIX::$_"}, $loc->{$_});
}
}
if ($currency) {
my $curr = $Vend::Cfg->{Currency_repository}{$currency};
for(@Vend::Config::Locale_directives_currency) {
$Vend::Cfg->{$_} = $curr->{$_}
if defined $curr->{$_};
}
for(@Vend::Config::Locale_keys_currency) {
$Vend::Cfg->{Locale}{$_} = $curr->{$_}
if defined $curr->{$_};
}
}
if(my $ref = $Vend::Cfg->{CodeDef}{LocaleChange}) {
$ref = $ref->{Routine};
if($ref->{all}) {
$ref->{all}->($locale, $opt);
}
if($ref->{lc $locale}) {
$ref->{lc $locale}->($locale, $opt);
}
}
if($opt->{persist}) {
$::Scratch->{mv_locale} = $locale if $locale;
delete $::Scratch->{mv_currency_tmp};
delete $::Scratch->{mv_currency};
$::Scratch->{mv_currency} = $currency if $currency;
}
elsif($currency) {
Vend::Interpolate::set_tmp('mv_currency_tmp')
unless defined $::Scratch->{mv_currency_tmp};
$::Scratch->{mv_currency_tmp} = $currency;
}
else {
delete $::Scratch->{mv_currency_tmp};
delete $::Scratch->{mv_currency};
}
return '';
}
sub currency {
my($amount, $noformat, $convert, $opt) = @_;
$opt = {} unless $opt;
$convert ||= $opt->{convert};
my $pd = $Vend::Cfg->{PriceDivide};
if($opt->{locale}) {
$convert = 1 unless length($convert);
$pd = $Vend::Cfg->{Locale_repository}{$opt->{locale}}{PriceDivide};
}
if($pd and $convert) {
$amount = $amount / $pd;
}
my $hash;
if(
$noformat =~ /\w+=\w\w/
and
ref($hash = get_option_hash($noformat)) eq 'HASH'
)
{
$opt->{display} ||= $hash->{display};
$noformat = $opt->{noformat} = $hash->{noformat};
}
return $amount if $noformat;
my $sep;
my $dec;
my $fmt;
my $precede = '';
my $succede = '';
my $loc = $opt->{locale}
|| $::Scratch->{mv_currency_tmp}
|| $::Scratch->{mv_currency}
|| $Vend::Cfg->{Locale};
if(ref($loc)) {
## Do nothing, is a hash reference
}
elsif($loc) {
$loc = $Vend::Cfg->{Locale_repository}{$loc};
}
if (! $loc) {
$fmt = "%.2f";
}
else {
$sep = $loc->{mon_thousands_sep} || $loc->{thousands_sep} || ',';
$dec = $loc->{mon_decimal_point} || $loc->{decimal_point} || '.';
return picture_format($amount, $loc->{price_picture}, $sep, $dec)
if defined $loc->{price_picture};
if (defined $loc->{frac_digits}) {
$fmt = "%." . $loc->{frac_digits} . "f";
} else {
$fmt = "%.2f";
}
my $cs;
my $display = lc($opt->{display}) || 'symbol';
my $sep_by_space = $loc->{p_sep_by_space};
my $cs_precedes = $loc->{p_cs_precedes};
if( $loc->{int_currency_symbol} && $display eq 'text' ) {
$cs = $loc->{int_currency_symbol};
$cs_precedes = 1;
if (length($cs) > 3 || $cs =~ /\W$/) {
$sep_by_space = 0;
}
else {
$sep_by_space = 1;
}
}
elsif ( $display eq 'none' ) {
$cs = '';
}
elsif ( $display eq 'symbol' ) {
$cs = $loc->{currency_symbol} || '';
}
if($cs) {
if ($cs_precedes) {
$precede = $cs;
$precede = "$precede " if $sep_by_space;
}
else {
$succede = $cs;
$succede = " $succede" if $sep_by_space;
}
}
}
$amount = safe_sprintf($fmt, $amount);
$amount =~ s/\./$dec/ if defined $dec;
$amount = commify($amount, $sep || undef)
if $Vend::Cfg->{PriceCommas};
return "$precede$amount$succede";
}
## random_string
# leaving out 0, O and 1, l
my $random_chars = "ABCDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz23456789";
# Return a string of random characters.
sub random_string {
my ($len) = @_;
$len = 8 unless $len;
my ($r, $i);
$r = '';
for ($i = 0; $i < $len; ++$i) {
$r .= substr($random_chars, int(rand(length($random_chars))), 1);
}
$r;
}
# To generate a unique key for caching
# Not very good without MD5
#
my $Md;
my $Keysub;
eval {require Digest::MD5 };
if(! $@) {
$Md = new Digest::MD5;
$Keysub = sub {
@_ = time() unless @_;
$Md->reset();
if($Global::UTF8) {
$Md->add(map encode_utf8($_), @_);
}
else {
$Md->add(@_);
}
$Md->hexdigest();
};
}
else {
$Keysub = sub {
my $out = '';
@_ = time() unless @_;
for(@_) {
$out .= unpack "%32c*", $_;
$out .= unpack "%32c*", substr($_,5);
$out .= unpack "%32c*", substr($_,-1,5);
}
$out;
};
}
sub generate_key { &$Keysub(@_) }
sub hexify {
my $string = shift;
$string =~ s/(\W)/sprintf '%%%02x', ord($1)/ge;
return $string;
}
sub unhexify {
my $s = shift;
$s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
return $s;
}
*unescape_chars = \&unhexify;
sub unescape_full {
my $url = shift;
$url =~ tr/+/ /;
$url =~ s/<!--.*?-->//sg;
return unhexify($url);
}
## UNEVAL
# Returns a string representation of an anonymous array, hash, or scaler
# that can be eval'ed to produce the same value.
# uneval([1, 2, 3, [4, 5]]) -> '[1,2,3,[4,5,],]'
# Uses either Storable::freeze or Data::Dumper::DumperX or uneval
# in
sub uneval_it {
my($o) = @_; # recursive
my($r, $s, $i, $key, $value);
local($^W) = 0;
$r = ref $o;
if (!$r) {
$o =~ s/([\\"\$@])/\\$1/g;
$s = '"' . $o . '"';
} elsif ($r eq 'ARRAY') {
$s = "[";
foreach $i (0 .. $#$o) {
$s .= uneval_it($o->[$i]) . ",";
}
$s .= "]";
} elsif ($r eq 'HASH') {
$s = "{";
while (($key, $value) = each %$o) {
$key =~ s/(['\\])/\\$1/g;
$s .= "'$key' => " . uneval_it($value) . ",";
}
$s .= "}";
} else {
$s = "'something else'";
}
$s;
}
use subs 'uneval_fast';
sub uneval_it_file {
my ($ref, $fn) = @_;
open(UNEV, ">$fn")
or die "Can't create $fn: $!\n";
print UNEV uneval_fast($ref);
close UNEV;
}
sub eval_it_file {
my ($fn) = @_;
local($/) = undef;
open(UNEV, "< $fn") or return undef;
my $ref = evalr(<UNEV>);
close UNEV;
return $ref;
}
# See if we have Storable and the user has OKed its use
# If so, session storage/write will be about 5x faster
eval {
die unless $ENV{MINIVEND_STORABLE};
require Storable;
import Storable 'freeze';
if ($ENV{MINIVEND_STORABLE_CODE}) {
# allow code references to be stored to the session
$Storable::Deparse = 1;
$Storable::Eval = 1;
}
$Fast_uneval = \&Storable::freeze;
$Fast_uneval_file = \&Storable::store;
$Eval_routine = \&Storable::thaw;
$Eval_routine_file = \&Storable::retrieve;
};
# See if Data::Dumper is installed with XSUB
# If it is, session writes will be about 25-30% faster
eval {
die if $ENV{MINIVEND_NO_DUMPER};
require Data::Dumper;
import Data::Dumper 'DumperX';
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
$Data::Dumper::Deepcopy = 1;
if(defined $Fast_uneval) {
$Pretty_uneval = \&Data::Dumper::Dumper;
}
else {
$Pretty_uneval = \&Data::Dumper::DumperX;
$Fast_uneval = \&Data::Dumper::DumperX
}
};
*uneval_fast = defined $Fast_uneval ? $Fast_uneval : \&uneval_it;
*evalr = defined $Eval_routine ? $Eval_routine : sub { eval shift };
*eval_file = defined $Eval_routine_file ? $Eval_routine_file : \&eval_it_file;
*uneval_file = defined $Fast_uneval_file ? $Fast_uneval_file : \&uneval_it_file;
*uneval = defined $Pretty_uneval ? $Pretty_uneval : \&uneval_it;
# Log data fields to a data file.
sub logData {
my($file,@msg) = @_;
my $prefix = '';
$file = ">>$file" unless $file =~ /^[|>]/;
my $msg = tabbed @msg;
eval {
unless($file =~ s/^[|]\s*//) {
# We have checked for beginning > or | previously
open(MVLOGDATA, $file) or die "open\n";
lockfile(\*MVLOGDATA, 1, 1) or die "lock\n";
seek(MVLOGDATA, 0, 2) or die "seek\n";
print(MVLOGDATA "$msg\n") or die "write to\n";
unlockfile(\*MVLOGDATA) or die "unlock\n";
}
else {
my (@args) = grep /\S/, Text::ParseWords::shellwords($file);
open(MVLOGDATA, "|-") || exec @args;
print(MVLOGDATA "$msg\n") or die "pipe to\n";
}
close(MVLOGDATA) or die "close\n";
};
if ($@) {
if($::Limit->{logdata_error_length} > 0) {
$msg = substr($msg, 0, $::Limit->{logdata_error_length});
}
logError ("Could not %s log file '%s': %s\nto log this data:\n%s",
$@,
$file,
$!,
$msg,
);
return 0;
}
1;
}
sub quoted_comma_string {
my ($text) = @_;
my (@fields);
push(@fields, $+) while $text =~ m{
"([^\"\\]*(?:\\.[^\"\\]*)*)"[\s,]? ## std quoted string, w/possible space-comma
| ([^\s,]+)[\s,]? ## anything else, w/possible space-comma
| [,\s]+ ## any comma or whitespace
}gx;
@fields;
}
# Modified from old, old module called Ref.pm
sub copyref {
my($x,$r) = @_;
my($z, $y);
my $rt = ref $x;
if ($rt =~ /SCALAR/) {
# Would \$$x work?
$z = $$x;
return \$z;
} elsif ($rt =~ /HASH/) {
$r = {} unless defined $r;
for $y (sort keys %$x) {
$r->{$y} = &copyref($x->{$y}, $r->{$y});
}
return $r;
} elsif ($rt =~ /ARRAY/) {
$r = [] unless defined $r;
for ($y = 0; $y <= $#{$x}; $y++) {
$r->[$y] = &copyref($x->[$y]);
}
return $r;
} elsif ($rt =~ /REF/) {
$z = &copyref($x);
return \$z;
} elsif (! $rt) {
return $x;
} else {
die "do not know how to copy $x";
}
}
sub check_gate {
my($f, $gatedir) = @_;
my $gate;
if ($gate = readfile("$gatedir/.access_gate") ) {
$f =~ s:.*/::;
$gate = Vend::Interpolate::interpolate_html($gate);
if($gate =~ m!^$f(?:\.html?)?[ \t]*:!m ) {
$gate =~ s!.*(\n|^)$f(?:\.html?)?[ \t]*:!!s;
$gate =~ s/\n[\S].*//s;
$gate =~ s/^\s+//;
}
elsif($gate =~ m{^\*(?:\.html?)?[: \t]+(.*)}m) {
$gate = $1;
}
else {
undef $gate;
}
}
return $gate;
}
sub string_to_ref {
my ($string) = @_;
if($MVSAFE::Safe) {
return eval $string;
}
my $safe = $Vend::Interpolate::safe_safe || new Vend::Safe;
return $safe->reval($string);
}
sub is_hash {
return ref($_[0]) eq 'HASH';
}
# Verify that passed string is a valid IPv4 address.
sub is_ipv4 {
my $addr = shift or return;
my @segs = split '.', $addr;
return unless @segs == 4;
foreach (@segs) {
return unless /^\d{1,3}$/ && !/^0\d/;
return unless $_ <= 255;
}
return 1;
}
# Verify that passed string is a valid IPv6 address.
sub is_ipv6 {
my $addr = shift or return;
my @segs = split ':', $addr;
my $quads = 8;
# Check for IPv4 style ending
if ($segs[-1] =~ /\./) {
return unless is_ipv4(pop @segs);
$quads = 6;
}
# Check the special case of the :: abbreviation.
if ($addr =~ /::/) {
# Three :'s together is wrong, though.
return if $addr =~ /:::/;
# Also only one set of :: is allowed.
return if $addr =~ /::.*::/;
# Check that we don't have too many quads.
return if @segs >= $quads;
}
else {
# No :: abbreviation, so the number of quads must be exact.
return unless @segs == $quads;
}
# Check the validity of each quad
foreach (@segs) {
return unless /^[0-9a-f]{1,4}$/i;
}
return 1;
}
sub dotted_hash {
my($hash, $key, $value, $delete_empty) = @_;
$hash = get_option_hash($hash) unless is_hash($hash);
unless (is_hash($hash)) {
return undef unless defined $value;
$hash = {};
}
my @keys = split /[\.:]+/, $key;
my $final;
my $ref;
if(! defined $value) {
# Retrieving
$ref = $hash->{shift @keys};
for(@keys) {
return undef unless is_hash($ref);
$ref = $ref->{$_};
}
return $ref;
}
# Storing
$final = pop @keys;
$ref = $hash;
for(@keys) {
$ref->{$_} = {} unless is_hash($ref->{$_});
$ref = $ref->{$_};
}
if($delete_empty and ! length($value)) {
delete $ref->{$final};
}
else {
$ref->{$final} = $value;
}
$hash = uneval_it($hash);
return $hash;
}
sub get_option_hash {
my $string = shift;
my $merge = shift;
if (ref $string eq 'HASH') {
my $ref = { %$string };
return $ref unless ref $merge;
for(keys %{$merge}) {
$ref->{$_} = $merge->{$_}
unless defined $ref->{$_};
}
return $ref;
}
return {} unless $string and $string =~ /\S/;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
if($string =~ /^{/ and $string =~ /}/) {
return string_to_ref($string);
}
my @opts;
unless ($string =~ /,/) {
@opts = grep $_ ne "=", Text::ParseWords::shellwords($string);
for(@opts) {
s/^(\w[-\w]*\w)=(["'])(.*)\2$/$1$3/;
}
}
else {
@opts = split /\s*,\s*/, $string;
}
my %hash;
for(@opts) {
my ($k, $v) = split /[\s=]+/, $_, 2;
$k =~ s/-/_/g;
$hash{$k} = $v;
}
if($merge) {
return \%hash unless ref $merge;
for(keys %$merge) {
$hash{$_} = $merge->{$_}
unless defined $hash{$_};
}
}
return \%hash;
}
sub word2ary {
my $val = shift;
return $val if ref($val) eq 'ARRAY';
my @ary = grep /\w/, split /[\s,\0]+/, $val;
return \@ary;
}
sub ary2word {
my $val = shift;
return $val if ref($val) ne 'ARRAY';
@$val = grep /\w/, @$val;
return join " ", @$val;
}
## Takes an IC scalar form value (parm=val\nparm2=val) and translates it
## to a reference
sub scalar_to_hash {
my $val = shift;
$val =~ s/^\s+//mg;
$val =~ s/\s+$//mg;
my @args;
@args = split /\n+/, $val;
my $ref = {};
for(@args) {
m!([^=]+)=(.*)!
and $ref->{$1} = $2;
}
return $ref;
}
## Takes a form reference (i.e. from \%CGI::values) and makes into a
## scalar value value (i.e. parm=val\nparm2=val). Also translates it
## via HTML entities -- it is designed to make it into a hidden
## form value
sub hash_to_scalar {
my $ref = shift
or return '';
unless (ref($ref) eq 'HASH') {
die __PACKAGE__ . " hash_to_scalar routine got bad reference.\n";
}
my @parms;
while( my($k, $v) = each %$ref ) {
$v =~ s/\r?\n/\r/g;
push @parms, HTML::Entities::encode("$k=$v");
}
return join "\n", @parms;
}
## This simply returns a hash of words, which may be quoted shellwords
## Replaces most of parse_hash in Vend::Config
sub hash_string {
my($settings, $ref) = @_;
return $ref if ! $settings or $settings !~ /\S/;
$ref ||= {};
$settings =~ s/^\s+//;
$settings =~ s/\s+$//;
my(@setting) = Text::ParseWords::shellwords($settings);
my $i;
for ($i = 0; $i < @setting; $i += 2) {
$ref->{$setting[$i]} = $setting[$i + 1];
}
return $ref;
}
## READIN
my $Lang;
sub find_locale_bit {
my $text = shift;
unless (defined $Lang) {
$Lang = $::Scratch->{mv_locale} || $Vend::Cfg->{DefaultLocale};
}
$text =~ m{\[$Lang\](.*)\[/$Lang\]}s
and return $1;
$text =~ s{\[(\w+)\].*\[/\1\].*}{}s;
return $text;
}
sub parse_locale {
my ($input) = @_;
return if $::Pragma->{no_locale_parse};
# avoid copying big strings
my $r = ref($input) ? $input : \$input;
if($Vend::Cfg->{Locale}) {
my $key;
$$r =~ s~\[L(\s+([^\]]+))?\]((?s:.)*?)\[/L\]~
$key = $2 || $3;
defined $Vend::Cfg->{Locale}{$key}
? ($Vend::Cfg->{Locale}{$key}) : $3 ~eg;
$$r =~ s~\[LC\]((?s:.)*?)\[/LC\]~
find_locale_bit($1) ~eg;
undef $Lang;
}
else {
$$r =~ s~\[L(?:\s+[^\]]+)?\]((?s:.)*?)\[/L\]~$1~g;
}
# return scalar string if one get passed initially
return ref($input) ? $input : $$r;
}
sub teleport_name {
my ($file, $teleport, $table) = @_;
my $db;
return $file
unless $teleport
and $db = Vend::Data::database_exists_ref($table);
my @f = qw/code base_code expiration_date show_date page_text/;
my ($c, $bc, $ed, $sd, $pt) = @{$Vend::Cfg->{PageTableMap}}{@f};
my $q = qq{
SELECT $c from $table
WHERE $bc = '$file'
AND $ed < $teleport
AND $sd >= $teleport
ORDER BY $sd DESC
};
my $ary = $db->query($q);
if($ary and $ary->[0]) {
$file = $ary->[0][0];
}
return $file;
}
# Reads in a page from the page directory with the name FILE and ".html"
# appended. If the HTMLsuffix configuration has changed (because of setting in
# catalog.cfg or Locale definitions) it will substitute that. Returns the
# entire contents of the page, or undef if the file could not be read.
# Substitutes Locale bits as necessary.
sub readin {
my($file, $only, $locale) = @_;
## We don't want to try if we are forcing a flypage
return undef if $Vend::ForceFlypage;
my($fn, $contents, $gate, $pathdir, $dir, $level);
local($/);
if($file =~ m{[\[<]}) {
::logGlobal("Possible code/SQL injection attempt with file name '%s'", $file);
$file = escape_chars($file);
::logGlobal("Suspect file changed to '%s'", $file);
}
$Global::Variable->{MV_PREV_PAGE} = $Global::Variable->{MV_PAGE}
if defined $Global::Variable->{MV_PAGE};
$Global::Variable->{MV_PAGE} = $file;
$file =~ s#^\s+##;
$file =~ s#\s+$##;
$file =~ s#\.html?$##;
if($file =~ m{\.\.} and $file =~ /\.\..*\.\./) {
logError( "Too many .. in file path '%s' for security.", $file );
$file = find_special_page('violation');
}
if(index($file, '/') < 0) {
$pathdir = '';
}
else {
$file =~ s#//+#/#g;
$file =~ s#/+$##g;
($pathdir = $file) =~ s#/[^/]*$##;
$pathdir =~ s:^/+::;
}
my $try;
my $suffix = $Vend::Cfg->{HTMLsuffix};
my $db_tried;
$locale = 1 unless defined $locale;
my $record;
FINDPAGE: {
## If PageTables is set, we try to find the page in the table first
## but only once, without the suffix
if(! $db_tried++ and $Vend::Cfg->{PageTables}) {
my $teleport = $Vend::Session->{teleport};
my $field = $Vend::Cfg->{PageTableMap}{page_text};
foreach my $t (@{$Vend::Cfg->{PageTables}}) {
my $db = Vend::Data::database_exists_ref($t);
next unless $db;
if($teleport) {
$file = teleport_name($file, $teleport, $t);
}
$record = $db->row_hash($file)
or next;
$contents = $record->{$field};
last FINDPAGE if length $contents;
undef $contents;
}
}
my @dirs = ($Vend::Cfg->{PreviewDir},
$Vend::Cfg->{PageDir},
@{$Vend::Cfg->{TemplateDir} || []},
@{$Global::TemplateDir || []});
foreach $try (@dirs) {
next unless $try;
$dir = $try . "/" . $pathdir;
if (-f "$dir/.access") {
if (-s _) {
$level = 3;
}
else {
$level = '';
}
if(-f "$dir/.autoload") {
my $status = ::interpolate_html( readfile("$dir/.autoload") );
$status =~ s/\s+//g;
undef $level if $status;
}
$gate = check_gate($file,$dir)
if defined $level;
}
if( defined $level and ! check_security($file, $level, $gate) ){
my $realm = $::Variable->{COMPANY} || $Vend::Cat;
if(-f "$try/violation$suffix") {
$fn = "$try/violation$suffix";
}
else {
$file = find_special_page('violation');
$fn = $try . "/" . escape_chars($file) . $suffix;
}
}
else {
$fn = $try . "/" . escape_chars($file) . $suffix;
}
if (open(MVIN, "< $fn")) {
binmode(MVIN) if $Global::Windows;
binmode(MVIN, ":utf8") if $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
undef $/;
$contents = <MVIN>;
close(MVIN);
last;
}
last if defined $only;
}
if(! defined $contents) {
last FINDPAGE if $suffix eq '.html';
$suffix = '.html';
redo FINDPAGE;
}
}
if(! defined $contents) {
$contents = readfile_db("pages/$file");
}
return unless defined $contents;
parse_locale(\$contents);
return $contents unless wantarray;
return ($contents, $record);
}
sub is_yes {
return scalar( defined($_[0]) && ($_[0] =~ /^[yYtT1]/));
}
sub is_no {
return scalar( !defined($_[0]) || ($_[0] =~ /^[nNfF0]/));
}
# Returns a URL which will run the ordering system again. Each URL
# contains the session ID as well as a unique integer to avoid caching
# of pages by the browser.
my @scratches = qw/
add_dot_html
add_source
link_relative
match_security
no_count
no_session
/;
sub vendUrl {
my($path, $arguments, $r, $opt) = @_;
$opt ||= {};
if($opt->{auto_format}) {
return $path if $path =~ m{^/};
$path =~ s:#([^/.]+)$::
and $opt->{anchor} = $1;
$path =~ s/\.html?$//i
and $opt->{add_dot_html} = 1;
}
$r = $Vend::Cfg->{VendURL}
unless defined $r;
my $secure;
my @parms;
my %skip = qw/form 1 href 1 reparse 1/;
for(@scratches) {
next if defined $opt->{$_};
next unless defined $::Scratch->{"mv_$_"};
$skip{$_} = 1;
$opt->{$_} = $::Scratch->{"mv_$_"};
}
my $extra;
if($opt->{form}) {
$path = $Vend::Cfg->{ProcessPage} unless $path;
if($opt->{form} eq 'auto') {
my $form = '';
while( my ($k, $v) = each %$opt) {
next if $skip{$k};
$k =~ s/^__//;
$form .= "$k=$v\n";
}
$opt->{form} = $form;
}
push @parms, Vend::Interpolate::escape_form($opt->{form});
}
my($id, $ct);
$id = $Vend::SessionID
unless $opt->{no_session_id}
or ($Vend::Cookie and $::Scratch->{mv_no_session_id});
$ct = ++$Vend::Session->{pageCount}
unless $opt->{no_count};
if($opt->{no_session} or $::Pragma->{url_no_session_id}) {
undef $id;
undef $ct;
}
if($opt->{link_relative}) {
my $cur = $Global::Variable->{MV_PAGE};
$cur =~ s{/[^/]+$}{}
and $path = "$cur/$path";
}
if($opt->{match_security}) {
$opt->{secure} = $CGI::secure;
}
if($opt->{secure} or exists $Vend::Cfg->{AlwaysSecure}{$path}) {
$r = $Vend::Cfg->{SecureURL};
}
$path = escape_chars_url($path)
if $path =~ $need_escape;
$r .= '/' . $path;
$r .= '.html' if $opt->{add_dot_html} and $r !~ m{(?:/|\.html?)$};
if($opt->{add_source} and $Vend::Session->{source}) {
my $sn = hexify($Vend::Session->{source});
push @parms, "$::VN->{mv_source}=$sn";
}
push @parms, "$::VN->{mv_session_id}=$id" if $id;
push @parms, "$::VN->{mv_arg}=" . hexify($arguments) if defined $arguments;
push @parms, "$::VN->{mv_pc}=$ct" if $ct;
push @parms, "$::VN->{mv_cat}=$Vend::Cat" if $Vend::VirtualCat;
$r .= '?' . join($Global::UrlJoiner, @parms) if @parms;
if($opt->{anchor}) {
$opt->{anchor} =~ s/^#//;
$r .= '#' . $opt->{anchor};
}
# return full-path portion of the URL
if ($opt->{path_only}) {
$r =~ s!^https?://[^/]*!!i;
}
return $r;
}
sub secure_vendUrl {
return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL}, $_[3]);
}
my %strip_vars;
my $strip_init;
sub change_url {
my $url = shift;
return $url if $url =~ m{^\w+:};
return $url if $url =~ m{^/};
if(! $strip_init) {
for(qw/mv_session_id mv_pc/) {
$strip_vars{$_} = 1;
$strip_vars{$::IV->{$_}} = 1;
}
}
my $arg;
my @args;
($url, $arg) = split /[?&]/, $url, 2;
@args = grep ! $strip_vars{$_}, split $Global::UrlSplittor, $arg;
return Vend::Interpolate::tag_area( $url, '', {
form => join "\n", @args,
} );
}
sub resolve_links {
my $html = shift;
$html =~ s/(<a\s+[^>]*href\s*=\s*)(["'])([^'"]+)\2/$1 . $2 . change_url($3) . $2/gei;
return $html;
}
### flock locking
# sys/file.h:
my $flock_LOCK_SH = 1; # Shared lock
my $flock_LOCK_EX = 2; # Exclusive lock
my $flock_LOCK_NB = 4; # Don't block when locking
my $flock_LOCK_UN = 8; # Unlock
# Returns the total number of items ordered.
# Uses the current cart if none specified.
sub tag_nitems {
my($ref, $opt) = @_;
my($cart, $total, $item);
if($ref) {
$cart = $::Carts->{$ref}
or return 0;
}
else {
$cart = $Vend::Items;
}
my ($attr, $sub);
if($opt->{qualifier}) {
$attr = $opt->{qualifier};
my $qr;
eval {
$qr = qr{$opt->{compare}} if $opt->{compare};
};
if($qr) {
$sub = sub {
$_[0] =~ $qr;
};
}
else {
$sub = sub { return $_[0] };
}
}
if($opt->{lines}) {
return scalar(grep {! $attr or $sub->($_->{$attr})} @$cart);
}
$total = 0;
foreach $item (@$cart) {
next if $attr and ! $sub->($item->{$attr});
if ($opt->{gift_cert} && $item->{$opt->{gift_cert}}) {
$total++;
next;
}
$total += $item->{'quantity'};
}
$total;
}
sub dump_structure {
my ($ref, $name) = @_;
my $save;
$name =~ s/\.cfg$//;
$name .= '.structure';
open(UNEV, ">$name") or die "Couldn't write structure $name: $!\n";
local($Data::Dumper::Indent);
$Data::Dumper::Indent = 2;
print UNEV uneval($ref);
close UNEV;
}
# Do an internal HTTP authorization check
sub check_authorization {
my($auth, $pwinfo) = @_;
$auth =~ s/^\s*basic\s+//i or return undef;
my ($user, $pw) = split(
":",
MIME::Base64::decode_base64($auth),
2,
);
my $cmp_pw;
my $use_crypt = 1;
if( $user eq $Vend::Cfg->{RemoteUser} and
$Vend::Cfg->{Password} )
{
$cmp_pw = $Vend::Cfg->{Password};
undef $use_crypt if $::Variable->{MV_NO_CRYPT};
}
else {
$pwinfo = $Vend::Cfg->{UserDatabase} unless $pwinfo;
undef $use_crypt if $::Variable->{MV_NO_CRYPT};
$cmp_pw = Vend::Interpolate::tag_data($pwinfo, 'password', $user)
if defined $Vend::Cfg->{Database}{$pwinfo};
}
return undef unless $cmp_pw;
if(! $use_crypt) {
return $user if $pw eq $cmp_pw;
}
else {
my $test = crypt($pw, $cmp_pw);
return $user
if $test eq $cmp_pw;
}
return undef;
}
# Check that the user is authorized by one or all of the
# configured security checks
sub check_security {
my($item, $reconfig, $gate) = @_;
my $msg;
if(! $reconfig) {
# If using the new USERDB access control you may want to remove this next line
# for anyone with an HTTP basic auth will have access to everything
#return 1 if $CGI::user and ! $Global::Variable->{MV_USERDB};
if($gate) {
$gate =~ s/\s+//g;
return 1 if is_yes($gate);
}
elsif($Vend::Session->{logged_in}) {
return 1 if $::Variable->{MV_USERDB_REMOTE_USER};
my $db;
my $field;
if ($db = $::Variable->{MV_USERDB_ACL_TABLE}) {
$field = $::Variable->{MV_USERDB_ACL_COLUMN};
my $access = Vend::Data::database_field(
$db,
$Vend::Session->{username},
$field,
);
return 1 if $access =~ m{(^|\s)$item(\s|$)};
}
}
if($Vend::Cfg->{UserDB} and $Vend::Cfg->{UserDB}{log_failed}) {
my $besthost = $CGI::remote_host || $CGI::remote_addr;
logError("auth error host=%s ip=%s script=%s page=%s",
$besthost,
$CGI::remote_addr,
$CGI::script_name,
$CGI::path_info,
);
}
return '';
}
elsif($reconfig eq '1') {
$msg = 'reconfigure catalog';
}
elsif ($reconfig eq '2') {
$msg = "access protected database $item";
return 1 if is_yes($gate);
}
elsif ($reconfig eq '3') {
$msg = "access administrative function $item";
}
# Check if host IP is correct when MasterHost is set to something
if ( $Vend::Cfg->{MasterHost}
and
( $CGI::remote_host !~ /^($Vend::Cfg->{MasterHost})$/
and
$CGI::remote_addr !~ /^($Vend::Cfg->{MasterHost})$/ ) )
{
my $fmt = <<'EOF';
ALERT: Attempt to %s at %s from:
REMOTE_ADDR %s
REMOTE_USER %s
USER_AGENT %s
SCRIPT_NAME %s
PATH_INFO %s
EOF
logGlobal({ level => 'warning' },
$fmt,
$msg,
$CGI::script_name,
$CGI::host,
$CGI::user,
$CGI::useragent,
$CGI::script_name,
$CGI::path_info,
);
return '';
}
# Check to see if password enabled, then check
if (
$reconfig eq '1' and
!$CGI::user and
$Vend::Cfg->{Password} and
crypt($CGI::reconfigure_catalog, $Vend::Cfg->{Password})
ne $Vend::Cfg->{Password})
{
::logGlobal(
{ level => 'warning' },
"ALERT: Password mismatch, attempt to %s at %s from %s",
$msg,
$CGI::script_name,
$CGI::host,
);
return '';
}
# Finally check to see if remote_user match enabled, then check
if ($Vend::Cfg->{RemoteUser} and
$CGI::user ne $Vend::Cfg->{RemoteUser})
{
my $fmt = <<'EOF';
ALERT: Attempt to %s %s per user name:
REMOTE_HOST %s
REMOTE_ADDR %s
REMOTE_USER %s
USER_AGENT %s
SCRIPT_NAME %s
PATH_INFO %s
EOF
::logGlobal(
{ level => 'warning' },
$fmt,
$CGI::script_name,
$msg,
$CGI::remote_host,
$CGI::remote_addr,
$CGI::user,
$CGI::useragent,
$CGI::script_name,
$CGI::path_info,
);
return '';
}
# Don't allow random reconfigures without one of the three checks
unless ($Vend::Cfg->{MasterHost} or
$Vend::Cfg->{Password} or
$Vend::Cfg->{RemoteUser})
{
my $fmt = <<'EOF';
Attempt to %s on %s, secure operations disabled.
REMOTE_ADDR %s
REMOTE_USER %s
USER_AGENT %s
SCRIPT_NAME %s
PATH_INFO %s
EOF
::logGlobal(
{ level => 'warning' },
$fmt,
$msg,
$CGI::script_name,
$CGI::host,
$CGI::user,
$CGI::useragent,
$CGI::script_name,
$CGI::path_info,
);
return '';
}
# Authorized if got here
return 1;
}
# Checks the Locale for a special page definintion mv_special_$key and
# returns it if found, otherwise goes to the default Vend::Cfg->{Special} array
sub find_special_page {
my $key = shift;
my $dir = '';
$dir = "../$Vend::Cfg->{SpecialPageDir}/"
if $Vend::Cfg->{SpecialPageDir};
return $Vend::Cfg->{Special}{$key} || "$dir$key";
}
## ERROR
# Log the error MSG to the error file.
sub logDebug {
return unless $Global::DebugFile;
if(my $re = $Vend::Cfg->{DebugHost}) {
return unless
Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
}
if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
return unless $sub->();
}
my $msg;
if (my $tpl = $Global::DebugTemplate) {
my %debug;
$tpl = POSIX::strftime($tpl, localtime());
$tpl =~ s/\s*$//;
$debug{page} = $Global::Variable->{MV_PAGE};
$debug{tag} = $Vend::CurrentTag;
$debug{host} = $CGI::host || $CGI::remote_addr;
$debug{remote_addr} = $CGI::remote_addr;
$debug{catalog} = $Vend::Cat;
if($tpl =~ /\{caller\d+\}/i) {
my @caller = caller();
for(my $i = 0; $i < @caller; $i++) {
$debug{"caller$i"} = $caller[$i];
}
}
$debug{message} = errmsg(@_);
$msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
}
else {
$msg = caller() . ":debug: " . errmsg(@_);
}
if ($Global::SysLog) {
logGlobal({ level => 'debug' }, $msg);
}
else {
print $msg, "\n";
}
return;
}
sub errmsg {
my($fmt, @strings) = @_;
my $location;
if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
$location = $Vend::Cfg->{Locale};
}
elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
$location = $Global::Locale;
}
if($location) {
if(ref $location->{$fmt}) {
$fmt = $location->{$fmt}[0];
@strings = @strings[ @{ $location->{$fmt}[1] } ];
}
else {
$fmt = $location->{$fmt};
}
}
return scalar(@strings) ? sprintf $fmt, @strings : $fmt;
}
*l = \&errmsg;
sub show_times {
my $message = shift || 'time mark';
my @times = times();
for( my $i = 0; $i < @times; $i++) {
$times[$i] -= $Vend::Times[$i];
}
logDebug("$message: " . join " ", @times);
}
# This %syslog_constant_map is an attempt to work around a strange problem
# where the eval inside &Sys::Syslog::xlate fails, which then croaks.
# The cause of this freakish problem is still to be determined.
my %syslog_constant_map;
sub setup_syslog_constant_map {
for (
(map { "local$_" } (0..7)),
qw(
auth
authpriv
cron
daemon
ftp
kern
lpr
mail
news
syslog
user
uucp
emerg
alert
crit
err
warning
notice
info
debug
)
) {
$syslog_constant_map{$_} = Sys::Syslog::xlate($_);
}
return;
}
sub logGlobal {
return 1 if $Vend::ExternalProgram;
my $opt;
my $msg = shift;
if (ref $msg) {
$opt = $msg;
$msg = shift;
}
else {
$opt = {};
}
$msg = errmsg($msg, @_) if @_;
$Vend::Errors .= $msg . "\n" if $Global::DisplayErrors;
my $nl = $opt->{strip} ? '' : "\n";
print "$msg$nl"
if $Global::Foreground
and ! $Vend::Log_suppress
and ! $Vend::Quiet
and ! $Global::SysLog;
my ($fn, $facility, $level);
if ($Global::SysLog) {
$facility = $Global::SysLog->{facility} || 'local3';
$level = $opt->{level} || 'info';
# remap deprecated synonyms supported by logger(1)
my %level_map = (
error => 'err',
panic => 'emerg',
warn => 'warning',
);
# remap levels according to any user-defined global configuration
my $level_cfg;
if ($level_cfg = $Global::SysLog->{$level_map{$level} || $level}) {
if ($level_cfg =~ /(.+)\.(.+)/) {
($facility, $level) = ($1, $2);
}
else {
$level = $level_cfg;
}
}
$level = $level_map{$level} if $level_map{$level};
my $tag = $Global::SysLog->{tag} || 'interchange';
my $socket = $opt->{socket} || $Global::SysLog->{socket};
if ($Global::SysLog->{internal}) {
unless ($Vend::SysLogReady) {
eval {
use Sys::Syslog ();
if ($socket) {
my ($socket_path, $types) = ($socket =~ /^(\S+)(?:\s+(.*))?/);
$types ||= 'native,tcp,udp,unix,pipe,stream,console';
my $type_array = [ grep /\S/, split /[,\s]+/, $types ];
Sys::Syslog::setlogsock($type_array, $socket_path) or die "Error calling setlogsock\n";
}
Sys::Syslog::openlog $tag, 'ndelay,pid', $facility;
};
if ($@) {
print "\nError opening syslog: $@\n";
print "to report this error:\n", $msg;
exit 1;
}
setup_syslog_constant_map() unless %syslog_constant_map;
$Vend::SysLogReady = 1;
}
}
else {
$fn = '|' . ($Global::SysLog->{command} || 'logger');
$fn .= " -p $facility.$level";
$fn .= " -t $tag" unless lc($tag) eq 'none';
$fn .= " -u $socket" if $socket;
}
}
else {
$fn = $Global::ErrorFile;
}
if ($fn) {
my $lock;
if ($fn =~ s/^([^|>])/>>$1/) {
$lock = 1;
$msg = format_log_msg($msg);
}
eval {
# We have checked for beginning > or | previously
open(MVERROR, $fn) or die "open\n";
if ($lock) {
lockfile(\*MVERROR, 1, 1) or die "lock\n";
seek(MVERROR, 0, 2) or die "seek\n";
}
print(MVERROR $msg, "\n") or die "write to\n";
if ($lock) {
unlockfile(\*MVERROR) or die "unlock\n";
}
close(MVERROR) or die "close\n";
};
if ($@) {
chomp $@;
print "\nCould not $@ error file '$Global::ErrorFile':\n$!\n";
print "to report this error:\n", $msg, "\n";
exit 1;
}
}
elsif ($Vend::SysLogReady) {
eval {
# avoid eval in Sys::Syslog::xlate() by using cached constants where possible
my $level_mapped = $syslog_constant_map{$level};
$level_mapped = $level unless defined $level_mapped;
my $facility_mapped = $syslog_constant_map{$facility};
$facility_mapped = $facility unless defined $facility_mapped;
my $priority = "$level_mapped|$facility_mapped";
Sys::Syslog::syslog $priority, $msg;
};
}
return 1;
}
sub logError {
return unless $Vend::Cfg;
my $msg = shift;
my $opt;
if (ref $_[0]) {
$opt = shift;
}
else {
$opt = {};
}
unless ($Global::SysLog) {
if (! $opt->{file}) {
my $tag = $opt->{tag} || $msg;
if (my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) {
$opt->{file} = $dest;
}
}
$opt->{file} ||= $Vend::Cfg->{ErrorFile};
}
$msg = errmsg($msg, @_) if @_;
print "$msg\n"
if $Global::Foreground
and ! $Vend::Log_suppress
and ! $Vend::Quiet
and ! $Global::SysLog;
$Vend::Session->{last_error} = $msg;
$msg = format_log_msg($msg) unless $msg =~ s/^\\//;
if ($Global::SysLog) {
logGlobal({ level => 'err' }, $msg);
return;
}
$Vend::Errors .= $msg . "\n"
if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors;
my $reason;
if (! allowed_file($opt->{file}, 1)) {
$@ = 'access';
$reason = 'prohibited by global configuration';
}
else {
eval {
open(MVERROR, '>>', $opt->{file})
or die "open\n";
lockfile(\*MVERROR, 1, 1) or die "lock\n";
seek(MVERROR, 0, 2) or die "seek\n";
print(MVERROR $msg, "\n") or die "write to\n";
unlockfile(\*MVERROR) or die "unlock\n";
close(MVERROR) or die "close\n";
};
}
if ($@) {
chomp $@;
logGlobal ({ level => 'info' },
"Could not %s error file %s: %s\nto report this error: %s",
$@,
$opt->{file},
$reason || $!,
$msg,
);
}
return;
}
# Front-end to log routines that ignores repeated identical
# log messages after the first occurrence
my %logOnce_cache;
my %log_sub_map = (
data => \&logData,
debug => \&logDebug,
error => \&logError,
global => \&logGlobal,
);
# First argument should be log type (see above map).
# Rest of arguments are same as if calling log routine directly.
sub logOnce {
my $tag = join "", @_;
return if exists $logOnce_cache{$tag};
my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error};
my $status = $log_sub->(@_);
$logOnce_cache{$tag} = 1;
return $status;
}
# Here for convenience in calls
sub set_cookie {
my ($name, $value, $expire, $domain, $path, $secure) = @_;
# Set expire to now + some time if expire string is something like
# "30 days" or "7 weeks" or even "60 minutes"
if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
$expire = adjust_time($expire);
}
if (! $::Instance->{Cookies}) {
$::Instance->{Cookies} = []
}
else {
@{$::Instance->{Cookies}} =
grep $_->[0] ne $name, @{$::Instance->{Cookies}};
}
push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
return;
}
# Here for convenience in calls
sub read_cookie {
my ($lookfor, $string) = @_;
$string = $CGI::cookie
unless defined $string;
return cookies_hash($string) unless defined $lookfor && length($lookfor);
return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
return unescape_chars($1);
}
sub cookies_hash {
my $string = shift || $CGI::cookie;
my %cookies = map {
my ($k,$v) = split '=', $_, 2;
$k => unescape_chars($v)
} split(/;\s*/, $string);
return \%cookies;
}
sub send_mail {
my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
if(ref $to) {
my $head = $to;
for(my $i = $#$head; $i > 0; $i--) {
if($head->[$i] =~ /^\s/) {
my $new = splice @$head, $i, 1;
$head->[$i - 1] .= "\n$new";
}
}
$body = $subject;
undef $subject;
for(@$head) {
s/\s+$//;
if (/^To:\s*(.+)/si) {
$to = $1;
}
elsif (/^Reply-to:\s*(.+)/si) {
$reply = $1;
}
elsif (/^subj(?:ect)?:\s*(.+)/si) {
$subject = $1;
}
elsif($_) {
push @extra_headers, $_;
}
}
}
# If configured, intercept all outgoing email and re-route
if (
my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
|| $Global::Variable->{MV_EMAIL_INTERCEPT}
) {
my @info_headers;
$to = "To: $to";
for ($to, @extra_headers) {
next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
logError(
"Intercepting outgoing email (%s: %s) and instead sending to '%s'",
$header, $value, $intercept
);
$_ = "$header: $intercept";
push @info_headers, "X-Intercepted-$header: $value";
}
$to =~ s/^To: //;
push @extra_headers, @info_headers;
}
my($ok);
#::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
unless (defined $use_mime) {
$use_mime = $::Instance->{MIME} || undef;
}
if(!defined $reply) {
$reply = $::Values->{mv_email}
? "Reply-To: $::Values->{mv_email}\n"
: '';
}
elsif ($reply) {
$reply = "Reply-To: $reply\n"
unless $reply =~ /^reply-to:/i;
$reply =~ s/\s+$/\n/;
}
$ok = 0;
my $none;
my $using = $Vend::Cfg->{SendMailProgram};
if($using =~ /^(none|Net::SMTP)$/i) {
$none = 1;
$ok = 1;
}
SEND: {
#::logDebug("testing sendmail send none=$none");
last SEND if $none;
#::logDebug("in Sendmail send $using");
open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
my $mime = '';
$mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
or last SEND;
for(@extra_headers) {
s/\s*$/\n/;
print MVMAIL $_
or last SEND;
}
$mime =~ s/\s*$/\n/;
print MVMAIL $mime
or last SEND;
print MVMAIL $body
or last SEND;
print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
if $use_mime;
print MVMAIL "\r\n\cZ" if $Global::Windows;
close MVMAIL or last SEND;
$ok = ($? == 0);
}
SMTP: {
my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
my $helo = $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
last SMTP unless $none and $mhost;
eval {
require Net::SMTP;
};
last SMTP if $@;
$ok = 0;
$using = "Net::SMTP (mail server $mhost)";
#::logDebug("using $using");
undef $none;
my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP;
#::logDebug("smtp object $smtp");
my $from = $::Variable->{MV_MAILFROM}
|| $Global::Variable->{MV_MAILFROM}
|| $Vend::Cfg->{MailOrderTo};
for(@extra_headers) {
s/\s*$/\n/;
next unless /^From:\s*(\S.+)$/mi;
$from = $1;
}
push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
my $mime = '';
$mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
$smtp->mail($from)
or last SMTP;
#::logDebug("smtp accepted from=$from");
my @to;
my @addr = split /\s*,\s*/, $to;
for (@addr) {
if(/\s/) {
## Uh-oh. Try to handle
if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
push @to, $1
}
else {
logError("Net::SMTP sender skipping unparsable address %s", $_);
}
}
else {
push @to, $_;
}
}
@addr = $smtp->recipient(@to, { SkipBad => 1 });
if(scalar(@addr) != scalar(@to)) {
logError(
"Net::SMTP not able to send to all addresses of %s",
join(", ", @to),
);
}
#::logDebug("smtp accepted to=" . join(",", @addr));
$smtp->data();
push @extra_headers, $reply if $reply;
for ("To: $to", "Subject: $subject", @extra_headers) {
next unless $_;
s/\s*$/\n/;
#::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
$smtp->datasend($_)
or last SMTP;
}
if($use_mime) {
$mime =~ s/\s*$/\n/;
$smtp->datasend($mime)
or last SMTP;
}
$smtp->datasend("\n");
$smtp->datasend($body)
or last SMTP;
$smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
if $use_mime;
$smtp->dataend()
or last SMTP;
$ok = $smtp->quit();
}
if ($none or !$ok) {
logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
$using,
$to,
$subject,
$reply,
$body,
);
}
$ok;
}
sub codedef_routine {
my ($tag, $routine, $modifier) = @_;
my $area = $Vend::Config::tagCanon{lc $tag}
or do {
logError("Unknown CodeDef type %s", $tag);
return undef;
};
$routine =~ s/-/_/g;
my @tries;
if ($tag eq 'UserTag') {
@tries = ($Vend::Cfg->{UserTag}, $Global::UserTag);
}
else {
@tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area});
}
no strict 'refs';
my $ref;
for my $base (@tries) {
next unless $base;
$ref = $base->{Routine}{$routine}
and return $ref;
$ref = $base->{MapRoutine}{$routine}
and return \&{"$ref"};
}
return undef unless $Global::AccumulateCode;
#::logDebug("trying code_from file for area=$area routine=$routine");
$ref = Vend::Config::code_from_file($area, $routine)
or return undef;
#::logDebug("returning ref=$ref for area=$area routine=$routine");
return $ref;
}
sub codedef_options {
my ($tag, $modifier) = @_;
my @out;
my $empty;
my @keys = keys %{$Vend::Cfg->{CodeDef}};
push @keys, keys %{$Global::CodeDef};
my %gate = ( public => 1 );
my @mod = grep /\w/, split /[\s\0,]+/, $modifier;
for(@mod) {
if($_ eq 'all') {
$gate{private} = 1;
}
if($_ eq 'empty') {
$empty = ['', errmsg('--select--')];
}
if($_ eq 'admin') {
$gate{admin} = 1;
}
}
for(@keys) {
if(lc($tag) eq lc($_)) {
$tag = $_;
last;
}
}
my %seen;
for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) {
if(my $desc = $repos->{Description}) {
my $vis = $repos->{Visibility} || {};
my $help = $repos->{Help} || {};
while( my($k, $v) = each %$desc) {
next if $seen{$k}++;
if(my $perm = $vis->{$k}) {
if($perm =~ /^with\s+([\w:]+)/) {
my $mod = $1;
no strict 'refs';
next unless ${$mod . "::VERSION"};
}
else {
next unless $gate{$perm};
}
}
push @out, [$k, $v, $help->{$k}];
}
}
}
if(@out) {
@out = sort { $a->[1] cmp $b->[1] } @out;
unshift @out, $empty if $empty;
}
else {
push @out, ['', errmsg('--none--') ];
}
return \@out;
}
# Adds a timestamp to the end of a binary timecard file. You can specify the timestamp
# as the second arg (unixtime) or just leave it out (or undefined) and it will be set
# to the current time.
sub timecard_stamp {
my ($filename,$timestamp) = @_;
$timestamp ||= time;
open(FH, '>>', $filename) or die "Can't open $filename for append: $!";
lockfile(\*FH, 1, 1);
binmode FH;
print FH pack('N',time);
unlockfile(\*FH);
close FH;
}
# Reads a timestamp from a binary timecard file. If $index is negative indexes back from
# the end of the file, otherwise indexes from the front of the file so that 0 is the first
# (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if
# the file doesn't exist or the index falls outside of the bounds of the timecard file.
sub timecard_read {
my ($filename,$index) = @_;
$index *= 4;
my $limit = $index >= 0 ? $index + 4 : $index * -1;
if (-f $filename && (stat(_))[7] % 4) {
# The file is corrupt, delete it and start over.
::logError("Counter file $filename found to be corrupt, deleting.");
unlink($filename);
return;
}
return unless (-f _ && (stat(_))[7] > $limit);
# The file exists and is big enough to cover the $index. Seek to the $index
# and return the timestamp from that position.
open (FH, '<', $filename) or die "Can't open $filename for read: $!";
lockfile(\*FH, 0, 1);
binmode FH;
seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!";
my $rtime;
read(FH,$rtime,4) or die "Can't read from $filename: $!";
unlockfile(\*FH);
close FH;
return unpack('N',$rtime);
}
#
# Adjusts a unix time stamp (2nd arg) by the amount specified in the first arg. First arg should be
# a number (signed integer or float) followed by one of second(s), minute(s), hour(s), day(s)
# week(s) month(s) or year(s). Second arg defaults to the current time. If the third arg is true
# the time will be compensated for daylight savings time (so that an adjustment of 6 months will
# still cause the same time to be displayed, even if it is transgressing the DST boundary).
#
# This will accept multiple adjustments strung together, so you can do: "-5 days, 2 hours, 6 mins"
# and the time will have thost amounts subtracted from it. You can also add and subtract in the
# same line, "+2 years -3 days". If you specify a sign (+ or -) then that sign will remain in
# effect until a new sign is specified on the line (so you can do,
# "+5 years, 6 months, 3 days, -4 hours, 7 minutes"). The comma (,) between adjustments is
# optional.
#
sub adjust_time {
my ($adjust, $time, $compensate_dst) = @_;
$time ||= time;
unless ($adjust =~ /^(?:\s*[+-]?\s*[\d\.]+\s*[a-z]*\s*,?)+$/i) {
::logError("adjust_time(): bad format: $adjust");
return $time;
}
# @times: 0: sec, 1: min, 2: hour, 3: day, 4: month, 5: year, 8: isdst
# 6,7: dow and doy, but mktime ignores these (and so do we).
# A note about isdst: localtime returns 1 if returned time is adjusted for dst and 0 otherwise.
# mktime expects the same, but if this is set to -1 mktime will determine if the date should be
# dst adjusted according to dst rules for the current timezone. The way that we use this is we
# leave it set to the return value from locatime and we end up with a time that is adjusted by
# an absolute amount (so if you adjust by six months the actual time returned may be different
# but only because of DST). If we want mktime to compensate for dst then we set this to -1 and
# mktime will make the appropriate adjustment for us (either add one hour or subtract one hour
# or leave the time the same).
my @times = localtime($time);
my $sign = 1;
foreach my $amount ($adjust =~ /([+-]?\s*[\d\.]+\s*[a-z]*)/ig) {
my $unit = 'seconds';
$amount =~ s/\s+//g;
if ($amount =~ s/^([+-])//) { $sign = $1 eq '+' ? 1 : -1 }
if ($amount =~ s/([a-z]+)$//) { $unit = lc $1 }
$amount *= $sign;
# A week is simply 7 days.
if ($unit =~ /^w/) {
$unit = 'days';
$amount *= 7;
}
if ($unit =~ /^s/) { $times[0] += $amount }
elsif ($unit =~ /^mo/) { $times[4] += $amount } # has to come before min
elsif ($unit =~ /^m/) { $times[1] += $amount }
elsif ($unit =~ /^h/) { $times[2] += $amount }
elsif ($unit =~ /^d/) { $times[3] += $amount }
elsif ($unit =~ /^y/) { $times[5] += $amount }
else {
::logError("adjust_time(): bad unit: $unit");
return $time;
}
}
if ($compensate_dst) { $times[8] = -1 }
# mktime can only handle integers, so we need to convert real numbers:
my @multip = (0, 60, 60, 24, 0, 12);
my $monfrac = 0;
foreach my $i (reverse 0..5) {
if ($times[$i] =~ /\./) {
if ($multip[$i]) {
$times[$i-1] += ($times[$i] - int $times[$i]) * $multip[$i];
}
elsif ($i == 4) {
# Fractions of a month need some really extra special handling.
$monfrac = $times[$i] - int $times[$i];
}
$times[$i] = int $times[$i]
}
}
$time = POSIX::mktime(@times);
# This is how we handle a fraction of a month:
if ($monfrac) {
$times[4] += $monfrac > 0 ? 1 : -1;
my $timediff = POSIX::mktime(@times);
$timediff = int(abs($timediff - $time) * $monfrac);
$time += $timediff;
}
return $time;
}
sub backtrace {
my $msg = "Backtrace:\n\n";
my $frame = 1;
my $assertfile = '';
my $assertline = 0;
while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) {
$msg .= sprintf(" frame %d: $subroutine ($filename line $line)\n", $frame - 2);
if ($subroutine =~ /assert$/) {
$assertfile = $filename;
$assertline = $line;
}
}
if ($assertfile) {
open(SRC, $assertfile) and do {
my $line;
my $line_n = 0;
$msg .= "\nProblem in $assertfile line $assertline:\n\n";
while ($line = <SRC>) {
$line_n++;
$msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10);
}
close(SRC);
};
}
::logGlobal($msg);
undef;
}
sub header_data_scrub {
my ($head_data) = @_;
## "HTTP Response Splitting" Exploit Fix
## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html
$head_data =~ s/(?:%0[da]|[\r\n]+)+//ig;
return $head_data;
}
### Provide stubs for former Vend::Util functions relocated to Vend::File
*canonpath = \&Vend::File::canonpath;
*catdir = \&Vend::File::catdir;
*catfile = \&Vend::File::catfile;
*exists_filename = \&Vend::File::exists_filename;
*file_modification_time = \&Vend::File::file_modification_time;
*file_name_is_absolute = \&Vend::File::file_name_is_absolute;
*get_filename = \&Vend::File::get_filename;
*lockfile = \&Vend::File::lockfile;
*path = \&Vend::File::path;
*readfile = \&Vend::File::readfile;
*readfile_db = \&Vend::File::readfile_db;
*set_lock_type = \&Vend::File::set_lock_type;
*unlockfile = \&Vend::File::unlockfile;
*writefile = \&Vend::File::writefile;
1;
__END__
Jump to Line
Something went wrong with that request. Please try again.