| File: | blib/lib/Object/Configure.pm |
| Coverage: | 80.3% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Object::Configure; | |||||
| 2 | ||||||
| 3 | # TODO: configuration inheritance from parents | |||||
| 4 | ||||||
| 5 | 10 10 10 | 715103 7 134 | use strict; | |||
| 6 | 10 10 10 | 13 8 157 | use warnings; | |||
| 7 | ||||||
| 8 | 10 10 10 | 13 7 267 | use Carp; | |||
| 9 | 10 10 10 | 2017 215285 191 | use Config::Abstraction 0.36; | |||
| 10 | 10 10 10 | 2172 116830 161 | use Log::Abstraction 0.26; | |||
| 11 | 10 10 10 | 21 46 185 | use Params::Get 0.13; | |||
| 12 | 10 10 10 | 17 13 119 | use Return::Set; | |||
| 13 | 10 10 10 | 21 6 190 | use Scalar::Util qw(blessed weaken); | |||
| 14 | 10 10 10 | 11 9 24 | use Time::HiRes qw(time); | |||
| 15 | 10 10 10 | 2441 26079 6732 | use File::stat; | |||
| 16 | ||||||
| 17 | # Global registry to track configured objects for hot reload | |||||
| 18 | our %_object_registry = (); | |||||
| 19 | our %_config_watchers = (); | |||||
| 20 | our %_config_file_stats = (); | |||||
| 21 | ||||||
| 22 | # Keep track of the original USR1 handler for chaining | |||||
| 23 | our $_original_usr1_handler; | |||||
| 24 | ||||||
| 25 - 33 | =head1 NAME Object::Configure - Runtime Configuration for an Object =head1 VERSION 0.17 =cut | |||||
| 34 | ||||||
| 35 | our $VERSION = 0.17; | |||||
| 36 | ||||||
| 37 - 269 | =head1 SYNOPSIS
The C<Object::Configure> module is a lightweight utility designed to inject runtime parameters into other classes,
primarily by layering configuration and logging support,
when instatiating objects.
L<Log::Abstraction> and L<Config::Abstraction> are modules developed to solve a specific need,
runtime configurability without needing to rewrite or hardcode behaviours.
The goal is to allow individual modules to enable or disable features on the fly,
and to do it using whatever configuration system the user prefers.
Although the initial aim was general configurability,
the primary use case that's emerged has been fine-grained logging control,
more flexible and easier to manage than what you'd typically do with L<Log::Log4perl>.
For example,
you might want one module to log verbosely while another stays quiet,
and be able to toggle that dynamically - without making invasive changes to each module.
To tie it all together,
there is C<Object::Configure>.
It sits on L<Log::Abstraction> and L<Config::Abstraction>,
and with just a couple of extra lines in a class constructor,
you can hook in this behaviour seamlessly.
The intent is to keep things modular and reusable,
especially across larger systems or in situations where you want user-selectable behaviour.
Add this to your constructor:
package My::Module;
use Object::Configure;
use Params::Get;
sub new {
my $class = shift;
my $params = Object::Configure::configure($class, @_ ? \@_ : undef); # Reads in the runtime configuration settings
# or my $params = Object::Configure::configure($class, { @_ });
return bless $params, $class;
}
Throughout your class, add code such as:
sub method
{
my $self = shift;
$self->{'logger'}->trace(ref($self), ': ', __LINE__, ' entering method');
}
=head3 CONFIGURATION INHERITANCE
C<Object::Configure> supports configuration inheritance, allowing child classes to inherit and override configuration settings from their parent classes. When a class is configured, the module automatically traverses the inheritance hierarchy (using C<@ISA>) and loads configuration files for each ancestor class in the chain.
Configuration files are loaded in order from the most general (base class) to the most specific (child class), with later files overriding earlier ones. For example, if C<My::Child::Class> inherits from C<My::Parent::Class>, which inherits from C<My::Base::Class>, the module will:
=over 4
=item 1. Load C<my-base-class.yml> (or .conf, .json, etc.) if it exists
=item 2. Load C<my-parent-class.yml> if it exists, overriding base settings
=item 3. Load C<my-child-class.yml>, overriding both parent and base settings
=back
The configuration files should be named using lowercase versions of the class name with C<::> replaced by hyphens (C<->).
For example, C<My::Parent::Class> would use C<my-parent-class.yml>.
This allows you to define common settings in a base class configuration file and selectively override them in child class configurations, promoting DRY (Don't Repeat Yourself) principles and making it easier to manage configuration across class hierarchies.
Example:
# File: config/my-base-class.yml
---
My__Base__Class:
timeout: 30
retries: 3
log_level: info
# File: config/my-child-class.yml
---
My__Child__Class:
timeout: 60
# Inherits retries: 3 and log_level: info from parent
# Result: Child class gets timeout=60, retries=3, log_level=info
Parent configuration files are optional.
If a parent class's configuration file doesn't exist, the module simply skips it and continues up the inheritance chain.
All discovered configuration files are tracked in the C<_config_files> array for hot reload support.
=head2 CHANGING BEHAVIOUR AT RUN TIME
=head3 USING A CONFIGURATION FILE
To control behavior at runtime, C<Object::Configure> supports loading settings from a configuration file via L<Config::Abstraction>.
A minimal example of a config file (C<~/.conf/local.conf>) might look like:
[My__Module]
logger.file = /var/log/mymodule.log
The C<configure()> function will read this file,
overlay it onto your default parameters,
and initialize the logger accordingly.
If the file is not readable and no config_dirs are provided,
the module will throw an error.
To be clear, in this case, inheritance is not followed.
This mechanism allows dynamic tuning of logging behavior (or other parameters you expose) without modifying code.
More details to be written.
=head3 USING ENVIRONMENT VARIABLES
C<Object::Configure> also supports runtime configuration via environment variables,
without requiring a configuration file.
Environment variables are read automatically when you use the C<configure()> function,
thanks to its integration with L<Config::Abstraction>.
These variables should be prefixed with your class name, followed by a double colon.
For example, to enable syslog logging for your C<My::Module> class,
you could set:
export My__Module__logger__file=/var/log/mymodule.log
This would be equivalent to passing the following in your constructor:
My::Module->new(logger => Log::Abstraction->new({ file => '/var/log/mymodule.log' });
All environment variables are read and merged into the default parameters under the section named after your class.
This allows centralized and temporary control of settings (e.g., for production diagnostics or ad hoc testing) without modifying code or files.
Note that environment variable settings take effect regardless of whether a configuration file is used,
and are applied during the call to C<configure()>.
More details to be written.
=head2 HOT RELOAD
Hot reload is not supported on Windows.
=head3 Basic Hot Reload Setup
package My::App;
use Object::Configure;
sub new {
my $class = shift;
my $params = Object::Configure::configure($class, @_ ? \@_ : undef);
my $self = bless $params, $class;
# Register for hot reload
Object::Configure::register_object($class, $self) if $params->{_config_file};
return $self;
}
# Optional: Define a reload hook
sub _on_config_reload {
my ($self, $new_config) = @_;
print "My::App config was reloaded!\n";
# Custom reload logic here
}
=head3 Enable Hot Reload in Your Main Application
# Enable hot reload with custom callback
Object::Configure::enable_hot_reload(
interval => 5, # Check every 5 seconds
callback => sub {
print "Configuration files have been reloaded!\n";
}
);
# Your application continues running...
# Config changes will be automatically detected and applied
=head3 Manual Reload
# Manually trigger a reload
my $count = Object::Configure::reload_config();
print "Reloaded configuration for $count objects\n";
=head1 SUBROUTINES/METHODS
=head2 configure
Configure your class at runtime with hot reload support.
Takes arguments:
=over 4
=item * C<class>
=item * C<params>
A hashref containing default parameters to be used in the constructor.
=item * C<carp_on_warn>
If set to 1, call C<Carp::carp> on C<warn()>.
This value is also read from the configuration file,
which will take precedence.
The default is 0.
=item * C<croak_on_error>
If set to 1, call C<Carp::croak> on C<error()>.
This value is also read from the configuration file,
which will take precedence.
The default is 1.
=item * C<logger>
The logger to use.
If none is given, an instatiation of L<Log::Abstraction> will be created, unless the logger is set to NULL.
=item * C<schema>
A L<Params::Validate::Strict> compatible schema to validate the configuration file against.
=back
Returns a hash ref containing the new values for the constructor.
Now you can set up a configuration file and environment variables to configure your object.
=cut | |||||
| 270 | ||||||
| 271 | sub configure { | |||||
| 272 | 39 | 2118496 | my $class = $_[0]; | |||
| 273 | 39 | 72 | my $params = $_[1] || {}; # Contains the defaults, the run time config will overwrite them | |||
| 274 | 39 | 29 | my $array; | |||
| 275 | ||||||
| 276 | 39 | 75 | if(exists($params->{'logger'}) && (ref($params->{'logger'}) eq 'ARRAY')) { | |||
| 277 | 0 | 0 | $array = delete $params->{'logger'}; | |||
| 278 | } | |||||
| 279 | ||||||
| 280 | 39 | 45 | my $original_class = $class; | |||
| 281 | 39 | 109 | $class =~ s/::/__/g; | |||
| 282 | ||||||
| 283 | # Store config file path for hot reload | |||||
| 284 | 39 | 37 | my $config_file = $params->{'config_file'}; | |||
| 285 | 39 | 41 | my $config_dirs = $params->{'config_dirs'}; | |||
| 286 | ||||||
| 287 | # Get inheritance chain for finding ancestor config files | |||||
| 288 | 39 | 44 | my @inheritance_chain = _get_inheritance_chain($original_class); | |||
| 289 | ||||||
| 290 | # Build list of config files to load (ancestor to child order) | |||||
| 291 | 39 | 31 | my @config_files_to_load = (); | |||
| 292 | 39 | 31 | my %tracked_files = (); | |||
| 293 | ||||||
| 294 | 39 | 38 | if ($config_file) { | |||
| 295 | # Check if primary config file is readable (unless config_dirs provided) | |||||
| 296 | 29 | 171 | if ((!$config_dirs) && (!-r $config_file)) { | |||
| 297 | 2 | 48 | croak("$class: ", $config_file, ": $!"); | |||
| 298 | } | |||||
| 299 | ||||||
| 300 | # Find config files for each class in the hierarchy | |||||
| 301 | # Important: iterate in reverse order (base -> parent -> child) | |||||
| 302 | 27 | 35 | foreach my $ancestor_class (reverse @inheritance_chain) { | |||
| 303 | 40 | 340 | my $ancestor_config_file = _find_class_config_file( | |||
| 304 | $ancestor_class, | |||||
| 305 | $config_file, | |||||
| 306 | $config_dirs | |||||
| 307 | ); | |||||
| 308 | ||||||
| 309 | # Skip if this is the primary config file - it will be added at the end | |||||
| 310 | 40 | 48 | if ($ancestor_config_file && $ancestor_config_file eq $config_file) { | |||
| 311 | 8 | 8 | next; | |||
| 312 | } | |||||
| 313 | ||||||
| 314 | # Only add if we found a file and haven't already added it | |||||
| 315 | 32 | 79 | if ($ancestor_config_file && -r $ancestor_config_file && !$tracked_files{$ancestor_config_file}) { | |||
| 316 | 12 | 17 | push @config_files_to_load, { | |||
| 317 | file => $ancestor_config_file, | |||||
| 318 | class => $ancestor_class | |||||
| 319 | }; | |||||
| 320 | 12 | 8 | $tracked_files{$ancestor_config_file} = 1; | |||
| 321 | ||||||
| 322 | # Track for hot reload | |||||
| 323 | 12 | 33 | if (-f $ancestor_config_file) { | |||
| 324 | 12 | 35 | $_config_file_stats{$ancestor_config_file} = stat($ancestor_config_file); | |||
| 325 | } | |||||
| 326 | } | |||||
| 327 | } | |||||
| 328 | ||||||
| 329 | # Ensure the primary config file is included LAST (highest priority) | |||||
| 330 | # This handles the case where the primary file doesn't match the class name pattern | |||||
| 331 | 27 | 542 | if ($config_file && !$tracked_files{$config_file} && -r $config_file) { | |||
| 332 | 27 | 45 | push @config_files_to_load, { | |||
| 333 | file => $config_file, | |||||
| 334 | class => $original_class | |||||
| 335 | }; | |||||
| 336 | 27 | 49 | $tracked_files{$config_file} = 1; | |||
| 337 | ||||||
| 338 | 27 | 93 | if (-f $config_file) { | |||
| 339 | 27 | 42 | $_config_file_stats{$config_file} = stat($config_file); | |||
| 340 | } | |||||
| 341 | } | |||||
| 342 | } | |||||
| 343 | ||||||
| 344 | # Sort by class hierarchy to ensure correct order (base -> parent -> child) | |||||
| 345 | # This must happen AFTER all files are collected | |||||
| 346 | 37 | 1801 | if (@config_files_to_load) { | |||
| 347 | 27 | 17 | my %class_order; | |||
| 348 | 27 | 41 | for my $i (0..$#inheritance_chain) { | |||
| 349 | 40 | 44 | $class_order{$inheritance_chain[$i]} = $i; | |||
| 350 | } | |||||
| 351 | @config_files_to_load = sort { | |||||
| 352 | 27 17 | 48 27 | ($class_order{$a->{class}} // 999) <=> ($class_order{$b->{class}} // 999) | |||
| 353 | } @config_files_to_load; | |||||
| 354 | } | |||||
| 355 | ||||||
| 356 | # Load and merge configurations from all files | |||||
| 357 | 37 | 58 | if (@config_files_to_load) { | |||
| 358 | # Start with the passed-in defaults | |||||
| 359 | 27 | 38 | my $merged_params = { %$params }; | |||
| 360 | ||||||
| 361 | 27 | 33 | foreach my $config_info (@config_files_to_load) { | |||
| 362 | 39 | 108 | my $cfg_file = $config_info->{file}; | |||
| 363 | 39 | 29 | my $cfg_class = $config_info->{class}; | |||
| 364 | 39 | 23 | my $section_name = $cfg_class; | |||
| 365 | 39 | 49 | $section_name =~ s/::/__/g; | |||
| 366 | ||||||
| 367 | # When loading individual config files for inheritance, | |||||
| 368 | # don't pass config_dirs - just load the specific file | |||||
| 369 | 39 | 117 | my $config = Config::Abstraction->new( | |||
| 370 | config_file => $cfg_file, | |||||
| 371 | env_prefix => "${section_name}__" | |||||
| 372 | ); | |||||
| 373 | ||||||
| 374 | 39 | 66821 | if ($config) { | |||
| 375 | # Get this config file's values for the section | |||||
| 376 | 39 | 58 | my $this_config = $config->merge_defaults( | |||
| 377 | defaults => {}, | |||||
| 378 | section => $section_name, | |||||
| 379 | merge => 1, | |||||
| 380 | deep => 1 | |||||
| 381 | ); | |||||
| 382 | ||||||
| 383 | # Deep merge: later configs override earlier ones | |||||
| 384 | 39 | 2190 | $merged_params = _deep_merge($merged_params, $this_config); | |||
| 385 | } elsif ($@) { | |||||
| 386 | 0 | 0 | carp("Warning: Can't load configuration from $cfg_file: $@"); | |||
| 387 | } | |||||
| 388 | } | |||||
| 389 | ||||||
| 390 | 27 | 207 | $params = $merged_params; | |||
| 391 | ||||||
| 392 | } elsif (my $config = Config::Abstraction->new(env_prefix => "${class}__")) { | |||||
| 393 | # Handle environment variables with inheritance | |||||
| 394 | 3 | 2594 | my $merged_config = {}; | |||
| 395 | ||||||
| 396 | # Merge ancestor configurations from environment | |||||
| 397 | 3 | 3 | foreach my $ancestor_class (reverse @inheritance_chain) { | |||
| 398 | 3 | 3 | my $section_name = $ancestor_class; | |||
| 399 | 3 | 6 | $section_name =~ s/::/__/g; | |||
| 400 | ||||||
| 401 | 3 | 6 | my $ancestor_env_config = Config::Abstraction->new( | |||
| 402 | env_prefix => "${section_name}__" | |||||
| 403 | ); | |||||
| 404 | ||||||
| 405 | 3 | 1203 | if ($ancestor_env_config) { | |||
| 406 | 3 | 5 | my $ancestor_config = $ancestor_env_config->merge_defaults( | |||
| 407 | defaults => {}, | |||||
| 408 | section => $section_name, | |||||
| 409 | merge => 1, | |||||
| 410 | deep => 1 | |||||
| 411 | ); | |||||
| 412 | 3 | 186 | $merged_config = _deep_merge($merged_config, $ancestor_config); | |||
| 413 | } | |||||
| 414 | } | |||||
| 415 | ||||||
| 416 | 3 | 26 | $params = $config->merge_defaults( | |||
| 417 | defaults => $params, | |||||
| 418 | section => $class, | |||||
| 419 | merge => 1, | |||||
| 420 | deep => 1 | |||||
| 421 | ); | |||||
| 422 | ||||||
| 423 | # Apply inherited config | |||||
| 424 | 3 | 121 | $params = _deep_merge($merged_config, $params); | |||
| 425 | ||||||
| 426 | # Track this config file for hot reload | |||||
| 427 | 3 | 7 | if ($params->{config_path} && -f $params->{config_path}) { | |||
| 428 | 0 | 0 | $_config_file_stats{$params->{config_path}} = stat($params->{config_path}); | |||
| 429 | } | |||||
| 430 | } | |||||
| 431 | ||||||
| 432 | 37 | 6081 | my $croak_on_error = exists($params->{'croak_on_error'}) ? $params->{'croak_on_error'} : 1; | |||
| 433 | 37 | 39 | my $carp_on_warn = exists($params->{'carp_on_warn'}) ? $params->{'carp_on_warn'} : 0; | |||
| 434 | ||||||
| 435 | # Load the default logger | |||||
| 436 | 37 | 45 | if (my $logger = $params->{'logger'}) { | |||
| 437 | 5 | 8 | if ($params->{'logger'} ne 'NULL') { | |||
| 438 | 5 | 7 | if(ref($logger) eq 'HASH') { | |||
| 439 | 4 | 4 | if ($logger->{'syslog'}) { | |||
| 440 | $params->{'logger'} = Log::Abstraction->new({ | |||||
| 441 | carp_on_warn => $carp_on_warn, | |||||
| 442 | syslog => $logger->{'syslog'}, | |||||
| 443 | 1 1 | 1 3 | %{$logger} | |||
| 444 | }); | |||||
| 445 | } else { | |||||
| 446 | $params->{'logger'} = Log::Abstraction->new({ | |||||
| 447 | carp_on_warn => $carp_on_warn, | |||||
| 448 | 3 3 | 2 10 | %{$logger} | |||
| 449 | }); | |||||
| 450 | } | |||||
| 451 | } elsif(!blessed($logger) || !$logger->isa('Log::Abstraction')) { | |||||
| 452 | 1 | 3 | $params->{'logger'} = Log::Abstraction->new({ | |||
| 453 | carp_on_warn => $carp_on_warn, | |||||
| 454 | logger => $logger | |||||
| 455 | }); | |||||
| 456 | } | |||||
| 457 | } | |||||
| 458 | } elsif ($array) { | |||||
| 459 | 0 | 0 | $params->{'logger'} = Log::Abstraction->new( | |||
| 460 | array => $array, | |||||
| 461 | carp_on_warn => $carp_on_warn | |||||
| 462 | ); | |||||
| 463 | 0 | 0 | undef $array; | |||
| 464 | } else { | |||||
| 465 | 32 | 89 | $params->{'logger'} = Log::Abstraction->new(carp_on_warn => $carp_on_warn); | |||
| 466 | } | |||||
| 467 | ||||||
| 468 | 37 | 183766 | if ($array && !$params->{'logger'}->{'array'}) { | |||
| 469 | 0 | 0 | $params->{'logger'}->{'array'} = $array; | |||
| 470 | } | |||||
| 471 | ||||||
| 472 | # Store config file path in params for hot reload | |||||
| 473 | 37 | 52 | $params->{_config_file} = $config_file if(defined($config_file)); | |||
| 474 | 37 39 | 66 54 | $params->{_config_files} = [map { $_->{file} } @config_files_to_load] if @config_files_to_load; | |||
| 475 | ||||||
| 476 | 37 | 73 | return Return::Set::set_return($params, { 'type' => 'hashref' }); | |||
| 477 | } | |||||
| 478 | ||||||
| 479 | # Find the appropriate config file for a given class | |||||
| 480 | # Looks for class-specific config files based on naming conventions | |||||
| 481 | sub _find_class_config_file { | |||||
| 482 | 41 | 756 | my ($class, $base_config_file, $config_dirs) = @_; | |||
| 483 | ||||||
| 484 | # Convert class name to file-friendly format | |||||
| 485 | 41 | 39 | my $class_file = lc($class); | |||
| 486 | 41 | 55 | $class_file =~ s/::/-/g; | |||
| 487 | ||||||
| 488 | # Extract directory, basename, and extension from base config file | |||||
| 489 | 41 | 29 | my ($base_dir, $base_name, $base_ext); | |||
| 490 | ||||||
| 491 | 41 | 176 | if ($base_config_file =~ m{^(.*/)([^/]+?)(\.[^.]+)?$}) { | |||
| 492 | 41 | 74 | $base_dir = $1 || ''; | |||
| 493 | 41 | 40 | $base_name = $2; | |||
| 494 | 41 | 59 | $base_ext = $3 || ''; | |||
| 495 | } else { | |||||
| 496 | 0 | 0 | $base_name = $base_config_file; | |||
| 497 | 0 | 0 | $base_dir = ''; | |||
| 498 | 0 | 0 | $base_ext = ''; | |||
| 499 | } | |||||
| 500 | ||||||
| 501 | # Try several naming patterns | |||||
| 502 | 41 | 78 | my @patterns = ( | |||
| 503 | "${base_dir}${class_file}${base_ext}", # my-parent-class.yml | |||||
| 504 | "${base_dir}${class_file}.conf", # my-parent-class.conf | |||||
| 505 | "${base_dir}${class_file}.yml", # my-parent-class.yml | |||||
| 506 | "${base_dir}${class_file}.yaml", # my-parent-class.yaml | |||||
| 507 | "${base_dir}${class_file}.json", # my-parent-class.json | |||||
| 508 | ); | |||||
| 509 | ||||||
| 510 | # Also try with config_dirs if provided | |||||
| 511 | 41 | 67 | if ($config_dirs && ref($config_dirs) eq 'ARRAY') { | |||
| 512 | 22 | 17 | foreach my $dir (@$config_dirs) { | |||
| 513 | # Remove trailing slash if present | |||||
| 514 | 22 | 17 | $dir =~ s{/$}{}; | |||
| 515 | 22 | 39 | push @patterns, ( | |||
| 516 | "${dir}/${class_file}${base_ext}", | |||||
| 517 | "${dir}/${class_file}.conf", | |||||
| 518 | "${dir}/${class_file}.yml", | |||||
| 519 | "${dir}/${class_file}.yaml", | |||||
| 520 | "${dir}/${class_file}.json", | |||||
| 521 | ); | |||||
| 522 | } | |||||
| 523 | } | |||||
| 524 | ||||||
| 525 | # Return the first file that exists and is readable | |||||
| 526 | 41 | 41 | foreach my $pattern (@patterns) { | |||
| 527 | 126 | 410 | if (-r $pattern && -f $pattern) { | |||
| 528 | 21 | 34 | return $pattern; | |||
| 529 | } | |||||
| 530 | } | |||||
| 531 | ||||||
| 532 | 20 | 28 | return undef; | |||
| 533 | } | |||||
| 534 | ||||||
| 535 | # Helper function to get the inheritance chain for a class | |||||
| 536 | sub _get_inheritance_chain { | |||||
| 537 | 40 | 73042 | my ($class) = @_; | |||
| 538 | 40 | 39 | my @chain = (); | |||
| 539 | 40 | 30 | my %seen = (); | |||
| 540 | ||||||
| 541 | 40 | 59 | _walk_isa($class, \@chain, \%seen); | |||
| 542 | ||||||
| 543 | 40 | 74 | return @chain; | |||
| 544 | } | |||||
| 545 | ||||||
| 546 | # Recursive function to walk the @ISA hierarchy | |||||
| 547 | sub _walk_isa { | |||||
| 548 | 55 | 55 | my ($class, $chain, $seen) = @_; | |||
| 549 | ||||||
| 550 | 55 | 79 | return if $seen->{$class}++; | |||
| 551 | ||||||
| 552 | # Get the @ISA array for this class | |||||
| 553 | 10 10 10 | 32 4 227 | no strict 'refs'; | |||
| 554 | 55 55 | 52 118 | my @isa = @{"${class}::ISA"}; | |||
| 555 | 10 10 10 | 13 9 6612 | use strict 'refs'; | |||
| 556 | ||||||
| 557 | # Recursively process parent classes first | |||||
| 558 | 55 | 54 | foreach my $parent (@isa) { | |||
| 559 | # Skip common base classes that won't have configs | |||||
| 560 | 15 | 17 | next if $parent eq 'Exporter'; | |||
| 561 | 15 | 12 | next if $parent eq 'DynaLoader'; | |||
| 562 | 15 | 14 | next if $parent eq 'UNIVERSAL'; | |||
| 563 | ||||||
| 564 | 15 | 18 | _walk_isa($parent, $chain, $seen); | |||
| 565 | } | |||||
| 566 | ||||||
| 567 | # Add current class to chain (after parents) | |||||
| 568 | 55 | 66 | push @$chain, $class; | |||
| 569 | } | |||||
| 570 | ||||||
| 571 | # Deep merge two hash references | |||||
| 572 | # Second hash takes precedence over first | |||||
| 573 | sub _deep_merge { | |||||
| 574 | 47 | 42 | my ($base, $overlay) = @_; | |||
| 575 | ||||||
| 576 | 47 | 56 | return $overlay unless ref($base) eq 'HASH'; | |||
| 577 | 47 | 48 | return $base unless ref($overlay) eq 'HASH'; | |||
| 578 | ||||||
| 579 | 47 | 63 | my $result = { %$base }; | |||
| 580 | ||||||
| 581 | 47 | 53 | foreach my $key (keys %$overlay) { | |||
| 582 | 81 | 127 | if (ref($overlay->{$key}) eq 'HASH' && ref($result->{$key}) eq 'HASH') { | |||
| 583 | 2 | 3 | $result->{$key} = _deep_merge($result->{$key}, $overlay->{$key}); | |||
| 584 | } else { | |||||
| 585 | 79 | 74 | $result->{$key} = $overlay->{$key}; | |||
| 586 | } | |||||
| 587 | } | |||||
| 588 | ||||||
| 589 | 47 | 166 | return $result; | |||
| 590 | } | |||||
| 591 | ||||||
| 592 | ||||||
| 593 - 598 | =head2 instantiate($class,...) Create and configure an object of the given class. This is a quick and dirty way of making third-party classes configurable at runtime. =cut | |||||
| 599 | ||||||
| 600 | sub instantiate | |||||
| 601 | { | |||||
| 602 | 3 | 74737 | my $params = Params::Get::get_params('class', @_); | |||
| 603 | ||||||
| 604 | 3 | 37 | my $class = $params->{'class'}; | |||
| 605 | 3 | 3 | $params = configure($class, $params); | |||
| 606 | ||||||
| 607 | 3 | 200 | my $obj = $class->new($params); | |||
| 608 | ||||||
| 609 | # Register object for hot reload if config file is used | |||||
| 610 | 3 | 15 | if ($params->{_config_file}) { | |||
| 611 | 2 | 3 | register_object($class, $obj); | |||
| 612 | } | |||||
| 613 | ||||||
| 614 | 3 | 9 | return $obj; | |||
| 615 | } | |||||
| 616 | ||||||
| 617 - 628 | =head1 HOT RELOAD FEATURES
=head2 enable_hot_reload
Enable hot reloading for configuration files.
Object::Configure::enable_hot_reload(
interval => 5, # Check every 5 seconds (default: 10)
callback => sub { print "Config reloaded!\n"; } # Optional callback
);
=cut | |||||
| 629 | ||||||
| 630 | sub enable_hot_reload { | |||||
| 631 | 2 | 3268 | my %params = @_; | |||
| 632 | ||||||
| 633 | 2 | 4 | my $interval = $params{interval} || 10; | |||
| 634 | 2 | 2 | my $callback = $params{callback}; | |||
| 635 | ||||||
| 636 | # Don't start multiple watchers | |||||
| 637 | 2 | 4 | return if %_config_watchers; | |||
| 638 | ||||||
| 639 | # Fork a background process to watch config files | |||||
| 640 | 2 | 1914 | if (my $pid = fork()) { | |||
| 641 | # Parent process - store the watcher PID | |||||
| 642 | 1 | 22 | $_config_watchers{pid} = $pid; | |||
| 643 | 1 | 8 | $_config_watchers{callback} = $callback; | |||
| 644 | 1 | 30 | return $pid; | |||
| 645 | } elsif (defined $pid) { | |||||
| 646 | # Child process - run the file watcher | |||||
| 647 | 1 | 29 | _run_config_watcher($interval, $callback); | |||
| 648 | 0 | 0 | exit 0; | |||
| 649 | } else { | |||||
| 650 | 0 | 0 | croak("Failed to fork config watcher: $!"); | |||
| 651 | } | |||||
| 652 | } | |||||
| 653 | ||||||
| 654 - 660 | =head2 disable_hot_reload Disable hot reloading and stop the background watcher. Object::Configure::disable_hot_reload(); =cut | |||||
| 661 | ||||||
| 662 | sub disable_hot_reload { | |||||
| 663 | 13 | 2821 | if (my $pid = $_config_watchers{pid}) { | |||
| 664 | 1 | 11 | kill('TERM', $pid); | |||
| 665 | 1 | 169235 | waitpid($pid, 0); | |||
| 666 | 1 | 15 | %_config_watchers = (); | |||
| 667 | } | |||||
| 668 | } | |||||
| 669 | ||||||
| 670 - 676 | =head2 reload_config Manually trigger a configuration reload for all registered objects. Object::Configure::reload_config(); =cut | |||||
| 677 | ||||||
| 678 | sub reload_config { | |||||
| 679 | 12 | 72155 | my $reloaded_count = 0; | |||
| 680 | ||||||
| 681 | 12 | 42 | foreach my $class_key (keys %_object_registry) { | |||
| 682 | 12 | 15 | my $objects = $_object_registry{$class_key}; | |||
| 683 | ||||||
| 684 | # Clean up dead object references | |||||
| 685 | 12 70 | 22 75 | @$objects = grep { defined $_ } @$objects; | |||
| 686 | ||||||
| 687 | 12 | 13 | foreach my $obj_ref (@$objects) { | |||
| 688 | 70 | 71 | if (my $obj = $$obj_ref) { | |||
| 689 | 13 | 15 | eval { | |||
| 690 | 13 | 22 | _reload_object_config($obj); | |||
| 691 | 13 | 334 | $reloaded_count++; | |||
| 692 | }; | |||||
| 693 | 13 | 21 | if ($@) { | |||
| 694 | 0 | 0 | warn "Failed to reload config for object: $@"; | |||
| 695 | } | |||||
| 696 | } | |||||
| 697 | } | |||||
| 698 | ||||||
| 699 | # Remove empty entries | |||||
| 700 | 12 | 17 | delete $_object_registry{$class_key} unless @$objects; | |||
| 701 | } | |||||
| 702 | ||||||
| 703 | 12 | 15 | return $reloaded_count; | |||
| 704 | } | |||||
| 705 | ||||||
| 706 | # Internal function to run the config file watcher | |||||
| 707 | sub _run_config_watcher { | |||||
| 708 | 1 | 5 | my ($interval, $callback) = @_; | |||
| 709 | ||||||
| 710 | # Set up signal handlers for clean shutdown | |||||
| 711 | 1 1 | 73 60 | local $SIG{TERM} = sub { exit 0 }; | |||
| 712 | 1 0 | 18 0 | local $SIG{INT} = sub { exit 0 }; | |||
| 713 | ||||||
| 714 | 1 | 8 | while (1) { | |||
| 715 | 3 | 2003390 | sleep($interval); | |||
| 716 | ||||||
| 717 | 3 | 49 | my $changes_detected = 0; | |||
| 718 | ||||||
| 719 | # Check each monitored config file | |||||
| 720 | 2 | 33 | foreach my $config_file (keys %_config_file_stats) { | |||
| 721 | 2 | 51 | if (-f $config_file) { | |||
| 722 | 2 | 38 | my $current_stat = stat($config_file); | |||
| 723 | 2 | 485 | my $stored_stat = $_config_file_stats{$config_file}; | |||
| 724 | ||||||
| 725 | # Compare modification times | |||||
| 726 | 2 | 42 | if ((!$stored_stat) || ($current_stat->mtime > $stored_stat->mtime)) { | |||
| 727 | 1 | 19 | $_config_file_stats{$config_file} = $current_stat; | |||
| 728 | 1 | 7 | $changes_detected = 1; | |||
| 729 | } | |||||
| 730 | } else { | |||||
| 731 | # File was deleted | |||||
| 732 | 0 | 0 | delete $_config_file_stats{$config_file}; | |||
| 733 | 0 | 0 | $changes_detected = 1; | |||
| 734 | } | |||||
| 735 | } | |||||
| 736 | ||||||
| 737 | 2 | 20 | if($changes_detected) { | |||
| 738 | 1 | 14 | if($^O ne 'MSWin32') { | |||
| 739 | # Reload configurations in the main process | |||||
| 740 | # Use a signal or shared memory mechanism | |||||
| 741 | 1 | 18 | if(my $parent_pid = getppid()) { | |||
| 742 | 1 | 19 | kill('USR1', $parent_pid); | |||
| 743 | } | |||||
| 744 | } | |||||
| 745 | } | |||||
| 746 | } | |||||
| 747 | } | |||||
| 748 | ||||||
| 749 | # Internal function to reload a single object's configuration | |||||
| 750 | sub _reload_object_config { | |||||
| 751 | 13 | 13 | my ($obj) = @_; | |||
| 752 | ||||||
| 753 | 13 | 32 | return unless blessed($obj); | |||
| 754 | ||||||
| 755 | 13 | 19 | my $class = ref($obj); | |||
| 756 | 13 | 8 | my $original_class = $class; | |||
| 757 | 13 | 22 | $class =~ s/::/__/g; | |||
| 758 | ||||||
| 759 | # Get the original config file path if it exists | |||||
| 760 | 13 | 16 | my $config_file = $obj->{_config_file} || $obj->{config_file}; | |||
| 761 | 13 | 99 | return unless $config_file && -f $config_file; | |||
| 762 | ||||||
| 763 | # Reload the configuration | |||||
| 764 | 12 | 60 | my $config = Config::Abstraction->new( | |||
| 765 | config_file => $config_file, | |||||
| 766 | env_prefix => "${class}__" | |||||
| 767 | ); | |||||
| 768 | ||||||
| 769 | 12 | 18237 | if ($config) { | |||
| 770 | # Use merge_defaults with empty defaults to get just the config values | |||||
| 771 | 12 | 22 | my $new_params = $config->merge_defaults( | |||
| 772 | defaults => {}, | |||||
| 773 | section => $class, | |||||
| 774 | merge => 1, | |||||
| 775 | deep => 1 | |||||
| 776 | ); | |||||
| 777 | ||||||
| 778 | # Update object properties, preserving non-config data | |||||
| 779 | 12 | 559 | foreach my $key (keys %$new_params) { | |||
| 780 | 13 | 20 | next if $key =~ /^_/; # Skip private properties | |||
| 781 | ||||||
| 782 | 13 | 22 | if($key =~ /^logger/ && $new_params->{$key} ne 'NULL') { | |||
| 783 | # Handle logger reconfiguration specially | |||||
| 784 | 1 | 3 | _reconfigure_logger($obj, $key, $new_params->{$key}); | |||
| 785 | } else { | |||||
| 786 | 12 | 13 | $obj->{$key} = $new_params->{$key}; | |||
| 787 | } | |||||
| 788 | } | |||||
| 789 | ||||||
| 790 | # Call object's reload hook if it exists | |||||
| 791 | 12 | 39 | if ($obj->can('_on_config_reload')) { | |||
| 792 | 12 | 20 | $obj->_on_config_reload($new_params); | |||
| 793 | } | |||||
| 794 | ||||||
| 795 | # Log the reload if logger exists | |||||
| 796 | 12 | 97 | if ($obj->{logger} && $obj->{logger}->can('info')) { | |||
| 797 | 12 | 32 | $obj->{logger}->info("Configuration reloaded for $original_class"); | |||
| 798 | } | |||||
| 799 | } | |||||
| 800 | } | |||||
| 801 | ||||||
| 802 | # Internal function to reconfigure the logger | |||||
| 803 | sub _reconfigure_logger | |||||
| 804 | { | |||||
| 805 | 1 | 2 | my ($obj, $key, $logger_config) = @_; | |||
| 806 | ||||||
| 807 | 1 | 2 | if (ref($logger_config) eq 'HASH') { | |||
| 808 | # Create new logger with new config | |||||
| 809 | 0 | 0 | my $carp_on_warn = $obj->{carp_on_warn} || 0; | |||
| 810 | ||||||
| 811 | 0 | 0 | if ($logger_config->{syslog}) { | |||
| 812 | $obj->{$key} = Log::Abstraction->new({ | |||||
| 813 | carp_on_warn => $carp_on_warn, | |||||
| 814 | syslog => $logger_config->{syslog}, | |||||
| 815 | 0 | 0 | %$logger_config | |||
| 816 | }); | |||||
| 817 | } else { | |||||
| 818 | 0 | 0 | $obj->{$key} = Log::Abstraction->new({ | |||
| 819 | carp_on_warn => $carp_on_warn, | |||||
| 820 | %$logger_config | |||||
| 821 | }); | |||||
| 822 | } | |||||
| 823 | } else { | |||||
| 824 | 1 | 2 | $obj->{$key} = $logger_config; | |||
| 825 | } | |||||
| 826 | } | |||||
| 827 | ||||||
| 828 - 837 | =head2 register_object Register an object for hot reload monitoring. Object::Configure::register_object($class, $obj); This is automatically called by the configure() function when a config file is used, but can also be called manually to register objects for hot reload. =cut | |||||
| 838 | ||||||
| 839 | sub register_object { | |||||
| 840 | 17 | 987 | my ($class, $obj) = @_; | |||
| 841 | ||||||
| 842 | # Use weak references to avoid memory leaks | |||||
| 843 | 17 | 9 | my $obj_ref = \$obj; | |||
| 844 | 17 | 26 | weaken($$obj_ref); | |||
| 845 | ||||||
| 846 | 17 17 | 8 17 | push @{$_object_registry{$class}}, $obj_ref; | |||
| 847 | ||||||
| 848 | # Set up signal handler for hot reload (only once) | |||||
| 849 | 17 | 23 | if (!defined $_original_usr1_handler) { | |||
| 850 | # Store the existing handler (could be DEFAULT, IGNORE, or a code ref) | |||||
| 851 | 6 | 27 | $_original_usr1_handler = $SIG{USR1} || 'DEFAULT'; | |||
| 852 | ||||||
| 853 | 6 | 11 | return if($^O eq 'MSWin32'); # There is no SIGUSR1 on Windows | |||
| 854 | ||||||
| 855 | $SIG{USR1} = sub { | |||||
| 856 | # Handle our hot reload first | |||||
| 857 | 3 | 1016589 | reload_config(); | |||
| 858 | 3 | 4 | if ($_config_watchers{callback}) { | |||
| 859 | 1 | 5 | $_config_watchers{callback}->(); | |||
| 860 | } | |||||
| 861 | ||||||
| 862 | # Chain to the original handler if it exists and is callable | |||||
| 863 | 3 | 8 | if (ref($_original_usr1_handler) eq 'CODE') { | |||
| 864 | 3 | 3 | $_original_usr1_handler->(); | |||
| 865 | } elsif ($_original_usr1_handler eq 'DEFAULT') { | |||||
| 866 | # Let the default handler run (which typically does nothing for USR1) | |||||
| 867 | # We don't need to explicitly call it | |||||
| 868 | } elsif ($_original_usr1_handler eq 'IGNORE') { | |||||
| 869 | # Do nothing - the signal was being ignored | |||||
| 870 | } | |||||
| 871 | # Note: If it was some other string, it was probably a custom handler name | |||||
| 872 | # but we can't easily call those, so we'll just warn | |||||
| 873 | elsif ($_original_usr1_handler ne 'DEFAULT' && $_original_usr1_handler ne 'IGNORE') { | |||||
| 874 | 0 | 0 | warn "Object::Configure: Cannot chain to non-code USR1 handler: $_original_usr1_handler"; | |||
| 875 | } | |||||
| 876 | 6 | 49 | }; | |||
| 877 | } | |||||
| 878 | } | |||||
| 879 | ||||||
| 880 - 887 | =head2 restore_signal_handlers Restore original signal handlers and disable hot reload integration. Useful when you want to cleanly shut down the hot reload system. Object::Configure::restore_signal_handlers(); =cut | |||||
| 888 | ||||||
| 889 | sub restore_signal_handlers | |||||
| 890 | { | |||||
| 891 | 16 | 204282 | if (defined $_original_usr1_handler) { | |||
| 892 | 6 | 31 | $SIG{USR1} = $_original_usr1_handler if($^O ne 'MSWin32'); # There is no SIGUSR1 on Windows | |||
| 893 | 6 | 20 | $_original_usr1_handler = undef; | |||
| 894 | } | |||||
| 895 | } | |||||
| 896 | ||||||
| 897 - 906 | =head2 get_signal_handler_info
Get information about the current signal handler setup.
Useful for debugging signal handler chains.
my $info = Object::Configure::get_signal_handler_info();
print "Original USR1 handler: ", $info->{original_usr1} || 'none', "\n";
print "Hot reload active: ", $info->{hot_reload_active} ? 'yes' : 'no', "\n";
=cut | |||||
| 907 | ||||||
| 908 | sub get_signal_handler_info { | |||||
| 909 | return { | |||||
| 910 | original_usr1 => $_original_usr1_handler, | |||||
| 911 | current_usr1 => $SIG{USR1}, | |||||
| 912 | hot_reload_active => defined $_original_usr1_handler, | |||||
| 913 | watcher_pid => $_config_watchers{pid}, | |||||
| 914 | 2 | 10 | }; | |||
| 915 | } | |||||
| 916 | ||||||
| 917 | # Cleanup on module destruction | |||||
| 918 | END { | |||||
| 919 | 10 | 83100 | disable_hot_reload(); | |||
| 920 | ||||||
| 921 | # Restore original USR1 handler if we modified it | |||||
| 922 | 10 | 18 | restore_signal_handlers(); | |||
| 923 | } | |||||
| 924 | ||||||
| 925 - 969 | =head1 SEE ALSO =over 4 =item * L<Config::Abstraction> =item * L<Log::Abstraction> =item * Test coverage report: L<https://nigelhorne.github.io/Object-Configure/coverage/> =back =head1 SUPPORT This module is provided as-is without any warranty. Please report any bugs or feature requests to C<bug-object-configure at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Object-Configure>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. You can find documentation for this module with the perldoc command. perldoc Object::Configure =head1 LICENSE AND COPYRIGHT Copyright 2025 Nigel Horne. Usage is subject to licence terms. The licence terms of this software are as follows: =over 4 =item * Personal single user, single computer use: GPL2 =item * All other users (including Commercial, Charity, Educational, Government) must apply in writing for a licence for use from Nigel Horne at the above e-mail. =back =cut | |||||
| 970 | ||||||
| 971 | 1; | |||||