File Coverage

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

linestmtbrancondsubtimecode
1package Object::Configure;
2
3
20
20
20
1647344
22
252
use strict;
4
20
20
20
33
11
379
use warnings;
5
6
20
20
20
36
11
485
use Carp;
7
20
20
20
4111
615803
318
use Config::Abstraction 0.38;
8
20
20
20
56
18
261
use File::Spec;
9
20
20
20
4145
196228
336
use Log::Abstraction 0.26;
10
20
20
20
50
93
279
use Params::Get 0.13;
11
20
20
20
40
26
255
use Return::Set;
12
20
20
20
36
10
382
use Scalar::Util qw(blessed weaken);
13
20
20
20
35
12
80
use Time::HiRes qw(time);
14
20
20
20
4582
50526
15717
use File::stat;
15
16# Global registry to track configured objects for hot reload
17our %_object_registry = ();
18our %_config_watchers = ();
19our %_config_file_stats = ();
20
21# Keep track of the original USR1 handler for chaining
22our $_original_usr1_handler;
23
24 - 32
=head1 NAME

Object::Configure - Runtime Configuration for an Object

=head1 VERSION

0.21

=cut
33
34our $VERSION = 0.21;
35
36 - 408
=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: ~/.conf/my-base-class.yml
    ---
    My__Base__Class:
      timeout: 30
      retries: 3
      log_level: info

    # File: ~/.conf/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.

=head3 UNIVERSAL CONFIGURATION

All Perl classes implicitly inherit from C<UNIVERSAL>.
C<Object::Configure> takes advantage of this to provide a mechanism for universal configuration settings
that apply to all classes by default.

If you create a configuration file named C<universal.yml> (or C<universal.conf>, C<universal.json>, etc.)
in your configuration directory,
the settings in its C<UNIVERSAL> section will be inherited by all classes that use C<Object::Configure>,
unless explicitly overridden by class-specific configuration files.

This is particularly useful for setting application-wide defaults such as logging levels,
timeout values,
or other common parameters that should apply across all modules.

Example C<~/.conf/universal.yml>:

    ---
    UNIVERSAL:
      timeout: 30
      retries: 3
      logger:
        level: info

With this universal configuration file in place,
all classes will inherit these default values.
Individual classes can override any of these settings in their own configuration files:

Example C<~/.conf/my-special-class.yml>:

    ---
    My__Special__Class:
      timeout: 120
      # Inherits retries: 3 and logger.level: info from UNIVERSAL

The universal configuration is loaded first in the inheritance chain,
followed by parent class configurations,
and finally the specific class configuration,
with later configurations overriding earlier ones.

=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";

=encoding utf8

=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.

=head3 API Specification

=head4 Input

    schema => {
        class => {
            type => 'string',
            required => 1,
            description => 'Fully-qualified class name'
        },
        params => {
            type => 'hashref',
            optional => 1,
            default => {},
            schema => {
                config_file => {
                    type => 'string',
                    optional => 1,
                    description => 'Configuration file basename'
                }, config_dirs => {
                    type => 'arrayref',
                    optional => 1,
                    description => 'Directories to search for config files'
                }, logger => {
                    type => [qw(hashref coderef object string arrayref)],
                    optional => 1,
                    description => 'Logger configuration or instance'
                }, carp_on_warn => {
                    type => 'boolean',
                    optional => 1,
                    default => 0,
                    description => 'Use Carp::carp for warnings'
                }, croak_on_error => {
                    type => 'boolean',
                    optional => 1,
                    default => 1,
                    description => 'Use Carp::croak for errors'
                }
            }
        }
    }

=head4 Output

    type => 'hashref',
    description => 'Merged configuration parameters',
    schema => {
        logger => {
            type => 'object',
            isa => 'Log::Abstraction',
            description => 'Initialized logger instance'
        },
        _config_file => {
            type => 'string',
            optional => 1,
            description => 'Primary configuration file path'
        },
        _config_files => {
            type => 'arrayref',
            optional => 1,
            description => 'All loaded configuration file paths'
        }
    }

=head3 Formal Specification

    configure: Class × Params → ConfigHash

    Given:
    - C: set of all class names
    - P: set of all parameter hashes
    - F: set of all file paths
    - H: set of all configuration hashes

    State:
    - ConfigFiles: F → H (maps file paths to configuration content)
    - EnvVars: String → String (environment variables)
    - InheritanceChain: C → seq C (ordered sequence of ancestor classes)

    Pre-condition:
    âˆ€ class ∈ C, params ∈ P •
        class ≠ ∅ ∧
        (params.config_file ≠ ∅ ⇒
            (∃ dir ∈ params.config_dirs • readable(dir/params.config_file)) ∨
            readable(params.config_file))

    Post-condition:
    âˆ€ result ∈ H •
        result = params ⊕
                 (⊕ f ∈ InheritanceConfigFiles(class) • ConfigFiles(f)) ⊕
                 (⊕ v ∈ RelevantEnvVars(class) • v) ∧
        result.logger ∈ Log::Abstraction ∧
        (∀ k ∈ dom params •
            (params(k) ∈ CodeRef ∨ blessed(params(k))) ⇒ result(k) = params(k))

    where ⊕ denotes hash merge with right-precedence

=cut
409
410sub configure {
411
202
2981366
        my $class = $_[0];
412
202
291
        my $params = $_[1] || {};       # Contains the defaults, the run time config will overwrite them
413
202
199
        my $array;
414
415
202
516
        croak(__PACKAGE__, ': configure: what class do you want to configure?') if(!defined($class) || $class eq '');
416
417        # Stash coderefs and blessed objects EXCEPT logger (which needs special handling)
418
419        # Config::Abstraction treats unknown scalar values as config file paths and will
420        # attempt to read them, which corrupts coderefs and object references.
421        # We must remove these from $params before calling configure(), then restore them
422        # afterward. The logger parameter has its own special handling below, so we skip it here.
423        # This automatic stashing means users don't need to implement the stash-delete-restore
424        # pattern in their own constructors.
425
196
191
        my %stashed_values;
426
196
270
        foreach my $key (keys %$params) {
427
298
264
                next if $key eq 'logger';       # logger has its own special handling below
428
263
197
                my $value = $params->{$key};
429
263
543
                if(ref($value) eq 'CODE' || blessed($value)) {
430
36
46
                        $stashed_values{$key} = delete $params->{$key};
431                }
432        }
433
434
196
334
        if(exists($params->{'logger'}) && (ref($params->{'logger'}) eq 'ARRAY')) {
435
5
5
                $array = delete $params->{'logger'};
436        }
437
438
196
142
        my $original_class = $class;
439
196
347
        $class =~ s/::/__/g;
440
441        # Store config file path for hot reload
442
196
178
        my $config_file = $params->{'config_file'};
443
196
139
        my $config_dirs = $params->{'config_dirs'};
444
445        # Get inheritance chain for finding ancestor config files
446
196
238
        my @inheritance_chain = _get_inheritance_chain($original_class);
447
448        # Build list of config files to load (ancestor to child order)
449
196
210
        my @config_files_to_load = ();
450
196
145
        my %tracked_files = ();
451
452
196
181
        if ($config_file) {
453                # Check if primary config file is readable (unless config_dirs provided)
454
95
377
                if ((!$config_dirs) && (!-r $config_file)) {
455
7
132
                        croak("$class: ", $config_file, ": $!");
456                }
457
458                # Find config files for each class in the hierarchy
459                # Important: iterate in reverse order (base -> parent -> child)
460
88
96
                foreach my $ancestor_class (reverse @inheritance_chain) {
461
191
2563
                        my $ancestor_config_file = _find_class_config_file(
462                                $ancestor_class,
463                                $config_file,
464                                $config_dirs
465                        );
466
467                        # Skip if this is the primary config file - it will be added at the end
468
191
229
                        if ($ancestor_config_file && $ancestor_config_file eq $config_file) {
469
8
7
                                next;
470                        }
471
472                        # Only add if we found a file and haven't already added it
473
183
351
                        if ($ancestor_config_file && -r $ancestor_config_file && !$tracked_files{$ancestor_config_file}) {
474
39
62
                                push @config_files_to_load, {
475                                        file => $ancestor_config_file,
476                                        class => $ancestor_class
477                                };
478
39
64
                                $tracked_files{$ancestor_config_file} = 1;
479
480                                # Track for hot reload
481
39
103
                                if (-f $ancestor_config_file) {
482
39
65
                                        $_config_file_stats{$ancestor_config_file} = stat($ancestor_config_file);
483                                }
484                        }
485                }
486
487                # Ensure the primary config file is included LAST (highest priority)
488                # This handles the case where the primary file doesn't match the class name pattern
489
88
801
                if ($config_file && !$tracked_files{$config_file} && -r $config_file) {
490
27
65
                        push @config_files_to_load, {
491                                file => $config_file,
492                                class => $original_class
493                        };
494
27
29
                        $tracked_files{$config_file} = 1;
495
496
27
80
                        if (-f $config_file) {
497
27
69
                                $_config_file_stats{$config_file} = stat($config_file);
498                        }
499                }
500
501
88
2385
                if(!scalar(@config_files_to_load)) {
502                        # Can't find an inheritence tree
503
41
41
27
27
                        foreach my $dir(@{$config_dirs}) {
504
41
105
                                my $candidate = File::Spec->catfile($dir, $config_file);
505
41
168
                                if(-r $candidate) {
506
38
57
                                        push @config_files_to_load, {
507                                                file => $candidate,
508                                                class => $original_class
509                                        };
510
38
38
                                        last;  # CRITICAL: Stop at first readable file
511                                }
512                        }
513                }
514        }
515
516        # Load and merge configurations from all files
517
189
392
        if (@config_files_to_load) {
518                # Sort by class hierarchy to ensure correct order (base -> parent -> child)
519                # This must happen AFTER all files are collected
520
85
83
                if (@config_files_to_load) {
521
85
65
                        my %class_order;
522
85
128
                        for my $i (0..$#inheritance_chain) {
523
185
190
                                $class_order{$inheritance_chain[$i]} = $i;
524                        }
525                        @config_files_to_load = sort {
526
85
24
136
46
                                ($class_order{$a->{class}} // 999) <=> ($class_order{$b->{class}} // 999)
527                        } @config_files_to_load;
528                }
529
530                # Start with the passed-in defaults
531
85
129
                my $merged_params = { %$params };
532
533
85
95
                foreach my $config_info (@config_files_to_load) {
534
104
224
                        my $cfg_file = $config_info->{file};
535
104
70
                        my $cfg_class = $config_info->{class};
536
104
85
                        my $section_name = $cfg_class;
537
104
132
                        $section_name =~ s/::/__/g;
538
539                        # When loading individual config files for inheritance,
540                        # don't pass config_dirs - just load the specific file
541
104
376
                        my $config = Config::Abstraction->new(
542                                config_file => $cfg_file,
543                                env_prefix => "${section_name}__"
544                        );
545
546
104
138521
                        if ($config) {
547                                # Get this config file's values for the section
548
104
198
                                my $this_config = $config->merge_defaults(
549                                        defaults => {},
550                                        section => $section_name,
551                                        merge => 1,
552                                        deep => 1
553                                );
554
555                                # Deep merge: later configs override earlier ones
556
104
7228
                                $merged_params = _deep_merge($merged_params, $this_config);
557                        } elsif ($@) {
558
0
0
                                carp("Warning: Can't load configuration from $cfg_file: $@");
559                        }
560                }
561
562
85
696
                $params = $merged_params;
563        } elsif (my $config = Config::Abstraction->new(env_prefix => "${class}__")) {
564                # Handle environment variables with inheritance
565
4
3500
                my $merged_config = {};
566
567                # Merge ancestor configurations from environment
568
4
8
                foreach my $ancestor_class (reverse @inheritance_chain) {
569
8
35
                        my $section_name = $ancestor_class;
570
8
13
                        $section_name =~ s/::/__/g;
571
572
8
15
                        my $ancestor_env_config = Config::Abstraction->new(
573                                env_prefix => "${section_name}__"
574                        );
575
576
8
3353
                        if ($ancestor_env_config) {
577
4
12
                                my $ancestor_config = $ancestor_env_config->merge_defaults(
578                                        defaults => {},
579                                        section => $section_name,
580                                        merge => 1,
581                                        deep => 1
582                                );
583
4
308
                                $merged_config = _deep_merge($merged_config, $ancestor_config);
584                        }
585                }
586
587
4
11
                $params = $config->merge_defaults(
588                        defaults => $params,
589                        section => $class,
590                        merge => 1,
591                        deep => 1
592                );
593
594                # Apply inherited config
595
4
197
                $params = _deep_merge($merged_config, $params);
596
597                # Track this config file for hot reload
598
4
16
                if ($params->{config_path} && -f $params->{config_path}) {
599
0
0
                        $_config_file_stats{$params->{config_path}} = stat($params->{config_path});
600                }
601        }
602
603
189
62071
        my $croak_on_error = exists($params->{'croak_on_error'}) ? $params->{'croak_on_error'} : 1;
604
189
194
        my $carp_on_warn = exists($params->{'carp_on_warn'}) ? $params->{'carp_on_warn'} : 0;
605
606        # Load the default logger
607
189
265
        if (my $logger = $params->{'logger'}) {
608
40
200
                if(!ref($logger) && $logger eq 'NULL') {
609                        # Explicitly keep NULL - do not create a logger
610                        # The logger param stays as the string 'NULL'
611                } elsif(ref($logger) eq 'HASH') {
612
22
32
                        if(exists $logger->{'syslog'}) {
613                                $params->{'logger'} = Log::Abstraction->new({
614                                        carp_on_warn => $carp_on_warn,
615                                        syslog => $logger->{'syslog'},
616
7
7
8
26
                                        %{$logger}
617                                });
618                        } else {
619                                $params->{'logger'} = Log::Abstraction->new({
620                                        carp_on_warn => $carp_on_warn,
621
15
15
12
56
                                        %{$logger}
622                                });
623                        }
624                } elsif(!blessed($logger) || !$logger->isa('Log::Abstraction')) {
625
7
15
                        $params->{'logger'} = Log::Abstraction->new({
626                                carp_on_warn => $carp_on_warn,
627                                logger => $logger
628                        });
629                }
630        } elsif ($array) {
631
5
8
                $params->{'logger'} = Log::Abstraction->new(
632                        array => $array,
633                        carp_on_warn => $carp_on_warn
634                );
635
5
121
                undef $array;
636        } else {
637
144
343
                $params->{'logger'} = Log::Abstraction->new(carp_on_warn => $carp_on_warn);
638        }
639
640
189
495564
        if(exists($params->{'logger'}) && ref($params->{'logger'})) {
641
181
215
                if ($array && !$params->{'logger'}->{'array'}) {
642
0
0
                        $params->{'logger'}->{'array'} = $array;
643                }
644
645
181
196
                if ($array && !$params->{'logger'}->{'array'}) {
646
0
0
                        $params->{'logger'}->{'array'} = $array;
647                }
648        }
649
650        # Store config file path in params for hot reload
651        # Preserve user-provided internal keys
652
189
194
        if (!exists($params->{_config_file})) {
653
186
252
                $params->{_config_file} = $config_file if defined($config_file);
654        }
655
189
197
        if (!exists($params->{_config_files})) {
656
186
104
185
190
                $params->{_config_files} = [map { $_->{file} } @config_files_to_load] if @config_files_to_load;
657        }
658
659        # Restore stashed coderefs and objects via hash slice
660
189
22
246
23
        @{$params}{keys %stashed_values} = values %stashed_values if %stashed_values;
661
662
189
363
        return Return::Set::set_return($params, { 'type' => 'hashref' });
663}
664
665# Find the appropriate config file for a given class
666# Looks for class-specific config files based on naming conventions
667sub _find_class_config_file {
668
207
26314
        my ($class, $base_config_file, $config_dirs) = @_;
669
670        # Convert class name to file-friendly format
671
207
194
        my $class_file = lc($class);
672
207
231
        $class_file =~ s/::/-/g;
673
674        # Extract directory and extension from base config file using File::Spec
675        # so that path separators are handled correctly on all platforms
676
207
1236
        my ($base_vol, $base_dir_part, $base_name_ext) = File::Spec->splitpath($base_config_file);
677
207
648
        my (undef, $base_ext) = $base_name_ext =~ /^(.*?)(\.[^.]+)?$/;
678
207
241
        $base_ext //= '';       # $2 is undef when there is no extension
679
207
481
        my $base_dir = File::Spec->catpath($base_vol, $base_dir_part, '');
680
681        # Try base directory patterns first
682
207
1999
        my @base_patterns = (
683                File::Spec->catfile($base_dir, "${class_file}${base_ext}"),
684                File::Spec->catfile($base_dir, "${class_file}.conf"),
685                File::Spec->catfile($base_dir, "${class_file}.yml"),
686                File::Spec->catfile($base_dir, "${class_file}.yaml"),
687                File::Spec->catfile($base_dir, "${class_file}.json"),
688        );
689
690
207
402
        foreach my $pattern (@base_patterns) {
691
939
2910
                if (-r $pattern && -f $pattern) {
692
24
43
                        return $pattern;
693                }
694        }
695
696        # Then try config_dirs in order - fully check each dir before moving to next
697
183
290
        if ($config_dirs && ref($config_dirs) eq 'ARRAY') {
698
145
124
                foreach my $dir (@$config_dirs) {
699                        # Remove trailing slash if present
700
144
105
                        $dir =~ s{/$}{};
701
144
252
                        my @dir_patterns = (
702                                "${dir}/${class_file}${base_ext}",
703                                "${dir}/${class_file}.conf",
704                                "${dir}/${class_file}.yml",
705                                "${dir}/${class_file}.yaml",
706                                "${dir}/${class_file}.json",
707                        );
708
144
81
                        foreach my $pattern (@dir_patterns) {
709
581
2033
                                if (-r $pattern && -f $pattern) {
710
35
78
                                        return $pattern;
711                                }
712                        }
713                }
714        }
715
716
148
199
        return undef;
717}
718
719# Helper function to get the inheritance chain for a class
720sub _get_inheritance_chain {
721
208
92205
        my ($class) = @_;
722
208
216
        my @chain = ();
723
208
134
        my %seen = ();
724
725
208
294
        _walk_isa($class, \@chain, \%seen);
726
727
208
319
        return @chain;
728}
729
730# Recursive function to walk the @ISA hierarchy
731sub _walk_isa {
732
467
5359
        my ($class, $chain, $seen) = @_;
733
734
467
592
        return if $seen->{$class}++;
735
736        # Get the @ISA array for this class
737
20
20
20
65
20
518
        no strict 'refs';
738
463
463
248
941
        my @isa = @{"${class}::ISA"};
739
20
20
20
35
10
15884
        use strict 'refs';
740
741        # Recursively process parent classes first
742
463
350
        foreach my $parent (@isa) {
743                # Skip common base classes that won't have configs
744                # next if $parent eq 'Exporter';
745                # next if $parent eq 'DynaLoader';
746                # next if $parent eq 'UNIVERSAL';
747
748
44
35
                _walk_isa($parent, $chain, $seen);
749        }
750
751        # If this class has no parents and isn't UNIVERSAL itself,
752        # explicitly add UNIVERSAL as a parent
753
463
653
        if (!@isa && $class ne 'UNIVERSAL') {
754
211
202
                _walk_isa('UNIVERSAL', $chain, $seen);
755        }
756
757        # Add current class to chain (after parents)
758
463
430
        push @$chain, $class;
759}
760
761# Deep merge two hash references
762# Second hash takes precedence over first
763sub _deep_merge {
764
152
47296
        my ($base, $overlay) = @_;
765
766
152
193
        return $overlay unless ref($base) eq 'HASH';
767
147
164
        return $overlay unless ref($overlay) eq 'HASH';
768
769
140
178
        my $result = { %$base };
770
771
140
200
        foreach my $key (keys %$overlay) {
772
1229
957
                if (ref($overlay->{$key}) eq 'HASH' && ref($result->{$key}) eq 'HASH') {
773
6
17
                        $result->{$key} = _deep_merge($result->{$key}, $overlay->{$key});
774                } else {
775
1223
931
                        $result->{$key} = $overlay->{$key};
776                }
777        }
778
779
140
523
        return $result;
780}
781
782
783 - 884
=head2 instantiate($class,...)

Create and configure an object of a third-party class without modifying the class itself.

=head3 Purpose

Provides a convenient way to make third-party classes (those you cannot modify) configurable
at runtime using Object::Configure. This is a wrapper that calls C<configure> and then
instantiates the class.

=head3 Arguments

Takes a hash or hashref with the following keys:

=over 4

=item * C<class> (Required)

The fully-qualified class name to instantiate (e.g., C<'LWP::UserAgent'>).

=item * Additional keys

Any additional keys are passed through to C<configure> and then to the class constructor.

=back

=head3 Returns

A blessed object of the specified class, configured according to the parameters and
configuration files.

=head3 Side Effects

=over 4

=item * Calls C<configure> (see its side effects)

=item * Calls the C<new> method on the specified class

=item * Registers the object for hot reload if a configuration file was used

=back

=head3 Notes

The specified class must have a C<new> method that accepts a hashref of parameters.
This is a "quick and dirty" way to add configuration support to classes you don't control.

=head3 Usage Example

    use Object::Configure;

    # Configure LWP::UserAgent from a config file
    my $ua = Object::Configure::instantiate(
        class => 'LWP::UserAgent',
        config_file => 'lwp.yml',
        config_dirs => ['/etc/myapp'],
        timeout => 30
    );

=head3 API Specification

=head4 Input

    schema => {
        class => {
            type => 'string',
            required => 1,
            description => 'Class name to instantiate',
            can => 'new'
        }
    }

=head4 Output

    type => 'object',
    description => 'Instance of the specified class'

=head3 Formal Specification

    instantiate: Params → Object

    Given:
    - P: set of all parameter hashes
    - C: set of all class names
    - O: set of all objects

    Pre-condition:
    âˆ€ params ∈ P •
        params.class ∈ C ∧
        params.class.can('new')

    Post-condition:
    âˆ€ result ∈ O •
        âˆƒ config ∈ H •
            config = configure(params.class, params) ∧
            result = params.class.new(config) ∧
            blessed(result) = params.class ∧
            (config._config_file ≠ ∅ ⇒
                result ∈ _object_registry(params.class))

=cut
885
886sub instantiate
887{
888
12
93982
        my $params = Params::Get::get_params('class', @_);
889
890
12
167
        my $class = $params->{'class'};
891
12
24
        $params = configure($class, $params);
892
893
12
883
        my $obj = $class->new($params);
894
895        # Register object for hot reload if config file is used
896
11
59
        if ($params->{_config_file}) {
897
4
5
                register_object($class, $obj);
898        }
899
900
11
19
        return $obj;
901}
902
903 - 1032
=head1 HOT RELOAD FEATURES

=head2 enable_hot_reload

Enable automatic hot reloading of configuration files when they are modified.

=head3 Purpose

Starts a background process that monitors configuration files for changes and automatically
reloads them into registered objects. This allows runtime configuration updates without
restarting the application.

=head3 Arguments

Takes a hash with the following optional keys:

=over 4

=item * C<interval> (Optional, default: 10)

Number of seconds between configuration file checks. Lower values provide faster
response to changes but consume more CPU.

=item * C<callback> (Optional)

A coderef to execute after configuration files are reloaded. Useful for logging
or triggering application-specific reload behavior.

=back

=head3 Returns

The process ID (PID) of the background watcher process on success.
Returns immediately if hot reload is already enabled.

=head3 Side Effects

=over 4

=item * Forks a background process to monitor configuration files

=item * The background process sends SIGUSR1 to the parent when changes are detected

=item * Stores the watcher PID in C<%_config_watchers>

=item * May throw an exception (via C<croak>) if the fork fails

=back

=head3 Notes

Hot reload is not supported on Windows due to lack of SIGUSR1 signal support.
The background process runs indefinitely until C<disable_hot_reload> is called.
Objects must be registered via C<register_object> to receive configuration updates.

=head3 Usage Example

    use Object::Configure;

    # Enable hot reload with 5-second check interval
    Object::Configure::enable_hot_reload(
        interval => 5,
        callback => sub {
            my $timestamp = localtime;
            print "[$timestamp] Configuration reloaded\n";
        }
    );

    # Application continues running...
    while (1) {
        # Do work...
        sleep(1);
    }

=head3 API Specification

=head4 Input

    schema => {
        interval => {
            type => 'integer',
            optional => 1,
            default => 10,
            min => 1,
            description => 'Check interval in seconds'
        },
        callback => {
            type => 'coderef',
            optional => 1,
            description => 'Code to execute after reload'
        }
    }

=head4 Output

    type => 'integer',
    description => 'PID of background watcher process',
    condition => 'value > 0'

=head3 Formal Specification

    enable_hot_reload: Interval × Callback → PID

    Given:
    - I: set of positive integers (intervals in seconds)
    - CB: set of code references
    - PID: set of process identifiers

    State:
    - _config_watchers: {pid: PID, callback: CB}
    - _config_file_stats: F → Stat

    Pre-condition:
    âˆ€ interval ∈ I, callback ∈ CB ∪ {∅} •
        interval ≥ 1 ∧
        _config_watchers = ∅ ∧
        OS ≠ 'MSWin32'

    Post-condition:
    âˆ€ result ∈ PID •
        result > 0 ∧
        _config_watchers.pid = result ∧
        _config_watchers.callback = callback ∧
        (∀ t ∈ Time •
            (t mod interval = 0) ⇒
                (∃ f ∈ dom _config_file_stats •
                    mtime(f) > _config_file_stats(f).mtime ⇒
                        send_signal(SIGUSR1, parent_process)))

=cut
1033
1034
1035sub enable_hot_reload {
1036
9
12007
        my %params = @_;
1037
1038
9
19
        my $interval = $params{interval} || 10;
1039
9
9
        my $callback = $params{callback};
1040
1041        # Don't start multiple watchers
1042
9
18
        return if %_config_watchers;
1043
1044        # Fork a background process to watch config files
1045
7
6326
        if (my $pid = fork()) {
1046                # Parent process - store the watcher PID
1047
4
160
                $_config_watchers{pid} = $pid;
1048
4
77
                $_config_watchers{callback} = $callback;
1049
4
216
                return $pid;
1050        } elsif (defined $pid) {
1051                # Child process - run the file watcher
1052
3
156
                _run_config_watcher($interval, $callback);
1053
0
0
                exit 0;
1054        } else {
1055
0
0
                croak("Failed to fork config watcher: $!");
1056        }
1057}
1058
1059 - 1131
=head2 disable_hot_reload

Disable hot reloading and terminate the background watcher process.

=head3 Purpose

Cleanly shuts down the hot reload system by terminating the background watcher
process and clearing internal state.

=head3 Arguments

None.

=head3 Returns

Nothing.

=head3 Side Effects

=over 4

=item * Sends SIGTERM to the background watcher process

=item * Waits for the watcher process to terminate

=item * Clears C<%_config_watchers> state

=back

=head3 Notes

Safe to call even if hot reload is not currently enabled.
The function blocks until the watcher process has fully terminated.

=head3 Usage Example

    use Object::Configure;

    # Enable hot reload
    Object::Configure::enable_hot_reload(interval => 5);

    # ... application runs ...

    # Clean shutdown
    Object::Configure::disable_hot_reload();

=head3 API Specification

=head4 Input

    schema => {}

=head4 Output

    type => 'void'

=head3 Formal Specification

    disable_hot_reload: () → ()

    State:
    - _config_watchers: {pid: PID, callback: CB}

    Pre-condition:
    true

    Post-condition:
    _config_watchers = ∅ ∧
    (∀ p ∈ PID •
        p = _config_watchers.pid@pre ⇒
            Â¬alive(p))

=cut
1132
1133sub disable_hot_reload {
1134        ## MUTANT_SKIP_BEGIN
1135
33
18822
        if (my $pid = $_config_watchers{pid}) {
1136                # Guard against non-numeric PIDs (e.g. from mutation testing)
1137
4
94
                if($pid =~ /\A[0-9]+\z/ && $pid > 0) {
1138
4
38
                        kill('TERM', $pid);
1139
1140                        # Wait up to 5 seconds for the child to exit; if it doesn't respond
1141                        # to SIGTERM, escalate to SIGKILL to avoid hanging indefinitely
1142
4
26
                        my $deadline = time() + 5;
1143
4
20
                        my $kid;
1144
4
22
                        do {
1145
16
149
                                $kid = waitpid($pid, POSIX::WNOHANG());
1146
16
119
                                if($kid == 0 && time() < $deadline) {
1147
12
1201989
                                        select undef, undef, undef, 0.1;        # sleep 100ms between polls
1148                                }
1149                        } while($kid == 0 && time() < $deadline);
1150
1151                        # Escalate if still alive after timeout
1152
4
21
                        if($kid == 0) {
1153
0
0
                                kill('KILL', $pid);
1154
0
0
                                waitpid($pid, 0);       # SIGKILL is not deferrable; this wait is safe
1155                        }
1156                }
1157
4
33
                %_config_watchers = ();
1158        }
1159        ## MUTANT_SKIP_END
1160}
1161
1162 - 1251
=head2 reload_config

Manually trigger configuration reload for all registered objects.

=head3 Purpose

Forces an immediate reload of configuration from files for all objects that have been
registered for hot reload. This is useful for testing or forcing a reload without
waiting for the automatic file monitoring to detect changes.

=head3 Arguments

None.

=head3 Returns

An integer count of how many objects had their configuration successfully reloaded.

=head3 Side Effects

=over 4

=item * Reads configuration files from disk

=item * Updates object properties with new configuration values

=item * Calls C<_on_config_reload> hook on objects that implement it

=item * Cleans up dead weak references from C<%_object_registry>

=item * May emit warnings if configuration reload fails for any object

=back

=head3 Notes

Only objects registered via C<register_object> are reloaded.
Objects are updated in-place; their identity does not change.
Private properties (those starting with C<_>) are not updated during reload.

=head3 Usage Example

    use Object::Configure;

    # Create and register objects
    my $obj = My::Module->new(config_file => 'app.yml');

    # Manually edit app.yml...

    # Force immediate reload
    my $count = Object::Configure::reload_config();
    print "Reloaded configuration for $count objects\n";

=head3 API Specification

=head4 Input

    schema => {}

=head4 Output

    type => 'integer',
    description => 'Number of objects successfully reloaded',
    condition => 'value >= 0'

=head3 Formal Specification

    reload_config: () → â„•

    State:
    - _object_registry: C → seq ObjectRef
    - ConfigFiles: F → H

    Pre-condition:
    true

    Post-condition:
    âˆ€ result ∈ â„• •
        result = |{obj ∈ flatten(ran _object_registry) |
                   obj ≠ ∅ ∧
                   obj._config_file ∈ dom ConfigFiles}| ∧
        (∀ obj ∈ flatten(ran _object_registry) •
            obj ≠ ∅ ∧ obj._config_file ∈ dom ConfigFiles ⇒
                (∀ k ∈ dom ConfigFiles(obj._config_file) •
                    k ∉ PrivateKeys ⇒
                        obj(k)@post = ConfigFiles(obj._config_file)(k)))

    where PrivateKeys = {k | k starts with '_'}

=cut
1252
1253sub reload_config {
1254
37
589560
        my $reloaded_count = 0;
1255
1256
37
91
        foreach my $class_key (keys %_object_registry) {
1257
35
44
                my $objects = $_object_registry{$class_key};
1258
1259                # Clean up dead object references
1260
35
97
61
114
                @$objects = grep { defined $_ } @$objects;
1261
1262
35
44
                foreach my $obj_ref (@$objects) {
1263
97
110
                        if (my $obj = $$obj_ref) {
1264
33
32
                                eval {
1265
33
49
                                        _reload_object_config($obj);
1266
33
197
                                        $reloaded_count++;
1267                                };
1268
33
53
                                if ($@) {
1269
0
0
                                        warn "Failed to reload config for object: $@";
1270                                }
1271                        }
1272                }
1273
1274                # Remove empty entries
1275
35
52
                delete $_object_registry{$class_key} unless @$objects;
1276        }
1277
1278
37
47
        return $reloaded_count;
1279}
1280
1281# Internal function to run the config file watcher
1282sub _run_config_watcher {
1283
3
28
        my ($interval, $callback) = @_;
1284
1285        # Set up signal handlers for clean shutdown
1286
3
3
288
203
        local $SIG{TERM} = sub { exit 0 };
1287
3
0
151
0
        local $SIG{INT} = sub { exit 0 };
1288
1289
3
20
        while (1) {
1290
5
2006312
                sleep($interval);
1291
1292
5
91
                my $changes_detected = 0;
1293
1294                # Check each monitored config file
1295
2
29
                foreach my $config_file (keys %_config_file_stats) {
1296
2
63
                        if (-f $config_file) {
1297
2
45
                                my $current_stat = stat($config_file);
1298
2
482
                                my $stored_stat = $_config_file_stats{$config_file};
1299
1300                                # Compare modification times
1301
2
57
                                if ((!$stored_stat) || ($current_stat->mtime > $stored_stat->mtime)) {
1302
1
10
                                        $_config_file_stats{$config_file} = $current_stat;
1303
1
16
                                        $changes_detected = 1;
1304                                }
1305                        } else {
1306                                # File was deleted
1307
0
0
                                delete $_config_file_stats{$config_file};
1308
0
0
                                $changes_detected = 1;
1309                        }
1310                }
1311
1312
2
20
                if($changes_detected) {
1313
1
12
                        if($^O ne 'MSWin32') {
1314                                # Reload configurations in the main process
1315                                # Use a signal or shared memory mechanism
1316
1
17
                                if(my $parent_pid = getppid()) {
1317
1
23
                                        kill('USR1', $parent_pid);
1318                                }
1319                        }
1320                }
1321        }
1322}
1323
1324# Internal function to reload a single object's configuration
1325sub _reload_object_config {
1326
33
30
        my $obj = $_[0];
1327
1328
33
88
        return unless blessed($obj);
1329
1330
33
44
        my $class = ref($obj);
1331
33
33
        my $original_class = $class;
1332
33
67
        $class =~ s/::/__/g;
1333
1334        # Get the original config file path(s) if they exist
1335        # Use the full path from _config_files if available, otherwise try _config_file
1336
33
27
        my $config_file;
1337
33
27
136
52
        if ($obj->{_config_files} && ref($obj->{_config_files}) eq 'ARRAY' && @{$obj->{_config_files}}) {
1338                # Use the last (most specific) config file
1339
27
35
                $config_file = $obj->{_config_files}[-1];
1340        } else {
1341
6
12
                $config_file = $obj->{_config_file} || $obj->{config_file};
1342        }
1343
1344
33
221
        return unless $config_file && -f $config_file;
1345
1346        # Reload the configuration
1347
26
123
        my $config = Config::Abstraction->new(
1348                config_file => $config_file,
1349                env_prefix => "${class}__"
1350        );
1351
1352
26
26617
        if ($config) {
1353                # Use merge_defaults with empty defaults to get just the config values
1354
26
73
                my $new_params = $config->merge_defaults(
1355                        defaults => {},
1356                        section => $class,
1357                        merge => 1,
1358                        deep => 1
1359                );
1360
1361                # Update object properties, preserving non-config data
1362
26
1443
                foreach my $key (keys %$new_params) {
1363
31
49
                        next if $key =~ /^_/;   # Skip private properties
1364
1365
31
61
                        if($key =~ /^logger/ && $new_params->{$key} ne 'NULL') {
1366                                # Handle logger reconfiguration specially
1367
1
3
                                _reconfigure_logger($obj, $key, $new_params->{$key});
1368                        } else {
1369
30
38
                                $obj->{$key} = $new_params->{$key};
1370                        }
1371                }
1372
1373                # Call object's reload hook if it exists
1374
26
92
                if ($obj->can('_on_config_reload')) {
1375
14
32
                        $obj->_on_config_reload($new_params);
1376                }
1377
1378                # Log the reload if logger exists
1379
26
172
                if ($obj->{logger} && $obj->{logger}->can('info')) {
1380
24
58
                        $obj->{logger}->info("Configuration reloaded for $original_class");
1381                }
1382        }
1383
1384
26
522
        return;
1385}
1386
1387# Internal function to reconfigure the logger
1388sub _reconfigure_logger
1389{
1390
8
11893
        my ($obj, $key, $logger_config) = @_;
1391
1392
8
11
        if (ref($logger_config) eq 'HASH') {
1393                # Create new logger with new config
1394
6
13
                my $carp_on_warn = $obj->{carp_on_warn} || 0;
1395
1396
6
7
                if ($logger_config->{syslog}) {
1397                        $obj->{$key} = Log::Abstraction->new({
1398                                carp_on_warn => $carp_on_warn,
1399                                syslog => $logger_config->{syslog},
1400
3
10
                                %$logger_config
1401                        });
1402                } else {
1403
3
8
                        $obj->{$key} = Log::Abstraction->new({
1404                                carp_on_warn => $carp_on_warn,
1405                                %$logger_config
1406                        });
1407                }
1408        } else {
1409
2
4
                $obj->{$key} = $logger_config;
1410        }
1411}
1412
1413 - 1527
=head2 register_object($class, $obj)

Register an object for hot reload monitoring.

=head3 Purpose

Adds an object to the hot reload registry so it will receive automatic configuration
updates when files change. Uses weak references to prevent memory leaks.

=head3 Arguments

=over 4

=item * C<class> (Required)

The class name of the object, used for organizing the registry.

=item * C<obj> (Required)

The object instance to register. Must be a blessed reference.

=back

=head3 Returns

Nothing.

=head3 Side Effects

=over 4

=item * Adds a weak reference to the object in C<%_object_registry>

=item * Sets up SIGUSR1 signal handler on first call (Unix-like systems only)

=item * Stores the original SIGUSR1 handler for later restoration

=back

=head3 Notes

Objects are stored using weak references, so they will be automatically
garbage collected when no other references exist.
The SIGUSR1 handler chains to any existing handler that was installed.
On Windows, the signal handler is not installed (SIGUSR1 does not exist).

=head3 Usage Example

    package My::Module;
    use Object::Configure;

    sub new {
        my $class = shift;
        my $params = Object::Configure::configure($class, {
            config_file => 'mymodule.yml',
        });
        my $self = bless $params, $class;

        # Register for hot reload
        Object::Configure::register_object($class, $self)
            if $params->{_config_file};

        return $self;
    }

=head3 API Specification

=head4 Input

    schema => {
        class => {
            type => 'string',
            required => 1,
            description => 'Class name for registry organization'
        },
        obj => {
            type => 'object',
            required => 1,
            description => 'Blessed object instance to register'
        }
    }

=head4 Output

    type => 'void'

=head3 Formal Specification

    register_object: C × O → ()

    Given:
    - C: set of class names
    - O: set of blessed objects
    - OR: C → seq WeakRef(O) (object registry)

    State:
    - _object_registry: OR
    - _original_usr1_handler: SignalHandler ∪ {∅}
    - $SIG{USR1}: SignalHandler

    Pre-condition:
    âˆ€ class ∈ C, obj ∈ O •
        class ≠ ∅ ∧
        obj ≠ ∅ ∧
        blessed(obj) ≠ ∅

    Post-condition:
    âˆ€ class ∈ C, obj ∈ O •
        âˆƒ ref ∈ _object_registry(class) •
            weak(ref) = obj ∧
        (_original_usr1_handler = ∅@pre ⇒
            (_original_usr1_handler@post = $SIG{USR1}@pre ∧
             $SIG{USR1}@post = reload_config_handler))

=cut
1528
1529sub register_object
1530{
1531
68
217734
        my ($class, $obj) = @_;
1532
1533
68
214
        croak(__PACKAGE__, '::register_object: Usage ($class, $obj)') unless(defined($class) && defined($obj));
1534
1535        # Use weak references to avoid memory leaks
1536
58
50
        my $obj_ref = \$obj;
1537
58
79
        weaken($$obj_ref);
1538
1539
58
58
47
79
        push @{$_object_registry{$class}}, $obj_ref;
1540
1541        # Set up signal handler for hot reload (only once)
1542
58
58
        if (!defined $_original_usr1_handler) {
1543                # Store the existing handler (could be DEFAULT, IGNORE, or a code ref)
1544
32
82
                $_original_usr1_handler = $SIG{USR1} || 'DEFAULT';
1545
1546
32
55
                return if($^O eq 'MSWin32');    # There is no SIGUSR1 on Windows
1547
1548                $SIG{USR1} = sub {
1549                        # Handle our hot reload first
1550
9
1015328
                        reload_config();
1551
9
15
                        if ($_config_watchers{callback}) {
1552
1
8
                                $_config_watchers{callback}->();
1553                        }
1554
1555                        # Chain to the original handler if it exists and is callable
1556
9
23
                        if (ref($_original_usr1_handler) eq 'CODE') {
1557
6
8
                                $_original_usr1_handler->();
1558                        } elsif ($_original_usr1_handler eq 'DEFAULT') {
1559                                # Let the default handler run (which typically does nothing for USR1)
1560                                # We don't need to explicitly call it
1561                        } elsif ($_original_usr1_handler eq 'IGNORE') {
1562                                # Do nothing - the signal was being ignored
1563                        }
1564                        # Note: If it was some other string, it was probably a custom handler name
1565                        # but we can't easily call those, so we'll just warn
1566                        elsif ($_original_usr1_handler ne 'DEFAULT' && $_original_usr1_handler ne 'IGNORE') {
1567
0
0
                                warn "Object::Configure: Cannot chain to non-code USR1 handler: $_original_usr1_handler";
1568                        }
1569
32
193
                };
1570        }
1571
58
65
        return; # ensure the functions return nothing (void/empty list)
1572}
1573
1574 - 1642
=head2 restore_signal_handlers

Restore original signal handlers and disable hot reload integration.

=head3 Purpose

Restores the signal handler that was in place before Object::Configure installed
its SIGUSR1 handler. This is useful for clean shutdown or when transferring
control to another hot reload system.

=head3 Arguments

None.

=head3 Returns

Nothing.

=head3 Side Effects

=over 4

=item * Restores C<$SIG{USR1}> to its original value

=item * Clears C<$_original_usr1_handler> internal state

=back

=head3 Notes

Safe to call even if Object::Configure never installed a signal handler.
On Windows, this function has no effect (SIGUSR1 does not exist).

=head3 Usage Example

    use Object::Configure;

    # Objects are registered...

    # Clean shutdown
    Object::Configure::disable_hot_reload();
    Object::Configure::restore_signal_handlers();

=head3 API Specification

=head4 Input

    schema => {}

=head4 Output

    type => 'void'

=head3 Formal Specification

    restore_signal_handlers: () → ()

    State:
    - _original_usr1_handler: SignalHandler ∪ {∅}
    - $SIG{USR1}: SignalHandler

    Pre-condition:
    true

    Post-condition:
    $SIG{USR1}@post = _original_usr1_handler@pre ∧
    _original_usr1_handler@post = ∅

=cut
1643
1644sub restore_signal_handlers
1645{
1646
41
368742
        if (defined $_original_usr1_handler) {
1647
17
108
                $SIG{USR1} = $_original_usr1_handler if($^O ne 'MSWin32');      # There is no SIGUSR1 on Windows
1648
17
48
                $_original_usr1_handler = undef;
1649        }
1650
1651
41
301
        return; # ensure the functions return nothing (void/empty list)
1652}
1653
1654 - 1766
=head2 get_signal_handler_info

Get information about the current signal handler setup for debugging.

=head3 Purpose

Returns diagnostic information about the signal handler state, useful for
debugging signal handler chains or verifying hot reload configuration.

=head3 Arguments

None.

=head3 Returns

A hashref containing the following keys:

=over 4

=item * C<original_usr1>

The signal handler that was installed before Object::Configure's handler,
or undef if no handler was present.

=item * C<current_usr1>

The currently installed SIGUSR1 handler.

=item * C<hot_reload_active>

Boolean indicating whether Object::Configure's hot reload handler is active.

=item * C<watcher_pid>

The PID of the background watcher process, or undef if not running.

=back

=head3 Side Effects

None.

=head3 Notes

This is primarily a debugging aid and is not needed for normal operation.

=head3 Usage Example

    use Object::Configure;
    use Data::Dumper;

    Object::Configure::enable_hot_reload();

    my $info = Object::Configure::get_signal_handler_info();
    print Dumper($info);
    # $VAR1 = {
    #     'original_usr1' => 'DEFAULT',
    #     'current_usr1' => CODE(0x...),
    #     'hot_reload_active' => 1,
    #     'watcher_pid' => 12345
    # };

=head3 API Specification

=head4 Input

    schema => {}

=head4 Output

    type => 'hashref',
    schema => {
        original_usr1 => {
            type => [qw(coderef string undef)],
            description => 'Original SIGUSR1 handler'
        },
        current_usr1 => {
            type => [qw(coderef string undef)],
            description => 'Current SIGUSR1 handler'
        },
        hot_reload_active => {
            type => 'boolean',
            description => 'Whether hot reload is active'
        },
        watcher_pid => {
            type => [qw(integer undef)],
            description => 'Background watcher process PID'
        }
    }

=head3 Formal Specification

    get_signal_handler_info: () → InfoHash

    Given:
    - IH: set of all info hashes

    State:
    - _original_usr1_handler: SignalHandler ∪ {∅}
    - $SIG{USR1}: SignalHandler ∪ {∅}
    - _config_watchers: {pid: PID, callback: CB}

    Pre-condition:
    true

    Post-condition:
    âˆ€ result ∈ IH •
        result.original_usr1 = _original_usr1_handler ∧
        result.current_usr1 = $SIG{USR1} ∧
        result.hot_reload_active = (_original_usr1_handler ≠ ∅) ∧
        result.watcher_pid = _config_watchers.pid

=cut
1767
1768sub get_signal_handler_info {
1769        return {
1770                original_usr1 => $_original_usr1_handler,
1771                current_usr1 => $SIG{USR1},
1772                hot_reload_active => defined $_original_usr1_handler,
1773                watcher_pid => $_config_watchers{pid},
1774
17
11631
        };
1775}
1776
1777# Cleanup on module destruction
1778END {
1779
17
99675
        disable_hot_reload();
1780
1781        # Restore original USR1 handler if we modified it
1782
17
47
        restore_signal_handlers();
1783}
1784
1785 - 1819
=head1 SEE ALSO

=over 4

=item * L<Config::Abstraction>

=item * L<Log::Abstraction>

=item * L<Test Dashboard|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 LICENCE AND COPYRIGHT

Copyright 2025-2026 Nigel Horne.

Usage is subject to GPL2 licence terms.
If you use it,
please let me know.

=cut
1820
18211;