lib/Vend/Config.pm

   1 # Vend::Config - Configure Interchange
   2 #
   3 # Copyright (C) 2002-2011 Interchange Development Group
   4 # Copyright (C) 1996-2002 Red Hat, Inc.
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public
  20 # License along with this program; if not, write to the Free
  21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  22 # MA  02110-1301  USA.
  23
  24 package Vend::Config;
  25 require Exporter;
  26
  27 @ISA = qw(Exporter);
  28
  29 @EXPORT         = qw( config global_config config_named_catalog );
  30
  31 @EXPORT_OK      = qw( get_catalog_default get_global_default parse_time parse_database);
  32
  33 use strict;
  34 no warnings qw(uninitialized numeric);
  35 use vars qw(
  36                         $VERSION $C
  37                         @Locale_directives_ary @Locale_directives_scalar
  38                         @Locale_directives_code %tagCanon
  39                         %ContainerSave %ContainerTrigger %ContainerSpecial %ContainerType
  40                         %Default
  41                         %Dispatch_code %Dispatch_priority
  42                         %Cleanup_code %Cleanup_priority
  43                         @Locale_directives_currency @Locale_keys_currency
  44                         $GlobalRead  $SystemCodeDone $SystemGroupsDone $CodeDest
  45                         $SystemReposDone $ReposDest @include
  46                         );
  47 use Vend::Safe;
  48 use Fcntl;
  49 use Vend::Parse;
  50 use Vend::Util;
  51 use Vend::File;
  52 use Vend::Data;
  53 use Vend::Cron;
  54 use Vend::CharSet ();
  55
  56 $VERSION = '2.247';
  57
  58 my %CDname;
  59 my %CPname;
  60 %ContainerType = (
  61         yesno => sub {
  62                 my ($var, $value, $end) = @_;
  63                 $var = $CDname{lc $var};
  64                 if($end) {
  65                         my $val = delete $ContainerSave{$var};
  66                         no strict 'refs';
  67                         if($C) {
  68                                 $C->{$var} = $val;
  69                         }
  70                         else {
  71                                 ${"Global::$var"} = $val;
  72
  73                         }
  74                 }
  75                 else {
  76                         no strict 'refs';
  77                         $ContainerSave{$var} = $C ? $C->{$var} : ${"Global::$var"};
  78                         $ContainerSave{$var} ||= 'No';
  79                 }
  80         },
  81 );
  82
  83 my %DirectiveAlias = qw(
  84         URL            VendURL
  85         DataDir        ProductDir
  86         DefaultTables  ProductFiles
  87         Profiles       OrderProfile
  88 );
  89
  90 for( qw(search refresh cancel return secure unsecure submit control checkout) ) {
  91         $Global::LegalAction{$_} = 1;
  92 }
  93
  94 @Locale_directives_currency = (
  95 qw/
  96                 CommonAdjust
  97                 PriceCommas
  98                 PriceDivide
  99                 PriceField
 100                 PriceDefault
 101                 SalesTax
 102                 Levies
 103                 TaxShipping
 104                 TaxInclusive
 105 /       );
 106
 107 @Locale_keys_currency = (
 108 qw/
 109         currency_symbol
 110         frac_digits
 111         int_curr_symbol
 112         int_currency_symbol
 113         int_frac_digits
 114         mon_decimal_point
 115         mon_grouping
 116         price_picture
 117         mon_thousands_sep
 118         n_cs_precedes
 119         negative_sign
 120         p_cs_precedes
 121         p_sep_by_space
 122         positive_sign
 123
 124 /   );
 125
 126 @Locale_directives_scalar = (
 127 qw/
 128                 AutoEnd
 129                 Autoload
 130                 CategoryField
 131                 CommonAdjust
 132                 DescriptionField
 133                 HTMLsuffix
 134                 ImageDir
 135                 ImageDirSecure
 136                 PageDir
 137                 Preload
 138                 PriceCommas
 139                 PriceDefault
 140                 PriceDivide
 141                 PriceField
 142                 SalesTax
 143                 SpecialPageDir
 144                 TaxShipping
 145                 TaxInclusive
 146 /   );
 147
 148 @Locale_directives_ary = (
 149 qw/
 150         AutoModifier
 151         Levies
 152         ProductFiles
 153         UseModifier
 154 /   );
 155
 156 # These are extra routines that are run if certain directives are
 157 # updated
 158 # Form:
 159 #
 160 # [ 'Directive', \&routine, [ @args ] ],
 161 #
 162 # @args are optional.
 163 #
 164 @Locale_directives_code = (
 165         [ 'ProductFiles', \&Vend::Data::update_productbase ],
 166 );
 167
 168 my %HashDefaultBlank = (qw(
 169                                         SOAP                    1
 170                                         Mail                    1
 171                                         Accounting              1
 172                                         Levy                    1
 173                                 ));
 174
 175 my %DumpSource = (qw(
 176                                         SpecialPage                     1
 177                                         GlobalSub                       1
 178                                 ));
 179
 180 my %DontDump = (qw(
 181                                         GlobalSub                       1
 182                                         SpecialPage                     1
 183                                 ));
 184
 185 my %UseExtended = (qw(
 186                                         Catalog                         1
 187                                         SubCatalog                      1
 188                                         Variable                        1
 189                                 ));
 190
 191 my %InitializeEmpty = (qw(
 192                                         FileControl                     1
 193                                 ));
 194
 195 my %AllowScalarAction = (qw(
 196                                         FileControl                     1
 197                                         SOAP_Control            1
 198                                 ));
 199
 200 my @External_directives = qw(
 201         CatalogName
 202         ScratchDefault
 203         ValuesDefault
 204         ScratchDir
 205         SessionDB
 206         SessionDatabase
 207         SessionExpire
 208         VendRoot
 209         VendURL
 210         SecureURL
 211         Variable->SQLDSN
 212         Variable->SQLPASS
 213         Variable->SQLUSER
 214 );
 215
 216 my %extmap = qw/
 217         ia      ItemAction
 218         fa      FormAction
 219         am      ActionMap
 220         oc      OrderCheck
 221         ut      UserTag
 222         fi      Filter
 223         so      SearchOp
 224         fw      Widget
 225         lc      LocaleChange
 226         tag     UserTag
 227         ct      CoreTag
 228         jsc     JavaScriptCheck
 229 /;
 230
 231 for( values %extmap ) {
 232         $extmap{lc $_} = $_;
 233 }
 234
 235 %tagCanon = ( qw(
 236
 237         group                   Group
 238         actionmap               ActionMap
 239         arraycode               ArrayCode
 240         hashcode                HashCode
 241         coretag                 CoreTag
 242         searchop                SearchOp
 243         localechange    LocaleChange
 244         filter                  Filter
 245         formaction              FormAction
 246         ordercheck              OrderCheck
 247         usertag                 UserTag
 248         systemtag               SystemTag
 249         widget                  Widget
 250
 251         alias                   Alias
 252         addattr                 addAttr
 253         attralias               attrAlias
 254         attrdefault             attrDefault
 255         cannest                 canNest
 256         description     Description
 257         override                Override
 258         visibility      Visibility
 259         help                    Help
 260         documentation   Documentation
 261         extrameta               ExtraMeta
 262         gobble                  Gobble
 263         hasendtag               hasEndTag
 264         implicit                Implicit
 265         interpolate             Interpolate
 266         invalidatecache InvalidateCache
 267         isendanchor             isEndAnchor
 268         multiple                Multiple
 269         norearrange             noRearrange
 270         order                   Order
 271         posnumber               PosNumber
 272         posroutine              PosRoutine
 273         maproutine              MapRoutine
 274         noreparse               NoReparse
 275         javascriptcheck JavaScriptCheck
 276         required                Required
 277         routine                 Routine
 278         version                 Version
 279 ));
 280
 281 my %tagSkip = ( qw! Documentation 1 Version 1 !);
 282
 283 my %tagAry      = ( qw! Order 1 Required 1 ! );
 284 my %tagHash     = ( qw!
 285                                 attrAlias   1
 286                                 Implicit    1
 287                                 attrDefault     1
 288                                 ! );
 289 my %tagBool = ( qw!
 290                                 ActionMap   1
 291                                 addAttr     1
 292                                 canNest     1
 293                                 Filter      1
 294                                 FormAction  1
 295                                 hasEndTag   1
 296                                 Interpolate 1
 297                                 isEndAnchor 1
 298                                 isOperator  1
 299                                 Multiple    1
 300                                 ItemAction  1
 301                                 noRearrange 1
 302                                 NoReparse   1
 303                                 OrderCheck  1
 304                                 UserTag     1
 305                                 ! );
 306
 307 my %current_dest;
 308 my %valid_dest = qw/
 309                                         actionmap        ActionMap
 310                                         coretag          UserTag
 311                                         filter           Filter
 312                                         formaction       FormAction
 313                                         itemaction       ItemAction
 314                                         ordercheck       OrderCheck
 315                                         localechange     LocaleChange
 316                                         usertag          UserTag
 317                                         hashcode         HashCode
 318                                         arraycode        ArrayCode
 319                                         searchop                 SearchOp
 320                                         widget           Widget
 321                                         javascriptcheck  JavaScriptCheck
 322                                 /;
 323
 324
 325 my $StdTags;
 326
 327 use vars qw/ $configfile /;
 328
 329 ### This is unset when interchange script is run, so that the default
 330 ### when used by an external program is not to compile subroutines
 331 $Vend::ExternalProgram = 1;
 332
 333 # Report a fatal error in the configuration file.
 334 sub config_error {
 335         my $msg = shift;
 336         if(@_) {
 337                 $msg = errmsg($msg, @_);
 338         }
 339
 340         local($^W);
 341         if ($configfile) {
 342                 $msg = errmsg("%s\nIn line %s of the configuration file '%s':\n%s\n",
 343                         $msg,
 344                         $.,
 345                         $configfile,
 346                         $Vend::config_line,
 347                 );
 348         }
 349
 350         if ($Vend::ExternalProgram) {
 351                 warn "$msg\n" unless $Vend::Quiet;
 352         }
 353         else {
 354                 die "$msg\n";
 355         }
 356 }
 357
 358 sub config_warn {
 359         my $msg = shift;
 360         if(@_) {
 361                 $msg = errmsg($msg, @_);
 362         }
 363
 364         local($^W);
 365         my $extra = '';
 366         if($configfile and $Vend::config_line) {
 367                 $extra = errmsg(
 368                                 "\nIn line %s of the configuration file '%s':\n%s\n",
 369                                                 $msg,
 370                                                 $.,
 371                                                 $configfile,
 372                                                 $Vend::config_line,
 373         );
 374         }
 375
 376         ::logGlobal({level => 'notice'}, "$msg$extra");
 377 }
 378
 379 sub setcat {
 380         $C = $_[0] || $Vend::Cfg;
 381 }
 382
 383 sub global_directives {
 384
 385         my $directives = [
 386 #   Order is not really important, catalogs are best first
 387
 388 #   Directive name      Parsing function    Default value
 389
 390         ['RunDir',                       'root_dir',             $Global::RunDir || 'etc'],
 391         ['DebugFile',            'root_dir',             ''],
 392         ['CatalogUser',          'hash',                         ''],
 393         ['ConfigDir',             undef,                 'etc/lib'],
 394         ['FeatureDir',           'root_dir',         'features'],
 395         ['ConfigDatabase',       'config_db',        ''],
 396         ['ConfigAllBefore',      'root_dir_array',       'catalog_before.cfg'],
 397         ['ConfigAllAfter',       'root_dir_array',       'catalog_after.cfg'],
 398         ['Message',          'message',           ''],
 399         ['Capability',           'capability',           ''],
 400         ['Require',                      'require',                      ''],
 401         ['Suggest',                      'suggest',                      ''],
 402         ['VarName',          'varname',           ''],
 403         ['Windows',          undef,               $Global::Windows || ''],
 404         ['LockType',         undef,               $Global::Windows ? 'none' : ''],
 405         ['DumpStructure',        'yesno',            'No'],
 406         ['DumpAllCfg',       'yesno',                'No'],
 407         ['DisplayErrors',    'yesno',            'No'],
 408         ['DeleteDirective', sub {
 409                                                         my $c = $Global::DeleteDirective || {};
 410                                                         shift;
 411                                                         my @sets = map { lc $_ } split /[,\s]+/, shift;
 412                                                         @{$c}{@sets} = map { 1 } @sets;
 413                                                         return $c;
 414                                                  },            ''],
 415         ['Inet_Mode',         'yesno',            (
 416                                                                                                 defined $Global::Inet_Mode
 417                                                                                                 ||
 418                                                                                                 defined $Global::Unix_Mode
 419                                                                                                 )
 420                                                                                                 ? ($Global::Inet_Mode || 0) : 'No'],
 421         ['Unix_Mode',         'yesno',            (
 422                                                                                                 defined $Global::Inet_Mode
 423                                                                                                 ||
 424                                                                                                 defined $Global::Unix_Mode
 425                                                                                                 )
 426                                                                                                 ? ($Global::Unix_Mode || 0) : 'Yes'],
 427         ['TcpMap',           'hash',             ''],
 428         ['CodeRepository',   'root_dir',         ''],
 429         ['AccumulateCode',   'yesno',            'No'],
 430         ['Environment',      'array',            ''],
 431         ['TcpHost',           undef,             'localhost 127.0.0.1'],
 432         ['AcceptRedirect',       'yesno',                        'No'],
 433         ['SendMailProgram',  'executable',               [
 434                                                                                                 $Global::SendMailLocation,
 435                                                                                            '/usr/sbin/sendmail',
 436                                                                                            '/usr/lib/sendmail',
 437                                                                                            'Net::SMTP',
 438                                                                                           ]
 439                                                                                   ],
 440         ['EncryptProgram',  'executable',                [ 'gpg', 'pgpe', 'none', ] ],
 441         ['PIDfile',              'root_dir',         "etc/$Global::ExeName.pid"],
 442         ['SocketFile',           'root_dir_array',   ''],
 443         ['SocketPerms',      'integer',          0600],
 444         ['SocketReadTimeout','integer',          1],
 445         ['SOAP',             'yesno',            'No'],
 446         ['SOAP_Socket',       'array',            ''],
 447         ['SOAP_Perms',        'integer',          0600],
 448         ['MaxRequestsPerChild','integer',           50],
 449         ['ChildLife',         'time',             0],
 450         ['StartServers',      'integer',          0],
 451         ['PreFork',                   'yesno',            0],
 452         ['PreForkSingleFork', 'yesno',            0],
 453         ['SOAP_MaxRequests', 'integer',           50],
 454         ['SOAP_StartServers', 'integer',          1],
 455         ['SOAP_Control',     'action',           ''],
 456         ['Jobs',                         'hash',                 'MaxLifetime 600 MaxServers 1 UseGlobal 0'],
 457         ['IPCsocket',            'root_dir',         'etc/socket.ipc'],
 458         ['HouseKeeping',     'time',          60],
 459         ['HouseKeepingCron', 'cron',          ''],
 460         ['Mall',                  'yesno',           'No'],
 461         ['TagGroup',             'tag_group',            $StdTags],
 462         ['ConfigParseComments',          'warn',                 ''],
 463         ['TagInclude',           'tag_include',          'ALL'],
 464         ['ActionMap',            'action',                       ''],
 465         ['FileControl',          'action',                       ''],
 466         ['FormAction',           'action',                       ''],
 467         ['MaxServers',       'integer',          10],
 468         ['GlobalSub',            'subroutine',       ''],
 469         ['Database',             'database',         ''],
 470         ['FullUrl',                      'yesno',            'No'],
 471         ['FullUrlIgnorePort', 'yesno',           'No'],
 472         ['Locale',                       'locale',            ''],
 473         ['HitCount',             'yesno',            'No'],
 474         ['IpHead',                       'yesno',            'No'],
 475         ['IpQuad',                       'integer',          '1'],
 476         ['TagDir',               'root_dir_array',       'code'],
 477         ['TemplateDir',      'root_dir_array',   ''],
 478         ['DebugTemplate',    undef,              ''],
 479         ['DomainTail',           'yesno',            'Yes'],
 480         ['CountrySubdomains','hash',             ''],
 481         ['TrustProxy',           'list_wildcard_full', ''],
 482         ['AcrossLocks',          'yesno',            'No'],
 483     ['DNSBL',            'array',            ''],
 484         ['NotRobotUA',           'list_wildcard',      ''],
 485         ['RobotUA',                      'list_wildcard',      ''],
 486         ['RobotIP',                      'list_wildcard_full', ''],
 487         ['RobotHost',            'list_wildcard_full', ''],
 488         ['HostnameLookups',      'yesno',            'No'],
 489         ['TolerateGet',          'yesno',            'No'],
 490         ['PIDcheck',             'time',          '0'],
 491         ['LockoutCommand',    undef,             ''],
 492         ['SafeUntrap',       'array',            'ftfile sort'],
 493         ['SafeTrap',         'array',            ':base_io'],
 494         ['NoAbsolute',           'yesno',                        'No'],
 495         ['AllowGlobal',          'boolean',                      ''],
 496         ['PerlNoStrict',         'boolean',                      ''],
 497         ['PerlAlwaysGlobal', 'boolean',                  ''],
 498         ['AddDirective',         'directive',            ''],
 499         ['UserTag',                      'tag',                          ''],
 500         ['CodeDef',                      'mapped_code',          ''],
 501         ['HotDBI',                       'boolean',                      ''],
 502         ['HammerLock',           'time',         30],
 503         ['DataTrace',            'integer',              0],
 504         ['ShowTimes',            'yesno',                0],
 505         ['ErrorFile',            'root_dir',         undef],
 506         ['SysLog',                       'hash',             undef],
 507         ['Logging',                      'integer',              0],
 508         ['CheckHTML',             undef,             ''],
 509         ['UrlSepChar',           'url_sep_char',     '&'],
 510         ['Variable',             'variable',             ''],
 511         ['Profiles',             'profile',              ''],
 512         ['Catalog',                      'catalog',              ''],
 513         ['SubCatalog',           'catalog',              ''],
 514         ['AutoVariable',         'autovar',              'UrlJoiner'],
 515         ['XHTML',                        'yesno',                'No'],
 516         ['UTF8',                         'yesno',                $ENV{MINIVEND_DISABLE_UTF8} ? 'No' : 'Yes'],
 517         ['External',             'yesno',                'No'],
 518         ['ExternalFile',         'root_dir',         "$Global::RunDir/external.structure"],
 519         ['ExternalExport',       undef,                          'Global::Catalog=Catalog'],
 520         ['DowncaseVarname',   undef,           ''],
 521
 522         ];
 523         return $directives;
 524 }
 525
 526
 527 sub catalog_directives {
 528
 529         my $directives = [
 530 #   Order is somewhat important, the first 6 especially
 531
 532 #   Directive name      Parsing function    Default value
 533
 534         ['ErrorFile',        'relative_dir',     'error.log'],
 535         ['ActionMap',            'action',                       ''],
 536         ['FileControl',          'action',                       ''],
 537         ['FormAction',           'action',                       ''],
 538         ['ItemAction',           'action',                       ''],
 539         ['PageDir',          'relative_dir',     'pages'],
 540         ['SpecialPageDir',   undef,                      'special_pages'],
 541         ['ProductDir',       'relative_dir',     'products'],
 542         ['OfflineDir',       'relative_dir',     'offline'],
 543         ['ConfDir',          'relative_dir',     'etc'],
 544         ['RunDir',           'relative_dir',     ''],
 545         ['ConfigDir',        'relative_dir',     'config'],
 546         ['TemplateDir',      'dir_array',                ''],
 547         ['ConfigDatabase',       'config_db',        ''],
 548         ['Require',                      'require',                      ''],
 549         ['Suggest',                      'suggest',                      ''],
 550         ['Message',          'message',           ''],
 551         ['Variable',             'variable',             ''],
 552         ['VarName',          'varname',           ''],
 553         ['Limit',                        'hash',    'option_list 5000 chained_cost_levels 32 robot_expire 1'],
 554         ['ScratchDefault',       'hash',                 ''],
 555         ['Profile',                      'locale',               ''],
 556         ['ValuesDefault',        'hash',                 ''],
 557         ['ProductFiles',         'array_complete',  'products'],
 558         ['PageTables',           'array_complete',  ''],
 559         ['PageTableMap',         'hash',                        qq{
 560                                                                                                 expiration_date expiration_date
 561                                                                                                 show_date       show_date
 562                                                                                                 page_text       page_text
 563                                                                                                 base_page       base_page
 564                                                                                                 code            code
 565                                                                                         }],
 566         ['DisplayErrors',    'yesno',            'No'],
 567         ['ParseVariables',       'yesno',            'No'],
 568         ['SpecialPage',          'special', 'order ord/basket results results search results flypage flypage'],
 569         ['DirectoryIndex',       undef,                          ''],
 570         ['Sub',                          'subroutine',       ''],
 571         ['VendURL',          'url',              undef],
 572         ['SecureURL',        'url',              undef],
 573         ['PostURL',          'url',              ''],
 574         ['SecurePostURL',    'url',              ''],
 575         ['ProcessPage',      undef,              'process'],
 576         ['History',          'integer',          0],
 577         ['OrderReport',      undef,                      'etc/report'],
 578         ['ScratchDir',       'relative_dir',     'tmp'],
 579         ['PermanentDir',     'relative_dir',     'perm'],
 580         ['SessionDB',            undef,                  ''],
 581         ['SessionType',          undef,                  'File'],
 582         ['SessionDatabase',  'relative_dir',     'session'],
 583         ['ConfigParseComments',          'warn',                 ''],
 584         ['SessionLockFile',  undef,                      'etc/session.lock'],
 585         ['MoreDB',                       'yesno',                'No'],
 586         ['DatabaseDefault',  'hash',             ''],
 587         ['DatabaseAuto',         'dbauto',               ''],
 588         ['DatabaseAutoIgnore',   'regex',                ''],
 589         ['Database',             'database',             ''],
 590         ['Preload',          'routine_array',    ''],
 591         ['Autoload',             'routine_array',        ''],
 592         ['AutoEnd',                      'routine_array',        ''],
 593         ['Replace',                      'replace',              ''],
 594         ['Member',                       'variable',             ''],
 595         ['Feature',          'feature',          ''],
 596         ['WritePermission',  'permission',       'user'],
 597         ['ReadPermission',   'permission',       'user'],
 598         ['SessionExpire',    'time',             '1 hour'],
 599         ['SaveExpire',       'time',             '30 days'],
 600         ['MailOrderTo',      undef,              ''],
 601         ['SendMailProgram',  'executable',              $Global::SendMailProgram],
 602         ['PGP',              undef,                      ''],
 603 # GLIMPSE
 604         ['Glimpse',          'executable',       ''],
 605 # END GLIMPSE
 606         ['Locale',           'locale',           ''],
 607         ['Route',            'locale',           ''],
 608         ['LocaleDatabase',   'configdb',         ''],
 609         ['ExecutionLocale',   undef,             'C'],
 610         ['DefaultLocale',     undef,             ''],
 611         ['RouteDatabase',     'configdb',        ''],
 612         ['DirectiveDatabase', 'dbconfig',        ''],
 613         ['VariableDatabase',  'dbconfig',        ''],
 614         ['DirConfig',         'dirconfig',        ''],
 615         ['FileDatabase',         undef,                          ''],
 616         ['NoSearch',         'wildcard',         'userdb'],
 617         ['AllowRemoteSearch',    'array_complete',     'products variants options'],
 618         ['OrderCounter',         undef,              ''],
 619         ['MimeType',         'hash',             ''],
 620         ['AliasTable',           undef,              ''],
 621         ['ImageAlias',           'hash',             ''],
 622         ['TableRestrict',        'hash',             ''],
 623         ['Filter',                       'hash',             ''],
 624         ['ImageDirSecure',   undef,                  ''],
 625         ['ImageDirInternal', undef,                  ''],
 626         ['ImageDir',             undef,              ''],
 627         ['DeliverImage',     'yesno',                    'no'],
 628         ['SpecialSub',       'hash',                     ''],
 629         ['SetGroup',             'valid_group',      ''],
 630         ['UseModifier',          'array',            ''],
 631         ['AutoModifier',         'array',            ''],
 632         ['MaxQuantityField', undef,                  ''],
 633         ['MinQuantityField', undef,                  ''],
 634         ['LogFile',               undef,             'etc/log'],
 635         ['Pragma',                       'boolean_value',    ''],
 636         ['NoExport',             'boolean',                      ''],
 637         ['NoExportExternal', 'yesno',                    'no'],
 638         ['NoImport',             'boolean',              ''],
 639         ['NoImportExternal', 'yesno',            'no'],
 640         ['CommonAdjust',         undef,                  ''],
 641         ['PriceDivide',          undef,                  1],
 642         ['PriceCommas',          'yesno',            'Yes'],
 643         ['OptionsEnable',        undef,              ''],
 644         ['OptionsAttribute', undef,                  ''],
 645         ['Options',                      'locale',           ''],
 646         ['AlwaysSecure',         'boolean',          ''],
 647         ['Password',         undef,              ''],
 648         ['AdminSub',             'boolean',                      ''],
 649         ['ExtraSecure',          'yesno',            'No'],
 650         ['FallbackIP',           'yesno',            'No'],
 651         ['WideOpen',             'yesno',            'No'],
 652         ['Promiscuous',          'yesno',            'No'],
 653         ['Cookies',                      'yesno',            'Yes'],
 654         ['CookieName',           undef,              ''],
 655         ['CookiePattern',        'regex',            '[-\w:.]+'],
 656         ['CookieLogin',      'yesno',            'No'],
 657         ['CookieDomain',     undef,              ''],
 658         ['MasterHost',           undef,              ''],
 659         ['UserTag',                      'tag',                  ''],
 660         ['CodeDef',                      'mapped_code',          ''],
 661         ['RemoteUser',           undef,              ''],
 662         ['TaxShipping',          undef,              ''],
 663         ['TaxInclusive',     'yesno',                    'No'],
 664         ['FractionalItems',  'yesno',                    'No'],
 665         ['SeparateItems',    'yesno',                    'No'],
 666         ['PageSelectField',  undef,                  ''],
 667         ['NonTaxableField',  undef,                  ''],
 668         ['CreditCardAuto',       'yesno',            'No'],
 669         ['FormIgnore',       'boolean',              ''],
 670         ['EncryptProgram',       undef,              $Global::EncryptProgram || ''],
 671         ['EncryptKey',           undef,              ''],
 672         ['AsciiTrack',           undef,              ''],
 673         ['TrackFile',            undef,              ''],
 674         ['TrackPageParam',       'hash',             ''],
 675         ['TrackDateFormat',      undef,              ''],
 676         ['SalesTax',             undef,              ''],
 677         ['SalesTaxFunction', undef,                  ''],
 678         ['StaticDir',            undef,              ''],
 679         ['SOAP',                         'yesno',                        'No'],
 680         ['SOAP_Enable',          'hash',                         ''],
 681         ['SOAP_Action',          'action',                       ''],
 682         ['SOAP_Control',     'action',             ''],
 683         ['UserDB',                       'locale',               ''],
 684         ['UserControl',          'yesno',                'No'],
 685         ['UserDatabase',         undef,                  ''],
 686         ['RobotLimit',           'integer',                   0],
 687         ['OrderLineLimit',       'integer',                   0],
 688         ['RedirectCache',        undef,                          ''],
 689         ['HTMLsuffix',       undef,                  '.html'],
 690         ['CustomShipping',       undef,              ''],
 691         ['DefaultShipping',      undef,              'default'],
 692         ['UpsZoneFile',          undef,              ''],
 693         ['OrderProfile',         'profile',              ''],
 694         ['SearchProfile',        'profile',              ''],
 695         ['OnFly',                        undef,              ''],
 696         ['CategoryField',    undef,              'category'],
 697         ['DescriptionField', undef,              'description'],
 698         ['PriceDefault',         undef,              'price'],
 699         ['PriceField',           undef,              'price'],
 700         ['DiscountSpacesOn', 'yesno',            'no'],
 701         ['DiscountSpaceVar', 'array',            'mv_discount_space'],
 702         ['Jobs',                         'hash',                 ''],
 703         ['Shipping',         'locale',           ''],
 704         ['Accounting',           'locale',               ''],
 705         ['Levies',                       'array',                ''],
 706         ['Levy',                         'locale',               ''],
 707         ['AutoVariable',         'autovar',              ''],
 708         ['ErrorDestination', 'hash',             ''],
 709         ['XHTML',                        'yesno',                $Global::XHTML],
 710         ['External',             'yesno',                'No'],
 711         ['ExternalExport',       undef,                  join " ", @External_directives],
 712         ['CartTrigger',          'routine_array',        ''],
 713         ['CartTriggerQuantity', 'yesno',                 'no'],
 714     ['UserTrack',        'yesno',            'no'],
 715         ['DebugHost',        'ip_address_regexp',       ''],
 716         ['BounceReferrals',  'yesno',            'no'],
 717         ['BounceReferralsRobot', 'yesno',        'no'],
 718         ['BounceRobotSessionURL',                'yesno', 'no'],
 719         ['OrderCleanup',     'routine_array',    ''],
 720         ['SessionCookieSecure', 'yesno',         'no'],
 721         ['SessionHashLength', 'integer',         1],
 722         ['SessionHashLevels', 'integer',         2],
 723         ['SourcePriority', 'array_complete', 'mv_pc mv_source'],
 724         ['SourceCookie', sub { &parse_ordered_attributes(@_, [qw(name expire domain path secure)]) }, '' ],
 725
 726         ];
 727
 728         push @$directives, @$Global::AddDirective
 729                 if $Global::AddDirective;
 730         return $directives;
 731 }
 732
 733 sub get_parse_routine {
 734         my $parse = shift
 735                 or return undef;
 736         my $routine;
 737         my $rname = $parse;
 738         if(ref $parse eq 'CODE') {
 739                 $routine = $parse;
 740         }
 741         elsif( $parse =~ /^\w+$/) {
 742                 no strict 'refs';
 743                 $routine = \&{'parse_' . $parse};
 744                 $rname = "parse_$rname";
 745         }
 746         else {
 747                 no strict 'refs';
 748                 $routine = \&{"$parse"};
 749         }
 750
 751         if(ref($routine) ne 'CODE') {
 752                 config_error('Unknown parse routine %s', $rname);
 753         }
 754
 755         return $routine;
 756
 757 }
 758
 759 sub global_chunk {
 760         my ($fn) = @_;
 761
 762         my $save_c = $C;
 763         undef $C;
 764
 765         local $/;
 766         $/ = "\n";
 767
 768
 769         open GCHUNK, "< $fn"
 770                 or config_error("read global chunk %s: %s", $fn, $!);
 771
 772 #::logDebug("GCHUNK length: " . -s $fn);
 773         while(<GCHUNK>) {
 774                 my $line = $_;
 775                 my($lvar, $value) = read_config_value($_, \*GCHUNK);
 776                 next unless $lvar;
 777                 eval {
 778                         $GlobalRead->($lvar, $value);
 779                 };
 780                 if($@ =~ /Duplicate\s+usertag/i) {
 781                         next;
 782                 }
 783                 if($@) {
 784                         ::logDebug("error running global $lvar: $@");
 785                 }
 786         }
 787     close GCHUNK;
 788
 789         Vend::Dispatch::update_global_actions();
 790         finalize_mapped_code();
 791
 792         $C = $save_c;
 793         return 1;
 794 }
 795
 796 sub code_from_file {
 797         my ($area, $name, $nohup) = @_;
 798         my $c;
 799         my $fn;
 800 #::logDebug("code_from_file $area, $name");
 801         return unless $c = $Global::TagLocation->{$area};
 802 #::logDebug("We have a repos for $area");
 803         return unless $fn = $c->{$name};
 804 #::logDebug("code_from_file found file=$fn");
 805
 806 #::logDebug("master reading in new area=$area name=$name fn=$fn") if $nohup;
 807
 808         local $/;
 809         $/ = "\n";
 810
 811         undef $C;
 812
 813         my $tdir = $Global::TagDir->[0];
 814         my $accdir = "$tdir/Accumulated";
 815
 816         my $newfn = $fn;
 817         $newfn =~ s{^$Global::CodeRepository/*}{};
 818
 819         my $lfile = "$accdir/$newfn";
 820         my $ldir = $lfile;
 821         $ldir =~ s{/[^/]+$}{};
 822         unless(-d $ldir) {
 823                 die "Supposed directory $ldir is a file" if -e $ldir;
 824                 File::Path::mkpath($ldir)
 825                         or die "Cannot create directory $ldir: $!";
 826         }
 827
 828         my $printnew;
 829         if(-f $lfile) {
 830                 ## This has already been submitted for master integration, no
 831                 ## need to do it
 832                 $nohup = 1;
 833         }
 834         else {
 835                 open NEWTAG, ">> $lfile"
 836                         or die "Cannot write new tag file $lfile: $!";
 837                 if (lockfile(\*NEWTAG, 1, 0)) {
 838                         ## We got a lock, we are the only one
 839                         File::Copy::copy($fn, $lfile);
 840                         unlockfile(\*NEWTAG);
 841                         close NEWTAG;
 842                 }
 843                 else {
 844                         ## No lock, some other process doing same thing
 845                 }
 846         }
 847
 848         open SYSTAG, "< $fn"
 849                 or config_error("read system tag file %s: %s", $fn, $!);
 850
 851         while(<SYSTAG>) {
 852                 my $line = $_;
 853                 my($lvar, $value) = read_config_value($_, \*SYSTAG);
 854                 next unless $lvar;
 855                 eval {
 856                         $GlobalRead->($lvar, $value);
 857                 };
 858                 if($@ =~ /Duplicate\s+usertag/i) {
 859                         next;
 860                 }
 861         }
 862     close SYSTAG;
 863     close NEWTAG;
 864
 865         finalize_mapped_code($area);
 866
 867         my $precursor = '';
 868         my $routine;
 869         my $init;
 870         if($area eq 'UserTag') {
 871                 $init = $Global::UserTag->{Bootstrap}{$name};
 872                 $routine = $Global::UserTag->{Routine}{$name};
 873 #::logDebug("NO ROUTINE FOR area=$area name=$name") unless $routine;
 874         }
 875         else {
 876                 $precursor = 'CodeDef ';
 877                 $init = $Global::CodeDef->{$area}{Bootstrap}{$name};
 878                 $routine = $Global::CodeDef->{$area}{Routine}{$name};
 879                 if(! $routine) {
 880                         no strict 'refs';
 881                         $routine = $Global::CodeDef->{$area}{MapRoutine}{$name}
 882                                 and $routine = \&{"$routine"};
 883                 }
 884 #::logDebug("area=$area name=$name now=" . ::uneval($Global::CodeDef->{$area}));
 885         }
 886
 887         if($init and ref($routine) eq 'CODE') {
 888                 ## Attempt to initialize
 889                 $init = get_option_hash($init);
 890                 $routine->($init);
 891         }
 892
 893
 894         ## Tell the master server we have a new tag
 895         unless($nohup) {
 896 #::logDebug("notifying master of new area=$area name=$name fn=$fn");
 897                 ## Bring this tag in global
 898                 open(RESTART, ">>$Global::RunDir/restart")
 899                                 or die "open $Global::RunDir/restart: $!\n";
 900                 lockfile(\*RESTART, 1, 1)
 901                                 or die "lock $Global::RunDir/restart: $!\n";
 902                 print RESTART "$precursor$area $name\n";
 903                 unlockfile(\*RESTART)
 904                                 or die "unlock $Global::RunDir/restart: $!\n";
 905                 close RESTART;
 906                 kill 'HUP', $Vend::MasterProcess;
 907         }
 908
 909 #::logDebug("routine=$routine for area=$area name=$name");
 910 #::logDebug("REF IS=" . ::uneval($Global::UserTag)) if $nohup;
 911         return $routine;
 912 }
 913
 914 sub set_directive {
 915         my ($directive, $value, $global) = @_;
 916         my $directives;
 917
 918         if($global)     { $directives = global_directives(); }
 919         else            { $directives = catalog_directives(); }
 920
 921         my ($d, $dir, $parse);
 922         no strict 'refs';
 923         foreach $d (@$directives) {
 924                 next unless (lc $directive) eq (lc $d->[0]);
 925                 $parse = get_parse_routine($d->[1]);
 926                 $dir = $d->[0];
 927                 $value = $parse->($dir, $value)
 928                         if $parse;
 929                 last;
 930         }
 931         return [$dir, $value] if defined $dir;
 932         return undef;
 933 }
 934
 935 sub get_catalog_default {
 936         my ($directive) = @_;
 937         my $directives = catalog_directives();
 938         my $value;
 939         for(@$directives) {
 940                 next unless (lc $directive) eq (lc $_->[0]);
 941                 $value = $_->[2];
 942         }
 943         return undef unless defined $value;
 944         return $value;
 945 }
 946
 947 sub get_global_default {
 948         my ($directive) = @_;
 949         my $directives = global_directives();
 950         my $value;
 951         for(@$directives) {
 952                 next unless (lc $directive) eq (lc $_->[0]);
 953                 $value = $_->[2];
 954         }
 955         return undef unless defined $value;
 956         return $value;
 957 }
 958
 959 sub evaluate_ifdef {
 960         my ($ifdef, $reverse, $global) = @_;
 961 #::logDebug("ifdef '$ifdef'");
 962         my $status;
 963         $ifdef =~ /^\s*(\@?)(\w+)\s*(.*)/;
 964         $global = $1 || $global || undef;
 965         my $var  = $2;
 966         my $cond = $3;
 967         my $var_ref = ! $global ? $C->{Variable} : $Global::Variable;
 968 #::logDebug("Variable value '$var_ref->{$var}'");
 969         if (! $cond) {
 970                 $status = ! (not $var_ref->{$var});
 971         }
 972         elsif ($cond) {
 973                 my $val = $var_ref->{$var} || '';
 974                 my $safe = new Vend::Safe;
 975                 my $code = "q{$val}" . " " . $cond;
 976                 $status = $safe->reval($code);
 977                 if($@) {
 978                         config_warn(
 979                                 errmsg("Syntax error in ifdef evaluation at line %s of %s",
 980                                                 $.,
 981                                                 $configfile,
 982                                         ),
 983                         );
 984                         $status = '';
 985                 }
 986         }
 987 #::logDebug("ifdef status '$status', reverse=" . !(not $reverse));
 988         return $reverse ? ! $status : $status;
 989 }
 990
 991 # This is what happens when ParseVariables is true
 992 sub substitute_variable {
 993         my($val) = @_;
 994         1 while $val =~ s/__([A-Z][A-Z_0-9]*?[A-Z0-9])__/$C->{Variable}->{$1}/g;
 995         # Only parse once for globals so they can contain other
 996         # global and catalog variables
 997         $val =~ s/\@\@([A-Z][A-Z_0-9]+[A-Z0-9])\@\@/$Global::Variable->{$1}/g;
 998         return $val;
 999 }
1000
1001 # Parse the configuration file for directives.  Each directive sets
1002 # the corresponding variable in the Vend::Cfg:: package.  E.g.
1003 # "DisplayErrors No" in the config file sets Vend::Cfg->{DisplayErrors} to 0.
1004 # Directives which have no defined default value ("undef") must be specified
1005 # in the config file.
1006
1007 my($directives, $directive, %parse);
1008
1009 sub config {
1010         my($catalog, $dir, $confdir, $subconfig, $existing, $passed_file) = @_;
1011         my($d, $parse, $var, $value, $lvar);
1012
1013         $Vend::Cat = $catalog;
1014
1015         if(ref $existing eq 'HASH') {
1016 #::logDebug("existing=$existing");
1017                 $C = $existing;
1018         }
1019         else {
1020                 undef $existing;
1021                 $C = {};
1022                 $C->{CatalogName} = $catalog;
1023                 $C->{VendRoot} = $dir;
1024
1025                 unless (defined $subconfig) {
1026                         $C->{ErrorFile} = 'error.log';
1027                         $C->{ConfigFile} = 'catalog.cfg';
1028                 }
1029                 else {
1030                         $C->{ConfigFile} = "$catalog.cfg";
1031                         $C->{BaseCatalog} = $subconfig;
1032                 }
1033         }
1034
1035         unless($directives) {
1036                 $directives = catalog_directives();
1037                 foreach $d (@$directives) {
1038                         my $ucdir = $d->[0];
1039                         $directive = lc $d->[0];
1040                         next if $Global::DeleteDirective->{$directive};
1041                         $CDname{$directive} = $ucdir;
1042                         $CPname{$directive} = $d->[1];
1043                         $parse{$directive} = get_parse_routine($d->[1]);
1044                 }
1045         }
1046
1047         for(keys %DirectiveAlias) {
1048                 my $k = lc $_;
1049                 my $v = $DirectiveAlias{$_};
1050                 my $lv = lc $v;
1051                 $CDname{$k} = $CDname{$lv};
1052                 $CPname{$k} = $CPname{$lv};
1053                 $parse{$k} = $parse{$lv};
1054         }
1055
1056         no strict 'refs';
1057
1058         if(! $subconfig and ! $existing ) {
1059                 foreach $d (@$directives) {
1060                         my $ucdir = $d->[0];
1061                         $directive = lc $d->[0];
1062                         next if $Global::DeleteDirective->{$directive};
1063                         $parse = $parse{$directive};
1064
1065                         $value = (
1066                                                 ! defined $MV::Default{$catalog} or
1067                                                 ! defined $MV::Default{$catalog}{$ucdir}
1068                                          )
1069                                          ? $d->[2]
1070                                          : $MV::Default{$catalog}{$ucdir};
1071
1072                         if (defined $parse and defined $value) {
1073 #::logDebug("parsing default directive=$directive ucdir=$ucdir parse=$parse value=$value CDname=$CDname{$directive}");
1074                                 $value = $parse->($ucdir, $value);
1075                         }
1076                         $C->{$CDname{$directive}} = $value;
1077                 }
1078         }
1079
1080         @include = ($passed_file || $C->{ConfigFile});
1081         my %include_hash = ($include[0] => 1);
1082         my $done_one;
1083         my ($db, $dname, $nm);
1084         my ($before, $after);
1085         my $recno = 'C0001';
1086
1087         my @hidden_config;
1088         if(! $existing and ! $subconfig) {
1089                 @hidden_config = grep -f $_,
1090                                                                  "$C->{CatalogName}.site",
1091                                                                  "$Global::ConfDir/$C->{CatalogName}.before",
1092                                                                  @{$Global::ConfigAllBefore},
1093                                                          ;
1094
1095                 # Backwards because of unshift;
1096                 for (@hidden_config) {
1097                         unshift @include, $_;
1098                         $include_hash{$_} = 1;
1099                 }
1100
1101                 @hidden_config = grep -f $_,
1102                                                                  "$Global::ConfDir/$C->{CatalogName}.after",
1103                                                                  @{$Global::ConfigAllAfter},
1104                                                          ;
1105
1106                 for (@hidden_config) {
1107                         push @include, $_;
1108                         $include_hash{$_} = 1;
1109                 }
1110         }
1111
1112         # %MV::Default holds command-line mods to config, which we write
1113         # to a file for easier processing
1114         if(! $existing and defined $MV::Default{$catalog}) {
1115                 my $fn = "$Global::RunDir/$catalog.cmdline";
1116                 open(CMDLINE, ">$fn")
1117                         or die "Can't create cmdline configfile $fn: $!\n";
1118                 for(@{$MV::DefaultAry{$catalog}}) {
1119                         my ($d, $v) = split /\s+/, $_, 2;
1120                         if($v =~ /\n/) {
1121                                 $v = "<<EndOfMvD\n$v\nEndOfMvD\n";
1122                         }
1123                         else {
1124                                 $v .= "\n";
1125                         }
1126                         printf CMDLINE '%-19s %s', $d, $v;
1127                 }
1128                 close CMDLINE;
1129                 push @include, $fn;
1130                 $include_hash{$_} = 1;
1131         }
1132
1133         my $allcfg;
1134         if($Global::DumpAllCfg) {
1135                 open ALLCFG, ">$Global::RunDir/allconfigs.cfg"
1136                         and $allcfg = 1;
1137         }
1138         # Create closure that reads and sets config values
1139         my $read = sub {
1140                 my ($lvar, $value, $tie, $var) = @_;
1141
1142                 # parse variables in the value if necessary
1143                 if($C->{ParseVariables} and $value =~ /(?:__|\@\@)/) {
1144                         save_variable($CDname{$lvar}, $value);
1145                         $value = substitute_variable($value);
1146                 }
1147
1148                 # call the parsing function for this directive
1149                 $parse = $parse{$lvar};
1150                 $value = $parse->($CDname{$lvar}, $value) if defined $parse and ! $tie;
1151
1152                 # and set the $C->directive variable
1153                 if($tie) {
1154                         watch ( $CDname{$lvar}, $value );
1155                 }
1156                 else {
1157                         $C->{$CDname{$lvar}} = $value;
1158                 }
1159         };
1160
1161 #print "include starts with @include\n";
1162 CONFIGLOOP:
1163         while ($configfile = shift @include) {
1164                 my $tellmark;
1165                 if(ref $configfile) {
1166                         ($configfile, $tellmark)  = @$configfile;
1167 #print "recalling $configfile (pos $tellmark)\n";
1168                 }
1169
1170         # See if anything is defined in options to do before the
1171         # main configuration file.  If there is a file, then we
1172         # will do it (after pushing the main one on @include).
1173
1174         -f $configfile && open(CONFIG, "< $configfile")
1175                 or do {
1176                         my $msg = "Could not open configuration file '" . $configfile .
1177                                         "' for catalog '" . $catalog . "':\n$!";
1178                         if(defined $done_one) {
1179                                 warn "$msg\n";
1180                                 open (CONFIG, '');
1181                         }
1182                         else {
1183                                 die "$msg\n";
1184                         }
1185                 };
1186         print ALLCFG "# READING FROM $configfile\n" if $allcfg;
1187         seek(CONFIG, $tellmark, 0) if $tellmark;
1188 #print "seeking to $tellmark in $configfile, include is @include\n";
1189         my ($ifdef, $begin_ifdef);
1190         while(<CONFIG>) {
1191                 if($allcfg) {
1192                         print ALLCFG $_
1193                                 unless /^\s*include\s+/i;
1194                 }
1195                 chomp;                  # zap trailing newline,
1196                 if(/^\s*endif\s*$/i) {
1197 #print "found $_\n";
1198                         undef $ifdef;
1199                         undef $begin_ifdef;
1200                         next;
1201                 }
1202                 if(/^\s*if(n?)def\s+(.*)/i) {
1203                         if(defined $ifdef) {
1204                                 config_error("Can't overlap ifdef at line %s of %s", $., $configfile);
1205                         }
1206                         $ifdef = evaluate_ifdef($2,$1);
1207                         $begin_ifdef = $.;
1208 #print "found $_\n";
1209                         next;
1210                 }
1211                 if(defined $ifdef) {
1212                         next unless $ifdef;
1213                 }
1214                 if(/^\s*include\s+(.+)/i) {
1215 #print "found $_\n";
1216                         my $spec = $1;
1217                         $spec = substitute_variable($spec) if $C->{ParseVariables};
1218                         if ($include_hash{$spec}) {
1219                                 config_error("Possible infinite loop through inclusion of $spec at line %s of %s, skipping", $., $configfile);
1220                                 next;
1221                         }
1222                         $include_hash{$spec} = 1;
1223                         my $ref = [ $configfile, tell(CONFIG)];
1224 #print "saving config $configfile (pos $ref->[1])\n";
1225                         #unshift @include, [ $configfile, tell(CONFIG) ];
1226                         unshift @include, $ref;
1227                         close CONFIG;
1228                         unshift @include, grep -f $_, glob($spec);
1229                         next CONFIGLOOP;
1230                 }
1231
1232                 my ($lvar, $value, $var, $tie) =
1233                         read_config_value($_, \*CONFIG, $allcfg);
1234
1235                 next unless $lvar;
1236
1237                 # Use our closure defined above
1238                 $read->($lvar, $value, $tie);
1239
1240                 # If we have passed off configuration to a database we stop here...
1241                 last if $C->{ConfigDatabase}->{ACTIVE};
1242
1243                 # See if we want to load the config database
1244                 if(! $db and $C->{ConfigDatabase}->{LOAD}) {
1245                         $db = $C->{ConfigDatabase}->{OBJECT}
1246                                 or config_error(
1247                                         "ConfigDatabase $C->{ConfigDatabase}->{'name'} not active.");
1248                         $dname = $C->{ConfigDatabase}{name};
1249                 }
1250
1251                 # Actually load ConfigDatabase if present
1252                 if($db) {
1253                         $nm = $CDname{$lvar};
1254                         my ($extended, $status);
1255                         undef $extended;
1256
1257                         # set directive name
1258                         $status = Vend::Data::set_field($db, $recno, 'directive', $nm);
1259                         defined $status
1260                                 or config_error(
1261                                         "ConfigDatabase failed for %s, field '%s'",
1262                                         $dname,
1263                                         'directive',
1264                                         );
1265
1266                         # use extended value field if necessary or directed
1267                         if (length($value) > 250 or $UseExtended{$nm}) {
1268                                 $extended = $value;
1269                                 $extended =~ s/(\S+)\s*//;
1270                                 $value = $1 || '';
1271                                 $status = Vend::Data::set_field($db, $recno, 'extended', $extended);
1272                                 defined $status
1273                                         or config_error(
1274                                                 "ConfigDatabase failed for %s, field '%s'",
1275                                                 $dname,
1276                                                 'extended',
1277                                                 );
1278                         }
1279
1280                         # set value -- just a name if extended was used
1281                         $status = Vend::Data::set_field($db, $recno, 'value', $value);
1282                         defined $status
1283                                 or config_error(
1284                                                 "ConfigDatabase failed for %s, field '%s'",
1285                                                 $dname,
1286                                                 'value',
1287                                         );
1288
1289                         $recno++;
1290                 }
1291
1292         }
1293         $done_one = 1;
1294         close CONFIG;
1295         delete $include_hash{$configfile};
1296
1297         # See if we have an active configuration database
1298         if($C->{ConfigDatabase}->{ACTIVE}) {
1299                 my ($key,$value,$dir,@val);
1300                 my $name = $C->{ConfigDatabase}->{name};
1301                 $db = $C->{ConfigDatabase}{OBJECT} or
1302                         config_error("ConfigDatabase called ACTIVE with no database object.\n");
1303                 my $items = $db->array_query("select * from $name order by code");
1304                 my $one;
1305                 foreach $one ( @$items ) {
1306                         ($key, $dir, @val) = @$one;
1307                         $value = join " ", @val;
1308                         $value =~ s/\s/\n/ if $value =~ /\n/;
1309                         $value =~ s/^\s+//;
1310                         $value =~ s/\s+$//;
1311                         $lvar = lc $dir;
1312                         $read->($lvar, $value);
1313                 }
1314         }
1315
1316         if(defined $ifdef) {
1317                 config_error("Failed to close #ifdef on line %s.", $begin_ifdef);
1318         }
1319
1320 } # end CONFIGLOOP
1321
1322         # We need to make this directory if it isn't already there....
1323         if(! $existing and $C->{ScratchDir} and ! -e $C->{ScratchDir}) {
1324                 mkdir $C->{ScratchDir}, 0700
1325                         or die "Can't make temporary directory $C->{ScratchDir}: $!\n";
1326         }
1327
1328         return $C if $existing;
1329
1330         # check for unspecified directives that don't have default values
1331
1332         # but set some first if appropriate
1333         set_defaults() unless $C->{BaseCatalog};
1334
1335         REQUIRED: {
1336                 last REQUIRED if defined $subconfig;
1337                 last REQUIRED if defined $Vend::ExternalProgram;
1338                 foreach $var (keys %CDname) {
1339                         if (! defined $C->{$CDname{$var}}) {
1340                                 my $msg = errmsg(
1341                                         "Please specify the %s directive in the configuration file '%s'",
1342                                         $CDname{$var},
1343                                         ($passed_file || $C->{ConfigFile}),
1344                                 );
1345
1346                                 die "$msg\n";
1347                         }
1348                 }
1349         }
1350
1351         # Set up hash of keys to hide for BounceReferrals and BounceReferralsRobot
1352         $C->{BounceReferrals_hide} = { map { ($_, 1) } grep { !(/^cookie-/ or /^session(?:$|-)/) } @{$C->{SourcePriority}} };
1353         my @exclude = qw( mv_form_charset mv_session_id mv_tmp_session );
1354         @{$C->{BounceReferrals_hide}}{@exclude} = (1) x @exclude;
1355
1356         finalize_mapped_code();
1357
1358         set_readonly_config();
1359         # Ugly legacy stuff so API won't break
1360         $C->{Special} = $C->{SpecialPage} if defined $C->{SpecialPage};
1361         my $return = $C;
1362         undef $C;
1363         return $return;
1364 }
1365
1366 sub read_container {
1367         my($start, $handle, $marker, $parse, $allcfg) = @_;
1368         my $lvar = lc $marker;
1369         my $var = $CDname{$lvar};
1370
1371 #::logDebug("Read container start=$start marker=$marker lvar=$lvar var=$var parse=$parse");
1372         $parse ||= {};
1373 #::logDebug("Read container parse value=$CPname{$lvar}");
1374         my $sub = $ContainerSpecial{$var}
1375                           || $ContainerSpecial{$lvar}
1376                           || $ContainerType{$CPname{$lvar}};
1377
1378         if($sub) {
1379 #::logDebug("Trigger special container");
1380                 $start =~ s/\n$//;
1381                 $sub->($var, $start);
1382                 $ContainerTrigger{$lvar} ||= $sub;
1383                 return $start;
1384         }
1385
1386         my $foundeot = 0;
1387         my $startline = $.;
1388         my $value = '';
1389         if(length $start) {
1390                 $value .= "$start\n";
1391         }
1392         while (<$handle>) {
1393                 print ALLCFG $_ if $allcfg;
1394                 if ($_ =~ m{^\s*</$marker>\s*$}i) {
1395                         $foundeot = 1;
1396                         last;
1397                 }
1398                 $value .= $_;
1399         }
1400         return undef unless $foundeot;
1401         #untaint
1402         $value =~ /((?s:.)*)/;
1403         $value = $1;
1404         return $value;
1405 }
1406
1407 sub read_here {
1408         my($handle, $marker, $allcfg) = @_;
1409         my $foundeot = 0;
1410         my $startline = $.;
1411         my $value = '';
1412         while (<$handle>) {
1413                 print ALLCFG $_ if $allcfg;
1414                 if ($_ =~ m{^$marker$}) {
1415                         $foundeot = 1;
1416                         last;
1417                 }
1418                 $value .= $_;
1419         }
1420         return undef unless $foundeot;
1421         #untaint
1422         $value =~ /((?s:.)*)/;
1423         $value = $1;
1424         return $value;
1425 }
1426
1427 sub config_named_catalog {
1428         my ($cat_name, $source, $db_only, $dbconfig) = @_;
1429         my ($g, $c);
1430
1431         $g = $Global::Catalog{$cat_name};
1432         unless (defined $g) {
1433                 logGlobal( "Can't find catalog '%s'" , $cat_name );
1434                 return undef;
1435         }
1436
1437         $Vend::Log_suppress = 1;
1438
1439         unless ($db_only or $Vend::Quiet) {
1440                 logGlobal( "Config '%s' %s%s", $g->{'name'}, $source );
1441         }
1442         undef $Vend::Log_suppress;
1443
1444     chdir $g->{'dir'}
1445             or die "Couldn't change to $g->{'dir'}: $!\n";
1446
1447         if($db_only) {
1448                 logGlobal(
1449                         "Config table '%s' (file %s) for catalog %s from %s",
1450                         $db_only,
1451                         $dbconfig,
1452                         $g->{'name'},
1453                         $source,
1454                         );
1455                 my $cfg = $Global::Selector{$g->{script}}
1456                         or die errmsg("'%s' not a catalog (%s).", $g->{name}, $g->{script});
1457                 undef $cfg->{Database}{$db_only};
1458                 $Vend::Cfg = config(
1459                                 $g->{name},
1460                                 $g->{dir},
1461                                 undef,
1462                                 undef,
1463                                 $cfg,
1464                                 $dbconfig,
1465                                 )
1466                         or die errmsg("error configuring catalog %s table %s: %s",
1467                                                         $g->{name},
1468                                                         $db_only,
1469                                                         $@,
1470                                         );
1471                 open_database();
1472                 close_database();
1473                 return $Vend::Cfg;
1474         }
1475
1476     eval {
1477         $c = config($g->{'name'},
1478                                         $g->{'dir'},
1479                                         undef,
1480                                         $g->{'base'} || undef,
1481 # OPTION_EXTENSION
1482 #                                       $Vend::CommandLine->{$g->{'name'}} || undef
1483 # END OPTION_EXTENSION
1484                                         );
1485     };
1486
1487     if($@) {
1488                 my $msg = $@;
1489         logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
1490         return undef;
1491     }
1492
1493         if (defined $g->{base}) {
1494                 open_database(1);
1495                 dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
1496                 return $c;
1497         }
1498
1499         eval {
1500                 $Vend::Cfg = $c;
1501                 $::Variable = $Vend::Cfg->{Variable};
1502                 $::Pragma   = $Vend::Cfg->{Pragma};
1503                 Vend::Data::read_salestax();
1504                 Vend::Data::read_shipping();
1505                 open_database(1);
1506                 my $db;
1507                 close_database();
1508         };
1509
1510         undef $Vend::Cfg;
1511     if($@) {
1512                 my $msg = $@;
1513                 $msg =~ s/\s+$//;
1514         logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
1515         return undef;
1516     }
1517
1518         dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
1519
1520     my $status_dir = ($c->{Source}{RunDir} ? $c->{RunDir} : $c->{ConfDir});
1521
1522         delete $c->{Source};
1523
1524         my $stime = scalar localtime();
1525         writefile(">$Global::RunDir/status.$g->{name}", "$stime\n$g->{dir}\n");
1526         writefile(">$status_dir/status.$g->{name}", "$stime\n");
1527
1528         return $c;
1529
1530 }
1531
1532
1533 use File::Find;
1534
1535 sub get_system_groups {
1536
1537         my @files;
1538         my $wanted = sub {
1539                 return if (m{^\.} || ! -f $_);
1540                 $File::Find::name =~ m{/([^/]+)/([^/.]+)\.(\w+)$}
1541                         or return;
1542                 my $group = $1;
1543                 my $tname = $2;
1544                 my $ext = $extmap{lc $3} or return;
1545                 $ext =~ /Tag$/ or return;
1546                 push @files, [ $group, $tname ];
1547         };
1548         File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
1549
1550         $Global::TagGroup ||= {};
1551         for(@files) {
1552                 my $g = $Global::TagGroup->{":$_->[0]"} ||= [];
1553                 push @$g, $_->[1];
1554         }
1555         return;
1556 }
1557
1558 sub get_repos_code {
1559
1560 #::logDebug("get_repos_code called");
1561         return unless $Global::CodeRepository;
1562
1563         return if $Vend::ControllingInterchange;
1564
1565         my @files;
1566         my $wanted = sub {
1567                 return if (m{^\.} || ! -f $_);
1568                 return unless m{^[^.]+\.(\w+)$};
1569                 my $ext = $extmap{lc $1} or return;
1570                 push @files, [ $File::Find::name, $ext];
1571         };
1572         File::Find::find({ wanted => $wanted, follow => 1 }, $Global::CodeRepository);
1573
1574         my $c = $Global::TagLocation = {};
1575
1576         # %valid_dest is scoped as my variable above
1577
1578         for(@files) {
1579                 my $foundfile   = $_->[0];
1580                 my $dest                = $_->[1];
1581                 open SYSTAG, "< $foundfile"
1582                         or next;
1583                 while(<SYSTAG>) {
1584                         my($lvar, $value) = read_config_value($_, \*SYSTAG);
1585                         my $name;
1586                         my $dest;
1587                         if($lvar eq 'codedef') {
1588                                 $value =~ s/^(\S+)\s+(\S+).*//s;
1589                                 $dest = $valid_dest{lc $2};
1590                                 $name = $1;
1591                         }
1592                         elsif($dest = $valid_dest{$lvar}) {
1593                                 $value =~ m/^(\S+)\s+/
1594                                 and $name = $1;
1595                         }
1596
1597                         next unless $dest and $name;
1598
1599                         $name = lc $name;
1600                         $name =~ s/-/_/g;
1601                         $c->{$dest} ||= {};
1602                         $c->{$dest}{$name} ||= $foundfile;
1603                 }
1604                 close SYSTAG;
1605         }
1606
1607 #::logDebug("repos is:\n" . ::uneval($Global::TagLocation));
1608
1609 }
1610
1611 sub get_system_code {
1612
1613         return if $CodeDest;
1614         return if $Vend::ControllingInterchange;
1615
1616         # defined means don't go here anymore
1617         $SystemCodeDone = '';
1618         my @files;
1619         my $wanted = sub {
1620                 return if (m{^\.} || ! -f $_);
1621                 return unless m{^[^.]+\.(\w+)$};
1622                 my $ext = $extmap{lc $1} or return;
1623                 push @files, [ $File::Find::name, $ext];
1624         };
1625         File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
1626
1627         local($configfile);
1628         for(@files) {
1629                 $CodeDest = $_->[1];
1630
1631                 $configfile = $_->[0];
1632                 open SYSTAG, "< $configfile"
1633                         or config_error("read system tag file %s: %s", $configfile, $!);
1634                 while(<SYSTAG>) {
1635                         my($lvar, $value) = read_config_value($_, \*SYSTAG);
1636                         next unless $lvar;
1637                         $GlobalRead->($lvar, $value);
1638                 }
1639                 close SYSTAG;
1640         }
1641
1642         undef $CodeDest;
1643         # 1 means read system tag directories
1644         $SystemCodeDone = 1;
1645 }
1646
1647 sub read_config_value {
1648         local($_) = shift;
1649         return undef unless $_;
1650         my ($fh, $allcfg) = @_;
1651
1652         my $lvar;
1653         my $tie;
1654
1655         chomp;                  # zap trailing newline,
1656         s/^\s*#.*//;            # comments,
1657                                 # mh 2/10/96 changed comment behavior
1658                                 # to avoid zapping RGB values
1659                                 #
1660         s/\s+$//;               #  trailing spaces
1661         return undef unless $_;
1662
1663         local($Vend::config_line);
1664         $Vend::config_line = $_;
1665         my $container_here;
1666         my $container_trigger;
1667         my $var;
1668         my $value;
1669
1670         if(s{^[ \t]*<(/?)(\w+)\s*(.*)\s*>\s*$}{$2$3}) {
1671                 $container_trigger = $1;
1672                 $var = $container_here = $2;
1673                 $value = $3;
1674         }
1675         else {
1676                 # lines read from the config file become untainted
1677                 m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error from $_");
1678                 $var = $1;
1679                 $value = $2;
1680         }
1681         ($lvar = $var) =~ tr/A-Z/a-z/;
1682
1683         config_error("Unknown directive '%s'", $lvar), next
1684                 unless defined $CDname{$lvar};
1685
1686         my($codere) = '[-\w_#/.]+';
1687
1688         if ($container_trigger) {                  # Apache container value
1689                 if(my $sub = $ContainerTrigger{$lvar}) {
1690                         $sub->($var, $value, 1);
1691                         return;
1692                 }
1693         }
1694
1695         if ($container_here) {                  # Apache container value
1696                 my $begin  = $value;
1697                 $begin .= "\n" if length $begin;
1698                 my $mark = "</$container_here>";
1699                 my $startline = $.;
1700                 $value = read_container($begin, $fh, $container_here, \%parse);
1701                 unless (defined $value) {
1702                         config_error (sprintf('%d: %s', $startline,
1703                                 qq#no end contaner ("</$container_here>") found#));
1704                 }
1705         }
1706         elsif ($value =~ /^(.*)<<(\w+)\s*/) {                  # "here" value
1707                 my $begin  = $1 || '';
1708                 $begin .= "\n" if $begin;
1709                 my $mark = $2;
1710                 my $startline = $.;
1711                 $value = $begin . read_here($fh, $mark);
1712                 unless (defined $value) {
1713                         config_error (sprintf('%d: %s', $startline,
1714                                 qq#no end marker ("$mark") found#));
1715                 }
1716         }
1717         elsif ($value =~ /^(.*)<&(\w+)\s*/) {                # "here sub" value
1718                 my $begin  = $1 || '';
1719                 $begin .= "\n" if $begin;
1720                 my $mark  = $2;
1721                 my $startline = $.;
1722                 $value = $begin . read_here($fh, $mark, $allcfg);
1723                 unless (defined $value) {
1724                         config_error (sprintf('%d: %s', $startline,
1725                                 qq#no end marker ("$mark") found#));
1726                 }
1727                 eval {
1728                         require Tie::Watch;
1729                 };
1730                 unless ($@) {
1731                         $tie = 1;
1732                 }
1733                 else {
1734                         config_warn(
1735                                 "No Tie::Watch module installed at %s, setting %s to default.",
1736                                 $startline,
1737                                 $var,
1738                         );
1739                         $value = '';
1740                 }
1741         }
1742         elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) {   # read from file
1743                 my $confdir = $C ? $C->{ConfigDir} : $Global::ConfigDir;
1744                 $value = $1 || '';
1745                 my $file = $3;
1746                 $value .= "\n" if $value;
1747                 unless ($confdir) {
1748                         config_error(
1749                                 "%s: Can't read from file until ConfigDir defined",
1750                                 $CDname{$lvar},
1751                         );
1752                 }
1753                 $file = $CDname{$lvar} unless $file;
1754
1755                 # If the file isn't already specified with an absolute path, try the
1756                 # Config directory, then the current directory.  When neither file
1757                 # exists, use the Config directory and continue.
1758                 if ($file !~ m!^/!) {
1759                         my $test_with_confdir = escape_chars("$confdir/$file");
1760                         if (-f $test_with_confdir) {
1761                                 $file = $test_with_confdir;
1762                         }
1763                         else {
1764                                 my $test_without_confdir = escape_chars($file);
1765                                 if (-f $test_without_confdir) {
1766                                         $file = $test_without_confdir;
1767                                 }
1768                                 else {
1769                                         $file = $test_with_confdir;
1770                                 }
1771                         }
1772                 }
1773
1774                 my $tmpval = readfile($file);
1775                 unless( defined $tmpval ) {
1776                         config_warn(
1777                                         "%s: read from non-existent file %s, skipping.",
1778                                         $CDname{$lvar},
1779                                         $file,
1780                         );
1781                         return undef;
1782                 }
1783                 chomp($tmpval) unless $tmpval =~ m!.\n.!;
1784                 $value .= $tmpval;
1785         }
1786         return($lvar, $value, $var, $tie);
1787 }
1788
1789 # Parse the global configuration file for directives.  Each directive sets
1790 # the corresponding variable in the Global:: package.  E.g.
1791 # "DisplayErrors No" in the config file sets Global::DisplayErrors to 0.
1792 # Directives which have no default value ("undef") must be specified
1793 # in the config file.
1794 sub global_config {
1795         my(%parse, $var, $value, $lvar, $parse);
1796         my($directive, $seen_catalog);
1797         no strict 'refs';
1798
1799         %CDname = ();
1800         %CPname = ();
1801
1802         my $directives = global_directives();
1803
1804         $Global::Structure = {} unless $Global::Structure;
1805
1806         # Prevent parsers from thinking it is a catalog
1807         undef $C;
1808
1809         foreach my $d (@$directives) {
1810                 $directive = lc $d->[0];
1811                 $CDname{$directive} = $d->[0];
1812                 $CPname{$directive} = $d->[1];
1813                 $parse = get_parse_routine($d->[1]);
1814                 $parse{$directive} = $parse;
1815                 undef $value;
1816                 $value = (
1817                                         ! defined $MV::Default{mv_global} or
1818                                         ! defined $MV::Default{mv_global}{$d->[0]}
1819                                  )
1820                                  ? $d->[2]
1821                                  : $MV::Default{mv_global}{$d->[0]};
1822
1823                 if (defined $DumpSource{$CDname{$directive}}) {
1824                         $Global::Structure->{ $CDname{$directive} } = $value;
1825                 }
1826
1827                 if (defined $parse and defined $value) {
1828                         $value = $parse->($d->[0], $value);
1829                 }
1830
1831                 if(defined $value) {
1832                         ${'Global::' . $CDname{$directive}} = $value;
1833
1834                         $Global::Structure->{ $CDname{$directive} } = $value
1835                                 unless defined $DontDump{ $CDname{$directive} };
1836                 }
1837
1838         }
1839
1840         my (@include) = $Global::ConfigFile;
1841
1842         # Create closure for reading of value
1843
1844         my $read = sub {
1845                 my ($lvar, $value, $tie) = @_;
1846
1847 #::logDebug("Doing a GlobalRead for $lvar") unless $Global::Foreground;
1848                 unless (defined $CDname{$lvar}) {
1849                         config_error("Unknown directive '%s'", $var);
1850                         return;
1851                 }
1852
1853 #::logDebug("Continuing a GlobalRead for $lvar") unless $Global::Foreground;
1854                 if (defined $DumpSource{$CDname{$directive}}) {
1855                         $Global::Structure->{ $CDname{$directive} } = $value;
1856                 }
1857
1858                 # call the parsing function for this directive
1859                 $parse = $parse{$lvar};
1860 #::logDebug("parse routine is $parse for $CDname{$lvar}") unless $Global::Foreground;
1861                 $value = $parse->($CDname{$lvar}, $value) if defined $parse;
1862
1863                 # and set the Global::directive variable
1864                 ${'Global::' . $CDname{$lvar}} = $value;
1865 #::logDebug("It is now=" . ::uneval($value)) unless $Global::Foreground;
1866                 $Global::Structure->{ $CDname{$lvar} } = $value
1867                         unless defined $DontDump{ $CDname{$lvar} };
1868         };
1869
1870         $GlobalRead = $read;
1871         my $done_one;
1872 GLOBLOOP:
1873         while ($configfile = shift @include) {
1874                 my $tellmark;
1875                 if(ref $configfile) {
1876                         ($configfile, $tellmark)  = @$configfile;
1877 #print "recalling $configfile (pos $tellmark)\n";
1878                 }
1879
1880         -f $configfile && open(GLOBAL, "< $configfile")
1881                 or do {
1882                         my $msg = errmsg(
1883                                                 "Could not open global configuration file '%s': %s",
1884                                                 $configfile,
1885                                                 $!,
1886                                                 );
1887                         if(defined $done_one) {
1888                                 warn "$msg\n";
1889                                 open (GLOBAL, '');
1890                         }
1891                         else {
1892                                 die "$msg\n";
1893                         }
1894                 };
1895         seek(GLOBAL, $tellmark, 0) if $tellmark;
1896 #print "seeking to $tellmark in $configfile, include is @include\n";
1897         my ($ifdef, $begin_ifdef);
1898         while(<GLOBAL>) {
1899                 if(/^\s*endif\s*$/i) {
1900 #print "found $_";
1901                         undef $ifdef;
1902                         undef $begin_ifdef;
1903                         next;
1904                 }
1905                 if(/^\s*if(n?)def\s+(.*)/i) {
1906 #print "found $_";
1907                         if(defined $ifdef) {
1908                                 config_error(
1909                                         "Can't overlap ifdef at line %s of %s",
1910                                         $.,
1911                                         $configfile,
1912                                 );
1913                         }
1914                         $ifdef = evaluate_ifdef($2,$1,1);
1915                         $begin_ifdef = $.;
1916                         next;
1917                 }
1918                 if(defined $ifdef) {
1919                         next unless $ifdef;
1920                 }
1921                 if(/^\s*include\s+(.+)/) {
1922 #print "found $_";
1923                         my $spec = $1;
1924                         my $ref = [ $configfile, tell(GLOBAL)];
1925 #print "saving config $configfile (pos $ref->[1])\n";
1926                         unshift @include, $ref;
1927                         close GLOBAL;
1928                         chomp;
1929                         unshift @include, grep -f $_, glob($spec);
1930                         next GLOBLOOP;
1931                 }
1932
1933                 my ($lvar, $value, $tie) = read_config_value($_, \*GLOBAL);
1934                 next unless $lvar;
1935                 $read->($lvar, $value, $tie);
1936
1937         }
1938         close GLOBAL;
1939         $done_one = 1;
1940 } # end GLOBLOOP;
1941
1942         # In case no user-supplied config has been given...returns
1943         # with no effect if that has been done already.
1944         get_system_code() unless defined $SystemCodeDone;
1945
1946         # Directive post-processing
1947         global_directive_postprocess();
1948
1949         # Do some cleanup
1950         set_global_defaults();
1951
1952         # check for unspecified directives that don't have default values
1953         foreach $var (keys %CDname) {
1954                 last if defined $Vend::ExternalProgram;
1955                 if (!defined ${'Global::' . $CDname{$var}}) {
1956                         die "Please specify the $CDname{$var} directive in the\n" .
1957                         "configuration file '$Global::ConfigFile'\n";
1958                 }
1959         }
1960
1961         # Inits Global UserTag entries
1962         ADDTAGS: {
1963                 Vend::Parse::global_init;
1964         }
1965
1966         ## Pulls in the places where code can be found when AccumulatingTags
1967         get_repos_code() if $Global::AccumulateCode;
1968
1969         finalize_mapped_code();
1970
1971         dump_structure($Global::Structure, "$Global::RunDir/$Global::ExeName")
1972                 if $Global::DumpStructure and ! $Vend::ExternalProgram;
1973
1974         delete $Global::Structure->{Source};
1975
1976         %CDname = ();
1977         return 1;
1978 }
1979
1980 # Use Tie::Watch to attach subroutines to config variables
1981 sub watch {
1982         my($name, $value) = @_;
1983         $C->{Tie_Watch} = [] unless $C->{Tie_Watch};
1984         push @{$C->{Tie_Watch}}, $name;
1985
1986         my ($ref, $orig);
1987 #::logDebug("Contents of $name: " . uneval_it($C->{$name}));
1988         if(CORE::ref($C->{$name}) =~ /ARRAY/) {
1989 #::logDebug("watch ref=array");
1990                 $ref = $C->{$name};
1991                 $orig = [ @{ $C->{$name} } ];
1992         }
1993         elsif(CORE::ref($C->{$name}) =~ /HASH/) {
1994 #::logDebug("watch ref=hash");
1995                 $ref = $C->{$name};
1996                 $orig = { %{ $C->{$name} } };
1997         }
1998         else {
1999 #::logDebug("watch ref=scalar");
2000                 $ref = \$C->{$name};
2001                 $orig = $C->{$name};
2002         }
2003 #::logDebug("watch ref=$ref orig=$orig name=$name value=$value");
2004         $C->{WatchIt} = { _mvsafe => $C->{ActionMap}{_mvsafe} } if ! $C->{WatchIt};
2005         parse_action('WatchIt', "$name $value");
2006         my $coderef = $C->{WatchIt}{$name}
2007                 or return undef;
2008         my $recode = sub {
2009                                         package Vend::Interpolate;
2010                                         init_calc();
2011                                         my $key = $_[0]->Args(-fetch)->[0];
2012                                         return $coderef->(@_, $key);
2013                                 };
2014         package Vend::Interpolate;
2015         $Vend::Config::C->{WatchIt}{$name} = Tie::Watch->new(
2016                                         -variable => $ref,
2017                                         -fetch => [$recode,$orig],
2018                                         );
2019 }
2020
2021 sub get_wildcard_list {
2022         my($var, $value, $base) = @_;
2023
2024         $value =~ s/\s*#.*?$//mg;
2025         $value =~ s/^\s+//;
2026         $value =~ s/\s+$//;
2027         return '' if ! $value;
2028
2029         if($value !~ /\|/) {
2030                 $value =~ s/([\\\+\|\[\]\(\){}])/\\$1/g;
2031                 $value =~ s/\./\\./g;
2032                 $value =~ s/\*/.*/g;
2033                 $value =~ s/\?/./g;
2034                 my @items = grep /\S/, split /\s*,\s*/, $value;
2035                 for (@items) {
2036                         s/\s+/\\s+/g;
2037                         my $extra = $_;
2038                         if ($base && $extra =~ s/^\.\*\\\.//){
2039                                 push(@items,$extra) if $extra;
2040                         }
2041                 }
2042                 $value = join '|', @items;
2043         }
2044         return parse_regex($var, $value);
2045 }
2046
2047 sub external_global {
2048         my ($value) = @_;
2049
2050         my $main = {};
2051
2052         my @sets = grep /\w/, split /[\s,]+/, $value;
2053 #::logDebug( "Parsing sets=" . join(",", @sets) . "\n" );
2054
2055         no strict 'refs';
2056
2057         for my $set (@sets) {
2058 #::logDebug( "Parsing $set\n" );
2059                 my @keys = split /->/, $set;
2060                 my ($k, $v) = split /=/, $keys[0];
2061                 my $major;
2062                 my $var;
2063                 if($k =~ m/^(\w+)::(\w+)$/) {
2064                         $major = $1;
2065                         $var = $2;
2066                 }
2067                 $major ||= 'Global';
2068                 $v ||= $var;
2069                 my $walk = ${"${major}::$var"};
2070                 my $ref = $main->{$v} = $walk;
2071                 for(my $i = 1; $i < @keys; $i++) {
2072                         my $current = $keys[$i];
2073 #::logDebug( "Walking $current\n" );
2074                         if($i == $#keys) {
2075                                 if( CORE::ref($ref) eq 'ARRAY' ) {
2076                                         $current =~ s/\D+//g;
2077                                         $current =~ /^\d+$/
2078                                                 or config_error("External: Bad array index $current from $set");
2079                                         $ref->[$current] = $walk->[$current];
2080 #::logDebug( "setting $current to ARRAY\n" );
2081                                 }
2082                                 elsif( CORE::ref($ref) eq 'HASH' ) {
2083                                         $ref->{$current} = $walk->{$current};
2084 #::logDebug( "setting $current to HASH\n" );
2085                                 }
2086                                 else {
2087                                         config_error("External: bad data structure for $set");
2088                                 }
2089                         }
2090                         else {
2091                                 $walk = $walk->{$current};
2092 #::logDebug( "Walking $current\n" );
2093                                 if( CORE::ref($walk) eq 'HASH' ) {
2094                                         $ref->{$current} = {};
2095                                         $ref = $ref->{$current};
2096                                 }
2097                                 else {
2098                                         config_error("External: bad data structure for $set");
2099                                 }
2100                         }
2101                 }
2102         }
2103         return $main;
2104 }
2105
2106 # Set the External environment, dumps, etc.
2107 sub external_cat {
2108         my ($value) = @_;
2109
2110         my $c = $C
2111                 or config_error( "Not in catalog configuration context." );
2112
2113         my $main = {};
2114         my @sets = grep /\w/, split /[\s,]+/, $value;
2115         for my $set (@sets) {
2116                 my @keys = split /->/, $set;
2117                 my $ref  = $main;
2118                 my $walk = $c;
2119                 for(my $i = 0; $i < @keys; $i++) {
2120                         my $current = $keys[$i];
2121                         if($i == $#keys) {
2122                                 if( CORE::ref($ref) eq 'ARRAY' ) {
2123                                         $current =~ s/\D+//g;
2124                                         $current =~ /^\d+$/
2125                                                 or config_error("External: Bad array index $current from $set");
2126                                         $ref->[$current] = $walk->[$current];
2127                                 }
2128                                 elsif( CORE::ref($ref) eq 'HASH' ) {
2129                                         $ref->{$current} = $walk->{$current};
2130                                 }
2131                                 else {
2132                                         config_error("External: bad data structure for $set");
2133                                 }
2134                         }
2135                         else {
2136                                 $walk = $walk->{$current};
2137                                 if( CORE::ref($walk) eq 'HASH' ) {
2138                                         $ref->{$current} ||= {};
2139                                         $ref = $ref->{$current};
2140                                 }
2141                                 else {
2142                                         config_error("External: bad data structure for $set");
2143                                 }
2144                         }
2145                 }
2146         }
2147
2148         return $main;
2149 }
2150
2151 # Set up an ActionMap or FormAction or FileAction
2152 sub parse_action {
2153         my ($var, $value, $mapped) = @_;
2154         if (! $value) {
2155                 return $InitializeEmpty{$var} ? '' : {};
2156         }
2157
2158         return if $Vend::ExternalProgram;
2159
2160         my $c;
2161         if($mapped) {
2162                 $c = $mapped;
2163         }
2164         elsif(defined $C) {
2165                 $c = $C->{$var} ||= {};
2166         }
2167         else {
2168                 no strict 'refs';
2169                 $c = ${"Global::$var"} ||= {};
2170         }
2171
2172         if (defined $C and ! $c->{_mvsafe}) {
2173                 my $calc = Vend::Interpolate::reset_calc();
2174                 $c->{_mvsafe} = $calc;
2175         }
2176         my ($name, $sub) = split /\s+/, $value, 2;
2177
2178         $name =~ s/-/_/g;
2179
2180         ## Determine if we are in a catalog config, and if
2181         ## perl should be global and/or strict
2182         my $nostrict;
2183         my $perlglobal = 1;
2184
2185         if($C) {
2186                 $nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
2187                 $perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
2188         }
2189
2190         # Untaint and strip this pup
2191         $sub =~ s/^\s*((?s:.)*\S)\s*//;
2192         $sub = $1;
2193
2194         if($sub !~ /\s/) {
2195                 no strict 'refs';
2196                 if($sub =~ /::/ and ! $C) {
2197                         $c->{$name} = \&{"$sub"};
2198                 }
2199                 else {
2200                         if($C and $C->{Sub}) {
2201                                 $c->{$name} = $C->{Sub}{$sub};
2202                         }
2203
2204                         if(! $c->{$name} and $Global::GlobalSub) {
2205                                 $c->{$name} = $Global::GlobalSub->{$sub};
2206                         }
2207                 }
2208                 if(! $c->{$name} and $AllowScalarAction{$var}) {
2209                         $c->{$name} = $sub;
2210                 }
2211                 elsif(! $c->{$name}) {
2212                         $@ = errmsg("Mapped %s action routine '%s' is non-existent.", $var, $sub);
2213                 }
2214         }
2215         elsif ( ! $mapped and $sub !~ /^sub\b/) {
2216                 if($AllowScalarAction{$var}) {
2217                         $c->{$name} = $sub;
2218                 }
2219                 else {
2220                         my $code = <<EOF;
2221 sub {
2222                                 return Vend::Interpolate::interpolate_html(<<EndOfThisHaiRYTHING);
2223 $sub
2224 EndOfThisHaiRYTHING
2225 }
2226 EOF
2227                         $c->{$name} = eval $code;
2228                 }
2229         }
2230         elsif ($perlglobal) {
2231                 package Vend::Interpolate;
2232                 if($nostrict) {
2233                         no strict;
2234                         $c->{$name} = eval $sub;
2235                 }
2236                 else {
2237                         $c->{$name} = eval $sub;
2238                 }
2239         }
2240         else {
2241                 package Vend::Interpolate;
2242                 $c->{$name} = $c->{_mvsafe}->reval($sub);
2243         }
2244         if($@) {
2245                 config_warn("Action '%s' did not compile correctly (%s).", $name, $@);
2246         }
2247         return $c;
2248
2249 }
2250
2251 sub get_directive {
2252         my $name = shift;
2253         $name = $CDname{lc $name} || $name;
2254         no strict 'refs';
2255         if($C) {
2256                 return $C->{$name};
2257         }
2258         else {
2259                 return ${"Global::$name"};
2260         }
2261 }
2262
2263 # Adds features contained in FeatureDir called by catalog
2264
2265 sub parse_feature {
2266         my ($var, $value) = @_;
2267         my $c = $C->{$var} || {};
2268         return $c unless $value;
2269
2270         $value =~ s/^\s+//;
2271         $value =~ s/\s+$//;
2272         my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
2273
2274         unless(-d $fdir) {
2275                 config_warn("Feature '%s' not found, skipping.", $value);
2276                 return $c;
2277         }
2278
2279         # Get the global install files and remove them from the config list
2280         my @gfiles = glob("$fdir/*.global");
2281         my %seen;
2282         @seen{@gfiles} = @gfiles;
2283
2284         # Get the init files and remove them from the config list
2285         my @ifiles = glob("$fdir/*.init");
2286         @seen{@ifiles} = @ifiles;
2287
2288         # Get the uninstall files and remove them from the config list
2289         my @ufiles = glob("$fdir/*.uninstall");
2290         @seen{@ufiles} = @ifiles;
2291
2292         # Any other files are config files
2293         my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
2294
2295         # directories are for copying
2296         my @cdirs = grep -d $_, @cfiles;
2297
2298         # strip the directories from the config list, leaving catalog.cfg stuff
2299         @cfiles   = grep -f $_, @cfiles;
2300
2301         # Don't install global more than once
2302         @gfiles = grep ! $Global::FeatureSeen{$_}++, @gfiles;
2303
2304         # Place the catalog configuration in the config list
2305         unshift @include, @cfiles;
2306
2307         my @copy;
2308         my $wanted = sub {
2309                 return unless -f $_;
2310                 my $n = $File::Find::name;
2311                 $n =~ s{^$fdir/}{};
2312                 my $d = $File::Find::dir;
2313                 $d =~ s{^$fdir/}{};
2314                 push @copy, [$n, $d];
2315         };
2316
2317         if(@cdirs) {
2318                 File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
2319         }
2320 #::logDebug("gfiles=" . ::uneval(\@gfiles));
2321 #::logDebug("cfiles=" . ::uneval(\@cfiles));
2322 #::logDebug("ifiles=" . ::uneval(\@ifiles));
2323 #::logDebug("ufiles=" . ::uneval(\@ufiles));
2324 #::logDebug("cdirs=" . ::uneval(\@cdirs));
2325 #::logDebug("copy=" . ::uneval(\@copy));
2326
2327         for(@copy) {
2328                 my ($n, $d) = @$_;
2329
2330                 my $tf = Vend::File::catfile($C->{VendRoot}, $n);
2331                 next if -f $tf;
2332
2333                 my $td = Vend::File::catfile($C->{VendRoot}, $d);
2334                 unless(-d $td) {
2335                         File::Path::mkpath($td)
2336                                 or do {
2337                                         config_warn("Feature %s not able to make directory %s", $value, $td);
2338                                         next;
2339                                 };
2340                 }
2341                 File::Copy::copy("$fdir/$n", $tf)
2342                         or do {
2343                                 config_warn("Feature %s not able to copy %s to %s", $value, "$fdir/$n", $tf);
2344                                 next;
2345                         };
2346         }
2347
2348         for(@gfiles) {
2349                 global_chunk($_);
2350         }
2351
2352         if(@ifiles) {
2353                 my $initdir = Vend::File::catfile($C->{ConfDir}, 'init', $value);
2354                 File::Path::mkpath($initdir) unless -d $initdir;
2355                 my $unfile = Vend::File::catfile($initdir, 'uninstall');
2356
2357                 ## Feature was previously uninstalled, we *do* need to run init
2358                 my $ignore = -f $unfile;
2359
2360                 if($ignore) {
2361                         unlink $unfile
2362                                         or die errmsg("Couldn't unlink $unfile: $!");
2363                 }
2364
2365                 for(@ifiles) {
2366                         my $fn = $_;
2367                         $fn =~ s{^$fdir/}{};
2368                         if($ignore) {
2369                                 unlink "$initdir/$fn"
2370                                         or die errmsg("Couldn't unlink $fn: $!");
2371                         }
2372
2373                         next if -f "$initdir/$fn";
2374                         $C->{Init} ||= [];
2375                         push @{$C->{Init}}, [$_, "$initdir/$fn"];
2376                 }
2377         }
2378
2379 #::logDebug("Init=" . ::uneval($C->{Init}));
2380
2381         $c->{$value} = 1;
2382         return $c;
2383 }
2384
2385 sub uninstall_feature {
2386         my ($value) = @_;
2387         my $c = $Vend::Cfg
2388                 or die "Not in catalog context.\n";
2389
2390 #::logDebug("Running uninstall for cat=$Vend::Cat, from cfg ref=$c->{CatalogName}");
2391         $value =~ s/^\s+//;
2392         $value =~ s/\s+$//;
2393         my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
2394
2395         unless(-d $fdir) {
2396                 config_warn("Feature '%s' not found, skipping.", $value);
2397                 return $c;
2398         }
2399
2400         my $etag = errmsg("feature %s uninstall -- ", $value);
2401
2402         # Get the global install files and remove them from the config list
2403         my @gfiles = glob("$fdir/*.global");
2404         my %seen;
2405         @seen{@gfiles} = @gfiles;
2406
2407         # Get the init files and remove them from the config list
2408         my @ifiles = glob("$fdir/*.init");
2409         @seen{@ifiles} = @ifiles;
2410
2411         # Get the uninstall files and remove them from the config list
2412         my @ufiles = glob("$fdir/*.uninstall");
2413         @seen{@ufiles} = @ifiles;
2414
2415         # Any other files are config files
2416         my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
2417
2418         # directories are for copying
2419         my @cdirs = grep -d $_, @cfiles;
2420
2421         my $Tag = new Vend::Tags;
2422
2423         my @copy;
2424         my @errors;
2425         my @warnings;
2426
2427         my $wanted = sub {
2428                 return unless -f $_;
2429                 my $n = $File::Find::name;
2430                 $n =~ s{^$fdir/}{};
2431                 my $d = $File::Find::dir;
2432                 $d =~ s{^$fdir/}{};
2433                 push @copy, [$n, $d];
2434         };
2435
2436         if(@cdirs) {
2437                 File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
2438         }
2439 #::logDebug("ufiles=" . ::uneval(\@ufiles));
2440 #::logDebug("ifiles=" . ::uneval(\@ifiles));
2441 #::logDebug("cdirs=" . ::uneval(\@cdirs));
2442 #::logDebug("copy=" . ::uneval(\@copy));
2443
2444         for(@ufiles) {
2445 #::logDebug("Running uninstall file $_");
2446                 my $save = $Global::AllowGlobal->{$Vend::Cat};
2447                 $Global::AllowGlobal->{$Vend::Cat} = 1;
2448                 open UNFILE, "< $_"
2449                         or do {
2450                                 push @errors, $etag . errmsg("error reading %s: %s", $_, $!);
2451                         };
2452                 my $chunk = join "", <UNFILE>;
2453                 close UNFILE;
2454
2455 #::logDebug("uninstall chunk length=" . length($chunk));
2456
2457                 my $out;
2458                 eval {
2459                         $out = Vend::Interpolate::interpolate_html($chunk);
2460                 };
2461
2462                 if($@) {
2463                         push @errors, $etag . errmsg("error running uninstall %s: %s", $_, $@);
2464                 }
2465
2466                 push @warnings, $etag . errmsg("message from %s: %s", $_, $out)
2467                         if $out =~ /\S/;
2468
2469                 $Global::AllowGlobal->{$Vend::Cat} = $save;
2470         }
2471
2472         for(@copy) {
2473                 my ($n, $d) = @$_;
2474
2475                 my $tf = Vend::File::catfile($c->{VendRoot}, $n);
2476                 next unless -f $tf;
2477
2478                 my $contents1 = Vend::File::readfile($tf);
2479
2480                 my $sf = "$fdir/$n";
2481
2482                 open UNSRC, "< $sf"
2483                         or die $etag . errmsg("Couldn't read uninstall source file %s: %s", $sf, $!);
2484
2485                 local $/;
2486                 my $contents2 = <UNSRC>;
2487
2488                 if($contents1 ne $contents2) {
2489                         push @warnings, $etag . errmsg("will not uninstall %s, changed.", $tf);
2490                         next;
2491                 }
2492
2493                 unlink $tf
2494                         or do {
2495                                 push @errors,
2496                                         $etag . errmsg("$etag couldn't unlink file %s: %s", $tf, $!);
2497                                 next;
2498                         };
2499
2500                 my $td = Vend::File::catfile($c->{VendRoot}, $d);
2501                 my @left = glob("$td/*");
2502                 push @left, glob("$td/.?*");
2503                 next if @left;
2504                 File::Path::rmtree($td);
2505         }
2506
2507         if(@ifiles) {
2508 #::logDebug("running uninstall touch and init");
2509                 my $initdir = Vend::File::catfile($c->{ConfDir}, 'init', $value);
2510                 File::Path::mkpath($initdir) unless -d $initdir;
2511                 my $fn = Vend::File::catfile($initdir, 'uninstall');
2512 #::logDebug("touching uninstall file $fn");
2513                 open UNFILE, ">> $fn"
2514                         or die errmsg("Couldn't create uninstall flag file %s: %s", $fn, $!);
2515                 print UNFILE $etag . errmsg("uninstalled at %s.\n", scalar(localtime));
2516                 close UNFILE;
2517         }
2518
2519
2520         my $errors;
2521         for(@errors) {
2522                 $Tag->error({ set => $_});
2523                 ::logError($_);
2524                 $errors++;
2525         }
2526
2527         for(@warnings) {
2528                 $Tag->warnings($_);
2529                 ::logE