Log the actual error, as order-desk version does
[interchange.git] / lib / Vend / Config.pm
1 # Vend::Config - Configure Interchange
2 #
3 # Copyright (C) 2002-2017 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 Config;
48 use Vend::Safe;
49 use Fcntl;
50 use Vend::Parse;
51 use Vend::Util;
52 use Vend::File;
53 use Vend::Data;
54 use Vend::Cron;
55 use Vend::CharSet ();
56
57 $VERSION = '2.249';
58
59 my %CDname;
60 my %CPname;
61 %ContainerType = (
62         yesno => sub {
63                 my ($var, $value, $end) = @_;
64                 $var = $CDname{lc $var};
65                 if($end) {
66                         my $val = delete $ContainerSave{$var};
67                         no strict 'refs';
68                         if($C) {
69                                 $C->{$var} = $val;
70                         }
71                         else {
72                                 ${"Global::$var"} = $val;
73                                 
74                         }
75                 }
76                 else {
77                         no strict 'refs';
78                         $ContainerSave{$var} = $C ? $C->{$var} : ${"Global::$var"};
79                         $ContainerSave{$var} ||= 'No';
80                 }
81         },
82 );
83
84 my %DirectiveAlias = qw(
85         URL            VendURL
86         DataDir        ProductDir
87         DefaultTables  ProductFiles
88         Profiles       OrderProfile
89 );
90
91 for( qw(search refresh cancel return secure unsecure submit control checkout) ) {
92         $Global::LegalAction{$_} = 1;
93 }
94
95 @Locale_directives_currency = (
96 qw/
97                 CommonAdjust
98                 PriceCommas
99                 PriceDivide
100                 PriceField
101                 PriceDefault
102                 SalesTax
103                 Levies
104                 TaxShipping
105                 TaxInclusive
106 /       );
107
108 @Locale_keys_currency = (
109 qw/
110         currency_symbol
111         frac_digits
112         int_curr_symbol
113         int_currency_symbol
114         int_frac_digits
115         mon_decimal_point
116         mon_grouping
117         price_picture
118         mon_thousands_sep
119         n_cs_precedes
120         negative_sign
121         p_cs_precedes
122         p_sep_by_space
123         positive_sign
124
125 /   );
126
127 @Locale_directives_scalar = (
128 qw/
129                 AutoEnd
130                 Autoload
131                 CategoryField
132                 CommonAdjust
133                 DescriptionField
134                 HTMLsuffix
135                 ImageDir
136                 ImageDirSecure
137                 PageDir
138                 Preload
139                 PriceCommas
140                 PriceDefault
141                 PriceDivide
142                 PriceField
143                 SalesTax
144                 SpecialPageDir
145                 TaxShipping
146                 TaxInclusive
147 /   );
148
149 @Locale_directives_ary = (
150 qw/
151         AutoModifier
152         Levies
153         ProductFiles
154         UseModifier
155 /   );
156
157 # These are extra routines that are run if certain directives are
158 # updated
159 # Form:
160 #
161 # [ 'Directive', \&routine, [ @args ] ],
162
163 # @args are optional.
164
165 @Locale_directives_code = (
166         [ 'ProductFiles', \&Vend::Data::update_productbase ],
167 );
168
169 my %HashDefaultBlank = (qw(
170                                         SOAP                    1
171                                         Mail                    1
172                                         Accounting              1
173                                         Levy                    1
174                                         QueryCache              1
175                                 ));
176
177 my %DumpSource = (qw(
178                                         SpecialPage                     1
179                                         GlobalSub                       1
180                                 ));
181
182 my %DontDump = (qw(
183                                         GlobalSub                       1
184                                         SpecialPage                     1
185                                 ));
186
187 my %UseExtended = (qw(
188                                         Catalog                         1
189                                         SubCatalog                      1
190                                         Variable                        1
191                                 ));
192
193 my %InitializeEmpty = (qw(
194                                         FileControl                     1
195                                 ));
196
197 my %AllowScalarAction = (qw(
198                                         FileControl                     1
199                                         SOAP_Control            1
200                                 ));
201
202 my @External_directives = qw(
203         CatalogName 
204         ScratchDefault 
205         ValuesDefault 
206         ScratchDir 
207         SessionDB 
208         SessionDatabase 
209         SessionExpire 
210         VendRoot 
211         VendURL
212         SecureURL
213         Variable->SQLDSN
214         Variable->SQLPASS
215         Variable->SQLUSER
216 );
217
218 my %extmap = qw/
219         ia      ItemAction
220         fa      FormAction
221         am      ActionMap
222         oc      OrderCheck
223         ut      UserTag
224         fi      Filter
225         so      SearchOp
226         fw      Widget
227         lc      LocaleChange
228         tag     UserTag
229         ct      CoreTag
230         jsc     JavaScriptCheck
231 /;
232
233 for( values %extmap ) {
234         $extmap{lc $_} = $_;
235 }
236
237 %tagCanon = ( qw(
238
239         group                   Group
240         actionmap               ActionMap
241         arraycode               ArrayCode
242         hashcode                HashCode
243         coretag                 CoreTag
244         searchop                SearchOp
245         localechange    LocaleChange
246         filter                  Filter
247         formaction              FormAction
248         ordercheck              OrderCheck
249         usertag                 UserTag
250         systemtag               SystemTag
251         widget                  Widget
252
253         alias                   Alias
254         addattr                 addAttr
255         attralias               attrAlias
256         attrdefault             attrDefault
257         cannest                 canNest
258         description     Description
259         override                Override
260         underride               Underride
261         visibility      Visibility
262         help                    Help
263         documentation   Documentation
264         extrameta               ExtraMeta
265         gobble                  Gobble
266         hasendtag               hasEndTag
267         implicit                Implicit
268         interpolate             Interpolate
269         invalidatecache InvalidateCache
270         isendanchor             isEndAnchor
271         multiple                Multiple
272         norearrange             noRearrange
273         order                   Order
274         posnumber               PosNumber
275         posroutine              PosRoutine
276         maproutine              MapRoutine
277         noreparse               NoReparse
278         javascriptcheck JavaScriptCheck
279         required                Required
280         routine                 Routine
281         version                 Version
282 ));
283
284 my %tagSkip = ( qw! Documentation 1 Version 1 !);
285
286 my %tagAry      = ( qw! Order 1 Required 1 ! );
287 my %tagHash     = ( qw!
288                                 attrAlias   1
289                                 Implicit    1
290                                 attrDefault     1
291                                 ! );
292 my %tagBool = ( qw!
293                                 ActionMap   1
294                                 addAttr     1
295                                 canNest     1
296                                 Filter      1
297                                 FormAction  1
298                                 hasEndTag   1
299                                 Interpolate 1
300                                 isEndAnchor 1
301                                 isOperator  1
302                                 Multiple    1
303                                 ItemAction  1
304                                 noRearrange 1
305                                 NoReparse   1
306                                 OrderCheck  1
307                                 UserTag     1
308                                 ! );
309
310 my %current_dest;
311 my %valid_dest = qw/
312                                         actionmap        ActionMap
313                                         coretag          UserTag
314                                         filter           Filter
315                                         formaction       FormAction
316                                         itemaction       ItemAction
317                                         ordercheck       OrderCheck
318                                         localechange     LocaleChange
319                                         usertag          UserTag
320                                         hashcode         HashCode
321                                         arraycode        ArrayCode
322                                         searchop                 SearchOp
323                                         widget           Widget
324                                         javascriptcheck  JavaScriptCheck
325                                 /;
326
327
328 my $StdTags;
329
330 use vars qw/ $configfile /;
331
332 ### This is unset when interchange script is run, so that the default
333 ### when used by an external program is not to compile subroutines
334 $Vend::ExternalProgram = 1;
335
336 # Report a fatal error in the configuration file.
337 sub config_error {
338         my $msg = shift;
339         if(@_) {
340                 $msg = errmsg($msg, @_);
341         }
342
343         local($^W);
344         if ($configfile) {
345                 $msg = errmsg("%s\nIn line %s of the configuration file '%s':\n%s\n",
346                         $msg,
347                         $.,
348                         $configfile,
349                         $Vend::config_line,
350                 );
351         }
352         
353         if ($Vend::ExternalProgram) {
354                 warn "$msg\n" unless $Vend::Quiet;
355         }
356         else {
357                 die "$msg\n";
358         }
359 }
360
361 sub config_warn {
362         my $msg = shift;
363         if(@_) {
364                 $msg = errmsg($msg, @_);
365         }
366
367         local($^W);
368         my $extra = '';
369         if($configfile and $Vend::config_line) {
370                 $extra = errmsg(
371                                 "\nIn line %s of the configuration file '%s':\n%s\n",
372                                                 $msg,
373                                                 $.,
374                                                 $configfile,
375                                                 $Vend::config_line,
376         );
377         }
378
379         ::logGlobal({level => 'notice'}, "$msg$extra");
380 }
381
382 sub setcat {
383         $C = $_[0] || $Vend::Cfg;
384 }
385
386 sub global_directives {
387
388         my $directives = [
389 #   Order is not really important, catalogs are best first
390
391 #   Directive name      Parsing function    Default value
392
393         ['RunDir',                       'root_dir',             $Global::RunDir || 'etc'],
394         ['DebugFile',            'root_dir',             ''],
395         ['CatalogUser',          'hash',                         ''],
396         ['ConfigDir',             undef,                 'etc/lib'],
397         ['FeatureDir',           'root_dir',         'features'],
398         ['ConfigDatabase',       'config_db',        ''],
399         ['ConfigAllBefore',      'root_dir_array',       'catalog_before.cfg'],
400         ['ConfigAllAfter',       'root_dir_array',       'catalog_after.cfg'],
401         ['Message',          'message',           ''],
402         ['Capability',           'capability',           ''],
403         ['Require',                      'require',                      ''],
404         ['Suggest',                      'suggest',                      ''],
405         ['VarName',          'varname',           ''],
406         ['Windows',          undef,               $Global::Windows || ''],
407         ['LockType',         undef,               $Global::Windows ? 'none' : ''],
408         ['DumpStructure',        'yesno',            'No'],
409         ['DumpAllCfg',       'yesno',                'No'],
410         ['DisplayErrors',    'yesno',            'No'],
411         ['DeleteDirective', sub {
412                                                         my $c = $Global::DeleteDirective || {};
413                                                         shift;
414                                                         my @sets = map { lc $_ } split /[,\s]+/, shift;
415                                                         @{$c}{@sets} = map { 1 } @sets;
416                                                         return $c;
417                                                  },            ''],
418         ['Inet_Mode',         'yesno',            (
419                                                                                                 defined $Global::Inet_Mode
420                                                                                                 ||
421                                                                                                 defined $Global::Unix_Mode
422                                                                                                 )
423                                                                                                 ? ($Global::Inet_Mode || 0) : 'No'],
424         ['Unix_Mode',         'yesno',            (
425                                                                                                 defined $Global::Inet_Mode
426                                                                                                 ||
427                                                                                                 defined $Global::Unix_Mode
428                                                                                                 )
429                                                                                                 ? ($Global::Unix_Mode || 0) : 'Yes'],
430         ['TcpMap',           'hash',             ''],
431         ['CodeRepository',   'root_dir',         ''],
432         ['AccumulateCode',   'yesno',            'No'],
433         ['Environment',      'array',            ''],
434         ['TcpHost',           undef,             'localhost 127.0.0.1'],
435         ['AcceptRedirect',       'yesno',                        'No'],
436         ['SendMailProgram',  'executable',               [
437                                                                                                 $Global::SendMailLocation,
438                                                                                            '/usr/sbin/sendmail',
439                                                                                            '/usr/lib/sendmail',
440                                                                                            'Net::SMTP',
441                                                                                           ]
442                                                                                   ],
443         ['EncryptProgram',  'executable',                [ 'gpg', 'pgpe', 'none', ] ],
444         ['PIDfile',              'root_dir',         "etc/$Global::ExeName.pid"],
445         ['SocketFile',           'root_dir_array',   ''],
446         ['SocketPerms',      'integer',          0600],
447         ['SocketReadTimeout','integer',          1],
448         ['SOAP',             'yesno',            'No'],
449         ['SOAP_Socket',       'array',            ''],
450         ['SOAP_Perms',        'integer',          0600],
451         ['MaxRequestsPerChild','integer',           50],
452         ['ChildLife',         'time',             0],
453         ['StartServers',      'integer',          0],
454         ['PreFork',                   'yesno',            0],
455         ['PreForkSingleFork', 'yesno',            0],
456         ['SOAP_MaxRequests', 'integer',           50],
457         ['SOAP_StartServers', 'integer',          1],
458         ['SOAP_Control',     'action',           ''],
459         ['Jobs',                         'hash',                 'MaxLifetime 600 MaxServers 1 UseGlobal 0'],
460         ['IPCsocket',            'root_dir',         'etc/socket.ipc'],
461         ['HouseKeeping',     'time',          60],
462         ['HouseKeepingCron', 'cron',          ''],
463         ['Mall',                  'yesno',           'No'],
464         ['TagGroup',             'tag_group',            $StdTags],
465         ['ConfigParseComments',          'warn',                 ''],
466         ['TagInclude',           'tag_include',          'ALL'],
467         ['ActionMap',            'action',                       ''],
468         ['FileControl',          'action',                       ''],
469         ['FormAction',           'action',                       ''],
470         ['MaxServers',       'integer',          10],
471         ['GlobalSub',            'subroutine',       ''],
472         ['Database',             'database',         ''],
473         ['FullUrl',                      'yesno',            'No'],
474         ['FullUrlIgnorePort', 'yesno',           'No'],
475         ['Locale',                       'locale',            ''],
476         ['HitCount',             'yesno',            'No'],
477         ['IpHead',                       'yesno',            'No'],
478         ['IpQuad',                       'integer',          '1'],
479         ['TagDir',               'root_dir_array',       'code'],
480         ['TemplateDir',      'root_dir_array',   ''],
481         ['DebugTemplate',    undef,              ''],
482         ['DomainTail',           'yesno',            'Yes'],
483         ['CountrySubdomains','hash',             ''],
484         ['TrustProxy',           'list_wildcard_full', ''],
485         ['AcrossLocks',          'yesno',            'No'],
486     ['DNSBL',            'array',            ''],
487         ['NotRobotUA',           'list_wildcard',      ''],
488         ['RobotUA',                      'list_wildcard',      ''],
489         ['RobotIP',                      'list_wildcard_full', ''],
490         ['RobotHost',            'list_wildcard_full', ''],
491         ['HostnameLookups',      'yesno',            'No'],
492         ['TolerateGet',          'yesno',            'No'],
493         ['PIDcheck',             'time',          '0'],
494         ['LockoutCommand',    undef,             ''],
495         ['SafeUntrap',       'array',            'ftfile sort'],
496         ['SafeTrap',         'array',            ':base_io'],
497         ['NoAbsolute',           'yesno',                        'No'],
498         ['AllowGlobal',          'boolean',                      ''],
499         ['PerlNoStrict',         'boolean',                      ''],
500         ['PerlAlwaysGlobal', 'boolean',                  ''],
501         ['AddDirective',         'directive',            ''],
502         ['UserTag',                      'tag',                          ''],
503         ['CodeDef',                      'mapped_code',          ''],
504         ['HotDBI',                       'boolean',                      ''],
505         ['HammerLock',           'time',         30],
506         ['DataTrace',            'integer',              0],
507         ['ShowTimes',            'yesno',                0],
508         ['ErrorFile',            'root_dir',         undef],
509         ['SysLog',                       'hash',             undef],
510         ['Logging',                      'integer',              0],
511         ['CheckHTML',             undef,             ''],
512         ['UrlSepChar',           'url_sep_char',     '&'],
513         ['Variable',             'variable',             ''],
514         ['Profiles',             'profile',              ''],
515         ['Catalog',                      'catalog',              ''],
516         ['SubCatalog',           'catalog',              ''],
517         ['AutoVariable',         'autovar',              'UrlJoiner'],
518         ['EnableJSONPost',       'yesno',                        'No'],
519         ['UnpackJSON',           'yesno',                        'Yes'],
520         ['XHTML',                        'yesno',                'No'],
521         ['UTF8',                         'yesno',                $ENV{MINIVEND_DISABLE_UTF8} ? 'No' : 'Yes'],
522         ['External',             'yesno',                'No'],
523         ['ExternalFile',         'root_dir',         "$Global::RunDir/external.structure"],
524         ['ExternalExport',       undef,                          'Global::Catalog=Catalog'],
525         ['DowncaseVarname',   undef,           ''],
526
527         ];
528         return $directives;
529 }
530
531
532 sub catalog_directives {
533
534         my $directives = [
535 #   Order is somewhat important, the first 6 especially
536
537 #   Directive name      Parsing function    Default value
538
539         ['ErrorFile',        'relative_dir',     'error.log'],
540         ['ActionMap',            'action',                       ''],
541         ['FileControl',          'action',                       ''],
542         ['FormAction',           'action',                       ''],
543         ['ItemAction',           'action',                       ''],
544         ['PageDir',          'relative_dir',     'pages'],
545         ['SpecialPageDir',   undef,                      'special_pages'],
546         ['ProductDir',       'relative_dir',     'products'],
547         ['OfflineDir',       'relative_dir',     'offline'],
548         ['ConfDir',          'relative_dir',     'etc'],
549         ['RunDir',           'relative_dir',     ''],
550         ['ConfigDir',        'relative_dir',     'config'],
551         ['TemplateDir',      'dir_array',                ''],
552         ['ConfigDatabase',       'config_db',        ''],
553         ['Require',                      'require',                      ''],
554         ['Suggest',                      'suggest',                      ''],
555         ['Message',          'message',           ''],
556         ['Variable',             'variable',             ''],
557         ['VarName',          'varname',           ''],
558         ['Limit',                        'hash',    'option_list 5000 chained_cost_levels 32 robot_expire 1'],
559         ['ScratchDefault',       'hash',                 ''],
560         ['Profile',                      'locale',               ''],
561         ['ValuesDefault',        'hash',                 ''],
562         ['ProductFiles',         'array_complete',  'products'],
563         ['PageTables',           'array_complete',  ''],
564         ['PageTableMap',         'hash',                        qq{
565                                                                                                 expiration_date expiration_date
566                                                                                                 show_date       show_date
567                                                                                                 page_text       page_text
568                                                                                                 base_page       base_page
569                                                                                                 code            code
570                                                                                         }],
571         ['DisplayErrors',    'yesno',            'No'],
572         ['ParseVariables',       'yesno',            'No'],
573         ['SpecialPage',          'special', 'order ord/basket results results search results flypage flypage'],
574         ['DirectoryIndex',       undef,                          ''],
575         ['Sub',                          'subroutine',       ''],
576         ['VendURL',          'url',              undef],
577         ['SecureURL',        'url',              undef],
578         ['PostURL',          'url',              ''],
579         ['SecurePostURL',    'url',              ''],
580         ['ProcessPage',      undef,              'process'],
581         ['History',          'integer',          0],
582         ['OrderReport',      undef,                      'etc/report'],
583         ['ScratchDir',       'relative_dir',     'tmp'],
584         ['PermanentDir',     'relative_dir',     'perm'],
585         ['SessionDB',            undef,                  ''],
586         ['SessionType',          undef,                  'File'],
587         ['SessionDatabase',  'relative_dir',     'session'],
588         ['ConfigParseComments',          'warn',                 ''],
589         ['SessionLockFile',  undef,                      'etc/session.lock'],
590         ['MoreDB',                       'yesno',                'No'],
591         ['DatabaseDefault',  'hash',             ''],
592         ['DatabaseAuto',         'dbauto',               ''],
593         ['DatabaseAutoIgnore',   'regex',                ''],
594         ['Database',             'database',             ''],
595         ['Preload',          'routine_array',    ''],
596         ['Autoload',             'routine_array',        ''],
597         ['AutoEnd',                      'routine_array',        ''],
598         ['Replace',                      'replace',              ''],
599         ['Member',                       'variable',             ''],
600         ['Feature',          'feature',          ''],
601         ['WritePermission',  'permission',       'user'],
602         ['ReadPermission',   'permission',       'user'],
603         ['SessionExpire',    'time',             '1 hour'],
604         ['SaveExpire',       'time',             '30 days'],
605         ['MailOrderTo',      undef,              ''],
606         ['SendMailProgram',  'executable',              $Global::SendMailProgram],
607         ['PGP',              undef,                      ''],
608 # GLIMPSE
609         ['Glimpse',          'executable',       ''],
610 # END GLIMPSE
611         ['Locale',           'locale',           ''],
612         ['Route',            'locale',           ''],
613         ['LocaleDatabase',   'configdb',         ''],
614         ['ExecutionLocale',   undef,             'C'],
615         ['DefaultLocale',     undef,             ''],
616         ['RouteDatabase',     'configdb',        ''],
617         ['DirectiveDatabase', 'dbconfig',        ''],
618         ['VariableDatabase',  'dbconfig',        ''],
619         ['DirConfig',         'dirconfig',        ''],
620         ['FileDatabase',         undef,                          ''],
621         ['NoSearch',         'wildcard',         'userdb'],
622         ['AllowRemoteSearch',    'array_complete',     'products variants options'],
623         ['OrderCounter',         undef,              ''],
624         ['MimeType',         'hash',             ''],
625         ['AliasTable',           undef,              ''],
626         ['ImageAlias',           'hash',             ''],
627         ['TableRestrict',        'hash',             ''],
628         ['Filter',                       'hash',             ''],
629         ['ImageDirSecure',   undef,                  ''],
630         ['ImageDirInternal', undef,                  ''],
631         ['ImageDir',             undef,              ''],
632         ['DeliverImage',     'yesno',                    'no'],
633         ['SpecialSub',       'hash',                     ''],
634         ['SetGroup',             'valid_group',      ''],
635         ['UseModifier',          'array',            ''],
636         ['AutoModifier',         'array',            ''],
637         ['MaxQuantityField', undef,                  ''],
638         ['MinQuantityField', undef,                  ''],
639         ['LogFile',               undef,             'etc/log'],
640         ['Pragma',                       'boolean_value',    ''],
641         ['NoExport',             'boolean',                      ''],
642         ['NoExportExternal', 'yesno',                    'no'],
643         ['NoImport',             'boolean',              ''],
644         ['NoImportExternal', 'yesno',            'no'],
645         ['CommonAdjust',         undef,                  ''],
646         ['PriceDivide',          undef,                  1],
647         ['PriceCommas',          'yesno',            'Yes'],
648         ['OptionsEnable',        undef,              ''],
649         ['OptionsAttribute', undef,                  ''],
650         ['Options',                      'locale',           ''],
651         ['AlwaysSecure',         'boolean',          ''],
652         ['AlwaysSecureGlob', 'list_wildcard_full', ''],
653         ['Password',         undef,              ''],
654         ['AdminSub',             'boolean',                      ''],
655         ['ExtraSecure',          'yesno',            'No'],
656         ['FallbackIP',           'yesno',            'No'],
657         ['WideOpen',             'yesno',            'No'],
658         ['Promiscuous',          'yesno',            'No'],
659         ['Cookies',                      'yesno',            'Yes'],
660         ['CookieName',           undef,              ''],
661         ['CookiePattern',        'regex',            '[-\w:.]+'],
662         ['CookieLogin',      'yesno',            'No'],
663         ['CookieDomain',     undef,              ''],
664         ['InternalCookie',   'yesno',            'No'], ## Allows CookieName to be change yet still handle IP address in cookie
665         ['MasterHost',           undef,              ''],
666         ['UserTag',                      'tag',                  ''],
667         ['CodeDef',                      'mapped_code',          ''],
668         ['RemoteUser',           undef,              ''],
669         ['TaxShipping',          undef,              ''],
670         ['TaxInclusive',     'yesno',                    'No'],
671         ['FractionalItems',  'yesno',                    'No'],
672         ['SeparateItems',    'yesno',                    'No'],
673         ['PageSelectField',  undef,                  ''],
674         ['NonTaxableField',  undef,                  ''],
675         ['CreditCardAuto',       'yesno',            'No'],
676         ['FormIgnore',       'boolean',              ''],
677         ['EncryptProgram',       undef,              $Global::EncryptProgram || ''],
678         ['EncryptKey',           undef,              ''],
679         ['AsciiTrack',           undef,              ''],
680         ['TrackFile',            undef,              ''],
681         ['TrackPageParam',       'hash',             ''],
682         ['TrackDateFormat',      undef,              ''],
683         ['SalesTax',             undef,              ''],
684         ['SalesTaxFunction', undef,                  ''],
685         ['CounterDir',           'relative_dir',     ''],
686         ['SOAP',                         'yesno',                        'No'],
687         ['SOAP_Enable',          'hash',                         ''],
688         ['SOAP_Action',          'action',                       ''],                              
689         ['SOAP_Control',     'action',             ''],           
690         ['UserDB',                       'locale',               ''], 
691         ['UserControl',          'yesno',                'No'], 
692         ['UserDatabase',         undef,                  ''],
693         ['RobotLimit',           'integer',                   0],
694         ['OrderLineLimit',       'integer',                   0],
695         ['RedirectCache',        undef,                          ''],
696         ['HTMLsuffix',       undef,                  '.html'],
697         ['CustomShipping',       undef,              ''],
698         ['DefaultShipping',      undef,              'default'],
699         ['UpsZoneFile',          undef,              ''],
700         ['OrderProfile',         'profile',              ''],
701         ['SearchProfile',        'profile',              ''],
702         ['OnFly',                        undef,              ''],
703         ['CategoryField',    undef,              'category'],
704         ['DescriptionField', undef,              'description'],
705         ['PriceDefault',         undef,              'price'],
706         ['PriceField',           undef,              'price'],
707         ['DiscountSpacesOn', 'yesno',            'no'],
708         ['DiscountSpaceVar', 'array',            'mv_discount_space'],
709         ['Jobs',                         'hash',                 ''],
710         ['Shipping',         'locale',           ''],
711         ['Accounting',           'locale',               ''],
712         ['Levies',                       'array',                ''],
713         ['Levy',                         'locale',               ''],
714         ['AutoVariable',         'autovar',              ''],
715         ['ErrorDestination', 'hash',             ''],
716         ['XHTML',                        'yesno',                $Global::XHTML],
717         ['External',             'yesno',                'No'],
718         ['ExternalExport',       undef,                  join " ", @External_directives],
719         ['CartTrigger',          'routine_array',        ''],
720         ['CartTriggerQuantity', 'yesno',                 'no'],
721     ['UserTrack',        'yesno',            'no'],
722         ['DebugHost',        'ip_address_regexp',       ''],
723         ['BounceReferrals',  'yesno',            'no'],
724         ['BounceReferralsRobot', 'yesno',        'no'],
725         ['BounceRobotSessionURL',                'yesno', 'no'],
726         ['OrderCleanup',     'routine_array',    ''],
727         ['QueryCache',        'hash',                   ''],
728         ['SessionCookieSecure', 'yesno',         'no'],
729         ['SessionHashLength', 'integer',         1],
730         ['SessionHashLevels', 'integer',         2],
731         ['SourcePriority', 'array_complete', 'mv_pc mv_source'],
732         ['SourceCookie', sub { &parse_ordered_attributes(@_, [qw(name expire domain path secure)]) }, '' ],
733         ['SuppressCachedCookies', 'yesno',       'no'],
734         ['OutputCookieHook', undef,              ''],
735
736         ];
737
738         push @$directives, @$Global::AddDirective
739                 if $Global::AddDirective;
740         return $directives;
741 }
742
743 sub get_parse_routine {
744         my $parse = shift
745                 or return undef;
746         my $routine;
747         my $rname = $parse;
748         if(ref $parse eq 'CODE') {
749                 $routine = $parse;
750         }
751         elsif( $parse =~ /^\w+$/) {
752                 no strict 'refs';
753                 $routine = \&{'parse_' . $parse};
754                 $rname = "parse_$rname";
755         }
756         else {
757                 no strict 'refs';
758                 $routine = \&{"$parse"};
759         }
760
761         if(ref($routine) ne 'CODE') {
762                 config_error('Unknown parse routine %s', $rname);
763         }
764
765         return $routine;
766         
767 }
768
769 sub global_chunk {
770         my ($fn) = @_;
771
772         my $save_c = $C;
773         undef $C;
774
775         local $/;
776         $/ = "\n";
777
778
779         open GCHUNK, "< $fn"
780                 or config_error("read global chunk %s: %s", $fn, $!);
781
782 #::logDebug("GCHUNK length: " . -s $fn);
783         while(<GCHUNK>) {
784                 my $line = $_;
785                 my($lvar, $value) = read_config_value($_, \*GCHUNK);
786                 next unless $lvar;
787                 eval {
788                         $GlobalRead->($lvar, $value);
789                 };
790                 if($@ =~ /Duplicate\s+usertag/i) {
791                         next;
792                 }
793                 if($@) {
794                         ::logDebug("error running global $lvar: $@");
795                 }
796         }
797     close GCHUNK;
798
799         Vend::Dispatch::update_global_actions();
800         finalize_mapped_code();
801
802         $C = $save_c;
803         return 1;
804 }
805
806 sub code_from_file {
807         my ($area, $name, $nohup) = @_;
808         my $c;
809         my $fn;
810 #::logDebug("code_from_file $area, $name");
811         return unless $c = $Global::TagLocation->{$area};
812 #::logDebug("We have a repos for $area");
813         return unless $fn = $c->{$name};
814 #::logDebug("code_from_file found file=$fn");
815
816 #::logDebug("master reading in new area=$area name=$name fn=$fn") if $nohup;
817
818         local $/;
819         $/ = "\n";
820
821         undef $C;
822
823         my $tdir = $Global::TagDir->[0];
824         my $accdir = "$tdir/Accumulated";
825
826         my $newfn = $fn;
827         $newfn =~ s{^$Global::CodeRepository/*}{};
828
829         my $lfile = "$accdir/$newfn";
830         my $ldir = $lfile;
831         $ldir =~ s{/[^/]+$}{};
832         unless(-d $ldir) {
833                 die "Supposed directory $ldir is a file" if -e $ldir;
834                 File::Path::mkpath($ldir)
835                         or die "Cannot create directory $ldir: $!";
836         }
837
838         my $printnew;
839         if(-f $lfile) {
840                 ## This has already been submitted for master integration, no
841                 ## need to do it
842                 $nohup = 1;
843         }
844         else {
845                 open NEWTAG, ">> $lfile"
846                         or die "Cannot write new tag file $lfile: $!";
847                 if (lockfile(\*NEWTAG, 1, 0)) {
848                         ## We got a lock, we are the only one
849                         File::Copy::copy($fn, $lfile);
850                         unlockfile(\*NEWTAG);
851                         close NEWTAG;
852                 }
853                 else {
854                         ## No lock, some other process doing same thing
855                 }
856         }
857
858         open SYSTAG, "< $fn"
859                 or config_error("read system tag file %s: %s", $fn, $!);
860
861         while(<SYSTAG>) {
862                 my $line = $_;
863                 my($lvar, $value) = read_config_value($_, \*SYSTAG);
864                 next unless $lvar;
865                 eval {
866                         $GlobalRead->($lvar, $value);
867                 };
868                 if($@ =~ /Duplicate\s+usertag/i) {
869                         next;
870                 }
871         }
872     close SYSTAG;
873     close NEWTAG;
874
875         finalize_mapped_code($area);
876
877         my $precursor = '';
878         my $routine;
879         my $init;
880         if($area eq 'UserTag') {
881                 $init = $Global::UserTag->{Bootstrap}{$name};
882                 $routine = $Global::UserTag->{Routine}{$name};
883 #::logDebug("NO ROUTINE FOR area=$area name=$name") unless $routine;
884         }
885         else {
886                 $precursor = 'CodeDef ';
887                 $init = $Global::CodeDef->{$area}{Bootstrap}{$name};
888                 $routine = $Global::CodeDef->{$area}{Routine}{$name};
889                 if(! $routine) {
890                         no strict 'refs';
891                         $routine = $Global::CodeDef->{$area}{MapRoutine}{$name}
892                                 and $routine = \&{"$routine"};
893                 }
894 #::logDebug("area=$area name=$name now=" . ::uneval($Global::CodeDef->{$area}));
895         }
896
897         if($init and ref($routine) eq 'CODE') {
898                 ## Attempt to initialize
899                 $init = get_option_hash($init);
900                 $routine->($init);
901         }
902
903
904         ## Tell the master server we have a new tag
905         unless($nohup) {
906 #::logDebug("notifying master of new area=$area name=$name fn=$fn");
907                 ## Bring this tag in global
908                 open(RESTART, ">>$Global::RunDir/restart")
909                                 or die "open $Global::RunDir/restart: $!\n";
910                 lockfile(\*RESTART, 1, 1)
911                                 or die "lock $Global::RunDir/restart: $!\n";
912                 print RESTART "$precursor$area $name\n";
913                 unlockfile(\*RESTART)
914                                 or die "unlock $Global::RunDir/restart: $!\n";
915                 close RESTART;
916                 kill 'HUP', $Vend::MasterProcess;
917         }
918
919 #::logDebug("routine=$routine for area=$area name=$name");
920 #::logDebug("REF IS=" . ::uneval($Global::UserTag)) if $nohup;
921         return $routine;
922 }
923
924 sub set_directive {
925         my ($directive, $value, $global) = @_;
926         my $directives;
927
928         if($global)     { $directives = global_directives(); }
929         else            { $directives = catalog_directives(); }
930
931         my ($d, $dir, $parse);
932         no strict 'refs';
933         foreach $d (@$directives) {
934                 next unless (lc $directive) eq (lc $d->[0]);
935                 $parse = get_parse_routine($d->[1]);
936                 $dir = $d->[0];
937                 $value = $parse->($dir, $value)
938                         if $parse;
939                 last;
940         }
941         return [$dir, $value] if defined $dir;
942         return undef;
943 }
944
945 sub get_catalog_default {
946         my ($directive) = @_;
947         my $directives = catalog_directives();
948         my $value;
949         for(@$directives) {
950                 next unless (lc $directive) eq (lc $_->[0]);
951                 $value = $_->[2];
952         }
953         return undef unless defined $value;
954         return $value;
955 }
956
957 sub get_global_default {
958         my ($directive) = @_;
959         my $directives = global_directives();
960         my $value;
961         for(@$directives) {
962                 next unless (lc $directive) eq (lc $_->[0]);
963                 $value = $_->[2];
964         }
965         return undef unless defined $value;
966         return $value;
967 }
968
969 sub evaluate_ifdef {
970         my ($ifdef, $reverse, $global) = @_;
971 #::logDebug("ifdef '$ifdef'");
972         my $status;
973         $ifdef =~ /^\s*(\@?)(\w+)\s*(.*)/;
974         $global = $1 || $global || undef;
975         my $var  = $2;
976         my $cond = $3;
977         my $var_ref = ! $global ? $C->{Variable} : $Global::Variable;
978 #::logDebug("Variable value '$var_ref->{$var}'");
979         if (! $cond) {
980                 $status = ! (not $var_ref->{$var});
981         }
982         elsif ($cond) {
983                 my $val = $var_ref->{$var} || '';
984                 my $safe = new Vend::Safe;
985                 my $code = "q{$val}" . " " . $cond;
986                 $status = $safe->reval($code);
987                 if($@) {
988                         config_warn(
989                                 errmsg("Syntax error in ifdef evaluation at line %s of %s",
990                                                 $.,
991                                                 $configfile,
992                                         ),
993                         );
994                         $status = '';
995                 }
996         }
997 #::logDebug("ifdef status '$status', reverse=" . !(not $reverse));
998         return $reverse ? ! $status : $status;
999 }
1000
1001 # This is what happens when ParseVariables is true
1002 sub substitute_variable {
1003         my($val) = @_;
1004         1 while $val =~ s/__([A-Z][A-Z_0-9]*?[A-Z0-9])__/$C->{Variable}->{$1}/g;
1005         # Only parse once for globals so they can contain other
1006         # global and catalog variables
1007         $val =~ s/\@\@([A-Z][A-Z_0-9]+[A-Z0-9])\@\@/$Global::Variable->{$1}/g;
1008         return $val;
1009 }
1010
1011 # Parse the configuration file for directives.  Each directive sets
1012 # the corresponding variable in the Vend::Cfg:: package.  E.g.
1013 # "DisplayErrors No" in the config file sets Vend::Cfg->{DisplayErrors} to 0.
1014 # Directives which have no defined default value ("undef") must be specified
1015 # in the config file.
1016
1017 my($directives, $directive, %parse);
1018
1019 sub config {
1020         my($catalog, $dir, $confdir, $subconfig, $existing, $passed_file) = @_;
1021         my($d, $parse, $var, $value, $lvar);
1022
1023         $Vend::Cat = $catalog;
1024
1025         if(ref $existing eq 'HASH') {
1026 #::logDebug("existing=$existing");
1027                 $C = $existing;
1028         }
1029         else {
1030                 undef $existing;
1031                 $C = {};
1032                 $C->{CatalogName} = $catalog;
1033                 $C->{VendRoot} = $dir;
1034
1035                 unless (defined $subconfig) {
1036                         $C->{ErrorFile} = 'error.log';
1037                         $C->{ConfigFile} = 'catalog.cfg';
1038                 }
1039                 else {
1040                         $C->{ConfigFile} = "$catalog.cfg";
1041                         $C->{BaseCatalog} = $subconfig;
1042                 }
1043         }
1044
1045         unless($directives) {
1046                 $directives = catalog_directives();
1047                 foreach $d (@$directives) {
1048                         my $ucdir = $d->[0];
1049                         $directive = lc $d->[0];
1050                         next if $Global::DeleteDirective->{$directive};
1051                         $CDname{$directive} = $ucdir;
1052                         $CPname{$directive} = $d->[1];
1053                         $parse{$directive} = get_parse_routine($d->[1]);
1054                 }
1055         }
1056
1057         for(keys %DirectiveAlias) {
1058                 my $k = lc $_;
1059                 my $v = $DirectiveAlias{$_};
1060                 my $lv = lc $v;
1061                 $CDname{$k} = $CDname{$lv};
1062                 $CPname{$k} = $CPname{$lv};
1063                 $parse{$k} = $parse{$lv};
1064         }
1065
1066         no strict 'refs';
1067
1068         if(! $subconfig and ! $existing ) {
1069                 foreach $d (@$directives) {
1070                         my $ucdir = $d->[0];
1071                         $directive = lc $d->[0];
1072                         next if $Global::DeleteDirective->{$directive};
1073                         $parse = $parse{$directive};
1074
1075                         $value = ( 
1076                                                 ! defined $MV::Default{$catalog} or
1077                                                 ! defined $MV::Default{$catalog}{$ucdir}
1078                                          )
1079                                          ? $d->[2]
1080                                          : $MV::Default{$catalog}{$ucdir};
1081
1082                         if (defined $parse and defined $value) {
1083 #::logDebug("parsing default directive=$directive ucdir=$ucdir parse=$parse value=$value CDname=$CDname{$directive}");
1084                                 $value = $parse->($ucdir, $value);
1085                         }
1086                         $C->{$CDname{$directive}} = $value;
1087                 }
1088         }
1089
1090         @include = ($passed_file || $C->{ConfigFile});
1091         my %include_hash = ($include[0] => 1);
1092         my $done_one;
1093         my ($db, $dname, $nm);
1094         my ($before, $after);
1095         my $recno = 'C0001';
1096
1097         my @hidden_config;
1098         if(! $existing and ! $subconfig) {
1099                 @hidden_config = grep -f $_, 
1100                                                                  "$C->{CatalogName}.site",
1101                                                                  "$Global::ConfDir/$C->{CatalogName}.before",
1102                                                                  @{$Global::ConfigAllBefore},
1103                                                          ;
1104
1105                 # Backwards because of unshift;
1106                 for (@hidden_config) {
1107                         unshift @include, $_;
1108                         $include_hash{$_} = 1;
1109                 }
1110
1111                 @hidden_config = grep -f $_, 
1112                                                                  "$Global::ConfDir/$C->{CatalogName}.after",
1113                                                                  @{$Global::ConfigAllAfter},
1114                                                          ;
1115
1116                 for (@hidden_config) {
1117                         push @include, $_;
1118                         $include_hash{$_} = 1;
1119                 }
1120         }
1121
1122         # %MV::Default holds command-line mods to config, which we write
1123         # to a file for easier processing 
1124         if(! $existing and defined $MV::Default{$catalog}) {
1125                 my $fn = "$Global::RunDir/$catalog.cmdline";
1126                 open(CMDLINE, ">$fn")
1127                         or die "Can't create cmdline configfile $fn: $!\n";
1128                 for(@{$MV::DefaultAry{$catalog}}) {
1129                         my ($d, $v) = split /\s+/, $_, 2;
1130                         if($v =~ /\n/) {
1131                                 $v = "<<EndOfMvD\n$v\nEndOfMvD\n";
1132                         }
1133                         else {
1134                                 $v .= "\n";
1135                         }
1136                         printf CMDLINE '%-19s %s', $d, $v;
1137                 }
1138                 close CMDLINE;
1139                 push @include, $fn;
1140                 $include_hash{$_} = 1;
1141         }
1142
1143         my $allcfg;
1144         if($Global::DumpAllCfg) {
1145                 open ALLCFG, ">$Global::RunDir/allconfigs.cfg"
1146                         and $allcfg = 1;
1147         }
1148         # Create closure that reads and sets config values
1149         my $read = sub {
1150                 my ($lvar, $value, $tie, $var) = @_;
1151
1152                 # parse variables in the value if necessary
1153                 if($C->{ParseVariables} and $value =~ /(?:__|\@\@)/) {
1154                         save_variable($CDname{$lvar}, $value);
1155                         $value = substitute_variable($value);
1156                 }
1157
1158                 # call the parsing function for this directive
1159                 $parse = $parse{$lvar};
1160                 $value = $parse->($CDname{$lvar}, $value) if defined $parse and ! $tie;
1161
1162                 # and set the $C->directive variable
1163                 if($tie) {
1164                         watch ( $CDname{$lvar}, $value );
1165                 }
1166                 else {
1167                         $C->{$CDname{$lvar}} = $value;
1168                 }
1169         };
1170
1171 #print "include starts with @include\n";
1172 CONFIGLOOP:
1173         while ($configfile = shift @include) {
1174                 my $tellmark;
1175                 if(ref $configfile) {
1176                         ($configfile, $tellmark)  = @$configfile;
1177 #print "recalling $configfile (pos $tellmark)\n";
1178                 }
1179
1180         # See if anything is defined in options to do before the
1181         # main configuration file.  If there is a file, then we
1182         # will do it (after pushing the main one on @include).
1183         
1184         -f $configfile && open(CONFIG, "< $configfile")
1185                 or do {
1186                         my $msg = "Could not open configuration file '" . $configfile .
1187                                         "' for catalog '" . $catalog . "':\n$!";
1188                         if(defined $done_one) {
1189                                 warn "$msg\n";
1190                                 open (CONFIG, '');
1191                         }
1192                         else {
1193                                 die "$msg\n";
1194                         }
1195                 };
1196         print ALLCFG "# READING FROM $configfile\n" if $allcfg;
1197         seek(CONFIG, $tellmark, 0) if $tellmark;
1198 #print "seeking to $tellmark in $configfile, include is @include\n";
1199         my ($ifdef, $begin_ifdef);
1200         while(<CONFIG>) {
1201                 if($allcfg) {
1202                         print ALLCFG $_
1203                                 unless /^\s*include\s+/i;
1204                 }
1205                 chomp;                  # zap trailing newline,
1206                 if(/^\s*endif\s*$/i) {
1207 #print "found $_\n";
1208                         undef $ifdef;
1209                         undef $begin_ifdef;
1210                         next;
1211                 }
1212                 if(/^\s*if(n?)def\s+(.*)/i) {
1213                         if(defined $ifdef) {
1214                                 config_error("Can't overlap ifdef at line %s of %s", $., $configfile);
1215                         }
1216                         $ifdef = evaluate_ifdef($2,$1);
1217                         $begin_ifdef = $.;
1218 #print "found $_\n";
1219                         next;
1220                 }
1221                 if(defined $ifdef) {
1222                         next unless $ifdef;
1223                 }
1224                 if(/^\s*include\s+(.+)/i) {
1225 #print "found $_\n";
1226                         my $spec = $1;
1227                         $spec = substitute_variable($spec) if $C->{ParseVariables};
1228                         if ($include_hash{$spec}) {
1229                                 config_error("Possible infinite loop through inclusion of $spec at line %s of %s, skipping", $., $configfile);
1230                                 next;
1231                         }
1232                         $include_hash{$spec} = 1;
1233                         my $ref = [ $configfile, tell(CONFIG)];
1234 #print "saving config $configfile (pos $ref->[1])\n";
1235                         #unshift @include, [ $configfile, tell(CONFIG) ];
1236                         unshift @include, $ref;
1237                         close CONFIG;
1238                         unshift @include, grep -f $_, glob($spec);
1239                         next CONFIGLOOP;
1240                 }
1241
1242                 my ($lvar, $value, $var, $tie) =
1243                         read_config_value($_, \*CONFIG, $allcfg);
1244
1245                 next unless $lvar;
1246
1247                 # Use our closure defined above
1248                 $read->($lvar, $value, $tie);
1249
1250                 # If we have passed off configuration to a database we stop here...
1251                 last if $C->{ConfigDatabase}->{ACTIVE};
1252
1253                 # See if we want to load the config database
1254                 if(! $db and $C->{ConfigDatabase}->{LOAD}) {
1255                         $db = $C->{ConfigDatabase}->{OBJECT}
1256                                 or config_error(
1257                                         "ConfigDatabase $C->{ConfigDatabase}->{'name'} not active.");
1258                         $dname = $C->{ConfigDatabase}{name};
1259                 }
1260
1261                 # Actually load ConfigDatabase if present
1262                 if($db) {
1263                         $nm = $CDname{$lvar};
1264                         my ($extended, $status);
1265                         undef $extended;
1266
1267                         # set directive name
1268                         $status = Vend::Data::set_field($db, $recno, 'directive', $nm);
1269                         defined $status
1270                                 or config_error(
1271                                         "ConfigDatabase failed for %s, field '%s'",
1272                                         $dname,
1273                                         'directive',
1274                                         );
1275
1276                         # use extended value field if necessary or directed
1277                         if (length($value) > 250 or $UseExtended{$nm}) {
1278                                 $extended = $value;
1279                                 $extended =~ s/(\S+)\s*//;
1280                                 $value = $1 || '';
1281                                 $status = Vend::Data::set_field($db, $recno, 'extended', $extended);
1282                                 defined $status
1283                                         or config_error(
1284                                                 "ConfigDatabase failed for %s, field '%s'",
1285                                                 $dname,
1286                                                 'extended',
1287                                                 );
1288                         }
1289
1290                         # set value -- just a name if extended was used
1291                         $status = Vend::Data::set_field($db, $recno, 'value', $value);
1292                         defined $status
1293                                 or config_error(
1294                                                 "ConfigDatabase failed for %s, field '%s'",
1295                                                 $dname,
1296                                                 'value',
1297                                         );
1298
1299                         $recno++;
1300                 }
1301                 
1302         }
1303         $done_one = 1;
1304         close CONFIG;
1305         delete $include_hash{$configfile};
1306
1307         # See if we have an active configuration database
1308         if($C->{ConfigDatabase}->{ACTIVE}) {
1309                 my ($key,$value,$dir,@val);
1310                 my $name = $C->{ConfigDatabase}->{name};
1311                 $db = $C->{ConfigDatabase}{OBJECT} or 
1312                         config_error("ConfigDatabase called ACTIVE with no database object.\n");
1313                 my $items = $db->array_query("select * from $name order by code");
1314                 my $one;
1315                 foreach $one ( @$items ) {
1316                         ($key, $dir, @val) = @$one;
1317                         $value = join " ", @val;
1318                         $value =~ s/\s/\n/ if $value =~ /\n/;
1319                         $value =~ s/^\s+//;
1320                         $value =~ s/\s+$//;
1321                         $lvar = lc $dir;
1322                         $read->($lvar, $value);
1323                 }
1324         }
1325
1326         if(defined $ifdef) {
1327                 config_error("Failed to close #ifdef on line %s.", $begin_ifdef);
1328         }
1329
1330 } # end CONFIGLOOP
1331
1332         # We need to make this directory if it isn't already there....
1333         if(! $existing and $C->{ScratchDir} and ! -e $C->{ScratchDir}) {
1334                 mkdir $C->{ScratchDir}, 0700
1335                         or die "Can't make temporary directory $C->{ScratchDir}: $!\n";
1336         }
1337
1338         return $C if $existing;
1339
1340         # check for unspecified directives that don't have default values
1341
1342         # but set some first if appropriate
1343         set_defaults() unless $C->{BaseCatalog};
1344
1345         REQUIRED: {
1346                 last REQUIRED if defined $subconfig;
1347                 last REQUIRED if defined $Vend::ExternalProgram;
1348                 foreach $var (keys %CDname) {
1349                         if (! defined $C->{$CDname{$var}}) {
1350                                 my $msg = errmsg(
1351                                         "Please specify the %s directive in the configuration file '%s'",
1352                                         $CDname{$var},
1353                                         ($passed_file || $C->{ConfigFile}),
1354                                 );
1355
1356                                 die "$msg\n";
1357                         }
1358                 }
1359         }
1360
1361         # Set up hash of keys to hide for BounceReferrals and BounceReferralsRobot
1362         $C->{BounceReferrals_hide} = { map { ($_, 1) } grep { !(/^cookie-/ or /^session(?:$|-)/) } @{$C->{SourcePriority}} };
1363         my @exclude = qw( mv_form_charset mv_session_id mv_tmp_session );
1364         @{$C->{BounceReferrals_hide}}{@exclude} = (1) x @exclude;
1365
1366         finalize_mapped_code();
1367
1368         set_readonly_config();
1369         # Ugly legacy stuff so API won't break
1370         $C->{Special} = $C->{SpecialPage} if defined $C->{SpecialPage};
1371         my $return = $C;
1372         undef $C;
1373         return $return;
1374 }
1375
1376 sub read_container {
1377         my($start, $handle, $marker, $parse, $allcfg) = @_;
1378         my $lvar = lc $marker;
1379         my $var = $CDname{$lvar};
1380
1381 #::logDebug("Read container start=$start marker=$marker lvar=$lvar var=$var parse=$parse");
1382         $parse ||= {};
1383 #::logDebug("Read container parse value=$CPname{$lvar}");
1384         my $sub = $ContainerSpecial{$var}
1385                           || $ContainerSpecial{$lvar}
1386                           || $ContainerType{$CPname{$lvar}};
1387
1388         if($sub) {
1389 #::logDebug("Trigger special container");
1390                 $start =~ s/\n$//;
1391                 $sub->($var, $start);
1392                 $ContainerTrigger{$lvar} ||= $sub;
1393                 return $start;
1394         }
1395         
1396         my $foundeot = 0;
1397         my $startline = $.;
1398         my $value = '';
1399         if(length $start) {
1400                 $value .= "$start\n";
1401         }
1402         while (<$handle>) {
1403                 print ALLCFG $_ if $allcfg;
1404                 if ($_ =~ m{^\s*</$marker>\s*$}i) {
1405                         $foundeot = 1;
1406                         last;
1407                 }
1408                 $value .= $_;
1409         }
1410         return undef unless $foundeot;
1411         #untaint
1412         $value =~ /((?s:.)*)/;
1413         $value = $1;
1414         return $value;
1415 }
1416
1417 sub read_here {
1418         my($handle, $marker, $allcfg) = @_;
1419         my $foundeot = 0;
1420         my $startline = $.;
1421         my $value = '';
1422         while (<$handle>) {
1423                 print ALLCFG $_ if $allcfg;
1424                 if ($_ =~ m{^$marker$}) {
1425                         $foundeot = 1;
1426                         last;
1427                 }
1428                 $value .= $_;
1429         }
1430         return undef unless $foundeot;
1431         #untaint
1432         $value =~ /((?s:.)*)/;
1433         $value = $1;
1434         return $value;
1435 }
1436
1437 sub config_named_catalog {
1438         my ($cat_name, $source, $db_only, $dbconfig) = @_;
1439         my ($g, $c);
1440
1441         $g = $Global::Catalog{$cat_name};
1442         unless (defined $g) {
1443                 logGlobal( "Can't find catalog '%s'" , $cat_name );
1444                 return undef;
1445         }
1446
1447         $Vend::Log_suppress = 1;
1448
1449         unless ($db_only or $Vend::Quiet) {
1450                 logGlobal( "Config '%s' %s%s", $g->{'name'}, $source );
1451         }
1452         undef $Vend::Log_suppress;
1453
1454     chdir $g->{'dir'}
1455             or die "Couldn't change to $g->{'dir'}: $!\n";
1456
1457         if($db_only) {
1458                 logGlobal(
1459                         "Config table '%s' (file %s) for catalog %s from %s",
1460                         $db_only,
1461                         $dbconfig,
1462                         $g->{'name'},
1463                         $source,
1464                         );
1465                 my $cfg = $Global::Selector{$g->{script}}
1466                         or die errmsg("'%s' not a catalog (%s).", $g->{name}, $g->{script});
1467                 undef $cfg->{Database}{$db_only};
1468                 $Vend::Cfg = config(
1469                                 $g->{name},
1470                                 $g->{dir},
1471                                 undef,
1472                                 undef,
1473                                 $cfg,
1474                                 $dbconfig,
1475                                 )
1476                         or die errmsg("error configuring catalog %s table %s: %s",
1477                                                         $g->{name},
1478                                                         $db_only,
1479                                                         $@,
1480                                         );
1481                 open_database();
1482                 close_database();
1483                 return $Vend::Cfg;
1484         }
1485
1486     eval {
1487         $c = config($g->{'name'},
1488                                         $g->{'dir'},
1489                                         undef,
1490                                         $g->{'base'} || undef,
1491 # OPTION_EXTENSION
1492 #                                       $Vend::CommandLine->{$g->{'name'}} || undef
1493 # END OPTION_EXTENSION
1494                                         );
1495     };
1496
1497     if($@) {
1498                 my $msg = $@;
1499         logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
1500         return undef;
1501     }
1502
1503         if (defined $g->{base}) {
1504                 open_database(1);
1505                 dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
1506                 return $c;
1507         }
1508
1509         eval {
1510                 $Vend::Cfg = $c;        
1511                 $::Variable = $Vend::Cfg->{Variable};
1512                 $::Pragma   = $Vend::Cfg->{Pragma};
1513                 Vend::Data::read_salestax();
1514                 Vend::Data::read_shipping();
1515                 open_database(1);
1516                 my $db;
1517                 close_database();
1518         };
1519
1520         undef $Vend::Cfg;
1521     if($@) {
1522                 my $msg = $@;
1523                 $msg =~ s/\s+$//;
1524         logGlobal( "%s config error: %s" , $g->{'name'}, $msg );
1525         return undef;
1526     }
1527
1528         dump_structure($c, "$c->{RunDir}/$g->{name}") if $Global::DumpStructure;
1529
1530     my $status_dir = ($c->{Source}{RunDir} ? $c->{RunDir} : $c->{ConfDir});
1531
1532         delete $c->{Source};
1533
1534         my $stime = scalar localtime();
1535         writefile(">$Global::RunDir/status.$g->{name}", "$stime\n$g->{dir}\n");
1536         writefile(">$status_dir/status.$g->{name}", "$stime\n");
1537
1538         return $c;
1539
1540 }
1541
1542
1543 use File::Find;
1544
1545 sub get_system_groups {
1546
1547         my @files;
1548         my $wanted = sub {
1549                 return if (m{^\.} || ! -f $_);
1550                 $File::Find::name =~ m{/([^/]+)/([^/.]+)\.(\w+)$}
1551                         or return;
1552                 my $group = $1;
1553                 my $tname = $2;
1554                 my $ext = $extmap{lc $3} or return;
1555                 $ext =~ /Tag$/ or return;
1556                 push @files, [ $group, $tname ];
1557         };
1558         File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
1559
1560         $Global::TagGroup ||= {};
1561         for(@files) {
1562                 my $g = $Global::TagGroup->{":$_->[0]"} ||= [];
1563                 push @$g, $_->[1];
1564         }
1565         return;
1566 }
1567
1568 sub get_repos_code {
1569
1570 #::logDebug("get_repos_code called");
1571         return unless $Global::CodeRepository;
1572
1573         return if $Vend::ControllingInterchange;
1574         
1575         my @files;
1576         my $wanted = sub {
1577                 return if (m{^\.} || ! -f $_);
1578                 return unless m{^[^.]+\.(\w+)$};
1579                 my $ext = $extmap{lc $1} or return;
1580                 push @files, [ $File::Find::name, $ext];
1581         };
1582         File::Find::find({ wanted => $wanted, follow => 1 }, $Global::CodeRepository);
1583
1584         my $c = $Global::TagLocation = {};
1585
1586         # %valid_dest is scoped as my variable above
1587
1588         for(@files) {
1589                 my $foundfile   = $_->[0];
1590                 my $dest                = $_->[1];
1591                 open SYSTAG, "< $foundfile"
1592                         or next;
1593                 while(<SYSTAG>) {
1594                         my($lvar, $value) = read_config_value($_, \*SYSTAG);
1595                         my $name;
1596                         my $dest;
1597                         if($lvar eq 'codedef') {
1598                                 $value =~ s/^(\S+)\s+(\S+).*//s;
1599                                 $dest = $valid_dest{lc $2};
1600                                 $name = $1;
1601                         }
1602                         elsif($dest = $valid_dest{$lvar}) {
1603                                 $value =~ m/^(\S+)\s+/
1604                                 and $name = $1;
1605                         }
1606
1607                         next unless $dest and $name;
1608
1609                         $name = lc $name;
1610                         $name =~ s/-/_/g;
1611                         $c->{$dest} ||= {};
1612                         $c->{$dest}{$name} ||= $foundfile;
1613                 }
1614                 close SYSTAG;
1615         }
1616
1617 #::logDebug("repos is:\n" . ::uneval($Global::TagLocation));
1618
1619 }
1620
1621 sub get_system_code {
1622
1623         return if $CodeDest;
1624         return if $Vend::ControllingInterchange;
1625         
1626         # defined means don't go here anymore
1627         $SystemCodeDone = '';
1628         my @files;
1629         my $wanted = sub {
1630                 return if (m{^\.} || ! -f $_);
1631                 return unless m{^[^.]+\.(\w+)$};
1632                 my $ext = $extmap{lc $1} or return;
1633                 push @files, [ $File::Find::name, $ext];
1634         };
1635         File::Find::find({ wanted => $wanted, follow => 1 }, @$Global::TagDir);
1636
1637         local($configfile);
1638         for(@files) {
1639                 $CodeDest = $_->[1];
1640
1641                 $configfile = $_->[0];
1642                 open SYSTAG, "< $configfile"
1643                         or config_error("read system tag file %s: %s", $configfile, $!);
1644                 while(<SYSTAG>) {
1645                         my($lvar, $value) = read_config_value($_, \*SYSTAG);
1646                         next unless $lvar;
1647                         $GlobalRead->($lvar, $value);
1648                 }
1649                 close SYSTAG;
1650         }
1651
1652         undef $CodeDest;
1653         # 1 means read system tag directories
1654         $SystemCodeDone = 1;
1655 }
1656
1657 sub read_config_value {
1658         local($_) = shift;
1659         return undef unless $_;
1660         my ($fh, $allcfg) = @_;
1661
1662         my $lvar;
1663         my $tie;
1664
1665         chomp;                  # zap trailing newline,
1666         s/^\s*#.*//;            # comments,
1667                                 # mh 2/10/96 changed comment behavior
1668                                 # to avoid zapping RGB values
1669                                 #
1670         s/\s+$//;               #  trailing spaces
1671         return undef unless $_;
1672
1673         local($Vend::config_line);
1674         $Vend::config_line = $_;
1675         my $container_here;
1676         my $container_trigger;
1677         my $var;
1678         my $value;
1679
1680         if(s{^[ \t]*<(/?)(\w+)\s*(.*)\s*>\s*$}{$2$3}) {
1681                 $container_trigger = $1;
1682                 $var = $container_here = $2;
1683                 $value = $3;
1684         }
1685         else {
1686                 # lines read from the config file become untainted
1687                 m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error from $_");
1688                 $var = $1;
1689                 $value = $2;
1690         }
1691         ($lvar = $var) =~ tr/A-Z/a-z/;
1692
1693         config_error("Unknown directive '%s'", $lvar), next
1694                 unless defined $CDname{$lvar};
1695
1696         my($codere) = '[-\w_#/.]+';
1697
1698         if ($container_trigger) {                  # Apache container value
1699                 if(my $sub = $ContainerTrigger{$lvar}) {
1700                         $sub->($var, $value, 1);
1701                         return;
1702                 }
1703         }
1704
1705         if ($container_here) {                  # Apache container value
1706                 my $begin  = $value;
1707                 $begin .= "\n" if length $begin;
1708                 my $mark = "</$container_here>";
1709                 my $startline = $.;
1710                 $value = read_container($begin, $fh, $container_here, \%parse);
1711                 unless (defined $value) {
1712                         config_error (sprintf('%d: %s', $startline,
1713                                 qq#no end contaner ("</$container_here>") found#));
1714                 }
1715         }
1716         elsif ($value =~ /^(.*)<<(\w+)\s*/) {                  # "here" value
1717                 my $begin  = $1 || '';
1718                 $begin .= "\n" if $begin;
1719                 my $mark = $2;
1720                 my $startline = $.;
1721                 $value = $begin . read_here($fh, $mark);
1722                 unless (defined $value) {
1723                         config_error (sprintf('%d: %s', $startline,
1724                                 qq#no end marker ("$mark") found#));
1725                 }
1726         }
1727         elsif ($value =~ /^(.*)<&(\w+)\s*/) {                # "here sub" value
1728                 my $begin  = $1 || '';
1729                 $begin .= "\n" if $begin;
1730                 my $mark  = $2;
1731                 my $startline = $.;
1732                 $value = $begin . read_here($fh, $mark, $allcfg);
1733                 unless (defined $value) {
1734                         config_error (sprintf('%d: %s', $startline,
1735                                 qq#no end marker ("$mark") found#));
1736                 }
1737                 eval {
1738                         require Tie::Watch;
1739                 };
1740                 unless ($@) {
1741                         $tie = 1;
1742                 }
1743                 else {
1744                         config_warn(
1745                                 "No Tie::Watch module installed at %s, setting %s to default.",
1746                                 $startline,
1747                                 $var,
1748                         );
1749                         $value = '';
1750                 }
1751         }
1752         elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) {   # read from file
1753                 my $confdir = $C ? $C->{ConfigDir} : $Global::ConfigDir;
1754                 $value = $1 || '';
1755                 my $file = $3;
1756                 $value .= "\n" if $value;
1757                 unless ($confdir) {
1758                         config_error(
1759                                 "%s: Can't read from file until ConfigDir defined",
1760                                 $CDname{$lvar},
1761                         );
1762                 }
1763                 $file = $CDname{$lvar} unless $file;
1764                 
1765                 # If the file isn't already specified with an absolute path, try the 
1766                 # Config directory, then the current directory.  When neither file
1767                 # exists, use the Config directory and continue.
1768                 if ($file !~ m!^/!) {
1769                         my $test_with_confdir = escape_chars("$confdir/$file");
1770                         if (-f $test_with_confdir) {
1771                                 $file = $test_with_confdir;
1772                         }
1773                         else {
1774                                 my $test_without_confdir = escape_chars($file);
1775                                 if (-f $test_without_confdir) {
1776                                         $file = $test_without_confdir;
1777                                 }
1778                                 else {
1779                                         $file = $test_with_confdir;
1780                                 }
1781                         }
1782                 }
1783                  
1784                 my $tmpval = readfile($file);
1785                 unless( defined $tmpval ) {
1786                         config_warn(
1787                                         "%s: read from non-existent file %s, skipping.",
1788                                         $CDname{$lvar},
1789                                         $file,
1790                         );
1791                         return undef;
1792                 }
1793                 chomp($tmpval) unless $tmpval =~ m!.\n.!;
1794                 $value .= $tmpval;
1795         }
1796         return($lvar, $value, $var, $tie);
1797 }
1798
1799 # Parse the global configuration file for directives.  Each directive sets
1800 # the corresponding variable in the Global:: package.  E.g.
1801 # "DisplayErrors No" in the config file sets Global::DisplayErrors to 0.
1802 # Directives which have no default value ("undef") must be specified
1803 # in the config file.
1804 sub global_config {
1805         my(%parse, $var, $value, $lvar, $parse);
1806         my($directive, $seen_catalog);
1807         no strict 'refs';
1808
1809         %CDname = ();
1810         %CPname = ();
1811
1812         my $directives = global_directives();
1813
1814         $Global::Structure = {} unless $Global::Structure;
1815
1816         # Prevent parsers from thinking it is a catalog
1817         undef $C;
1818
1819         foreach my $d (@$directives) {
1820                 $directive = lc $d->[0];
1821                 $CDname{$directive} = $d->[0];
1822                 $CPname{$directive} = $d->[1];
1823                 $parse = get_parse_routine($d->[1]);
1824                 $parse{$directive} = $parse;
1825                 undef $value;
1826                 $value = ( 
1827                                         ! defined $MV::Default{mv_global} or
1828                                         ! defined $MV::Default{mv_global}{$d->[0]}
1829                                  )
1830                                  ? $d->[2]
1831                                  : $MV::Default{mv_global}{$d->[0]};
1832
1833                 if (defined $DumpSource{$CDname{$directive}}) {
1834                         $Global::Structure->{ $CDname{$directive} } = $value;
1835                 }
1836
1837                 if (defined $parse and defined $value) {
1838                         $value = $parse->($d->[0], $value);
1839                 }
1840
1841                 if(defined $value) {
1842                         ${'Global::' . $CDname{$directive}} = $value;
1843
1844                         $Global::Structure->{ $CDname{$directive} } = $value
1845                                 unless defined $DontDump{ $CDname{$directive} };
1846                 }
1847
1848         }
1849
1850         my (@include) = $Global::ConfigFile; 
1851
1852         # Create closure for reading of value
1853
1854         my $read = sub {
1855                 my ($lvar, $value, $tie) = @_;
1856
1857 #::logDebug("Doing a GlobalRead for $lvar") unless $Global::Foreground;
1858                 unless (defined $CDname{$lvar}) {
1859                         config_error("Unknown directive '%s'", $var);
1860                         return;
1861                 }
1862
1863 #::logDebug("Continuing a GlobalRead for $lvar") unless $Global::Foreground;
1864                 if (defined $DumpSource{$CDname{$directive}}) {
1865                         $Global::Structure->{ $CDname{$directive} } = $value;
1866                 }
1867
1868                 # call the parsing function for this directive
1869                 $parse = $parse{$lvar};
1870 #::logDebug("parse routine is $parse for $CDname{$lvar}") unless $Global::Foreground;
1871                 $value = $parse->($CDname{$lvar}, $value) if defined $parse;
1872
1873                 # and set the Global::directive variable
1874                 ${'Global::' . $CDname{$lvar}} = $value;
1875 #::logDebug("It is now=" . ::uneval($value)) unless $Global::Foreground;
1876                 $Global::Structure->{ $CDname{$lvar} } = $value
1877                         unless defined $DontDump{ $CDname{$lvar} };
1878         };
1879
1880         $GlobalRead = $read;
1881         my $done_one;
1882 GLOBLOOP:
1883         while ($configfile = shift @include) {
1884                 my $tellmark;
1885                 if(ref $configfile) {
1886                         ($configfile, $tellmark)  = @$configfile;
1887 #print "recalling $configfile (pos $tellmark)\n";
1888                 }
1889
1890         -f $configfile && open(GLOBAL, "< $configfile")
1891                 or do {
1892                         my $msg = errmsg(
1893                                                 "Could not open global configuration file '%s': %s",
1894                                                 $configfile,
1895                                                 $!,
1896                                                 );
1897                         if(defined $done_one) {
1898                                 warn "$msg\n";
1899                                 open (GLOBAL, '');
1900                         }
1901                         else {
1902                                 die "$msg\n";
1903                         }
1904                 };
1905         seek(GLOBAL, $tellmark, 0) if $tellmark;
1906 #print "seeking to $tellmark in $configfile, include is @include\n";
1907         my ($ifdef, $begin_ifdef);
1908         while(<GLOBAL>) {
1909                 if(/^\s*endif\s*$/i) {
1910 #print "found $_";
1911                         undef $ifdef;
1912                         undef $begin_ifdef;
1913                         next;
1914                 }
1915                 if(/^\s*if(n?)def\s+(.*)/i) {
1916 #print "found $_";
1917                         if(defined $ifdef) {
1918                                 config_error(
1919                                         "Can't overlap ifdef at line %s of %s",
1920                                         $.,
1921                                         $configfile,
1922                                 );
1923                         }
1924                         $ifdef = evaluate_ifdef($2,$1,1);
1925                         $begin_ifdef = $.;
1926                         next;
1927                 }
1928                 if(defined $ifdef) {
1929                         next unless $ifdef;
1930                 }
1931                 if(/^\s*include\s+(.+)/) {
1932 #print "found $_";
1933                         my $spec = $1;
1934                         my $ref = [ $configfile, tell(GLOBAL)];
1935 #print "saving config $configfile (pos $ref->[1])\n";
1936                         unshift @include, $ref;
1937                         close GLOBAL;
1938                         chomp;
1939                         unshift @include, grep -f $_, glob($spec);
1940                         next GLOBLOOP;
1941                 }
1942
1943                 my ($lvar, $value, $tie) = read_config_value($_, \*GLOBAL);
1944                 next unless $lvar;
1945                 $read->($lvar, $value, $tie);
1946
1947         }
1948         close GLOBAL;
1949         $done_one = 1;
1950 } # end GLOBLOOP;
1951
1952         # In case no user-supplied config has been given...returns
1953         # with no effect if that has been done already.
1954         get_system_code() unless defined $SystemCodeDone;
1955
1956         # Directive post-processing
1957         global_directive_postprocess();
1958
1959         # Do some cleanup
1960         set_global_defaults();
1961
1962         # check for unspecified directives that don't have default values
1963         foreach $var (keys %CDname) {
1964                 last if defined $Vend::ExternalProgram;
1965                 if (!defined ${'Global::' . $CDname{$var}}) {
1966                         die "Please specify the $CDname{$var} directive in the\n" .
1967                         "configuration file '$Global::ConfigFile'\n";
1968                 }
1969         }
1970
1971         # Inits Global UserTag entries
1972         ADDTAGS: {
1973                 Vend::Parse::global_init;
1974         }
1975
1976         ## Pulls in the places where code can be found when AccumulatingTags
1977         get_repos_code() if $Global::AccumulateCode;
1978
1979         finalize_mapped_code();
1980
1981         dump_structure($Global::Structure, "$Global::RunDir/$Global::ExeName")
1982                 if $Global::DumpStructure and ! $Vend::ExternalProgram;
1983
1984         delete $Global::Structure->{Source};
1985
1986         %CDname = ();
1987         return 1;
1988 }
1989
1990 # Use Tie::Watch to attach subroutines to config variables
1991 sub watch {
1992         my($name, $value) = @_;
1993         $C->{Tie_Watch} = [] unless $C->{Tie_Watch};
1994         push @{$C->{Tie_Watch}}, $name;
1995
1996         my ($ref, $orig);
1997 #::logDebug("Contents of $name: " . uneval_it($C->{$name}));
1998         if(CORE::ref($C->{$name}) =~ /ARRAY/) {
1999 #::logDebug("watch ref=array");
2000                 $ref = $C->{$name};
2001                 $orig = [ @{ $C->{$name} } ];
2002         }
2003         elsif(CORE::ref($C->{$name}) =~ /HASH/) {
2004 #::logDebug("watch ref=hash");
2005                 $ref = $C->{$name};
2006                 $orig = { %{ $C->{$name} } };
2007         }
2008         else {
2009 #::logDebug("watch ref=scalar");
2010                 $ref = \$C->{$name};
2011                 $orig = $C->{$name};
2012         }
2013 #::logDebug("watch ref=$ref orig=$orig name=$name value=$value");
2014         $C->{WatchIt} = { _mvsafe => $C->{ActionMap}{_mvsafe} } if ! $C->{WatchIt};
2015         parse_action('WatchIt', "$name $value");
2016         my $coderef = $C->{WatchIt}{$name}
2017                 or return undef;
2018         my $recode = sub {
2019                                         package Vend::Interpolate;
2020                                         init_calc();
2021                                         my $key = $_[0]->Args(-fetch)->[0];
2022                                         return $coderef->(@_, $key);
2023                                 };
2024         package Vend::Interpolate;
2025         $Vend::Config::C->{WatchIt}{$name} = Tie::Watch->new(
2026                                         -variable => $ref,
2027                                         -fetch => [$recode,$orig],
2028                                         );
2029 }
2030
2031 sub get_wildcard_list {
2032         my($var, $value, $base) = @_;
2033
2034         $value =~ s/\s*#.*?$//mg;
2035         $value =~ s/^\s+//;
2036         $value =~ s/\s+$//;
2037         return '' if ! $value;
2038
2039         if($value !~ /\|/) {
2040                 $value =~ s/([\\\+\|\[\]\(\){}])/\\$1/g;
2041                 $value =~ s/\./\\./g;
2042                 $value =~ s/\*/.*/g;
2043                 $value =~ s/\?/./g;
2044                 my @items = grep /\S/, split /\s*,\s*/, $value;
2045                 for (@items) {
2046                         s/\s+/\\s+/g;
2047                         my $extra = $_;
2048                         if ($base && $extra =~ s/^\.\*\\\.//){
2049                                 push(@items,$extra) if $extra;
2050                         }
2051                 }
2052                 $value = join '|', @items;
2053         }
2054         return parse_regex($var, $value);
2055 }
2056
2057 sub external_global {
2058         my ($value) = @_;
2059
2060         my $main = {};
2061
2062         my @sets = grep /\w/, split /[\s,]+/, $value;
2063 #::logDebug( "Parsing sets=" . join(",", @sets) . "\n" );
2064
2065         no strict 'refs';
2066
2067         for my $set (@sets) {
2068 #::logDebug( "Parsing $set\n" );
2069                 my @keys = split /->/, $set;
2070                 my ($k, $v) = split /=/, $keys[0];
2071                 my $major;
2072                 my $var;
2073                 if($k =~ m/^(\w+)::(\w+)$/) {
2074                         $major = $1;
2075                         $var = $2;
2076                 }
2077                 $major ||= 'Global';
2078                 $v ||= $var;
2079                 my $walk = ${"${major}::$var"};
2080                 my $ref = $main->{$v} = $walk;
2081                 for(my $i = 1; $i < @keys; $i++) {
2082                         my $current = $keys[$i];
2083 #::logDebug( "Walking $current\n" );
2084                         if($i == $#keys) {
2085                                 if( CORE::ref($ref) eq 'ARRAY' ) {
2086                                         $current =~ s/\D+//g;
2087                                         $current =~ /^\d+$/
2088                                                 or config_error("External: Bad array index $current from $set");
2089                                         $ref->[$current] = $walk->[$current];
2090 #::logDebug( "setting $current to ARRAY\n" );
2091                                 }
2092                                 elsif( CORE::ref($ref) eq 'HASH' ) {
2093                                         $ref->{$current} = $walk->{$current};
2094 #::logDebug( "setting $current to HASH\n" );
2095                                 }
2096                                 else {
2097                                         config_error("External: bad data structure for $set");
2098                                 }
2099                         }
2100                         else {
2101                                 $walk = $walk->{$current};
2102 #::logDebug( "Walking $current\n" );
2103                                 if( CORE::ref($walk) eq 'HASH' ) {
2104                                         $ref->{$current} = {};
2105                                         $ref = $ref->{$current};
2106                                 }
2107                                 else {
2108                                         config_error("External: bad data structure for $set");
2109                                 }
2110                         }
2111                 }
2112         }
2113         return $main;
2114 }
2115
2116 # Set the External environment, dumps, etc.
2117 sub external_cat {
2118         my ($value) = @_;
2119
2120         my $c = $C
2121                 or config_error( "Not in catalog configuration context." );
2122
2123         my $main = {};
2124         my @sets = grep /\w/, split /[\s,]+/, $value;
2125         for my $set (@sets) {
2126                 my @keys = split /->/, $set;
2127                 my $ref  = $main;
2128                 my $walk = $c;
2129                 for(my $i = 0; $i < @keys; $i++) {
2130                         my $current = $keys[$i];
2131                         if($i == $#keys) {
2132                                 if( CORE::ref($ref) eq 'ARRAY' ) {
2133                                         $current =~ s/\D+//g;
2134                                         $current =~ /^\d+$/
2135                                                 or config_error("External: Bad array index $current from $set");
2136                                         $ref->[$current] = $walk->[$current];
2137                                 }
2138                                 elsif( CORE::ref($ref) eq 'HASH' ) {
2139                                         $ref->{$current} = $walk->{$current};
2140                                 }
2141                                 else {
2142                                         config_error("External: bad data structure for $set");
2143                                 }
2144                         }
2145                         else {
2146                                 $walk = $walk->{$current};
2147                                 if( CORE::ref($walk) eq 'HASH' ) {
2148                                         $ref->{$current} ||= {};
2149                                         $ref = $ref->{$current};
2150                                 }
2151                                 else {
2152                                         config_error("External: bad data structure for $set");
2153                                 }
2154                         }
2155                 }
2156         }
2157
2158         return $main;
2159 }
2160
2161 # Set up an ActionMap or FormAction or FileAction
2162 sub parse_action {
2163         my ($var, $value, $mapped) = @_;
2164         if (! $value) {
2165                 return $InitializeEmpty{$var} ? '' : {};
2166         }
2167
2168         return if $Vend::ExternalProgram;
2169
2170         my $c;
2171         if($mapped) {
2172                 $c = $mapped;
2173         }
2174         elsif(defined $C) {
2175                 $c = $C->{$var} ||= {};
2176         }
2177         else {
2178                 no strict 'refs';
2179                 $c = ${"Global::$var"} ||= {};
2180         }
2181
2182         if (defined $C and ! $c->{_mvsafe}) {
2183                 my $calc = Vend::Interpolate::reset_calc();
2184                 $c->{_mvsafe} = $calc;
2185         }
2186         my ($name, $sub) = split /\s+/, $value, 2;
2187
2188         $name =~ s/-/_/g;
2189         
2190         ## Determine if we are in a catalog config, and if 
2191         ## perl should be global and/or strict
2192         my $nostrict;
2193         my $perlglobal = 1;
2194
2195         if($C) {
2196                 $nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
2197                 $perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
2198         }
2199
2200         # Untaint and strip this pup
2201         $sub =~ s/^\s*((?s:.)*\S)\s*//;
2202         $sub = $1;
2203
2204         if($sub !~ /\s/) {
2205                 no strict 'refs';
2206                 if($sub =~ /::/ and ! $C) {
2207                         $c->{$name} = \&{"$sub"};
2208                 }
2209                 else {
2210                         if($C and $C->{Sub}) {
2211                                 $c->{$name} = $C->{Sub}{$sub};
2212                         }
2213
2214                         if(! $c->{$name} and $Global::GlobalSub) {
2215                                 $c->{$name} = $Global::GlobalSub->{$sub};
2216                         }
2217                 }
2218                 if(! $c->{$name} and $AllowScalarAction{$var}) {
2219                         $c->{$name} = $sub;
2220                 }
2221                 elsif(! $c->{$name}) {
2222                         $@ = errmsg("Mapped %s action routine '%s' is non-existent.", $var, $sub);
2223                 }
2224         }
2225         elsif ( ! $mapped and $sub !~ /^sub\b/) {
2226                 if($AllowScalarAction{$var}) {
2227                         $c->{$name} = $sub;
2228                 }
2229                 else {
2230                         my $code = <<EOF;
2231 sub {
2232                                 return Vend::Interpolate::interpolate_html(<<EndOfThisHaiRYTHING);
2233 $sub
2234 EndOfThisHaiRYTHING
2235 }
2236 EOF
2237                         $c->{$name} = eval $code;
2238                 }
2239         }
2240         elsif ($perlglobal) {
2241                 package Vend::Interpolate;
2242                 if($nostrict) {
2243                         no strict;
2244                         $c->{$name} = eval $sub;
2245                 }
2246                 else {
2247                         $c->{$name} = eval $sub;
2248                 }
2249         }
2250         else {
2251                 package Vend::Interpolate;
2252                 $c->{$name} = $c->{_mvsafe}->reval($sub);
2253         }
2254         if($@) {
2255                 config_warn("Action '%s' did not compile correctly (%s).", $name, $@);
2256         }
2257         return $c;
2258         
2259 }
2260
2261 sub get_directive {
2262         my $name = shift;
2263         $name = $CDname{lc $name} || $name;
2264         no strict 'refs';
2265         if($C) {
2266                 return $C->{$name};
2267         }
2268         else {
2269                 return ${"Global::$name"};
2270         }
2271 }
2272
2273 # Adds features contained in FeatureDir called by catalog
2274
2275 sub parse_feature {
2276         my ($var, $value) = @_;
2277         my $c = $C->{$var} || {};
2278         return $c unless $value;
2279
2280         $value =~ s/^\s+//;
2281         $value =~ s/\s+$//;
2282         my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
2283
2284         unless(-d $fdir) {
2285                 config_warn("Feature '%s' not found, skipping.", $value);
2286                 return $c;
2287         }
2288
2289         # Get the global install files and remove them from the config list
2290         my @gfiles = glob("$fdir/*.global");
2291         my %seen;
2292         @seen{@gfiles} = @gfiles;
2293
2294         # Get the init files and remove them from the config list
2295         my @ifiles = glob("$fdir/*.init");
2296         @seen{@ifiles} = @ifiles;
2297
2298         # Get the uninstall files and remove them from the config list
2299         my @ufiles = glob("$fdir/*.uninstall");
2300         @seen{@ufiles} = @ifiles;
2301
2302         # Any other files are config files
2303         my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
2304
2305         # directories are for copying
2306         my @cdirs = grep -d $_, @cfiles;
2307
2308         # strip the directories from the config list, leaving catalog.cfg stuff
2309         @cfiles   = grep -f $_, @cfiles;
2310
2311         # Don't install global more than once
2312         @gfiles = grep ! $Global::FeatureSeen{$_}++, @gfiles;
2313
2314         # Place the catalog configuration in the config list
2315         unshift @include, @cfiles;
2316
2317         my @copy;
2318         my $wanted = sub {
2319                 return unless -f $_;
2320                 my $n = $File::Find::name;
2321                 $n =~ s{^$fdir/}{};
2322                 my $d = $File::Find::dir;
2323                 $d =~ s{^$fdir/}{};
2324                 push @copy, [$n, $d];
2325         };
2326
2327         if(@cdirs) {
2328                 File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
2329         }
2330 #::logDebug("gfiles=" . ::uneval(\@gfiles));
2331 #::logDebug("cfiles=" . ::uneval(\@cfiles));
2332 #::logDebug("ifiles=" . ::uneval(\@ifiles));
2333 #::logDebug("ufiles=" . ::uneval(\@ufiles));
2334 #::logDebug("cdirs=" . ::uneval(\@cdirs));
2335 #::logDebug("copy=" . ::uneval(\@copy));
2336
2337         for(@copy) {
2338                 my ($n, $d) = @$_;
2339
2340                 my $tf = Vend::File::catfile($C->{VendRoot}, $n);
2341                 next if -f $tf;
2342
2343                 my $td = Vend::File::catfile($C->{VendRoot}, $d);
2344                 unless(-d $td) {
2345                         File::Path::mkpath($td)
2346                                 or do {
2347                                         config_warn("Feature %s not able to make directory %s", $value, $td);
2348                                         next;
2349                                 };
2350                 }
2351                 File::Copy::copy("$fdir/$n", $tf)
2352                         or do {
2353                                 config_warn("Feature %s not able to copy %s to %s", $value, "$fdir/$n", $tf);
2354                                 next;
2355                         };
2356         }
2357
2358         for(@gfiles) {
2359                 global_chunk($_);
2360         }
2361
2362         if(@ifiles) {
2363                 my $initdir = Vend::File::catfile($C->{ConfDir}, 'init', $value);
2364                 File::Path::mkpath($initdir) unless -d $initdir;
2365                 my $unfile = Vend::File::catfile($initdir, 'uninstall');
2366
2367                 ## Feature was previously uninstalled, we *do* need to run init
2368                 my $ignore = -f $unfile;
2369
2370                 if($ignore) {
2371                         unlink $unfile
2372                                         or die errmsg("Couldn't unlink $unfile: $!");
2373                 }
2374
2375                 for(@ifiles) {
2376                         my $fn = $_;
2377                         $fn =~ s{^$fdir/}{};
2378                         if($ignore) {
2379                                 unlink "$initdir/$fn"
2380                                         or die errmsg("Couldn't unlink $fn: $!");
2381                         }
2382
2383                         next if -f "$initdir/$fn";
2384                         $C->{Init} ||= [];
2385                         push @{$C->{Init}}, [$_, "$initdir/$fn"];
2386                 }
2387         }
2388
2389 #::logDebug("Init=" . ::uneval($C->{Init}));
2390
2391         $c->{$value} = 1;
2392         return $c;
2393 }
2394
2395 sub uninstall_feature {
2396         my ($value) = @_;
2397         my $c = $Vend::Cfg
2398                 or die "Not in catalog context.\n";
2399
2400 #::logDebug("Running uninstall for cat=$Vend::Cat, from cfg ref=$c->{CatalogName}");
2401         $value =~ s/^\s+//;
2402         $value =~ s/\s+$//;
2403         my $fdir = Vend::File::catfile($Global::FeatureDir, $value);
2404
2405         unless(-d $fdir) {
2406                 config_warn("Feature '%s' not found, skipping.", $value);
2407                 return $c;
2408         }
2409
2410         my $etag = errmsg("feature %s uninstall -- ", $value);
2411
2412         # Get the global install files and remove them from the config list
2413         my @gfiles = glob("$fdir/*.global");
2414         my %seen;
2415         @seen{@gfiles} = @gfiles;
2416
2417         # Get the init files and remove them from the config list
2418         my @ifiles = glob("$fdir/*.init");
2419         @seen{@ifiles} = @ifiles;
2420
2421         # Get the uninstall files and remove them from the config list
2422         my @ufiles = glob("$fdir/*.uninstall");
2423         @seen{@ufiles} = @ifiles;
2424
2425         # Any other files are config files
2426         my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");
2427
2428         # directories are for copying
2429         my @cdirs = grep -d $_, @cfiles;
2430
2431         my $Tag = new Vend::Tags;
2432
2433         my @copy;
2434         my @errors;
2435         my @warnings;
2436
2437         my $wanted = sub {
2438                 return unless -f $_;
2439                 my $n = $File::Find::name;
2440                 $n =~ s{^$fdir/}{};
2441                 my $d = $File::Find::dir;
2442                 $d =~ s{^$fdir/}{};
2443                 push @copy, [$n, $d];
2444         };
2445
2446         if(@cdirs) {
2447                 File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
2448         }
2449 #::logDebug("ufiles=" . ::uneval(\@ufiles));
2450 #::logDebug("ifiles=" . ::uneval(\@ifiles));
2451 #::logDebug("cdirs=" . ::uneval(\@cdirs));
2452 #::logDebug("copy=" . ::uneval(\@copy));
2453
2454         for(@ufiles) {
2455 #::logDebug("Running uninstall file $_");
2456                 my $save = $Global::AllowGlobal->{$Vend::Cat};
2457                 $Global::AllowGlobal->{$Vend::Cat} = 1;
2458                 open UNFILE, "< $_"
2459                         or do {
2460                                 push @errors, $etag . errmsg("error reading %s: %s", $_, $!);
2461                         };
2462                 my $chunk = join "", <UNFILE>;
2463                 close UNFILE;
2464
2465 #::logDebug("uninstall chunk length=" . length($chunk));
2466
2467                 my $out;
2468                 eval {
2469                         $out = Vend::Interpolate::interpolate_html($chunk);
2470                 };
2471
2472                 if($@) {
2473                         push @errors, $etag . errmsg("error running uninstall %s: %s", $_, $@);
2474                 }
2475
2476                 push @warnings, $etag . errmsg("message from %s: %s", $_, $out)
2477                         if $out =~ /\S/;
2478
2479                 $Global::AllowGlobal->{$Vend::Cat} = $save;
2480         }
2481
2482         for(@copy) {
2483                 my ($n, $d) = @$_;
2484
2485                 my $tf = Vend::File::catfile($c->{VendRoot}, $n);
2486                 next unless -f $tf;
2487
2488                 my $contents1 = Vend::File::readfile($tf);
2489
2490                 my $sf = "$fdir/$n";
2491
2492                 open UNSRC, "< $sf"
2493                         or die $etag . errmsg("Couldn't read uninstall source file %s: %s", $sf, $!);
2494
2495                 local $/;
2496                 my $contents2 = <UNSRC>;
2497
2498                 if($contents1 ne $contents2) {
2499                         push @warnings, $etag . errmsg("will not uninstall %s, changed.", $tf);
2500                         next;
2501                 }
2502
2503                 unlink $tf
2504                         or do {
2505                                 push @errors,
2506                                         $etag . errmsg("$etag couldn't unlink file %s: %s", $tf, $!);
2507                                 next;
2508                         };
2509
2510                 my $td = Vend::File::catfile($c->{VendRoot}, $d);
2511                 my @left = glob("$td/*");
2512                 push @left, glob("$td/.?*");
2513                 next if @left;
2514                 File::Path::rmtree($td);
2515         }
2516
2517         if(@ifiles) {
2518 #::logDebug("running uninstall touch and init");
2519                 my $initdir = Vend::File::catfile($c->{ConfDir}, 'init', $value);
2520                 File::Path::mkpath($initdir) unless -d $initdir;
2521                 my $fn = Vend::File::catfile($initdir, 'uninstall');
2522 #::logDebug("touching uninstall file $fn");
2523                 open UNFILE, ">> $fn"
2524                         or die errmsg("Couldn't create uninstall flag file %s: %s", $fn, $!);
2525                 print UNFILE $etag . errmsg("uninstalled at %s.\n", scalar(localtime));
2526                 close UNFILE;
2527         }
2528
2529
2530         my $errors;
2531         for(@errors) {
2532                 $Tag->error({ set => $_});
2533                 ::logError($_);
2534                 $errors++;
2535         }
2536
2537         for(@warnings) {
2538                 $Tag->warnings($_);
2539                 ::logError($_);
2540         }
2541
2542         return ! $errors;
2543 }
2544
2545
2546 # Changes configuration directives into Variable settings, i.e.
2547 # DescriptionField becomes __DescriptionField__, ProductFiles becomes
2548 # __ProductFiles_0__, ProductFiles_1__, etc. Doesn't handle hash keys
2549 # that have non-word chars.
2550
2551 sub parse_autovar {
2552         my($var, $val) = @_;
2553
2554         return '' if ! $val;
2555
2556         my @dirs = grep /\w/, split /[\s,\0]+/, $val;
2557
2558         my $name;
2559         foreach $name (@dirs) {
2560                 next unless $name =~ /^\w+$/;
2561                 my $val = get_directive($name);
2562                 if(! ref $val) {
2563                         parse_variable('Variable', "$name $val");
2564                 }
2565                 elsif ($val =~ /ARRAY/) {
2566                         for(my $i = 0; $i < @$val; $i++) {
2567                                 my $an = "${name}_$i";
2568                                 parse_variable('Variable', "$an $val->[$i]");
2569                         }
2570                 }
2571                 elsif ($val =~ /HASH/) {
2572                         my ($k, $v);
2573                         while ( ($k, $v) = each %$val) {
2574                                 next unless $k =~ /^\w+$/;
2575                                 parse_variable('Variable', "$k $v");
2576                         }
2577                 }
2578                 else {
2579                         config_warn('%s directive not parsable by AutoVariable', $name);
2580                 }
2581         }
2582 }
2583
2584
2585 # Checks to see if a globalsub, sub, usertag, or Perl module is present
2586 # If called with a third parameter, is just "suggestion"
2587 # If called with a fourth parameter, is just capability check
2588
2589 sub parse_capability {
2590         return parse_require(@_, 1, 1);
2591 }
2592
2593 sub parse_tag_group {
2594         my ($var, $setting) = @_;
2595
2596         my $c;
2597         if(defined $C) {
2598                 $c = $C->{$var} || {};
2599         }
2600         else {
2601                 no strict 'refs';
2602                 $c = ${"Global::$var"} || {};
2603         }
2604         
2605         $setting =~ tr/-/_/;
2606         $setting =~ s/[,\s]+/ /g;
2607         $setting =~ s/^\s+//;
2608         $setting =~ s/\s+$//;
2609
2610         my @pairs = Text::ParseWords::shellwords($setting);
2611
2612         while(@pairs) {
2613                 my ($group, $sets) = splice @pairs, 0, 2;
2614                 my @sets = grep $_, split /\s+/, $sets;
2615                 my @groups = grep /:/, @sets;
2616                 @sets = grep $_ !~ /:/, @sets;
2617                 for(@groups) {
2618                         next unless $c->{$_};
2619                         push @sets, @{$c->{$_}};
2620                 }
2621                 $c->{$group} = \@sets;
2622         }
2623         return $c;
2624 }
2625
2626 my %incmap = qw/TagInclude TagGroup/;
2627 sub parse_tag_include {
2628         my ($var, $setting) = @_;
2629
2630         my $c;
2631         my $g;
2632
2633         my $mapper = $incmap{$var} || 'TagGroup';
2634         if(defined $C) {
2635                 $c = $C->{$var} || {};
2636                 $g = $C->{$mapper} || {};
2637         }
2638         else {
2639                 no strict 'refs';
2640                 $c = ${"Global::$var"} || {};
2641                 $g = ${"Global::$mapper"} || {};
2642         }
2643         
2644         $setting =~ s/"/ /g;
2645         $setting =~ s/^\s+//;
2646         $setting =~ s/\s+$//;
2647         $setting =~ s/[,\s]+/ /g;
2648
2649         if($setting eq 'ALL') {
2650                 return { ALL => 1 };
2651         }
2652
2653         delete $c->{ALL};
2654
2655         get_system_groups() unless $SystemGroupsDone;
2656
2657         my @incs = Text::ParseWords::shellwords($setting);
2658
2659         for(@incs) {
2660                 my @things;
2661                 my $not = 0;
2662                 if(/:/) {
2663                         $not = 1 if s/^!//;
2664                         if(! $g->{$_}) {
2665                                 config_warn(
2666                                         "unknown %s %s included from %s",
2667                                         $mapper,
2668                                         $_,
2669                                         $var,
2670                                 );
2671                         }
2672                         else {
2673                                 @things = @{$g->{$_}}
2674                         }
2675                 }
2676                 else {
2677                         @things = ($_);
2678                 }
2679                 for(@things) {
2680                         my $not = s/^!// ? ! $not : $not;
2681                         $c->{$_} = not $not;
2682                 }
2683         }
2684         return $c;
2685 }
2686
2687 sub parse_suggest {
2688         return parse_require(@_, 1);
2689 }
2690
2691 sub parse_require {
2692         my($var, $val, $warn, $cap) = @_;
2693
2694         return if $Vend::ExternalProgram;
2695         return if $Vend::ControllingInterchange;
2696
2697         my $carptype;
2698         my $error_message;
2699         my $pathinfo;
2700
2701         if($val =~ s/\s+"(.*)"//s) {
2702                 $error_message = "\a\n\n$1\n";
2703         }
2704
2705         if($val =~ s%\s+((/[\w.-]+)+)%%) {
2706                 $pathinfo = $1;
2707         }
2708         
2709         if($cap) {
2710                 $carptype = sub { return; };
2711         }
2712         elsif($warn) {
2713                 $carptype = sub { return parse_message('', @_) };
2714                 $error_message = "\a\n\nSuggest %s %s for proper catalog operation. Not all functions will work!\n"
2715                         unless $error_message;
2716         }
2717         else {
2718                 $carptype = \&config_error;
2719                 $error_message ||= 'Required %s %s not present. Aborting '
2720                         . ($C ? 'catalog' : 'Interchange daemon') . '.';
2721         }
2722
2723         my $nostrict;
2724         my $perlglobal = 1;
2725
2726         if($C) {
2727                 $nostrict = $Global::PerlNoStrict->{$C->{CatalogName}};
2728                 $perlglobal = $Global::AllowGlobal->{$C->{CatalogName}};
2729         }
2730
2731         my $vref = $C ? $C->{Variable} : $Global::Variable;
2732         my $require;
2733         my $testsub = sub { 0 };
2734         my $name;
2735         if($val =~ s/^globalsub\s+//i) {
2736                 $require = $Global::GlobalSub;
2737                 $name = 'GlobalSub';
2738         }
2739         elsif($val =~ s/^sub\s+//i) {
2740                 $require = $C->{Sub};
2741                 $name = 'Sub';
2742         }
2743         elsif($val =~ s/^taggroup\s+//i) {
2744                 $require = $Global::UserTag->{Routine};
2745                 my @groups = grep /\S/, split /[\s,]+/, $val;
2746                 my @needed;
2747                 my $ref;
2748                 for (@groups) {
2749                         if($ref = $Global::TagGroup->{$_}) {
2750                                 push @needed, @$ref;
2751                         }
2752                         else {
2753                                 push @needed, $_;
2754                         }
2755                 }
2756                 $name = "TagGroup $val member";
2757                 $val = join " ", @needed;
2758         }
2759         elsif($val =~ s/^usertag\s+//i) {
2760                 $require = {};
2761                 $name = 'UserTag';
2762
2763                 $testsub = sub {
2764                         my $name = shift;
2765
2766                         my @tries = ($Global::UserTag->{Routine});
2767                         push(@tries,$C->{UserTag}->{Routine}) if $C;
2768
2769                         foreach (@tries) {
2770                                 return 1 if defined $_->{$name};
2771                         }
2772                         return 0;
2773                 };
2774         }
2775         elsif($val =~ s/^(?:perl)?module\s+//i) {
2776                 $require = {};
2777                 $name = 'Perl module';
2778                 $testsub = sub {
2779                         my $module = shift;
2780                         my $oldtype = '';
2781                         if($module =~ s/\.pl$//) {
2782                                 $oldtype = '.pl';
2783                         }
2784                         $module =~ /[^\w:]/ and return undef;
2785                         if($perlglobal) {
2786                                 if ($pathinfo) {
2787                                         unshift(@INC, $pathinfo);
2788                                         unshift(@INC, "$pathinfo/$Config{archname}");
2789                                 }
2790                                 eval "require $module$oldtype;";
2791                                 my $error = $@;
2792                                 if ($pathinfo) {
2793                                         shift(@INC);
2794                                         shift(@INC);
2795                                 }
2796                                 ::logGlobal("while eval'ing module %s got [%s]\n", $module, $error) if $error;
2797                                 return ! $error;
2798                         }
2799                         else {
2800                                 # Since we aren't safe to actually require, we will 
2801                                 # just look for a readable module file
2802                                 $module =~ s!::!/!g;
2803                                 $oldtype = '.pm' if ! $oldtype;
2804                                 my $found;
2805                                 for(@INC) {
2806                                         next unless -f "$_/$module$oldtype" and -r _;
2807                                         $found = 1;
2808                                 }
2809                                 return $found;
2810                         }
2811                 };
2812         }
2813         elsif ($val =~ s/^(?:perl)?include\s+//i) {
2814                 my $path = Vend::File::make_absolute_file($val, 1);
2815                 $require = {};
2816                 $name = 'Perl include path';
2817                 $testsub =
2818                         sub {
2819                                 if (-d $path) {
2820                                         unshift @INC, $path;
2821                                         return 1;
2822                                 }
2823                                 return 0;
2824                         };
2825         }
2826         elsif ($val =~ s/^file\s*//i) {
2827                 $require = {};
2828                 $name = 'Readable file';
2829                 $val = $pathinfo unless $val;
2830
2831                 $testsub = sub {
2832                         my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
2833                         if ($C && $path =~ s:^/+::) {
2834                                 $path = "$C->{VendRoot}/$path";
2835                         }
2836                         return -r $path;
2837                 };
2838         }
2839         elsif ($val =~ s/^executable\s*//i) {
2840                 $require = {};
2841                 $name = 'Executable file';
2842                 $val = $pathinfo unless $val;
2843
2844                 $testsub = sub {
2845                         my $path = Vend::File::make_absolute_file(shift, $C ? 0 : 1);
2846                         if ($C && $path =~ s:^/+::) {
2847                                 $path = "$C->{VendRoot}/$path";
2848                         }
2849                         return -x $path;
2850                 };
2851         }
2852         my @requires = grep /\S/, split /\s+/, $val;
2853
2854         my $uname = uc $name;
2855         $uname =~ s/.*\s+//;
2856         for(@requires) {
2857                 $vref->{"MV_REQUIRE_${uname}_$_"} = 1;
2858                 next if defined $require->{$_};
2859                 next if $testsub->($_);
2860                 delete $vref->{"MV_REQUIRE_${uname}_$_"};
2861                 $carptype->( $error_message, $name, $_ );
2862         }
2863         return '';      
2864 }
2865
2866 # Sets the special variable remap array
2867 #
2868
2869 my $Varnames;
2870 INITVARS: {
2871         local($/);
2872         $Varnames = <DATA>;
2873 }
2874
2875 sub parse_varname {
2876         my($item,$settings) = @_;
2877
2878         return if $Vend::ExternalProgram;
2879
2880         my($iv,$vn,$k,$v,@set);
2881 #logDebug("parse_varname: $settings");
2882         if(defined $C) {
2883                 return '' if ! $settings;
2884                 $C->{IV} = { %{$Global::IV} } if ! $C->{IV};
2885                 $C->{VN} = { %{$Global::VN} } if ! $C->{VN};
2886                 $iv = $C->{IV};
2887                 $vn = $C->{VN};
2888         }
2889         else {
2890                 if (! $Global::VarName) {
2891                         unless (-s "$Global::ConfDir/varnames" && -r _) {
2892                                 $settings = $Varnames . "\n$settings";
2893                                 writefile("$Global::ConfDir/varnames", $Varnames);
2894                         }
2895                         else {
2896                                 $settings = readfile("$Global::ConfDir/varnames");
2897                         }
2898                 }
2899                 undef $Varnames;
2900                 $Global::IV = {} if ! $Global::IV;
2901                 $Global::VN = {} if ! $Global::VN;
2902                 $iv = $Global::IV;
2903                 $vn = $Global::VN;
2904         }
2905
2906         @set = grep /\S/, split /\s+/, $settings;
2907         while( $k = shift @set, $v = shift @set ) {
2908                 $vn->{$k} = $v;
2909                 $iv->{$v} = $k;
2910         }
2911         return 1;
2912 }
2913
2914 sub parse_word {
2915         my($name, $val) = @_;
2916
2917         return '' unless $val;
2918         unless ($val =~ /^\w+$/) {
2919                 config_error("Illegal non-word value in '%s' for %s", $val, $name);
2920         }
2921         return $val;
2922 }
2923
2924 # Allow addition of a new catalog directive
2925 sub parse_directive {
2926         my($name, $val) = @_;
2927
2928         return '' unless $val;
2929         my($dir, $parser, $default) = split /\s+/, $val, 3 ;
2930         if(! defined &{"parse_$parser"} and ! defined &{"$parser"}) {
2931                 if (defined $Global::GlobalSub->{"parse_$parser"}) {
2932                         no strict 'refs';
2933                         *{"Vend::Config::parse_$parser"} = $Global::GlobalSub->{"parse_$parser"};
2934                 } else {
2935                         $parser = undef;
2936                 }
2937         }
2938         $default = '' if ! $default or $default eq 'undef';
2939         $Global::AddDirective = [] unless $Global::AddDirective;
2940         push @$Global::AddDirective, [ $dir, $parser, $default ];
2941         return $Global::AddDirective;
2942 }
2943
2944 # Allow a subcatalog value to completely replace a base value
2945 sub parse_replace {
2946         my($name, $val) = @_;
2947
2948         return {} unless $val;
2949
2950         $C->{$val} = get_catalog_default($val);
2951         $C->{$name}->{$val} = 1;
2952         $C->{$name};
2953 }
2954
2955
2956 # Send a message during configuration, goes to terminal if during
2957 # daemon startup, always goes to error log
2958 sub parse_message {
2959         my($name, $val) = @_;
2960
2961         return '' unless $val;
2962
2963         return 1 if $Vend::Quiet;
2964
2965         my $strip;
2966         my $info_only;
2967         ## strip trailing whitespace if -n beins message
2968         while($val =~ s/^-([ni])\s+//) {
2969                 $1 eq 'n' and $val =~ s/^-n\s+// and $strip = 1 and $val =~ s/\s+$//;
2970                 $info_only = 1 if $1 eq 'i';
2971         }
2972
2973         my $msg = errmsg($val,
2974                                                 $name,
2975                                                 $.,
2976                                                 $configfile,
2977                                 );
2978
2979         if($info_only and $Global::Foreground) {
2980                 print $msg;
2981         }
2982         else {
2983                 logGlobal({level => 'info', strip => $strip },
2984                                 errmsg($val,
2985                                                 $name,
2986                                                 $.,
2987                                                 $configfile,
2988                                 )
2989                 );
2990         }
2991 }
2992
2993
2994 # Warn about directives no longer supported in the configuration file.
2995 sub parse_warn {
2996         my($name, $val) = @_;
2997
2998         return '' unless $val;
2999
3000         ::logGlobal({level => 'info'},
3001                                 errmsg("Directive %s no longer supported at line %s of %s.",
3002                                                 $name,
3003                                                 $.,
3004                                                 $configfile,
3005                                 )
3006         );
3007 }
3008
3009 # Each of the parse functions accepts the value of a directive from the
3010 # configuration file as a string and either returns the parsed value or
3011 # signals a syntax error.
3012
3013 # Sets a boolean array for any type of item
3014 sub parse_boolean {
3015         my($item,$settings) = @_;
3016         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3017         my $c;
3018
3019         if(defined $C) {
3020                 $c = $C->{$item} || {};
3021         }
3022         else {
3023                 no strict 'refs';
3024                 $c = ${"Global::$item"} || {};
3025         }
3026
3027         for (@setting) {
3028                 $c->{$_} = 1;
3029         }
3030         return $c;
3031 }
3032
3033 # Sets a boolean array, but configurable value with tag=value
3034 sub parse_boolean_value {
3035         my($item,$settings) = @_;
3036         my(@setting) = split /[\s,]+/, $settings;
3037         my $c;
3038
3039         if(defined $C) {
3040                 $c = $C->{$item} || {};
3041         }
3042         else {
3043                 no strict 'refs';
3044                 $c = ${"Global::$item"} || {};
3045         }
3046
3047         for (@setting) {
3048                 my ($k,$v);
3049                 if(/=/) {
3050                         ($k,$v) = split /=/, $_, 2;
3051                 }
3052                 else {
3053                         $k = $_;
3054                         $v = 1;
3055                 }
3056                 $c->{$k} = $v;
3057         }
3058         return $c;
3059 }
3060
3061 use POSIX qw(
3062                                 setlocale localeconv
3063                                 LC_ALL          LC_CTYPE        LC_COLLATE
3064                                 LC_MONETARY     LC_NUMERIC      LC_TIME
3065                         );
3066
3067 # Sets the special locale array. Tries to use POSIX setlocale,
3068 # accepts a 'custom' setting with the proper definitions of
3069 # decimal_point,  mon_thousands_sep, and frac_digits (the only supported at
3070 # the moment).  Otherwise uses US-English settings if not set.
3071 #
3072 sub parse_locale {
3073         my($item,$settings) = @_;
3074         return ($settings || '') unless $settings =~ /[^\d.]/;
3075         $settings = '' if "\L$settings" eq 'default';
3076         my $name;
3077         my ($c, $store);
3078         if(defined $C) {
3079                 $c = $C->{$item} || { };
3080                 $C->{$item . "_repository"} = {}
3081                         unless $C->{$item . "_repository"};
3082                 $store = $C->{$item . "_repository"};
3083         }
3084         else {
3085                 no strict 'refs';
3086                 $c = ${"Global::$item"} || {};
3087                 ${"Global::$item" . "_repository"} = {}
3088                         unless ${"Global::$item" . "_repository"};
3089                 $store = ${"Global::$item" . "_repository"};
3090         }
3091
3092         my ($eval, $safe);
3093         if ($settings =~ s/^\s*([-\w.@]+)(?:\s+)?//) {
3094                 $name = $1;
3095
3096                 undef $eval;
3097                 $settings =~ /^\s*{/
3098                         and $settings =~ /}\s*$/
3099                                 and $eval = 1;
3100                 $eval and ! $safe and $safe = new Vend::Safe;
3101                 if(! defined $store->{$name} and $item eq 'Locale') {
3102                     my $past = POSIX::setlocale(POSIX::LC_ALL);
3103                         if(POSIX::setlocale(POSIX::LC_ALL, $name) ) {
3104                                 $store->{$name} = POSIX::localeconv();
3105                         }
3106                         POSIX::setlocale(POSIX::LC_ALL, $past);
3107                 }
3108
3109                 my($sethash);
3110                 if ($eval) {
3111                         $sethash = $safe->reval($settings)
3112                                 or config_warn("bad Locale setting in %s: %s", $name, $@),
3113                                                 $sethash = {};
3114                 }
3115                 else {
3116                         $settings =~ s/^\s+//;
3117                         $settings =~ s/\s+$//;
3118                         $sethash = {};
3119                         %{$sethash} = Text::ParseWords::shellwords($settings);
3120                 }
3121                 $c = $store->{$name} || {};
3122                 my $nodefaults = delete $sethash->{MV_LOCALE_NO_DEFAULTS};
3123                 for (keys %{$sethash}) {
3124                         $c->{$_} = $sethash->{$_};
3125                 }
3126         }
3127         else {
3128                 config_error("Bad locale setting $settings.\n");
3129         }
3130
3131         $C->{LastLocale} = $name if $C and $item eq 'Locale';
3132
3133         $store->{$name} = $c unless $store->{$name};
3134
3135         return $c;
3136 }
3137
3138 #
3139 # Sets a structure like Locale but with the depth and access via key
3140 # No evaled structure setting, only key-value with shell quoting
3141
3142 sub parse_structure {
3143         my ($item, $settings) = @_;
3144         return {} unless $settings;
3145         my $key;
3146         my @rest;
3147         ($key, @rest) = Text::ParseWords::shellwords($settings);
3148         my ($c, $e);
3149         if(defined $C) {
3150                 $c = $C->{$item};
3151                 $e = $c->{$key} || { };
3152         }
3153         else {
3154                 no strict 'refs';
3155                 $c = ${"Global::$item"};
3156                 $e = $c->{$key} || {};
3157         }
3158
3159         while(scalar @rest) {
3160                 my $k = shift @rest;
3161                 $e->{$k} = shift @rest;
3162         }
3163         $c->{$key} = $e;
3164         return $c;
3165 }
3166
3167
3168 # Sets the special page array
3169 sub parse_special {
3170         my($item,$settings) = @_;
3171         return {} unless $settings;
3172         my(%setting) = grep /\S/, split /[\s,]+/, $settings;
3173         for (keys %setting) {
3174                 if($Global::NoAbsolute and file_name_is_absolute($setting{$_}) ) {
3175                         config_warn("Absolute file name not allowed: %s", $setting{$_});
3176                         next;
3177                 }
3178                 $C->{$item}{$_} = $setting{$_};
3179         }
3180         return $C->{$item};
3181 }
3182
3183 # Sets up a hash value from a configuration directive, syntax is
3184
3185 #   Directive  "key" "value"
3186
3187 # quotes are optional if word-only chars
3188
3189 sub parse_hash {
3190         my($item,$settings) = @_;
3191         if (! $settings) {
3192                 return $HashDefaultBlank{$item} ? '' : {};
3193         }
3194
3195         my $c;
3196
3197         if(defined $C) {
3198                 $c = $C->{$item} || {};
3199         }
3200         else {
3201                 no strict 'refs';
3202                 $c = ${"Global::$item"} || {};
3203         }
3204
3205         return hash_string($settings,$c);
3206 }
3207
3208 # Set up illegal values for certain directives
3209 my %IllegalValue = (
3210
3211                 AutoModifier => { qw/   mv_mi 1
3212                                                                 mv_si 1
3213                                                                 mv_ib 1
3214                                                                 group 1
3215                                                                 code  1
3216                                                                 sku   1
3217                                                                 quantity 1
3218                                                                 item  1     /
3219                                                 },
3220                 UseModifier => { qw/   mv_mi 1
3221                                                                 mv_si 1
3222                                                                 mv_ib 1
3223                                                                 group 1
3224                                                                 code  1
3225                                                                 sku   1
3226                                                                 quantity 1
3227                                                                 item  1     /
3228                                                 }
3229 );
3230
3231 my @Dispatches;
3232 my @Cleanups;
3233
3234 %Cleanup_priority = (
3235         AutoEnd => 1,
3236 );
3237
3238 %Dispatch_priority = (
3239         CookieLogin => 1,
3240         Locale => 2,
3241         DiscountSpaces => 5,
3242         Autoload => 8,
3243 );
3244
3245 %Cleanup_code = (
3246         AutoEnd => sub {
3247 #::logDebug("Doing AutoEnd dispatch...");
3248                 Vend::Dispatch::run_macro($Vend::Cfg->{AutoEnd});
3249         },
3250 );
3251
3252 %Dispatch_code = (
3253
3254         Autoload => sub {
3255 #::logDebug("Doing Autoload dispatch...");
3256                 my ($subname, $inspect_sub);
3257
3258                 if ($subname = $Vend::Cfg->{SpecialSub}{autoload_inspect}) {
3259                         $inspect_sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
3260                 }
3261                 
3262                 Vend::Dispatch::run_macro($Vend::Cfg->{Autoload}, undef, $inspect_sub);
3263         },
3264
3265         CookieLogin => sub {
3266 #::logDebug("Doing CookieLogin dispatch....");
3267                 if(! $Vend::Session->{logged_in}) {
3268                         COOKIELOGIN: {
3269                                 # Clear password cookie and don't allow automatic login
3270                                 # if mv_force_session is overriding the session cookie,
3271                                 # since user may be coming from a sister site where he
3272                                 # was logged out.
3273                                 (Vend::Util::read_cookie('MV_PASSWORD')
3274                                         and Vend::Util::set_cookie('MV_PASSWORD')), last COOKIELOGIN
3275                                                 if $CGI::values{mv_force_session};
3276                                 my $username;
3277                                 my $password;
3278                                 last COOKIELOGIN
3279                                         if  exists  $CGI::values{mv_username}
3280                                         and defined $CGI::values{mv_username};
3281                                 last COOKIELOGIN
3282                                         unless $username = Vend::Util::read_cookie('MV_USERNAME');
3283                                 last COOKIELOGIN
3284                                         unless $password = Vend::Util::read_cookie('MV_PASSWORD');
3285                                 $CGI::values{mv_username} = $username;
3286                                 $CGI::values{mv_password} = $password;
3287                                 my $profile = Vend::Util::read_cookie('MV_USERPROFILE');
3288                                 local(%SIG);
3289                                 undef $SIG{__DIE__};
3290                                 eval {
3291                                         Vend::UserDB::userdb('login', profile => $profile );
3292                                 };
3293                                 if($@) {
3294                                         $Vend::Session->{failure} .= $@;
3295                                 }
3296                         }
3297                 }
3298         },
3299
3300     Locale => sub {
3301 #::logDebug("Doing Locale dispatch...");
3302         my $locale = $::Scratch->{mv_locale};
3303         my $curr = $::Scratch->{mv_currency};
3304         $locale || $curr    or return;
3305
3306         if($locale and ! $::Scratch->{mv_language}) {
3307             $Global::Variable->{LANG}
3308                     = $::Variable->{LANG}
3309                     = $::Scratch->{mv_language}
3310                     = $locale;
3311         }
3312
3313         if($locale) {
3314             return unless defined $Vend::Cfg->{Locale_repository}{$locale};
3315         }
3316         elsif($curr) {
3317             return unless defined $Vend::Cfg->{Locale_repository}{$curr};
3318         }
3319 #::logDebug("running locale dispatch, locale=$locale, currency=$curr");
3320
3321         Vend::Util::setlocale( $locale, $curr, { persist => 1 } );
3322     },
3323
3324         DiscountSpaces => sub {
3325 #::logDebug("Doing DiscountSpaces dispatch...");
3326                 $::Discounts
3327                         = $Vend::Session->{discount}
3328                         = $Vend::Session->{discount_space}{
3329                                         $Vend::DiscountSpaceName = 'main'
3330                                 }
3331                         ||= {};
3332                 my $dspace;
3333                 for (@{$Vend::Cfg->{DiscountSpaceVar}}) {
3334                         next unless $dspace = $CGI::values{$_};
3335 #::logDebug("$_ is set=...");
3336                         last;
3337                 }
3338                 return unless $dspace;
3339                 $Vend::DiscountSpaceName = $dspace;
3340 #::logDebug("Discount space is set=$Vend::DiscountSpaceName...");
3341                 $::Discounts
3342                                 = $Vend::Session->{discount}
3343                                 = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName}
3344                                 ||= {};
3345     },
3346
3347 );
3348
3349 # Set up defaults for certain directives
3350 my $Have_set_global_defaults;
3351
3352 # Set the default search files based on ProductFiles setting
3353 # Honor a NO_SEARCH parameter in the Database structure
3354 # Set MV_DEFAULT_SEARCH_FILE to the {file} entry,
3355 # and set MV_DEFAULT_SEARCH_TABLE to the table name.
3356 #
3357 # Error out if not SubCatalog and can't find a setting.
3358 #
3359 sub set_default_search {
3360         my $setting = $C->{ProductFiles};
3361
3362         if(! $setting) {
3363                 return 1 if $C->{BaseCatalog};
3364                 return (undef, errmsg("No ProductFiles setting!") );
3365         }
3366         
3367         my @fout;
3368         my @tout;
3369         my $nofile;
3370         my $notable;
3371
3372         if ($C->{Variable}{MV_DEFAULT_SEARCH_FILE}) {
3373                 @fout =
3374                         grep /\S/,
3375                         split /[\s,]+/,
3376                         $C->{Variable}{MV_DEFAULT_SEARCH_FILE};
3377                 $nofile = 1;
3378                 for(@fout) {
3379                         next if /\./;
3380                         next unless exists $C->{Database}{$_};
3381                         $_ = $C->{Database}{$_}{file};
3382                 }
3383         }
3384         if ($C->{Variable}{MV_DEFAULT_SEARCH_TABLE}) {
3385                 @tout =
3386                         grep defined $C->{Database}{$_},
3387                                 split /[\s,]+/,
3388                                 $C->{Variable}{MV_DEFAULT_SEARCH_TABLE}
3389                 ;
3390                 $notable = 1;
3391         }
3392
3393         for(@$setting) {
3394                 next if $C->{Database}{$_}{NO_SEARCH};
3395                 push @tout, $_ unless $notable;
3396                 next unless defined $C->{Database}{$_}{file};
3397                 push @fout, $C->{Database}{$_}{file}
3398                         unless $nofile;
3399         }
3400         unless (scalar @fout) {
3401                 return 1 if $C->{BaseCatalog};
3402                 return (undef, errmsg("No default search file!") );
3403         }
3404         $C->{Variable}{MV_DEFAULT_SEARCH_FILE}  = \@fout;
3405         $C->{Variable}{MV_DEFAULT_SEARCH_TABLE} = \@tout;
3406         return 1;
3407 }
3408
3409 %Default = (
3410                 ## This rather extensive default setting is not typical for IC,
3411                 ## but performance in pricing routines demands it
3412                 Options => sub {
3413                         my $o = $C->{Options_repository} ||= {};
3414                         my $var = $C->{Variable};
3415
3416                         my @base = qw/Simple Matrix Old48/;
3417                         my %base;
3418                         @base{@base} = @base;
3419
3420                         my %seen;
3421                         my @types = grep !$seen{$_}++, keys %$o, @base;
3422
3423                         for(@types) {
3424                                 my $loc = $o->{$_} ||= {};
3425                                 eval "require Vend::Options::$_;";
3426                                 if($@) {
3427                                         my $msg = $@;
3428                                         config_warn(
3429                                                 "Unable to use options type %s, no module. Error: %s",
3430                                                 $_,
3431                                                 $msg,
3432                                         );
3433                                         undef $o->{$_};
3434                                         next;
3435                                 }
3436                                 eval {
3437                                         my $name = "Vend::Options::${_}::Default";
3438                                         no strict;
3439                                         while(my ($k,$v) = each %{"$name"}) {
3440                                                 next unless $k;
3441                                                 next if exists $loc->{$k};
3442                                                 $loc->{$k} = $v;
3443                                         }
3444                                 };
3445                                 $loc->{map} = {};
3446                                 if($loc->{remap} ||= $C->{Variable}{MV_OPTION_TABLE_MAP}) {
3447                                         $loc->{remap} =~ s/^\s+//;
3448                                         $loc->{remap} =~ s/\s+$//;
3449                                         my @points = split /[\0,\s]+/, $loc->{remap};
3450                                         map { m{(.*?)=(.*)} and $loc->{map}{$1} = $2} @points;
3451                                 }
3452                         }
3453                         $C->{Options} = $o->{default} || $o->{Simple};
3454                 },
3455                 Shipping => sub {
3456                         my $o = $C->{Shipping_repository} ||= {};
3457
3458                         my @base = qw/Postal/;
3459                         my %base;
3460                         @base{@base} = @base;
3461
3462                         my %seen;
3463                         my @types = grep !$seen{$_}++, keys %$o, @base;
3464
3465                         my %module_ignore = qw/resolution 1 default 1/;
3466
3467                         for(@types) {
3468                                 next if $module_ignore{$_};
3469                                 my $loc = $o->{$_} ||= {};
3470                                 eval "require Vend::Ship::$_;";
3471                                 if($@) {
3472                                         my $msg = $@;
3473                                         config_warn(
3474                                                 "Unable to use options type %s, no module. Error: %s",
3475                                                 $_,
3476                                                 $msg,
3477                                         );
3478                                         undef $o->{$_};
3479                                         next;
3480                                 }
3481                                 eval {
3482                                         my $name = "Vend::Ship::${_}::Default";
3483                                         no strict;
3484                                         while(my ($k,$v) = each %{"$name"}) {
3485                                                 next unless $k;
3486                                                 next if exists $loc->{$k};
3487                                                 $loc->{$k} = $v;
3488                                         }
3489                                 };
3490                         }
3491                         $C->{Shipping} = $o->{default} || $o->{Postal};
3492                 },
3493                 UserDB => sub {
3494                                         my $set = $C->{UserDB_repository};
3495                                         for(keys %$set) {
3496                                                 if( defined $set->{$_}{admin} ) {
3497                                                         $C->{AdminUserDB} = {} unless $C->{AdminUserDB};
3498                                                         $C->{AdminUserDB}{$_} = $set->{$_}{admin};
3499                                                 }
3500                                                 if($set->{$_}{encsub} =~ /sha1/i and ! $Vend::Util::SHA1) {
3501                                                         return(undef, "Unable to use SHA1 encryption for UserDB, no Digest::SHA or Digest::SHA1 module.");
3502                                                 }
3503                                         }
3504                                         return 1;
3505                                 },
3506                 UserControl => sub {
3507                                         return 1 unless shift;
3508                                         require Vend::UserControl;
3509                                         return 1;
3510                                 },
3511                 AutoModifier => sub {
3512                                         my $auto = shift;
3513                                         if($C->{OptionsEnable}) {
3514                                                 $auto = $C->{AutoModifier} = []
3515                                                         if ! $auto;
3516                                                 push @$auto, $C->{OptionsEnable};
3517                                         }
3518                                         return 1;
3519                                 },
3520                 OptionsEnable => sub {
3521                                         my $enable = shift
3522                                                 or return 1;
3523                                         return 1 if $C->{OptionsAttribute};
3524                                         $enable =~ s,.*:,,;
3525                                         $C->{OptionsAttribute} = $enable;
3526                                         return 1;
3527                                 },
3528                 Glimpse => sub {
3529                                         return 1 unless shift;
3530                                         require Vend::Glimpse;
3531                                         return 1;
3532                                 },
3533                 SOAP_Socket => sub {
3534                                         return 1 if $Have_set_global_defaults;
3535                                         $Global::SOAP_Socket = ['7780']
3536                                                 if $Global::SOAP and ! $Global::SOAP_Socket;
3537                                         return 1;
3538                                 },
3539                 TcpMap => sub {
3540                                         return 1 if defined $Have_set_global_defaults;
3541                                         my (@sets) = keys %{$Global::TcpMap};
3542                                         if(scalar @sets == 1 and $sets[0] eq '-') {
3543                                                 $Global::TcpMap = {};
3544                                         }
3545                                         return 1 if @sets;
3546                                         $Global::TcpMap->{7786} = '-';
3547                                         return 1;
3548                                 },
3549                 Database => sub {
3550                         my @del;
3551                         for ( keys %{$C->{Database}}) {
3552                                 push @del, $_ unless defined $C->{Database}{$_}{type};
3553                         }
3554                         for(@del) {
3555 #::logDebug("deleted non-existent db $_");
3556                                 delete $C->{Database}{$_};
3557                         }
3558                         return 1;
3559                 },
3560                 Locale => sub {
3561                                                 my $repos = $C->{Locale_repository}
3562                                                         or return 1;
3563                                                 if ($C->{DefaultLocale}) {
3564                                                         my $def = $C->{DefaultLocale};
3565                                                         if (exists($repos->{$def})) {
3566                                                                 $C->{Locale} = $repos->{$def};
3567                                                         }
3568                                                         else {
3569                                                                 return (0, errmsg('Default locale %s missing', $def));
3570                                                         }
3571                                                 }
3572                                                 else {
3573                                                         for(keys %$repos) {
3574                                                                 if($repos->{$_}{default}) {
3575                                                                         $C->{Locale} = $repos->{$_};
3576                                                                         $C->{DefaultLocale} = $_;
3577                                                                 }
3578                                                         }
3579                                                         if(! $C->{DefaultLocale} and $C->{LastLocale}) {
3580                                                                 $C->{DefaultLocale} = $C->{LastLocale};
3581                                                                 $C->{Locale} = $repos->{$C->{LastLocale}};
3582                                                         }
3583                                                 }
3584
3585                                                 # create currency repositories
3586                                                 for my $locale (keys %{$C->{Locale_repository}}) {
3587                                                         for my $key (@Locale_keys_currency) {
3588                                                                 if ($C->{Locale_repository}->{$locale}->{$key}) {
3589                                                                         $C->{Currency_repository}->{$locale}->{$key}
3590                                                                                 = $C->{Locale_repository}->{$locale}->{$key};
3591                                                                 }
3592                                                         }
3593                                                 }
3594                                                 
3595                                                 push @Dispatches, 'Locale';
3596                                                 return 1;
3597                                         },
3598
3599                 DiscountSpacesOn => sub {
3600                                         return 1 unless $C->{DiscountSpacesOn};
3601                                         push @Dispatches, 'DiscountSpaces';
3602                                         return 1;
3603                 },
3604                 QueryCache => sub { 
3605                                         my $qc; 
3606                                         return 1 unless $qc = $C->{QueryCache}; 
3607                                         $qc->{table} ||= 'qc'; 
3608                                         $qc->{intro} ||= 'qc'; 
3609                                         $qc->{default_expire} ||= '30min'; 
3610                                         $qc->{default_public_expire} ||= '48hours'; 
3611                                         $qc->{default_return} ||= '{}'; 
3612                                         return 1; 
3613                 },
3614                 CookieLogin => sub {
3615                                         return 1 unless $C->{CookieLogin};
3616                                         push @Dispatches, 'CookieLogin';
3617                                         return 1;
3618                 },
3619                 ProductFiles => \&set_default_search,
3620                 VendRoot => sub {
3621                         my $cat_template_dirs = $C->{TemplateDir} || [];
3622                         if ($Global::NoAbsolute) {
3623                                 for (@$cat_template_dirs) {
3624                                         if (absolute_or_relative($_) and ! /^$C->{VendRoot}/) {
3625                                                 config_error("TemplateDir path %s is prohibited by NoAbsolute", $_);
3626                                         }
3627                                 }
3628                         }
3629                         my @paths = map { quotemeta $_ }
3630                                                         $C->{VendRoot},
3631                                                         @$cat_template_dirs,
3632                                                         @{$Global::TemplateDir || []};
3633                         my $re = join "|", @paths;
3634                         $Global::AllowedFileRegex->{$C->{CatalogName}} = qr{^($re)};
3635                         return 1;
3636                 },
3637                 Autoload => sub {
3638                         return 1 unless $C->{Autoload};
3639                         push @Dispatches, 'Autoload';
3640                         return 1;
3641                 },
3642                 AutoEnd => sub {
3643                         return 1 unless $C->{AutoEnd};
3644                         push @Cleanups, 'AutoEnd';
3645                         return 1;
3646                 },
3647                 External => sub {
3648                         return 1 unless $C->{External};
3649                         unless($Global::External) {
3650                                 config_warn("External directive set to Yes, but not allowed by Interchange configuration.");
3651                                 return 1;
3652                         }
3653                         return 1 unless $C->{External};
3654                         unless($Global::ExternalStructure) {
3655                                 $Global::ExternalStructure = external_global($Global::ExternalExport);
3656                         }
3657                         $C->{ExternalExport} = external_cat($C->{ExternalExport});
3658                         $Global::ExternalStructure->{Catalogs}{ $C->{CatalogName} }{external_config}
3659                                 = $C->{ExternalExport};
3660                         Vend::Util::uneval_file($Global::ExternalStructure, $Global::ExternalFile);
3661                         chmod 0644, $Global::ExternalFile;
3662                 },
3663 );
3664
3665 sub global_directive_postprocess {
3666         if ($Global::UrlSepChar eq '&') {
3667                 if ($Global::Variable->{MV_HTML4_COMPLIANT}) {
3668                         $Global::UrlJoiner = '&amp;';
3669                         $Global::UrlSplittor = qr/\&amp;|\&/;
3670                 }
3671                 else {
3672                         $Global::UrlJoiner = '&';
3673                         $Global::UrlSplittor = qr/\&/;
3674                 }
3675         }
3676         else {
3677                 $Global::UrlJoiner = $Global::UrlSepChar;
3678                 $Global::UrlSplittor = qr/[&$Global::UrlSepChar]/o;
3679         }
3680                 
3681         $Global::CountrySubdomains ||= {};
3682
3683         while (my ($key,$val) = each(%$Global::CountrySubdomains)) {
3684                 $val =~ s/[\s,]+$//;
3685                 next unless $val;
3686
3687                 $val = '\.(?:' . join('|',split('[\s,]+',$val)) . ")\\.$key";
3688                 $Global::CountrySubdomains->{$key} = qr/$val/i;
3689         }
3690 }
3691
3692 sub set_global_defaults {
3693         ## Nothing here currently
3694 }
3695
3696 my @readonly_members = qw/
3697         UserDB_repository
3698         AdminUserDB
3699 /;
3700
3701 sub set_readonly_config {
3702         my $cat = $C->{CatalogName} or return;
3703         my $ro = $Global::ReadOnlyCfg{$cat} ||= {};
3704         for(@readonly_members) {
3705                 $ro->{$_} = copyref($C->{$_});
3706         }
3707 }
3708
3709 sub set_defaults {
3710         @Dispatches = ();
3711         @Cleanups = ();
3712         for(keys %Default) {
3713                 my ($status, $error) = $Default{$_}->($C->{$_});
3714                 next if $status;
3715                 return config_error(
3716                                 errmsg(
3717                                         'Directive %s returned default setting error: %s',
3718                                         $_,
3719                                         $error
3720                                 )
3721                 );
3722         }
3723         @Dispatches = sort { $Dispatch_priority{$a} cmp $Dispatch_priority{$b} } @Dispatches;
3724         @Cleanups = sort { $Cleanup_priority{$a} cmp $Cleanup_priority{$b} } @Cleanups;
3725         for(@Dispatches) {
3726                 push @{ $C->{DispatchRoutines} ||= [] }, $Dispatch_code{$_};
3727         }
3728         for(@Cleanups) {
3729                 push @{ $C->{CleanupRoutines} ||= [] }, $Cleanup_code{$_};
3730         }
3731
3732     # check MV_HTTP_CHARSET against a valid encoding
3733     if ( !$ENV{MINIVEND_DISABLE_UTF8} &&
3734          (my $enc = $C->{Variable}->{MV_HTTP_CHARSET}) ) {
3735         if (my $norm_enc = Vend::CharSet::validate_encoding($enc)) {
3736             if (uc $norm_enc ne uc($enc)) {
3737                 config_warn("Provided MV_HTTP_CHARSET '$enc' resolved to '$norm_enc'.  Continuing.");
3738                 $C->{Variable}->{MV_HTTP_CHARSET} = $norm_enc;
3739             }
3740         }
3741         else {
3742             config_error("Unrecognized/unsupported MV_HTTP_CHARSET: '%s'.", $enc);
3743             delete $C->{Variable}->{MV_HTTP_CHARSET};
3744         }
3745     }
3746
3747         $Have_set_global_defaults = 1;
3748         return;
3749 }
3750
3751 sub parse_url_sep_char {
3752         my($var,$val) = @_;
3753
3754         $val =~ s/\s+//g;
3755
3756         if($val =~ /[\w%]/) {
3757                 config_error(
3758                         errmsg("%s character value '%s' must not be word character or %%.", $var, $val)
3759                 );
3760         }
3761         elsif(length($val) > 1) {
3762                 config_error(
3763                         "%s character value '%s' longer than one character.",
3764                         $var,
3765                         $val,
3766                 );
3767         }
3768         elsif($val !~ /[&;:]/) {
3769                 config_warn("%s character value '%s' not a recommended value.", $var, $val);
3770         }
3771
3772         return $val;
3773 }
3774
3775 sub check_legal {
3776         my ($directive, $value) = @_;
3777         return 1 unless defined $IllegalValue{$directive}->{$value};
3778         config_error ("\nYou may not use a value of '$value' in the $directive directive.");
3779 }
3780
3781 sub parse_array {
3782         my($item,$settings) = @_;
3783         return '' unless $settings;
3784         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3785
3786         my $c;
3787
3788         if(defined $C) {
3789                 $c = $C->{$item} || [];
3790         }
3791         else {
3792                 no strict 'refs';
3793                 $c = ${"Global::$item"} || [];
3794         }
3795
3796         for (@setting) {
3797                 check_legal($item, $_);
3798                 push @{$c}, $_;
3799         }
3800         $c;
3801 }
3802
3803 sub parse_routine_array {
3804         my($item,$settings) = @_;
3805
3806         return '' unless $settings;
3807
3808         my $c;
3809         if(defined $C) {
3810                 $c = $C->{$item};
3811         }
3812         else {
3813                 no strict 'refs';
3814                 $c = ${"Global::$item"};
3815         }
3816
3817         my @mac;
3818
3819         if($settings =~ /^[-\s\w,]+$/) {
3820                 @mac = grep /\S/, split /[\s,]+/, $settings;
3821         }
3822         else {
3823                 push @mac, $settings;
3824         }
3825
3826         if(ref($c) eq 'ARRAY') {
3827                 push @$c, @mac;
3828         }
3829         elsif($c) {
3830                 $c = [$c, @mac];
3831         }
3832         else {
3833                 $c = scalar(@mac) > 1 ? [ @mac ] : $mac[0];
3834         }
3835
3836         return $c;
3837 }
3838
3839 sub parse_array_complete {
3840         my($item,$settings) = @_;
3841         return '' unless $settings;
3842         my(@setting) = grep /\S/, split /[\s,]+/, $settings;
3843
3844         my $c = [];
3845
3846         for (@setting) {
3847                 check_legal($item, $_);
3848                 push @{$c}, $_;
3849         }
3850
3851         $c;
3852 }
3853
3854 sub parse_list_wildcard {
3855         my $value = get_wildcard_list(@_,0);
3856         return '' unless length($value);
3857         return qr/$value/i;
3858 }
3859
3860 sub parse_list_wildcard_full {
3861         my $value = get_wildcard_list(@_,1);
3862         return '' unless length($value);
3863         return qr/^($value)$/i;
3864 }
3865
3866 # Make a dos-ish regex into a Perl regex, check for errors
3867 sub parse_wildcard {
3868         my($var, $value) = @_;
3869         return '' if ! $value;
3870
3871         $value =~ s/\./\\./g;
3872         $value =~ s/\*/.*/g;
3873         $value =~ s/\?/./g;
3874         $value =~
3875                 s[({(?:.+?,)+.+?})]
3876                  [ local $_ = $1; tr/{,}/(|)/; $_ ]eg;
3877         $value =~ s/\s+/|/g;
3878         eval {  
3879                 my $never = 'NeVAirBE';
3880                 $never =~ m{$value};
3881         };
3882
3883         if($@) {
3884                 config_error("Bad regular expression in $var.");
3885         }
3886         return $value;
3887 }
3888
3889
3890 # Check that a regex won't cause a syntax error. Uses m{}, which
3891 # should be used for all user-input regexes.
3892 sub parse_regex {
3893         my($var, $value) = @_;
3894
3895         eval {  
3896                 my $never = 'NeVAirBE';
3897                 $never =~ m{$value};
3898         };
3899
3900         if($@) {
3901                 config_error("Bad regular expression in $var.");
3902         }
3903         return $value;
3904 }
3905
3906 sub parse_ip_address_regexp {
3907
3908         my ($var, $value) = @_;
3909         return '' unless $value;
3910
3911         my @atoms = split /[\s,\0]/, $value;
3912
3913         eval {
3914                 require Net::IP::Match::Regexp;
3915         };
3916         $@ and config_error("$var directive requires module: $@");
3917
3918         my $re = Net::IP::Match::Regexp::create_iprange_regexp(@atoms)
3919                 or config_error("Improper IP address range for $var");
3920     return $re;
3921 }
3922
3923 # Prepend the Global::VendRoot pathname to the relative directory specified,
3924 # unless it already starts with a leading /.
3925
3926 sub parse_root_dir {
3927         my($var, $value) = @_;
3928         return '' unless $value;
3929         $value = "$Global::VendRoot/$value"
3930                 unless file_name_is_absolute($value);
3931         $value =~ s./+$..;
3932         return $value;
3933 }
3934
3935 sub parse_root_dir_array {
3936         my($var, $value) = @_;
3937         return [] unless $value;
3938
3939         no strict 'refs';
3940         my $c = ${"Global::$var"} || [];
3941
3942         my @dirs = grep /\S/, Text::ParseWords::shellwords($value);
3943
3944         foreach my $dir (@dirs) {
3945                 $dir = "$Global::VendRoot/$dir"
3946                         unless file_name_is_absolute($dir);
3947                 $dir =~ s./+$..;
3948                 push @$c, $dir;
3949         }
3950         return $c;
3951 }
3952
3953 sub parse_dir_array {
3954         my($var, $value) = @_;
3955         return [] unless $value;
3956
3957         $C->{$var} = [] unless $C->{$var};
3958         my $c = $C->{$var} || [];
3959
3960         my @dirs = grep /\S/, Text::ParseWords::shellwords($value);
3961
3962         foreach my $dir (@dirs) {
3963                 unless (allowed_file($dir)) {
3964                         config_error('Path %s not allowed in %s directive',
3965                                                                 $dir, $var);
3966                 }
3967                 $dir = "$C->{VendRoot}/$dir"
3968                         unless file_name_is_absolute($dir);
3969                 $dir =~ s./+$..;
3970                 push @$c, $dir;
3971         }
3972
3973         return $c;
3974 }
3975
3976 sub parse_relative_dir {
3977         my($var, $value) = @_;
3978
3979         if (absolute_or_relative($value)) {
3980                 config_error('Path %s not allowed in %s directive',
3981                                           $value, $var);
3982         }
3983
3984         $C->{Source}{$var} = $value;
3985
3986         $value = "$C->{VendRoot}/$value"
3987                 unless file_name_is_absolute($value);
3988         $value =~ s./+$..;
3989         $value;
3990 }
3991
3992 # Ensure only an integer value in the directive
3993 sub parse_integer {
3994         my($var, $value) = @_;
3995         $value = hex($value) if $value =~ /^0x[\dA-Fa-f]+$/;
3996         $value = oct($value) if $value =~ /^0[0-7]+$/;
3997         config_error("The $var directive (now set to '$value') must be an integer\n")
3998                 unless $value =~ /^\d+$/;
3999         $value;
4000 }
4001
4002 # Make sure no trailing slash in VendURL etc.
4003 sub parse_url {
4004         my($var, $value) = @_;
4005         $value =~ s,/+$,,;
4006         $value;
4007 }
4008
4009 # Parses a time specification such as "1 day" and returns the
4010 # number of seconds in the interval, or undef if the string could
4011 # not be parsed.
4012
4013 sub time_to_seconds {
4014         my($str) = @_;
4015         my($n, $dur);
4016
4017         ($n, $dur) = ($str =~ m/(\d+)[\s\0]*(\w+)?/);
4018         return undef unless defined $n;
4019         if (defined $dur) {
4020                 local($_) = $dur;
4021                 if (m/^s|sec|secs|second|seconds$/i) {
4022                 }
4023                 elsif (m/^m|min|mins|minute|minutes$/i) {
4024                         $n *= 60;
4025                 }
4026                 elsif (m/^h|hour|hours$/i) {
4027                         $n *= 60 * 60;
4028                 }
4029                 elsif (m/^d|day|days$/i) {
4030                         $n *= 24 * 60 * 60;
4031                 }
4032                 elsif (m/^w|week|weeks$/i) {
4033                         $n *= 7 * 24 * 60 * 60;
4034                 }
4035                 else {
4036                         return undef;
4037                 }
4038         }
4039
4040         $n;
4041 }
4042
4043 sub parse_valid_group {
4044         my($var, $value) = @_;
4045
4046         return '' unless $value;
4047
4048         my($name,$passwd,$gid,$members) = getgrnam($value);
4049
4050         config_error("$var: Group name '$value' is not a valid group\n")
4051                 unless defined $gid;
4052         $name = getpwuid($<);
4053         config_error("$var: Interchange user '$name' not in group '$value'\n")
4054                 unless $members =~ /\b$name\b/;
4055         $gid;
4056 }
4057
4058 sub parse_executable {
4059         my($var, $initial) = @_;
4060         my($x);
4061         my(@tries);
4062         
4063         if(ref $initial) {
4064                 @tries = @$initial;
4065         }
4066         else {
4067                 @tries = $initial;
4068         }
4069
4070         TRYEXE:
4071         foreach my $value (@tries) {
4072 #::logDebug("trying $value for $var");
4073                 my $root = $value;
4074                 $root =~ s/\s.*//;
4075
4076                 return $value if $Global::Windows;
4077                 if( ! defined $value or $value eq '') {
4078                         $x = '';
4079                 }
4080                 elsif( $value eq 'none') {
4081                         $x = 'none';
4082                         last;
4083                 }
4084                 elsif( $value =~ /^\w+::[:\w]+\w$/) {
4085                         ## Perl module like Net::SMTP
4086                         eval {
4087                                 eval "require $value";
4088                                 die if $@;
4089                                 $x = $value;
4090                         };
4091                         last if $x;
4092                 }
4093                 elsif ($root =~ m#^/# and -x $root) {
4094                         $x = $value;
4095                         last;
4096                 }
4097                 else {
4098                         my @path = split /:/, $ENV{PATH};
4099                         for (@path) {
4100                                 next unless -x "$_/$root";
4101                                 $x = $value;
4102                                 last TRYEXE;
4103                         }
4104                 }
4105         }
4106         config_error( errmsg(
4107                                         "Can't find executable (%s) for the %s directive\n",
4108                                         join('|', @tries),
4109                                         $var,
4110                                         )
4111                 ) unless defined $x;
4112 #::logDebug("$var=$x");
4113         return $x;
4114 }
4115
4116 sub parse_time {
4117         my($var, $value) = @_;
4118         my($n);
4119
4120         return $value unless $value;
4121
4122 #       $C->{Source}->{$var} = [$value];
4123
4124         $n = time_to_seconds($value);
4125         config_error("Bad time format ('$value') in the $var directive\n")
4126         unless defined $n;
4127         $n;
4128 }
4129
4130 sub parse_cron {
4131         my($var, $value) = @_;
4132
4133         return '' unless $value =~ /\s/ and $value =~ /[a-zA-Z]/;
4134
4135         unless($Vend::Cron::Loaded) {
4136                  config_warn(
4137                         "Cannot use %s unless %s module loaded%s",
4138                         'crontab',
4139                         'Vend::Cron',
4140                         ' (missing Set::Crontab?)',
4141                         );
4142                  return '';
4143         }
4144         return Vend::Cron::read_cron($value);
4145 }
4146
4147 # Determine catalog structure from Catalog config line(s)
4148 sub parse_catalog {
4149         my ($var, $setting) = @_;
4150         my $num = ! defined $Global::Catalog ? 0 : $Global::Catalog;
4151         return $num unless (defined $setting && $setting); 
4152
4153         my($name,$base,$dir,$script, @rest);
4154         ($name,@rest) = Text::ParseWords::shellwords($setting);
4155
4156         my %remap = qw/
4157                                         base      base
4158                                         alias     alias
4159                                         aliases   alias
4160                                         directory dir
4161                                         dir       dir
4162                                         script    script
4163                                         directive directive
4164                                         fullurl   full_url
4165                                         full      full_url
4166                                         /;
4167
4168         my ($cat, $key, $value);
4169         if ($Global::Catalog{$name}) {
4170                 # already defined
4171                 $cat   = $Global::Catalog{$name};
4172                 $key   = shift @rest;
4173                 $value = shift @rest;
4174         }
4175         elsif(
4176                         $var =~ /subcatalog/i and
4177                         @rest > 2
4178                         and file_name_is_absolute($rest[1]) 
4179                   )
4180         {
4181                 $cat = {
4182                         name   => $name,
4183                         base   => $rest[0],
4184                         dir    => $rest[1],
4185                         script => $rest[2],
4186                 };
4187                 splice(@rest, 0, 3);
4188                 $cat->{alias} = [ @rest ]
4189                         if @rest;
4190         }
4191         elsif( file_name_is_absolute($rest[0]) ) {
4192                 $cat = {
4193                         name   => $name,
4194                         dir    => $rest[0],
4195                         script => $rest[1],
4196                 };
4197                 splice(@rest, 0, 2);
4198                 $cat->{alias} = [ @rest ]
4199                         if @rest;
4200         }
4201         else {
4202                 $key   = shift @rest;
4203                 $value = shift @rest;
4204                 $cat = { name   => $name };
4205         }
4206
4207         $key = $remap{$key} if $key && defined $remap{$key};
4208
4209         if(! $key) {
4210                 # Nada
4211         }
4212         elsif($key eq 'alias' or $key eq 'server') {
4213                 $cat->{$key} = [] if ! $cat->{$key};
4214                 push @{$cat->{$key}}, $value;
4215                 push @{$cat->{$key}}, @rest if @rest;
4216         }
4217         elsif($key eq 'global') {
4218                 $cat->{$key} = $Global::AllowGlobal->{$name} = is_yes($value);
4219         }
4220         elsif($key eq 'directive') {
4221                 no strict 'refs';
4222                 my $p = $value;
4223                 my $v = join " ", @rest;
4224                 $cat->{$key} = {} if ! $cat->{$key};
4225                 my $ref = set_directive($p, $v, 1);
4226
4227                 if(ref $ref->[1] =~ /HASH/) {
4228                         if(! $cat->{$key}{$ref->[0]} ) {
4229                                 $cat->{$key}{$ref->[0]} =  { %{"Global::$ref->[0]"} };
4230                         }
4231                         for (keys %{$ref->[1]}) {
4232                                 $cat->{$key}{$ref->[0]}{$_} = $ref->[1]->{$_};
4233                         }
4234                 }
4235                 else {
4236                         $cat->{$key}{$ref->[0]} = $ref->[1];
4237                 }
4238         }
4239         else {
4240                 $cat->{$key} = $value;
4241         }
4242
4243 #::logDebug ("parsing catalog $name = " . uneval_it($cat));
4244
4245         $Global::Catalog{$name} = $cat;
4246
4247         # Define the main script name and array of aliases
4248         return ++$num;
4249 }
4250
4251 my %Explode_ref = (  qw!
4252                                                         COLUMN_DEF    COLUMN_DEF
4253 !);
4254
4255 my %Hash_ref = (  qw!
4256                                                         FILTER_FROM   FILTER_FROM
4257                                                         FILTER_TO     FILTER_TO 
4258                                                         LENGTH_EXCEPTION LENGTH_EXCEPTION
4259                                                         DEFAULT       DEFAULT
4260                                                         DEFAULT_SESSION       DEFAULT_SESSION
4261                                                         FIELD_ALIAS   FIELD_ALIAS
4262                                                         NUMERIC       NUMERIC
4263                                                         NO_UPDATE     NO_UPDATE
4264                                                         PREFER_NULL   PREFER_NULL
4265                                                         WRITE_CATALOG WRITE_CATALOG
4266                                         ! );
4267
4268 my %Ary_ref = (   qw!
4269                                                 NAME                NAME
4270                                                 BINARY              BINARY 
4271                                                 PRECREATE           PRECREATE 
4272                                                 POSTCREATE          POSTCREATE 
4273                                                 PREQUERY                        PREQUERY
4274                                                 INDEX               INDEX 
4275                                                 ALTERNATE_DSN       ALTERNATE_DSN
4276                                                 ALTERNATE_USER      ALTERNATE_USER
4277                                                 ALTERNATE_PASS      ALTERNATE_PASS
4278                                                 ALTERNATE_BASE_DN   ALTERNATE_BASE_DN
4279                                                 ALTERNATE_LDAP_HOST ALTERNATE_LDAP_HOST
4280                                                 ALTERNATE_BIND_DN   ALTERNATE_BIND_DN
4281                                                 ALTERNATE_BIND_PW   ALTERNATE_BIND_PW
4282                                                 POSTEXPORT          POSTEXPORT
4283                                         ! );
4284
4285 sub parse_config_db {
4286         my($name, $value) = @_;
4287         my ($d, $new);
4288         unless (defined $value && $value) { 
4289                 $d = {};
4290                 return $d;
4291         }
4292
4293         if($C) {
4294                 $d = $C->{ConfigDatabase};
4295         }
4296         else {
4297                 $d = $Global::ConfigDatabase;
4298         }
4299
4300         my($database,$remain) = split /[\s,]+/, $value, 2;
4301
4302         $d->{'name'} = $database;
4303         
4304         if(!defined $d->{'file'}) {
4305                 my($file, $type) = split /[\s,]+/, $remain, 2;
4306                 $d->{'file'} = $file;
4307                 if(             $type =~ /^\d+$/        ) {
4308                         $d->{'type'} = $type;
4309                 }
4310                 elsif(  $type =~ /^(dbi|sql)\b/i        ) {
4311                         $d->{'type'} = 8;
4312                         if($type =~ /^dbi:/) {
4313                                 $d->{DSN} = $type;
4314                         }
4315                 }
4316 # LDAP
4317                 elsif(  $type =~ /^ldap\b/i) {
4318                         $d->{'type'} = 9;
4319                         if($type =~ /^ldap:(.*)/i) {
4320                                 $d->{LDAP_HOST} = $1;
4321                         }
4322                 }
4323 # END LDAP
4324                 elsif(  "\U$type" eq 'TAB'      ) {
4325                         $d->{'type'} = 6;
4326                 }
4327                 elsif(  "\U$type" eq 'PIPE'     ) {
4328                         $d->{'type'} = 5;
4329                 }
4330                 elsif(  "\U$type" eq 'CSV'      ) {
4331                         $d->{'type'} = 4;
4332                 }
4333                 elsif(  "\U$type" eq 'DEFAULT'  ) {
4334                         $d->{'type'} = 1;
4335                 }
4336                 elsif(  $type =~ /[%]{1,3}|percent/i    ) {
4337                         $d->{'type'} = 3;
4338                 }
4339                 elsif(  $type =~ /line/i        ) {
4340                         $d->{'type'} = 2;
4341                 }
4342                 else {
4343                         $d->{'type'} = 1;
4344                         $d->{DELIMITER} = $type;
4345                 }
4346         }
4347         else {
4348                 my($p, $val) = split /\s+/, $remain, 2;
4349                 $p = uc $p;
4350
4351                 if(defined $Explode_ref{$p}) {
4352                         my($ak, $v);
4353                         my(@v) = Text::ParseWords::shellwords($val);
4354                         @v = grep defined $_, @v;
4355                         $d->{$p} = {} unless defined $d->{$p};
4356                         for(@v) {
4357                                 my ($sk,$v) = split /\s*=\s*/, $_;
4358                                 my (@k) = grep /\w/, split /\s*,\s*/, $sk;
4359                                 for my $k (@k) {
4360                                         if($d->{$p}->{$k}) {
4361                                                 config_warn(
4362                                                         qq{Database %s explode parameter %s redefined to "%s", was "%s".},
4363                                                         $d->{name},
4364                                                         "$p --> $k",
4365                                                         $v,
4366                                                         $d->{$p}->{$k},
4367                                                 );
4368                                         }
4369                                         $d->{$p}->{$k} = $v;
4370                                 }
4371                         }
4372                 }
4373                 elsif(defined $Hash_ref{$p}) {
4374                         my($k, $v);
4375                         my(@v) = Vend::Util::quoted_comma_string($val);
4376                         @v = grep defined $_, @v;
4377                         $d->{$p} = {} unless defined $d->{$p};
4378                         for(@v) {
4379                                 ($k,$v) = split /\s*=\s*/, $_;
4380                                 if($d->{$p}->{$k}) {
4381                                         config_warn(
4382                                                 qq{Database %s hash parameter %s redefined to "%s", was "%s".},
4383                                                 $d->{name},
4384                                                 "$p --> $k",
4385                                                 $v,
4386                                                 $d->{$p}->{$k},
4387                                         );
4388                                 }
4389                                 $d->{$p}->{$k} = $v;
4390                         }
4391                 }
4392                 elsif(defined $Ary_ref{$p}) {
4393                         my(@v) = Text::ParseWords::shellwords($val);
4394                         $d->{$p} = [] unless defined $d->{$p};
4395                         push @{$d->{$p}}, @v;
4396                 }
4397                 else {
4398                         defined $d->{$p}
4399                         and ! defined $C->{DatabaseDefault}{$p}
4400                                 and config_warn(
4401                                                 qq{Database %s scalar parameter %s redefined to "%s", was "%s".},
4402                                                 $d->{name},
4403                                                 $p,
4404                                                 $val,
4405                                                 $d->{$p},
4406                                         );
4407                         $d->{$p} = $val;
4408                 }
4409         }
4410
4411 #::logDebug("d object: " . uneval_it($d));
4412         if($d->{ACTIVE} and ! $d->{OBJECT}) {
4413                 my $name = $d->{'name'};
4414                 $d->{OBJECT} = Vend::Data::import_database($d)
4415                         or config_error("Config database $name failed import.\n");
4416         }
4417         elsif($d->{LOAD} and ! $d->{OBJECT}) {
4418                 my $name = $d->{'name'};
4419                 $d->{OBJECT} = Vend::Data::import_database($d)
4420                         or config_error("Config database $name failed import.\n");
4421                 if( $d->{type} == 8 ) {
4422                         $d->{OBJECT}->set_query("delete from $name where 1 = 1");
4423                 }
4424         }
4425
4426         return $d;
4427         
4428 }
4429
4430 sub parse_dbauto {
4431         my ($var, $value) = @_;
4432         return '' unless $value;
4433         my @inc = Vend::Table::DBI::auto_config($value);
4434         my %noed;
4435         for(@inc) {
4436                 my ($t, $thing) = @$_;
4437                 parse_boolean('NoImport', $t) unless $noed{$t}++;
4438                 parse_database('Database', "$t $thing");
4439         }
4440         return 1;
4441 }
4442
4443 sub parse_database {
4444         my ($var, $value) = @_;
4445         my ($c, $new);
4446
4447         if (! $value) {
4448                 $c = {};
4449                 return $c;
4450         }
4451
4452         $c = $C ? $C->{Database} : $Global::Database;
4453
4454         my($database,$remain) = split /[\s,]+/, $value, 2;
4455
4456         if( ! defined $c->{$database} ) {
4457                 $c->{$database} = { 'name' => $database, included_from => $configfile };
4458                 $new = 1;
4459         }
4460
4461         my $d = $c->{$database};
4462
4463         if($new) {
4464                 my($file, $type) = split /[\s,]+/, $remain, 2;
4465                 $d->{'file'} = $file;
4466                 if($file eq 'AUTO_SEQUENCE') {
4467                         # database table missing for AUTO_SEQUENCE directive
4468                         config_error('Missing database %s for AUTO_SEQUENCE %s.', $database, $type);
4469                         return $c;
4470                 }
4471                 if(             $type =~ /^\d+$/        ) {
4472                         $d->{'type'} = $type;
4473                 }
4474                 elsif(  $type =~ /^(dbi|sql)\b/i        ) {
4475                         $d->{'type'} = 8;
4476                         if($type =~ /^dbi:/) {
4477                                 $d->{DSN} = $type;
4478                         }
4479                 }
4480 # LDAP
4481                 elsif(  $type =~ /^ldap\b/i) {
4482                         $d->{'type'} = 9;
4483                         if($type =~ /^ldap:(.*)/i) {
4484                                 $d->{LDAP_HOST} = $1;
4485                         }
4486                 }
4487 # END LDAP
4488                 elsif(  $type =~ /^ic:(\w*)(:(.*))?/ ) {
4489                         my $class = $1;
4490                         my $dir = $3;
4491                         $d->{DIR} = $dir if $dir;
4492                         if($class =~ /^default$/i) {
4493                                 # Do nothing
4494                         }
4495                         elsif($class) {
4496                                 $class = uc $class;
4497                                 if(! $Vend::Data::db_config{$class}) {
4498                                         config_error("unrecognized IC database class: %s (from %s)", $class, $type);
4499                                 }
4500                                 $d->{Class} = $class;
4501                         }
4502                         $d->{'type'} = 6;
4503                 }
4504                 elsif(  "\U$type" eq 'TAB'      ) {
4505                         $d->{'type'} = 6;
4506                 }
4507                 elsif(  "\U$type" eq 'PIPE'     ) {
4508                         $d->{'type'} = 5;
4509                 }
4510                 elsif(  "\U$type" eq 'CSV'      ) {
4511                         $d->{'type'} = 4;
4512                 }
4513                 elsif(  "\U$type" eq 'DEFAULT'  ) {
4514                         $d->{'type'} = 1;
4515                 }
4516                 elsif(  $type =~ /[%]{1,3}|percent/i    ) {
4517                         $d->{'type'} = 3;
4518                 }
4519                 elsif(  $type =~ /line/i        ) {
4520                         $d->{'type'} = 2;
4521                 }
4522                 else {
4523                         $d->{'type'} = 1;
4524                         $d->{DELIMITER} = $type;
4525                 }
4526                 if    ($d->{'type'} eq '8')     { $d->{Class} = 'DBI'                                           }
4527                 elsif ($d->{'type'} eq '9') { $d->{Class} = 'LDAP'                                              }
4528                 else                                            { $d->{Class} ||= $Global::Default_database     }
4529
4530                 if($C and $C->{DatabaseDefault}) {
4531                         while ( my($k, $v) = each %{$C->{DatabaseDefault}}) {
4532                                 $d->{$k} = $v;
4533                         }
4534                 }
4535
4536                 $d->{HOT} = 1 if $d->{Class} eq 'MEMORY';
4537 #::logDebug("parse_database: type $type -> $d->{type}");
4538         }
4539         else {
4540                 my($p, $val) = split /\s+/, $remain, 2;
4541                 $p = uc $p;
4542 #::logDebug("parse_database: parameter $p = $val");
4543
4544                 if(defined $Explode_ref{$p}) {
4545                         my($ak, $v);
4546                         $val =~ s/,+$//;
4547                         $val =~ s/^,+//;
4548                         my(@v) = Text::ParseWords::shellwords($val);
4549                         @v = grep length $_, @v;
4550                         $d->{$p} = {} unless defined $d->{$p};
4551                         for(@v) {
4552                                 my ($sk,$v) = split /\s*=\s*/, $_;
4553                                 my (@k) = grep /\w/, split /\s*,\s*/, $sk;
4554                                 for my $k (@k) {
4555                                         if($d->{$p}->{$k}) {
4556                                                 config_warn(
4557                                                         qq{Database %s explode parameter %s redefined to "%s", was "%s".},
4558                                                         $d->{name},
4559                                                         "$p --> $k",
4560                                                         $v,
4561                                                         $d->{$p}->{$k},
4562                                                 );
4563                                         }
4564                                         $d->{$p}->{$k} = $v;
4565                                 }
4566                         }
4567                 }
4568                 elsif(defined $Hash_ref{$p}) {
4569                         my($k, $v);
4570                         my(@v) = Vend::Util::quoted_comma_string($val);
4571                         @v = grep defined $_, @v;
4572                         $d->{$p} = {} unless defined $d->{$p};
4573                         for(@v) {
4574                                 ($k,$v) = split /\s*=\s*/, $_;
4575                                 if($d->{$p}->{$k}) {
4576                                         config_warn(
4577                                                 qq{Database %s hash parameter %s redefined to "%s", was "%s".},
4578                                                 $d->{name},
4579                                                 "$p --> $k",
4580                                                 $v,
4581                                                 $d->{$p}->{$k},
4582                                         );
4583                                 }
4584                                 $d->{$p}->{$k} = $v;
4585                         }
4586                 }
4587                 elsif(defined $Ary_ref{$p}) {
4588                         my(@v) = Text::ParseWords::shellwords($val);
4589                         $d->{$p} = [] unless defined $d->{$p};
4590                         push @{$d->{$p}}, @v;
4591                 }
4592                 elsif ($p eq 'COMPOSITE_KEY') {
4593                     ## Magic hardcode
4594                         if($d->{type} == 8) {
4595                                 $d->{Class} = 'DBI_CompositeKey';
4596                                 $d->{$p} = $val;
4597                         }
4598                         else {
4599                                 config_warn(
4600                                         'Database %s parameter in type with no handling. Ignored.', 
4601                                         $p,
4602                                         );
4603                         }
4604                 }
4605                 elsif ($p eq 'CLASS') {
4606                         $d->{Class} = $val;
4607                 }
4608                 elsif ($p =~ /^(MEMORY|SDBM|GDBM|DB_FILE|LDAP)$/i) {
4609                         $d->{Class} = uc $p;
4610                 }
4611                 elsif ($p eq 'ALIAS') {
4612                         if (defined $c->{$val}) {
4613                                 config_warn("Database '%s' already exists, can't alias.", $val);
4614                         }
4615                         else {
4616                                 $c->{$val} = $d;
4617                         }
4618                 }
4619                 elsif ($p =~ /^MAP/) {
4620                         Vend::Table::Shadow::_parse_config_line ($d, $p, $val);
4621                 }
4622
4623                 else {
4624                         defined $d->{$p}
4625                         and ! defined $C->{DatabaseDefault}{$p}
4626                                 and
4627                                 config_warn(
4628                                         qq{Database %s scalar parameter %s redefined to "%s", was "%s".},
4629                                         $d->{name},
4630                                         $p,
4631                                         $val,
4632                                         $d->{$p},
4633                                 );
4634                         $d->{$p} = $val;
4635                 }
4636                 $d->{HOT} = 1 if $d->{Class} eq 'MEMORY';
4637         }
4638
4639         return $c;
4640 }
4641
4642 sub get_configdb {
4643         my ($var, $value) = @_;
4644         my ($table, $file, $type);
4645         unless ($C->{Database}{$value}) {
4646                 return if $Vend::ExternalProgram;
4647                 ($table, $file, $type) = split /\s+/, $value, 3;
4648                 $file = "$table.txt" unless $file;
4649                 $type = 'TAB' unless $type;
4650                 parse_database('Database',"$table $file $type");
4651                 unless ($C->{Database}{$table}) {
4652                         config_warn(
4653                                 "Bad $var value '%s': %s\n%s",
4654                                 "Database $table $file $type",
4655                                 uneval($C->{Database}),
4656                         );
4657                         return '';
4658                 }
4659         }
4660         else {
4661                 $table = $value;
4662         }
4663
4664         my $db;
4665         unless ($db = $C->{Database}{$table}) {
4666                 return if $Vend::ExternalProgram;
4667                 my $err = $@;
4668                 config_warn("Bad $var '%s': %s", $table, $err);
4669                 return '';
4670         }
4671         eval {
4672                 $db = Vend::Data::import_database($db);
4673         };
4674         if($@ or ! $db) {
4675                 my $err = $@ || errmsg("Unable to import table '%s' for config.", $table);
4676                 delete $C->{Database}{$table};
4677                 die $err;
4678         }
4679         return ($db, $table);
4680 }
4681
4682 my %Columnar = (Locale => 1);
4683
4684 sub parse_configdb {
4685         my ($var, $value) = @_;
4686
4687         my ($file, $type);
4688         return '' if ! $value;
4689         local($Vend::Cfg) = $C;
4690         my ($db, $table);
4691         eval {
4692                 ($db, $table) = get_configdb($var, $value);
4693         };
4694         ::logGlobal("$var $value: $@") if $@;
4695         return '' if ! $db;
4696
4697         my ($k, @f);    # key and fields
4698         my @l;                  # refs to locale repository
4699         my @n;                  # names of locales
4700         my @h;                  # names of locales
4701
4702         my $base_direc = $var;
4703         $base_direc =~ s/Database$//;
4704         my $repos_name = $base_direc . '_repository';
4705         my $repos = $C->{$repos_name} ||= {};
4706
4707         @n = $db->columns();
4708         shift @n;
4709         my $i;
4710         if($Columnar{$base_direc}) {
4711                 my @l;
4712                 for(@n) {
4713                         $repos->{$_} ||= {};
4714                         push @l, $repos->{$_};
4715                 }
4716                 my $i;
4717                 while( ($k , undef, @f ) = $db->each_record) {
4718                         for ($i = 0; $i < @f; $i++) {
4719                                 next unless length($f[$i]);
4720                                 $l[$i]->{$k} = $f[$i];
4721                         }
4722                 }
4723         }
4724         else {
4725                 while( ($k, undef, @f ) = $db->each_record) {
4726                         for ($i = 0; $i < @f; $i++) {
4727                                 next unless length($f[$i]);
4728                                 $repos->{$k}{$n[$i]} = $f[$i];
4729                         }
4730                 }
4731         }
4732         $db->close_table();
4733         return $table;
4734 }
4735
4736 sub parse_dirconfig {
4737         my ($var, $value) = @_;
4738
4739         return '' if ! $value;
4740         $value =~ s/(\w+)\s+//;
4741         my $direc = $1;
4742 #::logDebug("direc=$direc value=$value");
4743          
4744         my $ref = $C->{$direc};
4745
4746         unless(ref($ref) eq 'HASH') {
4747                 config_error("DirConfig called for non-hash configuration directive.");
4748         }
4749
4750         my $source = $C->{$var}   || {};
4751         my $sref = $source->{$direc} || {};
4752
4753         my @dirs = grep -d $_, glob($value);
4754         foreach my $dir (@dirs) {
4755                 opendir(DIRCONFIG, $dir)
4756                         or next;
4757                 my @files = grep /^\w+$/, readdir(DIRCONFIG);
4758                 for(@files) {
4759                         next unless -f "$dir/$_";
4760 #::logDebug("reading key=$_ from $dir/$_");
4761                         $ref->{$_} = readfile("$dir/$_", $Global::NoAbsolute, 0);
4762                         $ref->{$_} = substitute_variable($ref->{$_}) if $C->{ParseVariables};
4763                         $sref->{$_} = "$dir/$_";
4764                 }
4765         }
4766         $source->{$direc} = $sref;
4767         return $source;
4768 }
4769
4770 sub parse_dbconfig {
4771         my ($var, $value) = @_;
4772
4773         my ($file, $type);
4774         return '' if ! $value;
4775         local($Vend::Cfg) = $C;
4776
4777         my ($db, $table);
4778         eval {
4779                 ($db, $table) = get_configdb($var, $value);
4780         };
4781
4782         return '' if ! $db;
4783
4784         my ($k, @f);    # key and fields
4785         my @l;                  # refs to locale repository
4786         my @n;                  # names of locales
4787         my @h;                  # names of locales
4788
4789         @n = $db->columns();
4790         shift @n;
4791         my $extra;
4792         for(@n) {
4793                 my $real = $CDname{lc $_};
4794                 if (! ref $Vend::Cfg->{$real} or $Vend::Cfg->{$real} !~ /HASH/) {
4795                         # ignore non-existent directive, but put in hash
4796                         my $ref = {};
4797                         push @l, $ref;
4798                         push @h, [$real, $ref];
4799                         next;
4800                 }
4801                 push @l, $Vend::Cfg->{$real};
4802         }
4803         my $i;
4804         while( ($k, undef, @f ) = $db->each_record) {
4805 #::logDebug("Got key=$k f=@f");
4806                 for ($i = 0; $i < @f; $i++) {
4807                         next unless length($f[$i]);
4808                         $l[$i]->{$k} = $f[$i];
4809                 }
4810         }
4811         for(@h) {
4812                 $Vend::Cfg->{Hash}{$_->[0]} = $_->[1];
4813         }
4814         $db->close_table();
4815         return $table;
4816 }
4817
4818 sub parse_profile {
4819         my ($var, $value) = @_;
4820         my ($c, $ref, $sref, $i);
4821
4822         if($C) {
4823                 $C->{"${var}Name"} = {} if ! $C->{"${var}Name"};
4824                 $sref = $C->{Source};
4825                 $ref = $C->{"${var}Name"};
4826                 $c = $C->{$var} || [];
4827         }
4828         else {
4829                 no strict 'refs';
4830                 $sref = $Global::Source;
4831                 ${"Global::${var}Name"} = {}
4832                          if ! ${"Global::${var}Name"};
4833                 $ref = ${"Global::${var}Name"};
4834                 $c = ${"Global::$var"} || [];
4835         }
4836
4837         $sref->{$var} = $value;
4838
4839         my (@files) = glob($value);
4840         for(@files) {
4841                 next unless $_;
4842                 config_error(
4843                   "No leading / allowed if NoAbsolute set. Contact administrator.\n")
4844                 if m.^/. and $Global::NoAbsolute;
4845                 config_error(
4846                   "No leading ../.. allowed if NoAbsolute set. Contact administrator.\n")
4847                 if m#^\.\./.*\.\.# and $Global::NoAbsolute;
4848                 push @$c, (split /\s*[\r\n]+__END__[\r\n]+\s*/, readfile($_));
4849         }
4850         for($i = 0; $i < @$c; $i++) {
4851                 if($c->[$i] =~ s/(^|\n)__NAME__\s+([^\n\r]+)\r?\n/$1/) {
4852                         my $name = $2;
4853                         $name =~ s/\s+$//;
4854                         $ref->{$name} = $i;
4855                 }
4856         }
4857
4858         return $c;
4859 }
4860
4861 # Parse ordered or named attributes just like in a usertag.  Needs to have the routine specified as follows:
4862 # ['Foo', sub { &parse_ordered_attributes(@_, [qw(foo bar baz)]) }, 'foo bar baz'],
4863 # If called directly in the normal fashion then you cannot specify the attribute order, but you can
4864 # still use it for parsing named attributes.  The results are stored as a hashref (think $opt)
4865 sub parse_ordered_attributes {
4866         my ($var, $value, $order) = @_;
4867
4868         return {} if $value !~ /\S/;
4869
4870         my @settings = Text::ParseWords::shellwords($value);
4871         my %opt;
4872         if ($settings[0] =~ /=/) {
4873                 %opt = map { (split /=/, $_, 2)[0, 1] } @settings;
4874         }
4875
4876         elsif (ref $order eq 'ARRAY') {
4877                 @opt{@$order} = @settings;
4878         }
4879
4880         else {
4881                 config_error("$var only accepts named attributes.");
4882         }
4883
4884         return \%opt;
4885 }
4886
4887 # Designed to parse catalog subroutines and all vars
4888 sub save_variable {
4889         my ($var, $value) = @_;
4890         my ($c, $name, $param);
4891
4892         if(defined $C) {
4893                 $c = $C->{$var};
4894         }
4895         else { 
4896                 no strict 'refs';
4897                 $c = ${"Global::$var"};
4898         }
4899
4900         if ($var eq 'Variable' || $var eq 'Member') {
4901                 $value =~ s/^\s*(\w+)\s*//;
4902                 $name = $1;
4903                 return 1 if defined $c->{'save'}->{$name};
4904                 $value =~ s/\s+$//;
4905                 $c->{'save'}->{$name} = $value;
4906         }
4907         elsif ( !defined $C) { 
4908                 return 0;
4909         }
4910         elsif ( defined $C->{Source}{$var} && ref $C->{Source}{$var}) {
4911                 push @{$C->{Source}{$var}}, $value;
4912         }
4913         elsif ( defined $C->{Source}{$var}) {
4914                 $C->{Source}{$var} .= "\n$value";
4915         }
4916         else {
4917                 $C->{Source}{$var} = $value;
4918         }
4919         return 1;
4920
4921 }
4922
4923 sub map_widgets {
4924         my $gref;
4925         my $return      = ($gref = $Vend::Cfg->{CodeDef}{Widget})
4926                                                 ? $gref->{Routine}
4927                                                 : {};
4928         if(my $ref = $Global::CodeDef->{Widget}{Routine}) {
4929                 while ( my ($k, $v) = each %$ref) {
4930                         next if $return->{$k};
4931                         $return->{$k} = $v;
4932                 }
4933         }
4934         if(my $ref = $Global::CodeDef->{Widget}{MapRoutine}) {
4935                 no strict 'refs';
4936                 while ( my ($k, $v) = each %$ref) {
4937                         next if $return->{$k};
4938                         $return->{$k} = \&{"$v"};
4939                 }
4940         }
4941         if(my $ref = $Global::CodeDef->{Widget}{attrDefault}) {
4942                 no strict 'refs';
4943                 while ( my ($k, $v) = each %$ref) {
4944                         next if $return->{$k};
4945                         $return->{$k} = \&{"$v"};
4946                 }
4947         }
4948         return $return;
4949 }
4950
4951 sub map_widget_defaults {
4952         my $gref;
4953         my $return      = ($gref = $Vend::Cfg->{CodeDef}{Widget})
4954                                                 ? $gref->{attrDefault}
4955                                                 : {};
4956         if(my $ref = $Global::CodeDef->{Widget}{attrDefault}) {
4957                 while ( my ($k, $v) = each %$ref) {
4958                         next if $return->{$k};
4959                         $return->{$k} = $v;
4960                 }
4961         }
4962         return $return;
4963 }
4964
4965 sub map_codedef_to_directive {
4966         my $type = shift;
4967
4968         no strict 'refs';
4969
4970         my $c;
4971         my $cfg;
4972
4973         if( $C ) {
4974                 $c = $C->{CodeDef};
4975                 $cfg = $C->{$type}                      ||= {};
4976         }
4977         else {
4978                 $c = $Global::CodeDef;
4979                 $cfg =${"Global::$type"}        ||= {};
4980         }
4981
4982         my $ref;
4983         my $r;
4984
4985         return unless $r = $c->{$type};
4986         return unless $ref = $r->{Routine};
4987
4988         for(keys %$ref ) {
4989                 $cfg->{$_} = $ref->{$_};
4990                 }
4991 }
4992
4993 sub global_map_codedef {
4994         my $type = shift;
4995         map_codedef_to_directive($type);
4996         Vend::Dispatch::update_global_actions();
4997 }
4998
4999 my %MappedInit = (
5000         Filter => sub {
5001
5002 #::logDebug("Called filter MappedInit");
5003                 return if $C;
5004 #::logDebug("No \$C");
5005
5006                 my $c = $Global::CodeDef;
5007                 my $typeref = $c->{Filter}
5008                         or return;
5009                 my $submap = $typeref->{Routine}
5010                         or return;
5011
5012                 for(keys %$submap) {
5013 #::logDebug("Setting Filter for $_=$submap->{$_}");
5014                         $Vend::Interpolate::Filter{$_} = $submap->{$_};
5015                 }
5016                 if (my $ref = $typeref->{Alias}) {
5017 #::logDebug("We have an Alias ref");
5018                         for(keys %$ref) {
5019 #::logDebug("Checking Alias ref for $_=$ref->{$_}");
5020                                 if (exists $Vend::Interpolate::Filter{$ref->{$_}}) {
5021 #::logDebug("Setting Alias ref to $Vend::Interpolate::Filter{$ref->{$_}}");
5022                                         $submap->{$_}
5023                                                 = $Vend::Interpolate::Filter{$_}
5024                                                 = $Vend::Interpolate::Filter{$ref->{$_}};
5025                                 }
5026                         }
5027                 }
5028 #::logDebug("Filter is " . ::uneval(\%Vend::Interpolate::Filter));
5029         },
5030         ItemAction      => \&map_codedef_to_directive,
5031         OrderCheck      => \&map_codedef_to_directive,
5032         ActionMap       => \&global_map_codedef,
5033         FormAction      => \&global_map_codedef,
5034         Widget          => sub {
5035                                                 return unless $Vend::Cfg;
5036                                                 $Vend::UserWidget = map_widgets();
5037                                                 $Vend::UserWidgetDefault = map_widget_defaults();
5038                                         },
5039         UserTag         => sub {
5040                                                 return if $C;
5041                                                 return unless $Vend::Cfg;
5042                                                 Vend::Parse::add_tags($Global::UserTag);
5043                                         },
5044 );
5045