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