lib/Class/Simple/Readonly/Cached.pm

        start → end → jump
        

    1: package Class::Simple::Readonly::Cached;
    2: 
    3: use strict;
    4: use warnings;
    5: 
    6: use Carp;
    7: use List::Util   qw(none);
    8: use Scalar::Util qw(blessed);
    9: use Class::Simple;
   10: use Data::Reuse;
   11: use Params::Get 0.15;
   12: use Readonly;
   13: 
   14: # Private-sub enforcement: _name subs croak if called from outside this
   15: # package.  Sub::Private respects $ENV{HARNESS_ACTIVE}, so white-box tests
   16: # (run under prove / make test) are automatically exempt.
   17: BEGIN { $Sub::Private::config{mode} = 'enforce' }
   18: use Sub::Private 0.05;
   19: 
   20: # @ISA is intentionally EMPTY.
   21: #
   22: # Class::Simple creates permanent named methods in its own namespace the
   23: # first time any accessor is called (e.g. the first $obj->val() call
   24: # installs a real Class::Simple::val sub).  If we set @ISA = ('Class::Simple'),
   25: # those installed methods would be found by Perl's normal method lookup on
   26: # CSRC objects and would bypass our AUTOLOAD -- breaking the cache entirely.
   27: #
   28: # Keeping @ISA empty ensures every method call on a CSRC object is handled
   29: # by our AUTOLOAD.  The isa() and can() overrides below restore correct
   30: # UNIVERSAL behaviour for isa-of-Class::Simple checks.
   31: our @ISA = ();
   32: 
   33: # Package-level registry mapping inner-object refs (stringified) to a
   34: # record of { object => $wrapper, file => ..., line => ... }.
   35: # Used to detect and warn about double-wrapping.
   36: our %cached;
   37: 
   38: # Stored in the cache wherever a method returned undef or an empty list,
   39: # so we can distinguish "not yet cached" from "cached-undef".
   40: Readonly::Scalar my $UNDEF_SENTINEL => __PACKAGE__ . '>UNDEF<';
   41: 
   42: # CHI expiry value meaning "never expire this entry".
   43: Readonly::Scalar my $CHI_NEVER => 'never';
   44: 
   45: =head1 NAME
   46: 
   47: Class::Simple::Readonly::Cached - cache messages to an object
   48: 
   49: =head1 VERSION
   50: 
   51: Version 0.13
   52: 
   53: =cut
   54: 
   55: our $VERSION = '0.13';
   56: 
   57: =head1 SYNOPSIS
   58: 
   59: A caching decorator for L<Class::Simple>-based (and arbitrary) objects.
   60: 
   61: It is up to the caller to maintain the cache if the object comes out of
   62: sync with the cache, for example by changing its state.
   63: 
   64:     use Class::Simple::Readonly::Cached;
   65: 
   66:     my $obj = Class::Simple->new();
   67:     $obj->val('foo');
   68:     my $cached = Class::Simple::Readonly::Cached->new(
   69:         object => $obj,
   70:         cache  => {},
   71:     );
   72: 
   73:     my $val  = $cached->val();   # calls the real object
   74:     my $val2 = $cached->val();   # served from cache
   75: 
   76:     $val = $cached->val(a => 'b');   # args form part of the cache key
   77: 
   78: Note that when the object goes out of scope (DESTROY is called), the
   79: cache is cleared automatically.
   80: 
   81: =head1 DESCRIPTION
   82: 
   83: Wraps any Perl object in a transparent caching layer.  Every method call
   84: is intercepted via AUTOLOAD; on the first call (a I<miss>) the result is
   85: stored in the cache and returned.  Subsequent identical calls (same method
   86: name, same argument list) are I<hits> and are served directly from the
   87: cache without touching the inner object.
   88: 
   89: Two cache backends are supported: a plain hash reference (fast, in-process,
   90: no expiry) and any CHI-compatible object (persistent, shared, with expiry).
   91: 
   92: =head1 SUBROUTINES/METHODS
   93: 
   94: =head2 new
   95: 
   96: Construct a caching proxy around any Perl object.
   97: 
   98: =head3 Arguments
   99: 
  100: =over 4
  101: 
  102: =item C<cache> (mandatory)
  103: 
  104: Either a plain hash reference (C<{}>) or a CHI-compatible object that
  105: implements C<get()>, C<set()>, and C<purge()>.
  106: 
  107: =item C<object> (optional)
  108: 
  109: The object to wrap.  Defaults to a bare L<Class::Simple> instance.
  110: Must be a reference; a plain scalar argument causes a C<carp> and an
  111: C<undef> return.  Wrapping an already-wrapped
  112: C<Class::Simple::Readonly::Cached> object returns the existing wrapper
  113: with a warning.
  114: 
  115: =item C<quiet> (optional, boolean)
  116: 
  117: Suppress the double-wrap warning when non-zero.
  118: 
  119: =back
  120: 
  121: =head3 Returns
  122: 
  123: A C<Class::Simple::Readonly::Cached> object, or C<undef> on invalid
  124: C<object>.  Croaks on invalid C<cache>.
  125: 
  126: =head3 EXAMPLE
  127: 
  128:     use CHI;
  129:     use Class::Simple::Readonly::Cached;
  130: 
  131:     # --- Hash-ref cache (in-process, no expiry) ---
  132:     my $obj    = My::Expensive->new();
  133:     my $cached = Class::Simple::Readonly::Cached->new(
  134:         object => $obj,
  135:         cache  => {},
  136:     );
  137:     my $result  = $cached->compute();   # calls the real object
  138:     my $result2 = $cached->compute();   # from cache -- object not called
  139: 
  140:     # --- CHI cache (persistent, file-based) ---
  141:     use File::Temp qw(tempdir);
  142:     my $chi = CHI->new(driver => 'File', root_dir => tempdir(CLEANUP => 1));
  143:     my $cached2 = Class::Simple::Readonly::Cached->new(
  144:         object => $obj,
  145:         cache  => $chi,
  146:     );
  147: 
  148:     # --- Clone an existing wrapper ---
  149:     my $clone = $cached->new();   # shares the same inner object and cache
  150: 
  151: =head3 API SPECIFICATION
  152: 
  153:     # Input
  154:     {
  155:         cache  => { type => ['hashref', 'object'], required => 1  },
  156:         object => { type => 'ref',                 optional => 1  },
  157:         quiet  => { type => 'bool',                optional => 1  },
  158:     }
  159: 
  160:     # Output
  161:     { type => 'object', class => 'Class::Simple::Readonly::Cached',
  162:       optional => 1 }
  163: 
  164: =head3 MESSAGES
  165: 
  166:     Message                                                 Meaning                              Resolution
  167:     -------                                                 -------                              ----------
  168:     Cache must be ref to HASH or object                     cache is not a hashref or blessed    Pass \%hash or a CHI object.
  169:                                                             object
  170:     Cache object must implement get(), set(), and purge()   blessed cache lacks required API      Use a CHI-compatible object.
  171:     $object must be a reference, not a scalar               object is a plain string             Pass a blessed reference.
  172:     warning: $object is already a cached object             wrapping an already-wrapped object   Reuse the returned wrapper.
  173:     $object is already cached at LINE of FILE               double-wrap detected                 Reuse the existing wrapper;
  174:                                                                                                  set quiet => 1 to silence.
  175: 
  176: =head3 PSEUDOCODE
  177: 
  178:     1.  If class is undef:           carp and return undef   (::new() misuse)
  179:     2.  If class is blessed:         merge params into a clone and return
  180:     3.  Validate cache:              croak if not a hashref or CHI-compatible object
  181:     4.  Validate object:             carp+return if scalar; return existing
  182:                                      wrapper if already __PACKAGE__
  183:     5.  Create inner object:         Class::Simple->new(non-wrapper params)
  184:                                      unless object was supplied
  185:     6.  Check double-wrap registry:  if object in %cached, carp and return
  186:                                      existing wrapper (unless quiet)
  187:     7.  Bless and register:          bless $params, $class; set _class = $class;
  188:                                      call _build_cache_accessors to install
  189:                                      _get/_set coderefs and _cache_is_hash;
  190:                                      store in %cached with caller file and line
  191:     8.  Return $self
  192: 
  193: =cut
  194: 
  195: sub new
  196: {
●197 → 200 → 206  197: 	my $class = shift;
  198: 
  199: 	# Guard against the common mistake of calling ::new() instead of ->new().
  200: 	if(!defined($class)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  201: 		Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate');
  202: 		return;
  203: 	}
  204: 
  205: 	# Object invocation: clone the existing wrapper, merging any new params.
●206 → 206 → 217  206: 	if(blessed($class)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  207: 		my $params = Params::Get::get_params(undef, \@_) // {};
  208: 		my $clone  = bless { %{$class}, %{$params} }, ref($class);
  209: 		# If the caller overrides the cache, rebuild the pre-computed dispatch
  210: 		# closures so they target the new backend, not the original one.
  211: 		if(exists $params->{cache}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  212: 			_build_cache_accessors($clone);
  213: 		}
  214: 		return $clone;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  215: 	}
  216: 
●217 → 220 → 231  217: 	my $params = Params::Get::get_params('cache', @_);
  218: 
  219: 	# Validate the cache argument before doing anything else.
  220: 	if(blessed($params->{cache})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  221: 		unless($params->{cache}->can('get')
  Mutants (Total: 1, Killed: 1, Survived: 0)
  222: 			&& $params->{cache}->can('set')
  223: 			&& $params->{cache}->can('purge'))
  224: 		{
  225: 			Carp::croak("$class: Cache object must implement get(), set(), and purge()");
  226: 		}
  227: 	} elsif(ref($params->{cache}) ne 'HASH') {
  228: 		Carp::croak("$class: Cache must be ref to HASH or object");
  229: 	}
  230: 
●231 → 231 → 253  231: 	if(defined($params->{object})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  232: 		if(!ref($params->{object})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  233: 			Carp::carp(__PACKAGE__ . ': $object must be a reference, not a scalar');
  234: 			return;
  235: 		}
  236: 		if(ref($params->{object}) eq __PACKAGE__) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  237: 			# Silently returning the existing wrapper is safer than building
  238: 			# a second layer that would double-count misses/hits.
  239: 			Carp::carp(__PACKAGE__ . ': warning: $object is already a cached object');
  240: 			return $params->{object};
  Mutants (Total: 2, Killed: 2, Survived: 0)
  241: 		}
  242: 	} else {
  243: 		# No inner object supplied: create a bare Class::Simple instance.
  244: 		# Forward only non-wrapper keys so that 'cache' and 'quiet' do not
  245: 		# bleed into the inner object's attribute hash.
  246: 		my %inner = %{$params};
  247: 		delete @inner{qw(cache quiet)};   # O(1) hash-slice delete, no temp list
  248: 		$params->{object} = Class::Simple->new(%inner);
  249: 	}
  250: 
  251: 	# Warn if this inner object is already wrapped in a cache -- returning the
  252: 	# existing wrapper prevents hidden double-caching with stale hit counts.
●253 → 253 → 261  253: 	if(my $existing = $cached{$params->{object}}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  254: 		unless($params->{quiet}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  255: 			Carp::carp(__PACKAGE__ . ' $object is already cached at '
  256: 				. $existing->{line} . ' of ' . $existing->{file});
  257: 		}
  258: 		return $existing->{object};
  Mutants (Total: 2, Killed: 2, Survived: 0)
  259: 	}
  260: 
  261: 	my $self = bless $params, $class;
  262: 
  263: 	# Pre-compute values used on every AUTOLOAD dispatch.
  264: 	$self->{_class} = $class;
  265: 	_build_cache_accessors($self);
  266: 
  267: 	my (undef, $file, $line) = caller(0);   # destructure: only fields 1 and 2 needed
  268: 	$cached{$self->{object}} = {
  269: 		object => $self,
  270: 		file   => $file,
  271: 		line   => $line,
  272: 	};
  273: 
  274: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  275: }
  276: 
  277: =head2 object
  278: 
  279: Return the inner (wrapped) object.
  280: 
  281: =head3 Returns
  282: 
  283: The blessed reference that was passed as C<object> to C<new()>.
  284: 
  285: =head3 EXAMPLE
  286: 
  287:     # Bypass the cache to mutate state directly.
  288:     $cached->object()->reset();
  289: 
  290: =head3 API SPECIFICATION
  291: 
  292:     # Input  none
  293:     # Output { type => 'object' }
  294: 
  295: =head3 MESSAGES
  296: 
  297:     (none)
  298: 
  299: =cut
  300: 
  301: sub object
  302: {
  303: 	return $_[0]->{object};
  Mutants (Total: 2, Killed: 2, Survived: 0)
  304: }
  305: 
  306: =head2 state
  307: 
  308: Return a snapshot of cache hit and miss counts per cache key.
  309: Primarily useful for performance profiling and white-box tests.
  310: 
  311: =head3 Returns
  312: 
  313: A hash reference:
  314: 
  315: =over 4
  316: 
  317: =item C<hits>
  318: 
  319: Hash reference mapping each cache key to the number of times the
  320: result was served from cache.  C<undef> until the first hit.
  321: 
  322: =item C<misses>
  323: 
  324: Hash reference mapping each cache key to the number of times the
  325: inner object was actually invoked.  C<undef> until the first miss.
  326: 
  327: =back
  328: 
  329: =head3 EXAMPLE
  330: 
  331:     my $s = $cached->state();
  332:     my $hits   = do { my $n=0; $n += $_ for values %{$s->{hits}   // {}}; $n };
  333:     my $misses = do { my $n=0; $n += $_ for values %{$s->{misses} // {}}; $n };
  334:     printf "Hit rate: %.0f%%\n", 100 * $hits / ($hits + $misses) if $hits + $misses;
  335: 
  336: =head3 API SPECIFICATION
  337: 
  338:     # Input  None
  339:     # Output { type => 'hashref',
  340:     #          keys => { hits   => 'hashref|undef',
  341:     #                    misses => 'hashref|undef' } }
  342: 
  343: =head3 MESSAGES
  344: 
  345:     (none)
  346: 
  347: =cut
  348: 
  349: sub state
  350: {
  351: 	my $self = shift;
  352: 	return { hits => $self->{_hits}, misses => $self->{_misses} };
  353: }
  354: 
  355: =head2 can
  356: 
  357: Report whether the inner object (or this class) can respond to a
  358: given method.  Overrides C<UNIVERSAL::can> to account for the
  359: decorator pattern.
  360: 
  361: =head3 Returns
  362: 
  363: A code reference if the method exists, C<undef> otherwise.
  364: 
  365: =head3 EXAMPLE
  366: 
  367:     my $code = $cached->can('compute');
  368:     $code->($cached) if $code;
  369: 
  370: =head3 API SPECIFICATION
  371: 
  372:     # Input  { self   => { type => 'object|string' },
  373:     #          method => { type => 'string' } }
  374:     # Output { type => 'coderef|undef' }
  375: 
  376: =head3 MESSAGES
  377: 
  378:     (none)
  379: 
  380: =cut
  381: 
  382: sub can
  383: {
  384: 	my ($self, $method) = @_;
  385: 
  386: 	# Premise: 'new' belongs to the wrapper, not to the inner object.
  387: 	# Conclusion: short-circuit before any object check is needed.
  388: 	return \&new if $method eq 'new';
  Mutants (Total: 2, Killed: 2, Survived: 0)
  389: 
  390: 	# Premise: if $self is not a ref (class-level call) OR the inner object
  391: 	#          has been freed (global destruction), there is no object to delegate to.
  392: 	# Conclusion: fall back to UNIVERSAL for what this package directly provides.
  393: 	return $self->SUPER::can($method)
  394: 		if !ref($self) || !ref($self->{object});
  395: 
  396: 	# Premise: $self->{object} is alive and is a valid reference (Invariant I4).
  397: 	# Conclusion: delegate to the inner object first; fall back to UNIVERSAL.
  398: 	return $self->{object}->can($method) // $self->SUPER::can($method);
  Mutants (Total: 2, Killed: 2, Survived: 0)
  399: }
  400: 
  401: =head2 isa
  402: 
  403: Test class membership, delegating to the inner object's class
  404: hierarchy when needed.  Overrides C<UNIVERSAL::isa> to support the
  405: transparent decorator pattern.
  406: 
  407: =head3 Returns
  408: 
  409: True if the wrapper or its inner object is-a C<$class>.
  410: 
  411: =head3 EXAMPLE
  412: 
  413:     $cached->isa('My::Domain::Object');   # true if inner object is
  414: 
  415: =head3 API SPECIFICATION
  416: 
  417:     # Input  { self  => { type => 'object|string' },
  418:     #          class => { type => 'string' } }
  419:     # Output { type => 'bool' }
  420: 
  421: =head3 MESSAGES
  422: 
  423:     (none)
  424: 
  425: =cut
  426: 
  427: sub isa
  428: {
  429: 	my ($self, $class) = @_;
  430: 
  431: 	# Fast-path guards that do not require examining the inner object.
  432: 	#
  433: 	# Premise 1: $class eq ref($self) is logically subsumed by SUPER::isa,
  434: 	#   which also returns true for an exact class match -- but the string
  435: 	#   equality check is O(1) and avoids the UNIVERSAL dispatch overhead.
  436: 	#   Keeping it as a fast path is a valid micro-optimisation, NOT dead code.
  437: 	# Premise 2: $class eq __PACKAGE__ handles the subclass case:
  438: 	#   a My::Cached instance asked isa('Class::Simple::Readonly::Cached').
  439: 	# Premise 3: $class eq 'Class::Simple' is required because @ISA is
  440: 	#   intentionally empty; SUPER::isa would return false without this.
  441: 	# Premise 4: SUPER::isa covers the full UNIVERSAL hierarchy.
  442: 	# Conclusion: any of these makes the wrapper itself a member of $class.
  443: 	return 1 if $class eq ref($self)
  Mutants (Total: 2, Killed: 2, Survived: 0)
  444: 	          || $class eq __PACKAGE__
  445: 	          || $class eq 'Class::Simple'
  446: 	          || $self->SUPER::isa($class);
  447: 
  448: 	# Premise: none of the wrapper-level checks matched.
  449: 	# Premise: $self->{object} may be freed during global destruction; guard
  450: 	#          with ref() before delegating.
  451: 	# Conclusion: isa is true iff the inner object claims it.
  452: 	return !!(ref($self) && ref($self->{object}) && $self->{object}->isa($class));
  Mutants (Total: 2, Killed: 2, Survived: 0)
  453: }
  454: 
  455: # _build_cache_accessors -- install backend-specific _get/_set closures on $self.
  456: # The cache backend (HASH vs CHI) is fixed for a wrapper's lifetime.
  457: #              Deciding which branch to take on every AUTOLOAD call via ref($cache)
  458: #              plus a Sub::Private caller() check is unnecessary overhead.  Instead
  459: #              we close over the bare cache reference once at construction time and
  460: #              expose two named slots (_get/_set) that AUTOLOAD calls directly.
  461: #              The closures capture the cache ref as a lexical -- no reference back
  462: #              to $self, so no circular-reference hazard.
  463: # Entry:       $self is a fully-blessed wrapper with {cache} already set.
  464: # Exit:        $self->{_get}, $self->{_set}, and $self->{_cache_is_hash} are set.
  465: # Side-effects: Mutates $self.
  466: sub _build_cache_accessors :Private
  467: {
●468 → 470 → 0  468: 	my ($self) = @_;
  469: 	my $c = $self->{cache};                  # captured by the closures below
  470: 	if(ref($c) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  471: 		$self->{_cache_is_hash} = 1;
  472: 		$self->{_get}           = sub { $c->{$_[0]}                       };
  473: 		$self->{_set}           = sub { $c->{$_[0]} = $_[1]               };
  474: 	} else {
  475: 		$self->{_cache_is_hash} = 0;
  476: 		$self->{_get}           = sub { $c->get($_[0])                     };
  477: 		$self->{_set}           = sub { $c->set($_[0], $_[1], $CHI_NEVER)  };
  478: 	}
  479: }
  480: 
  481: # _can_fixate -- decide whether Data::Reuse::fixate is safe on a list.
  482: # fixate cannot handle GLOBs or blessed objects (RT#100461,
  483: #              RT#163955).  Only plain ARRAY, HASH, and SCALAR refs are safe.
  484: # Entry:       @_ is the list of values returned by the wrapped method.
  485: # Exit:        Returns 1 (safe) or 0 (unsafe).
  486: sub _can_fixate :Private
  487: {
  488: 	return none {
  Mutants (Total: 2, Killed: 2, Survived: 0)
  489: 		my $r = ref($_);
  490: 		$r && $r !~ /\A (?:ARRAY|HASH|SCALAR) \z/x   # GLOBs and blessed refs are unsafe for fixate
  491: 	} @_;
  492: }
  493: 
  494: =head2 AUTOLOAD
  495: 
  496: Not called directly.  Intercepts every method call not explicitly
  497: defined in this package, looks up the result in the cache, and on a
  498: miss proxies the call to the inner object and stores the result.
  499: 
  500: Cache lookup and storage use the pre-built C<_get>/C<_set> coderefs
  501: installed by C<_build_cache_accessors> at construction time, so the
  502: backend-type decision (HASH vs CHI) is made once -- never on each
  503: dispatch.
  504: 
  505: Three stored-value forms are mutually exclusive and exhaustive:
  506: 
  507: =over 4
  508: 
  509: =item ARRAY ref
  510: 
  511: The wrapped method previously returned a list.  Served as C<@array>
  512: in list context, or C<$array[-1]> in scalar context.
  513: 
  514: =item C<$UNDEF_SENTINEL>
  515: 
  516: The wrapped method returned C<undef> or an empty list.  Stored as the
  517: sentinel string so a cache miss (undefined value) can be distinguished
  518: from a cached C<undef>.
  519: 
  520: =item Any other defined scalar
  521: 
  522: The wrapped method returned a plain scalar in scalar context.  Served
  523: as-is in scalar context.  If the caller subsequently asks for the
  524: same key in list context, the scalar cannot be adapted -- the call is
  525: treated as a miss and the method is re-invoked so the array form gets
  526: independently cached.
  527: 
  528: =back
  529: 
  530: Handles C<DESTROY> specially: removes the wrapper from the double-wrap
  531: registry and clears cache entries whose keys begin with C<$self->{_class}>
  532: (Invariant I3 guarantees this is always set), then returns without
  533: calling the inner object's DESTROY.
  534: 
  535: =cut
  536: 
  537: sub AUTOLOAD
  538: {
●539 → 553 → 578  539: 	our $AUTOLOAD;
  540: 	my ($method) = $AUTOLOAD =~ /::(\w+)\z/;
  541: 
  542: 	# Prevent side effects in the inner object's method from leaking $_ back
  543: 	# to the caller.  Neither the DESTROY branch nor _can_fixate depends on a
  544: 	# pre-existing $_ value, so localizing it here is always safe.
  545: 	local $_;
  546: 
  547: 	my $self     = shift;
  548: 	my $cache    = $self->{cache};
  549: 	my $wantlist = wantarray;    # hoist: Perl does not cache this; avoid 3-4 redundant calls
  550: 
  551: 	# DESTROY arrives here because we handle it dynamically rather than
  552: 	# defining a named sub (which would suppress Class::Simple's AUTOLOAD).
  553: 	if($method eq 'DESTROY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  554: 		# During global destruction the symbol table may already be torn
  555: 		# down; accessing the cache at that point is unsafe.
  556: 		return if defined($^V) && ($^V ge 'v5.14.0') && ${^GLOBAL_PHASE} eq 'DESTRUCT';
  557: 
  558: 		# Remove from the double-wrap registry to prevent memory leaks in
  559: 		# long-running processes that create and destroy many wrappers.
  560: 		delete $cached{$self->{object}} if ref($self->{object});
  561: 
  562: 		if($cache) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  563: 			if($self->{_cache_is_hash}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  564: 				# Only delete keys that belong to this instance's class,
  565: 				# leaving entries from other classes untouched.
  566: 				my $prefix = $self->{_class};
  567: 				delete $cache->{$_} for grep { index($_, $prefix) == 0 } keys %{$cache};
  Mutants (Total: 1, Killed: 1, Survived: 0)
  568: 			} else {
  569: 				$cache->purge();
  570: 			}
  571: 		}
  572: 		return;
  573: 	}
  574: 
  575: 	# Build the cache key.
  576: 	# - _class is pre-computed in new() so we avoid ref($self) on every call.
  577: 	# - The @_ guard skips grep+join entirely for the common zero-arg getter case.
●578 → 587 → 621  578: 	my $key = $self->{_class} . '::' . $method . '::';
  579: 	$key .= join('::', grep { defined } @_) if @_;
  580: 
  581: 	# Use the pre-built backend closures (_get/_set) rather than a runtime
  582: 	# ref($cache) branch: the backend was fixed at construction time.
  583: 	my $get = $self->{_get};
  584: 	my $set = $self->{_set};
  585: 
  586: 	my $cached_val = $get->($key);
  587: 	if(defined($cached_val)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  588: 		# Premise: $cached_val is defined, so it was previously stored.
  589: 		# The stored value is one of exactly three mutually exclusive forms:
  590: 		#   (a) ARRAY ref  -- method returned a list
  591: 		#   (b) UNDEF_SENTINEL  -- method returned undef or empty list
  592: 		#   (c) any other scalar  -- method returned a plain scalar
  593: 		# Each is a separate equivalence partition; no overlap is possible.
  594: 
  595: 		if(ref($cached_val) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  596: 			# Premise: a list result was cached.
  597: 			# Conclusion: serve it in either call context.
  598: 			$self->{_hits}{$key}++;
  599: 			return $wantlist ? @{$cached_val} : $cached_val->[-1];
  Mutants (Total: 2, Killed: 2, Survived: 0)
  600: 		}
  601: 		if($cached_val eq $UNDEF_SENTINEL) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  602: 			# Premise: the cached result was undef or an empty list.
  603: 			# Conclusion: return "nothing" regardless of call context.
  604: 			$self->{_hits}{$key}++;
  605: 			return;
  606: 		}
  607: 		if(!$wantlist) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  608: 			# Premise: a scalar is cached AND the caller wants a scalar.
  609: 			# Conclusion: exact hit -- return the scalar directly.
  610: 			$self->{_hits}{$key}++;
  611: 			return $cached_val;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  612: 		}
  613: 		# Premise: a scalar is cached BUT the caller now wants a list.
  614: 		# Conclusion: this cannot be served from cache (see LIMITATIONS).
  615: 		# Fall through to re-invoke in list context so the array form
  616: 		# gets cached.  This is NOT counted as a hit.
  617: 	}
  618: 
  619: 	# Premise: no usable cached value exists for this key+context combination.
  620: 	# Conclusion: invoke the real object and cache whatever it returns.
●621 → 624 → 642  621: 	$self->{_misses}{$key}++;
  622: 	my $object = $self->{object};
  623: 
  624: 	if($wantlist) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  625: 		my @result = $object->$method(@_);
  626: 		if(!@result) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  627: 			# Premise: method returned an empty list (or undef in list context).
  628: 			# Conclusion: store the sentinel so future calls are hits, not misses.
  629: 			$set->($key, $UNDEF_SENTINEL);
  630: 			return;
  631: 		}
  632: 		# Premise: @result is non-empty.
  633: 		# Conclusion: cache as an arrayref so we can distinguish "list result"
  634: 		#   (stored as ARRAY ref) from "scalar result" (stored as plain scalar).
  635: 		#   fixate() shares memory across identical string values -- skip if any
  636: 		#   element is a type that Data::Reuse cannot handle (RT#100461).
  637: 		Data::Reuse::fixate(@result) if _can_fixate(@result);
  638: 		$set->($key, \@result);
  639: 		return @result;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  640: 	}
  641: 
●642 → 643 → 653  642: 	my $result = $object->$method(@_);
  643: 	if(!defined($result)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  644: 		# Premise: method returned undef in scalar context.
  645: 		# Conclusion: store sentinel; a bare undef in the cache would be
  646: 		#   indistinguishable from "cache miss" on the next call.
  647: 		$set->($key, $UNDEF_SENTINEL);
  648: 		return;
  649: 	}
  650: 	# Premise: $result is a defined scalar.
  651: 	# Conclusion: store it directly; ref($result) eq 'ARRAY' is impossible here
  652: 	#   because the scalar branch is only reached when !$wantlist.
  653: 	$set->($key, $result);
  654: 	return $result;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  655: }
  656: 
  657: =head1 LIMITATIONS
  658: 
  659: =over 4
  660: 
  661: =item B<Not safe for mutable objects>
  662: 
  663: The cache is never invalidated automatically.  If the inner object's
  664: state changes after caching, the wrapper will return stale data.  The
  665: caller must either reset the cache manually or avoid using this module
  666: with objects that mutate.
  667: 
  668: =item B<Argument serialisation is naive>
  669: 
  670: Cache keys are built by joining defined arguments with C<::>.  Two
  671: different argument lists can therefore produce the same key if an
  672: argument itself contains C<::> (e.g. C<foo('a::b', 'c')> vs
  673: C<foo('a', 'b::c')>).  Callers that pass arguments containing C<::>
  674: should use a CHI backend with a custom key serialiser.
  675: 
  676: =item B<Undefined arguments are collapsed>
  677: 
  678: Undefined values in the argument list are silently dropped from the
  679: cache key, so C<foo(undef)> and C<foo()> share a cache entry.
  680: 
  681: =item B<Scalar-then-list context mismatch is a miss>
  682: 
  683: If a method is first called in scalar context and then in list
  684: context with identical arguments, the second call is a cache miss
  685: and re-invokes the inner object.  Both results are then independently
  686: cached.
  687: 
  688: =item B<C<can('new')> returns a code reference, not a boolean>
  689: 
  690: For strict correctness C<can> returns C<\&new> for the C<'new'>
  691: method rather than the boolean C<1>.  The code reference is callable
  692: but callers who compare it with C<==> to C<1> will see a mismatch.
  693: 
  694: =item B<Does not work with L<Memoize>>
  695: 
  696: C<Memoize> intercepts at the symbol-table level and conflicts with
  697: the C<AUTOLOAD> dispatch used here.
  698: 
  699: =back
  700: 
  701: =head1 AUTHOR
  702: 
  703: Nigel Horne, C<< <njh at nigelhorne.com> >>
  704: 
  705: =head1 BUGS
  706: 
  707: Please report any bugs or feature requests to
  708: L<https://github.com/nigelhorne/Class-Simple-Readonly-Cached/issues>.
  709: 
  710: =head1 SEE ALSO
  711: 
  712: =over 4
  713: 
  714: =item * L<Test Dashboard|https://nigelhorne.github.io/Class-Simple-Readonly-Cached/coverage/>
  715: 
  716: =item * L<Class::Simple>
  717: 
  718: =item * L<CHI>
  719: 
  720: =item * L<Data::Reuse>
  721: 
  722: Values are shared between C<Class::Simple::Readonly::Cached> objects,
  723: since they are read-only.
  724: 
  725: =item * L<constant::defer>
  726: 
  727: =back
  728: 
  729: =head1 SUPPORT
  730: 
  731: This module is provided as-is without any warranty.
  732: 
  733: You can find documentation for this module with the perldoc command.
  734: 
  735:     perldoc Class::Simple::Readonly::Cached
  736: 
  737: =over 4
  738: 
  739: =item * MetaCPAN
  740: 
  741: L<https://metacpan.org/release/Class-Simple-Readonly-Cached>
  742: 
  743: =item * Source Repository
  744: 
  745: L<https://github.com/nigelhorne/Class-Simple-Readonly-Cached>
  746: 
  747: =item * CPAN Testers
  748: 
  749: L<http://matrix.cpantesters.org/?dist=Class-Simple-Readonly-Cached>
  750: 
  751: =back
  752: 
  753: =encoding UTF-8
  754: 
  755: =head1 FORMAL SPECIFICATION
  756: 
  757: =head2 new
  758: 
  759:     new : (C x P) -> (W | undef)
  760: 
  761:     C = class name string
  762:     P = { cache : (HashRef | CacheObj), object? : Ref, quiet? : Bool, ... }
  763:     W = blessed P in C
  764: 
  765:     valid_cache(c) :=
  766:         ref(c) = 'HASH'
  767:         OR ( blessed(c) AND c.can('get') AND c.can('set') AND c.can('purge') )
  768: 
  769:     Precondition:
  770:         valid_cache(P.cache)
  771: 
  772:     Post-construction invariants (hold for all W returned by new()):
  773:         W._class         = C
  774:         W._cache_is_hash = (ref(P.cache) = 'HASH')
  775:         W._get           = λk. (W._cache_is_hash ? W.cache[k] : W.cache.get(k))
  776:         W._set           = λ(k,v). (W._cache_is_hash ? W.cache[k]:=v
  777:                                                       : W.cache.set(k,v,'never'))
  778: 
  779:     Double-wrap invariant:
  780:         forall o in Dom(cached): new(C, {object: o, ...}) = cached[o].object
  781: 
  782:     Clone (object invocation):
  783:         forall w : W: w.new(P') = bless( merge(w, P'), ref(w) )
  784:         Corollary: if cache in Dom(P'), rebuild _get/_set/_cache_is_hash for P'.cache
  785: 
  786: =head2 object
  787: 
  788:     object : W -> Ref
  789: 
  790:     forall w : W: object(w) = w.object
  791: 
  792: =head2 state
  793: 
  794:     state : W -> HashRef
  795: 
  796:     forall w : W: state(w) = { hits => w._hits, misses => w._misses }
  797: 
  798: =head2 can
  799: 
  800:     can : (W|Str x Str) -> (CodeRef | undef)
  801: 
  802:     forall w : W, m : Str:
  803:       can(w, 'new') = \&new
  804:       can(w, m)     = w.object.can(m)  OR SUPER::can(w, m)
  805: 
  806: =head2 isa
  807: 
  808:     isa : (W x Str) -> Bool
  809: 
  810:     forall w : W, c : Str:
  811:       isa(w, c) = 1  if c in { ref(w), 'Class::Simple::Readonly::Cached' }
  812:                | 1  if SUPER::isa(w, c)
  813:                | w.object.isa(c)  if ref(w)
  814:                | 0  otherwise
  815: 
  816: =head2 autoload
  817: 
  818:     autoload : (W x M x A*) -> R
  819: 
  820:     M  = method name string
  821:     A* = argument tuple (possibly empty)
  822:     R  = scalar | list | undef
  823: 
  824:     Cache key:
  825:         k(w, m, a) := w._class ++ '::' ++ m ++ '::' ++ defined_args(a)
  826:         (w._class = ref(w), pre-computed once in new() to avoid ref() per dispatch)
  827: 
  828:     Caching law:
  829:         get(cache(w), k(w,m,a)) = v, v != undef
  830:             => autoload(w, m, a) = v          (cache hit)
  831:         get(cache(w), k(w,m,a)) = undef
  832:             => v = w.object.m(a)
  833:                set(cache(w), k(w,m,a), v)
  834:                autoload(w, m, a) = v          (cache miss)
  835: 
  836: =head1 LICENSE AND COPYRIGHT
  837: 
  838: Author Nigel Horne: C<njh@nigelhorne.com>
  839: Copyright (C) 2019-2026 Nigel Horne
  840: 
  841: Usage is subject to the GPL2 licence terms.
  842: If you use it,
  843: please let me know.
  844: 
  845: =cut
  846: 
  847: 1;