File Coverage

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

linestmtbrancondsubtimecode
1package Object::Configure;
2
3# TODO: configuration inheritance from parents
4
5
9
9
9
620884
4
119
use strict;
6
9
9
9
15
7
144
use warnings;
7
8
9
9
9
16
6
211
use Carp;
9
9
9
9
1669
198230
151
use Config::Abstraction 0.32;
10
9
9
9
1874
109250
150
use Log::Abstraction 0.25;
11
9
9
9
19
39
126
use Params::Get 0.13;
12
9
9
9
15
9
106
use Return::Set;
13
9
9
9
17
7
155
use Scalar::Util qw(blessed weaken);
14
9
9
9
11
9
30
use Time::HiRes qw(time);
15
9
9
9
2181
23484
7866
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.15

=cut
34
35our $VERSION = 0.15;
36
37 - 217
=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');
    }

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

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.

=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
218
219sub configure {
220
31
2107735
        my $class = $_[0];
221
31
55
        my $params = $_[1] || {};
222
31
28
        my $array;
223
224
31
55
        if (exists($params->{'logger'}) && (ref($params->{'logger'}) eq 'ARRAY')) {
225
0
0
                $array = delete $params->{'logger'};
226        }
227
228
31
26
        my $original_class = $class;
229
31
53
        $class =~ s/::/__/g;
230
231        # Store config file path for hot reload
232
31
42
        my $config_file = $params->{'config_file'};
233
234        # Load the configuration from a config file, if provided
235
31
64
        if ($config_file) {
236
21
23
                my $config_dirs = $params->{'config_dirs'};
237
21
168
                if ((!$config_dirs) && (!-r $config_file)) {
238
2
37
                        croak("$class: ", $config_file, ": $!");
239                }
240
241                # Track this config file for hot reload
242
19
74
                if (-f $config_file) {
243
19
40
                        $_config_file_stats{$config_file} = stat($config_file);
244                }
245
246
19
1702
                if (my $config = Config::Abstraction->new(
247                        config_dirs => $config_dirs,
248                        config_file => $config_file,
249                        env_prefix => "${class}__"
250                )) {
251
19
56607
                        $params = $config->merge_defaults(
252                                defaults => $params,
253                                section => $class,
254                                merge => 1,
255                                deep => 1
256                        );
257                } elsif ($@) {
258
0
0
                        croak("$class: Can't load configuration from ", $config_file, ": $@");
259                } else {
260
0
0
                        croak("$class: Can't load configuration from ", $config_file);
261                }
262        } elsif (my $config = Config::Abstraction->new(env_prefix => "${class}__")) {
263
3
3215
                $params = $config->merge_defaults(
264                        defaults => $params,
265                        section => $class,
266                        merge => 1,
267                        deep => 1
268                );
269                # Track this config file for hot reload
270
3
211
                if ($params->{config_path} && -f $params->{config_path}) {
271
0
0
                        $_config_file_stats{$config_file} = stat($config_file);
272                }
273        }
274
275
29
9194
        my $carp_on_warn = $params->{'carp_on_warn'} || 0;
276
277        # Load the default logger
278
29
251
        if (my $logger = $params->{'logger'}) {
279
5
9
                if ($params->{'logger'} ne 'NULL') {
280
5
7
                        if (ref($logger) eq 'HASH') {
281
4
6
                                if ($logger->{'syslog'}) {
282                                        $params->{'logger'} = Log::Abstraction->new({
283                                                carp_on_warn => $carp_on_warn,
284                                                syslog => $logger->{'syslog'},
285
1
1
2
4
                                                %{$logger}
286                                        });
287                                } else {
288                                        $params->{'logger'} = Log::Abstraction->new({
289                                                carp_on_warn => $carp_on_warn,
290
3
3
2
13
                                                %{$logger}
291                                        });
292                                }
293                        } elsif (!blessed($logger) || !$logger->isa('Log::Abstraction')) {
294
1
3
                                $params->{'logger'} = Log::Abstraction->new({
295                                        carp_on_warn => $carp_on_warn,
296                                        logger => $logger
297                                });
298                        }
299                }
300        } elsif ($array) {
301
0
0
                $params->{'logger'} = Log::Abstraction->new(
302                        array => $array,
303                        carp_on_warn => $carp_on_warn
304                );
305
0
0
                undef $array;
306        } else {
307
24
86
                $params->{'logger'} = Log::Abstraction->new(carp_on_warn => $carp_on_warn);
308        }
309
310
29
157630
        if ($array && !$params->{'logger'}->{'array'}) {
311
0
0
                $params->{'logger'}->{'array'} = $array;
312        }
313
314        # Store config file path in params for hot reload
315
29
50
        $params->{_config_file} = $config_file if(defined($config_file));
316
317
29
64
        return Return::Set::set_return($params, { 'type' => 'hashref' });
318}
319
320 - 325
=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
326
327sub instantiate
328{
329
3
71606
        my $params = Params::Get::get_params('class', @_);
330
331
3
38
        my $class = $params->{'class'};
332
3
4
        $params = configure($class, $params);
333
334
3
139
        my $obj = $class->new($params);
335
336        # Register object for hot reload if config file is used
337
3
9
        if ($params->{_config_file}) {
338
2
3
                register_object($class, $obj);
339        }
340
341
3
7
        return $obj;
342}
343
344 - 355
=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
356
357sub enable_hot_reload {
358
2
3336
        my %params = @_;
359
360
2
4
        my $interval = $params{interval} || 10;
361
2
2
        my $callback = $params{callback};
362
363        # Don't start multiple watchers
364
2
4
        return if %_config_watchers;
365
366        # Fork a background process to watch config files
367
2
1922
        if (my $pid = fork()) {
368                # Parent process - store the watcher PID
369
1
10
                $_config_watchers{pid} = $pid;
370
1
11
                $_config_watchers{callback} = $callback;
371
1
26
                return $pid;
372        } elsif (defined $pid) {
373                # Child process - run the file watcher
374
1
25
                _run_config_watcher($interval, $callback);
375
0
0
                exit 0;
376        } else {
377
0
0
                croak("Failed to fork config watcher: $!");
378        }
379}
380
381 - 387
=head2 disable_hot_reload

Disable hot reloading and stop the background watcher.

    Object::Configure::disable_hot_reload();

=cut
388
389sub disable_hot_reload {
390
12
2922
        if (my $pid = $_config_watchers{pid}) {
391
1
11
                kill('TERM', $pid);
392
1
147703
                waitpid($pid, 0);
393
1
14
                %_config_watchers = ();
394        }
395}
396
397 - 403
=head2 reload_config

Manually trigger a configuration reload for all registered objects.

    Object::Configure::reload_config();

=cut
404
405sub reload_config {
406
12
72190
        my $reloaded_count = 0;
407
408
12
36
        foreach my $class_key (keys %_object_registry) {
409
12
14
                my $objects = $_object_registry{$class_key};
410
411                # Clean up dead object references
412
12
70
21
71
                @$objects = grep { defined $_ } @$objects;
413
414
12
15
                foreach my $obj_ref (@$objects) {
415
70
71
                        if (my $obj = $$obj_ref) {
416
13
10
                                eval {
417
13
23
                                        _reload_object_config($obj);
418
13
305
                                        $reloaded_count++;
419                                };
420
13
17
                                if ($@) {
421
0
0
                                        warn "Failed to reload config for object: $@";
422                                }
423                        }
424                }
425
426                # Remove empty entries
427
12
15
                delete $_object_registry{$class_key} unless @$objects;
428        }
429
430
12
14
        return $reloaded_count;
431}
432
433# Internal function to run the config file watcher
434sub _run_config_watcher {
435
1
4
        my ($interval, $callback) = @_;
436
437        # Set up signal handlers for clean shutdown
438
1
1
100
47
        local $SIG{TERM} = sub { exit 0 };
439
1
0
22
0
        local $SIG{INT} = sub { exit 0 };
440
441
1
4
        while (1) {
442
3
2003486
                sleep($interval);
443
444
3
41
                my $changes_detected = 0;
445
446                # Check each monitored config file
447
2
24
                foreach my $config_file (keys %_config_file_stats) {
448
2
53
                        if (-f $config_file) {
449
2
37
                                my $current_stat = stat($config_file);
450
2
414
                                my $stored_stat = $_config_file_stats{$config_file};
451
452                                # Compare modification times
453
2
45
                                if ((!$stored_stat) || ($current_stat->mtime > $stored_stat->mtime)) {
454
1
10
                                        $_config_file_stats{$config_file} = $current_stat;
455
1
23
                                        $changes_detected = 1;
456                                }
457                        } else {
458                                # File was deleted
459
0
0
                                delete $_config_file_stats{$config_file};
460
0
0
                                $changes_detected = 1;
461                        }
462                }
463
464
2
20
                if($changes_detected) {
465
1
12
                        if($^O ne 'MSWin32') {
466                                # Reload configurations in the main process
467                                # Use a signal or shared memory mechanism
468
1
18
                                if(my $parent_pid = getppid()) {
469
1
42
                                        kill('USR1', $parent_pid);
470                                }
471                        }
472                }
473        }
474}
475
476# Internal function to reload a single object's configuration
477sub _reload_object_config {
478
13
14
        my ($obj) = @_;
479
480
13
32
        return unless blessed($obj);
481
482
13
20
        my $class = ref($obj);
483
13
9
        my $original_class = $class;
484
13
22
        $class =~ s/::/__/g;
485
486        # Get the original config file path if it exists
487
13
16
        my $config_file = $obj->{_config_file} || $obj->{config_file};
488
13
94
        return unless $config_file && -f $config_file;
489
490        # Reload the configuration
491
12
59
        my $config = Config::Abstraction->new(
492                config_file => $config_file,
493                env_prefix => "${class}__"
494        );
495
496
12
18104
        if ($config) {
497                # Use merge_defaults with empty defaults to get just the config values
498
12
24
                my $new_params = $config->merge_defaults(
499                        defaults => {},
500                        section => $class,
501                        merge => 1,
502                        deep => 1
503                );
504
505                # Update object properties, preserving non-config data
506
12
577
                foreach my $key (keys %$new_params) {
507
13
27
                        next if $key =~ /^_/;   # Skip private properties
508
509
13
24
                        if($key =~ /^logger/ && $new_params->{$key} ne 'NULL') {
510                                # Handle logger reconfiguration specially
511
1
2
                                _reconfigure_logger($obj, $key, $new_params->{$key});
512                        } else {
513
12
16
                                $obj->{$key} = $new_params->{$key};
514                        }
515                }
516
517                # Call object's reload hook if it exists
518
12
28
                if ($obj->can('_on_config_reload')) {
519
12
19
                        $obj->_on_config_reload($new_params);
520                }
521
522                # Log the reload if logger exists
523
12
90
                if ($obj->{logger} && $obj->{logger}->can('info')) {
524
12
21
                        $obj->{logger}->info("Configuration reloaded for $original_class");
525                }
526        }
527}
528
529# Internal function to reconfigure the logger
530sub _reconfigure_logger
531{
532
1
1
        my ($obj, $key, $logger_config) = @_;
533
534
1
3
        if (ref($logger_config) eq 'HASH') {
535                # Create new logger with new config
536
0
0
                my $carp_on_warn = $obj->{carp_on_warn} || 0;
537
538
0
0
                if ($logger_config->{syslog}) {
539                        $obj->{$key} = Log::Abstraction->new({
540                                carp_on_warn => $carp_on_warn,
541                                syslog => $logger_config->{syslog},
542
0
0
                                %$logger_config
543                        });
544                } else {
545
0
0
                        $obj->{$key} = Log::Abstraction->new({
546                                carp_on_warn => $carp_on_warn,
547                                %$logger_config
548                        });
549                }
550        } else {
551
1
2
                $obj->{$key} = $logger_config;
552        }
553}
554
555 - 564
=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
565
566sub register_object {
567
17
751
        my ($class, $obj) = @_;
568
569        # Use weak references to avoid memory leaks
570
17
12
        my $obj_ref = \$obj;
571
17
25
        weaken($$obj_ref);
572
573
17
17
12
22
        push @{$_object_registry{$class}}, $obj_ref;
574
575        # Set up signal handler for hot reload (only once)
576
17
26
        if (!defined $_original_usr1_handler) {
577                # Store the existing handler (could be DEFAULT, IGNORE, or a code ref)
578
6
25
                $_original_usr1_handler = $SIG{USR1} || 'DEFAULT';
579
580
6
17
                return if($^O eq 'MSWin32');    # There is no SIGUSR1 on Windows
581
582                $SIG{USR1} = sub {
583                        # Handle our hot reload first
584
3
1016616
                        reload_config();
585
3
6
                        if ($_config_watchers{callback}) {
586
1
3
                                $_config_watchers{callback}->();
587                        }
588
589                        # Chain to the original handler if it exists and is callable
590
3
8
                        if (ref($_original_usr1_handler) eq 'CODE') {
591
3
3
                                $_original_usr1_handler->();
592                        } elsif ($_original_usr1_handler eq 'DEFAULT') {
593                                # Let the default handler run (which typically does nothing for USR1)
594                                # We don't need to explicitly call it
595                        } elsif ($_original_usr1_handler eq 'IGNORE') {
596                                # Do nothing - the signal was being ignored
597                        }
598                        # Note: If it was some other string, it was probably a custom handler name
599                        # but we can't easily call those, so we'll just warn
600                        elsif ($_original_usr1_handler ne 'DEFAULT' && $_original_usr1_handler ne 'IGNORE') {
601
0
0
                                warn "Object::Configure: Cannot chain to non-code USR1 handler: $_original_usr1_handler";
602                        }
603
6
50
                };
604        }
605}
606
607 - 614
=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
615
616sub restore_signal_handlers
617{
618
15
204704
        if (defined $_original_usr1_handler) {
619
6
36
                $SIG{USR1} = $_original_usr1_handler if($^O ne 'MSWin32');      # There is no SIGUSR1 on Windows
620
6
24
                $_original_usr1_handler = undef;
621        }
622}
623
624 - 633
=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
634
635sub get_signal_handler_info {
636        return {
637                original_usr1 => $_original_usr1_handler,
638                current_usr1 => $SIG{USR1},
639                hot_reload_active => defined $_original_usr1_handler,
640                watcher_pid => $_config_watchers{pid},
641
2
14
        };
642}
643
644# Cleanup on module destruction
645END {
646
9
83077
        disable_hot_reload();
647
648        # Restore original USR1 handler if we modified it
649
9
69
        restore_signal_handlers();
650}
651
652 - 696
=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
697
6981;