lib/Object/Configure.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 97.76%
TER2 (Branch): 92.68%
TER3 (LCSAJ): 100.0% (19/19)
Approximate LCSAJ segments: 165

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package Object::Configure;
    2: 
    3: use strict;
    4: use warnings;
    5: 
    6: use Carp;
    7: use Config::Abstraction 0.38;
    8: use File::Spec;
    9: use Log::Abstraction 0.26;
   10: use mro;
   11: use Params::Get 0.13;
   12: use Readonly;
   13: use Return::Set;
   14: use List::Util   qw(any);
   15: use Scalar::Util qw(blessed weaken);
   16: use Time::HiRes  qw(time);
   17: use File::stat;
   18: use POSIX qw(WNOHANG);
   19: 
   20: # Avoid magic literals scattered across hot paths and signal handlers.
   21: # Centralising here makes global search-replace safe and self-documents intent.
   22: Readonly my $OS_WINDOWS      => 'MSWin32';
   23: Readonly my $LOGGER_NULL     => 'NULL';
   24: Readonly my $SIG_DEFAULT     => 'DEFAULT';
   25: Readonly my $SIG_IGNORE      => 'IGNORE';
   26: Readonly my $POLL_SLEEP      => 0.1;   # seconds between waitpid polls in disable_hot_reload
   27: Readonly my $KILL_TIMEOUT    => 5;     # seconds before SIGKILL escalation after SIGTERM
   28: Readonly my $DEFAULT_INTERVAL => 10;   # default hot-reload poll interval in seconds
   29: 
   30: # Matches any path segment that is exactly ".." (anchored start, slash, or end).
   31: # Catches: ../foo  foo/../bar  foo/..  and leading ../
   32: # Used in two places; kept as a constant so both guards are always in sync.
   33: Readonly my $RE_PATH_TRAVERSAL => qr{(?:\A|/)\.\.(?:/|\z)};
   34: 
   35: # Global registry — intentionally package-level so that the END block and
   36: # signal handlers installed in one call site share state with all others.
   37: # This is a deliberate singleton design; see LIMITATIONS for the trade-offs.
   38: our %_object_registry   = ();
   39: our %_config_watchers   = ();
   40: our %_config_file_stats = ();
   41: 
   42: # Memoization caches — keyed by inputs; valid for the process lifetime because
   43: # Perl @ISA hierarchies and filesystem layouts are stable after module load.
   44: # Both caches include undef sentinels (use exists, not defined, to check hits).
   45: our %_chain_cache = ();  # class         => [UNIVERSAL, ..., Class] (base-first)
   46: our %_find_cache  = ();  # "\0"-joined key => file path or undef
   47: 
   48: # Saved before we install our SIGUSR1 handler so we can chain and restore it.
   49: our $_original_usr1_handler;
   50: 
   51: =head1 NAME
   52: 
   53: Object::Configure - Runtime Configuration for an Object
   54: 
   55: =head1 VERSION
   56: 
   57: 0.24
   58: 
   59: =cut
   60: 
   61: our $VERSION = 0.24;
   62: 
   63: =head1 DESCRIPTION
   64: 
   65: C<Object::Configure> injects runtime configuration and logging into Perl class
   66: constructors.  It is a thin layer on top of L<Config::Abstraction> (reads config
   67: files and environment variables) and L<Log::Abstraction> (logging).
   68: 
   69: Call C<configure($class, \%params)> at the start of your C<new()> method.  It:
   70: 
   71: =over 4
   72: 
   73: =item 1. Walks C<@ISA> and finds config files for every class in the inheritance chain.
   74: 
   75: =item 2. Merges those files, then overlays environment variables named C<ClassName__key>.
   76: 
   77: =item 3. Creates a L<Log::Abstraction> logger and stores it in C<$params-E<gt>{logger}>.
   78: 
   79: =item 4. Returns a hashref ready to pass to C<bless>.
   80: 
   81: =back
   82: 
   83: The module also provides optional hot-reload support: a background process watches
   84: config files and sends C<SIGUSR1> to trigger an in-place update of registered objects
   85: without restarting the application.
   86: 
   87: B<Hot reload is not supported on Windows> (C<SIGUSR1> does not exist there).
   88: 
   89: =head1 SYNOPSIS
   90: 
   91: =head2 Example 1: Add configurable logging to your own class
   92: 
   93:     package My::Module;
   94:     use Object::Configure;
   95: 
   96:     sub new {
   97:         my ($class, %args) = @_;
   98: 
   99:         # configure() reads config files + env vars, sets up a logger,
  100:         # and returns a hashref ready to bless.
  101:         my $params = Object::Configure::configure($class, \%args);
  102: 
  103:         return bless $params, $class;
  104:     }
  105: 
  106:     sub do_work {
  107:         my $self = shift;
  108:         $self->{logger}->info('Starting do_work');
  109:         # ...
  110:     }
  111: 
  112:     # Usage -- reads ~/.conf/my-module.yml if it exists:
  113:     my $obj = My::Module->new(config_file => '/etc/myapp/my-module.yml');
  114:     $obj->do_work;
  115: 
  116: =head2 Example 2: Configure a third-party class you cannot modify
  117: 
  118:     use Object::Configure;
  119: 
  120:     # Wrap LWP::UserAgent so it reads its settings from a YAML file.
  121:     my $ua = Object::Configure::instantiate(
  122:         class       => 'LWP::UserAgent',
  123:         config_file => '/etc/myapp/lwp.yml',
  124:         timeout     => 30,      # fallback if the file has no timeout key
  125:     );
  126: 
  127:     $ua->get('https://example.com');
  128: 
  129: =head2 Example 3: Multi-level inheritance -- config files merge automatically
  130: 
  131:     # ~/.conf/my-base-class.yml
  132:     # My__Base__Class:
  133:     #   timeout: 30
  134:     #   retries: 3
  135: 
  136:     # ~/.conf/my-child-class.yml
  137:     # My__Child__Class:
  138:     #   timeout: 60   # overrides base; retries:3 is inherited
  139: 
  140:     package My::Child::Class;
  141:     our @ISA = ('My::Base::Class');
  142:     use Object::Configure;
  143: 
  144:     sub new {
  145:         my ($class, %args) = @_;
  146:         # Walks @ISA, merges base config then child config.
  147:         # Result: timeout=60, retries=3
  148:         my $params = Object::Configure::configure($class, \%args);
  149:         return bless $params, $class;
  150:     }
  151: 
  152: =head2 Example 4: Hot reload -- objects update when the config file changes
  153: 
  154:     package My::Service;
  155:     use Object::Configure;
  156: 
  157:     sub new {
  158:         my ($class, %args) = @_;
  159:         my $params = Object::Configure::configure($class, \%args);
  160:         my $self   = bless $params, $class;
  161: 
  162:         # Register so reload_config() updates $self in-place on file change.
  163:         Object::Configure::register_object($class, $self)
  164:             if $params->{_config_file};
  165: 
  166:         return $self;
  167:     }
  168: 
  169:     package main;
  170: 
  171:     my $svc = My::Service->new(config_file => '/etc/myapp/service.yml');
  172: 
  173:     # Fork a background watcher; it sends SIGUSR1 when the file changes.
  174:     Object::Configure::enable_hot_reload(
  175:         interval => 5,
  176:         callback => sub { print "Config reloaded at ", scalar localtime, "\n" },
  177:     );
  178: 
  179:     while (1) { sleep 1 }          # event loop
  180: 
  181:     Object::Configure::disable_hot_reload();    # clean shutdown
  182: 
  183: =head2 Example 5: Override settings with environment variables (no file needed)
  184: 
  185:     # Shell:
  186:     #   export My__Module__log_level=debug
  187:     #   export My__Module__timeout=120
  188: 
  189:     package My::Module;
  190:     use Object::Configure;
  191: 
  192:     sub new {
  193:         my ($class, %args) = @_;
  194:         # configure() picks up My__Module__* env vars automatically.
  195:         my $params = Object::Configure::configure($class, \%args);
  196:         return bless $params, $class;
  197:     }
  198: 
  199:     my $obj = My::Module->new;
  200:     # $obj->{log_level} eq 'debug'   $obj->{timeout} == 120
  201: 
  202: =head1 CONFIGURATION
  203: 
  204: =head2 Config file naming
  205: 
  206: The config file name is derived from the class name by lowercasing it and replacing
  207: C<::> with hyphens (C<->):
  208: 
  209:     My::Parent::Class  =>  my-parent-class.yml
  210: 
  211: The file is searched for in the directory of the C<config_file> argument, then in
  212: any directories listed in C<config_dirs>.
  213: 
  214: =head2 Section key naming inside the config file
  215: 
  216: Inside the YAML (or JSON or conf) file, the section key uses double underscores in
  217: place of C<::>:
  218: 
  219:     # my-parent-class.yml
  220:     ---
  221:     My__Parent__Class:
  222:       timeout: 30
  223:       retries: 3
  224: 
  225: =head2 Configuration resolution order
  226: 
  227: The following sources are merged from I<lowest> to I<highest> priority.  A value
  228: from a higher-priority source always wins over a lower-priority one.
  229: 
  230: =over 4
  231: 
  232: =item 1. B<Caller-supplied params> -- the hashref you pass to C<configure()>.  Despite
  233: the name "defaults", these are the I<lowest> priority and are overridden by everything
  234: else.
  235: 
  236: =item 2. B<UNIVERSAL section> -- the C<UNIVERSAL:> block in C<universal.yml> (or
  237: C<universal.conf>, C<universal.json>) in your config directories, if the file exists.
  238: 
  239: =item 3. B<Ancestor class config files> -- walked base-first through C<@ISA> using
  240: the class's Method Resolution Order (MRO).
  241: 
  242: =item 4. B<Primary config file> -- the file named by the C<config_file> argument.
  243: 
  244: =item 5. B<Environment variables> -- named C<ClassName__key=value>, where C<::> in
  245: the class name is replaced by C<__>.  These are the I<highest> priority.
  246: 
  247: =back
  248: 
  249: =head2 UNIVERSAL configuration
  250: 
  251: If you create C<universal.yml> in your config directory with a C<UNIVERSAL:> section,
  252: those settings apply to every class that uses C<Object::Configure> unless a
  253: more-specific source overrides them:
  254: 
  255:     # ~/.conf/universal.yml
  256:     ---
  257:     UNIVERSAL:
  258:       timeout: 30
  259:       logger:
  260:         level: warning
  261: 
  262: =head2 Logging
  263: 
  264: C<configure()> always sets C<$params-E<gt>{logger}> to a L<Log::Abstraction>
  265: instance.  You can control it by passing a C<logger> key:
  266: 
  267:     # Arrayref: messages are captured into @log (protected from merge override)
  268:     configure($class, { logger => \@log });
  269: 
  270:     # Hashref: options forwarded to Log::Abstraction::new()
  271:     configure($class, { logger => { level => 'debug', file => '/var/log/app.log' } });
  272: 
  273:     # String 'NULL': disables all logging
  274:     configure($class, { logger => 'NULL' });
  275: 
  276:     # Existing Log::Abstraction object: used as-is
  277:     configure($class, { logger => $my_logger });
  278: 
  279: B<Note:> only arrayref loggers are stashed before the config merge and are guaranteed
  280: to survive it.  C<'NULL'> and blessed logger objects can be overridden by a
  281: C<UNIVERSAL:> section in C<universal.yml>.  See L</COMMON PITFALLS>.
  282: 
  283: =head2 Environment variable format
  284: 
  285: Environment variable names are constructed as:
  286: 
  287:     ClassName__key
  288: 
  289: where C<::> in the class name is replaced by two underscores.
  290: 
  291:     export My__Module__timeout=60
  292:     export My__Module__logger__level=debug
  293: 
  294: =head1 HOT RELOAD
  295: 
  296: Hot reload lets you edit a config file and have all live objects update themselves
  297: without restarting the program.
  298: 
  299: =head2 How it works
  300: 
  301: =over 4
  302: 
  303: =item 1. Your constructor calls C<register_object($class, $self)> to opt in.
  304: 
  305: =item 2. Your main program calls C<enable_hot_reload()> to fork a background watcher.
  306: 
  307: =item 3. The watcher polls config files every C<interval> seconds and sends
  308: C<SIGUSR1> to the parent when it detects a change.
  309: 
  310: =item 4. The C<SIGUSR1> handler calls C<reload_config()>, which re-reads files and
  311: updates every registered object in-place.
  312: 
  313: =item 5. Your main program calls C<disable_hot_reload()> on shutdown.
  314: 
  315: =back
  316: 
  317: Private keys (those whose names start with C<_>) are never overwritten during
  318: reload, so internal bookkeeping is safe.
  319: 
  320: B<Hot reload is not supported on Windows.>
  321: 
  322: =head1 COMMON PITFALLS
  323: 
  324: =head2 Only arrayref loggers survive the config merge
  325: 
  326: If you pass C<logger =E<gt> 'NULL'> or C<logger =E<gt> $existing_logger>, the
  327: C<UNIVERSAL:> section in C<universal.yml> (or a site-local config file) can
  328: silently override your logger during the config merge.
  329: 
  330: Only arrayref loggers are stashed before the merge and are guaranteed to survive:
  331: 
  332:     # Protected -- will NOT be overridden by universal.yml
  333:     configure($class, { logger => \@captured });
  334: 
  335:     # NOT protected -- universal.yml can override these
  336:     configure($class, { logger => 'NULL' });
  337:     configure($class, { logger => $existing_obj });
  338: 
  339: =head2 Caller-supplied keys are the LOWEST priority
  340: 
  341: Despite being called "defaults", keys you pass directly to C<configure()> are
  342: overridden by config files and environment variables:
  343: 
  344:     # My__Module__timeout=60 is set in the shell.
  345:     # $params->{timeout} will be 60, not 30.
  346:     configure('My::Module', { timeout => 30 });
  347: 
  348: Use caller-supplied keys only as a last-resort fallback.
  349: 
  350: =head2 register_object() pushes; it does not replace
  351: 
  352: Calling C<register_object()> twice for the same class registers B<two> entries.
  353: Both objects receive updates on every reload.  The second call does not remove the
  354: first.
  355: 
  356:     Object::Configure::register_object('My::Class', $obj_a);
  357:     Object::Configure::register_object('My::Class', $obj_b);
  358:     # reload_config() now updates BOTH $obj_a and $obj_b
  359: 
  360: =head2 Private keys are never updated on hot reload
  361: 
  362: Any key whose name begins with C<_> is skipped during C<reload_config()>.
  363: A config key named C<_my_setting> in your YAML file will be ignored at reload time.
  364: 
  365: =head2 The 'class' key appears on objects created by instantiate()
  366: 
  367: C<instantiate()> intentionally leaves the C<class> key in the hashref passed to
  368: C<$class-E<gt>new()> as a debugging aid.  Your object will have a C<class>
  369: attribute set to the class name:
  370: 
  371:     my $obj = Object::Configure::instantiate(class => 'My::Thing', ...);
  372:     print $obj->{class};    # prints 'My::Thing'
  373: 
  374: =head2 Memoization caches are not invalidated during a run
  375: 
  376: C<_get_inheritance_chain()> and C<_find_class_config_file()> cache their results
  377: for the lifetime of the process.  If you alter C<@ISA> or add config files after
  378: the first C<configure()> call for a given class, the cache returns stale results.
  379: 
  380: =head2 disable_hot_reload() blocks for up to five seconds
  381: 
  382: It waits for the watcher process to exit (SIGTERM first, then SIGKILL).  Do not
  383: call it from inside a signal handler or a timing-sensitive loop.
  384: 
  385: =head2 config_file must be developer-controlled
  386: 
  387: The C<config_file> path is validated against directory traversal (C<../>) but is
  388: not otherwise restricted.  It must always be a developer-supplied path, never raw
  389: user input.
  390: 
  391: =head1 SUBROUTINES/METHODS
  392: 
  393: =head2 configure($class, \%params)
  394: 
  395: Merge configuration for C<$class> from all available sources and return a hashref
  396: ready to pass to C<bless>.  This is the core function; call it at the start of your
  397: C<new()> method.
  398: 
  399: =head3 Arguments
  400: 
  401: =over 4
  402: 
  403: =item * C<$class> (Required, string)
  404: 
  405: The fully-qualified Perl class name to configure (e.g., C<'My::Module'>).  Must
  406: start with a letter or underscore; each C<::>-separated component must also start
  407: with a letter or underscore.  Digits, newlines, and shell metacharacters are rejected.
  408: 
  409: =item * C<\%params> (Optional, hashref; defaults to C<{}>)
  410: 
  411: Caller-supplied values.  These have the I<lowest> priority and are overridden by
  412: config files and environment variables.  Recognized special keys:
  413: 
  414: =over 4
  415: 
  416: =item * C<config_file> (string, optional) -- path to the primary YAML/JSON/conf file.
  417: 
  418: =item * C<config_dirs> (arrayref of strings, optional) -- additional directories to
  419: search when C<config_file> is a bare filename with no directory component.
  420: 
  421: =item * C<logger> (various, optional) -- see L</Logging>.
  422: 
  423: =item * C<carp_on_warn> (boolean, optional, default 0) -- if true, the logger uses
  424: C<Carp::carp> instead of C<warn>.
  425: 
  426: =item * C<croak_on_error> (boolean, optional, default 1) -- if true, the logger uses
  427: C<Carp::croak> instead of C<die>.
  428: 
  429: =back
  430: 
  431: =back
  432: 
  433: =head3 Returns
  434: 
  435: A hashref containing all merged configuration keys plus:
  436: 
  437: =over 4
  438: 
  439: =item * C<logger> -- a L<Log::Abstraction> instance, or the string C<'NULL'>.
  440: 
  441: =item * C<_config_file> -- path of the primary config file (only if one was loaded).
  442: 
  443: =item * C<_config_files> -- arrayref of every config file that was loaded (only if
  444: at least one was loaded).
  445: 
  446: =back
  447: 
  448: =head3 Error messages
  449: 
  450: =over 4
  451: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  452: =item * C<Object::Configure: configure: what class do you want to configure?> --
  453: C<$class> was C<undef> or an empty string.  Pass C<ref($self)> or C<__PACKAGE__>.
  454: 
  455: =item * C<Object::Configure: configure: invalid class name (must be a valid Perl package name): CLASS> --
  456: C<$class> contains characters not allowed in a Perl package name (for example, a

					

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

  457: digit as the first character of a C<::>-component, a newline, or a semicolon).
  458: 
  459: =item * C<CLASS: config_file contains path traversal sequences: FILE> --
  460: C<config_file> contains a C<..> segment (e.g., C<../../etc/passwd>).  The
  461: C<config_file> argument must always be a developer-controlled path.
  462: 
  463: =item * C<CLASS: FILE: OS-ERROR> --
  464: C<config_file> is not readable and no C<config_dirs> were supplied.  Check file
  465: permissions or add C<config_dirs>.
  466: 
  467: =item * C<Warning: Can't load configuration from FILE: DETAIL> --
  468: L<Config::Abstraction> rejected the file (typically a YAML/JSON syntax error).
  469: This is a warning, not fatal; C<configure()> continues with an empty config.
  470: 
  471: =item * C<Object::Configure: config_path contains path traversal sequences: PATH> --
  472: An environment variable set a C<config_path> value containing C<..>.
  473: 
  474: =back

  Mutants (Total: 1, Killed: 1, Survived: 0)
  475: 
  476: =head3 API Specification
  477: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  478: =head4 Input
  479: 
  480:     schema => {
  481:         class => {
  482:             type        => 'string',
  483:             required    => 1,
  484:             description => 'Fully-qualified Perl class name',
  485:             pattern     => qr/\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/,
  486:         },
  487:         params => {
  488:             type        => 'hashref',
  489:             optional    => 1,
  490:             default     => {},
  491:             description => 'Caller-supplied defaults (lowest priority)',

  Mutants (Total: 1, Killed: 1, Survived: 0)
  492:             schema => {
  493:                 config_file => {
  494:                     type        => 'string',
  495:                     optional    => 1,
  496:                     description => 'Primary config file path',
  497:                 },
  498:                 config_dirs => {
  499:                     type        => 'arrayref',
  500:                     optional    => 1,

  Mutants (Total: 1, Killed: 1, Survived: 0)
  501:                     description => 'Extra directories to search for config files',
  502:                 },
  503:                 logger => {
  504:                     type        => [qw(undef string arrayref hashref object)],
  505:                     optional    => 1,
  506:                     description => 'Logger spec -- see CONFIGURATION/Logging',
  507:                 },

  Mutants (Total: 1, Killed: 1, Survived: 0)
  508:                 carp_on_warn => {
  509:                     type        => 'boolean',
  510:                     optional    => 1,

  Mutants (Total: 1, Killed: 1, Survived: 0)
  511:                     default     => 0,
  512:                     description => 'Use Carp::carp for logger warnings',
  513:                 },
  514:                 croak_on_error => {
  515:                     type        => 'boolean',
  516:                     optional    => 1,
  517:                     default     => 1,
  518:                     description => 'Use Carp::croak for logger errors',

  Mutants (Total: 1, Killed: 1, Survived: 0)
  519:                 },
  520:             },
  521:         },
  522:     }
  523: 
  524: =head4 Output
  525: 
  526:     type        => 'hashref',
  527:     description => 'Merged configuration hashref, ready to bless',
  528:     schema => {
  529:         logger => {
  530:             type        => [qw(object string)],
  531:             description => 'Log::Abstraction instance or the string "NULL"',
  532:         },
  533:         _config_file => {
  534:             type        => 'string',
  535:             optional    => 1,
  536:             description => 'Path of the primary config file that was loaded',
  537:         },
  538:         _config_files => {
  539:             type        => 'arrayref',
  540:             optional    => 1,
  541:             description => 'All config file paths that were loaded, in load order',
  542:         },
  543:     }
  544: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  545: =cut
  546: 
  547: sub configure {
●548 → 572 → 580  548: 	my $class  = $_[0];
  549: 	my $params = $_[1] // {};	# caller's defaults; config file values override them
  550: 	my $array_logger;		# stash for an arrayref logger spec (Config::Abstraction rejects refs)
  551: 
  552: 	croak(__PACKAGE__, ': configure: what class do you want to configure?')
  553: 		if !defined($class) || $class eq '';
  554: 
  555: 	# SECURITY: validate $class is a syntactically valid Perl package name before
  556: 	# it propagates into env_prefix, croak messages, and %_chain_cache keys.
  557: 	# Exploit mechanism: a class name containing \n, ;, or shell metacharacters
  558: 	# can poison log lines, carp output, and env-variable lookups if not rejected here.
  559: 	# Under Perl taint mode (-T) an unvalidated external value would also fail the
  560: 	# taint check inside Config::Abstraction when used as an env_prefix substring.
  561: 	croak(__PACKAGE__, ': configure: invalid class name (must be a valid Perl package name): ', $class)
  562: 		unless $class =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;
  563: 
  564: 	# Config::Abstraction, Log::Abstraction, and Return::Set all use eval internally
  565: 	# Protect the caller's $@ from being clobbered by our internal eval blocks.
  566: 	local $@;
  567: 
  568: 	# Config::Abstraction treats unknown scalar values as config file paths and will
  569: 	# attempt to read them, corrupting coderefs and object references.

  Mutants (Total: 1, Killed: 1, Survived: 0)
  570: 	# Stash them here and restore after merging so callers never need this pattern.
  571: 	my %stashed_values;
  572: 	foreach my $key (keys %$params) {
  573: 		next if $key eq 'logger';	# logger has its own path through _build_logger
  574: 		my $value = $params->{$key};
  575: 		if(ref($value) eq 'CODE' || blessed($value)) {
  576: 			$stashed_values{$key} = delete $params->{$key};
  577: 		}
  578: 	}
  579: 
●580 → 580 → 584  580: 	if(exists($params->{'logger'}) && ref($params->{'logger'}) eq 'ARRAY') {
  581: 		$array_logger = delete $params->{'logger'};
  582: 	}
  583: 
●584 → 596 → 603  584: 	my $original_class = $class;
  585: 	$class =~ s/::/__/g;
  586: 
  587: 	my $config_file = $params->{'config_file'};
  588: 	my $config_dirs = $params->{'config_dirs'};
  589: 

					

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

  590: 	# SECURITY (S1 — path traversal): reject config_file paths containing ".." segments
  591: 	# before they reach Config::Abstraction.  The pen-test suite confirmed C::A parses
  592: 	# /etc/passwd as a colon-delimited conf file, injecting every user account as a
  593: 	# config key.  The ".." guard blocks the traversal vector; direct absolute paths to
  594: 	# system files remain the caller's responsibility (document: config_file must be
  595: 	# developer-controlled, never raw user input).
  596: 	if(defined($config_file) && $config_file =~ $RE_PATH_TRAVERSAL) {
  597: 		croak("$class: config_file contains path traversal sequences: $config_file");
  598: 	}
  599: 
  600: 	# _get_inheritance_chain returns [UNIVERSAL, ..., Base, Child] (base-first).
  601: 	# Reversing it below gives child-first for the discovery loop; the sort
  602: 	# that follows re-establishes base-first order for actual loading.
●603 → 608 → 652  603: 	my @inheritance_chain = _get_inheritance_chain($original_class);
  604: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  605: 	my @config_files_to_load = ();
  606: 	my %tracked_files        = ();
  607: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  608: 	if($config_file) {
  609: 		# Fail early so the error message carries the OS errno string while $!
  610: 		# is still fresh from the -r test, giving a locale-correct message.
  611: 		if(!$config_dirs && !-r $config_file) {
  612: 			croak("$class: ", $config_file, ": $!");
  613: 		}
  614: 
  615: 		foreach my $ancestor_class (reverse @inheritance_chain) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
  616: 			my $ancestor_config_file = _find_class_config_file(
  617: 				$ancestor_class,
  618: 				$config_file,
  619: 				$config_dirs
  620: 			);
  621: 
  622: 			# Primary file is added separately at the end (highest priority)
  623: 			next if $ancestor_config_file && $ancestor_config_file eq $config_file;
  624: 
  625: 			if($ancestor_config_file && -r $ancestor_config_file && !$tracked_files{$ancestor_config_file}) {
  626: 				push @config_files_to_load, { file => $ancestor_config_file, class => $ancestor_class };
  627: 				$tracked_files{$ancestor_config_file} = 1;
  628: 				$_config_file_stats{$ancestor_config_file} = stat($ancestor_config_file)
  629: 					if -f $ancestor_config_file;
  630: 			}
  631: 		}
  632: 
  633: 		# Premise: $config_file is true (we are inside if($config_file) above).
  634: 		if(!$tracked_files{$config_file} && -r $config_file) {
  635: 			push @config_files_to_load, { file => $config_file, class => $original_class };
  636: 			$tracked_files{$config_file} = 1;
  637: 			$_config_file_stats{$config_file} = stat($config_file)
  638: 				if -f $config_file;
  639: 		}
  640: 
  641: 		if(!scalar(@config_files_to_load)) {
  642: 			foreach my $dir (@{$config_dirs}) {
  643: 				my $candidate = File::Spec->catfile($dir, $config_file);
  644: 				if(-r $candidate) {
  645: 					push @config_files_to_load, { file => $candidate, class => $original_class };
  646: 					last;	# stop at first readable hit; later dirs are lower priority
  647: 				}
  648: 			}
  649: 		}
  650: 	}
  651: 
●652 → 652 → 739  652: 	if(@config_files_to_load) {
  653: 		# Sort so that base-class files are loaded before child files.
  654: 		# %class_order is keyed on the chain (UNIVERSAL=0, ..., Child=N).
  655: 		my %class_order;
  656: 		for my $i (0 .. $#inheritance_chain) {
  657: 			$class_order{ $inheritance_chain[$i] } = $i;
  658: 		}
  659: 		@config_files_to_load = sort {
  660: 			($class_order{ $a->{class} } // 999) <=> ($class_order{ $b->{class} } // 999)
  661: 		} @config_files_to_load;
  662: 
  663: 		my $merged_params = { %$params };
  664: 
  665: 		foreach my $config_info (@config_files_to_load) {
  666: 			my $cfg_file    = $config_info->{file};
  667: 			my $cfg_class   = $config_info->{class};
  668: 			my $section_name = $cfg_class;
  669: 			$section_name =~ s/::/__/g;
  670: 
  671: 			# Load only the specific file; do not re-pass config_dirs to avoid
  672: 			# re-scanning directories and picking up the wrong file for this class.
  673: 			my $config = Config::Abstraction->new(
  674: 				config_file => $cfg_file,
  675: 				env_prefix  => "${section_name}__"
  676: 			);
  677: 
  678: 			if($config) {
  679: 				my $this_config = $config->merge_defaults(
  680: 					defaults => {},
  681: 					section  => $section_name,
  682: 					merge    => 1,
  683: 					deep     => 1
  684: 				);
  685: 				$merged_params = _deep_merge($merged_params, $this_config);
  686: 			} elsif($@) {
  687: 				carp("Warning: Can't load configuration from $cfg_file: $@");
  688: 			}
  689: 		}
  690: 
  691: 		$params = $merged_params;
  692: 	} elsif(my $config = Config::Abstraction->new(env_prefix => "${class}__")) {
  693: 		# No config file: honour environment variables across the full ancestor chain.
  694: 		my $merged_config = {};
  695: 
  696: 		# Iterate base-first so that each more-specific class overrides the more
  697: 		# general one: UNIVERSAL → GrandParent → Parent → Child.
  698: 		foreach my $ancestor_class (@inheritance_chain) {
  699: 			my $section_name = $ancestor_class;
  700: 			$section_name =~ s/::/__/g;
  701: 
  702: 			my $ancestor_env_config = Config::Abstraction->new(env_prefix => "${section_name}__");
  703: 			if($ancestor_env_config) {
  704: 				my $ancestor_config = $ancestor_env_config->merge_defaults(
  705: 					defaults => {},
  706: 					section  => $section_name,
  707: 					merge    => 1,
  708: 					deep     => 1
  709: 				);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  710: 				$merged_config = _deep_merge($merged_config, $ancestor_config);
  711: 			}
  712: 		}
  713: 
  714: 		$params = $config->merge_defaults(
  715: 			defaults => $params,
  716: 			section  => $class,
  717: 			merge    => 1,
  718: 			deep     => 1
  719: 		);
  720: 
  721: 		$params = _deep_merge($merged_config, $params);
  722: 
  723: 		# SECURITY (S1 extension — config_path traversal + taint):
  724: 		# config_path arrives from Config::Abstraction, which reads %ENV.  Under
  725: 		# taint mode (-T) the value is tainted; any syscall with a tainted argument
  726: 		# is fatal.  Apply the same $RE_PATH_TRAVERSAL guard as config_file (line 491)
  727: 		# before any filesystem probe, so the two guards stay in sync.
  728: 		# Exploit: ClassName__config_path=../../etc/shadow causes the hot-reload watcher
  729: 		# to stat() and track an arbitrary system file, leaking mtime changes via SIGUSR1.
  730: 		if($params->{config_path}) {
  731: 			croak(__PACKAGE__, ': config_path contains path traversal sequences: ',
  732: 				$params->{config_path})
  733: 				if $params->{config_path} =~ $RE_PATH_TRAVERSAL;
  734: 			$_config_file_stats{ $params->{config_path} } = stat($params->{config_path})
  735: 				if -f $params->{config_path};
  736: 		}
  737: 	}
  738: 
●739 → 749 → 752  739: 	my $croak_on_error = exists($params->{'croak_on_error'}) ? $params->{'croak_on_error'} : 1;
  740: 	my $carp_on_warn   = exists($params->{'carp_on_warn'})   ? $params->{'carp_on_warn'}   : 0;
  741: 
  742: 	# User-supplied logger always wins over config-file logger.
  743: 	# $array_logger is defined when the caller passed an arrayref; it was deleted from
  744: 	# $params before config merging so the merge couldn't overwrite it.  Config-file logger
  745: 	# (a hashref from YAML) is only used when the caller gave no explicit logger at all.
  746: 	my $logger_spec = defined($array_logger) ? $array_logger : $params->{'logger'};
  747: 	$params->{'logger'} = _build_logger($logger_spec, $carp_on_warn);
  748: 
  749: 	if(!exists($params->{_config_file})) {
  750: 		$params->{_config_file} = $config_file if defined $config_file;
  751: 	}
●752 → 752 → 758  752: 	if(!exists($params->{_config_files})) {
  753: 		$params->{_config_files} = [ map { $_->{file} } @config_files_to_load ]
  754: 			if @config_files_to_load;
  755: 	}
  756: 
  757: 	# Re-attach stashed coderefs/objects via hash slice
  758: 	@{$params}{ keys %stashed_values } = values %stashed_values if %stashed_values;
  759: 
  760: 	return Return::Set::set_return($params, { 'type' => 'hashref' });
  761: }
  762: 
  763: =head2 instantiate(%params)
  764: 
  765: Configure and instantiate a third-party class without modifying the class itself.
  766: 
  767: C<instantiate> is a convenience wrapper: it calls C<configure>, passes the merged
  768: hashref to C<$class-E<gt>new(...)>, and optionally registers the result for hot reload.
  769: Use it when you need runtime configuration for a class whose source you cannot change.
  770: 
  771: =head3 Arguments
  772: 
  773: Takes a flat hash (not a hashref).  Recognized keys:
  774: 
  775: =over 4
  776: 
  777: =item * C<class> (Required, string)
  778: 
  779: The fully-qualified class name to instantiate (e.g., C<'LWP::UserAgent'>).  The class
  780: must already be loaded and must have a C<new> method that accepts a hashref.
  781: 
  782: =item * All other keys
  783: 
  784: Passed through to C<configure()> as C<\%params>.  See L</configure($class, \%params)>
  785: for the full list.
  786: 
  787: =back
  788: 
  789: =head3 Returns
  790: 
  791: A blessed object of type C<$class>.
  792: 
  793: B<Note:> The returned object's hash will contain a C<class> key holding the class name.
  794: This is intentional -- it is left in the hash as a debugging aid so you can always
  795: see which class an object came from.  Do not depend on its absence.
  796: 
  797: =head3 Side Effects
  798: 
  799: =over 4
  800: 
  801: =item * Calls C<configure($class, \%params)> -- see its side effects.
  802: 
  803: =item * Calls C<$class-E<gt>new(\%merged_params)>.
  804: 
  805: =item * If the config produced a C<_config_file>, calls C<register_object($class, $obj)>
  806: so the object participates in hot reload.
  807: 
  808: =back
  809: 
  810: =head3 Error messages
  811: 
  812: Same as C<configure()>.  In addition:
  813: 
  814: =over 4
  815: 
  816: =item * Any exception thrown by C<$class-E<gt>new(...)> propagates unchanged.
  817: 
  818: =back
  819: 
  820: =head3 Usage Example
  821: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  822:     use Object::Configure;
  823: 
  824:     my $ua = Object::Configure::instantiate(

  Mutants (Total: 2, Killed: 2, Survived: 0)
  825:         class       => 'LWP::UserAgent',
  826:         config_file => 'lwp.yml',
  827:         config_dirs => ['/etc/myapp'],
  828:         timeout     => 30,
  829:     );
  830: 
  831: =head3 API Specification
  832: 
  833: =head4 Input
  834: 
  835:     schema => {
  836:         class => {
  837:             type        => 'string',
  838:             required    => 1,
  839:             description => 'Fully-qualified class name; must respond to new(hashref)',
  840:         },
  841:         # all other keys forwarded to configure()
  842:     }
  843: 
  844: =head4 Output
  845: 
  846:     type        => 'object',
  847:     description => 'Blessed instance of $class, with class key present in hash',
  848:     notes       => 'class key intentionally left in hash as a debugging aid',
  849: 
  850: =cut
  851: 
  852: sub instantiate
  853: {
  854: 	my $params = Params::Get::get_params('class', @_);
  855: 
  856: 	# 'class' is read into $class then left in $params,
  857: 	# 'class' propagates into configure() as a spurious config key and
  858: 	# ends up in the blessed object's hash, allowing the caller to see
  859: 	# that has come from what, helping debugging
  860: 	my $class = $params->{'class'};
  861: 	$params = configure($class, $params);
  862: 
  863: 	my $obj = $class->new($params);
  864: 
  865: 	register_object($class, $obj) if $params->{_config_file};
  866: 
  867: 	return $obj;
  868: }
  869: 
  870: =head1 HOT RELOAD FEATURES
  871: 
  872: =head2 enable_hot_reload(%opts)
  873: 
  874: Fork a background watcher that sends SIGUSR1 to the parent whenever a tracked
  875: configuration file changes on disk.  Objects registered via C<register_object()>
  876: then have their configuration reloaded automatically.
  877: 
  878: B<Unix only.>  On Windows this function is a silent no-op (SIGUSR1 does not exist).
  879: 
  880: =head3 Arguments
  881: 
  882: Takes a flat hash.  All keys are optional.
  883: 
  884: =over 4
  885: 
  886: =item * C<interval> (integer E<gt>= 1, default: 10)
  887: 
  888: Seconds between file-modification checks.  Lower values detect changes faster
  889: but use more CPU.  Zero or negative values are silently replaced with the default.
  890: 
  891: =item * C<callback> (coderef, optional)
  892: 
  893: Called in the parent process after each successful config reload.  Useful for
  894: logging or flushing caches.
  895: 
  896: =back
  897: 
  898: =head3 Returns
  899: 
  900: The PID of the watcher child process (integer E<gt> 0), or C<undef>/empty if hot
  901: reload was already active (idempotent: a second call returns immediately without
  902: forking again).
  903: 
  904: =head3 Side Effects
  905: 
  906: =over 4
  907: 
  908: =item * Forks a child process.
  909: 
  910: =item * The child polls C<%_config_file_stats> and sends C<SIGUSR1> to the parent
  911: on mtime change.
  912: 
  913: =item * Stores C<{pid =E<gt> $pid, callback =E<gt> $cb}> in C<%_config_watchers>.
  914: 
  915: =back
  916: 
  917: =head3 Error messages
  918: 
  919: =over 4
  920: 
  921: =item * C<Object::Configure: fork failed: OS-ERROR> -- C<fork()> returned C<undef>.
  922: Check system resource limits (C<ulimit -u>).
  923: 
  924: =back
  925: 
  926: =head3 Usage Example
  927: 
  928:     Object::Configure::enable_hot_reload(
  929:         interval => 5,
  930:         callback => sub { warn "Config reloaded at " . localtime . "\n" },
  931:     );
  932: 
  933:     while (1) { sleep 1 }  # watcher runs in the background
  934: 
  935: =head3 API Specification
  936: 
  937: =head4 Input
  938: 
  939:     schema => {
  940:         interval => {
  941:             type        => 'integer',
  942:             optional    => 1,
  943:             default     => 10,
  944:             minimum     => 1,
  945:             description => 'Poll interval in seconds',
  946:         },
  947:         callback => {
  948:             type        => 'coderef',
  949:             optional    => 1,
  950:             description => 'Called in parent after each reload',
  951:         },
  952:     }
  953: 
  954: =head4 Output
  955: 
  956:     type        => [qw(integer undef)],
  957:     description => 'PID of watcher child; undef/empty if already active',
  958:     condition   => 'value > 0 when defined',
  959: 
  960:     enable_hot_reload : Interval x Callback -> PID | empty
  961: 
  962:     Pre:
  963:       interval >= 1   (enforced: negative/zero replaced with DEFAULT_INTERVAL)
  964:       _config_watchers = {}
  965: 
  966:     Post:
  967:       _config_watchers.pid = result
  968:       _config_watchers.callback = callback
  969:       (forall t: t mod interval = 0 =>
  970:           (exists f in _config_file_stats: mtime(f) changed =>
  971:               send_signal(SIGUSR1, parent_pid)))
  972: 
  973: =cut
  974: 
  975: sub enable_hot_reload {
●976 → 987 → 0  976: 	my %params = @_;
  977: 
  978: 	# SECURITY (S4): use defined-or (//) not truth-or (||) so that interval=>0
  979: 	# is not silently replaced.  Then guard: a zero or negative interval would make
  980: 	# the child busy-loop, consuming 100% CPU (internal DoS vector).
  981: 	my $interval = $params{interval} // $DEFAULT_INTERVAL;
  982: 	$interval    = $DEFAULT_INTERVAL unless $interval > 0;
  983: 	my $callback = $params{callback};
  984: 
  985: 	return if %_config_watchers;	# already watching; avoid double-fork
  986: 
  987: 	if(my $pid = fork()) {
  988: 		$_config_watchers{pid}      = $pid;
  989: 		$_config_watchers{callback} = $callback;
  990: 		return $pid;
  991: 	} elsif(defined $pid) {
  992: 		# Child: run forever, signal parent on change
  993: 		_run_config_watcher($interval, $callback);
  994: 		exit 0;
  995: 	} else {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  996: 		croak("Failed to fork config watcher: $!");
  997: 	}
  998: }
  999: 
 1000: =head2 disable_hot_reload()
 1001: 
 1002: Stop the background watcher and clear hot-reload state.

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1003: 
 1004: Safe to call when hot reload is not active (no-op).  After this call,
 1005: configuration files are no longer monitored and C<%_config_watchers> is empty.
 1006: 
 1007: =head3 Arguments
 1008: 
 1009: None.
 1010: 
 1011: =head3 Returns

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1012: 
 1013: Nothing (void).
 1014: 
 1015: =head3 Side Effects
 1016: 
 1017: =over 4
 1018: 
 1019: =item * Sends SIGTERM to the watcher child.
 1020: 
 1021: =item * Polls for up to C<$KILL_TIMEOUT> seconds (default: 5); escalates to SIGKILL
 1022: if the child has not exited by then.
 1023: 
 1024: =item * Calls C<waitpid> to reap the child.
 1025: 
 1026: =item * Clears C<%_config_watchers>.
 1027: 
 1028: =back
 1029: 
 1030: B<Blocking>: this function may take up to five seconds if the watcher ignores SIGTERM.
 1031: 
 1032: =head3 API Specification
 1033: 
 1034: =head4 Input
 1035: 
 1036:     schema => {}   # no arguments
 1037: 
 1038: =head4 Output
 1039: 
 1040:     type => 'void'
 1041: 
 1042: =cut
 1043: 
 1044: sub disable_hot_reload {
 1045: 	## MUTANT_SKIP_BEGIN
●1046 → 1046 → 0 1046: 	if(my $pid = $_config_watchers{pid}) {
 1047: 		# SECURITY (S3 — PID safety):
 1048: 		#   $pid > 1  excludes PID 0 (sends SIGTERM to whole process group — DoS)
 1049: 		#             and PID 1 (init — catastrophic as root).
 1050: 		#   $pid != $$ prevents self-signaling if %_config_watchers is corrupted.
 1051: 		# Exploit mechanism: if global state is poisoned with pid=0 or pid=1,
 1052: 		# kill('TERM', 0) signals every process in the group; kill('TERM', 1) kills
 1053: 		# init as root.  Both are now rejected at the comparison level.
 1054: 		if($pid =~ /\A[0-9]+\z/ && $pid > 1 && $pid != $$) {
 1055: 			kill('TERM', $pid);
 1056: 
 1057: 			# Poll up to KILL_TIMEOUT seconds; escalate to SIGKILL if SIGTERM is ignored.
 1058: 			# SIGKILL cannot be caught or deferred so the subsequent waitpid is always safe.
 1059: 			my $deadline = time() + $KILL_TIMEOUT;
 1060: 			my $kid;
 1061: 			do {
 1062: 				$kid = waitpid($pid, WNOHANG);
 1063: 				if($kid == 0 && time() < $deadline) {
 1064: 					select undef, undef, undef, $POLL_SLEEP;
 1065: 				}
 1066: 			} while($kid == 0 && time() < $deadline);
 1067: 
 1068: 			if($kid == 0) {
 1069: 				kill('KILL', $pid);
 1070: 				waitpid($pid, 0);
 1071: 			}
 1072: 		}
 1073: 		%_config_watchers = ();
 1074: 	}
 1075: 	## MUTANT_SKIP_END
 1076: }
 1077: 
 1078: =head2 reload_config()
 1079: 
 1080: Immediately reload configuration from disk for every registered object.
 1081: 
 1082: Normally called automatically by the SIGUSR1 handler.  You may call it manually
 1083: to force a reload (e.g., in tests or on a custom signal).
 1084: 
 1085: =head3 Arguments
 1086: 
 1087: None.
 1088: 
 1089: =head3 Returns
 1090: 
 1091: An integer E<gt>= 0: the count of objects whose configuration was successfully
 1092: reloaded.
 1093: 
 1094: =head3 Side Effects
 1095: 
 1096: =over 4
 1097: 
 1098: =item * Reads config files from disk for each registered object.
 1099: 
 1100: =item * Updates non-private keys (those not starting with C<_>) in-place on
 1101: each live object.
 1102: 
 1103: =item * Prunes dead weak references from C<%_object_registry>.
 1104: 
 1105: =item * Emits a C<carp> warning (not a croak) if reload fails for any individual
 1106: object; other objects are still processed.
 1107: 
 1108: =back
 1109: 
 1110: =head3 API Specification
 1111: 
 1112: =head4 Input
 1113: 
 1114:     schema => {}   # no arguments
 1115: 
 1116: =head4 Output
 1117: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1118:     type        => 'integer',
 1119:     description => 'Count of objects successfully reloaded',
 1120:     condition   => 'value >= 0',
 1121: 
 1122: =cut
 1123: 
 1124: sub reload_config {
●1125 → 1127 → 1149 1125: 	my $reloaded_count = 0;
 1126: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1127: 	foreach my $class_key (keys %_object_registry) {
 1128: 		my $objects = $_object_registry{$class_key};
 1129: 
 1130: 		@$objects = grep { defined $$_ } @$objects;	# prune garbage-collected weak refs (check referent, not the ref-to-scalar itself)
 1131: 
 1132: 		foreach my $obj_ref (@$objects) {
 1133: 			if(my $obj = $$obj_ref) {
 1134: 				# Protect the caller's $@ from being clobbered by our internal eval blocks.
 1135: 				local $@;
 1136: 				eval {
 1137: 					_reload_object_config($obj);
 1138: 					$reloaded_count++;
 1139: 				};
 1140: 				if($@) {
 1141: 					carp("Failed to reload config for object: $@");
 1142: 				}
 1143: 			}
 1144: 		}
 1145: 
 1146: 		delete $_object_registry{$class_key} unless @$objects;
 1147: 	}
 1148: 
 1149: 	return $reloaded_count;
 1150: }
 1151: 
 1152: =head2 register_object($class, $obj)
 1153: 
 1154: Register a blessed object so it receives configuration updates when files change.
 1155: 
 1156: B<Push semantics>: each call I<appends> a new entry to the registry for C<$class>.
 1157: It does not replace a previous entry.  Multiple objects of the same class are all
 1158: tracked and all reloaded.
 1159: 
 1160: =head3 Arguments
 1161: 
 1162: =over 4
 1163: 
 1164: =item * C<$class> (Required, string)
 1165: 
 1166: The class name used to organise the registry.  Typically C<ref($self)> or the
 1167: calling package name.
 1168: 
 1169: =item * C<$obj> (Required, blessed reference)
 1170: 
 1171: The object to register.  B<Must be a blessed reference.>  Passing an unblessed
 1172: hashref or any other unblessed value causes an immediate C<croak>.
 1173: 
 1174: =back
 1175: 
 1176: =head3 Returns
 1177: 
 1178: Nothing (void).
 1179: 
 1180: =head3 Side Effects
 1181: 
 1182: =over 4
 1183: 
 1184: =item * Pushes a weak reference to C<$obj> onto C<$_object_registry{$class}>.
 1185: 
 1186: =item * On the first call ever (for any class): saves the current C<$SIG{USR1}>
 1187: and installs Object::Configure's handler.  On Unix, the handler calls
 1188: C<reload_config()> then chains to the prior handler.  On Windows, signal
 1189: installation is skipped but C<$_original_usr1_handler> is still set.
 1190: 
 1191: =back
 1192: 
 1193: =head3 Error messages
 1194: 
 1195: =over 4
 1196: 
 1197: =item * C<Object::Configure::register_object: Usage ($class, $obj)> --

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1198: either C<$class> or C<$obj> was C<undef>.
 1199: 
 1200: =item * C<Object::Configure::register_object: $obj must be a blessed reference> --
 1201: C<$obj> was defined but not blessed.  This guard prevents DoS via registry flooding
 1202: (reloading thousands of unblessed entries on every SIGUSR1).
 1203: 
 1204: =back
 1205: 
 1206: =head3 Usage Example
 1207: 
 1208:     package My::Module;
 1209:     use Object::Configure;
 1210: 
 1211:     sub new {
 1212:         my ($class, %args) = @_;
 1213:         my $params = Object::Configure::configure($class, \%args);
 1214:         my $self   = bless $params, $class;
 1215:         Object::Configure::register_object($class, $self)
 1216:             if $self->{_config_file};
 1217:         return $self;
 1218:     }
 1219: 
 1220: =head3 API Specification
 1221: 
 1222: =head4 Input
 1223: 
 1224:     schema => {
 1225:         class => {
 1226:             type        => 'string',
 1227:             required    => 1,
 1228:             description => 'Class name for registry key',
 1229:         },
 1230:         obj => {
 1231:             type        => 'object',
 1232:             required    => 1,
 1233:             description => 'Blessed object to register; unblessed refs are rejected',
 1234:             blessed     => 1,
 1235:         },
 1236:     }
 1237: 
 1238: =head4 Output
 1239: 
 1240:     type => 'void'
 1241: 
 1242: =cut
 1243: 
 1244: sub register_object
 1245: {
●1246 → 1266 → 1286 1246: 	my ($class, $obj) = @_;
 1247: 
 1248: 	croak(__PACKAGE__, '::register_object: Usage ($class, $obj)')
 1249: 		unless defined($class) && defined($obj);
 1250: 
 1251: 	# SECURITY: enforce the API contract (POD: "$obj must be a blessed reference").
 1252: 	# Accepting unblessed refs silently would allow DoS via registry flooding: an
 1253: 	# adversary or buggy caller can push thousands of unblessed entries; reload_config()
 1254: 	# iterates every entry on every SIGUSR1, degrading throughput proportionally.
 1255: 	croak(__PACKAGE__, '::register_object: $obj must be a blessed reference')
 1256: 		unless blessed($obj);
 1257: 
 1258: 	my $obj_ref = \$obj;
 1259: 	weaken($$obj_ref);
 1260: 	push @{ $_object_registry{$class} }, $obj_ref;
 1261: 
 1262: 	# Install SIGUSR1 handler exactly once.  We save the previous handler so
 1263: 	# we can chain to it (another module may have installed one) and restore it
 1264: 	# on shutdown.  On Windows SIGUSR1 does not exist so we skip the signal work
 1265: 	# but still save $_original_usr1_handler so restore_signal_handlers is safe.
 1266: 	if(!defined $_original_usr1_handler) {
 1267: 		$_original_usr1_handler = $SIG{USR1} || $SIG_DEFAULT;
 1268: 
 1269: 		return if $^O eq $OS_WINDOWS;
 1270: 
 1271: 		$SIG{USR1} = sub {
 1272: 			reload_config();
 1273: 			$_config_watchers{callback}->() if $_config_watchers{callback};
 1274: 
 1275: 			if(ref($_original_usr1_handler) eq 'CODE') {
 1276: 				$_original_usr1_handler->();
 1277: 			} elsif($_original_usr1_handler eq $SIG_DEFAULT
 1278: 			     || $_original_usr1_handler eq $SIG_IGNORE) {
 1279: 				# DEFAULT for USR1 is typically a no-op; IGNORE means discard
 1280: 			} else {
 1281: 				carp("Object::Configure: Cannot chain to non-code USR1 handler: $_original_usr1_handler");
 1282: 			}
 1283: 		};
 1284: 	}
 1285: 
 1286: 	return;
 1287: }
 1288: 
 1289: =head2 restore_signal_handlers()
 1290: 
 1291: Restore C<$SIG{USR1}> to the handler that was in place before
 1292: C<register_object()> installed the hot-reload handler, and clear
 1293: C<$_original_usr1_handler>.
 1294: 
 1295: Safe to call even when Object::Configure never installed a handler (no-op).
 1296: On Windows this function has no effect (SIGUSR1 does not exist there).
 1297: 
 1298: =head3 Arguments
 1299: 
 1300: None.
 1301: 
 1302: =head3 Returns
 1303: 
 1304: Nothing (void).
 1305: 
 1306: =head3 Side Effects
 1307: 
 1308: =over 4
 1309: 
 1310: =item * Sets C<$SIG{USR1}> back to its saved value (Unix only).
 1311: 
 1312: =item * Sets C<$_original_usr1_handler> to C<undef>.
 1313: 
 1314: =back
 1315: 
 1316: =head3 API Specification
 1317: 
 1318: =head4 Input
 1319: 
 1320:     schema => {}   # no arguments
 1321: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1322: =head4 Output
 1323: 
 1324:     type => 'void'

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1325: 
 1326: =cut
 1327: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1328: sub restore_signal_handlers
 1329: {
●1330 → 1330 → 1335 1330: 	if(defined $_original_usr1_handler) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1331: 		$SIG{USR1} = $_original_usr1_handler unless $^O eq $OS_WINDOWS;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1332: 		$_original_usr1_handler = undef;
 1333: 	}
 1334: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1335: 	return;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1336: }
 1337: 
 1338: =head2 get_signal_handler_info()
 1339: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1340: Return a snapshot of the current signal-handler and hot-reload state.
 1341: This is a debugging aid; normal application code does not need to call it.
 1342: 
 1343: =head3 Arguments
 1344: 
 1345: None.
 1346: 
 1347: =head3 Returns
 1348: 
 1349: A hashref with these keys:
 1350: 
 1351: =over 4
 1352: 
 1353: =item * C<original_usr1> -- the C<$SIG{USR1}> value that existed before
 1354: Object::Configure installed its handler, or C<undef> if no handler was saved yet.
 1355: 
 1356: =item * C<current_usr1> -- the currently installed C<$SIG{USR1}> handler (coderef,
 1357: C<'DEFAULT'>, C<'IGNORE'>, or C<undef>).

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1358: 
 1359: =item * C<hot_reload_active> -- C<1> if C<$_original_usr1_handler> is defined,
 1360: C<''> otherwise.
 1361: 
 1362: =item * C<watcher_pid> -- the PID of the background watcher child, or C<undef>
 1363: if C<enable_hot_reload()> has not been called (or the watcher has been stopped).
 1364: 
 1365: =back
 1366: 
 1367: =head3 Usage Example
 1368: 
 1369:     use Object::Configure;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1370:     use Data::Dumper;
 1371: 
 1372:     Object::Configure::enable_hot_reload();
 1373:     print Dumper(Object::Configure::get_signal_handler_info());
 1374:     # {
 1375:     #   original_usr1    => 'DEFAULT',
 1376:     #   current_usr1     => sub { ... },
 1377:     #   hot_reload_active => 1,
 1378:     #   watcher_pid       => 12345,
 1379:     # }
 1380: 
 1381: =head3 API Specification
 1382: 
 1383: =head4 Input
 1384: 
 1385:     schema => {}   # no arguments
 1386: 
 1387: =head4 Output
 1388: 
 1389:     type        => 'hashref',
 1390:     description => 'Snapshot of signal-handler and watcher state',

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1391:     schema => {
 1392:         original_usr1     => { type => [qw(coderef string undef)] },
 1393:         current_usr1      => { type => [qw(coderef string undef)] },
 1394:         hot_reload_active => { type => 'boolean'                  },
 1395:         watcher_pid       => { type => [qw(integer undef)]        },
 1396:     }
 1397: 
 1398: =cut
 1399: 
 1400: sub get_signal_handler_info {
 1401: 	return {
 1402: 		original_usr1    => $_original_usr1_handler,
 1403: 		current_usr1     => $SIG{USR1},
 1404: 		hot_reload_active => defined $_original_usr1_handler,
 1405: 		watcher_pid      => $_config_watchers{pid},
 1406: 	};
 1407: }
 1408: 
 1409: # ----------------------------------------------------------------------------
 1410: # Private helpers
 1411: # All routines below are implementation details; callers must not rely on them.
 1412: # ----------------------------------------------------------------------------
 1413: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1414: # Purpose:   Consolidate all logger-creation paths into one place.
 1415: #            Called from configure() and _reconfigure_logger() to eliminate
 1416: #            the duplication that existed between the two.
 1417: # Entry:     $spec may be: undef (want default), the string 'NULL' (no logging),
 1418: #            an ARRAY ref (log-capture array), a HASH ref (options for Log::Abstraction),
 1419: #            a pre-built Log::Abstraction instance (pass through), or any other

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1420: #            scalar (treated as a logger name / file path).
 1421: #            $carp_on_warn is a boolean controlling Carp::carp integration.
 1422: # Exit:      Returns a Log::Abstraction instance, or the string 'NULL'.
 1423: # Side:      May allocate a new Log::Abstraction object.
 1424: sub _build_logger {
●1425 → 1437 → 1441 1425: 	my ($spec, $carp_on_warn) = @_;
 1426: 	$carp_on_warn //= 0;
 1427: 
 1428: 	return Log::Abstraction->new(carp_on_warn => $carp_on_warn)
 1429: 		unless defined $spec;
 1430: 
 1431: 	return $LOGGER_NULL

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1432: 		if !ref($spec) && $spec eq $LOGGER_NULL;
 1433: 
 1434: 	return $spec
 1435: 		if blessed($spec) && $spec->isa('Log::Abstraction');
 1436: 
 1437: 	if(ref($spec) eq 'ARRAY') {
 1438: 		return Log::Abstraction->new(array => $spec, carp_on_warn => $carp_on_warn);
 1439: 	}
 1440: 
●1441 → 1441 → 1446 1441: 	if(ref($spec) eq 'HASH') {
 1442: 		return Log::Abstraction->new({ carp_on_warn => $carp_on_warn, %$spec });
 1443: 	}
 1444: 
 1445: 	# Scalar: a logger name, file path, or other string identifier passed to L::A
 1446: 	return Log::Abstraction->new({ carp_on_warn => $carp_on_warn, logger => $spec });
 1447: }
 1448: 
 1449: # Purpose:   Build the ancestor chain needed for config-file discovery and env merging.
 1450: #            Uses the class's own MRO (DFS or C3) via mro::get_linear_isa, which is
 1451: #            more correct than a hardcoded DFS walk and handles diamond inheritance.
 1452: #            UNIVERSAL is added explicitly because mro::get_linear_isa does not include
 1453: #            it unless it appears in @ISA, yet Object::Configure supports universal.yml.
 1454: # Entry:     $class is a fully-qualified class name that has already been loaded.
 1455: # Exit:      Returns a list in base-first order: (UNIVERSAL, ..., GrandParent, Parent, Class).
 1456: #            Result is memoized in %_chain_cache; mro::get_linear_isa is not re-invoked
 1457: #            for classes already seen in this process.  The cache is valid for the process
 1458: #            lifetime because @ISA is stable after module load in normal Perl programs.
 1459: #            Algorithmic cost: O(N) first call; O(1) amortised on subsequent calls.
 1460: sub _get_inheritance_chain {
 1461: 	my ($class) = @_;
 1462: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1463: 	# Cache hit: return a copy of the stored list (caller may modify the returned list).
 1464: 	return @{ $_chain_cache{$class} } if $_chain_cache{$class};
 1465: 
 1466: 	my @mro = @{ mro::get_linear_isa($class) };

  Mutants (Total: 4, Killed: 4, Survived: 0)
 1467: 
 1468: 	# mro::get_linear_isa returns child-first; reverse to get base-first.
 1469: 	# UNIVERSAL is implicit in Perl's type system but not always in the MRO list,
 1470: 	# so append it when absent to ensure universal.yml is picked up.
 1471: 	# List::Util::any is XS and short-circuits on first match -- faster than grep.
 1472: 	push @mro, 'UNIVERSAL' unless any { $_ eq 'UNIVERSAL' } @mro;
 1473: 
 1474: 	my @chain = reverse @mro;
 1475: 	$_chain_cache{$class} = \@chain;   # store arrayref; return list copy below
 1476: 	return @chain;

					

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

 1477: }

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1478: 
 1479: # Purpose:   Find a config file for a specific ancestor class using the same
 1480: #            naming convention as the primary config file (directory + extension).
 1481: # Entry:     $class is a fully-qualified class name.
 1482: #            $base_config_file is the primary config file path (provides dir and ext).
 1483: #            $config_dirs is an optional arrayref of additional search directories.
 1484: #            Does NOT modify elements of $config_dirs (trailing-slash removal uses a copy).
 1485: # Exit:      Returns a readable file path, or undef if nothing found.
 1486: #            Result (including undef for "not found") is memoized in %_find_cache, keyed
 1487: #            by (class, base_config_file, config_dirs-elements) joined with NUL bytes.
 1488: #            Subsequent calls with identical arguments skip all filesystem probes.
 1489: #            Algorithmic cost: O(extensions) syscalls first call; O(1) amortised.
 1490: sub _find_class_config_file {
 1491: 	my ($class, $base_config_file, $config_dirs) = @_;
 1492: 
 1493: 	# Build a NUL-separated cache key. NUL cannot appear in Linux file paths (the
 1494: 	# pen-test suite confirms this: Perl's -r warns and returns undef for NUL paths).
 1495: 	my $cache_key = join("\0", $class, $base_config_file,
 1496: 		$config_dirs ? @$config_dirs : ());
 1497: 	return $_find_cache{$cache_key} if exists $_find_cache{$cache_key};
 1498: 
 1499: 	my $class_file = lc($class);
 1500: 	$class_file =~ s/::/-/g;
 1501: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1502: 	my ($base_vol, $base_dir_part, $base_name_ext) = File::Spec->splitpath($base_config_file);
 1503: 	my (undef, $base_ext) = $base_name_ext =~ /^(.*?)(\.[^.]+)?$/;
 1504: 	$base_ext //= '';
 1505: 	my $base_dir = File::Spec->catpath($base_vol, $base_dir_part, '');
 1506: 
 1507: 	# Single-exit-point via labeled block so the cache write happens unconditionally.
 1508: 	my $found;
 1509: 	SEARCH: {
 1510: 		# Dedup: when $base_ext is already .yml/.conf/etc the first candidate would
 1511: 		# be a duplicate of a later one, causing a redundant filesystem probe.
 1512: 		my %_seen_pat;
 1513: 		foreach my $pattern (grep { !$_seen_pat{$_}++ } (
 1514: 			File::Spec->catfile($base_dir, "${class_file}${base_ext}"),

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1515: 			File::Spec->catfile($base_dir, "${class_file}.conf"),
 1516: 			File::Spec->catfile($base_dir, "${class_file}.yml"),
 1517: 			File::Spec->catfile($base_dir, "${class_file}.yaml"),
 1518: 			File::Spec->catfile($base_dir, "${class_file}.json"),
 1519: 		)) {
 1520: 			if(-r $pattern && -f $pattern) {
 1521: 				$found = $pattern;
 1522: 				last SEARCH;
 1523: 			}
 1524: 		}
 1525: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1526: 		if($config_dirs && ref($config_dirs) eq 'ARRAY') {
 1527: 			foreach my $dir (@$config_dirs) {
 1528: 				# Use a copy so the caller's arrayref element is never mutated.
 1529: 				(my $clean_dir = $dir) =~ s{/$}{};
 1530: 				my %_seen_dir_pat;
 1531: 				foreach my $pattern (grep { !$_seen_dir_pat{$_}++ } (
 1532: 					"${clean_dir}/${class_file}${base_ext}",

					

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

 1533: 					"${clean_dir}/${class_file}.conf",
 1534: 					"${clean_dir}/${class_file}.yml",
 1535: 					"${clean_dir}/${class_file}.yaml",
 1536: 					"${clean_dir}/${class_file}.json",
 1537: 				)) {
 1538: 					if(-r $pattern && -f $pattern) {
 1539: 						$found = $pattern;
 1540: 						last SEARCH;
 1541: 					}
 1542: 				}
 1543: 			}
 1544: 		}
 1545: 	}
 1546: 
 1547: 	# Cache stores undef for "not found"; callers must use exists, not defined.
 1548: 	return ($_find_cache{$cache_key} = $found);
 1549: }
 1550: 
 1551: # Purpose:   Run as the forked watcher child.  Polls %_config_file_stats and
 1552: #            sends SIGUSR1 to the parent when any file changes.
 1553: # Entry:     $interval >= 1 (seconds). $callback is unused in the child (it runs
 1554: #            in the parent's SIGUSR1 handler).
 1555: # Exit:      Never returns; terminates via SIGTERM/SIGINT handlers.
 1556: # Side:      Modifies %_config_file_stats entries in the child's address space only.
 1557: sub _run_config_watcher {
●1558 → 1571 → 0 1558: 	my ($interval, $callback) = @_;
 1559: 
 1560: 	# SECURITY (S5): re-validate $interval in the child process.
 1561: 	# If the parent's fork() fires before enable_hot_reload() applies its own guard
 1562: 	# (race) or state is corrupted between fork and here, sleep(0) or sleep(-1) would
 1563: 	# cause a busy-loop that saturates the CPU.  int() also prevents floating-point
 1564: 	# values like 0.001 from reaching the kernel as a near-zero sleep.
 1565: 	$interval = int($interval // $DEFAULT_INTERVAL);
 1566: 	$interval = $DEFAULT_INTERVAL unless $interval > 0;
 1567: 
 1568: 	local $SIG{TERM} = sub { exit 0 };
 1569: 	local $SIG{INT}  = sub { exit 0 };
 1570: 
 1571: 	while(1) {
 1572: 		sleep($interval);
 1573: 
 1574: 		my $changes_detected = 0;

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1576: 		foreach my $config_file (keys %_config_file_stats) {
 1577: 			if(-f $config_file) {
 1578: 				my $current_stat = stat($config_file);
 1579: 				my $stored_stat  = $_config_file_stats{$config_file};
 1580: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1581: 				if(!$stored_stat || $current_stat->mtime > $stored_stat->mtime) {
 1582: 					$_config_file_stats{$config_file} = $current_stat;
 1583: 					$changes_detected = 1;
 1584: 				}
 1585: 			} else {
 1586: 				delete $_config_file_stats{$config_file};
 1587: 				$changes_detected = 1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1588: 			}
 1589: 		}
 1590: 
 1591: 		if($changes_detected && $^O ne $OS_WINDOWS) {
 1592: 			if(my $parent_pid = getppid()) {
 1593: 				kill('USR1', $parent_pid);
 1594: 			}
 1595: 		}
 1596: 	}
 1597: }
 1598: 
 1599: # Purpose:   Reload a single object's configuration from disk and update its fields.
 1600: #            Private properties (prefix '_') are intentionally skipped to avoid
 1601: #            clobbering internal bookkeeping set at construction time.
 1602: # Entry:     $obj must be a blessed reference with a {_config_file} or {_config_files} key.
 1603: # Exit:      Returns nothing; updates $obj in-place.
 1604: # Side:      Reads from disk. Calls $obj->_on_config_reload if the method exists.
 1605: sub _reload_object_config {
●1606 → 1616 → 1627 1606: 	my $obj = $_[0];
 1607: 
 1608: 	return unless blessed($obj);
 1609: 
 1610: 	my $class          = ref($obj);
 1611: 	my $original_class = $class;
 1612: 	$class =~ s/::/__/g;
 1613: 
 1614: 	# Prefer the most-specific (last) file from the full list; fall back to scalar key
 1615: 	my $config_file;
 1616: 	if($obj->{_config_files} && ref($obj->{_config_files}) eq 'ARRAY' && @{ $obj->{_config_files} }) {
 1617: 		$config_file = $obj->{_config_files}[-1];
 1618: 	} else {
 1619: 		$config_file = $obj->{_config_file} || $obj->{config_file};
 1620: 	}
 1621: 
 1622: 	# SECURITY (S1 — path traversal): an attacker who modifies $obj->{_config_file}
 1623: 	# (e.g., via a deserialization gadget or a malicious config merge) can redirect
 1624: 	# hot-reload to read arbitrary system files.  Reject paths with ".." segments here
 1625: 	# so that even a corrupted object cannot force a traversal read.
 1626: 	# Must come BEFORE the -f check so traversal paths for non-existent files are also rejected.
●1627 → 1627 → 1633 1627: 	if($config_file && $config_file =~ $RE_PATH_TRAVERSAL) {
 1628: 		carp(__PACKAGE__, ': _reload_object_config: refusing path with traversal sequences: ',
 1629: 			$config_file);
 1630: 		return;
 1631: 	}
 1632: 
●1633 → 1640 → 1674 1633: 	return unless $config_file && -f $config_file;
 1634: 
 1635: 	my $config = Config::Abstraction->new(
 1636: 		config_file => $config_file,
 1637: 		env_prefix  => "${class}__"
 1638: 	);
 1639: 
 1640: 	if($config) {
 1641: 		my $new_params = $config->merge_defaults(
 1642: 			defaults => {},
 1643: 			section  => $class,
 1644: 			merge    => 1,
 1645: 			deep     => 1
 1646: 		);
 1647: 
 1648: 		foreach my $key (keys %$new_params) {
 1649: 			next if $key =~ /^_/;
 1650: 
 1651: 			if($key eq 'logger') {
 1652: 				# Only the exact 'logger' key triggers logger reconstruction.
 1653: 				# Keys like 'logger.file' are flat config values, not logger specs.
 1654: 				# Guard: assign directly for undef (no logger) or literal 'NULL'.
 1655: 				# Premise 1: _build_logger handles every other spec type.
 1656: 				# Premise 2: undef/NULL need no construction. Conclusion: rebuild only otherwise.
 1657: 				my $val = $new_params->{$key};
 1658: 				if(!defined($val) || (!ref($val) && $val eq $LOGGER_NULL)) {
 1659: 					$obj->{$key} = $val;
 1660: 				} else {
 1661: 					_reconfigure_logger($obj, $key, $val);
 1662: 				}
 1663: 			} else {
 1664: 				$obj->{$key} = $new_params->{$key};
 1665: 			}
 1666: 		}
 1667: 
 1668: 		$obj->_on_config_reload($new_params) if $obj->can('_on_config_reload');
 1669: 
 1670: 		$obj->{logger}->info("Configuration reloaded for $original_class")
 1671: 			if $obj->{logger} && $obj->{logger}->can('info');
 1672: 	}
 1673: 
 1674: 	return;
 1675: }
 1676: 
 1677: # Purpose:   Replace the logger on an already-constructed object with one
 1678: #            built from a new config value (typically a YAML hashref).
 1679: #            Delegates to _build_logger so logger-creation logic lives in one place.
 1680: # Entry:     $obj is a blessed hashref. $key is the hash key to update (usually 'logger').
 1681: #            $logger_config is the new spec from the config file.
 1682: # Exit:      Returns nothing; updates $obj->{$key} in-place.
 1683: # Side:      May allocate a new Log::Abstraction instance.
 1684: sub _reconfigure_logger
 1685: {
 1686: 	my ($obj, $key, $logger_config) = @_;
 1687: 	my $carp_on_warn = $obj->{carp_on_warn} || 0;
 1688: 	$obj->{$key} = _build_logger($logger_config, $carp_on_warn);
 1689: 	return;
 1690: }
 1691: 
 1692: # Purpose:   Right-precedence deep merge of two hash references.
 1693: #            Scalar/arrayref values in $overlay replace those in $base entirely;
 1694: #            nested hashrefs are merged recursively.
 1695: # Entry:     Both args should be hashrefs (or undef/non-ref, handled gracefully).
 1696: # Exit:      Returns a new hashref; neither input is modified.
 1697: sub _deep_merge {
●1698 → 1705 → 1713 1698: 	my ($base, $overlay) = @_;
 1699: 
 1700: 	return $overlay unless ref($base)    eq 'HASH';
 1701: 	return $overlay unless ref($overlay) eq 'HASH';
 1702: 
 1703: 	my $result = { %$base };
 1704: 
 1705: 	foreach my $key (keys %$overlay) {
 1706: 		if(ref($overlay->{$key}) eq 'HASH' && ref($result->{$key}) eq 'HASH') {
 1707: 			$result->{$key} = _deep_merge($result->{$key}, $overlay->{$key});
 1708: 		} else {
 1709: 			$result->{$key} = $overlay->{$key};
 1710: 		}
 1711: 	}
 1712: 
 1713: 	return $result;
 1714: }
 1715: 
 1716: # Clean up the watcher child and restore signal state on interpreter exit.
 1717: END {
 1718: 	disable_hot_reload();
 1719: 	restore_signal_handlers();
 1720: }
 1721: 
 1722: =head1 SEE ALSO
 1723: 
 1724: =over 4
 1725: 
 1726: =item * L<Config::Abstraction>
 1727: 
 1728: =item * L<Log::Abstraction>
 1729: 
 1730: =item * L<Test Dashboard|https://nigelhorne.github.io/Object-Configure/coverage/>
 1731: 
 1732: =back
 1733: 
 1734: =head1 LIMITATIONS
 1735: 
 1736: =over 4
 1737: 
 1738: =item * B<Global singleton state.> C<%_object_registry>, C<%_config_watchers>, and
 1739: C<%_config_file_stats> are package globals.  Two independent subsystems in the same
 1740: process share one hot-reload registry and one SIGUSR1 handler.  There is no
 1741: instance-level isolation.  A proper fix would wrap state in an object and allow
 1742: multiple independent C<Object::Configure> instances, but that would break the
 1743: existing constructor-call API (C<configure($class, \%params)>).
 1744: 
 1745: =item * B<Hot reload is Unix-only.> SIGUSR1 does not exist on Windows.
 1746: All signal-related paths are guarded with C<$^O ne 'MSWin32'>, so the module
 1747: loads on Windows but silently skips hot-reload registration.
 1748: 
 1749: =item * B<configure() is a God function.> At ~120 lines it handles arg validation,
 1750: config-file discovery, MRO walking, multi-file merging, env-var merging, logger
 1751: creation, and hot-reload bookkeeping.  Future versions should decompose this into
 1752: smaller, independently testable units.
 1753: 
 1754: =item * B<_deep_merge reimplements CPAN.> L<Hash::Merge::Simple> or L<Hash::Merge>
 1755: provide tested, feature-complete deep merge.  The internal C<_deep_merge> is 15
 1756: lines and correct for the current use, but does not handle arrayrefs (they are
 1757: replaced wholesale, not merged).  If array-merge semantics are ever needed, switch
 1758: to a CPAN module.
 1759: 
 1760: =item * B<No encapsulation enforcement.> Private helpers (C<_build_logger>,
 1761: C<_get_inheritance_chain>, etc.) are accessible to any caller.  L<Sub::Private>
 1762: (enforce mode) would make accidental external use a compile-time error.  It is not
 1763: added here to avoid a smoker dependency on a less-common module.
 1764: 
 1765: =item * B<configure() signature is positional, instantiate() is named.>  The two
 1766: public constructors have inconsistent calling conventions.  Normalising them to named
 1767: args would require a deprecation cycle.
 1768: 
 1769: =item * B<mro::get_linear_isa and UNIVERSAL.>  Perl's C<mro::get_linear_isa> does
 1770: not include C<UNIVERSAL> in its output unless C<UNIVERSAL> appears explicitly in
 1771: C<@ISA>.  This module appends C<UNIVERSAL> manually so that C<universal.yml> is
 1772: always discovered.  If a future Perl version changes this behaviour the guard
 1773: (C<grep { $_ eq 'UNIVERSAL' }>) remains correct.
 1774: 
 1775: =back
 1776: 
 1777: =head1 Formal Specification
 1778: 
 1779: =head2 configure
 1780: 
 1781:     configure: Class x Params -> ConfigHash
 1782: 
 1783:     Given:
 1784:     - C: set of all class names
 1785:     - P: set of all parameter hashes
 1786:     - F: set of all file paths
 1787:     - H: set of all configuration hashes
 1788: 
 1789:     State:
 1790:     - ConfigFiles: F -> H (maps file paths to configuration content)
 1791:     - EnvVars: String -> String (environment variables)
 1792:     - InheritanceChain: C -> seq C (ordered sequence of ancestor classes)
 1793: 
 1794:     Pre-condition:
 1795:     forall class in C, params in P:
 1796:         class != empty
 1797:         (params.config_file != empty =>
 1798:             (exists dir in params.config_dirs: readable(dir/params.config_file))
 1799:             OR readable(params.config_file))
 1800: 
 1801:     Post-condition:
 1802:     forall result in H:
 1803:         result = params
 1804:                  (+) (merge f in InheritanceConfigFiles(class): ConfigFiles(f))
 1805:                  (+) (merge v in RelevantEnvVars(class): v)
 1806:         result.logger in Log::Abstraction
 1807:         (forall k in dom params:
 1808:             (params(k) in CodeRef OR blessed(params(k))) => result(k) = params(k))
 1809: 
 1810:     where (+) denotes hash merge with right-precedence
 1811: 
 1812: =head2 instantiate
 1813: 
 1814:     instantiate: Params -> Object
 1815: 
 1816:     Given:
 1817:     - P: set of all parameter hashes
 1818:     - C: set of all class names
 1819:     - O: set of all objects
 1820: 
 1821:     Pre-condition:
 1822:     forall params in P:
 1823:         params.class in C
 1824:         params.class.can('new')
 1825: 
 1826:     Post-condition:
 1827:     forall result in O:
 1828:         exists config in H:
 1829:             config = configure(params.class, params)
 1830:             result = params.class.new(config)
 1831:             blessed(result) = params.class
 1832:             (config._config_file != empty =>
 1833:                 result in _object_registry(params.class))
 1834: 
 1835: =head2 enable_hot_reload
 1836: 
 1837:     enable_hot_reload: Interval x Callback -> PID
 1838: 
 1839:     Given:
 1840:     - I: set of positive integers (intervals in seconds)
 1841:     - CB: set of code references
 1842:     - PID: set of process identifiers
 1843: 
 1844:     State:
 1845:     - _config_watchers: {pid: PID, callback: CB}
 1846:     - _config_file_stats: F -> Stat
 1847: 
 1848:     Pre-condition:
 1849:     forall interval in I, callback in CB union {empty}:
 1850:         interval >= 1
 1851:         _config_watchers = empty
 1852:         OS != 'MSWin32'
 1853: 
 1854:     Post-condition:
 1855:     forall result in PID:
 1856:         result > 0
 1857:         _config_watchers.pid = result
 1858:         _config_watchers.callback = callback
 1859:         (forall t in Time:
 1860:             (t mod interval = 0) =>
 1861:                 (exists f in dom _config_file_stats:
 1862:                     mtime(f) > _config_file_stats(f).mtime =>
 1863:                         send_signal(SIGUSR1, parent_process)))
 1864: 
 1865: =head2 disable_hot_reload
 1866: 
 1867:     disable_hot_reload: () -> ()
 1868: 
 1869:     State:
 1870:     - _config_watchers: {pid: PID, callback: CB}
 1871: 
 1872:     Pre-condition:
 1873:     true
 1874: 
 1875:     Post-condition:
 1876:     _config_watchers = empty
 1877:     (forall p in PID:
 1878:         p = _config_watchers.pid@pre =>
 1879:             NOT alive(p))
 1880: 
 1881: =head2 reload_config
 1882: 
 1883:     reload_config: () -> N
 1884: 
 1885:     State:
 1886:     - _object_registry: C -> seq ObjectRef
 1887:     - ConfigFiles: F -> H
 1888: 
 1889:     Pre-condition:
 1890:     true
 1891: 
 1892:     Post-condition:
 1893:     forall result in N:
 1894:         result = |{obj in flatten(ran _object_registry) |
 1895:                    obj != empty
 1896:                    obj._config_file in dom ConfigFiles}|
 1897:         (forall obj in flatten(ran _object_registry):
 1898:             obj != empty AND obj._config_file in dom ConfigFiles =>
 1899:                 (forall k in dom ConfigFiles(obj._config_file):
 1900:                     k NOT in PrivateKeys =>
 1901:                         obj(k)@post = ConfigFiles(obj._config_file)(k)))
 1902: 
 1903:     where PrivateKeys = {k | k starts with '_'}
 1904: 
 1905: =head2 register_object
 1906: 
 1907:     register_object: C x O -> ()
 1908: 
 1909:     Given:
 1910:     - C: set of class names
 1911:     - O: set of blessed objects
 1912:     - OR: C -> seq WeakRef(O) (object registry)
 1913: 
 1914:     State:
 1915:     - _object_registry: OR
 1916:     - _original_usr1_handler: SignalHandler union {empty}
 1917:     - $SIG{USR1}: SignalHandler
 1918: 
 1919:     Pre-condition:
 1920:     forall class in C, obj in O:
 1921:         class != empty
 1922:         obj != empty
 1923:         blessed(obj) != empty
 1924: 
 1925:     Post-condition:
 1926:     forall class in C, obj in O:
 1927:         exists ref in _object_registry(class):
 1928:             weak(ref) = obj
 1929:         (_original_usr1_handler = empty@pre =>
 1930:             (_original_usr1_handler@post = $SIG{USR1}@pre
 1931:              $SIG{USR1}@post = reload_config_handler))
 1932: 
 1933: =head2 restore_signal_handlers
 1934: 
 1935:     restore_signal_handlers: () -> ()
 1936: 
 1937:     State:
 1938:     - _original_usr1_handler: SignalHandler union {empty}
 1939:     - $SIG{USR1}: SignalHandler
 1940: 
 1941:     Pre-condition:
 1942:     true
 1943: 
 1944:     Post-condition:
 1945:     $SIG{USR1}@post = _original_usr1_handler@pre
 1946:     _original_usr1_handler@post = empty
 1947: 
 1948: =head2 get_signal_handler_info
 1949: 
 1950:     get_signal_handler_info: () -> InfoHash
 1951: 
 1952:     Given:
 1953:     - IH: set of all info hashes
 1954: 
 1955:     State:
 1956:     - _original_usr1_handler: SignalHandler union {empty}
 1957:     - $SIG{USR1}: SignalHandler union {empty}
 1958:     - _config_watchers: {pid: PID, callback: CB}
 1959: 
 1960:     Pre-condition:
 1961:     true
 1962: 
 1963:     Post-condition:
 1964:     forall result in IH:
 1965:         result.original_usr1 = _original_usr1_handler
 1966:         result.current_usr1 = $SIG{USR1}
 1967:         result.hot_reload_active = (_original_usr1_handler != empty)
 1968:         result.watcher_pid = _config_watchers.pid
 1969: 
 1970: =head1 SUPPORT
 1971: 
 1972: Please report bugs and feature requests at:
 1973: 
 1974: =over 4
 1975: 
 1976: =item * RT (CPAN bug tracker): L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Object-Configure>
 1977: 
 1978: or by e-mail: C<bug-object-configure at rt.cpan.org>
 1979: 
 1980: =item * GitHub issues: L<https://github.com/nigelhorne/Object-Configure/issues>
 1981: 
 1982: =back
 1983: 
 1984: You will be notified automatically of progress on your report.
 1985: 
 1986:     perldoc Object::Configure
 1987: 
 1988: =head1 LICENCE AND COPYRIGHT
 1989: 
 1990: Copyright 2025-2026 Nigel Horne.
 1991: 
 1992: Usage is subject to GPL2 licence terms.
 1993: If you use it, please let me know.
 1994: 
 1995: =cut
 1996: 
 1997: 1;