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                 ::logError($_);
2530         }
2531
2532         return ! $errors;
2533 }
2534
2535
2536 # Changes configuration directives into Variable settings, i.e.
2537 # DescriptionField becomes __DescriptionField__, ProductFiles becomes
2538 # __ProductFiles_0__, ProductFiles_1__, etc. Doesn't handle hash keys
2539 # that have non-word chars.
2540
2541 sub parse_autovar {
2542         my($var, $val) = @_;
2543
2544         return '' if ! $val;
2545
2546         my @dirs = grep /\w/, split /[\s,\0]+/, $val;
2547
2548         my $name;
2549         foreach $name (@dirs) {
2550                 next unless $name =~ /^\w+$/;
2551                 my $val = get_directive($name);
2552                 if(! ref $val) {
2553                         parse_variable('Variable', "$name $val");
2554                 }
2555                 elsif ($val =~ /ARRAY/) {
2556                         for(my $i = 0; $i < @$val; $i++) {
2557                                 my $an = "${name}_$i";
2558                                 parse_variable('Variable', "$an $val->[$i]");
2559                         }
2560                 }
2561                 elsif ($val =~ /HASH/) {
2562                         my ($k, $v);
2563                         while ( ($k, $v) = each %$val) {
2564                                 next unless $k =~ /^\w+$/;
2565                                 parse_variable('Variable', "$k $v");
2566                         }
2567                 }
2568                 else {
2569                         config_warn('%s directive not parsable by AutoVariable', $name);
2570                 }
2571         }
2572 }
2573
2574
2575 # Checks to see if a globalsub, sub, usertag, or Perl module is present
2576 # If called with a third parameter, is just "suggestion"
2577 # If called with a fourth parameter, is just capability check
2578
2579 sub parse_capability {
2580         return parse_require(@_, 1, 1);
2581 }
2582
2583 sub parse_tag_group {
2584         my ($var, $setting) = @_;
2585
2586         my $c;
2587         if(defined $C) {
2588                 $c = $C->{$var} || {};
2589         }
2590         else {
2591                 no strict 'refs';
2592                 $c = ${"Global::$var"} || {};
2593         }
2594
2595         $setting =~ tr/-/_/;
2596         $setting =~ s/[,\s]+/ /g;
2597         $setting =~ s/^\s+//;
2598         $setting =~ s/\s+$//;
2599
2600         my @pairs = Text::ParseWords::shellwords($setting);
2601
2602         while(@pairs) {
2603                 my ($group, $sets) = splice @pairs, 0, 2;
2604                 my @sets = grep $_, split /\s+/, $sets;
2605                 my @groups = grep /:/, @sets;
2606                 @sets = grep $_ !~ /:/, @sets;
2607                 for(@groups) {
2608                         next unless $c->{$_};
2609                         push @sets, @{$c->{$_}};
2610                 }
2611                 $c->{$group} = \@sets;
2612         }
2613         return $c;
2614 }
2615
2616 my %incmap = qw/TagInclude TagGroup/;
2617 sub parse_tag_include {
2618         my ($var, $setting) = @_;
2619
2620         my $c;
2621         my $g;
2622
2623         my $mapper = $incmap{$var} || 'TagGroup';
2624         if(defined $C) {
2625                 $c = $C->{$var} || {};
2626                 $g = $C->{$mapper} || {};
2627         }
2628         else {
2629                 no strict 'refs';
2630                 $c = ${"Global::$var"} || {};
2631                 $g = ${"Global::$mapper"} || {};
2632         }
2633
2634         $setting =~ s/"/ /g;
2635         $setting =~ s/^\s+//;
2636         $setting =~ s/\s+$//;
2637         $setting =~ s/[,\s]+/ /g;
2638
2639         if($setting eq 'ALL') {
2640                 return { ALL => 1 };
2641         }
2642
2643         delete $c->{ALL};
2644
2645         get_system_groups() unless $SystemGroupsDone;
2646
2647         my @incs = Text::ParseWords::shellwords($setting);
2648
2649         for(@incs) {
2650                 my @things;
2651                 my $not = 0;
2652                 if(/:/) {
2653                         $not = 1 if s/^!//;
2654                         if(! $g->{$_}) {
2655                                 config_warn(
2656                                         "unknown %s %s included from %s",
2657                                         $mapper,
2658                                         $_,
2659                                         $var,
2660                                 );
2661                         }
2662                         else {
2663                                 @things = @{$g->{$_}}
2664                         }
2665                 }
2666                 else {
2667                         @things = ($_);
2668                 }
2669                 for(@things) {
2670                         my $not = s/^!// ? ! $not : $not;
2671                         $c->{$_} = not $not;
2672                 }
2673         }
2674         return $c;
2675 }
2676
2677 sub parse_suggest {
2678         return parse_require(@_, 1);
2679 }
2680
2681 sub parse_require {
2682         my($var, $val, $warn, $cap) = @_;
2683
2684         return if $Vend::ExternalProgram;
2685         return if $Vend::ControllingInterchange;
2686
2687         my $carptype;
2688         my $error_message;
2689         my $pathinfo;
2690
2691         if($val =~ s/\s+"(.*)"//s) {
2692                 $error_message = "\a\n\n$1\n";
2693         }
2694
2695         if($val =~ s%\s+((/[\w.-]+)+)%%) {
2696                 $pathinfo = $1;
2697         }
2698
2699         if($cap) {
2700                 $carptype = sub { return; };
2701         }
2702         elsif($warn) {
2703                 $carptype = sub { return parse_message('', @_) };
2704                 $error_message = "\a\n\nSuggest %s %s for proper catalog operation. Not all functions will work!\n"
2705                         unless $error_message;
2706         }
2707         else {
2708                 $carptype = \&config_error;
2709                 $error_message ||= 'Required %s %s not present. Aborting '
2710                         . ($C ? 'catalog' : 'Interchange daemon') . '.';
2711         }
2712
2713         my $nostrict;
2714         my $perlglobal = 1;
2715
2716         if($C) {
2717                 $nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
2718                 $perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
2719         }
2720
2721         my $vref = $C ? $C->{Variable} : $Global::Variable;
2722         my $require;
2723         my $testsub = sub { 0 };
2724         my $name;
2725         if($val =~ s/^globalsub\s+//i) {
2726                 $require = $Global::GlobalSub;
2727                 $name = 'GlobalSub';
2728         }
2729         elsif($val =~ s/^sub\s+//i) {
2730                 $require = $C->{Sub};
2731                 $name = 'Sub';
2732         }
2733         elsif($val =~ s/^taggroup\s+//i) {
2734                 $require = $Global::UserTag->{Routine};
2735                 my @groups = grep /\S/, split /[\s,]+/, $val;
2736                 my @needed;
2737                 my $ref;
2738                 for (@groups) {
2739                         if($ref = $Global::TagGroup->{$_}) {
2740                                 push @needed, @$ref;
2741                         }
2742                         else {
2743                                 push @needed, $_;
2744                         }
2745                 }
2746                 $name = "TagGroup $val member";
2747                 $val = join " ", @needed;
2748         }
2749         elsif($val =~ s/^usertag\s+//i) {
2750                 $require = {};
2751                 $name = 'UserTag';
2752
2753                 $testsub = sub {
2754                         my $name = shift;
2755
2756                         my @tries = ($Global::UserTag->{Routine});
2757                         push(@tries,$C->{UserTag}->{Routine}) if $C;
2758
2759                         foreach (@tries) {
2760                                 return 1 if defined $_->{$name};
2761                         }
2762                         return 0;
2763                 };
2764         }
2765         elsif($val =~ s/^(?:perl)?module\s+//i) {
2766                 $require = {};
2767                 $name = 'Perl module';
2768                 $testsub = sub {
2769                         my $module = shift;
2770                         my $oldtype = '';
2771                         if($module =~ s/\.pl$//) {
2772                                 $oldtype = '.pl';
2773                         }
2774                         $module =~ /[^\w:]/ and return undef;
2775                         if($perlglobal) {
2776                                 if ($pathinfo) {
2777                                         unshift(@INC, $pathinfo);
2778                                 }
2779                                 eval "require $module$oldtype;";
2780                                 my $error = $@;
2781                                 if ($pathinfo) {
2782                                         shift(@INC);
2783                                 }
2784                                 ::logGlobal("while eval'ing module %s got [%s]\n", $module, $error) if $error;
2785                                 return ! $error;
2786                         }
2787                         else {
2788                                 # Since we aren't safe to actually require, we will
2789                                 # just look for a readable module file
2790                                 $module =~ s!::!/!g;
2791                                 $oldtype = '.pm' if ! $oldtype;
2792                                 my $found;
2793                                 for(@INC) {
2794                                         next unless -f "$_/$module$oldtype" and -r _;
2795                                         $found = 1;
2796                                 }
2797                                 return $found;
2798                         }
2799                 };
2800         }
2801         elsif ($val =~ s/^(?:perl)?include\s+//i) {
2802                 my $path = Vend::File::make_absolute_file($val, 1);
2803                 $require = {};
2804                 $name = 'Perl include path';
2805                 $testsub =
2806                         sub {
2807                                 if (-d $path) {
2808                                         unshift @INC, $path;
2809                                         return 1;
2810                                 }
2811                                 return 0;
2812                         };
2813         }
2814         elsif ($val =~ s/^file\s*//i) {
2815                 $require = {};
2816                 $name = 'Readable file';
2817                 $val = $pathinfo unless $val;
2818
2819                 $testsub = sub {
2820                         my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
2821                         if ($C && $path =~ s:^/+::) {
2822                                 $path = "$C->{VendRoot}/$path";
2823                         }
2824                         return -r $path;
2825                 };
2826         }
2827         elsif ($val =~ s/^executable\s*//i) {
2828                 $require = {};
2829                 $name = 'Executable file';
2830                 $val = $pathinfo unless $val;
2831
2832                 $testsub = sub {
2833                         my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
2834                         if ($C && $path =~ s:^/+::) {
2835                                 $path = "$C->{VendRoot}/$path";
2836                         }
2837                         return -x $path;
2838                 };
2839         }
2840         my @requires = grep /\S/, split /\s+/, $val;
2841
2842         my $uname = uc $name;
2843         $uname =~ s/.*\s+//;
2844         for(@requires) {
2845                 $vref->{"MV_REQUIRE_${uname}_$_"} = 1;
2846                 next if defined $require->{$_};
2847                 next if $testsub->($_);
2848                 delete $vref->{"MV_REQUIRE_${uname}_$_"};
2849                 $carptype->( $error_message, $name, $_ );
2850         }
2851         return '';
2852 }
2853
2854 # Sets the special variable remap array
2855 #
2856
2857 my $Varnames;
2858 INITVARS: {
2859         local($/);
2860         $Varnames = <DATA>;
2861 }
2862
2863 sub parse_varname {
2864         my($item,$settings) = @_;
2865
2866         return if $Vend::ExternalProgram;
2867
2868         my($iv,$vn,$k,$v,@set);
2869 #logDebug("parse_varname: $settings");
2870         if(defined $C) {
2871                 return '' if ! $settings;
2872                 $C->{IV} = { %{$Global::IV} } if ! $C->{IV};
2873                 $C->{VN} = { %{$Global::VN} } if ! $C->{VN};
2874                 $iv = $C->{IV};
2875                 $vn = $C->{VN};
2876         }
2877         else {
2878                 if (! $Global::VarName) {
2879                         unless (-s "$Global::ConfDir/varnames" && -r _) {
2880                                 $settings = $Varnames . "\n$settings";
2881                                 writefile("$Global::ConfDir/varnames", $Varnames);
2882                         }
2883                         else {
2884                                 $settings = readfile("$Global::ConfDir/varnames");
2885                         }
2886                 }
2887                 undef $Varnames;
2888                 $Global::IV = {} if ! $Global::IV;
2889                 $Global::VN = {} if ! $Global::VN;
2890                 $iv = $Global::IV;
2891                 $vn = $Global::VN;
2892         }
2893
2894         @set = grep /\S/, split /\s+/, $settings;
2895         while( $k = shift @set, $v = shift @set ) {
2896                 $vn->{$k} = $v;
2897                 $iv->{$v} = $k;
2898         }
2899         return 1;
2900 }
2901
2902 sub parse_word {
2903         my($name, $val) = @_;
2904
2905         return '' unless $val;
2906         unless ($val =~ /^\w+$/) {
2907                 config_error("Illegal non-word value in '%s' for %s", $val, $name);
2908         }
2909         return $val;
2910 }
2911
2912 # Allow addition of a new catalog directive
2913 sub parse_directive {
2914         my($name, $val) = @_;
2915
2916         return '' unless $val;
2917         my($dir, $parser, $default) = split /\s+/, $val, 3 ;
2918         if(! defined &{"parse_$parser"} and ! defined &{"$parser"}) {
2919                 if (defined $Global::GlobalSub->{"parse_$parser"}) {
2920                         no strict 'refs';
2921                         *{"Vend::Config::parse_$parser"} = $Global::GlobalSub->{"parse_$parser"};
2922                 } else {
2923                         $parser = undef;
2924                 }
2925         }
2926         $default = '' if ! $default or $default eq 'undef';
2927         $Global::AddDirective = [] unless $Global::AddDirective;
2928         push @$Global::AddDirective, [ $dir, $parser, $default ];
2929         return $Global::AddDirective;
2930 }
2931
2932 # Allow a subcatalog value to completely replace a base value
2933 sub parse_replace {
2934         my($name, $val) = @_;
2935
2936         return {} unless $val;
2937
2938         $C->{$val} = get_catalog_default($val);
2939         $C->{$name}->{$val} = 1;
2940         $C->{$name};
2941 }
2942
2943
2944 # Send a message during configuration, goes to terminal if during
2945 # daemon startup, always goes to error log
2946 sub parse_message {
2947         my($name, $val) = @_;
2948
2949         return '' unless $val;
2950
2951         return 1 if $Vend::Quiet;
2952
2953         my $strip;
2954         my $info_only;
2955         ## strip trailing whitespace if -n beins message
2956         while($val =~ s/^-([ni])\s+//) {
2957                 $1 eq 'n' and $val =~ s/^-n\s+// and $strip = 1 and $val =~ s/\s+$//;
2958                 $info_only = 1 if $1 eq 'i';
2959         }
2960
2961         my $msg = errmsg($val,
2962                                                 $name,
2963                                                 $.,
2964                                                 $configfile,
2965                                 );
2966
2967         if($info_only and $Global::Foreground) {
2968                 print $msg;
2969         }
2970         else {
2971                 logGlobal({level => 'info', strip => $strip },
2972                                 errmsg($val,
2973                                                 $name,
2974                                                 $.,
2975                                                 $configfile,
2976                                 )
2977                 );
2978         }
2979 }
2980
2981
2982 # Warn about directives no longer supported in the configuration file.
2983 sub parse_warn {
2984         my($name, $val) = @_;
2985
2986         return '' unless $val;
2987
2988         ::logGlobal({level => 'info'},
2989                                 errmsg("Directive %s no longer supported at line %s of %s.",
2990                                                 $name,
2991                                                 $.,
2992                                                 $configfile,
2993                                 )
2994         );
2995 }
2996
2997 # Each of the parse functions accepts the value of a directive from the
2998 # configuration file as a string and either returns the parsed value or
2999 # signals a syntax error.
3000
3001 # Sets a boolean array for any type of item
3002 sub parse_boolean {
3003         my($item,$settings) = @_;
3004         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3005         my $c;
3006
3007         if(defined $C) {
3008                 $c = $C->{$item} || {};
3009         }
3010         else {
3011                 no strict 'refs';
3012                 $c = ${"Global::$item"} || {};
3013         }
3014
3015         for (@setting) {
3016                 $c->{$_} = 1;
3017         }
3018         return $c;
3019 }
3020
3021 # Sets a boolean array, but configurable value with tag=value
3022 sub parse_boolean_value {
3023         my($item,$settings) = @_;
3024         my(@setting) = split /[\s,]+/, $settings;
3025         my $c;
3026
3027         if(defined $C) {
3028                 $c = $C->{$item} || {};
3029         }
3030         else {
3031                 no strict 'refs';
3032                 $c = ${"Global::$item"} || {};
3033         }
3034
3035         for (@setting) {
3036                 my ($k,$v);
3037                 if(/=/) {
3038                         ($k,$v) = split /=/, $_, 2;
3039                 }
3040                 else {
3041                         $k = $_;
3042                         $v = 1;
3043                 }
3044                 $c->{$k} = $v;
3045         }
3046         return $c;
3047 }
3048
3049 use POSIX qw(
3050                                 setlocale localeconv
3051                                 LC_ALL          LC_CTYPE        LC_COLLATE
3052                                 LC_MONETARY     LC_NUMERIC      LC_TIME
3053                         );
3054
3055 # Sets the special locale array. Tries to use POSIX setlocale,
3056 # accepts a 'custom' setting with the proper definitions of
3057 # decimal_point,  mon_thousands_sep, and frac_digits (the only supported at
3058 # the moment).  Otherwise uses US-English settings if not set.
3059 #
3060 sub parse_locale {
3061         my($item,$settings) = @_;
3062         return ($settings || '') unless $settings =~ /[^\d.]/;
3063         $settings = '' if "\L$settings" eq 'default';
3064         my $name;
3065         my ($c, $store);
3066         if(defined $C) {
3067                 $c = $C->{$item} || { };
3068                 $C->{$item . "_repository"} = {}
3069                         unless $C->{$item . "_repository"};
3070                 $store = $C->{$item . "_repository"};
3071         }
3072         else {
3073                 no strict 'refs';
3074                 $c = ${"Global::$item"} || {};
3075                 ${"Global::$item" . "_repository"} = {}
3076                         unless ${"Global::$item" . "_repository"};
3077                 $store = ${"Global::$item" . "_repository"};
3078         }
3079
3080         my ($eval, $safe);
3081         if ($settings =~ s/^\s*([-\w.@]+)(?:\s+)?//) {
3082                 $name = $1;
3083
3084                 undef $eval;
3085                 $settings =~ /^\s*{/
3086                         and $settings =~ /}\s*$/
3087                                 and $eval = 1;
3088                 $eval and ! $safe and $safe = new Vend::Safe;
3089                 if(! defined $store->{$name} and $item eq 'Locale') {
3090                     my $past = POSIX::setlocale(POSIX::LC_ALL);
3091                         if(POSIX::setlocale(POSIX::LC_ALL, $name) ) {
3092                                 $store->{$name} = POSIX::localeconv();
3093                         }
3094                         POSIX::setlocale(POSIX::LC_ALL, $past);
3095                 }
3096
3097                 my($sethash);
3098                 if ($eval) {
3099                         $sethash = $safe->reval($settings)
3100                                 or config_warn("bad Locale setting in %s: %s", $name, $@),
3101                                                 $sethash = {};
3102                 }
3103                 else {
3104                         $settings =~ s/^\s+//;
3105                         $settings =~ s/\s+$//;
3106                         $sethash = {};
3107                         %{$sethash} = Text::ParseWords::shellwords($settings);
3108                 }
3109                 $c = $store->{$name} || {};
3110                 my $nodefaults = delete $sethash->{MV_LOCALE_NO_DEFAULTS};
3111                 for (keys %{$sethash}) {
3112                         $c->{$_} = $sethash->{$_};
3113                 }
3114         }
3115         else {
3116                 config_error("Bad locale setting $settings.\n");
3117         }
3118
3119         $C->{LastLocale} = $name if $C and $item eq 'Locale';
3120
3121         $store->{$name} = $c unless $store->{$name};
3122
3123         return $c;
3124 }
3125
3126 #
3127 # Sets a structure like Locale but with the depth and access via key
3128 # No evaled structure setting, only key-value with shell quoting
3129 #
3130 sub parse_structure {
3131         my ($item, $settings) = @_;
3132         return {} unless $settings;
3133         my $key;
3134         my @rest;
3135         ($key, @rest) = Text::ParseWords::shellwords($settings);
3136         my ($c, $e);
3137         if(defined $C) {
3138                 $c = $C->{$item};
3139                 $e = $c->{$key} || { };
3140         }
3141         else {
3142                 no strict 'refs';
3143                 $c = ${"Global::$item"};
3144                 $e = $c->{$key} || {};
3145         }
3146
3147         while(scalar @rest) {
3148                 my $k = shift @rest;
3149                 $e->{$k} = shift @rest;
3150         }
3151         $c->{$key} = $e;
3152         return $c;
3153 }
3154
3155
3156 # Sets the special page array
3157 sub parse_special {
3158         my($item,$settings) = @_;
3159         return {} unless $settings;
3160         my(%setting) = grep /\S/, split /[\s,]+/, $settings;
3161         for (keys %setting) {
3162                 if($Global::NoAbsolute and file_name_is_absolute($setting{$_}) ) {
3163                         config_warn("Absolute file name not allowed: %s", $setting{$_});
3164                         next;
3165                 }
3166                 $C->{$item}{$_} = $setting{$_};
3167         }
3168         return $C->{$item};
3169 }
3170
3171 # Sets up a hash value from a configuration directive, syntax is
3172 #
3173 #   Directive  "key" "value"
3174 #
3175 # quotes are optional if word-only chars
3176
3177 sub parse_hash {
3178         my($item,$settings) = @_;
3179         if (! $settings) {
3180                 return $HashDefaultBlank{$item} ? '' : {};
3181         }
3182
3183         my $c;
3184
3185         if(defined $C) {
3186                 $c = $C->{$item} || {};
3187         }
3188         else {
3189                 no strict 'refs';
3190                 $c = ${"Global::$item"} || {};
3191         }
3192
3193         return hash_string($settings,$c);
3194 }
3195
3196 # Set up illegal values for certain directives
3197 my %IllegalValue = (
3198
3199                 AutoModifier => { qw/   mv_mi 1
3200                                                                 mv_si 1
3201                                                                 mv_ib 1
3202                                                                 group 1
3203                                                                 code  1
3204                                                                 sku   1
3205                                                                 quantity 1
3206                                                                 item  1     /
3207                                                 },
3208                 UseModifier => { qw/   mv_mi 1
3209                                                                 mv_si 1
3210                                                                 mv_ib 1
3211                                                                 group 1
3212                                                                 code  1
3213                                                                 sku   1
3214                                                                 quantity 1
3215                                                                 item  1     /
3216                                                 }
3217 );
3218
3219 my @Dispatches;
3220 my @Cleanups;
3221
3222 %Cleanup_priority = (
3223         AutoEnd => 1,
3224 );
3225
3226 %Dispatch_priority = (
3227         CookieLogin => 1,
3228         Locale => 2,
3229         DiscountSpaces => 5,
3230         Autoload => 8,
3231 );
3232
3233 %Cleanup_code = (
3234         AutoEnd => sub {
3235 #::logDebug("Doing AutoEnd dispatch...");
3236                 Vend::Dispatch::run_macro($Vend::Cfg->{AutoEnd});
3237         },
3238 );
3239
3240 %Dispatch_code = (
3241
3242         Autoload => sub {
3243 #::logDebug("Doing Autoload dispatch...");
3244                 my ($subname, $inspect_sub);
3245
3246                 if ($subname = $Vend::Cfg->{SpecialSub}{autoload_inspect}) {
3247                         $inspect_sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
3248                 }
3249
3250                 Vend::Dispatch::run_macro($Vend::Cfg->{Autoload}, undef, $inspect_sub);
3251         },
3252
3253         CookieLogin => sub {
3254 #::logDebug("Doing CookieLogin dispatch....");
3255                 if(! $Vend::Session->{logged_in}) {
3256                         COOKIELOGIN: {
3257                                 # Clear password cookie and don't allow automatic login
3258                                 # if mv_force_session is overriding the session cookie,
3259                                 # since user may be coming from a sister site where he
3260                                 # was logged out.
3261                                 (Vend::Util::read_cookie('MV_PASSWORD')
3262                                         and Vend::Util::set_cookie('MV_PASSWORD')), last COOKIELOGIN
3263                                                 if $CGI::values{mv_force_session};
3264                                 my $username;
3265                                 my $password;
3266                                 last COOKIELOGIN
3267                                         if  exists  $CGI::values{mv_username}
3268                                         and defined $CGI::values{mv_username};
3269                                 last COOKIELOGIN
3270                                         unless $username = Vend::Util::read_cookie('MV_USERNAME');
3271                                 last COOKIELOGIN
3272                                         unless $password = Vend::Util::read_cookie('MV_PASSWORD');
3273                                 $CGI::values{mv_username} = $username;
3274                                 $CGI::values{mv_password} = $password;
3275                                 my $profile = Vend::Util::read_cookie('MV_USERPROFILE');
3276                                 local(%SIG);
3277                                 undef $SIG{__DIE__};
3278                                 eval {
3279                                         Vend::UserDB::userdb('login', profile => $profile );
3280                                 };
3281                                 if($@) {
3282                                         $Vend::Session->{failure} .= $@;
3283                                 }
3284                         }
3285                 }
3286         },
3287
3288     Locale => sub {
3289 #::logDebug("Doing Locale dispatch...");
3290         my $locale = $::Scratch->{mv_locale};
3291         my $curr = $::Scratch->{mv_currency};
3292         $locale || $curr    or return;
3293
3294         if($locale and ! $::Scratch->{mv_language}) {
3295             $Global::Variable->{LANG}
3296                     = $::Variable->{LANG}
3297                     = $::Scratch->{mv_language}
3298                     = $locale;
3299         }
3300
3301         if($locale) {
3302             return unless defined $Vend::Cfg->{Locale_repository}{$locale};
3303         }
3304         elsif($curr) {
3305             return unless defined $Vend::Cfg->{Locale_repository}{$curr};
3306         }
3307 #::logDebug("running locale dispatch, locale=$locale, currency=$curr");
3308
3309         Vend::Util::setlocale( $locale, $curr, { persist => 1 } );
3310     },
3311
3312         DiscountSpaces => sub {
3313 #::logDebug("Doing DiscountSpaces dispatch...");
3314                 $::Discounts
3315                         = $Vend::Session->{discount}
3316                         = $Vend::Session->{discount_space}{
3317                                         $Vend::DiscountSpaceName = 'main'
3318                                 }
3319                         ||= {};
3320                 my $dspace;
3321                 for (@{$Vend::Cfg->{DiscountSpaceVar}}) {
3322                         next unless $dspace = $CGI::values{$_};
3323 #::logDebug("$_ is set=...");
3324                         last;
3325                 }
3326                 return unless $dspace;
3327                 $Vend::DiscountSpaceName = $dspace;
3328 #::logDebug("Discount space is set=$Vend::DiscountSpaceName...");
3329                 $::Discounts
3330                                 = $Vend::Session->{discount}
3331                                 = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName}
3332                                 ||= {};
3333     },
3334
3335 );
3336
3337 # Set up defaults for certain directives
3338 my $Have_set_global_defaults;
3339
3340 # Set the default search files based on ProductFiles setting
3341 # Honor a NO_SEARCH parameter in the Database structure
3342 # Set MV_DEFAULT_SEARCH_FILE to the {file} entry,
3343 # and set MV_DEFAULT_SEARCH_TABLE to the table name.
3344 #
3345 # Error out if not SubCatalog and can't find a setting.
3346 #
3347 sub set_default_search {
3348         my $setting = $C->{ProductFiles};
3349
3350         if(! $setting) {
3351                 return 1 if $C->{BaseCatalog};
3352                 return (undef, errmsg("No ProductFiles setting!") );
3353         }
3354
3355         my @fout;
3356         my @tout;
3357         my $nofile;
3358         my $notable;
3359
3360         if ($C->{Variable}{MV_DEFAULT_SEARCH_FILE}) {
3361                 @fout =
3362                         grep /\S/,
3363                         split /[\s,]+/,
3364                         $C->{Variable}{MV_DEFAULT_SEARCH_FILE};
3365                 $nofile = 1;
3366                 for(@fout) {
3367                         next if /\./;
3368                         next unless exists $C->{Database}{$_};
3369                         $_ = $C->{Database}{$_}{file};
3370                 }
3371         }
3372         if ($C->{Variable}{MV_DEFAULT_SEARCH_TABLE}) {
3373                 @tout =
3374                         grep defined $C->{Database}{$_},
3375                                 split /[\s,]+/,
3376                                 $C->{Variable}{MV_DEFAULT_SEARCH_TABLE}
3377                 ;
3378                 $notable = 1;
3379         }
3380
3381         for(@$setting) {
3382                 next if $C->{Database}{$_}{NO_SEARCH};
3383                 push @tout, $_ unless $notable;
3384                 next unless defined $C->{Database}{$_}{file};
3385                 push @fout, $C->{Database}{$_}{file}
3386                         unless $nofile;
3387         }
3388         unless (scalar @fout) {
3389                 return 1 if $C->{BaseCatalog};
3390                 return (undef, errmsg("No default search file!") );
3391         }
3392         $C->{Variable}{MV_DEFAULT_SEARCH_FILE}  = \@fout;
3393         $C->{Variable}{MV_DEFAULT_SEARCH_TABLE} = \@tout;
3394         return 1;
3395 }
3396
3397 %Default = (
3398                 ## This rather extensive default setting is not typical for IC,
3399                 ## but performance in pricing routines demands it
3400                 Options => sub {
3401                         my $o = $C->{Options_repository} ||= {};
3402                         my $var = $C->{Variable};
3403
3404                         my @base = qw/Simple Matrix Old48/;
3405                         my %base;
3406                         @base{@base} = @base;
3407
3408                         my %seen;
3409                         my @types = grep !$seen{$_}++, keys %$o, @base;
3410
3411                         for(@types) {
3412                                 my $loc = $o->{$_} ||= {};
3413                                 eval "require Vend::Options::$_;";
3414                                 if($@) {
3415                                         my $msg = $@;
3416                                         config_warn(
3417                                                 "Unable to use options type %s, no module. Error: %s",
3418                                                 $_,
3419                                                 $msg,
3420                                         );
3421                                         undef $o->{$_};
3422                                         next;
3423                                 }
3424                                 eval {
3425                                         my $name = "Vend::Options::${_}::Default";
3426                                         no strict;
3427                                         while(my ($k,$v) = each %{"$name"}) {
3428                                                 next unless $k;
3429                                                 next if exists $loc->{$k};
3430                                                 $loc->{$k} = $v;
3431                                         }
3432                                 };
3433                                 $loc->{map} = {};
3434                                 if($loc->{remap} ||= $C->{Variable}{MV_OPTION_TABLE_MAP}) {
3435                                         $loc->{remap} =~ s/^\s+//;
3436                                         $loc->{remap} =~ s/\s+$//;
3437                                         my @points = split /[\0,\s]+/, $loc->{remap};
3438                                         map { m{(.*?)=(.*)} and $loc->{map}{$1} = $2} @points;
3439                                 }
3440                         }
3441                         $C->{Options} = $o->{default} || $o->{Simple};
3442                 },
3443                 Shipping => sub {
3444                         my $o = $C->{Shipping_repository} ||= {};
3445
3446                         my @base = qw/Postal/;
3447                         my %base;
3448                         @base{@base} = @base;
3449
3450                         my %seen;
3451                         my @types = grep !$seen{$_}++, keys %$o, @base;
3452
3453                         my %module_ignore = qw/resolution 1 default 1/;
3454
3455                         for(@types) {
3456                                 next if $module_ignore{$_};
3457                                 my $loc = $o->{$_} ||= {};
3458                                 eval "require Vend::Ship::$_;";
3459                                 if($@) {
3460                                         my $msg = $@;
3461                                         config_warn(
3462                                                 "Unable to use options type %s, no module. Error: %s",
3463                                                 $_,
3464                                                 $msg,
3465                                         );
3466                                         undef $o->{$_};
3467                                         next;
3468                                 }
3469                                 eval {
3470                                         my $name = "Vend::Ship::${_}::Default";
3471                                         no strict;
3472                                         while(my ($k,$v) = each %{"$name"}) {
3473                                                 next unless $k;
3474                                                 next if exists $loc->{$k};
3475                                                 $loc->{$k} = $v;
3476                                         }
3477                                 };
3478                         }
3479                         $C->{Shipping} = $o->{default} || $o->{Postal};
3480                 },
3481                 UserDB => sub {
3482                                         my $set = $C->{UserDB_repository};
3483                                         for(keys %$set) {
3484                                                 next unless defined $set->{$_}{admin};
3485                                                 $C->{AdminUserDB} = {} unless $C->{AdminUserDB};
3486                                                 $C->{AdminUserDB}{$_} = $set->{$_}{admin};
3487                                         }
3488                                         return 1;
3489                                 },
3490                 UserControl => sub {
3491                                         return 1 unless shift;
3492                                         require Vend::UserControl;
3493                                         return 1;
3494                                 },
3495                 AutoModifier => sub {
3496                                         my $auto = shift;
3497                                         if($C->{OptionsEnable}) {
3498                                                 $auto = $C->{AutoModifier} = []
3499                                                         if ! $auto;
3500                                                 push @$auto, $C->{OptionsEnable};
3501                                         }
3502                                         return 1;
3503                                 },
3504                 OptionsEnable => sub {
3505                                         my $enable = shift
3506                                                 or return 1;
3507                                         return 1 if $C->{OptionsAttribute};
3508                                         $enable =~ s,.*:,,;
3509                                         $C->{OptionsAttribute} = $enable;
3510                                         return 1;
3511                                 },
3512                 Glimpse => sub {
3513                                         return 1 unless shift;
3514                                         require Vend::Glimpse;
3515                                         return 1;
3516                                 },
3517                 SOAP_Socket => sub {
3518                                         return 1 if $Have_set_global_defaults;
3519                                         $Global::SOAP_Socket = ['7780']
3520                                                 if $Global::SOAP and ! $Global::SOAP_Socket;
3521                                         return 1;
3522                                 },
3523                 TcpMap => sub {
3524                                         return 1 if defined $Have_set_global_defaults;
3525                                         my (@sets) = keys %{$Global::TcpMap};
3526                                         if(scalar @sets == 1 and $sets[0] eq '-') {
3527                                                 $Global::TcpMap = {};
3528                                         }
3529                                         return 1 if @sets;
3530                                         $Global::TcpMap->{7786} = '-';
3531                                         return 1;
3532                                 },
3533                 Database => sub {
3534                         my @del;
3535                         for ( keys %{$C->{Database}}) {
3536                                 push @del, $_ unless defined $C->{Database}{$_}{type};
3537                         }
3538                         for(@del) {
3539 #::logDebug("deleted non-existent db $_");
3540                                 delete $C->{Database}{$_};
3541                         }
3542                         return 1;
3543                 },
3544                 Locale => sub {
3545                                                 my $repos = $C->{Locale_repository}
3546                                                         or return 1;
3547                                                 if ($C->{DefaultLocale}) {
3548                                                         my $def = $C->{DefaultLocale};
3549                                                         if (exists($repos->{$def})) {
3550                                                                 $C->{Locale} = $repos->{$def};
3551                                                         }
3552                                                         else {
3553                                                                 return (0, errmsg('Default locale %s missing', $def));
3554                                                         }
3555                                                 }
3556                                                 else {
3557                                                         for(keys %$repos) {
3558                                                                 if($repos->{$_}{default}) {
3559                                                                         $C->{Locale} = $repos->{$_};
3560                                                                         $C->{DefaultLocale} = $_;
3561                                                                 }
3562                                                         }
3563                                                         if(! $C->{DefaultLocale} and $C->{LastLocale}) {
3564                                                                 $C->{DefaultLocale} = $C->{LastLocale};
3565                                                                 $C->{Locale} = $repos->{$C->{LastLocale}};
3566                                                         }
3567                                                 }
3568
3569                                                 # create currency repositories
3570                                                 for my $locale (keys %{$C->{Locale_repository}}) {
3571                                                         for my $key (@Locale_keys_currency) {
3572                                                                 if ($C->{Locale_repository}->{$locale}->{$key}) {
3573                                                                         $C->{Currency_repository}->{$locale}->{$key}
3574                                                                                 = $C->{Locale_repository}->{$locale}->{$key};
3575                                                                 }
3576                                                         }
3577                                                 }
3578
3579                                                 push @Dispatches, 'Locale';
3580                                                 return 1;
3581                                         },
3582
3583                 DiscountSpacesOn => sub {
3584                                         return 1 unless $C->{DiscountSpacesOn};
3585                                         push @Dispatches, 'DiscountSpaces';
3586                                         return 1;
3587                 },
3588                 CookieLogin => sub {
3589                                         return 1 unless $C->{CookieLogin};
3590                                         push @Dispatches, 'CookieLogin';
3591                                         return 1;
3592                 },
3593                 ProductFiles => \&set_default_search,
3594                 VendRoot => sub {
3595                         my $cat_template_dirs = $C->{TemplateDir} || [];
3596                         if ($Global::NoAbsolute) {
3597                                 for (@$cat_template_dirs) {
3598                                         if (absolute_or_relative($_) and ! /^$C->{VendRoot}/) {
3599                                                 config_error("TemplateDir path %s is prohibited by NoAbsolute", $_);
3600                                         }
3601                                 }
3602                         }
3603                         my @paths = map { quotemeta $_ }
3604                                                         $C->{VendRoot},
3605                                                         @$cat_template_dirs,
3606                                                         @{$Global::TemplateDir || []};
3607                         my $re = join "|", @paths;
3608                         $Global::AllowedFileRegex->{$C->{CatalogName}} = qr{^($re)};
3609                         return 1;
3610                 },
3611                 Autoload => sub {
3612                         return 1 unless $C->{Autoload};
3613                         push @Dispatches, 'Autoload';
3614                         return 1;
3615                 },
3616                 AutoEnd => sub {
3617                         return 1 unless $C->{AutoEnd};
3618                         push @Cleanups, 'AutoEnd';
3619                         return 1;
3620                 },
3621                 External => sub {
3622                         return 1 unless $C->{External};
3623                         unless($Global::External) {
3624                                 config_warn("External directive set to Yes, but not allowed by Interchange configuration.");
3625                                 return 1;
3626                         }
3627                         return 1 unless $C->{External};
3628                         unless($Global::ExternalStructure) {
3629                                 $Global::ExternalStructure = external_global($Global::ExternalExport);
3630                         }
3631                         $C->{ExternalExport} = external_cat($C->{ExternalExport});
3632                         $Global::ExternalStructure->{Catalogs}{ $C->{CatalogName} }{external_config}
3633                                 = $C->{ExternalExport};
3634                         Vend::Util::uneval_file($Global::ExternalStructure, $Global::ExternalFile);
3635                         chmod 0644, $Global::ExternalFile;
3636                 },
3637 );
3638
3639 sub global_directive_postprocess {
3640         if ($Global::UrlSepChar eq '&') {
3641                 if ($Global::Variable->{MV_HTML4_COMPLIANT}) {
3642                         $Global::UrlJoiner = '&amp;';
3643                         $Global::UrlSplittor = qr/\&amp;|\&/;
3644                 }
3645                 else {
3646                         $Global::UrlJoiner = '&';
3647                         $Global::UrlSplittor = qr/\&/;
3648                 }
3649         }
3650         else {
3651                 $Global::UrlJoiner = $Global::UrlSepChar;
3652                 $Global::UrlSplittor = qr/[&$Global::UrlSepChar]/o;
3653         }
3654
3655         $Global::CountrySubdomains ||= {};
3656
3657         while (my ($key,$val) = each(%$Global::CountrySubdomains)) {
3658                 $val =~ s/[\s,]+$//;
3659                 next unless $val;
3660
3661                 $val = '\.(?:' . join('|',split('[\s,]+',$val)) . ")\\.$key";
3662                 $Global::CountrySubdomains->{$key} = qr/$val/i;
3663         }
3664 }
3665
3666 sub set_global_defaults {
3667         ## Nothing here currently
3668 }
3669
3670 my @readonly_members = qw/
3671         UserDB_repository
3672         AdminUserDB
3673 /;
3674
3675 sub set_readonly_config {
3676         my $cat = $C->{CatalogName} or return;
3677         my $ro = $Global::ReadOnlyCfg{$cat} ||= {};
3678         for(@readonly_members) {
3679                 $ro->{$_} = copyref($C->{$_});
3680         }
3681 }
3682
3683 sub set_defaults {
3684         @Dispatches = ();
3685         @Cleanups = ();
3686         for(keys %Default) {
3687                 my ($status, $error) = $Default{$_}->($C->{$_});
3688                 next if $status;
3689                 return config_error(
3690                                 errmsg(
3691                                         'Directive %s returned default setting error: %s',
3692                                         $_,
3693                                         $error
3694                                 )
3695                 );
3696         }
3697         @Dispatches = sort { $Dispatch_priority{$a} cmp $Dispatch_priority{$b} } @Dispatches;
3698         @Cleanups = sort { $Cleanup_priority{$a} cmp $Cleanup_priority{$b} } @Cleanups;
3699         for(@Dispatches) {
3700                 push @{ $C->{DispatchRoutines} ||= [] }, $Dispatch_code{$_};
3701         }
3702         for(@Cleanups) {
3703                 push @{ $C->{CleanupRoutines} ||= [] }, $Cleanup_code{$_};
3704         }
3705
3706     # check MV_HTTP_CHARSET against a valid encoding
3707     if ( !$ENV{MINIVEND_DISABLE_UTF8} &&
3708          (my $enc = $C->{Variable}->{MV_HTTP_CHARSET}) ) {
3709         if (my $norm_enc = Vend::CharSet::validate_encoding($enc)) {
3710             if ($norm_enc ne uc($enc)) {
3711                 config_warn("Provided MV_HTTP_CHARSET '$enc' resolved to '$norm_enc'.  Continuing.");
3712                 $C->{Variable}->{MV_HTTP_CHARSET} = $norm_enc;
3713             }
3714         }
3715         else {
3716             config_error("Unrecognized/unsupported MV_HTTP_CHARSET: '%s'.", $enc);
3717             delete $C->{Variable}->{MV_HTTP_CHARSET};
3718         }
3719     }
3720
3721         $Have_set_global_defaults = 1;
3722         return;
3723 }
3724
3725 sub parse_url_sep_char {
3726         my($var,$val) = @_;
3727
3728         $val =~ s/\s+//g;
3729
3730         if($val =~ /[\w%]/) {
3731                 config_error(
3732                         errmsg("%s character value '%s' must not be word character or %%.", $var, $val)
3733                 );
3734         }
3735         elsif(length($val) > 1) {
3736                 config_error(
3737                         "%s character value '%s' longer than one character.",
3738                         $var,
3739                         $val,
3740                 );
3741         }
3742         elsif($val !~ /[&;:]/) {
3743                 config_warn("%s character value '%s' not a recommended value.", $var, $val);
3744         }
3745
3746         return $val;
3747 }
3748
3749 sub check_legal {
3750         my ($directive, $value) = @_;
3751         return 1 unless defined $IllegalValue{$directive}->{$value};
3752         config_error ("\nYou may not use a value of '$value' in the $directive directive.");
3753 }
3754
3755 sub parse_array {
3756         my($item,$settings) = @_;
3757         return '' unless $settings;
3758         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3759
3760         my $c;
3761
3762         if(defined $C) {
3763                 $c = $C->{$item} || [];
3764         }
3765         else {
3766                 no strict 'refs';
3767                 $c = ${"Global::$item"} || [];
3768         }
3769
3770         for (@setting) {
3771                 check_legal($item, $_);
3772                 push @{$c}, $_;
3773         }
3774         $c;
3775 }
3776
3777 sub parse_routine_array {
3778         my($item,$settings) = @_;
3779
3780         return '' unless $settings;
3781
3782         my $c;
3783         if(defined $C) {
3784                 $c = $C->{$item};
3785         }
3786         else {
3787                 no strict 'refs';
3788                 $c = ${"Global::$item"};
3789         }
3790
3791         my @mac;
3792
3793         if($settings =~ /^[-\s\w,]+$/) {
3794                 @mac = grep /\S/, split /[\s,]+/, $settings;
3795         }
3796         else {
3797                 push @mac, $settings;
3798         }
3799
3800         if(ref($c) eq 'ARRAY') {
3801                 push @$c, @mac;
3802         }
3803         elsif($c) {
3804                 $c = [$c, @mac];
3805         }
3806         else {
3807                 $c = scalar(@mac) > 1 ? [ @mac ] : $mac[0];
3808         }
3809
3810         return $c;
3811 }
3812
3813 sub parse_array_complete {
3814         my($item,$settings) = @_;
3815         return '' unless $settings;
3816         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3817
3818         my $c = [];
3819
3820         for (@setting) {
3821                 check_legal($item, $_);
3822                 push @{$c}, $_;
3823         }
3824
3825         $c;
3826 }
3827
3828 sub parse_list_wildcard {
3829         my $value = get_wildcard_list(@_,0);
3830         return '' unless length($value);
3831         return qr/$value/i;
3832 }
3833
3834 sub parse_list_wildcard_full {
3835         my $value = get_wildcard_list(@_,1);
3836         return '' unless length($value);
3837         return qr/^($value)$/i;
3838 }
3839
3840 # Make a dos-ish regex into a Perl regex, check for errors
3841 sub parse_wildcard {
3842         my($var, $value) = @_;
3843         return '' if ! $value;
3844
3845         $value =~ s/\./\\./g;
3846         $value =~ s/\*/.*/g;
3847         $value =~ s/\?/./g;
3848         $value =~
3849                 s[({(?:.+?,)+.+?})]
3850                  [ local $_ = $1; tr/{,}/(|)/; $_ ]eg;
3851         $value =~ s/\s+/|/g;
3852         eval {
3853                 my $never = 'NeVAirBE';
3854                 $never =~ m{$value};
3855         };
3856
3857         if($@) {
3858                 config_error("Bad regular expression in $var.");
3859         }
3860         return $value;
3861 }
3862
3863
3864 # Check that a regex won't cause a syntax error. Uses m{}, which
3865 # should be used for all user-input regexes.
3866 sub parse_regex {
3867         my($var, $value) = @_;
3868
3869         eval {
3870                 my $never = 'NeVAirBE';
3871                 $never =~ m{$value};
3872         };
3873
3874         if($@) {
3875                 config_error("Bad regular expression in $var.");
3876         }
3877         return $value;
3878 }
3879
3880 sub parse_ip_address_regexp {
3881
3882         my ($var, $value) = @_;
3883         return '' unless $value;
3884
3885         eval {
3886                 require Net::IP::Match::Regexp;
3887         };
3888         $@ and config_error("$var directive requires module: $@");
3889
3890         my $re = Net::IP::Match::Regexp::create_iprange_regexp($value)
3891                 or config_error("Improper IP address range for $var");
3892     return $re;
3893 }
3894
3895 # Prepend the Global::VendRoot pathname to the relative directory specified,
3896 # unless it already starts with a leading /.
3897
3898 sub parse_root_dir {
3899         my($var, $value) = @_;
3900         return '' unless $value;
3901         $value = "$Global::VendRoot/$value"
3902                 unless file_name_is_absolute($value);
3903         $value =~ s./+$..;
3904         return $value;
3905 }
3906
3907 sub parse_root_dir_array {
3908         my($var, $value) = @_;
3909         return [] unless $value;
3910
3911         no strict 'refs';
3912         my $c = ${"Global::$var"} || [];
3913
3914         my @dirs = grep /\S/, Text::ParseWords::shellwords($value);
3915
3916         foreach my $dir (@dirs) {
3917                 $dir = "$Global::VendRoot/$dir"
3918                         unless file_name_is_absolute($dir);
3919                 $dir =~ s./+$..;
3920                 push @$c, $dir;
3921         }
3922         return $c;
3923 }
3924
3925 sub parse_dir_array {
3926         my($var, $value) = @_;
3927         return [] unless $value;
3928
3929         $C->{$var} = [] unless $C->{$var};
3930         my $c = $C->{$var} || [];
3931
3932         my @dirs = grep /\S/, Text::ParseWords::shellwords($value);
3933
3934         foreach my $dir (@dirs) {
3935                 unless (allowed_file($dir)) {
3936                         config_error('Path %s not allowed in %s directive',
3937                                                                 $dir, $var);
3938                 }
3939                 $dir = "$C->{VendRoot}/$dir"
3940                         unless file_name_is_absolute($dir);
3941                 $dir =~ s./+$..;
3942                 push @$c, $dir;
3943         }
3944
3945         return $c;
3946 }
3947
3948 sub parse_relative_dir {
3949         my($var, $value) = @_;
3950
3951         if (absolute_or_relative($value)) {
3952                 config_error('Path %s not allowed in %s directive',
3953                                           $value, $var);
3954         }
3955
3956         $C->{Source}{$var} = $value;
3957
3958         $value = "$C->{VendRoot}/$value"
3959                 unless file_name_is_absolute($value);
3960         $value =~ s./+$..;
3961         $value;
3962 }
3963
3964 # Ensure only an integer value in the directive
3965 sub parse_integer {
3966         my($var, $value) = @_;
3967         $value = hex($value) if $value =~ /^0x[\dA-Fa-f]+$/;
3968         $value = oct($value) if $value =~ /^0[0-7]+$/;
3969         config_error("The $var directive (now set to '$value') must be an integer\n")
3970                 unless $value =~ /^\d+$/;
3971         $value;
3972 }
3973
3974 # Make sure no trailing slash in VendURL etc.
3975 sub parse_url {
3976         my($var, $value) = @_;
3977         $value =~ s,/+$,,;
3978         $value;
3979 }
3980
3981 # Parses a time specification such as "1 day" and returns the
3982 # number of seconds in the interval, or undef if the string could
3983 # not be parsed.
3984
3985 sub time_to_seconds {
3986         my($str) = @_;
3987         my($n, $dur);
3988
3989         ($n, $dur) = ($str =~ m/(\d+)[\s\0]*(\w+)?/);
3990         return undef unless defined $n;
3991         if (defined $dur) {
3992                 local($_) = $dur;
3993                 if (m/^s|sec|secs|second|seconds$/i) {
3994                 }
3995                 elsif (m/^m|min|mins|minute|minutes$/i) {
3996                         $n *= 60;
3997                 }
3998                 elsif (m/^h|hour|hours$/i) {
3999                         $n *= 60 * 60;
4000                 }
4001                 elsif (m/^d|day|days$/i) {
4002                         $n *= 24 * 60 * 60;
4003                 }
4004                 elsif (m/^w|week|weeks$/i) {
4005                         $n *= 7 * 24 * 60 * 60;
4006                 }
4007                 else {
4008                         return undef;
4009                 }
4010         }
4011
4012         $n;
4013 }
4014
4015 sub parse_valid_group {
4016         my($var, $value) = @_;
4017
4018         return '' unless $value;
4019
4020         my($name,$passwd,$gid,$members) = getgrnam($value);
4021
4022         config_error("$var: Group name '$value' is not a valid group\n")
4023                 unless defined $gid;
4024         $name = getpwuid($<);
4025         config_error("$var: Interchange user '$name' not in group '$value'\n")
4026                 unless $members =~ /\b$name\b/;
4027         $gid;
4028 }
4029
4030 sub parse_executable {
4031         my($var, $initial) = @_;
4032         my($x);
4033         my(@tries);
4034
4035         if(ref $initial) {
4036                 @tries = @$initial;
4037         }
4038         else {
4039                 @tries = $initial;
4040         }
4041
4042         TRYEXE:
4043         foreach my $value (@tries) {
4044 #::logDebug("trying $value for $var");
4045                 my $root = $value;
4046                 $root =~ s/\s.*//;
4047
4048                 return $value if $Global::Windows;
4049                 if( ! defined $value or $value eq '') {
4050                         $x = '';
4051                 }
4052                 elsif( $value eq 'none') {
4053                         $x = 'none';
4054                         last;
4055                 }
4056                 elsif( $value =~ /^\w+::[:\w]+\w$/) {
4057                         ## Perl module like Net::SMTP
4058                         eval {
4059                                 eval "require $value";
4060                                 die if $@;
4061                                 $x = $value;
4062                         };
4063                         last if $x;
4064                 }
4065                 elsif ($root =~ m#^/# and -x $root) {
4066                         $x = $value;
4067                         last;
4068                 }
4069                 else {
4070                         my @path = split /:/, $ENV{PATH};
4071                         for (@path) {
4072                                 next unless -x "$_/$root";
4073                                 $x = $value;
4074                                 last TRYEXE;
4075                         }
4076                 }
4077         }
4078         config_error( errmsg(
4079                                         "Can't find executable (%s) for the %s directive\n",
4080                                         join('|', @tries),
4081                                         $var,
4082                                         )
4083                 ) unless defined $x;
4084 #::logDebug("$var=$x");
4085         return $x;
4086 }
4087
4088 sub parse_time {
4089         my($var, $value) = @_;
4090         my($n);
4091
4092         return $value unless $value;
4093
4094 #       $C->{Source}->{$var} = [$value];
4095
4096         $n = time_to_seconds($value);
4097         config_error("Bad time format ('$value') in the $var directive\n")
4098         unless defined $n;
4099         $n;
4100 }
4101
4102 sub parse_cron {
4103         my($var, $value) = @_;
4104
4105         return '' unless $value =~ /\s/ and $value =~ /[a-zA-Z]/;
4106
4107         unless($Vend::Cron::Loaded) {
4108                  config_warn(
4109                         "Cannot use %s unless %s module loaded%s",
4110                         'crontab',
4111                         'Vend::Cron',
4112                         ' (missing Set::Crontab?)',
4113                         );
4114                  return '';
4115         }
4116         return Vend::Cron::read_cron($value);
4117 }
4118
4119 # Determine catalog structure from Catalog config line(s)
4120 sub parse_catalog {
4121         my ($var, $setting) = @_;
4122         my $num = ! defined $Global::Catalog ? 0 : $Global::Catalog;
4123         return $num unless (defined $setting && $setting);
4124
4125         my($name,$base,$dir,$script, @rest);
4126         ($name,@rest) = Text::ParseWords::shellwords($setting);
4127
4128         my %remap = qw/
4129                                         base      base
4130                                         alias     alias
4131                                         aliases   alias
4132                                         directory dir
4133                                         dir       dir
4134                                         script    script
4135                                         directive directive
4136                                         fullurl   full_url
4137                                         full      full_url
4138                                         /;
4139
4140         my ($cat, $key, $value);
4141         if ($Global::Catalog{$name}) {
4142                 # already defined
4143                 $cat   = $Global::Catalog{$name};
4144                 $key   = shift @rest;
4145                 $value = shift @rest;
4146         }
4147         elsif(
4148                         $var =~ /subcatalog/i and
4149                         @rest > 2
4150                         and file_name_is_absolute($rest[1])
4151                   )
4152         {
4153                 $cat = {
4154                         name   => $name,
4155                         base   => $rest[0],
4156                         dir    => $rest[1],
4157                         script => $rest[2],
4158                 };
4159                 splice(@rest, 0, 3);
4160                 $cat->{alias} = [ @rest ]
4161                         if @rest;
4162         }
4163         elsif( file_name_is_absolute($rest[0]) ) {
4164                 $cat = {
4165                         name   => $name,
4166                         dir    => $rest[0],
4167                         script => $rest[1],
4168                 };
4169                 splice(@rest, 0, 2);
4170                 $cat->{alias} = [ @rest ]
4171                         if @rest;
4172         }
4173         else {
4174                 $key   = shift @rest;
4175                 $value = shift @rest;
4176                 $cat = { name   => $name };
4177         }
4178
4179         $key = $remap{$key} if $key && defined $remap{$key};
4180
4181         if(! $key) {
4182                 # Nada
4183         }
4184         elsif($key eq 'alias' or $key eq 'server') {
4185                 $cat->{$key} = [] if ! $cat->{$key};
4186                 push @{$cat->{$key}}, $value;
4187                 push @{$cat->{$key}}, @rest if @rest;
4188         }
4189         elsif($key eq 'global') {
4190                 $cat->{$key} = $Global::AllowGlobal->{$name} = is_yes($value);
4191         }
4192         elsif($key eq 'directive') {
4193                 no strict 'refs';
4194                 my $p = $value;
4195                 my $v = join " ", @rest;
4196                 $cat->{$key} = {} if ! $cat->{$key};
4197                 my $ref = set_directive($p, $v, 1);
4198
4199                 if(ref $ref->[1] =~ /HASH/) {
4200                         if(! $cat->{$key}{$ref->[0]} ) {
4201                                 $cat->{$key}{$ref->[0]} =  { %{"Global::$ref->[0]"} };
4202                         }
4203                         for (keys %{$ref->[1]}) {
4204                                 $cat->{$key}{$ref->[0]}{$_} = $ref->[1]->{$_};
4205                         }
4206                 }
4207                 else {
4208                         $cat->{$key}{$ref->[0]} = $ref->[1];
4209                 }
4210         }
4211         else {
4212                 $cat->{$key} = $value;
4213         }
4214
4215 #::logDebug ("parsing catalog $name = " . uneval_it($cat));
4216
4217         $Global::Catalog{$name} = $cat;
4218
4219         # Define the main script name and array of aliases
4220         return ++$num;
4221 }
4222
4223 my %Explode_ref = (  qw!
4224                                                         COLUMN_DEF    COLUMN_DEF
4225 !);
4226
4227 my %Hash_ref = (  qw!
4228                                                         FILTER_FROM   FILTER_FROM
4229                                                         FILTER_TO     FILTER_TO
4230                                                         LENGTH_EXCEPTION LENGTH_EXCEPTION
4231                                                         DEFAULT       DEFAULT
4232                                                         DEFAULT_SESSION       DEFAULT_SESSION
4233                                                         FIELD_ALIAS   FIELD_ALIAS
4234                                                         NUMERIC       NUMERIC
4235                                                         PREFER_NULL   PREFER_NULL
4236                                                         WRITE_CATALOG WRITE_CATALOG
4237                                         ! );
4238
4239 my %Ary_ref = (   qw!
4240                                                 NAME                NAME
4241                                                 BINARY              BINARY
4242                                                 PRECREATE           PRECREATE
4243                                                 POSTCREATE          POSTCREATE
4244                                                 PREQUERY                        PREQUERY
4245                                                 INDEX               INDEX
4246                                                 ALTERNATE_DSN       ALTERNATE_DSN
4247                                                 ALTERNATE_USER      ALTERNATE_USER
4248                                                 ALTERNATE_PASS      ALTERNATE_PASS
4249                                                 ALTERNATE_BASE_DN   ALTERNATE_BASE_DN
4250                                                 ALTERNATE_LDAP_HOST ALTERNATE_LDAP_HOST
4251                                                 ALTERNATE_BIND_DN   ALTERNATE_BIND_DN
4252                                                 ALTERNATE_BIND_PW   ALTERNATE_BIND_PW
4253                                                 POSTEXPORT          POSTEXPORT
4254                                         ! );
4255
4256 sub parse_config_db {
4257         my($name, $value) = @_;
4258         my ($d, $new);
4259         unless (defined $value && $value) {
4260                 $d = {};
4261                 return $d;
4262         }
4263
4264         if($C) {
4265                 $d = $C->{ConfigDatabase};
4266         }
4267         else {
4268                 $d = $Global::ConfigDatabase;
4269         }
4270
4271         my($database,$remain) = split /[\s,]+/, $value, 2;
4272
4273         $d->{'name'} = $database;
4274
4275         if(!defined $d->{'file'}) {
4276                 my($file, $type) = split /[\s,]+/, $remain, 2;
4277                 $d->{'file'} = $file;
4278                 if(             $type =~ /^\d+$/        ) {
4279                         $d->{'type'} = $type;
4280                 }
4281                 elsif(  $type =~ /^(dbi|sql)\b/i        ) {
4282                         $d->{'type'} = 8;
4283                         if($type =~ /^dbi:/) {
4284                                 $d->{DSN} = $type;
4285                         }
4286                 }
4287 # LDAP
4288                 elsif(  $type =~ /^ldap\b/i) {
4289                         $d->{'type'} = 9;
4290                         if($type =~ /^ldap:(.*)/i) {
4291                                 $d->{LDAP_HOST} = $1;
4292                         }
4293                 }
4294 # END LDAP
4295                 elsif(  "\U$type" eq 'TAB'      ) {
4296                         $d->{'type'} = 6;
4297                 }
4298                 elsif(  "\U$type" eq 'PIPE'     ) {
4299                         $d->{'type'} = 5;
4300                 }
4301                 elsif(  "\U$type" eq 'CSV'      ) {
4302                         $d->{'type'} = 4;
4303                 }
4304                 elsif(  "\U$type" eq 'DEFAULT'  ) {
4305                         $d->{'type'} = 1;
4306                 }
4307                 elsif(  $type =~ /[%]{1,3}|percent/i    ) {
4308                         $d->{'type'} = 3;
4309                 }
4310                 elsif(  $type =~ /line/i        ) {
4311                         $d->{'type'} = 2;
4312                 }
4313                 else {
4314                         $d->{'type'} = 1;
4315                         $d->{DELIMITER} = $type;
4316                 }
4317         }
4318         else {
4319                 my($p, $val) = split /\s+/, $remain, 2;
4320                 $p = uc $p;
4321
4322                 if(defined $Explode_ref{$p}) {
4323                         my($ak, $v);
4324                         my(@v) = Text::ParseWords::shellwords($val);
4325                         @v = grep defined $_, @v;
4326                         $d->{$p} = {} unless defined $d->{$p};
4327                         for(@v) {
4328                                 my ($sk,$v) = split /\s*=\s*/, $_;
4329                                 my (@k) = grep /\w/, split /\s*,\s*/, $sk;
4330                                 for my $k (@k) {
4331                                         if($d->{$p}->{$k}) {
4332                                                 config_warn(
4333                                                         qq{Database %s explode parameter %s redefined to "%s", was "%s".},
4334                                                         $d->{name},
4335                                                         "$p --> $k",
4336                                                         $v,
4337                                                         $d->{$p}->{$k},
4338                                                 );
4339                                         }
4340                                         $d->{$p}->{$k} = $v;
4341                                 }
4342                         }
4343                 }
4344                 elsif(defined $Hash_ref{$p}) {
4345                         my($k, $v);
4346                         my(@v) = Vend::Util::quoted_comma_string($val);
4347                         @v = grep defined $_, @v;
4348                         $d->{$p} = {} unless defined $d->{$p};
4349                         for(@v) {
4350                                 ($k,$v) = split /\s*=\s*/, $_;
4351                                 if($d->{$p}->{$k}) {
4352                                         config_warn(
4353                                                 qq{Database %s hash parameter %s redefined to "%s", was "%s".},
4354                                                 $d->{name},
4355                                                 "$p --> $k",
4356                                                 $v,
4357                                                 $d->{$p}->{$k},
4358                                         );
4359                                 }
4360                                 $d->{$p}->{$k} = $v;
4361                         }
4362                 }
4363                 elsif(defined $Ary_ref{$p}) {
4364                         my(@v) = Text::ParseWords::shellwords($val);
4365                         $d->{$p} = [] unless defined $d->{$p};
4366                         push @{$d->{$p}}, @v;
4367                 }
4368                 else {
4369                         defined $d->{$p}
4370                         and ! defined $C->{DatabaseDefault}{$p}
4371                                 and config_warn(
4372                                                 qq{Database %s scalar parameter %s redefined to "%s", was "%s".},
4373                                                 $d->{name},
4374                                                 $p,
4375                                                 $val,
4376                                                 $d->{$p},
4377                                         );
4378                         $d->{$p} = $val;
4379                 }
4380         }
4381
4382 #::logDebug("d object: " . uneval_it($d));
4383         if($d->{ACTIVE} and ! $d->{OBJECT}) {
4384                 my $name = $d->{'name'};
4385                 $d->{OBJECT} = Vend::Data::import_database($d)
4386                         or config_error("Config database $name failed import.\n");
4387         }
4388         elsif($d->{LOAD} and ! $d->{OBJECT}) {
4389                 my $name = $d->{'name'};
4390                 $d->{OBJECT} = Vend::Data::import_database($d)
4391                         or config_error("Config database $name failed import.\n");
4392                 if( $d->{type} == 8 ) {
4393                         $d->{OBJECT}->set_query("delete from $name where 1 = 1");
4394                 }
4395         }
4396
4397         return $d;
4398
4399 }
4400
4401 sub parse_dbauto {
4402         my ($var, $value) = @_;
4403         return '' unless $value;
4404         my @inc = Vend::Table::DBI::auto_config($value);
4405         my %noed;
4406         for(@inc) {
4407                 my ($t, $thing) = @$_;
4408                 parse_boolean('NoImport', $t) unless $noed{$t}++;
4409                 parse_database('Database', "$t $thing");
4410         }
4411         return 1;
4412 }
4413
4414 sub parse_database {
4415         my ($var, $value) = @_;
4416         my ($c, $new);
4417
4418         if (! $value) {
4419                 $c = {};
4420                 return $c;
4421         }
4422
4423         $c = $C ? $C->{Database} : $Global::Database;
4424
4425         my($database,$remain) = split /[\s,]+/, $value, 2;
4426
4427         if( ! defined $c->{$database} ) {
4428                 $c->{$database} = { 'name' => $database, included_from => $configfile };
4429                 $new = 1;
4430         }
4431
4432         my $d = $c->{$database};
4433
4434         if($new) {
4435                 my($file, $type) = split /[\s,]+/, $remain, 2;
4436                 $d->{'file'} = $file;
4437                 if($file eq 'AUTO_SEQUENCE') {
4438                         # database table missing for AUTO_SEQUENCE directive
4439                         config_error('Missing database %s for AUTO_SEQUENCE %s.', $database, $type);
4440                         return $c;
4441                 }
4442                 if(             $type =~ /^\d+$/        ) {
4443                         $d->{'type'} = $type;
4444                 }
4445                 elsif(  $type =~ /^(dbi|sql)\b/i        ) {
4446                         $d->{'type'} = 8;
4447                         if($type =~ /^dbi:/) {
4448                                 $d->{DSN} = $type;
4449                         }
4450                 }
4451 # LDAP
4452                 elsif(  $type =~ /^ldap\b/i) {
4453                         $d->{'type'} = 9;
4454                         if($type =~ /^ldap:(.*)/i) {
4455                                 $d->{LDAP_HOST} = $1;
4456                         }
4457                 }
4458 # END LDAP
4459                 elsif(  $type =~ /^ic:(\w*)(:(.*))?/ ) {
4460                         my $class = $1;
4461                         my $dir = $3;
4462                         $d->{DIR} = $dir if $dir;
4463                         if($class =~ /^default$/i) {
4464                                 # Do nothing
4465                         }
4466                         elsif($class) {
4467                                 $class = uc $class;
4468                                 if(! $Vend::Data::db_config{$class}) {
4469                                         config_error("unrecognized IC database class: %s (from %s)", $class, $type);
4470                                 }
4471                                 $d->{Class} = $class;
4472                         }
4473                         $d->{'type'} = 6;
4474                 }
4475                 elsif(  "\U$type" eq 'TAB'      ) {
4476                         $d->{'type'} = 6;
4477                 }
4478                 elsif(  "\U$type" eq 'PIPE'     ) {
4479                         $d->{'type'} = 5;
4480                 }
4481                 elsif(  "\U$type" eq 'CSV'      ) {
4482                         $d->{'type'} = 4;
4483                 }
4484                 elsif(  "\U$type" eq 'DEFAULT'  ) {
4485                         $d->{'type'} = 1;
4486                 }
4487                 elsif(  $type =~ /[%]{1,3}|percent/i    ) {
4488                         $d->{'type'} = 3;
4489                 }
4490                 elsif(  $type =~ /line/i        ) {
4491                         $d->{'type'} = 2;
4492                 }
4493                 else {
4494                         $d->{'type'} = 1;
4495                         $d->{DELIMITER} = $type;
4496                 }
4497                 if    ($d->{'type'} eq '8')     { $d->{Class} = 'DBI'                                           }
4498                 elsif ($d->{'type'} eq '9') { $d->{Class} = 'LDAP'                                              }
4499                 else                                            { $d->{Class} ||= $Global::Default_database     }
4500
4501                 if($C and $C->{DatabaseDefault}) {
4502                         while ( my($k, $v) = each %{$C->{DatabaseDefault}}) {
4503                                 $d->{$k} = $v;
4504                         }
4505                 }
4506
4507                 $d->{HOT} = 1 if $d->{Class} eq 'MEMORY';
4508 #::logDebug("parse_database: type $type -> $d->{type}");
4509         }
4510         else {
4511                 my($p, $val) = split /\s+/, $remain, 2;
4512                 $p = uc $p;
4513 #::logDebug("parse_database: parameter $p = $val");
4514
4515                 if(defined $Explode_ref{$p}) {
4516                         my($ak, $v);
4517                         $val =~ s/,+$//;
4518                         $val =~ s/^,+//;
4519                         my(@v) = Text::ParseWords::shellwords($val);
4520                         @v = grep length $_, @v;
4521                         $d->{$p} = {} unless defined $d->{$p};
4522                         for(@v) {
4523                                 my ($sk,$v) = split /\s*=\s*/, $_;
4524                                 my (@k) = grep /\w/, split /\s*,\s*/, $sk;
4525                                 for my $k (@k) {
4526                                         if($d->{$p}->{$k}) {
4527                                                 config_warn(
4528                                                         qq{Database %s explode parameter %s redefined to "%s", was "%s".},
4529                                                         $d->{name},
4530                                                         "$p --> $k",
4531                                                         $v,
4532                                                         $d->{$p}->{$k},
4533                                                 );
4534                                         }
4535                                         $d->{$p}->{$k} = $v;
4536                                 }
4537                         }
4538                 }
4539                 elsif(defined $Hash_ref{$p}) {
4540                         my($k, $v);
4541                         my(@v) = Vend::Util::quoted_comma_string($val);
4542                         @v = grep defined $_, @v;
4543                         $d->{$p} = {} unless defined $d->{$p};
4544                         for(@v) {
4545                                 ($k,$v) = split /\s*=\s*/, $_;
4546                                 if($d->{$p}->{$k}) {
4547                                         config_warn(
4548                                                 qq{Database %s hash parameter %s redefined to "%s", was "%s".},
4549                                                 $d->{name},
4550                                                 "$p --> $k",
4551                                                 $v,
4552                                                 $d->{$p}->{$k},
4553                                         );
4554                                 }
4555                                 $d->{$p}->{$k} = $v;
4556                         }
4557                 }
4558                 elsif(defined $Ary_ref{$p}) {
4559                         my(@v) = Text::ParseWords::shellwords($val);
4560                         $d->{$p} = [] unless defined $d->{$p};
4561                         push @{$d->{$p}}, @v;
4562                 }
4563                 elsif ($p eq 'COMPOSITE_KEY') {
4564                     ## Magic hardcode
4565                         if($d->{type} == 8) {
4566                                 $d->{Class} = 'DBI_CompositeKey';
4567                                 $d->{$p} = $val;
4568                         }
4569                         else {
4570                                 config_warn(
4571                                         'Database %s parameter in type with no handling. Ignored.',
4572                                         $p,
4573                                         );
4574                         }
4575                 }
4576                 elsif ($p eq 'CLASS') {
4577                         $d->{Class} = $val;
4578                 }
4579                 elsif ($p =~ /^(MEMORY|SDBM|GDBM|DB_FILE|LDAP)$/i) {
4580                         $d->{Class} = uc $p;
4581                 }
4582                 elsif ($p eq 'ALIAS') {
4583                         if (defined $c->{$val}) {
4584                                 config_warn("Database '%s' already exists, can't alias.", $val);
4585                         }
4586                         else {
4587                                 $c->{$val} = $d;
4588                         }
4589                 }
4590                 elsif ($p =~ /^MAP/) {
4591                         Vend::Table::Shadow::_parse_config_line ($d, $p, $val);
4592                 }
4593
4594                 else {
4595                         defined $d->{$p}
4596                         and ! defined $C->{DatabaseDefault}{$p}
4597                                 and
4598                                 config_warn(
4599                                         qq{Database %s scalar parameter %s redefined to "%s", was "%s".},
4600                                         $d->{name},
4601                                         $p,
4602                                         $val,
4603                                         $d->{$p},
4604                                 );
4605                         $d->{$p} = $val;
4606                 }
4607                 $d->{HOT} = 1 if $d->{Class} eq 'MEMORY';
4608         }
4609
4610         return $c;
4611 }
4612
4613 sub get_configdb {
4614         my ($var, $value) = @_;
4615         my ($table, $file, $type);
4616         unless ($C->{Database}{$value}) {
4617                 return if $Vend::ExternalProgram;
4618                 ($table, $file, $type) = split /\s+/, $value, 3;
4619                 $file = "$table.txt" unless $file;
4620                 $type = 'TAB' unless $type;
4621                 parse_database('Database',"$table $file $type");
4622                 unless ($C->{Database}{$table}) {
4623                         config_warn(
4624                                 "Bad $var value '%s': %s\n%s",
4625                                 "Database $table $file $type",
4626                                 uneval($C->{Database}),
4627                         );
4628                         return '';
4629                 }
4630         }
4631         else {
4632                 $table = $value;
4633         }
4634
4635         my $db;
4636         unless ($db = $C->{Database}{$table}) {
4637                 return if $Vend::ExternalProgram;
4638                 my $err = $@;
4639                 config_warn("Bad $var '%s': %s", $table, $err);
4640                 return '';
4641         }
4642         eval {
4643                 $db = Vend::Data::import_database($db);
4644         };
4645         if($@ or ! $db) {
4646                 my $err = $@ || errmsg("Unable to import table '%s' for config.", $table);
4647                 delete $C->{Database}{$table};
4648                 die $err;
4649         }
4650         return ($db, $table);
4651 }
4652
4653 my %Columnar = (Locale => 1);
4654
4655 sub parse_configdb {
4656         my ($var, $value) = @_;
4657
4658         my ($file, $type);
4659         return '' if ! $value;
4660         local($Vend::Cfg) = $C;
4661         my ($db, $table);
4662         eval {
4663                 ($db, $table) = get_configdb($var, $value);
4664         };
4665         ::logGlobal("$var $value: $@") if $@;
4666         return '' if ! $db;
4667
4668         my ($k, @f);    # key and fields
4669         my @l;                  # refs to locale repository
4670         my @n;                  # names of locales
4671         my @h;                  # names of locales
4672
4673         my $base_direc = $var;
4674         $base_direc =~ s/Database$//;
4675         my $repos_name = $base_direc . '_repository';
4676         my $repos = $C->{$repos_name} ||= {};
4677
4678         @n = $db->columns();
4679         shift @n;
4680         my $i;
4681         if($Columnar{$base_direc}) {
4682                 my @l;
4683                 for(@n) {
4684                         $repos->{$_} ||= {};
4685                         push @l, $repos->{$_};
4686                 }
4687                 my $i;
4688                 while( ($k , undef, @f ) = $db->each_record) {
4689                         for ($i = 0; $i < @f; $i++) {
4690                                 next unless length($f[$i]);
4691                                 $l[$i]->{$k} = $f[$i];
4692                         }
4693                 }
4694         }
4695         else {
4696                 while( ($k, undef, @f ) = $db->each_record) {
4697                         for ($i = 0; $i < @f; $i++) {
4698                                 next unless length($f[$i]);
4699                                 $repos->{$k}{$n[$i]} = $f[$i];
4700                         }
4701                 }
4702         }
4703         $db->close_table();
4704         return $table;
4705 }
4706
4707 sub parse_dirconfig {
4708         my ($var, $value) = @_;
4709
4710         return '' if ! $value;
4711         $value =~ s/(\w+)\s+//;
4712         my $direc = $1;
4713 #::logDebug("direc=$direc value=$value");
4714
4715         my $ref = $C->{$direc};
4716
4717         unless(ref($ref) eq 'HASH') {
4718                 config_error("DirConfig called for non-hash configuration directive.");
4719         }
4720
4721         my $source = $C->{$var}   || {};
4722         my $sref = $source->{$direc} || {};
4723
4724         my @dirs = grep -d $_, glob($value);
4725         foreach my $dir (@dirs) {
4726                 opendir(DIRCONFIG, $dir)
4727                         or next;
4728                 my @files = grep /^\w+$/, readdir(DIRCONFIG);
4729                 for(@files) {
4730                         next unless -f "$dir/$_";
4731 #::logDebug("reading key=$_ from $dir/$_");
4732                         $ref->{$_} = readfile("$dir/$_", $Global::NoAbsolute, 0);
4733                         $ref->{$_} = substitute_variable($ref->{$_}) if $C->{ParseVariables};
4734                         $sref->{$_} = "$dir/$_";
4735                 }
4736         }
4737         $source->{$direc} = $sref;
4738         return $source;
4739 }
4740
4741 sub parse_dbconfig {
4742         my ($var, $value) = @_;
4743
4744         my ($file, $type);
4745         return '' if ! $value;
4746         local($Vend::Cfg) = $C;
4747
4748         my ($db, $table);
4749         eval {
4750                 ($db, $table) = get_configdb($var, $value);
4751         };
4752
4753         return '' if ! $db;
4754
4755         my ($k, @f);    # key and fields
4756         my @l;                  # refs to locale repository
4757         my @n;                  # names of locales
4758         my @h;                  # names of locales
4759
4760         @n = $db->columns();
4761         shift @n;
4762         my $extra;
4763         for(@n) {
4764                 my $real = $CDname{lc $_};
4765                 if (! ref $Vend::Cfg->{$real} or $Vend::Cfg->{$real} !~ /HASH/) {
4766                         # ignore non-existent directive, but put in hash
4767                         my $ref = {};
4768                         push @l, $ref;
4769                         push @h, [$real, $ref];
4770                         next;
4771                 }
4772                 push @l, $Vend::Cfg->{$real};
4773         }
4774         my $i;
4775         while( ($k, undef, @f ) = $db->each_record) {
4776 #::logDebug("Got key=$k f=@f");
4777                 for ($i = 0; $i < @f; $i++) {
4778                         next unless length($f[$i]);
4779                         $l[$i]->{$k} = $f[$i];
4780                 }
4781         }
4782         for(@h) {
4783                 $Vend::Cfg->{Hash}{$_->[0]} = $_->[1];
4784         }
4785         $db->close_table();
4786         return $table;
4787 }
4788
4789 sub parse_profile {
4790         my ($var, $value) = @_;
4791         my ($c, $ref, $sref, $i);
4792
4793         if($C) {
4794                 $C->{"${var}Name"} = {} if ! $C->{"${var}Name"};
4795                 $sref = $C->{Source};
4796                 $ref = $C->{"${var}Name"};
4797                 $c = $C->{$var} || [];
4798         }
4799         else {
4800                 no strict 'refs';
4801                 $sref = $Global::Source;
4802                 ${"Global::${var}Name"} = {}
4803                          if ! ${"Global::${var}Name"};
4804                 $ref = ${"Global::${var}Name"};
4805                 $c = ${"Global::$var"} || [];
4806         }
4807
4808         $sref->{$var} = $value;
4809
4810         my (@files) = glob($value);
4811         for(@files) {
4812                 next unless $_;
4813                 config_error(
4814                   "No leading / allowed if NoAbsolute set. Contact administrator.\n")
4815                 if m.^/. and $Global::NoAbsolute;
4816                 config_error(
4817                   "No leading ../.. allowed if NoAbsolute set. Contact administrator.\n")
4818                 if m#^\.\./.*\.\.# and $Global::NoAbsolute;
4819                 push @$c, (split /\s*[\r\n]+__END__[\r\n]+\s*/, readfile($_));
4820         }
4821         for($i = 0; $i < @$c; $i++) {
4822                 if($c->[$i] =~ s/(^|\n)__NAME__\s+([^\n\r]+)\r?\n/$1/) {
4823                         my $name = $2;
4824                         $name =~ s/\s+$//;
4825                         $ref->{$name} = $i;
4826                 }
4827         }
4828
4829         return $c;
4830 }
4831
4832 # Parse ordered or named attributes just like in a usertag.  Needs to have the routine specified as follows:
4833 # ['Foo', sub { &parse_ordered_attributes(@_, [qw(foo bar baz)]) }, 'foo bar baz'],
4834 # If called directly in the normal fashion then you cannot specify the attribute order, but you can
4835 # still use it for parsing named attributes.  The results are stored as a hashref (think $opt)
4836 sub parse_ordered_attributes {
4837         my ($var, $value, $order) = @_;
4838
4839         return {} if $value !~ /\S/;
4840
4841         my @settings = Text::ParseWords::shellwords($value);
4842         my %opt;
4843         if ($settings[0] =~ /=/) {
4844                 %opt = map { (split /=/, $_, 2)[0, 1] } @settings;
4845         }
4846
4847         elsif (ref $order eq 'ARRAY') {
4848                 @opt{@$order} = @settings;
4849         }
4850
4851         else {
4852                 config_error("$var only accepts named attributes.");
4853         }
4854
4855         return \%opt;
4856 }
4857
4858 # Designed to parse catalog subroutines and all vars
4859 sub save_variable {
4860         my ($var, $value) = @_;
4861         my ($c, $name, $param);
4862
4863         if(defined $C) {
4864                 $c = $C->{$var};
4865         }
4866         else {
4867                 no strict 'refs';
4868                 $c = ${"Global::$var"};
4869         }
4870
4871         if ($var eq 'Variable' || $var eq 'Member') {
4872                 $value =~ s/^\s*(\w+)\s*//;
4873                 $name = $1;
4874                 return 1 if defined $c->{'save'}->{$name};
4875                 $value =~ s/\s+$//;
4876                 $c->{'save'}->{$name} = $value;
4877         }
4878         elsif ( !defined $C) {
4879                 return 0;
4880         }
4881         elsif ( defined $C->{Source}{$var} && ref $C->{Source}{$var}) {
4882                 push @{$C->{Source}{$var}}, $value;
4883         }
4884         elsif ( defined $C->{Source}{$var}) {
4885                 $C->{Source}{$var} .= "\n$value";
4886         }
4887         else {
4888                 $C->{Source}{$var} = $value;
4889         }
4890         return 1;
4891
4892 }
4893
4894 sub map_widgets {
4895         my $gref;
4896         my $return      = ($gref = $Vend::Cfg->{CodeDef}{Widget})
4897                                                 ? $gref->{Routine}
4898                                                 : {};
4899         if(my $ref = $Global::CodeDef->{Widget}{Routine}) {
4900                 while ( my ($k, $v) = each %$ref) {
4901                         next if $return->{$k};
4902                         $return->{$k} = $v;
4903                 }
4904         }
4905         if(my $ref = $Global::CodeDef->{Widget}{MapRoutine}) {
4906                 no strict 'refs';
4907                 while ( my ($k, $v) = each %$ref) {
4908                         next if $return->{$k};
4909                         $return->{$k} = \&{"$v"};
4910                 }
4911         }
4912         if(my $ref = $Global::CodeDef->{Widget}{attrDefault}) {
4913                 no strict 'refs';
4914                 while ( my ($k, $v) = each %$ref) {
4915                         next if $return->{$k};
4916                         $return->{$k} = \&{"$v"};
4917                 }
4918         }
4919         return $return;
4920 }
4921
4922 sub map_widget_defaults {
4923         my $gref;
4924         my $return      = ($gref = $Vend::Cfg->{CodeDef}{Widget})
4925                                                 ? $gref->{attrDefault}
4926                                                 : {};
4927         if(my $ref = $Global::CodeDef->{Widget}{attrDefault}) {
4928                 while ( my ($k, $v) = each %$ref) {
4929                         next if $return->{$k};
4930                         $return->{$k} = $v;
4931                 }
4932         }
4933         return $return;
4934 }
4935
4936 sub map_codedef_to_directive {
4937         my $type = shift;
4938
4939         no strict 'refs';
4940
4941         my $c;
4942         my $cfg;
4943
4944         if( $C ) {
4945                 $c = $C->{CodeDef};
4946                 $cfg = $C->{$type}                      ||= {};
4947         }
4948         else {
4949                 $c = $Global::CodeDef;
4950                 $cfg =${"Global::$type"}        ||= {};
4951         }
4952
4953         my $ref;
4954         my $r;
4955
4956         next unless $r = $c->{$type};
4957         next unless $ref = $r->{Routine};
4958
4959         for(keys %$ref ) {
4960                 $cfg->{$_} = $ref->{$_};
4961                 }
4962 }
4963
4964 sub global_map_codedef {
4965         my $type = shift;
4966         map_codedef_to_directive($type);
4967         Vend::Dispatch::update_global_actions();
4968 }
4969
4970 my %MappedInit = (
4971         Filter => sub {
4972
4973 #::logDebug("Called filter MappedInit");
4974                 return if $C;
4975 #::logDebug("No \$C");
4976
4977                 my $c = $Global::CodeDef;
4978                 my $typeref = $c->{Filter}
4979                         or return;
4980                 my $submap = $typeref->{Routine}
4981                         or return;
4982
4983                 for(keys %$submap) {
4984 #::logDebug("Setting Filter for $_=$submap->{$_}");
4985                         $Vend::Interpolate::Filter{$_} = $submap->{$_};
4986                 }
4987                 if (my $ref = $typeref->{Alias}) {
4988 #::logDebug("We have an Alias ref");
4989                         for(keys %$ref) {
4990 #::logDebug("Checking Alias ref for $_=$ref->{$_}");
4991                                 if (exists $Vend::Interpolate::Filter{$ref->{$_}}) {
4992 #::logDebug("Setting Alias ref to $Vend::Interpolate::Filter{$ref->{$_}}");
4993                                         $submap->{$_}
4994                                                 = $Vend::Interpolate::Filter{$_}
4995                                                 = $Vend::Interpolate::Filter{$ref->{$_}};
4996                                 }
4997                         }
4998                 }
4999 #::logDebug("Filter is " . ::uneval(\%Vend::Interpolate::Filter));
5000         },
5001         ItemAction      => \&map_codedef_to_directive,
5002         OrderCheck      => \&map_codedef_to_directive,
5003         ActionMap       => \&global_map_codedef,
5004         FormAction      => \&global_map_codedef,
5005         Widget          => sub {
5006                                                 return unless $Vend::Cfg;
5007                                                 $Vend::UserWidget = map_widgets();
5008                                                 $Vend::UserWidgetDefault = map_widget_defaults();
5009                                         },
5010         UserTag         => sub {
5011                                                 return if $C;
5012                                                 return unless $Vend::Cfg;
5013                                                 Vend::Parse::add_tags($Global::UserTag);
5014                                         },
5015 );
5016
5017 sub finalize_mapped_code {
5018         my @types = @_;
5019         unless(@types) {
5020                 @types = grep $_, values %valid_dest;
5021         }
5022
5023         for my $type (@types) {
5024                 if(my $sub = $MappedInit{$type}) {
5025                         $sub->($type);
5026                 }
5027         }
5028 }
5029
5030 my %Compiled = qw/
5031                                         Routine     Routine
5032                                         PosRoutine  PosRoutine
5033                                         HashCode    Routine
5034                                         ArrayCode   Routine
5035                                 /;
5036
5037 sub parse_mapped_code {
5038         my ($var, $value) = @_;
5039
5040         return {} if ! $value;
5041
5042         ## Can't give CodeDef a default or this will be premature
5043         get_system_code() unless defined $SystemCodeDone;
5044
5045         my($tag,$p,$val) = split /\s+/, $value, 3;
5046
5047         # Canonicalize
5048         $p = $tagCanon{lc $p} || ''
5049                 or ::logDebug("bizarre mapped code line '$value'");
5050         $tag =~ tr/-/_/;
5051         $tag =~ s/\W//g
5052                 and config_warn("Bad characters removed from '%s'.", $tag);
5053
5054         my $repos = $C ? ($C->{CodeDef} ||= {}) : ($Global::CodeDef ||= {});
5055
5056         if ($tagSkip{$p}) {
5057                 return $repos;
5058         }
5059
5060         my $dest = $valid_dest{lc $p} || $current_dest{$tag} || $CodeDest;
5061
5062         if(! $dest) {
5063                 config_warn("no destination for %s %s, skipping.", $var, $tag);
5064                 return $repos;
5065         }
5066         $current_dest{$tag} = $dest;
5067         $repos->{$dest} ||= {};
5068
5069         my $c = $repos->{$dest};
5070
5071         if($Compiled{$p}) {
5072                 $c->{$Compiled{$p}} ||= {};
5073                 parse_action($var, "$tag $val", $c->{$Compiled{$p}} ||= {});
5074         }
5075         elsif(defined $tagAry{$p}) {
5076                 my(@v) = Text::ParseWords::shellwords($val);
5077                 $c->{$p}{$tag} = [] unless defined $c->{$p}{$tag};
5078                 push @{$c->{$p}{$tag}}, @v;
5079         }
5080         elsif(defined $tagHash{$p}) {
5081                 my(%v) = Text::ParseWords::shellwords($val);
5082                 $c->{$p}{$tag} = {} unless defined $c->{$p}{$tag};
5083                 for (keys %v) {
5084                   $c->{$p}{$tag}{$_} = $v{$_};
5085                 }
5086         }
5087         elsif(defined $tagBool{$p}) {
5088                 $c->{$p}{$tag} = 1
5089                         unless defined $val and $val =~ /^[0nf]/i;
5090         }
5091         else {
5092                 config_warn("%s %s scalar parameter %s redefined.", $var, $tag, $p)
5093                         if defined $c->{$p}{$tag};
5094                 $c->{$p}{$tag} = $val;
5095         }
5096
5097         return $repos;
5098 }
5099
5100 # Parses the user tags
5101 sub parse_tag {
5102         my ($var, $value) = @_;
5103         my ($new);
5104
5105 #::logDebug("parse_tag var=$var val=$value") unless $Global::Foreground;
5106         return if $Vend::ExternalProgram;
5107
5108         unless (defined $value && $value) {
5109                 return {};
5110         }
5111
5112         return parse_mapped_code($var, $value)
5113                 if $var ne 'UserTag';
5114
5115 #::logDebug("ready to read tag, C='$C' SystemCodeDone=$Syst