File Coverage

File:blib/lib/Geo/Coder/Free/Config.pm
Coverage:62.6%

linestmtbrancondsubpodtimecode
1package Geo::Coder::Free::Config;
2
3# VWF is licensed under GPL2.0 for personal use only
4# njh@bandsman.co.uk
5
6# Usage is subject to licence terms.
7# The licence terms of this software are as follows:
8# Personal single user, single computer use: GPL2
9# All other users (including Commercial, Charity, Educational, Government)
10#       must apply in writing for a licence for use from Nigel Horne at the
11#       above e-mail.
12
13
2
2
2
2
74858
0
48
use warnings;
14
2
2
2
2
3
2
15
use strict;
15
16
2
2
2
2
2
2
47
use Carp;
17
2
2
2
2
368
44580
31
use Config::Abstraction;
18
2
2
2
2
675
96558
44
use CGI::Info;
19
2
2
2
2
8
1
67
use Data::Dumper;
20
2
2
2
2
264
1876
13
use Error::Simple;
21
2
2
2
2
49
2
27
use File::Spec;
22
2
2
2
2
4
25
957
use Params::Get 0.13;
23
24=encoding utf-8
25
26 - 34
=head1 NAME

Geo::Coder::Free::Config - Site-independent configuration file for the Versatile Web Framework

=head1 VERSION

Version 0.01

=cut
35
36our $VERSION = '0.01';
37
38 - 115
=head1 SUBROUTINES/METHODS

=head2 new

Creates a new Geo::Coder::Free::Config instance with hierarchical configuration loading.

Takes four optional arguments:
        info (CGI::Info object)
        logger
        config_directory - used when the configuration directory can't be worked out
        config_file - name of the configuration file - otherwise determined dynamically
        config (ref to hash of values to override in the config file

Values in the file are overridden by what's in the environment

B<Parameters:>

=over 4

=item * C<info> - CGI::Info object (optional, created if not provided)

=item * C<logger> - Logger object with debug() method (optional)

=item * C<config_directory> - Additional config directory path (optional)

=item * C<config_file> - Specific config filename (optional)

=item * C<config> - Hash ref of override values (optional)

=back

B<Configuration Resolution Order:>
1. Base configuration files
2. Values from config parameter
3. Environment variable overrides

B<Directory Search Order:>
1. $ENV{CONFIG_DIR} (if set)
2. Provided config_directory
3. ../conf relative to script
4. ../../conf relative to script
5. $DOCUMENT_ROOT/../lib/conf
6. $HOME/lib/conf

B<Returns:> Blessed Geo::Coder::Free::Config object

B<Throws:> Error::Simple on configuration errors

=head3 FORMAL SPECIFICATION

    [STRING, HASH, LOGGER]

    ConfigState ::= ⟨⟨ config_dirs : â„™ STRING;
                      config_data : HASH;
                      logger : LOGGER ⟩⟩

    ConfigArgs ::= ⟨⟨ info : CGI_Info;
                     logger : LOGGER;
                     config_directory : STRING;
                     config_file : STRING;
                     config : HASH ⟩⟩

    Init : ConfigArgs → ConfigState

    âˆ€ params : ConfigArgs •
      let dirs == if env.CONFIG_DIR ≠ ∅
                  then {env.CONFIG_DIR}
                  else default_dirs ∪ {params.config_directory} fi •
      let valid_dirs == {d : dirs | ∃ f : FILE • readable(d, f)} •
      valid_dirs ≠ ∅ ∧
      config_data ∈ HASH ∧
      config_data = merge(file_config, params.config, env_overrides)

    ValidConfigKey == {k : STRING | k ∈ dom config_data}

    GetConfigValue : ValidConfigKey → (STRING ∪ HASH ∪ ARRAY)

=cut
116
117sub new
118{
119
3
3
1
105510
        my $proto = shift;
120
3
11
        my $params = Params::Get::get_params(undef, @_);
121
122
3
50
33
52
        if (exists $params->{logger} && defined $params->{logger}) {
123                throw Error::Simple('logger must be an object with debug method')
124
0
0
0
0
                    unless ref($params->{logger}) && $params->{logger}->can('debug');
125        }
126
127
3
50
5
        if($params->{'logger'}) {
128
0
0
                $params->{'logger'}->debug(__PACKAGE__, '->new()');
129        }
130
131
3
100
67
11
        if(exists $params->{config} && defined $params->{config}) {
132
2
50
5
                throw Error::Simple('config must be a hash reference') unless ref($params->{config}) eq 'HASH';
133        }
134
135
3
33
8
        my $class = ref($proto) || $proto;
136
3
33
18
        my $info = $params->{info} || CGI::Info->new();
137
138
3
37300
        my @config_dirs;
139
3
50
7
        if($ENV{'CONFIG_DIR'}) {
140                # Validate directory exists
141                throw Error::Simple("CONFIG_DIR '$ENV{CONFIG_DIR}' does not exist or is not readable")
142
0
0
0
0
                        unless -d $ENV{'CONFIG_DIR'} && -r $ENV{'CONFIG_DIR'};
143
0
0
                @config_dirs = ($ENV{'CONFIG_DIR'});
144        } else {
145                # Build the standard search path; caller's config_directory is prepended below
146
3
10
                @config_dirs = (
147                        File::Spec->catdir(
148                                $info->script_dir(),
149                                File::Spec->updir(),
150                                File::Spec->updir(),
151                                'conf'
152                        ), File::Spec->catdir(
153                                $info->script_dir(),
154                                File::Spec->updir(),
155                                'conf'
156                        )
157                );
158
159
3
50
525
                if($ENV{'DOCUMENT_ROOT'}) {
160                        push(@config_dirs, File::Spec->catdir(
161
0
0
                                $ENV{'DOCUMENT_ROOT'},
162                                File::Spec->updir(),
163                                'lib',
164                                'conf'
165                        ))
166                }
167
3
50
8
                if($ENV{'HOME'}) {
168                        push(@config_dirs, File::Spec->catdir(
169
3
11
                                $ENV{'HOME'},
170                                'lib',
171                                'conf'
172                        ));
173                }
174
175                # Prepend the caller-supplied directory so it takes highest precedence
176
3
50
7
                if($params->{config_directory}) {
177
0
0
0
                        throw Error::Simple("config_directory must be a string") if ref($params->{config_directory});
178                        throw Error::Simple("config_directory '$params->{config_directory}' does not exist")
179
0
0
0
                                unless -d $params->{config_directory};
180
0
0
                        unshift @config_dirs, $params->{config_directory};
181                }
182        }
183
184        # Look for localised configurations
185
3
3
        my $language;
186
3
50
4
        if(my $lingua = $params->{'lingua'}) {
187
0
0
                $language = $lingua->language_code_alpha2();
188        }
189
3
33
17
        $language ||= $info->lang();
190
191
3
50
5717
        if($language) {
192                @config_dirs = map {
193
3
9
5
15
                        ($_, "$_/default", "$_/$language")
194                } @config_dirs;
195        } else {
196                @config_dirs = map {
197
0
0
0
0
                        ($_, File::Spec->catdir($_, 'default'))
198                } @config_dirs;
199        }
200
201
3
50
7
        if($params->{'debug'}) {
202                # Not sure this really does anything
203                # $Config::Auto::Debug = 1;
204
205
0
0
0
                if($params->{logger}) {
206
0
0
                        while(my ($key,$value) = each %ENV) {
207
0
0
0
                                if($value) {
208
0
0
                                        $params->{logger}->debug("$key=$value");
209                                }
210                        }
211                }
212        }
213
214
3
3
        my $config;
215
3
2
        eval {
216                $config = Config::Abstraction->new(
217                        config_dirs => \@config_dirs,
218                        config_files => ['default', $info->domain_name(), $ENV{'CONFIG_FILE'}, $params->{'config_file'}],
219
3
10
                        logger => $params->{'logger'}
220                )->all();
221        };
222
3
50
33
4107
        if($@ || !defined($config)) {
223
0
0
                throw Error::Simple("Configuration error: $@");
224        }
225
226        # Validate essential configuration structure
227
3
50
6
        throw Error::Simple('Configuration must be a hash reference') unless(ref($config) eq 'HASH');
228
229        # The values in config are defaults which can be overridden by
230        # the values in params->{config}
231
3
100
6
        if(defined($params->{'config'})) {
232
2
2
2
2
3
5
                $config = { %{$config}, %{$params->{'config'}} };
233        }
234
235        # Allow variables to be overridden by the environment
236
3
3
4
6
        foreach my $key(keys %{$config}) {
237
30
100
25
                if(my $value = $ENV{$key}) {
238                        # Validate environment variable names
239                        # throw Error::Simple("Invalid environment variable name: $key")
240                                # unless $key =~ /^[A-Z_][A-Z0-9_]*$/;
241
242                        # Sanitize values
243                        # $value =~ s/[^\w\s=\.\-]//g;  # Remove potentially dangerous characters
244
245
1
50
2
                        if($params->{'logger'}) {
246
0
0
                                $params->{'logger'}->debug(__PACKAGE__, ': ', __LINE__, " overwriting $key, ", $config->{$key}, " with $value");
247                        }
248                        # If the value contains an equals make it into a hash value
249
1
50
2
                        if($value =~ /(.+)=(.+)/) {
250
0
0
0
                                delete $config->{$key} if(!ref($config->{$key}));
251
0
0
                                $config->{$key}{$1} = $2;
252                        } else {
253
1
2
                                $config->{$key} = $value;
254                        }
255                }
256        }
257
258        # Config::Any turns fields with spaces into arrays, put them back
259
3
5
        foreach my $field('Contents', 'SiteTitle') {
260
6
50
9
                next if(!exists $config->{$field});
261
6
4
                my $value = $config->{$field};
262
263
6
50
9
                if(ref($value) eq 'ARRAY') {
264
0
0
0
0
                        $config->{$field} = join(' ', @{$value});
265                }
266        }
267
268        # unless($config->{'config_path'}) {
269                # $config->{'config_path'} = File::Spec->catdir($config_dir, $info->domain_name());
270        # }
271
3
0
33
5
        if($params->{'debug'} && $params->{'logger'}) {
272
0
0
                $params->{'logger'}->debug(__PACKAGE__, '(', __LINE__, '): ', Data::Dumper->new([$config])->Dump());
273        }
274
275
3
20
        return bless $config, $class;
276}
277
278sub AUTOLOAD
279{
280
5
5
1531
        our $AUTOLOAD;
281
5
5
        my $self = shift;
282
283
5
50
8
        return undef unless($self);
284
5
50
6
        return unless defined($AUTOLOAD);
285
286        # Extract the key name from the AUTOLOAD variable
287
5
11
        (my $key = $AUTOLOAD) =~ s/.*:://;
288
289
5
50
6
        return unless defined($key);
290
291        # Don't handle special methods
292
5
100
15
        return if $key eq 'DESTROY';
293
294        # Validate method name - only allow safe config keys
295
2
50
5
        Carp::croak(__PACKAGE__, ": Invalid key name: $key") unless $key =~ /^[a-zA-Z_][a-zA-Z0-9_]*$/;
296
297        # Return the value of the corresponding hash key
298        # Only return existing keys to avoid auto-vivification
299
2
100
8
        return exists $self->{$key} ? $self->{$key} : undef;
300}
301
3021;