File Coverage

File:blib/lib/Object/Configure.pm
Coverage:80.3%

linestmtbrancondsubtimecode
1package 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
18our %_object_registry = ();
19our %_config_watchers = ();
20our %_config_file_stats = ();
21
22# Keep track of the original USR1 handler for chaining
23our $_original_usr1_handler;
24
25 - 33
=head1 NAME

Object::Configure - Runtime Configuration for an Object

=head1 VERSION

0.17

=cut
34
35our $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
271sub 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
481sub _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
536sub _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
547sub _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
573sub _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
600sub 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
630sub 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
662sub 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
678sub 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
707sub _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
750sub _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
803sub _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
839sub 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
889sub 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
908sub 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
918END {
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
9711;