line
stmt
bran
cond
sub
pod
time
code
1
package App::Framework::Feature::Config ;
2
3
=head1 NAME
4
5
App::Framework::Feature::Config - Configuration file read/write
6
7
=head1 SYNOPSIS
8
9
use App::Framework '+Config' ;
10
11
12
=head1 DESCRIPTION
13
14
Provides a standard interface for reading/writing application configuration files. When this feature is included into an application, it attempts to read
15
a configuration file for the application (which may be stored in one of severeal places). If found, the configuartion file is processed and may update
16
the application options (see L).
17
18
Also, an application may create one or more extra instances of the feature to read addtional configuration files.
19
20
21
=head2 Configuration File Definition
22
23
Configuration files are text files containing variable / value pairs. Optionally these variable/value pairs may be gouped into 'sections' (see L).
24
25
26
=head3 Simple format
27
28
The simplest format consists of an optional description line followed immediately by a variable/value setting:
29
30
# description
31
var=value
32
33
(NOTE: There can be no empty lines between the description "comment" and the variable).
34
35
=head3 Extended format
36
37
An alternative to the simple format is as shown below. This contains additional information useful for checking the value setting.
38
39
## Summary: Configuration for Apache 2
40
## Type: s
41
#
42
# Here you can name files, separated by spaces, that should be Include'd from
43
# httpd.conf.
44
#
45
# This allows you to add e.g. VirtualHost statements without touching
46
# /etc/apache2/httpd.conf itself, which makes upgrading easier.
47
#
48
apache_include_files="mod_dav"
49
50
The lines prefixed by ## are extra information about the variable and are used to specify a summary, and a variable
51
type. The extra information prefixed by # is used as the description. The above example will be
52
shown in the application man page as:
53
54
-apache_include_files [Default: "mod_dav"]
55
Config option:Here you can name files, separated by spaces, that
56
should be Include'd from httpd.conf. This allows you to add e.g.
57
VirtualHost statements without touching /etc/apache2/httpd.conf
58
itself, which makes upgrading easier.
59
60
Any configuration variables specified in this manner will automatically be put into the application's options, but will also be available
61
via the application's 'Config' feature.
62
63
64
=head3 Sections
65
66
Each section is defined by a string contained within '[]'. Where there are multiple sections with the same name, they are added to an array. All variables
67
defined before the sections are treated as "global".
68
69
global=string
70
71
[top]
72
a=1
73
74
[instance]
75
a=11
76
77
[instance]
78
a=22
79
80
The above example will be stored as the HASH:
81
82
{
83
global => 'string'
84
top => [
85
{
86
a => 1
87
}
88
]
89
instance => [
90
{
91
a => 11
92
},
93
{
94
a => 22
95
}
96
],
97
}
98
99
Even if a section has only one instance, it is always stored as an array.
100
101
102
=head2 Configuration as Options
103
104
As stated above, any variables defined in the configuration file before the sections are treated as "global" (see L). These global variables
105
have the additional property that they are automatically treated like options definitions (see L).
106
107
This means that the global variables are indistinguishable from options (in fact all of the options variables appear in the global area of the configurations and
108
vice versa). Also, you do not need to specify options in the application script - you can just define them once in the configuration file (although see L).
109
110
=head2 File Paths
111
112
The configuration file is searched for using the path specification. This path is actually one or more paths, specified
113
in the order in which to search for the configuration file. The search is stopped as soon as the first valid file is found.
114
115
The application configuration search path is set to the following default, unless it is over-ridden by either the application
116
script or by the user (via command line options):
117
118
=over 4
119
120
=item * $HOME/$app_dir
121
122
User-specific configuration. $HOME is replaced with the user's home directory, and $app_dir is replaced by ".I" (or "I" on Windows)
123
where I is the name of the script.
124
125
This allows users to set up their own settings.
126
127
=item * $SYSTEM/$name
128
129
System configuration. $SYSTEM is replaced with "/etc" (or "C:" on Windows), and $name is replaced by the name of the script.
130
131
This allows sysadmins to set up a common set of settings.
132
133
=item * $app_path/config
134
135
Application-specific configuration. $app_path is replaced by the path to the installed script.
136
137
This allows script developers to bundle their settings with the installed script.
138
139
=back
140
141
As an example, the script 'test_script' installed on a Linux under '/usr/local/bin' will, by default, have the following search path:
142
143
$HOME/.test_script
144
/etc/test_script
145
/usr/local/bin/config
146
147
In addition to the search path described above, there is also a write search path. This path is searched until a file
148
(and it's path) can be written to by the script user. It is set, by default, to:
149
150
=over 4
151
152
=item * $HOME/$app_dir
153
154
User-specific configuration. $HOME is replaced with the user's home directory, and $app_dir is replaced by ".I" (or "I" on Windows)
155
where I is the name of the script.
156
157
This allows users to set up their own settings.
158
159
=item * $SYSTEM/$name
160
161
System configuration. $SYSTEM is replaced with "/etc" (or "C:" on Windows), and $name is replaced by the name of the script.
162
163
This allows sysadmins to set up a common set of settings.
164
165
=back
166
167
(i.e. the same as the read path, but without the application-bundle directory).
168
169
Uses L to provide the path search.
170
171
172
=head2 Creating Config Files
173
174
You can, of course, just write your config files from scratch. Alternatively, if you predominantly use "global" settings, then you specify
175
them as application options (L). Run your script with '-config_write' and it will automatically create
176
a formatted configuration file (see L for other command line settings).
177
178
=head2 Addtional Config Instances
179
180
In addition to having the application tied in with it's own configuration file, you can create multiple extra configuration files and read/write
181
then using this feature. To do this, create a new App::Framework::Feature::Config object instance per configuration file. You can then access
182
the contents of the file using the object's methods.
183
184
For example:
185
186
sub app
187
{
188
my ($app, $opts_href, $args_href) = @_ ;
189
190
## use application config object to create a new one
191
my $new_cfg = $app->feature('Config')->new(
192
'filename' => 'some_file.conf',
193
'path' => '$HOME,/etc/new_config',
194
'write_path' => '$HOME',
195
) ;
196
$new_cfg->read() ;
197
198
# do stuff with configuration
199
...
200
201
# (debug) show configuration
202
$app->prt_data("Readback config=", $new_cfg->config) ;
203
204
## write out file
205
$new_cfg->write() ;
206
}
207
208
209
=head2 Raw Configuration HASH
210
211
Configuration files are stored in a HASH, where the keys are the variable names and the values are a HASH of information for
212
that variable:
213
214
'summary' => Summary string
215
'default' => Default value
216
'description' => Description string
217
'type' => Variable option type (s, i, f)
218
'value' => Variable value
219
220
221
=cut
222
223
2
2
18062
use strict ;
2
7
2
213
224
225
our $VERSION = "0.11" ;
226
227
#============================================================================================
228
# USES
229
#============================================================================================
230
2
2
15
use App::Framework::Feature ;
2
5
2
58
231
2
2
17
use App::Framework::Base ;
2
12
2
139
232
2
2
37795
use App::Framework::Base::SearchPath ;
2
9
2
941
233
234
#============================================================================================
235
# OBJECT HIERARCHY
236
#============================================================================================
237
our @ISA = qw(App::Framework::Feature) ;
238
239
#============================================================================================
240
# GLOBALS
241
#============================================================================================
242
243
=head2 FIELDS
244
245
The following fields should be defined either in the call to 'new()', as part of a 'set()' call, or called by their accessor method
246
(which is the same name as the field):
247
248
249
=over 4
250
251
=item B - Name of config file
252
253
User-specified config filename. This is searched for using the search path
254
255
256
=item B - search path
257
258
A comma seperated list (in scalar context), or an ARRAY ref list of paths to be searched (for a file).
259
260
=item B - search path for writing
261
262
A comma seperated list (in scalar context), or an ARRAY ref list of paths to be searched (for a file) when writing. If not set, then
263
B is used.
264
265
=item B - configuration file path
266
267
Created when config file is read. Full path of configuration file accessed in last read or write.
268
269
270
=item B - section names list
271
272
Created when config file is read. ARRAY ref list of any section names.
273
274
275
=item B - configuration HASH ref
276
277
Created when config file is read. This is a HASH ref to the raw configuration file entries
278
279
=back
280
281
=cut
282
283
my %FIELDS = (
284
# user settings
285
'filename' => undef,
286
287
# Created during execution
288
'configuration' => {},
289
'file_path' => undef,
290
'sections' => [],
291
292
'_search_path' => undef,
293
) ;
294
295
296
=head2 ADDITIONAL COMMAND LINE OPTIONS
297
298
This feature adds the following additional command line options to any application:
299
300
=over 4
301
302
=item B<-config_path> - Config file path
303
304
Comma/semicolon separated list of search paths for the config file
305
306
=item B<-config_writepath> - Config file write path
307
308
Comma/semicolon separated list of paths for writing the config file. Uses -config_path setting if not specified.
309
310
=item B<-config> - Config filename
311
312
Specify the configuration filename to use
313
314
=item B<-config_write> - Write config file
315
316
When specified, writes the configuration file using the write path
317
318
=back
319
320
=cut
321
322
323
my $OPT_CFGPATH = "config_path" ;
324
my $OPT_CFGWRPATH = "config_writepath" ;
325
my $OPT_CFG = "config" ;
326
my $OPT_CFGWR = "config_write" ;
327
328
my $OPT_CFGPATH_AREF =
329
["$OPT_CFGPATH=s", 'Config file path', 'Comma/semicolon separated list of search paths for the config file', ] ;
330
my $OPT_CFGWRPATH_AREF =
331
["$OPT_CFGWRPATH=s", 'Config file write path', 'Comma/semicolon separated list of paths for writing the config file', ] ;
332
my $OPT_CFG_AREF =
333
["$OPT_CFG=s", 'Config file name', 'Config filename'] ;
334
my $OPT_CFGWR_AREF =
335
["$OPT_CFGWR", 'Write config file', 'When specified, writes the configuration file using the write path'] ;
336
337
# Set of default options
338
my @EXTRA_OPTIONS = (
339
$OPT_CFGPATH_AREF,
340
$OPT_CFGWRPATH_AREF,
341
$OPT_CFG_AREF,
342
$OPT_CFGWR_AREF,
343
) ;
344
345
my @CONFIG_OPTIONS = (
346
$OPT_CFGPATH,
347
$OPT_CFGWRPATH,
348
$OPT_CFG,
349
$OPT_CFGWR,
350
) ;
351
352
#============================================================================================
353
354
=head2 CONSTRUCTOR
355
356
=over 4
357
358
=cut
359
360
#============================================================================================
361
362
363
=item B< new([%args]) >
364
365
Create a new Config object.
366
367
The %args are specified as they would be in the B method, for example:
368
369
'mmap_handler' => $mmap_handler
370
371
The full list of possible arguments are :
372
373
'fields' => Either ARRAY list of valid field names, or HASH of field names with default values
374
375
=cut
376
377
sub new
378
{
379
2
2
1
51
my ($obj, %args) = @_ ;
380
381
2
66
45
my $class = ref($obj) || $obj ;
382
383
# create search path object
384
2
46
my $search_obj = App::Framework::Base::SearchPath->new(%args) ;
385
386
# Create object
387
2
55
my $this = $class->SUPER::new(%args,
388
'priority' => $App::Framework::Base::PRIORITY_SYSTEM + 15, # needs to be after options, but before data
389
'registered' => [qw/go_entry getopts_entry application_entry/],
390
'_search_path' => $search_obj,
391
) ;
392
393
## Map the search path object's methods into this object
394
2
11
foreach my $method (qw/path write_path read_filepath write_filepath/)
395
{
396
2
2
19
no warnings 'redefine';
2
6
2
171
397
2
2
18
no strict 'refs';
2
5
2
12094
398
399
8
128
*{ __PACKAGE__."::${method}"} = sub {
400
13
13
19
my $this = shift ;
401
13
73
$this->_dbg_prt( ["Config: calling searchpath->$method() ", \@_] ) ;
402
13
64
return $search_obj->$method(@_) ;
403
8
43
};
404
}
405
406
## If associated with an app, then add the app's variables to the search path
407
2
57
my $app = $this->app ;
408
2
100
7
if ($app)
409
{
410
## only interested in scalar values
411
1
16
my %vars = $app->vars() ;
412
1
4
my %app_vars ;
413
1
6
foreach my $var (keys %vars)
414
{
415
32
100
66
109
$app_vars{$var} = $vars{$var} if !ref($vars{$var}) || ref($vars{$var}) eq 'SCALAR' ;
416
}
417
1
32
$search_obj->env(\%app_vars) ;
418
}
419
420
2
11
return($this) ;
421
}
422
423
424
425
#============================================================================================
426
427
=back
428
429
=head2 CLASS METHODS
430
431
=over 4
432
433
=cut
434
435
#============================================================================================
436
437
#-----------------------------------------------------------------------------
438
439
=item B< init_class([%args]) >
440
441
Initialises the Config object class variables.
442
443
=cut
444
445
sub init_class
446
{
447
2
2
1
39
my $class = shift ;
448
2
14
my (%args) = @_ ;
449
450
# Add extra fields
451
2
35
$class->add_fields(\%FIELDS, \%args) ;
452
453
# init class
454
2
24
$class->SUPER::init_class(%args) ;
455
456
}
457
458
#============================================================================================
459
460
=back
461
462
=head2 OBJECT DATA METHODS
463
464
=over 4
465
466
=cut
467
468
#============================================================================================
469
470
#----------------------------------------------------------------------------
471
472
=item B
473
474
Overrides the parent 'set()' method to send the parameters off to the L object
475
as well as itself.
476
477
=cut
478
479
sub set
480
{
481
6
6
1
9
my $this = shift ;
482
6
40
my (%args) = @_ ;
483
484
6
100
22
if (keys %args)
485
{
486
487
4
40
$this->_dbg_prt( ["settings args = ", \%args] ) ;
488
489
# send to search path obj (if created yet)
490
4
163
my $search_obj = $this->_search_path ;
491
4
50
14
$this->_dbg_prt( ["settings args on search_obj\n"] ) if $search_obj ;
492
4
50
11
$search_obj->set(%args) if $search_obj ;
493
494
# handle the args
495
4
49
$this->SUPER::set(%args) ;
496
}
497
498
}
499
500
#============================================================================================
501
502
=back
503
504
=head2 OBJECT METHODS
505
506
=over 4
507
508
=cut
509
510
#============================================================================================
511
512
513
#-----------------------------------------------------------------------------
514
515
=item B< go_entry() >
516
517
Application hook: When application calls go() set up config options.
518
519
=cut
520
521
sub go_entry
522
{
523
1
1
1
4
my $this = shift ;
524
525
1
4
$this->_dbg_prt( ["Config: go_entry()\n"] ) ;
526
527
## must be under application to get here...
528
1
24
my $app = $this->app ;
529
530
1
33
9
my $home = $ENV{'HOME'} || $ENV{'USERPROFILE'} || "$ENV{'HOMEDRIVE'}$ENV{'HOMEPATH'}" ;
531
1
28
my $app_name = $app->name ;
532
1
28
my $app_path = $app->progpath ;
533
534
1
3
my $app_dir = ".$app_name" ;
535
1
5
my $sys = "/etc" ;
536
1
50
11
if ($^O =~ /MSWin/)
537
{
538
0
0
$app_dir = "$app_name" ;
539
0
0
$sys = "c:/" ;
540
}
541
542
## Set up write path, if not already set
543
1
4
my $write_path = $this->write_path() ;
544
1
5
$this->_dbg_prt( ["current write path=$write_path\n"] ) ;
545
1
50
4
unless ($write_path)
546
{
547
1
6
$this->_dbg_prt( ["set default write path\n"] ) ;
548
1
6
$this->write_path("$home/$app_dir;$sys/$app_name") ;
549
}
550
551
## Set up search path, if not already set
552
1
6
my $path = $this->path() ;
553
1
6
$this->_dbg_prt( ["current path=$path\n"] ) ;
554
1
50
4
unless ($path)
555
{
556
1
5
$this->_dbg_prt( ["set default path\n"] ) ;
557
1
7
$this->path("$home/$app_dir;$sys/$app_name;$app_path/config") ;
558
}
559
560
## Set up filename, if not already set
561
1
50
29
my $filename = $this->filename() || '' ;
562
1
8
$this->_dbg_prt( ["current filename=$filename\n"] ) ;
563
1
50
6
unless ($filename)
564
{
565
1
5
$this->_dbg_prt( ["set default filename\n"] ) ;
566
1
36
$this->filename("$app_name.conf") ;
567
}
568
569
# Set defaults
570
1
4
$OPT_CFGPATH_AREF->[3] = $this->path() ;
571
1
27
$OPT_CFG_AREF->[3] = $this->filename() ;
572
1
5
$OPT_CFGWRPATH_AREF->[3] = $this->write_path() ;
573
574
## Set options
575
1
7
$this->_dbg_prt( ["$this go_entry - append_options\n"] ) ;
576
1
50
4
$this->dump_callstack() if $this->debug ;
577
1
13
$app->feature('Options')->append_options(\@EXTRA_OPTIONS) ;
578
579
}
580
581
582
#-----------------------------------------------------------------------------
583
584
=item B< getopts_entry() >
585
586
Application hook: When application calls getopts() initialise the object and read config.
587
588
=cut
589
590
sub getopts_entry
591
{
592
1
1
1
2
my $this = shift ;
593
594
1
9
$this->_dbg_prt( ["Config: getopts_entry()\n"] ) ;
595
596
## must be under application to get here...
597
1
28
my $app = $this->app ;
598
599
## do first pass at getting options
600
1
8
my @saved_argv = @ARGV ;
601
602
## Allow any config command line options through, otherwise just get option defaults
603
1
4
@ARGV=() ;
604
1
5
for (my $argc=0; $argc < scalar(@saved_argv); ++$argc)
605
{
606
7
100
109
if ($saved_argv[$argc] =~ m/^\-($OPT_CFGPATH|$OPT_CFGWRPATH|$OPT_CFG)$/)
607
{
608
2
4
push @ARGV, $saved_argv[$argc] ;
609
2
7
push @ARGV, $saved_argv[++$argc] ;
610
}
611
}
612
613
# Parse options using GetOpts
614
1
5
my $opt = $app->feature('Options') ;
615
1
6
my $ok = $opt->get_options() ;
616
617
# If ok, we can continue...
618
1
50
4
if ($ok)
619
{
620
## Now got the actual config file path we want to use (either from latest options or from command line)...
621
622
## Get filename & search path
623
1
8
my $filename = $opt->option($OPT_CFG) ;
624
1
5
my $path = $opt->option($OPT_CFGPATH) ;
625
1
4
my $wr_path = $opt->option($OPT_CFGWRPATH) ;
626
627
## update config to reflect latest settings
628
1
7
$this->path($path) ;
629
1
25
$this->filename($filename) ;
630
1
4
$this->write_path($wr_path) ;
631
632
1
7
$this->_dbg_prt( ["Config: options path=$path filename=$filename write path=$wr_path\n"] ) ;
633
1
3
$this->_dbg_prt( ["Config: current path=",$this->path," filename=",$this->filename, " write path=",$this->write_path,"\n"] ) ;
634
635
## read config
636
1
9
$this->read() ;
637
638
1
2
my @new_options ;
639
640
1
56
my $complete_config = $this->configuration ;
641
1
6
$this->_dbg_prt( ["Config: config=", $complete_config] ) ;
642
643
## Set default values in options based on the config file
644
1
5
my %config = $this->get_raw_hash() ;
645
646
1
6
$this->_dbg_prt( ["Config: top-level hash=", \%config] ) ;
647
1
4
foreach my $field (keys %config)
648
{
649
11
66
34
my $default = $config{$field}{'value'} || $config{$field}{'default'} ;
650
11
42
my $opt_href = $opt->modify_default($field, $default) ;
651
652
# if not got this option, need to add it
653
11
100
31
unless ($opt_href)
654
{
655
# [ , , ]
656
8
12
my $spec = "$field" ;
657
8
100
24
$spec .= "=$config{$field}{type}" if $config{$field}{type} ;
658
659
8
13
my $summary = $config{$field}{'summary'} ;
660
8
9
my $description = "" ;
661
8
50
27
$description = "Config option:" . $config{$field}{'description'} if $config{$field}{'description'} ;
662
663
8
27
push @new_options, [$spec, $summary, $description, $default] ;
664
}
665
}
666
667
## append new options
668
1
50
5
if (@new_options)
669
{
670
1
6
$opt->append_options(\@new_options) ;
671
}
672
}
673
674
# restore args and allow Options feature to process them properly
675
1
21
@ARGV = @saved_argv ;
676
677
}
678
679
#-----------------------------------------------------------------------------
680
681
=item B< application_entry() >
682
683
Application hook: When application calls application() check options.
684
685
=cut
686
687
sub application_entry
688
{
689
1
1
1
2
my $this = shift ;
690
691
1
6
$this->_dbg_prt( ["Config: application_entry()\n"] ) ;
692
693
## must be under application to get here...
694
1
35
my $app = $this->app ;
695
1
106
my $opt = $this->app->feature('Options') ;
696
697
1
39
my $config_href = $this->configuration ;
698
699
## Update config from options
700
1
3
my $order=1 ;
701
1
23
my $options_fields_aref = $opt->option_names() ;
702
1
7
foreach my $option_name (@$options_fields_aref)
703
{
704
21
52
my $option_entry_href = $opt->option_entry($option_name) ;
705
706
# skip developer options
707
21
100
55
next if $option_entry_href->{developer} ;
708
709
# skip help options
710
## Remove all 'Pod' options
711
18
100
47
next if $option_entry_href->{'owner'} =~ m/::Pod$/ ;
712
713
15
57
$this->_dbg_prt( [" + CFG Option=$option_name\n"] ) ;
714
715
# copy option settings
716
15
100
43
if (exists($config_href->{$option_name}))
717
{
718
11
46
$this->_dbg_prt( [" + + Already got option in config: ", $config_href->{$option_name}, "Option entry: ", $option_entry_href] ) ;
719
720
# update value
721
11
33
$config_href->{$option_name}{'value'} = $opt->option($option_name) ;
722
11
16
foreach my $field (qw/summary description default/)
723
{
724
33
100
93
$config_href->{$option_name}{$field} = $option_entry_href->{$field}
725
if !defined($config_href->{$option_name}{$field}) ;
726
}
727
11
21
my $type = $option_entry_href->{type} ;
728
11
50
21
$type = $option_entry_href->{dest_type} if $option_entry_href->{dest_type} ;
729
11
50
37
$config_href->{$option_name}{type} = $type
730
if !defined($config_href->{$option_name}{type}) ;
731
732
733
}
734
else
735
{
736
4
12
$this->_dbg_prt( [" + + Creating new config entry\n"] ) ;
737
738
4
9
my $type = $option_entry_href->{type} ;
739
4
50
11
$type .= $option_entry_href->{dest_type} if $option_entry_href->{dest_type} ;
740
741
4
11
$config_href->{$option_name} = $this->_new_cfg(
742
$option_name,
743
$opt->option($option_name),
744
$option_entry_href->{summary},
745
$option_entry_href->{description},
746
$type,
747
$option_entry_href->{default},
748
$order++,
749
) ;
750
}
751
}
752
753
1
5
$this->_dbg_prt( ["write config option. Updated config=", $config_href] ) ;
754
755
## update
756
1
24
$this->configuration($config_href) ;
757
758
759
## Handle special options
760
1
50
3
if ($opt->option($OPT_CFGWR))
761
{
762
763
0
0
$this->_dbg_prt( ["write config option. Current config=", $config_href] ) ;
764
765
## write out config file
766
0
0
$this->write() ;
767
}
768
769
}
770
771
#----------------------------------------------------------------------------
772
773
=item B< config([%args]) >
774
775
Returns the config object. If %args are specified they are used to set the L
776
777
=cut
778
779
sub config
780
{
781
0
0
1
0
my $this = shift ;
782
0
0
my (%args) = @_ ;
783
784
0
0
0
$this->set(%args) if %args ;
785
0
0
return $this ;
786
}
787
788
#----------------------------------------------------------------------------
789
790
=item B< Config([%args]) >
791
792
Alias to L
793
794
=cut
795
796
*Config = \&config ;
797
798
#----------------------------------------------------------------------------
799
800
=item B< read([%args]) >
801
802
Read in the config file (located somewhere in the searchable path). Expects the filename and path
803
fields to already have been set. Optionally can specify these setting as part of the %args hash.
804
805
Updates the field 'file_path' with the full path to the read config file.
806
807
Returns the top-level HASH ref.
808
809
=cut
810
811
sub read
812
{
813
2
2
1
8
my $this = shift ;
814
2
5
my (%args) = @_ ;
815
816
2
10
$this->_dbg_prt( ["Config: read() args=", \%args] ) ;
817
818
2
9
$this->set(%args) ;
819
820
## Read the file - or barf
821
822
2
9
$this->_dbg_prt( ["calling read_filepath()...\n"] ) ;
823
824
# get file path
825
2
77
my $read_filepath = $this->read_filepath($this->filename) ;
826
827
2
23
$this->_dbg_prt( ["Config: read() file=$read_filepath\n"] ) ;
828
829
# if none found, just stop
830
2
50
12
if ($read_filepath)
831
{
832
2
152
$this->file_path($read_filepath) ;
833
834
# process file into hash
835
2
32
my %new_config = $this->_process($read_filepath) ;
836
837
# add to existing contents
838
2
19
$this->add_config(%new_config) ;
839
840
}
841
842
# return top-level hash
843
2
16
return $this->get_hash() ;
844
}
845
846
#----------------------------------------------------------------------------
847
848
=item B< write() >
849
850
Writes the configuration information to the specified file.
851
852
Updates the field 'file_path' with the full path to the written config file.
853
854
=cut
855
856
sub write
857
{
858
1
1
1
555
my $this = shift ;
859
860
## write out config - or barf
861
862
# get file path
863
1
36
my $write_filepath = $this->write_filepath($this->filename) ;
864
1
29
$this->file_path($write_filepath) ;
865
866
# write out config
867
1
4
$this->_write($write_filepath) ;
868
}
869
870
871
#----------------------------------------------------------------------------
872
873
=item B< add_config(%config) >
874
875
Adds the contents of the specified HASH to the current configuration settings.
876
877
=cut
878
879
sub add_config
880
{
881
2
2
1
6
my $this = shift ;
882
2
11
my (%config) = @_ ;
883
884
2
57
my $config_href = $this->configuration ;
885
886
## merge hashes
887
2
4
my %merged ;
888
2
9
foreach my $href ($config_href, \%config)
889
{
890
4
20
while (my ($k, $v) = each %$href)
891
{
892
30
81
$merged{$k} = $v ;
893
}
894
}
895
896
2
56
$this->configuration(\%merged) ;
897
}
898
899
#----------------------------------------------------------------------------
900
901
=item B< clear_config() >
902
903
Clear out the current configuration settings.
904
905
=cut
906
907
sub clear_config
908
{
909
0
0
1
0
my $this = shift ;
910
911
0
0
$this->configuration({}) ;
912
}
913
914
#----------------------------------------------------------------------------
915
916
=item B< get_hash([$name]) >
917
918
Returns a "flat" HASH (of variable/value pairs) where any arrays are removed.
919
If the I<$name> is specified, returns the HASH that the named key refers to,
920
unrolling it if it is an array.
921
922
Returns an empty HASH if I<$name> does not exist.
923
924
=cut
925
926
sub get_hash
927
{
928
8
8
1
2628
my $this = shift ;
929
8
19
my ($name) = @_ ;
930
931
## Get raw entries
932
8
32
my %raw = $this->get_raw_hash($name) ;
933
934
## convert
935
8
34
my %config = $this->raw_to_vals(\%raw) ;
936
937
8
69
return %config ;
938
}
939
940
#----------------------------------------------------------------------------
941
942
=item B< get_array([$name]) >
943
944
Returns an ARRAY of HASHes of variable/value pairs. If the I<$name> is specified, returns
945
the ARRAY that the named key refers to. In either case, if the item is not
946
an array, then it is rolled into a single entry ARRAY.
947
948
Returns an empty ARRAY if I<$name> does not exist.
949
950
=cut
951
952
sub get_array
953
{
954
10
10
1
20336
my $this = shift ;
955
10
17
my ($name) = @_ ;
956
957
10
100
41
$name ||= '' ;
958
10
11
my @config ;
959
960
## Get raw entries
961
10
31
my @to_copy = $this->get_raw_array($name) ;
962
963
10
66
$this->_dbg_prt( ["get_array($name) to_copy=", \@to_copy] ) ;
964
965
966
## copy values
967
10
28
foreach my $href (@to_copy)
968
{
969
22
47
my %config = $this->raw_to_vals($href) ;
970
22
69
push @config, \%config ;
971
}
972
973
10
44
$this->_dbg_prt( ["get_array($name) - array=", \@config] ) ;
974
975
10
53
return @config ;
976
}
977
978
979
#----------------------------------------------------------------------------
980
981
=item B< get_raw_hash([$name]) >
982
983
Returns a "flat" HASH (containing full config entry) where any arrays are removed.
984
If the I<$name> is specified, returns the HASH that the named key refers to,
985
unrolling it if it is an array.
986
987
Returns an empty HASH if I<$name> does not exist.
988
989
=cut
990
991
sub get_raw_hash
992
{
993
10
10
1
15
my $this = shift ;
994
10
16
my ($name) = @_ ;
995
996
10
16
my %config ;
997
998
# start at top
999
10
314
my $config_href = $this->configuration ;
1000
1001
# see if we want a sub-branch
1002
10
100
66
54
if ($name && exists($config_href->{$name}))
1003
{
1004
4
9
$config_href = $config_href->{$name} ;
1005
}
1006
1007
# Flatten array - copy over just those key/scalar pairs
1008
# instance => [
1009
# {
1010
# {a} => {'value'=>11, ...}
1011
# },
1012
# {
1013
# {a} => {'value'=>22, ...}
1014
# }
1015
# ],
1016
10
22
my @array = ($config_href) ;
1017
10
100
33
if (ref($config_href) eq 'ARRAY')
1018
{
1019
4
10
@array = @$config_href ;
1020
}
1021
1022
# now process from this point
1023
10
27
foreach my $href (@array)
1024
{
1025
10
48
foreach my $key (keys %$href)
1026
{
1027
# copy over just those key/scalar pairs
1028
106
100
209
if (ref($href->{$key}) eq 'HASH')
1029
{
1030
82
170
$config{$key} = $href->{$key} ;
1031
}
1032
}
1033
}
1034
1035
10
105
return %config ;
1036
}
1037
1038
#----------------------------------------------------------------------------
1039
1040
=item B< get_raw_array([$name]) >
1041
1042
Returns an ARRAY of HASHes (containing full config entry). If the I<$name> is specified, returns
1043
the ARRAY that the named key refers to. In either case, if the item is not
1044
an array, then it is rolled into a single entry ARRAY.
1045
1046
Returns an empty ARRAY if I<$name> does not exist.
1047
1048
=cut
1049
1050
sub get_raw_array
1051
{
1052
14
14
1
19
my $this = shift ;
1053
14
21
my ($name) = @_ ;
1054
1055
14
100
35
$name ||= '' ;
1056
1057
# start at top
1058
14
554
my $config_href = $this->configuration ;
1059
1060
# see if we want a sub-branch
1061
14
100
66
78
if ($name && exists($config_href->{$name}))
1062
{
1063
12
26
$config_href = $config_href->{$name} ;
1064
}
1065
1066
# now process from this point
1067
14
27
my @config ;
1068
14
100
38
if (ref($config_href) eq 'ARRAY')
1069
{
1070
12
36
@config = @$config_href ;
1071
}
1072
else
1073
{
1074
2
4
@config = ($config_href) ;
1075
}
1076
1077
14
36
return @config ;
1078
}
1079
1080
1081
#----------------------------------------------------------------------------
1082
1083
=item B< raw_to_vals($href) >
1084
1085
Given a HASH ref containing hashes of full config entries, convert into a hash
1086
of variable/value pairs
1087
1088
=cut
1089
1090
sub raw_to_vals
1091
{
1092
30
30
1
44
my $this = shift ;
1093
30
40
my ($href) = @_ ;
1094
1095
# copy values
1096
30
53
my %config ;
1097
30
96
foreach my $key (keys %$href)
1098
{
1099
154
532
$this->_dbg_prt( [" + key=$key\n"] ) ;
1100
# copy over just those key/scalar pairs
1101
154
100
538
if (ref($href->{$key}) eq 'HASH')
1102
{
1103
146
350
$config{$key} = $href->{$key}{'value'} ;
1104
146
100
369
my $val = $href->{$key}{'value'} || '';
1105
146
513
$this->_dbg_prt( [" + $key = $val\n"] ) ;
1106
}
1107
}
1108
1109
30
215
return %config ;
1110
}
1111
1112
1113
1114
1115
#============================================================================================
1116
# PRIVATE METHODS
1117
#============================================================================================
1118
1119
# # TAG: authenticate_cache_garbage_interval
1120
# # The time period between garbage collection across the username cache.
1121
# # This is a tradeoff between memory utilization (long intervals - say
1122
# # 2 days) and CPU (short intervals - say 1 minute). Only change if you
1123
# # have good reason to.
1124
# #
1125
# #Default:
1126
# # authenticate_cache_garbage_interval 1 hour
1127
# authenticate_cache_garbage_interval 1 hour
1128
1129
# ## Path: Network/WWW/Apache2
1130
# ## Description: Configuration for Apache 2
1131
# ## Type: string
1132
# ## Default: ""
1133
# ## ServiceRestart: apache2
1134
# #
1135
# # Here you can name files, separated by spaces, that should be Include'd from
1136
# # httpd.conf.
1137
# #
1138
# # This allows you to add e.g. VirtualHost statements without touching
1139
# # /etc/apache2/httpd.conf itself, which makes upgrading easier.
1140
# #
1141
# APACHE_CONF_INCLUDE_FILES=""
1142
1143
1144
1145
#----------------------------------------------------------------------------
1146
#
1147
#=item B< _process($filename) >
1148
#
1149
#Read in the config file (located somewhere in the searchable path).
1150
#
1151
#Returns a HASH of the config.
1152
#
1153
#=cut
1154
#
1155
sub _process
1156
{
1157
2
2
7
my $this = shift ;
1158
2
5
my ($filename) = @_ ;
1159
2
6
my %config ;
1160
my %sections ;
1161
0
0
my @sections ;
1162
2
6
my $order=1 ;
1163
1164
2
18
$this->_dbg_prt( ["Config: _process($filename)\n"] ) ;
1165
1166
2
50
234
open my $fh, "<$filename" or $this->throw_fatal("Feature:Config : unable to read file $filename : $!") ;
1167
2
7
my $line ;
1168
my %params ;
1169
2
8
my $href = \%config ;
1170
2
34732
while (defined($line = <$fh>))
1171
{
1172
375
479
chomp $line ;
1173
1174
375
1860
$this->_dbg_prt( [" + <$line>\n"] ) ;
1175
375
1957
$this->_dbg_prt( ["Params:", \%params] ) ;
1176
1177
375
1050
$line =~ s/^\s+// ;
1178
375
951
$line =~ s/\s+$// ;
1179
375
100
858
unless ($line)
1180
{
1181
## Empty line, see if we were creating a new entry - if so, save it
1182
57
50
123
if ($params{name})
1183
{
1184
0
0
$href->{$params{name}} = $this->_new_cfg(
1185
$params{name},
1186
undef,
1187
$params{summary},
1188
$params{description},
1189
$params{type},
1190
$params{default},
1191
$order++,
1192
) ;
1193
1194
}
1195
1196
# clear params ready for new entry
1197
57
85
foreach my $param (qw/summary description type name default/)
1198
{
1199
285
445
$params{$param} = undef ;
1200
}
1201
1202
57
195
next ;
1203
}
1204
1205
## Parameter setting
1206
#
1207
# e.g.
1208
# ## Description: Configuration for Apache 2
1209
#
1210
318
100
1502
if ($line =~ /^##\s*([^\s:]+)(?:\s*:){0,1}(.*)/)
100
100
1211
{
1212
75
258
my ($var, $val) = ($1, $2) ;
1213
75
388
$this->_dbg_prt( [" + Param: <$var> = <$val>\n"] ) ;
1214
1215
75
294
$val =~ s/^\s+// ;
1216
75
174
$val =~ s/\s+$// ;
1217
75
253
$params{lc $var} = $val ;
1218
}
1219
1220
## Description
1221
elsif ($line =~ /^#\s*(\S+.*)/)
1222
{
1223
68
228
$params{'description'} .= "$1\n" ;
1224
1225
68
322
$this->_dbg_prt( [" + Description: $params{'description'}\n"] ) ;
1226
}
1227
1228
## Section
1229
elsif ($line =~ /^\s*\[([^\]]+)\]/)
1230
{
1231
## new section
1232
20
42
my $section = $1 ;
1233
1234
# see if already seen
1235
20
100
46
if (!exists($sections{$section}))
1236
{
1237
# Add to section list
1238
8
15
push @sections, $section ;
1239
8
25
$sections{$section} = 1 ;
1240
}
1241
1242
# new hash for storing vars
1243
20
30
$href = {} ;
1244
1245
# add to section array
1246
20
100
67
$config{$section} ||= [] ;
1247
20
18
push @{$config{$section}}, $href ;
20
46
1248
}
1249
1250
## var = value
1251
318
100
1712
if ($line =~ /^\s*([^\s#]+)\s*=\s*(.*)/)
1252
{
1253
86
238
my ($var, $val) = ($1, $2) ;
1254
86
172
$val =~ s/^['"](.*)['"]$/$1/ ;
1255
86
141
$val =~ s/^\s+// ;
1256
86
121
$val =~ s/\s+$// ;
1257
1258
86
342
$this->_dbg_prt( ["Params before new_cfg:", \%params] ) ;
1259
86
380
$href->{$var} = $this->_new_cfg(
1260
$var,
1261
$val,
1262
$params{summary},
1263
$params{description},
1264
$params{type},
1265
$params{default},
1266
$order++,
1267
) ;
1268
1269
# clear params ready for new entry
1270
86
164
foreach my $param (qw/summary description type name default/)
1271
{
1272
430
849
$params{$param} = undef ;
1273
}
1274
1275
86
504
$this->_dbg_prt( [" + + $var = $val\n"] ) ;
1276
}
1277
}
1278
2
72
close $fh ;
1279
1280
## if we were creating a new entry then save it now
1281
2
50
8
if ($params{name})
1282
{
1283
0
0
$href->{$params{name}} = $this->_new_cfg(
1284
$params{name},
1285
undef,
1286
$params{summary},
1287
$params{description},
1288
$params{type},
1289
$params{default},
1290
$order++,
1291
) ;
1292
}
1293
1294
## save sections
1295
2
113
$this->sections(\@sections) ;
1296
1297
## return complete config HASH
1298
2
67
return %config ;
1299
}
1300
1301
1302
#----------------------------------------------------------------------------
1303
#
1304
#=item B< _new_cfg($var, $value, $summary, $description, $type, $default) >
1305
#
1306
#Create a new config entry.
1307
#
1308
#Returns a HASH of the config entry.
1309
#
1310
#=cut
1311
#
1312
sub _new_cfg
1313
{
1314
90
90
129
my $this = shift ;
1315
90
190
my ($var, $value, $summary, $description, $type, $default, $order) = @_ ;
1316
1317
{
1318
90
50
111
my ($dvar, $dvalue, $dsummary, $ddescription, $dtype, $ddefault, $dorder) = ($var||'', $value||'', $summary||'', $description||'', $type||'', $default||'', $order||'') ;
90
100
1062
100
100
100
100
50
1319
90
518
$this->_dbg_prt( ["_new_cfg($dvar) val=<$dvalue> summary=<$dsummary> desc=<$ddescription> type=<$dtype> index=<$dorder>\n"] ) ;
1320
}
1321
1322
## set defaults
1323
1324
# default to string type
1325
90
100
228
$type = 's' unless (defined($type)) ;
1326
1327
# if either summary or description is not set, then use the other for both
1328
90
100
265
$summary ||= '' ;
1329
90
100
219
$description ||= '' ;
1330
90
100
186
if ("$description$summary")
1331
{
1332
34
50
114
if (!$description)
100
1333
{
1334
0
0
$description = $summary ;
1335
}
1336
elsif (!$summary)
1337
{
1338
8
11
$summary = $description ;
1339
8
39
$summary =~ s/\s+$// ;
1340
}
1341
}
1342
1343
1344
90
365
$this->_dbg_prt( [" + type=<$type>\n"] ) ;
1345
1346
90
100
847
my $cfg_href = {
50
1347
'summary' => $summary,
1348
'default' => $default,
1349
'description' => $description,
1350
'type' => $type || '',
1351
'value' => $value,
1352
'index' => $order || 32767,
1353
} ;
1354
1355
90
334
return $cfg_href ;
1356
}
1357
1358
#----------------------------------------------------------------------------
1359
#
1360
#=item B< _write($write_file) >
1361
#
1362
#Write the config file (located somewhere in the searchable path).
1363
#
1364
#=cut
1365
#
1366
sub _write
1367
{
1368
1
1
3
my $this = shift ;
1369
1
2
my ($write_file) = @_ ;
1370
1371
1
6
$this->_dbg_prt( ["Config: _write($write_file)\n"] ) ;
1372
1373
1
50
284820
open my $fh, ">$write_file" or $this->throw_fatal("Feature:Config : unable to write file $write_file : $!") ;
1374
1375
## Global options
1376
1
10
my %config = $this->get_raw_hash() ;
1377
1378
# skip config options
1379
1
5
my $skip=0;
1380
1
8
foreach my $opt (@CONFIG_OPTIONS)
1381
{
1382
4
10
delete $config{$opt} ;
1383
}
1384
1385
## write global settings
1386
1
9
$this->_write_vars($fh, \%config) ;
1387
1388
## Sections
1389
1
37
my $sections_aref = $this->sections ;
1390
1
6
$this->_dbg_prt( ["Section", $sections_aref] );
1391
1
5
foreach my $section (@$sections_aref)
1392
{
1393
4
15
my @section_vars = $this->get_raw_array($section) ;
1394
4
19
$this->_dbg_prt( ["Section vars", \@section_vars] );
1395
1396
4
11
foreach my $href (@section_vars)
1397
{
1398
10
18
print $fh "\n[$section]\n" ;
1399
10
22
$this->_write_vars($fh, $href) ;
1400
}
1401
}
1402
1
248
close $fh ;
1403
}
1404
1405
#----------------------------------------------------------------------------
1406
#
1407
#=item B< _write_vars($fh, $href) >
1408
#
1409
#Write the config file variables - skipping arrays.
1410
#
1411
#=cut
1412
#
1413
sub _write_vars
1414
{
1415
11
11
14
my $this = shift ;
1416
11
15
my ($fh, $href) = @_ ;
1417
1418
11
41
$this->_dbg_prt( ["_write_vars()", $href] );
1419
1420
1421
11
51
foreach my $var (sort {$href->{$a}{'index'} <=> $href->{$b}{'index'}} keys %$href)
68
135
1422
{
1423
43
100
156
my $description = $href->{$var}{description} || '' ;
1424
43
100
141
my $summary = $href->{$var}{summary} || '' ;
1425
1426
# see if we use the short form
1427
43
100
66
375
if ((!"$description$summary") && ($href->{$var}{type} eq 's'))
100
66
1428
{
1429
## shortest form
1430
28
97
print $fh "$var=$href->{$var}{value}\n" ;
1431
}
1432
elsif (($description =~ /^$summary/) && ($href->{$var}{type} eq 's'))
1433
{
1434
## shorter form
1435
4
10
print $fh "# $summary\n" ;
1436
4
22
print $fh "$var=$href->{$var}{value}\n" ;
1437
}
1438
else
1439
{
1440
11
34
$description =~ s/\n/\n# /gs ;
1441
11
100
46
my $type = $href->{$var}{type} || '' ;
1442
11
100
33
my $val = $href->{$var}{value} || '' ;
1443
11
245
print $fh <
1444
## Name: $var
1445
## Summary: $summary
1446
## Type: $type
1447
#
1448
# $description
1449
#
1450
$var=$val
1451
1452
WRVAR
1453
}
1454
}
1455
}
1456
1457
# ============================================================================================
1458
# END OF PACKAGE
1459
1460
=back
1461
1462
=head1 DIAGNOSTICS
1463
1464
Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.
1465
1466
=head1 AUTHOR
1467
1468
Steve Price C<< >>
1469
1470
=head1 BUGS
1471
1472
None that I know of!
1473
1474
=cut
1475
1476
1;
1477
1478
__END__