Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
5771 lines (5104 sloc) 132 KB
# Vend::Config - Configure Interchange
#
# Copyright (C) 2002-2017 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::Config;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( config global_config config_named_catalog );
@EXPORT_OK = qw( get_catalog_default get_global_default parse_time parse_database);
use strict;
no warnings qw(uninitialized numeric);
use vars qw(
$VERSION $C
@Locale_directives_ary @Locale_directives_scalar
@Locale_directives_code %tagCanon
%ContainerSave %ContainerTrigger %ContainerSpecial %ContainerType
%Default
%Dispatch_code %Dispatch_priority
%Cleanup_code %Cleanup_priority
@Locale_directives_currency @Locale_keys_currency
$GlobalRead $SystemCodeDone $SystemGroupsDone $CodeDest
$SystemReposDone $ReposDest @include
);
use Config;
use Vend::Safe;
use Fcntl;
use Vend::Parse;
use Vend::Util;
use Vend::File;
use Vend::Data;
use Vend::Cron;
use Vend::CharSet ();
use Vend::CIDR qw(cidr2regex resembles_cidr);
$VERSION = '2.251';
my %CDname;
my %CPname;
%ContainerType = (
yesno => sub {
my ($var, $value, $end) = @_;
$var = $CDname{lc $var};
if($end) {
my $val = delete $ContainerSave{$var};
no strict 'refs';
if($C) {
$C->{$var} = $val;
}
else {
${"Global::$var"} = $val;
}
}
else {
no strict 'refs';
$ContainerSave{$var} = $C ? $C->{$var} : ${"Global::$var"};
$ContainerSave{$var} ||= 'No';
}
},
);
my %DirectiveAlias = qw(
URL VendURL
DataDir ProductDir
DefaultTables ProductFiles
Profiles OrderProfile
);
for( qw(search refresh cancel return secure unsecure submit control checkout) ) {
$Global::LegalAction{$_} = 1;
}
@Locale_directives_currency = (
qw/
CommonAdjust
PriceCommas
PriceDivide
PriceField
PriceDefault
SalesTax
Levies
TaxShipping
TaxInclusive
/ );
@Locale_keys_currency = (
qw/
currency_symbol
frac_digits
int_curr_symbol
int_currency_symbol
int_frac_digits
mon_decimal_point
mon_grouping
price_picture
mon_thousands_sep
n_cs_precedes
negative_sign
p_cs_precedes
p_sep_by_space
positive_sign
/ );
@Locale_directives_scalar = (
qw/
AutoEnd
Autoload
CategoryField
CommonAdjust
DescriptionField
HTMLsuffix
ImageDir
ImageDirSecure
PageDir
Preload
PriceCommas
PriceDefault
PriceDivide
PriceField
SalesTax
SpecialPageDir
TaxShipping
TaxInclusive
/ );
@Locale_directives_ary = (
qw/
AutoModifier
Levies
ProductFiles
UseModifier
/ );
# These are extra routines that are run if certain directives are
# updated
# Form:
#
# [ 'Directive', \&routine, [ @args ] ],
#
# @args are optional.
#
@Locale_directives_code = (
[ 'ProductFiles', \&Vend::Data::update_productbase ],
);
my %HashDefaultBlank = (qw(
SOAP 1
Mail 1
Accounting 1
Levy 1
QueryCache 1
));
my %DumpSource = (qw(
SpecialPage 1
GlobalSub 1
));
my %DontDump = (qw(
GlobalSub 1
SpecialPage 1
));
my %UseExtended = (qw(
Catalog 1
SubCatalog 1
Variable 1
));
my %InitializeEmpty = (qw(
FileControl 1
));
my %AllowScalarAction = (qw(
FileControl 1
SOAP_Control 1
));
my @External_directives = qw(
CatalogName
ScratchDefault
ValuesDefault
ScratchDir
SessionDB
SessionDatabase
SessionExpire
VendRoot
VendURL
SecureURL
Variable->SQLDSN
Variable->SQLPASS
Variable->SQLUSER
);
my %extmap = qw/
ia ItemAction
fa FormAction
am ActionMap
oc OrderCheck
ut UserTag
fi Filter
so SearchOp
fw Widget
lc LocaleChange
tag UserTag
ct CoreTag
jsc JavaScriptCheck
/;
for( values %extmap ) {
$extmap{lc $_} = $_;
}
%tagCanon = ( qw(
group Group
actionmap ActionMap
arraycode ArrayCode
hashcode HashCode
coretag CoreTag
searchop SearchOp
localechange LocaleChange
filter Filter
formaction FormAction
ordercheck OrderCheck
usertag UserTag
systemtag SystemTag
widget Widget
alias Alias
addattr addAttr
attralias attrAlias
attrdefault attrDefault
cannest canNest
description Description
override Override
underride Underride
visibility Visibility
help Help
documentation Documentation
extrameta ExtraMeta
gobble Gobble
hasendtag hasEndTag
implicit Implicit
interpolate Interpolate
invalidatecache InvalidateCache
isendanchor isEndAnchor
multiple Multiple
norearrange noRearrange
order Order
posnumber PosNumber
posroutine PosRoutine
maproutine MapRoutine
noreparse NoReparse
javascriptcheck JavaScriptCheck
required Required
routine Routine
version Version
));
my %tagSkip = ( qw! Documentation 1 Version 1 !);
my %tagAry = ( qw! Order 1 Required 1 ! );
my %tagHash = ( qw!
attrAlias 1
Implicit 1
attrDefault 1
! );
my %tagBool = ( qw!
ActionMap 1
addAttr 1
canNest 1
Filter 1
FormAction 1
hasEndTag 1
Interpolate 1
isEndAnchor 1
isOperator 1
Multiple 1
ItemAction 1
noRearrange 1
NoReparse 1
OrderCheck 1
UserTag 1
! );
my %current_dest;
my %valid_dest = qw/
actionmap ActionMap
coretag UserTag
filter Filter
formaction FormAction
itemaction ItemAction
ordercheck OrderCheck
localechange LocaleChange
usertag UserTag
hashcode HashCode
arraycode ArrayCode
searchop SearchOp
widget Widget
javascriptcheck JavaScriptCheck
/;
my $StdTags;
use vars qw/ $configfile /;
### This is unset when interchange script is run, so that the default
### when used by an external program is not to compile subroutines
$Vend::ExternalProgram = 1;
# Report a fatal error in the configuration file.
sub config_error {
my $msg = shift;
if(@_) {
$msg = errmsg($msg, @_);
}
local($^W);
if ($configfile) {
$msg = errmsg("%s\nIn line %s of the configuration file '%s':\n%s\n",
$msg,
$.,
$configfile,
$Vend::config_line,
);
}
if ($Vend::ExternalProgram) {
warn "$msg\n" unless $Vend::Quiet;
}
else {
die "$msg\n";
}
}
sub config_warn {
my $msg = shift;
if(@_) {
$msg = errmsg($msg, @_);
}
local($^W);
my $extra = '';
if($configfile and $Vend::config_line) {
$extra = errmsg(
"\nIn line %s of the configuration file '%s':\n%s\n",
$msg,
$.,
$configfile,
$Vend::config_line,
);
}
::logGlobal({level => 'notice'}, "$msg$extra");
}
sub setcat {
$C = $_[0] || $Vend::Cfg;
}
sub global_directives {
my $directives = [
# Order is not really important, catalogs are best first
# Directive name Parsing function Default value
['RunDir', 'root_dir', $Global::RunDir || 'etc'],
['DebugFile', 'root_dir', ''],
['CatalogUser', 'hash', ''],
['ConfigDir', undef, 'etc/lib'],
['FeatureDir', 'root_dir', 'features'],
['ConfigDatabase', 'config_db', ''],
['ConfigAllBefore', 'root_dir_array', 'catalog_before.cfg'],
['ConfigAllAfter', 'root_dir_array', 'catalog_after.cfg'],
['Message', 'message', ''],
['Capability', 'capability', ''],
['Require', 'require', ''],
['Suggest', 'suggest', ''],
['VarName', 'varname', ''],
['Windows', undef, $Global::Windows || ''],
['LockType', undef, $Global::Windows ? 'none' : ''],
['DumpStructure', 'yesno', 'No'],
['DumpAllCfg', 'yesno', 'No'],
['DisplayErrors', 'yesno', 'No'],
['DeleteDirective', sub {
my $c = $Global::DeleteDirective || {};
shift;
my @sets = map { lc $_ } split /[,\s]+/, shift;
@{$c}{@sets} = map { 1 } @sets;
return $c;
}, ''],
['Inet_Mode', 'yesno', (
defined $Global::Inet_Mode
||
defined $Global::Unix_Mode
)
? ($Global::Inet_Mode || 0) : 'No'],
['Unix_Mode', 'yesno', (
defined $Global::Inet_Mode
||
defined $Global::Unix_Mode
)
? ($Global::Unix_Mode || 0) : 'Yes'],
['TcpMap', 'hash', ''],
['CodeRepository', 'root_dir', ''],
['AccumulateCode', 'yesno', 'No'],
['Environment', 'array', ''],
['TcpHost', undef, 'localhost 127.0.0.1'],
['AcceptRedirect', 'yesno', 'No'],
['SendMailProgram', 'executable', [
$Global::SendMailLocation,
'/usr/sbin/sendmail',
'/usr/lib/sendmail',
'Net::SMTP',
]
],
['EncryptProgram', 'executable', [ 'gpg', 'pgpe', 'none', ] ],
['PIDfile', 'root_dir', "etc/$Global::ExeName.pid"],
['SocketFile', 'root_dir_array', ''],
['SocketPerms', 'integer', 0600],
['SocketReadTimeout','integer', 1],
['SOAP', 'yesno', 'No'],
['SOAP_Socket', 'array', ''],
['SOAP_Perms', 'integer', 0600],
['MaxRequestsPerChild','integer', 50],
['ChildLife', 'time', 0],
['StartServers', 'integer', 0],
['PreFork', 'yesno', 0],
['PreForkSingleFork', 'yesno', 0],
['SOAP_MaxRequests', 'integer', 50],
['SOAP_StartServers', 'integer', 1],
['SOAP_Control', 'action', ''],
['Jobs', 'hash', 'MaxLifetime 600 MaxServers 1 UseGlobal 0'],
['IPCsocket', 'root_dir', 'etc/socket.ipc'],
['HouseKeeping', 'time', 60],
['HouseKeepingCron', 'cron', ''],
['Mall', 'yesno', 'No'],
['TagGroup', 'tag_group', $StdTags],
['ConfigParseComments', 'warn', ''],
['TagInclude', 'tag_include', 'ALL'],
['ActionMap', 'action', ''],
['FileControl', 'action', ''],
['FormAction', 'action', ''],
['MaxServers', 'integer', 10],
['GlobalSub', 'subroutine', ''],
['Database', 'database', ''],
['FullUrl', 'yesno', 'No'],
['FullUrlIgnorePort', 'yesno', 'No'],
['Locale', 'locale', ''],
['HitCount', 'yesno', 'No'],
['IpHead', 'yesno', 'No'],
['IpQuad', 'integer', '1'],
['TagDir', 'root_dir_array', 'code'],
['TemplateDir', 'root_dir_array', ''],
['DebugTemplate', undef, ''],
['DomainTail', 'yesno', 'Yes'],
['CountrySubdomains','hash', ''],
['TrustProxy', 'list_wildcard_cidr', ''],
['AcrossLocks', 'yesno', 'No'],
['DNSBL', 'array', ''],
['NotRobotUA', 'list_wildcard', ''],
['RobotUA', 'list_wildcard', ''],
['RobotIP', 'list_wildcard_cidr', ''],
['RobotHost', 'list_wildcard_full', ''],
['HostnameLookups', 'yesno', 'No'],
['TolerateGet', 'yesno', 'No'],
['PIDcheck', 'time', '0'],
['LockoutCommand', undef, ''],
['SafeUntrap', 'array', 'ftfile sort'],
['SafeTrap', 'array', ':base_io'],
['NoAbsolute', 'yesno', 'No'],
['AllowGlobal', 'boolean', ''],
['PerlNoStrict', 'boolean', ''],
['PerlAlwaysGlobal', 'boolean', ''],
['AddDirective', 'directive', ''],
['UserTag', 'tag', ''],
['CodeDef', 'mapped_code', ''],
['HotDBI', 'boolean', ''],
['HammerLock', 'time', 30],
['DataTrace', 'integer', 0],
['ShowTimes', 'yesno', 0],
['ErrorFile', 'root_dir', undef],
['SysLog', 'hash', undef],
['Logging', 'integer', 0],
['CheckHTML', undef, ''],
['UrlSepChar', 'url_sep_char', '&'],
['Variable', 'variable', ''],
['Profiles', 'profile', ''],
['Catalog', 'catalog', ''],
['SubCatalog', 'catalog', ''],
['AutoVariable', 'autovar', 'UrlJoiner'],
['EnableJSONPost', 'yesno', 'No'],
['UnpackJSON', 'yesno', 'Yes'],
['XHTML', 'yesno', 'No'],
['UTF8', 'yesno', $ENV{MINIVEND_DISABLE_UTF8} ? 'No' : 'Yes'],
['External', 'yesno', 'No'],
['ExternalFile', 'root_dir', "$Global::RunDir/external.structure"],
['ExternalExport', undef, 'Global::Catalog=Catalog'],
['DowncaseVarname', undef, ''],
];
return $directives;
}
sub catalog_directives {
my $directives = [
# Order is somewhat important, the first 6 especially
# Directive name Parsing function Default value
['ErrorFile', 'relative_dir', 'error.log'],
['ActionMap', 'action', ''],
['FileControl', 'action', ''],
['FormAction', 'action', ''],
['ItemAction', 'action', ''],
['PageDir', 'relative_dir', 'pages'],
['SpecialPageDir', undef, 'special_pages'],
['ProductDir', 'relative_dir', 'products'],
['OfflineDir', 'relative_dir', 'offline'],
['ConfDir', 'relative_dir', 'etc'],
['RunDir', 'relative_dir', ''],
['ConfigDir', 'relative_dir', 'config'],
['TemplateDir', 'dir_array', ''],
['ConfigDatabase', 'config_db', ''],
['Require', 'require', ''],
['Suggest', 'suggest', ''],
['Message', 'message', ''],
['Variable', 'variable', ''],
['VarName', 'varname', ''],
['Limit', 'hash', 'option_list 5000 chained_cost_levels 32 robot_expire 1'],
['ScratchDefault', 'hash', ''],
['Profile', 'locale', ''],
['ValuesDefault', 'hash', ''],
['ProductFiles', 'array_complete', 'products'],
['PageTables', 'array_complete', ''],
['PageTableMap', 'hash', qq{
expiration_date expiration_date
show_date show_date
page_text page_text
base_page base_page
code code
}],
['DisplayErrors', 'yesno', 'No'],
['ParseVariables', 'yesno', 'No'],
['SpecialPage', 'special', 'order ord/basket results results search results flypage flypage'],
['DirectoryIndex', undef, ''],
['Sub', 'subroutine', ''],
['VendURL', 'url', undef],
['SecureURL', 'url', undef],
['PostURL', 'url', ''],
['SecurePostURL', 'url', ''],
['ProcessPage', undef, 'process'],
['History', 'integer', 0],
['OrderReport', undef, 'etc/report'],
['ScratchDir', 'relative_dir', 'tmp'],
['PermanentDir', 'relative_dir', 'perm'],
['SessionDB', undef, ''],
['SessionType', undef, 'File'],
['SessionDatabase', 'relative_dir', 'session'],
['ConfigParseComments', 'warn', ''],
['SessionLockFile', undef, 'etc/session.lock'],
['MoreDB', 'yesno', 'No'],
['DatabaseDefault', 'hash', ''],
['DatabaseAuto', 'dbauto', ''],
['DatabaseAutoIgnore', 'regex', ''],
['Database', 'database', ''],
['Preload', 'routine_array', ''],
['Autoload', 'routine_array', ''],
['AutoEnd', 'routine_array', ''],
['Replace', 'replace', ''],
['Member', 'variable', ''],
['Feature', 'feature', ''],
['WritePermission', 'permission', 'user'],
['ReadPermission', 'permission', 'user'],
['SessionExpire', 'time', '1 hour'],
['SaveExpire', 'time', '30 days'],
['MailOrderTo', undef, ''],
['SendMailProgram', 'executable', $Global::SendMailProgram],
['PGP', undef, ''],
# GLIMPSE
['Glimpse', 'executable', ''],
# END GLIMPSE
['Locale', 'locale', ''],
['Route', 'locale', ''],
['LocaleDatabase', 'configdb', ''],
['ExecutionLocale', undef, 'C'],
['DefaultLocale', undef, ''],
['RouteDatabase', 'configdb', ''],
['DirectiveDatabase', 'dbconfig', ''],
['VariableDatabase', 'dbconfig', ''],
['DirConfig', 'dirconfig', ''],
['FileDatabase', undef, ''],
['NoSearch', 'wildcard', 'userdb'],
['AllowRemoteSearch', 'array_complete', 'products variants options'],
['OrderCounter', undef, ''],
['MimeType', 'hash', ''],
['AliasTable', undef, ''],
['ImageAlias', 'hash', ''],
['TableRestrict', 'hash', ''],
['Filter', 'hash', ''],
['ImageDirSecure', undef, ''],
['ImageDirInternal', undef, ''],
['ImageDir', undef, ''],
['DeliverImage', 'yesno', 'no'],
['SpecialSub', 'hash', ''],
['SetGroup', 'valid_group', ''],
['UseModifier', 'array', ''],
['AutoModifier', 'array', ''],
['MaxQuantityField', undef, ''],
['MinQuantityField', undef, ''],
['LogFile', undef, 'etc/log'],
['Pragma', 'boolean_value', ''],
['NoExport', 'boolean', ''],
['NoExportExternal', 'yesno', 'no'],
['NoImport', 'boolean', ''],
['NoImportExternal', 'yesno', 'no'],
['CommonAdjust', undef, ''],
['PriceDivide', undef, 1],
['PriceCommas', 'yesno', 'Yes'],
['OptionsEnable', undef, ''],
['OptionsAttribute', undef, ''],
['Options', 'locale', ''],
['AlwaysSecure', 'boolean', ''],
['AlwaysSecureGlob', 'list_wildcard_full', ''],
['Password', undef, ''],
['AdminSub', 'boolean', ''],
['ExtraSecure', 'yesno', 'No'],
['FallbackIP', 'yesno', 'No'],
['WideOpen', 'yesno', 'No'],
['Promiscuous', 'yesno', 'No'],
['Cookies', 'yesno', 'Yes'],
['CookieName', undef, ''],
['CookiePattern', 'regex', '[-\w:.]+'],
['CookieLogin', 'yesno', 'No'],
['CookieDomain', undef, ''],
['InternalCookie', 'yesno', 'No'], ## Allows CookieName to be change yet still handle IP address in cookie
['MasterHost', undef, ''],
['UserTag', 'tag', ''],
['CodeDef', 'mapped_code', ''],
['RemoteUser', undef, ''],
['TaxShipping', undef, ''],
['TaxInclusive', 'yesno', 'No'],
['FractionalItems', 'yesno', 'No'],
['SeparateItems', 'yesno', 'No'],
['PageSelectField', undef, ''],
['NonTaxableField', undef, ''],
['CreditCardAuto', 'yesno', 'No'],
['FormIgnore', 'boolean', ''],
['EncryptProgram', undef, $Global::EncryptProgram || ''],
['EncryptKey', undef, ''],
['AsciiTrack', undef, ''],
['TrackFile', undef, ''],
['TrackPageParam', 'hash', ''],
['TrackDateFormat', undef, ''],
['SalesTax', undef, ''],
['SalesTaxFunction', undef, ''],
['CounterDir', 'relative_dir', ''],
['SOAP', 'yesno', 'No'],
['SOAP_Enable', 'hash', ''],
['SOAP_Action', 'action', ''],
['SOAP_Control', 'action', ''],
['UserDB', 'locale', ''],
['UserControl', 'yesno', 'No'],
['UserDatabase', undef, ''],
['RobotLimit', 'integer', 0],
['OrderLineLimit', 'integer', 0],
['RedirectCache', undef, ''],
['HTMLsuffix', undef, '.html'],
['CustomShipping', undef, ''],
['DefaultShipping', undef, 'default'],
['UpsZoneFile', undef, ''],
['OrderProfile', 'profile', ''],
['SearchProfile', 'profile', ''],
['OnFly', undef, ''],
['CategoryField', undef, 'category'],
['DescriptionField', undef, 'description'],
['PriceDefault', undef, 'price'],
['PriceField', undef, 'price'],
['DiscountSpacesOn', 'yesno', 'no'],
['DiscountSpaceVar', 'array', 'mv_discount_space'],
['Jobs', 'hash', ''],
['Shipping', 'locale', ''],
['Accounting', 'locale', ''],
['Levies', 'array', ''],
['Levy', 'locale', ''],
['AutoVariable', 'autovar', ''],
['ErrorDestination', 'hash', ''],
['XHTML', 'yesno', $Global::XHTML],
['External', 'yesno', 'No'],
['ExternalExport', undef, join " ", @External_directives],
['CartTrigger', 'routine_array', ''],
['CartTriggerQuantity', 'yesno', 'no'],
['UserTrack', 'yesno', 'no'],
['DebugHost', 'ip_address_regexp', ''],
['BounceReferrals', 'yesno', 'no'],
['BounceReferralsRobot', 'yesno', 'no'],
['BounceRobotSessionURL', 'yesno', 'no'],
['OrderCleanup', 'routine_array', ''],
['QueryCache', 'hash', ''],
['SessionCookieSecure', 'yesno', 'no'],
['SessionHashLength', 'integer', 1],
['SessionHashLevels', 'integer', 2],
['SourcePriority', 'array_complete', 'mv_pc mv_source'],
['SourceCookie', sub { &parse_ordered_attributes(@_, [qw(name expire domain path secure)]) }, '' ],
['SuppressCachedCookies', 'yesno', 'no'],
['OutputCookieHook', undef, ''],
];
push @$directives, @$Global::AddDirective
if $Global::AddDirective;
return $directives;
}
sub get_parse_routine {
my $parse = shift
or return undef;
my $routine;
my $rname = $parse;
if(ref $parse eq 'CODE') {
$routine = $parse;
}
elsif( $parse =~ /^\w+$/) {
no strict 'refs';
$routine = \&{'parse_' . $parse};
$rname = "parse_$rname";
}
else {
no strict 'refs';
$routine = \&{"$parse"};
}
if(ref($routine) ne 'CODE') {
config_error('Unknown parse routine %s', $rname);
}
return $routine;
}
sub global_chunk {
my ($fn) = @_;
my $save_c = $C;
undef $C;
local $/;
$/ = "\n";
open GCHUNK, "< $fn"
or config_error("read global chunk %s: %s", $fn, $!);
#::logDebug("GCHUNK length: " . -s $fn);
while(<GCHUNK>) {
my $line = $_;
my($lvar, $value) = read_config_value($_, \*GCHUNK);
next unless $lvar;
eval {
$GlobalRead->($lvar, $value);
};
if ($@) {
next if $@ =~ /Duplicate\s+usertag/i;
::logDebug("error running global $lvar: $@");
}
}
close GCHUNK;
Vend::Dispatch::update_global_actions();
finalize_mapped_code();
$C = $save_c;
return 1;
}
sub code_from_file {
my ($area, $name, $nohup) = @_;
my $c;
my $fn;
#::logDebug("code_from_file $area, $name");
return unless $c = $Global::TagLocation->{$area};
#::logDebug("We have a repos for $area");
return unless $fn = $c->{$name};
#::logDebug("code_from_file found file=$fn");
#::logDebug("master reading in new area=$area name=$name fn=$fn") if $nohup;
local $/;
$/ = "\n";
undef $C;
my $tdir = $Global::TagDir->[0];
my $accdir = "$tdir/Accumulated";
my $newfn = $fn;
$newfn =~ s{^$Global::CodeRepository/*}{};
my $lfile = "$accdir/$newfn";
my $ldir = $lfile;
$ldir =~ s{/[^/]+$}{};
unless(-d $ldir) {
die "Supposed directory $ldir is a file" if -e $ldir;
File::Path::mkpath($ldir)
or die "Cannot create directory $ldir: $!";
}
my $printnew;
if(-f $lfile) {
## This has already been submitted for master integration, no
## need to do it
$nohup = 1;
}
else {
open NEWTAG, ">> $lfile"
or die "Cannot write new tag file $lfile: $!";
if (lockfile(\*NEWTAG, 1, 0)) {
## We got a lock, we are the only one
File::Copy::copy($fn, $lfile);
unlockfile(\*NEWTAG);
close NEWTAG;
}
else {
## No lock, some other process doing same thing
}
}
open SYSTAG, "< $fn"
or config_error("read system tag file %s: %s", $fn, $!);
while(<SYSTAG>) {
my $line = $_;
my($lvar, $value) = read_config_value($_, \*SYSTAG);
next unless $lvar;
eval {
$GlobalRead->($lvar, $value);
};
next if $@ =~ /Duplicate\s+usertag/i;
}
close SYSTAG;
close NEWTAG;
finalize_mapped_code($area);
my $precursor = '';
my $routine;
my $init;
if($area eq 'UserTag') {
$init = $Global::UserTag->{Bootstrap}{$name};
$routine = $Global::UserTag->{Routine}{$name};
#::logDebug("NO ROUTINE FOR area=$area name=$name") unless $routine;
}
else {
$precursor = 'CodeDef ';
$init = $Global::CodeDef->{$area}{Bootstrap}{$name};
$routine = $Global::CodeDef->{$area}{Routine}{$name};
if(! $routine) {
no strict 'refs';
$routine = $Global::CodeDef->{$area}{MapRoutine}{$name}
and $routine = \&{"$routine"};
}
#::logDebug("area=$area name=$name now=" . ::uneval($Global::CodeDef->{$area}));
}
if($init and ref($routine) eq 'CODE') {
## Attempt to initialize
$init = get_option_hash($init);
$routine->($init);
}
## Tell the master server we have a new tag
unless($nohup) {
#::logDebug("notifying master of new area=$area name=$name fn=$fn");
## Bring this tag in global
open(RESTART, ">>$Global::RunDir/restart")
or die "open $Global::RunDir/restart: $!\n";
lockfile(\*RESTART, 1, 1)
or die "lock $Global::RunDir/restart: $!\n";
print RESTART "$precursor$area $name\n";
unlockfile(\*RESTART)
or die "unlock $Global::RunDir/restart: $!\n";
close RESTART;
kill 'HUP', $Vend::MasterProcess;
}
#::logDebug("routine=$routine for area=$area name=$name");
#::logDebug("REF IS=" . ::uneval($Global::UserTag)) if $nohup;
return $routine;
}
sub set_directive {
my ($directive, $value, $global) = @_;
my $directives;
if($global) { $directives = global_directives(); }
else { $directives = catalog_directives(); }
my ($d, $dir, $parse);
no strict 'refs';
foreach $d (@$directives) {
next unless (lc $directive) eq (lc $d->[0]);
$parse = get_parse_routine($d->[1]);
$dir = $d->[0];
$value = $parse->($dir, $value)
if $parse;
last;
}
return [$dir, $value] if defined $dir;
return undef;
}
sub get_catalog_default {
my ($directive) = @_;
my $directives = catalog_directives();
my $value;
for(@$directives) {
next unless (lc $directive) eq (lc $_->[0]);
$value = $_->[2];
}
return undef unless defined $value;
return $value;
}
sub get_global_default {
my ($directive) = @_;
my $directives = global_directives();
my $value;
for(@$directives) {
next unless (lc $directive) eq (lc $_->[0]);
$value = $_->[2];
}
return undef unless defined $value;
return $value;
}
sub evaluate_ifdef {
my ($ifdef, $reverse, $global) = @_;
#::logDebug("ifdef '$ifdef'");
my $status;
$ifdef =~ /^\s*(\@?)(\w+)\s*(.*)/;
$global = $1 || $global || undef;
my $var = $2;
my $cond = $3;
my $var_ref = ! $global ? $C->{Variable} : $Global::Variable;
#::logDebug("Variable value '$var_ref->{$var}'");
if (! $cond) {
$status = ! (not $var_ref->{$var});
}
elsif ($cond) {
my $val = $var_ref->{$var} || '';
my $safe = new Vend::Safe;
my $code = "q{$val}" . " " . $cond;
$status = $safe->reval($code);
if($@) {
config_warn(
errmsg("Syntax error in ifdef evaluation at line %s of %s",
$.,
$configfile,
),
);
$status = '';
}
}
#::logDebug("ifdef status '$status', reverse=" . !(not $reverse));
return $reverse ? ! $status : $status;
}
# This is what happens when ParseVariables is true
sub substitute_variable {
my($val) = @_;
1 while $val =~ s/__([A-Z][A-Z_0-9]*?[A-Z0-9])__/$C->{Variable}->{$1}/g;
# Only parse once for globals so they can contain other
# global and catalog variables
$val =~ s/\@\@([A-Z][A-Z_0-9]+[A-Z0-9])\@\@/$Global::Variable->{$1}/g;
return $val;
}
# Parse the configuration file for directives. Each directive sets
# the corresponding variable in the Vend::Cfg:: package. E.g.
# "DisplayErrors No" in the config file sets Vend::Cfg->{DisplayErrors} to 0.
# Directives which have no defined default value ("undef") must be specified
# in the config file.
my($directives, $directive, %parse);
sub config {
my($catalog, $dir, $confdir, $subconfig, $existing, $passed_file) = @_;
my($d, $parse, $var, $value, $lvar);
$Vend::Cat = $catalog;
if(ref $existing eq 'HASH') {
#::logDebug("existing=$existing");
$C = $existing;
}
else {
undef $existing;
$C = {};
$C->{CatalogName} = $catalog;
$C->{VendRoot} = $dir;
unless (defined $subconfig) {
$C->{ErrorFile} = 'error.log';
$C->{ConfigFile} = 'catalog.cfg';
}
else {
$C->{ConfigFile} = "$catalog.cfg";
$C->{BaseCatalog} = $subconfig;
}
}
unless($directives) {
$directives = catalog_directives();
foreach $d (@$directives) {
my $ucdir = $d->[0];
$directive = lc $d->[0];
next if $Global::DeleteDirective->{$directive};
$CDname{$directive} = $ucdir;
$CPname{$directive} = $d->[1];
$parse{$directive} = get_parse_routine($d->[1]);
}
}
for(keys %DirectiveAlias) {
my $k = lc $_;
my $v = $DirectiveAlias{$_};
my $lv = lc $v;
$CDname{$k} = $CDname{$lv};
$CPname{$k} = $CPname{$lv};
$parse{$k} = $parse{$lv};
}
no strict 'refs';
if(! $subconfig and ! $existing ) {
foreach $d (@$directives) {
my $ucdir = $d->[0];
$directive = lc $d->[0];
next if $Global::DeleteDirective->{$directive};
$parse = $parse{$directive};
$value = (
! defined $MV::Default{$catalog} or
! defined $MV::Default{$catalog}{$ucdir}
)
? $d->[2]
: $MV::Default{$catalog}{$ucdir};
if (defined $parse and defined $value) {
#::logDebug("parsing default directive=$directive ucdir=$ucdir parse=$parse value=$value CDname=$CDname{$directive}");
$value = $parse->($ucdir, $value);
}
$C->{$CDname{$directive}} = $value;
}
}
@include = ($passed_file || $C->{ConfigFile});
my %include_hash = ($include[0] => 1);
my $done_one;
my ($db, $dname, $nm);
my ($before, $after);
my $recno = 'C0001';
my @hidden_config;
if(! $existing and ! $subconfig) {
@hidden_config = grep -f $_,
"$C->{CatalogName}.site",
"$Global::ConfDir/$C->{CatalogName}.before",
@{$Global::ConfigAllBefore},
;
# Backwards because of unshift;
for (@hidden_config) {
unshift @include, $_;
$include_hash{$_} = 1;
}
@hidden_config = grep -f $_,
"$Global::ConfDir/$C->{CatalogName}.after",
@{$Global::ConfigAllAfter},
;
for (@hidden_config) {
push @include, $_;
$include_hash{$_} = 1;
}
}
# %MV::Default holds command-line mods to config, which we write
# to a file for easier processing
if(! $existing and defined $MV::Default{$catalog}) {
my $fn = "$Global::RunDir/$catalog.cmdline";
open(CMDLINE, ">$fn")
or die "Can't create cmdline configfile $fn: $!\n";
for(@{$MV::DefaultAry{$catalog}}) {
my ($d, $v) = split /\s+/, $_, 2;
if($v =~ /\n/) {
$v = "<<EndOfMvD\n$v\nEndOfMvD\n";
}
else {
$v .= "\n";
}
printf CMDLINE '%-19s %s', $d, $v;
}
close CMDLINE;
push @include, $fn;
$include_hash{$_} = 1;
}
my $allcfg;
if($Global::DumpAllCfg) {
open ALLCFG, ">$Global::RunDir/allconfigs.cfg"
and $allcfg = 1;
}
# Create closure that reads and sets config values
my $read = sub {
my ($lvar, $value, $tie, $var) = @_;
# parse variables in the value if necessary
if($C->{ParseVariables} and $value =~ /(?:__|\@\@)/) {
save_variable($CDname{$lvar}, $value);
$value = substitute_variable($value);
}
# call the parsing function for this directive
$parse = $parse{$lvar};
$value = $parse->($CDname{$lvar}, $value) if defined $parse and ! $tie;
# and set the $C->directive variable
if($tie) {
watch ( $CDname{$lvar}, $value );
}
else {
$C->{$CDname{$lvar}} = $value;
}
};
#print "include starts with @include\n";
CONFIGLOOP:
while ($configfile = shift @include) {
my $tellmark;
if(ref $configfile) {
($configfile, $tellmark) = @$configfile;
#print "recalling $configfile (pos $tellmark)\n";
}
# See if anything is defined in options to do before the
# main configuration file. If there is a file, then we
# will do it (after pushing the main one on @include).
-f $configfile && open(CONFIG, "< $configfile")
or do {
my $msg = "Could not open configuration file '" . $configfile .
"' for catalog '" . $catalog . "':\n$!";
if(defined $done_one) {
warn "$msg\n";
open (CONFIG, '');
}
else {
die "$msg\n";
}
};
print ALLCFG "# READING FROM $configfile\n" if $allcfg;
seek(CONFIG, $tellmark, 0) if $tellmark;
#print "seeking to $tellmark in $configfile, include is @include\n";
my ($ifdef, $begin_ifdef);
while(<CONFIG>) {
if($allcfg) {
print ALLCFG $_
unless /^\s*include\s+/i;
}
chomp; # zap trailing newline,
if(/^\s*endif\s*$/i) {
#print "found $_\n";
undef $ifdef;
undef $begin_ifdef;
next;
}
if(/^\s*if(n?)def\s+(.*)/i) {
if(defined $ifdef) {
config_error("Can't overlap ifdef at line %s of %s", $., $configfile);
}
$ifdef = evaluate_ifdef($2,$1);
$begin_ifdef = $.;
#print "found $_\n";
next;
}
if(defined $ifdef) {
next unless $ifdef;
}
if(/^\s*include\s+(.+)/i) {
#print "found $_\n";
my $spec = $1;
$spec = substitute_variable($spec) if $C->{ParseVariables};
if ($include_hash{$spec}) {
config_error("Possible infinite loop through inclusion of $spec at line %s of %s, skipping", $., $configfile);
next;
}
$include_hash{$spec} = 1;
my $ref = [ $configfile, tell(CONFIG)];
#print "saving config $configfile (pos $ref->[1])\n";
#unshift @include, [ $configfile, tell(CONFIG) ];
unshift @include, $ref;
close CONFIG;
unshift @include, grep -f $_, glob($spec);
next CONFIGLOOP;
}
my ($lvar, $value, $var, $tie) =
read_config_value($_, \*CONFIG, $allcfg);
next unless $lvar;
# Use our closure defined above
$read->($lvar, $value, $tie);
# If we have passed off configuration to a database we stop here...
last if $C->{ConfigDatabase}->{ACTIVE};
# See if we want to load the config database
if(! $db and $C->{ConfigDatabase}->{LOAD}) {
$db = $C->{ConfigDatabase}->{OBJECT}
or config_error(
"ConfigDatabase $C->{ConfigDatabase}->{'name'} not active.");
$dname = $C->{ConfigDatabase}{name};
}
# Actually load ConfigDatabase if present
if($db) {
$nm = $CDname{$lvar};
my ($extended, $status);
undef $extended;
# set directive name
$status = Vend::Data::set_field($db, $recno, 'directive', $nm);
defined $status
or config_error(
"ConfigDatabase failed for %s, field '%s'",
$dname,
'directive',
);
# use extended value field if necessary or directed
if (length($value) > 250 or $UseExtended{$nm}) {
$extended = $value;
$extended =~ s/(\S+)\s*//;
$value = $1 || '';
$status = Vend::Data::set_field($db, $recno, 'extended', $extended);
defined $status
or config_error(
"ConfigDatabase failed for %s, field '%s'",
$dname,
'extended',
);
}
# set value -- just a name if extended was used
$status = Vend::Data::set_field($db, $recno, 'value', $value);
defined $status
or config_error(
"ConfigDatabase failed for %s, field '%s'",
$dname,
'value',
);
$recno++;
}
}
$done_one = 1;
close CONFIG;
delete $include_hash{$configfile};
# See if we have an active configuration database
if($C->{ConfigDatabase}->{ACTIVE}) {
my ($key,$value,$dir,@val);
my $name = $C->{ConfigDatabase}->{name};
$db = $C->{ConfigDatabase}{OBJECT} or
config_error("ConfigDatabase called ACTIVE with no database object.\n");
my $items = $db->array_query("select * from $name order by code");
my $one;
foreach $one ( @$items ) {
($key, $dir, @val) = @$one;
$value = join " ", @val;
$value =~ s/\s/\n/ if $value =~ /\n/;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
$lvar = lc $dir;
$read->($lvar, $value);
}
}
if(defined $ifdef) {
config_error("Failed to close #ifdef on line %s.", $begin_ifdef);
}
} # end CONFIGLOOP
# We need to make this directory if it isn't already there....
if(! $existing and $C->{ScratchDir} and ! -e $C->{ScratchDir}) {
mkdir $C->{ScratchDir}, 0700
or die "Can't make temporary directory $C->{ScratchDir}: $!\n";
}
return $C if $existing;
# check for unspecified directives that don't have default values
# but set some first if appropriate
set_defaults() unless $C->{BaseCatalog};
REQUIRED: {
last REQUIRED if defined $subconfig;
last REQUIRED if defined $Vend::ExternalProgram;
foreach $var (keys %CDname) {
if (! defined $C->{$CDname{$var}}) {
my $msg = errmsg(
"Please specify the %s directive in the configuration file '%s'",
$CDname{$var},
($passed_file || $C->{ConfigFile}),
);
die "$msg\n";
}
}
}
# Set up hash of keys to hide for BounceReferrals and BounceReferralsRobot
$C->{BounceReferrals_hide} = { map { ($_, 1) } grep { !(/^cookie-/ or /^session(?:$|-)/) } @{$C->{SourcePriority}} };
my @exclude = qw( mv_form_charset mv_session_id mv_tmp_session );
@{$C->{BounceReferrals_hide}}{@exclude} = (1) x @exclude;
finalize_mapped_code();
set_readonly_config();
# Ugly legacy stuff so API won't break
$C->{Special} = $C->{SpecialPage} if defined $C->{SpecialPage};
my $return = $C;
undef $C;
return $return;
}
sub read_container {
my($start, $handle, $marker, $parse, $allcfg) = @_;
my $lvar = lc $marker;
my $var = $CDname{$lvar};
#::logDebug("Read container start=$start marker=$marker lvar=$lvar var=$var parse=$parse");
$parse ||= {};
#::logDebug("Read container parse value=$CPname{$lvar}");
my $sub = $ContainerSpecial{$var}
|| $ContainerSpecial{$lvar}
|| $ContainerType{$CPname{$lvar}};
if($sub) {
#::logDebug("Trigger special container");
$start =~ s/\n$//;
$sub->($var, $start);
$ContainerTrigger{$lvar} ||= $sub;
return $start;
}
my $foundeot = 0;
my $startline = $.;
my $value = '';
if(length $start) {
$value .= "$start\n";
}
while (<$handle>) {
print ALLCFG $_ if $allcfg;
if ($_ =~ m{^\s*</$marker>\s*$}i) {
$foundeot = 1;
last;
}
$value .= $_;
}
return undef unless $foundeot;
#untaint
$value =~ /((?s:.)*)/;
$value = $1;
return $value;
}
sub read_here {
my($handle, $marker, $allcfg) = @_;
my $foundeot = 0;
my $startline = $.;
my $value = '';
while (<$handle>) {
print ALLCFG $_ if $allcfg;
if ($_ =~ m{^$marker$}) {
$foundeot = 1;
last;
}
$value .= $_;
}
return undef unless $foundeot;
#untaint
$value =~ /((?s:.)*)/;
$value = $1;
return $value;
}
sub config_named_catalog {
my ($cat_name, $source, $db_only, $dbconfig) = @_;
my ($g, $c);
$g = $Global::Catalog{$cat_name};
unless (defined $g) {
logGlobal( "Can't find catalog '%s'" , $cat_name );
return undef;
}
$Vend::Log_suppress = 1;
unless ($db_only or $Vend::Quiet) {
logGlobal( "Config '%s' %s%s", $g->{'name'}, $source );
}
undef $Vend::Log_suppress;
chdir $g->{'dir'}
or die "Couldn't change to $g->{'dir'}: $!\n";
if($db_only) {
logGlobal(
"Config table '%s' (file %s) for catalog %s from %s",
$db_only,
$dbconfig,
$g->{'name'},
$source,
);
my $cfg = $Global::Selector{$g->{script}}
or die errmsg("'%s' not a catalog (%s).", $g->{name}, $g->{script});
undef $cfg->{Database}{$db_only};
$Vend::Cfg = config(
$g->{name},
$g->{dir},
undef,
undef,
$cfg,
$dbconfig,
)
or die errmsg("error configuring catalog %s table %s: %s",
$g->{name},
$db_only,
$@,
);
open_database();
close_database();
return $Vend::Cfg;
}
eval {
$c = config($g->{'name'},
$g->{'dir'},
undef,
$g->{'base'} || undef,
# OPTION_EXTENSION
# $Vend::CommandLine->{$g->{'name'}} || undef
# END OPTION_EXTENSION
);
};
if($@) {
my $msg = $@;
logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
return undef;
}
if (defined $g->{base}) {
open_database(1);
dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
return $c;
}
eval {
$Vend::Cfg = $c;
$::Variable = $Vend::Cfg->{Variable};
$::Pragma = $Vend::Cfg->{Pragma};
Vend::Data::read_salestax();
Vend::Data::read_shipping();
open_database(1);
my $db;
close_database();
};
undef $Vend::Cfg;
if($@) {
my $msg = $@;
$msg =~ s/\s+$//;
logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
return undef;
}
dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
my $status_dir = ($c->{Source}{RunDir} ? $c->{RunDir} : $c->{ConfDir});
delete $c->{Source};
my $stime = scalar localtime();
writefile(">$Global::RunDir/status.$g->{name}", "$stime\n$g->{dir}\n");
writefile(">$status_dir/status.$g->{name}", "$stime\n");
return $c;
}
use File::Find;
sub get_system_groups {
my @files;
my $wanted = sub {
return if (m{^\.} || ! -f $_);
$File::Find::name =~ m{/([^/]+)/([^/.]+)\.(\w+)$}
or return;
my $group = $1;
my $tname = $2;
my $ext = $extmap{lc $3} or return;
$ext =~ /Tag$/ or return;
push @files, [ $group, $tname ];
};
File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
$Global::TagGroup ||= {};
for(@files) {
my $g = $Global::TagGroup->{":$_->[0]"} ||= [];
push @$g, $_->[1];
}
return;
}
sub get_repos_code {
#::logDebug("get_repos_code called");
return unless $Global::CodeRepository;
return if $Vend::ControllingInterchange;
my @files;
my $wanted = sub {
return if (m{^\.} || ! -f $_);
return unless m{^[^.]+\.(\w+)$};
my $ext = $extmap{lc $1} or return;
push @files, [ $File::Find::name, $ext];
};
File::Find::find({ wanted => $wanted, follow => 1 }, $Global::CodeRepository);
my $c = $Global::TagLocation = {};
# %valid_dest is scoped as my variable above
for(@files) {
my $foundfile = $_->[0];
my $dest = $_->[1];
open SYSTAG, "< $foundfile"
or next;
while(<SYSTAG>) {
my($lvar, $value) = read_config_value($_, \*SYSTAG);
my $name;
my $dest;
if($lvar eq 'codedef') {
$value =~ s/^(\S+)\s+(\S+).*//s;
$dest = $valid_dest{lc $2};
$name = $1;
}
elsif($dest = $valid_dest{$lvar}) {
$value =~ m/^(\S+)\s+/
and $name = $1;
}
next unless $dest and $name;
$name = lc $name;
$name =~ s/-/_/g;
$c->{$dest} ||= {};
$c->{$dest}{$name} ||= $foundfile;
}
close SYSTAG;
}
#::logDebug("repos is:\n" . ::uneval($Global::TagLocation));
}
sub get_system_code {
return if $CodeDest;
return if $Vend::ControllingInterchange;
# defined means don't go here anymore
$SystemCodeDone = '';
my @files;
my $wanted = sub {
return if (m{^\.} || ! -f $_);
return unless m{^[^.]+\.(\w+)$};
my $ext = $extmap{lc $1} or return;
push @files, [ $File::Find::name, $ext];
};
File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
local($configfile);
for(@files) {
$CodeDest = $_->[1];
$configfile = $_->[0];
open SYSTAG, "< $configfile"
or config_error("read system tag file %s: %s", $configfile, $!);
while(<SYSTAG>) {
my($lvar, $value) = read_config_value($_, \*SYSTAG);
next unless $lvar;
$GlobalRead->($lvar, $value);
}
close SYSTAG;
}
undef $CodeDest;
# 1 means read system tag directories
$SystemCodeDone = 1;
}
sub read_config_value {
local($_) = shift;
return undef unless $_;
my ($fh, $allcfg) = @_;
my $lvar;
my $tie;
chomp; # zap trailing newline,
s/^\s*#.*//; # comments,
# mh 2/10/96 changed comment behavior
# to avoid zapping RGB values
#
s/\s+$//; # trailing spaces
return undef unless $_;
local($Vend::config_line);
$Vend::config_line = $_;
my $container_here;
my $container_trigger;
my $var;
my $value;
if(s{^[ \t]*<(/?)(\w+)\s*(.*)\s*>\s*$}{$2$3}) {
$container_trigger = $1;
$var = $container_here = $2;
$value = $3;
}
else {
# lines read from the config file become untainted
m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error from $_");
$var = $1;
$value = $2;
}
($lvar = $var) =~ tr/A-Z/a-z/;
config_error("Unknown directive '%s'", $lvar), next
unless defined $CDname{$lvar};
my($codere) = '[-\w_#/.]+';
if ($container_trigger) { # Apache container value
if(my $sub = $ContainerTrigger{$lvar}) {
$sub->($var, $value, 1);
return;
}
}
if ($container_here) { # Apache container value
my $begin = $value;
$begin .= "\n" if length $begin;
my $mark = "</$container_here>";
my $startline = $.;
$value = read_container($begin, $fh, $container_here, \%parse);
unless (defined $value) {
config_error (sprintf('%d: %s', $startline,
qq#no end contaner ("</$container_here>") found#));
}
}
elsif ($value =~ /^(.*)<<(\w+)\s*/) { # "here" value
my $begin = $1 || '';
$begin .= "\n" if $begin;
my $mark = $2;
my $startline = $.;
$value = $begin . read_here($fh, $mark);
unless (defined $value) {
config_error (sprintf('%d: %s', $startline,
qq#no end marker ("$mark") found#));
}
}
elsif ($value =~ /^(.*)<&(\w+)\s*/) { # "here sub" value
my $begin = $1 || '';
$begin .= "\n" if $begin;
my $mark = $2;
my $startline = $.;
$value = $begin . read_here($fh, $mark, $allcfg);
unless (defined $value) {
config_error (sprintf('%d: %s', $startline,
qq#no end marker ("$mark") found#));
}
eval {
require Tie::Watch;
};
unless ($@) {
$tie = 1;
}
else {
config_warn(
"No Tie::Watch module installed at %s, setting %s to default.",
$startline,
$var,
);
$value = '';
}
}
elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) { # read from file
my $confdir = $C ? $C->{ConfigDir} : $Global::ConfigDir;
$value = $1 || '';
my $file = $3;
$value .= "\n" if $value;
unless ($confdir) {
config_error(
"%s: Can't read from file until ConfigDir defined",
$CDname{$lvar},
);
}
$file = $CDname{$lvar} unless $file;
# If the file isn't already specified with an absolute path, try the
# Config directory, then the current directory. When neither file
# exists, use the Config directory and continue.
if ($file !~ m!^/!) {
my $test_with_confdir = escape_chars("$confdir/$file");
if (-f $test_with_confdir) {
$file = $test_with_confdir;
}
else {
my $test_without_confdir = escape_chars($file);
if (-f $test_without_confdir) {
$file = $test_without_confdir;
}
else {
$file = $test_with_confdir;
}
}
}
my $tmpval = readfile($file);
unless( defined $tmpval ) {
config_warn(
"%s: read from non-existent file %s, skipping.",
$CDname{$lvar},
$file,
);
return undef;
}
chomp($tmpval) unless $tmpval =~ m!.\n.!;
$value .= $tmpval;
}
return($lvar, $value, $var, $tie);
}
# Parse the global configuration file for directives. Each directive sets
# the corresponding variable in the Global:: package. E.g.
# "DisplayErrors No" in the config file sets Global::DisplayErrors to 0.
# Directives which have no default value ("undef") must be specified
# in the config file.
sub global_config {
my(%parse, $var, $value, $lvar, $parse);
my($directive, $seen_catalog);
no strict 'refs';
%CDname = ();
%CPname = ();
my $directives = global_directives();
$Global::Structure = {} unless $Global::Structure;
# Prevent parsers from thinking it is a catalog
undef $C;
foreach my $d (@$directives) {
$directive = lc $d->[0];
$CDname{$directive} = $d->[0];
$CPname{$directive} = $d->[1];
$parse = get_parse_routine($d->[1]);
$parse{$directive} = $parse;
undef $value;
$value = (
! defined $MV::Default{mv_global} or
! defined $MV::Default{mv_global}{$d->[0]}
)
? $d->[2]
: $MV::Default{mv_global}{$d->[0]};
if (defined $DumpSource{$CDname{$directive}}) {
$Global::Structure->{ $CDname{$directive} } = $value;
}
if (defined $parse and defined $value) {
$value = $parse->($d->[0], $value);
}
if(defined $value) {
${'Global::' . $CDname{$directive}} = $value;
$Global::Structure->{ $CDname{$directive} } = $value
unless defined $DontDump{ $CDname{$directive} };
}
}
my (@include) = $Global::ConfigFile;
# Create closure for reading of value
my $read = sub {
my ($lvar, $value, $tie) = @_;
#::logDebug("Doing a GlobalRead for $lvar") unless $Global::Foreground;
unless (defined $CDname{$lvar}) {
config_error("Unknown directive '%s'", $var);
return;
}
#::logDebug("Continuing a GlobalRead for $lvar") unless $Global::Foreground;
if (defined $DumpSource{$CDname{$directive}}) {
$Global::Structure->{ $CDname{$directive} } = $value;
}
# call the parsing function for this directive
$parse = $parse{$lvar};
#::logDebug("parse routine is $parse for $CDname{$lvar}") unless $Global::Foreground;
$value = $parse->($CDname{$lvar}, $value) if defined $parse;
# and set the Global::directive variable
${'Global::' . $CDname{$lvar}} = $value;
#::logDebug("It is now=" . ::uneval($value)) unless $Global::Foreground;
$Global::Structure->{ $CDname{$lvar} } = $value
unless defined $DontDump{ $CDname{$lvar} };
};
$GlobalRead = $read;
my $done_one;
GLOBLOOP:
while ($configfile = shift @include) {
my $tellmark;
if(ref $configfile) {
($configfile, $tellmark) = @$configfile;
#print "recalling $configfile (pos $tellmark)\n";
}
-f $configfile && open(GLOBAL, "< $configfile")
or do {
my $msg = errmsg(
"Could not open global configuration file '%s': %s",
$configfile,
$!,
);
if(defined $done_one) {
warn "$msg\n";
open (GLOBAL, '');
}
else {
die "$msg\n";
}
};
seek(GLOBAL, $tellmark, 0) if $tellmark;
#print "seeking to $tellmark in $configfile, include is @include\n";
my ($ifdef, $begin_ifdef);
while(<GLOBAL>) {
if(/^\s*endif\s*$/i) {
#print "found $_";
undef $ifdef;
undef $begin_ifdef;
next;
}
if(/^\s*if(n?)def\s+(.*)/i) {
#print "found $_";
if(defined $ifdef) {
config_error(
"Can't overlap ifdef at line %s of %s",
$.,
$configfile,
);
}
$ifdef = evaluate_ifdef($2,$1,1);
$begin_ifdef = $.;
next;
}
if(defined $ifdef) {
next unless $ifdef;
}
if(/^\s*include\s+(.+)/) {
#print "found $_";
my $spec = $1;
my $ref = [ $configfile, tell(GLOBAL)];
#print "saving config $configfile (pos $ref->[1])\n";
unshift @include, $ref;
close GLOBAL;
chomp;
unshift @include, grep -f $_, glob($spec);
next GLOBLOOP;
}
my ($lvar, $value, $tie) = read_config_value($_, \*GLOBAL);
next unless $lvar;
$read->($lvar, $value, $tie);
}
close GLOBAL;
$done_one = 1;
} # end GLOBLOOP;
# In case no user-supplied config has been given...returns
# with no effect if that has been done already.
get_system_code() unless defined $SystemCodeDone;
# Directive post-processing
global_directive_postprocess();
# Do some cleanup
set_global_defaults();
# check for unspecified directives that don't have default values
foreach $var (keys %CDname) {
last if defined $Vend::ExternalProgram;
if (!defined ${'Global::' . $CDname{$var}}) {
die "Please specify the $CDname{$var} directive in the\n" .
"configuration file '$Global::ConfigFile'\n";
}
}
# Inits Global UserTag entries
ADDTAGS: {
Vend::Parse::global_init;
}
## Pulls in the places where code can be found when AccumulatingTags
get_repos_code() if $Global::AccumulateCode;
finalize_mapped_code();
dump_structure($Global::Structure, "$Global::RunDir/$Global::ExeName")
if $Global::DumpStructure and ! $Vend::ExternalProgram;
delete $Global::Structure->{Source};
%CDname = ();
return 1;
}
# Use Tie::Watch to attach subroutines to config variables
sub watch {
my($name, $value) = @_;
$C->{Tie_Watch} = [] unless $C->{Tie_Watch};
push @{$C->{Tie_Watch}}, $name;
my ($ref, $orig);
#::logDebug("Contents of $name: " . uneval_it($C->{$name}));
if(CORE::ref($C->{$name}) =~ /ARRAY/) {
#::logDebug("watch ref=array");
$ref = $C->{$name};
$orig = [ @{ $C->{$name} } ];
}
elsif(CORE::ref($C->{$name}) =~ /HASH/) {
#::logDebug("watch ref=hash");
$ref = $C->{$name};
$orig = { %{ $C->{$name} } };
}
else {
#::logDebug("watch ref=scalar");
$ref = \$C->{$name};
$orig = $C->{$name};
}
#::logDebug("watch ref=$ref orig=$orig name=$name value=$value");
$C->{WatchIt} = { _mvsafe => $C->{ActionMap}{_mvsafe} } if ! $C->{WatchIt};
parse_action('WatchIt', "$name $value");
my $coderef = $C->{WatchIt}{$name}
or return undef;
my $recode = sub {
package Vend::Interpolate;
init_calc();
my $key = $_[0]->Args(-fetch)->[0];
return $coderef->(@_, $key);
};
package Vend::Interpolate;
$Vend::Config::C->{WatchIt}{$name} = Tie::Watch->new(
-variable => $ref,
-fetch => [$recode,$orig],
);
}
sub get_wildcard_list {
my($var, $value, $base) = @_;
$value =~ s/\s*#.*?$//mg;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
return '' if ! $value;
if($value !~ /\|/) {
$value =~ s/([\\\+\|\[\]\(\){}])/\\$1/g;
$value =~ s/\./\\./g;
$value =~ s/\*/.*/g;
$value =~ s/\?/./g;
my @items = grep /\S/, split /\s*,\s*/, $value;
for (@items) {
s/\s+/\\s+/g;
my $extra = $_;
if ($base && $extra =~ s/^\.\*\\\.//){
push(@items,$extra) if $extra;
}
}
$value = join '|', @items;
}
return parse_regex($var, $value);
}
sub external_global {
my ($value) = @_;
my $main = {};
my @sets = grep /\w/, split /[\s,]+/, $value;
#::logDebug( "Parsing sets=" . join(",", @sets) . "\n" );
no strict 'refs';
for my $set (@sets) {
#::logDebug( "Parsing $set\n" );
my @keys = split /->/, $set;
my ($k, $v) = split /=/, $keys[0];
my $major;
my $var;
if($k =~ m/^(\w+)::(\w+)$/) {
$major = $1;
$var = $2;
}
$major ||= 'Global';
$v ||= $var;
my $walk = ${"${major}::$var"};
my $ref = $main->{$v} = $walk;
for(my $i = 1; $i < @keys; $i++) {
my $current = $keys[$i];
#::logDebug( "Walking $current\n" );
if($i == $#keys) {
if( CORE::ref($ref) eq 'ARRAY' ) {
$current =~ s/\D+//g;
$current =~ /^\d+$/
or config_error("External: Bad array index $current from $set");
$ref->[$current] = $walk->[$current];
#::logDebug( "setting $current to ARRAY\n" );
}
elsif( CORE::ref($ref) eq 'HASH' ) {
$ref->{$current} = $walk->{$current};
#::logDebug( "setting $current to HASH\n" );
}
else {
config_error("External: bad data structure for $set");
}
}
else {
$walk = $walk->{$current};
#::logDebug( "Walking $current\n" );
if( CORE::ref($walk) eq 'HASH' ) {
$ref->{$current} = {};
$ref = $ref->{$current};
}
else {
config_error("External: bad data structure for $set");
}
}
}
}
return $main;
}
# Set the External environment, dumps, etc.
sub external_cat {
my ($value) = @_;
my $c = $C
or config_error( "Not in catalog configuration context." );
my $main = {};
my @sets = grep /\w/, split /[\s,]+/, $value;
for my $set (@sets) {
my @keys = split /->/, $set;
my $ref = $main;
my $walk = $c;
for(my $i = 0; $i < @keys; $i++) {
my $current = $keys[$i];
if($i == $#keys) {
if( CORE::ref($ref) eq 'ARRAY' ) {
$current =~ s/\D+//g;
$current =~ /^\d+$/
or config_error("External: Bad array index $current from $set");
$ref->[$current] = $walk->[$current];
}
elsif( CORE::ref($ref) eq 'HASH' ) {
$ref->{$current} = $walk->{$current};
}
else {
config_error("External: bad data structure for $set");
}
}
else {
$walk = $walk->{$current};
if( CORE::ref($walk) eq 'HASH' ) {
$ref->{$current} ||= {};
$ref = $ref->{$current};
}
else {
config_error("External: bad data structure for $set");
}
}
}
}
return $main;
}
# Set up an ActionMap or FormAction or FileAction
sub parse_action {
my ($var, $value, $mapped) = @_;
if (! $value) {
return $InitializeEmpty{$var} ? '' : {};
}
return if $Vend::ExternalProgram;
my $c;
if($mapped) {
$c = $mapped;
}
elsif(defined $C) {
$c = $C->{$var} ||= {};
}
else {
no strict 'refs';
$c = ${"Global::$var"} ||= {};
}
if (defined $C and ! $c->{_mvsafe}) {
my $calc = Vend::Interpolate::reset_calc();
$c->{_mvsafe} = $calc;
}
my ($name, $sub) = split /\s+/, $value, 2;
$name =~ s/-/_/g;
## Determine if we are in a catalog config, and if
## perl should be global and/or strict
my $nostrict;
my $perlglobal = 1;
if($C) {
$nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
$perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
}
# Untaint and strip this pup
$sub =~ s/^\s*((?s:.)*\S)\s*//;
$sub = $1;
# clear errors for code paths below that don't call eval or reval
undef $@;
if($sub !~ /\s/) {
no strict 'refs';
if($sub =~ /::/ and ! $C) {
$c->{$name} = \&{"$sub"};
}
else {
if($C and $C->{Sub}) {
$c->{$name} = $C->{Sub}{$sub};
}
if(! $c->{$name} and $Global::GlobalSub) {
$c->{$name} = $Global::GlobalSub->{$sub};
}
}
if(! $c->{$name} and $AllowScalarAction{$var}) {
$c->{$name} = $sub;
}
elsif(! $c->{$name}) {
$@ = errmsg("Mapped %s action routine '%s' is non-existent.", $var, $sub);
}
}
elsif ( ! $mapped and $sub !~ /^sub\b/) {
if($AllowScalarAction{$var}) {
$c->{$name} = $sub;
}
else {
my $code = <<EOF;
sub {
return Vend::Interpolate::interpolate_html(<<EndOfThisHaiRYTHING);
$sub
EndOfThisHaiRYTHING
}
EOF
$c->{$name} = eval $code;
}
}
elsif ($perlglobal) {
package Vend::Interpolate;
if($nostrict) {
no strict;
$c->{$name} = eval $sub;
}
else {
$c->{$name} = eval $sub;
}
}
else {
package Vend::Interpolate;
$c->{$name} = $c->{_mvsafe}->reval($sub);
}
if($@) {
config_warn("Action '%s' did not compile correctly (%s).", $name, $@);
}
return $c;
}
sub get_directive {
my $name = shift;
$name = $CDname{lc $name} || $name;
no strict 'refs';
if($C) {
return $C->{$name};
}
else {
return ${"Global::$name"};
}
}
# Adds features contained in FeatureDir called by catalog
sub parse_feature {
my ($var, $value) = @_;
my $c = $C->{$var} || {};
return $c unless $value;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
unless(-d $fdir) {
config_warn("Feature '%s' not found, skipping.", $value);
return $c;
}
# Get the global install files and remove them from the config list
my @gfiles = glob("$fdir/*.global");
my %seen;
@seen{@gfiles} = @gfiles;
# Get the init files and remove them from the config list
my @ifiles = glob("$fdir/*.init");
@seen{@ifiles} = @ifiles;
# Get the uninstall files and remove them from the config list
my @ufiles = glob("$fdir/*.uninstall");
@seen{@ufiles} = @ifiles;
# Any other files are config files
my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
# directories are for copying
my @cdirs = grep -d $_, @cfiles;
# strip the directories from the config list, leaving catalog.cfg stuff
@cfiles = grep -f $_, @cfiles;
# Don't install global more than once
@gfiles = grep ! $Global::FeatureSeen{$_}++, @gfiles;
# Place the catalog configuration in the config list
unshift @include, @cfiles;
my @copy;
my $wanted = sub {
return unless -f $_;
my $n = $File::Find::name;
$n =~ s{^$fdir/}{};
my $d = $File::Find::dir;
$d =~ s{^$fdir/}{};
push @copy, [$n, $d];
};
if(@cdirs) {
File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
}
#::logDebug("gfiles=" . ::uneval(\@gfiles));
#::logDebug("cfiles=" . ::uneval(\@cfiles));
#::logDebug("ifiles=" . ::uneval(\@ifiles));
#::logDebug("ufiles=" . ::uneval(\@ufiles));
#::logDebug("cdirs=" . ::uneval(\@cdirs));
#::logDebug("copy=" . ::uneval(\@copy));
for(@copy) {
my ($n, $d) = @$_;
my $tf = Vend::File::catfile($C->{VendRoot}, $n);
next if -f $tf;
my $td = Vend::File::catfile($C->{VendRoot}, $d);
unless(-d $td) {
File::Path::mkpath($td)
or do {
config_warn("Feature %s not able to make directory %s", $value, $td);
next;
};
}
File::Copy::copy("$fdir/$n", $tf)
or do {
config_warn("Feature %s not able to copy %s to %s", $value, "$fdir/$n", $tf);
next;
};
}
for(@gfiles) {
global_chunk($_);
}
if(@ifiles) {
my $initdir = Vend::File::catfile($C->{ConfDir}, 'init', $value);
File::Path::mkpath($initdir) unless -d $initdir;
my $unfile = Vend::File::catfile($initdir, 'uninstall');
## Feature was previously uninstalled, we *do* need to run init
my $ignore = -f $unfile;
if($ignore) {
unlink $unfile
or die errmsg("Couldn't unlink $unfile: $!");
}
for(@ifiles) {
my $fn = $_;
$fn =~ s{^$fdir/}{};
if($ignore) {
unlink "$initdir/$fn"
or die errmsg("Couldn't unlink $fn: $!");
}
next if -f "$initdir/$fn";
$C->{Init} ||= [];
push @{$C->{Init}}, [$_, "$initdir/$fn"];
}
}
#::logDebug("Init=" . ::uneval($C->{Init}));
$c->{$value} = 1;
return $c;
}
sub uninstall_feature {
my ($value) = @_;
my $c = $Vend::Cfg
or die "Not in catalog context.\n";
#::logDebug("Running uninstall for cat=$Vend::Cat, from cfg ref=$c->{CatalogName}");
$value =~ s/^\s+//;
$value =~ s/\s+$//;
my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
unless(-d $fdir) {
config_warn("Feature '%s' not found, skipping.", $value);
return $c;
}
my $etag = errmsg("feature %s uninstall -- ", $value);
# Get the global install files and remove them from the config list
my @gfiles = glob("$fdir/*.global");
my %seen;
@seen{@gfiles} = @gfiles;
# Get the init files and remove them from the config list
my @ifiles = glob("$fdir/*.init");
@seen{@ifiles} = @ifiles;
# Get the uninstall files and remove them from the config list
my @ufiles = glob("$fdir/*.uninstall");
@seen{@ufiles} = @ifiles;
# Any other files are config files
my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
# directories are for copying
my @cdirs = grep -d $_, @cfiles;
my $Tag = new Vend::Tags;
my @copy;
my @errors;
my @warnings;
my $wanted = sub {
return unless -f $_;
my $n = $File::Find::name;
$n =~ s{^$fdir/}{};
my $d = $File::Find::dir;
$d =~ s{^$fdir/}{};
push @copy, [$n, $d];
};
if(@cdirs) {
File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
}
#::logDebug("ufiles=" . ::uneval(\@ufiles));
#::logDebug("ifiles=" . ::uneval(\@ifiles));
#::logDebug("cdirs=" . ::uneval(\@cdirs));
#::logDebug("copy=" . ::uneval(\@copy));
for(@ufiles) {
#::logDebug("Running uninstall file $_");
my $save = $Global::AllowGlobal->{$Vend::Cat};
$Global::AllowGlobal->{$Vend::Cat} = 1;
open UNFILE, "< $_"
or do {
push @errors, $etag . errmsg("error reading %s: %s", $_, $!);
};
my $chunk = join "", <UNFILE>;
close UNFILE;
#::logDebug("uninstall chunk length=" . length($chunk));
my $out;
eval {
$out = Vend::Interpolate::interpolate_html($chunk);
};
if($@) {
push @errors, $etag . errmsg("error running uninstall %s: %s", $_, $@);
}
push @warnings, $etag . errmsg("message from %s: %s", $_, $out)
if $out =~ /\S/;
$Global::AllowGlobal->{$Vend::Cat} = $save;
}
for(@copy) {
my ($n, $d) = @$_;
my $tf = Vend::File::catfile($c->{VendRoot}, $n);
next unless -f $tf;
my $contents1 = Vend::File::readfile($tf);
my $sf = "$fdir/$n";
open UNSRC, "< $sf"
or die $etag . errmsg("Couldn't read uninstall source file %s: %s", $sf, $!);
local $/;
my $contents2 = <UNSRC>;
if($contents1 ne $contents2) {
push @warnings, $etag . errmsg("will not uninstall %s, changed.", $tf);
next;
}
unlink $tf
or do {
push @errors,
$etag . errmsg("$etag couldn't unlink file %s: %s", $tf, $!);
next;
};
my $td = Vend::File::catfile($c->{VendRoot}, $d);
my @left = glob("$td/*");
push @left, glob("$td/.?*");
next if @left;
File::Path::rmtree($td);
}
if(@ifiles) {
#::logDebug("running uninstall touch and init");
my $initdir = Vend::File::catfile($c->{ConfDir}, 'init', $value);
File::Path::mkpath($initdir) unless -d $initdir;
my $fn = Vend::File::catfile($initdir, 'uninstall');
#::logDebug("touching uninstall file $fn");
open UNFILE, ">> $fn"
or die errmsg("Couldn't create uninstall flag file %s: %s", $fn, $!);
print UNFILE $etag . errmsg("uninstalled at %s.\n", scalar(localtime));
close UNFILE;
}
my $errors;
for(@errors) {
$Tag->error({ set => $_});
::logError($_);
$errors++;
}
for(@warnings) {
$Tag->warnings($_);
::logError($_);
}
return ! $errors;
}
# Changes configuration directives into Variable settings, i.e.
# DescriptionField becomes __DescriptionField__, ProductFiles becomes
# __ProductFiles_0__, ProductFiles_1__, etc. Doesn't handle hash keys
# that have non-word chars.
sub parse_autovar {
my($var, $val) = @_;
return '' if ! $val;
my @dirs = grep /\w/, split /[\s,\0]+/, $val;
my $name;
foreach $name (@dirs) {
next unless $name =~ /^\w+$/;
my $val = get_directive($name);
if(! ref $val) {
parse_variable('Variable', "$name $val");
}
elsif ($val =~ /ARRAY/) {
for(my $i = 0; $i < @$val; $i++) {
my $an = "${name}_$i";
parse_variable('Variable', "$an $val->[$i]");
}
}
elsif ($val =~ /HASH/) {
my ($k, $v);
while ( ($k, $v) = each %$val) {
next unless $k =~ /^\w+$/;
parse_variable('Variable', "$k $v");
}
}
else {
config_warn('%s directive not parsable by AutoVariable', $name);
}
}
}
# Checks to see if a globalsub, sub, usertag, or Perl module is present
# If called with a third parameter, is just "suggestion"
# If called with a fourth parameter, is just capability check
sub parse_capability {
return parse_require(@_, 1, 1);
}
sub parse_tag_group {
my ($var, $setting) = @_;
my $c;
if(defined $C) {
$c = $C->{$var} || {};
}
else {
no strict 'refs';
$c = ${"Global::$var"} || {};
}
$setting =~ tr/-/_/;
$setting =~ s/[,\s]+/ /g;
$setting =~ s/^\s+//;
$setting =~ s/\s+$//;
my @pairs = Text::ParseWords::shellwords($setting);
while(@pairs) {
my ($group, $sets) = splice @pairs, 0, 2;
my @sets = grep $_, split /\s+/, $sets;
my @groups = grep /:/, @sets;
@sets = grep $_ !~ /:/, @sets;
for(@groups) {
next unless $c->{$_};
push @sets, @{$c->{$_}};
}
$c->{$group} = \@sets;
}
return $c;
}
my %incmap = qw/TagInclude TagGroup/;
sub parse_tag_include {
my ($var, $setting) = @_;
my $c;
my $g;
my $mapper = $incmap{$var} || 'TagGroup';
if(defined $C) {
$c = $C->{$var} || {};
$g = $C->{$mapper} || {};
}
else {
no strict 'refs';
$c = ${"Global::$var"} || {};
$g = ${"Global::$mapper"} || {};
}
$setting =~ s/"/ /g;
$setting =~ s/^\s+//;
$setting =~ s/\s+$//;
$setting =~ s/[,\s]+/ /g;
if($setting eq 'ALL') {
return { ALL => 1 };
}
delete $c->{ALL};
get_system_groups() unless $SystemGroupsDone;
my @incs = Text::ParseWords::shellwords($setting);
for(@incs) {
my @things;
my $not = 0;
if(/:/) {
$not = 1 if s/^!//;
if(! $g->{$_}) {
config_warn(
"unknown %s %s included from %s",
$mapper,
$_,
$var,
);
}
else {
@things = @{$g->{$_}}
}
}
else {
@things = ($_);
}
for(@things) {
my $not = s/^!// ? ! $not : $not;
$c->{$_} = not $not;
}
}
return $c;
}
sub parse_suggest {
return parse_require(@_, 1);
}
sub parse_require {
my($var, $val, $warn, $cap) = @_;
return if $Vend::ExternalProgram;
return if $Vend::ControllingInterchange;
my $carptype;
my $error_message;
my $pathinfo;
if($val =~ s/\s+"(.*)"//s) {
$error_message = "\a\n\n$1\n";
}
if($val =~ s%\s+((/[\w.-]+)+)%%) {
$pathinfo = $1;
}
if($cap) {
$carptype = sub { return; };
}
elsif($warn) {
$carptype = sub { return parse_message('', @_) };
$error_message = "\a\n\nSuggest %s %s for proper catalog operation. Not all functions will work!\n"
unless $error_message;
}
else {
$carptype = \&config_error;
$error_message ||= 'Required %s %s not present. Aborting '
. ($C ? 'catalog' : 'Interchange daemon') . '.';
}
my $nostrict;
my $perlglobal = 1;
if($C) {
$nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
$perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
}
my $vref = $C ? $C->{Variable} : $Global::Variable;
my $require;
my $testsub = sub { 0 };
my $name;
if($val =~ s/^globalsub\s+//i) {
$require = $Global::GlobalSub;
$name = 'GlobalSub';
}
elsif($val =~ s/^sub\s+//i) {
$require = $C->{Sub};
$name = 'Sub';
}
elsif($val =~ s/^taggroup\s+//i) {
$require = $Global::UserTag->{Routine};
my @groups = grep /\S/, split /[\s,]+/, $val;
my @needed;
my $ref;
for (@groups) {
if($ref = $Global::TagGroup->{$_}) {
push @needed, @$ref;
}
else {
push @needed, $_;
}
}
$name = "TagGroup $val member";
$val = join " ", @needed;
}
elsif($val =~ s/^usertag\s+//i) {
$require = {};
$name = 'UserTag';
$testsub = sub {
my $name = shift;
my @tries = ($Global::UserTag->{Routine});
push(@tries,$C->{UserTag}->{Routine}) if $C;
foreach (@tries) {
return 1 if defined $_->{$name};
}
return 0;
};
}
elsif($val =~ s/^(?:perl)?module\s+//i) {
$require = {};
$name = 'Perl module';
$testsub = sub {
my $module = shift;
my $oldtype = '';
if($module =~ s/\.pl$//) {
$oldtype = '.pl';
}
$module =~ /[^\w:]/ and return undef;
if($perlglobal) {
if ($pathinfo) {
unshift(@INC, $pathinfo);
unshift(@INC, "$pathinfo/$Config{archname}");
}
eval "require $module$oldtype;";
my $error = $@;
if ($pathinfo) {
shift(@INC);
shift(@INC);
}
::logGlobal("while eval'ing module %s got [%s]\n", $module, $error) if $error;
return ! $error;
}
else {
# Since we aren't safe to actually require, we will
# just look for a readable module file
$module =~ s!::!/!g;
$oldtype = '.pm' if ! $oldtype;
my $found;
for(@INC) {
next unless -f "$_/$module$oldtype" and -r _;
$found = 1;
}
return $found;
}
};
}
elsif ($val =~ s/^(?:perl)?include\s+//i) {
my $path = Vend::File::make_absolute_file($val, 1);
$require = {};
$name = 'Perl include path';
$testsub =
sub {
if (-d $path) {
unshift @INC, $path;
return 1;
}
return 0;
};
}
elsif ($val =~ s/^file\s*//i) {
$require = {};
$name = 'Readable file';
$val = $pathinfo unless $val;
$testsub = sub {
my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
if ($C && $path =~ s:^/+::) {
$path = "$C->{VendRoot}/$path";
}
return -r $path;
};
}
elsif ($val =~ s/^executable\s*//i) {
$require = {};
$name = 'Executable file';
$val = $pathinfo unless $val;
$testsub = sub {
my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
if ($C && $path =~ s:^/+::) {
$path = "$C->{VendRoot}/$path";
}
return -x $path;
};
}
my @requires = grep /\S/, split /\s+/, $val;
my $uname = uc $name;
$uname =~ s/.*\s+//;
for(@requires) {
$vref->{"MV_REQUIRE_${uname}_$_"} = 1;
next if defined $require->{$_};
next if $testsub->($_);
delete $vref->{"MV_REQUIRE_${uname}_$_"};
$carptype->( $error_message, $name, $_ );
}
return '';
}
# Sets the special variable remap array
#
my $Varnames;
INITVARS: {
local($/);
$Varnames = <DATA>;
}
sub parse_varname {
my($item,$settings) = @_;
return if $Vend::ExternalProgram;
my($iv,$vn,$k,$v,@set);
#logDebug("parse_varname: $settings");
if(defined $C) {
return '' if ! $settings;
$C->{IV} = { %{$Global::IV} } if ! $C->{IV};
$C->{VN} = { %{$Global::VN} } if ! $C->{VN};
$iv = $C->{IV};
$vn = $C->{VN};
}
else {
if (! $Global::VarName) {
unless (-s "$Global::ConfDir/varnames" && -r _) {
$settings = $Varnames . "\n$settings";
writefile("$Global::ConfDir/varnames", $Varnames);
}
else {
$settings = readfile("$Global::ConfDir/varnames");
}
}
undef $Varnames;
$Global::IV = {} if ! $Global::IV;
$Global::VN = {} if ! $Global::VN;
$iv = $Global::IV;
$vn = $Global::VN;
}
@set = grep /\S/, split /\s+/, $settings;
while( $k = shift @set, $v = shift @set ) {
$vn->{$k} = $v;
$iv->{$v} = $k;
}
return 1;
}
sub parse_word {
my($name, $val) = @_;
return '' unless $val;
unless ($val =~ /^\w+$/) {
config_error("Illegal non-word value in '%s' for %s", $val, $name);
}
return $val;
}
# Allow addition of a new catalog directive
sub parse_directive {
my($name, $val) = @_;
return '' unless $val;
my($dir, $parser, $default) = split /\s+/, $val, 3 ;
if(! defined &{"parse_$parser"} and ! defined &{"$parser"}) {
if (defined $Global::GlobalSub->{"parse_$parser"}) {
no strict 'refs';
*{"Vend::Config::parse_$parser"} = $Global::GlobalSub->{"parse_$parser"};
} else {
$parser = undef;
}
}
$default = '' if ! $default or $default eq 'undef';
$Global::AddDirective = [] unless $Global::AddDirective;
push @$Global::AddDirective, [ $dir, $parser, $default ];
return $Global::AddDirective;
}
# Allow a subcatalog value to completely replace a base value
sub parse_replace {
my($name, $val) = @_;
return {} unless $val;
$C->{$val} = get_catalog_default($val);
$C->{$name}->{$val} = 1;
$C->{$name};
}
# Send a message during configuration, goes to terminal if during
# daemon startup, always goes to error log
sub parse_message {
my($name, $val) = @_;
return '' unless $val;
return 1 if $Vend::Quiet;
my $strip;
my $info_only;
## strip trailing whitespace if -n beins message
while($val =~ s/^-([ni])\s+//) {
$1 eq 'n' and $val =~ s/^-n\s+// and $strip = 1 and $val =~ s/\s+$//;
$info_only = 1 if $1 eq 'i';
}
my $msg = errmsg($val,
$name,
$.,
$configfile,
);
if($info_only and $Global::Foreground) {
print $msg;
}
else {
logGlobal({level => 'info', strip => $strip },
errmsg($val,
$name,
$.,
$configfile,
)
);
}
}
# Warn about directives no longer supported in the configuration file.
sub parse_warn {
my($name, $val) = @_;
return '' unless $val;
::logGlobal({level => 'info'},
errmsg("Directive %s no longer supported at line %s of %s.",
$name,
$.,
$configfile,
)
);
}
# Each of the parse functions accepts the value of a directive from the
# configuration file as a string and either returns the parsed value or
# signals a syntax error.
# Sets a boolean array for any type of item
sub parse_boolean {
my($item,$settings) = @_;
my(@setting) = grep /\S/, split /[\s,]+/, $settings;
my $c;
if(defined $C) {
$c = $C->{$item} || {};
}
else {
no strict 'refs';
$c = ${"Global::$item"} || {};
}
for (@setting) {
$c->{$_} = 1;
}
return $c;
}
# Sets a boolean array, but configurable value with tag=value
sub parse_boolean_value {
my($item,$settings) = @_;
my(@setting) = split /[\s,]+/, $settings;
my $c;
if(defined $C) {
$c = $C->{$item} || {};
}
else {
no strict 'refs';
$c = ${"Global::$item"} || {};
}
for (@setting) {
my ($k,$v);
if(/=/) {
($k,$v) = split /=/, $_, 2;
}
else {
$k = $_;
$v = 1;
}
$c->{$k} = $v;
}
return $c;
}
use POSIX qw(
setlocale localeconv
LC_ALL LC_CTYPE LC_COLLATE
LC_MONETARY LC_NUMERIC LC_TIME
);
# Sets the special locale array. Tries to use POSIX setlocale,
# accepts a 'custom' setting with the proper definitions of
# decimal_point, mon_thousands_sep, and frac_digits (the only supported at
# the moment). Otherwise uses US-English settings if not set.
#
sub parse_locale {
my($item,$settings) = @_;
return ($settings || '') unless $settings =~ /[^\d.]/;
$settings = '' if "\L$settings" eq 'default';
my $name;
my ($c, $store);
if(defined $C) {
$c = $C->{$item} || { };
$C->{$item . "_repository"} = {}
unless $C->{$item . "_repository"};
$store = $C->{$item . "_repository"};
}
else {
no strict 'refs';
$c = ${"Global::$item"} || {};
${"Global::$item" . "_repository"} = {}
unless ${"Global::$item" . "_repository"};
$store = ${"Global::$item" . "_repository"};
}
my ($eval, $safe);
if ($settings =~ s/^\s*([-\w.@]+)(?:\s+)?//) {
$name = $1;
undef $eval;
$settings =~ /^\s*{/
and $settings =~ /}\s*$/
and $eval = 1;
$eval and ! $safe and $safe = new Vend::Safe;
if(! defined $store->{$name} and $item eq 'Locale') {
my $past = POSIX::setlocale(POSIX::LC_ALL);
if(POSIX::setlocale(POSIX::LC_ALL, $name) ) {
$store->{$name} = POSIX::localeconv();
}
POSIX::setlocale(POSIX::LC_ALL, $past);
}
my($sethash);
if ($eval) {
$sethash = $safe->reval($settings)
or config_warn("bad Locale setting in %s: %s", $name, $@),
$sethash = {};
}
else {
$settings =~ s/^\s+//;
$settings =~ s/\s+$//;
$sethash = {};
%{$sethash} = Text::ParseWords::shellwords($settings);
}
$c = $store->{$name} || {};
my $nodefaults = delete $sethash->{MV_LOCALE_NO_DEFAULTS};
for (keys %{$sethash}) {
$c->{$_} = $sethash->{$_};
}
}
else {
config_error("Bad locale setting $settings.\n");
}
$C->{LastLocale} = $name if $C and $item eq 'Locale';
$store->{$name} = $c unless $store->{$name};
return $c;
}
#
# Sets a structure like Locale but with the depth and access via key
# No evaled structure setting, only key-value with shell quoting
#
sub parse_structure {
my ($item, $settings) = @_;
return {} unless $settings;
my $key;
my @rest;
($key, @rest) = Text::ParseWords::shellwords($settings);
my ($c, $e);
if(defined $C) {
$c = $C->{$item};
$e = $c->{$key} || { };
}
else {
no strict 'refs';
$c = ${"Global::$item"};
$e = $c->{$key} || {};
}
while(scalar @rest) {
my $k = shift @rest;
$e->{$k} = shift @rest;
}
$c->{$key} = $e;
return $c;
}
# Sets the special page array
sub parse_special {
my($item,$settings) = @_;
return {} unless $settings;
my(%setting) = grep /\S/, split /[\s,]+/, $settings;
for (keys %setting) {
if($Global::NoAbsolute and file_name_is_absolute($setting{$_}) ) {
config_warn("Absolute file name not allowed: %s", $setting{$_});
next;
}
$C->{$item}{$_} = $setting{$_};
}
return $C->{$item};
}
# Sets up a hash value from a configuration directive, syntax is
#
# Directive "key" "value"
#
# quotes are optional if word-only chars
sub parse_hash {
my($item,$settings) = @_;
if (! $settings) {
return $HashDefaultBlank{$item} ? '' : {};
}
my $c;
if(defined $C) {
$c = $C->{$item} || {};
}
else {
no strict 'refs';
$c = ${"Global::$item"} || {};
}
return hash_string($settings,$c);
}
# Set up illegal values for certain directives
my %IllegalValue = (
AutoModifier => { qw/ mv_mi 1
mv_si 1
mv_ib 1
group 1
code 1
sku 1
quantity 1
item 1 /
},
UseModifier => { qw/ mv_mi 1
mv_si 1
mv_ib 1
group 1
code 1
sku 1
quantity 1
item 1 /
}
);
my @Dispatches;
my @Cleanups;
%Cleanup_priority = (
AutoEnd => 1,
);
%Dispatch_priority = (
CookieLogin => 1,
Locale => 2,
DiscountSpaces => 5,
Autoload => 8,
);
%Cleanup_code = (
AutoEnd => sub {
#::logDebug("Doing AutoEnd dispatch...");
Vend::Dispatch::run_macro($Vend::Cfg->{AutoEnd});
},
);
%Dispatch_code = (
Autoload => sub {
#::logDebug("Doing Autoload dispatch...");
my ($subname, $inspect_sub);
if ($subname = $Vend::Cfg->{SpecialSub}{autoload_inspect}) {
$inspect_sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
}
Vend::Dispatch::run_macro($Vend::Cfg->{Autoload}, undef, $inspect_sub);
},
CookieLogin => sub {
#::logDebug("Doing CookieLogin dispatch....");
if(! $Vend::Session->{logged_in}) {
COOKIELOGIN: {
# Clear password cookie and don't allow automatic login
# if mv_force_session is overriding the session cookie,
# since user may be coming from a sister site where he
# was logged out.
(Vend::Util::read_cookie('MV_PASSWORD')
and Vend::Util::set_cookie('MV_PASSWORD')), last COOKIELOGIN
if $CGI::values{mv_force_session};
my $username;
my $password;
last COOKIELOGIN
if exists $CGI::values{mv_username}
and defined $CGI::values{mv_username};
last COOKIELOGIN
unless $username = Vend::Util::read_cookie('MV_USERNAME');
last COOKIELOGIN
unless $password = Vend::Util::read_cookie('MV_PASSWORD');
$CGI::values{mv_username} = $username;
$CGI::values{mv_password} = $password;
my $profile = Vend::Util::read_cookie('MV_USERPROFILE');
local(%SIG);
undef $SIG{__DIE__};
eval {
Vend::UserDB::userdb('login', profile => $profile );
};
if($@) {
$Vend::Session->{failure} .= $@;
}
}
}
},
Locale => sub {
#::logDebug("Doing Locale dispatch...");
my $locale = $::Scratch->{mv_locale};
my $curr = $::Scratch->{mv_currency};
$locale || $curr or return;
if($locale and ! $::Scratch->{mv_language}) {
$Global::Variable->{LANG}
= $::Variable->{LANG}
= $::Scratch->{mv_language}
= $locale;
}
if($locale) {
return unless defined $Vend::Cfg->{Locale_repository}{$locale};
}
elsif($curr) {
return unless defined $Vend::Cfg->{Locale_repository}{$curr};
}
#::logDebug("running locale dispatch, locale=$locale, currency=$curr");
Vend::Util::setlocale( $locale, $curr, { persist => 1 } );
},
DiscountSpaces => sub {
#::logDebug("Doing DiscountSpaces dispatch...");
$::Discounts
= $Vend::Session->{discount}
= $Vend::Session->{discount_space}{
$Vend::DiscountSpaceName = 'main'
}
||= {};
my $dspace;
for (@{$Vend::Cfg->{DiscountSpaceVar}}) {
next unless $dspace = $CGI::values{$_};
#::logDebug("$_ is set=...");
last;
}
return unless $dspace;
$Vend::DiscountSpaceName = $dspace;
#::logDebug("Discount space is set=$Vend::DiscountSpaceName...");
$::Discounts
= $Vend::Session->{discount}
= $Vend::Session->{discount_space}{$Vend::DiscountSpaceName}
||= {};
},
);
# Set up defaults for certain directives
my $Have_set_global_defaults;
# Set the default search files based on ProductFiles setting
# Honor a NO_SEARCH parameter in the Database structure
# Set MV_DEFAULT_SEARCH_FILE to the {file} entry,
# and set MV_DEFAULT_SEARCH_TABLE to the table name.
#
# Error out if not SubCatalog and can't find a setting.
#
sub set_default_search {
my $setting = $C->{ProductFiles};
if(! $setting) {
return 1 if $C->{BaseCatalog};
return (undef, errmsg("No ProductFiles setting!") );
}
my @fout;
my @tout;
my $nofile;
my $notable;
if ($C->{Variable}{MV_DEFAULT_SEARCH_FILE}) {
@fout =
grep /\S/,
split /[\s,]+/,
$C->{Variable}{MV_DEFAULT_SEARCH_FILE};
$nofile = 1;
for(@fout) {
next if /\./;
next unless exists $C->{Database}{$_};
$_ = $C->{Database}{$_}{file};
}
}
if ($C->{Variable}{MV_DEFAULT_SEARCH_TABLE}) {
@tout =
grep defined $C->{Database}{$_},
split /[\s,]+/,
$C->{Variable}{MV_DEFAULT_SEARCH_TABLE}
;
$notable = 1;
}
for(@$setting) {
next if $C->{Database}{$_}{NO_SEARCH};
push @tout, $_ unless $notable;
next unless defined $C->{Database}{$_}{file};
push @fout, $C->{Database}{$_}{file}
unless $nofile;
}
unless (scalar @fout) {
return 1 if $C->{BaseCatalog};
return (undef, errmsg("No default search file!") );
}
$C->{Variable}{MV_DEFAULT_SEARCH_FILE} = \@fout;
$C->{Variable}{MV_DEFAULT_SEARCH_TABLE} = \@tout;
return 1;
}
%Default = (
## This rather extensive default setting is not typical for IC,
## but performance in pricing routines demands it
Options => sub {
my $o = $C->{Options_repository} ||= {};
my $var = $C->{Variable};
my @base = qw/Simple Matrix Old48/;
my %base;
@base{@base} = @base;
my %seen;
my @types = grep !$seen{$_}++, keys %$o, @base;
for(@types) {
my $loc = $o->{$_} ||= {};
eval "require Vend::Options::$_;";
if($@) {
my $msg = $@;
config_warn(
"Unable to use options type %s, no module. Error: %s",
$_,
$msg,
);
undef