File Coverage

blib/lib/App/Framework/Feature/Config.pm
Criterion Covered Total %
statement 316 330 95.7
branch 74 96 77.0
condition 51 64 79.6
subroutine 25 27 92.5
pod 16 16 100.0
total 482 533 90.4


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__