lib/Geo/Coder/Free/Config.pm

        start → end → jump
        

    1: package 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: use warnings;
   14: use strict;
   15: 
   16: use Carp;
   17: use Config::Abstraction;
   18: use CGI::Info;
   19: use Data::Dumper;
   20: use Error::Simple;
   21: use File::Spec;
   22: use Params::Get 0.13;
   23: 
   24: =encoding utf-8
   25: 
   26: =head1 NAME
   27: 
   28: Geo::Coder::Free::Config - Site-independent configuration file for the Versatile Web Framework
   29: 
   30: =head1 VERSION
   31: 
   32: Version 0.51
   33: 
   34: =cut
   35: 
   36: our $VERSION = '0.51';
   37: 
   38: =head1 SUBROUTINES/METHODS
   39: 
   40: =head2 new
   41: 
   42: Creates a new Geo::Coder::Free::Config instance with hierarchical configuration loading.
   43: 
   44: Takes four optional arguments:
   45: 	info (CGI::Info object)
   46: 	logger
   47: 	config_directory - used when the configuration directory can't be worked out
   48: 	config_file - name of the configuration file - otherwise determined dynamically
   49: 	config (ref to hash of values to override in the config file
   50: 
   51: Values in the file are overridden by what's in the environment
   52: 
   53: B<Parameters:>
   54: 
   55: =over 4
   56: 
   57: =item * C<info> - CGI::Info object (optional, created if not provided)
   58: 
   59: =item * C<logger> - Logger object with debug() method (optional)
   60: 
   61: =item * C<config_directory> - Additional config directory path (optional)
   62: 
   63: =item * C<config_file> - Specific config filename (optional)
   64: 
   65: =item * C<config> - Hash ref of override values (optional)
   66: 
   67: =back
   68: 
   69: B<Configuration Resolution Order:>
   70: 1. Base configuration files
   71: 2. Values from config parameter
   72: 3. Environment variable overrides
   73: 
   74: B<Directory Search Order:>
   75: 1. $ENV{CONFIG_DIR} (if set)
   76: 2. Provided config_directory
   77: 3. ../conf relative to script
   78: 4. ../../conf relative to script
   79: 5. $DOCUMENT_ROOT/../lib/conf
   80: 6. $HOME/lib/conf
   81: 
   82: B<Returns:> Blessed Geo::Coder::Free::Config object
   83: 
   84: B<Throws:> Error::Simple on configuration errors
   85: 
   86: =head3 FORMAL SPECIFICATION
   87: 
   88:     [STRING, HASH, LOGGER]
   89: 
   90:     ConfigState ::= ⟨⟨ config_dirs : ℙ STRING;
   91:                       config_data : HASH;
   92:                       logger : LOGGER ⟩⟩
   93: 
   94:     ConfigArgs ::= ⟨⟨ info : CGI_Info;
   95:                      logger : LOGGER;
   96:                      config_directory : STRING;
   97:                      config_file : STRING;
   98:                      config : HASH ⟩⟩
   99: 
  100:     Init : ConfigArgs → ConfigState
  101: 
  102:     ∀ params : ConfigArgs •
  103:       let dirs == if env.CONFIG_DIR ≠ ∅
  104:                   then {env.CONFIG_DIR}
  105:                   else default_dirs ∪ {params.config_directory} fi •
  106:       let valid_dirs == {d : dirs | ∃ f : FILE • readable(d, f)} •
  107:       valid_dirs ≠ ∅ ∧
  108:       config_data ∈ HASH ∧
  109:       config_data = merge(file_config, params.config, env_overrides)
  110: 
  111:     ValidConfigKey == {k : STRING | k ∈ dom config_data}
  112: 
  113:     GetConfigValue : ValidConfigKey → (STRING ∪ HASH ∪ ARRAY)
  114: 
  115: =cut
  116: 
  117: sub new
  118: {
●119 → 122 → 127  119: 	my $proto = shift;
  120: 	my $params = Params::Get::get_params(undef, @_);
  121: 
  122: 	if (exists $params->{logger} && defined $params->{logger}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  123: 		throw Error::Simple('logger must be an object with debug method')
  124: 		    unless ref($params->{logger}) && $params->{logger}->can('debug');
  125: 	}
  126: 
●127 → 127 → 131  127: 	if($params->{'logger'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  128: 		$params->{'logger'}->debug(__PACKAGE__, '->new()');
  129: 	}
  130: 
●131 → 131 → 135  131: 	if(exists $params->{config} && defined $params->{config}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  132: 		throw Error::Simple('config must be a hash reference') unless ref($params->{config}) eq 'HASH';
  133: 	}
  134: 
●135 → 139 → 185  135: 	my $class = ref($proto) || $proto;
  136: 	my $info = $params->{info} || CGI::Info->new();
  137: 
  138: 	my @config_dirs;
  139: 	if($ENV{'CONFIG_DIR'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  140: 		# Validate directory exists
  141: 		throw Error::Simple("CONFIG_DIR '$ENV{CONFIG_DIR}' does not exist or is not readable")
  142: 			unless -d $ENV{'CONFIG_DIR'} && -r $ENV{'CONFIG_DIR'};
  143: 		@config_dirs = ($ENV{'CONFIG_DIR'});
  144: 	} else {
  145: 		# Build the standard search path; caller's config_directory is prepended below
  146: 		@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: 		if($ENV{'DOCUMENT_ROOT'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  160: 			push(@config_dirs, File::Spec->catdir(
  161: 				$ENV{'DOCUMENT_ROOT'},
  162: 				File::Spec->updir(),
  163: 				'lib',
  164: 				'conf'
  165: 			))
  166: 		}
  167: 		if($ENV{'HOME'}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_167_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  168: 			push(@config_dirs, File::Spec->catdir(
  169: 				$ENV{'HOME'},
  170: 				'lib',
  171: 				'conf'
  172: 			));
  173: 		}
  174: 
  175: 		# Prepend the caller-supplied directory so it takes highest precedence
  176: 		if($params->{config_directory}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  177: 			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: 				unless -d $params->{config_directory};
  180: 			unshift @config_dirs, $params->{config_directory};
  181: 		}
  182: 	}
  183: 
  184: 	# Look for localised configurations
●185 → 186 → 189  185: 	my $language;
  186: 	if(my $lingua = $params->{'lingua'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  187: 		$language = $lingua->language_code_alpha2();
  188: 	}
●189 → 191 → 201  189: 	$language ||= $info->lang();
  190: 
  191: 	if($language) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_191_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  192: 		@config_dirs = map {
  193: 			($_, "$_/default", "$_/$language")
  194: 		} @config_dirs;
  195: 	} else {
  196: 		@config_dirs = map {
  197: 			($_, File::Spec->catdir($_, 'default'))
  198: 		} @config_dirs;
  199: 	}
  200: 
●201 → 201 → 214  201: 	if($params->{'debug'}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_201_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  202: 		# Not sure this really does anything
  203: 		# $Config::Auto::Debug = 1;
  204: 
  205: 		if($params->{logger}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_205_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  206: 			while(my ($key,$value) = each %ENV) {
  207: 				if($value) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_207_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  208: 					$params->{logger}->debug("$key=$value");
  209: 				}
  210: 			}
  211: 		}
  212: 	}
  213: 
●214 → 222 → 227  214: 	my $config;
  215: 	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: 			logger => $params->{'logger'}
  220: 		)->all();
  221: 	};
  222: 	if($@ || !defined($config)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  223: 		throw Error::Simple("Configuration error: $@");
  224: 	}
  225: 
  226: 	# Validate essential configuration structure
●227 → 231 → 236  227: 	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: 	if(defined($params->{'config'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  232: 		$config = { %{$config}, %{$params->{'config'}} };
  233: 	}
  234: 
  235: 	# Allow variables to be overridden by the environment
●236 → 236 → 259  236: 	foreach my $key(keys %{$config}) {
  237: 		if(my $value = $ENV{$key}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  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: 			if($params->{'logger'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  246: 				$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: 			if($value =~ /(.+)=(.+)/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  250: 				delete $config->{$key} if(!ref($config->{$key}));
  251: 				$config->{$key}{$1} = $2;
  252: 			} else {
  253: 				$config->{$key} = $value;
  254: 			}
  255: 		}
  256: 	}
  257: 
  258: 	# Config::Any turns fields with spaces into arrays, put them back
●259 → 259 → 271  259: 	foreach my $field('Contents', 'SiteTitle') {
  260: 		next if(!exists $config->{$field});
  261: 		my $value = $config->{$field};
  262: 
  263: 		if(ref($value) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  264: 			$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 → 271 → 275  271: 	if($params->{'debug'} && $params->{'logger'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  272: 		$params->{'logger'}->debug(__PACKAGE__, '(', __LINE__, '): ', Data::Dumper->new([$config])->Dump());
  273: 	}
  274: 
  275: 	return bless $config, $class;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  276: }
  277: 
  278: sub AUTOLOAD
  279: {
  280: 	our $AUTOLOAD;
  281: 	my $self = shift;
  282: 
  283: 	return undef unless($self);

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_283_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_283_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  284: 	return unless defined($AUTOLOAD);
  285: 
  286: 	# Extract the key name from the AUTOLOAD variable
  287: 	(my $key = $AUTOLOAD) =~ s/.*:://;
  288: 
  289: 	return unless defined($key);
  290: 
  291: 	# Don't handle special methods
  292: 	return if $key eq 'DESTROY';
  293: 
  294: 	# Validate method name - only allow safe config keys
  295: 	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: 	return exists $self->{$key} ? $self->{$key} : undef;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  300: }
  301: 
  302: 1;