File Coverage

blib/lib/CHI.pm

Criterion	Covered	Total	%
statement	87	89	97.7
branch	25	28	89.2
condition	19	21	90.4
subroutine	18	19	94.7
pod	2	6	33.3
total	151	163	92.6

package CHI;
$CHI::VERSION = '0.60';
use 5.006;
use Carp;
use CHI::Stats;
use String::RewritePrefix;
use Module::Runtime qw(require_module);
use Moo::Role ();
use strict;
use warnings;

my ( %final_class_seen, %memoized_cache_objects, %stats );
my %valid_config_keys =
  map { ( $_, 1 ) } qw(defaults memoize_cache_objects namespace storage);

sub logger {
    warn
      "CHI now uses Log::Any for logging - see Log::Any documentation for details";
}

sub config {
    my $class = shift;
    $class->_set_config(@_) if @_;
    return $class->_get_config();
}

sub _set_config {
    my ( $class, $config ) = @_;
    if ( my @bad_keys = grep { !$valid_config_keys{$_} } keys(%$config) ) {
        croak "unknown keys in config hash: " . join( ", ", @bad_keys );
    }

    # set class specific configuration
    no strict 'refs';
    no warnings 'redefine';
    *{"$class\::_get_config"} = sub { $config };
}

BEGIN { __PACKAGE__->config( {} ) }

sub memoized_cache_objects {
    my ($class) = @_;

    # Each CHI root class gets its hash of memoized objects
    #
    $memoized_cache_objects{$class} ||= {};
    return $memoized_cache_objects{$class};
}

sub clear_memoized_cache_objects {
    my ($class) = @_;

    $memoized_cache_objects{$class} = {};
}

sub stats {
    my ($class) = @_;

    # Each CHI root class gets its own stats object
    #
    $stats{$class} ||= CHI::Stats->new( chi_root_class => $class );
    return $stats{$class};
}

sub new {
    my ( $chi_root_class, %params ) = @_;

    my $config = $chi_root_class->config;

    # Cache object memoization: See if cache object with these parameters
    # has already been created, and return it if so. Only for parameters
    # with 0 or 1 keys.
    #
    my ( $cache_object_key, $cache_objects );
    if ( $config->{memoize_cache_objects} && keys(%params) <= 1 ) {
        $cache_object_key = join chr(28), %params;
        $cache_objects = $chi_root_class->memoized_cache_objects;
        if ( my $cache_object = $cache_objects->{$cache_object_key} ) {
            return $cache_object;
        }
    }

    # Gather defaults
    #
    my $core_defaults = $config->{defaults} || {};
    my $namespace_defaults =
      $config->{namespace}->{ $params{namespace} || 'Default' } || {};
    my $storage =
         $params{storage}
      || $namespace_defaults->{storage}
      || $core_defaults->{storage};
    my $storage_defaults = {};
    if ( defined($storage) ) {
        $storage_defaults = $config->{storage}->{$storage}
          or croak "no config for storage type '$storage'";
    }

    # Combine passed params with defaults
    #
    %params =
      ( %$core_defaults, %$storage_defaults, %$namespace_defaults, %params );

    # Get driver class from driver or driver_class parameters
    #
    my $driver_class;
    if ( my $driver = delete( $params{driver} ) ) {
        ($driver_class) =
          String::RewritePrefix->rewrite( { '' => 'CHI::Driver::', '+' => '' },
            $driver );
    }
    else {
        $driver_class = delete( $params{driver_class} );
    }
    croak "missing required param 'driver' or 'driver_class'"
      unless defined $driver_class;

    # Load driver class if it hasn't been loaded or defined in-line already
    #
    unless ( $driver_class->can('fetch') ) {
        require_module($driver_class);
    }

    # Select roles depending on presence of certain arguments. Everyone gets
    # the Universal role. Accept both 'roles' and 'traits' for backwards
    # compatibility. Add CHI::Driver::Role:: unless prefixed with '+'.
    #
    my @roles = ('Universal');
    foreach my $param_name (qw(roles traits)) {
        if ( exists( $params{$param_name} ) ) {
            push( @roles, @{ delete( $params{$param_name} ) } );
        }
    }
    if ( exists( $params{max_size} ) || exists( $params{is_size_aware} ) ) {
        push( @roles, 'IsSizeAware' );
    }
    if ( exists( $params{l1_cache} ) || exists( $params{mirror_cache} ) ) {
        push( @roles, 'HasSubcaches' );
    }
    if ( $params{is_subcache} ) {
        push( @roles, 'IsSubcache' );
    }
    @roles = String::RewritePrefix->rewrite(
        { '' => 'CHI::Driver::Role::', '+' => '' }, @roles );

    # Select a final class based on the driver class and roles, creating it
    # if necessary - adapted from MooseX::Traits
    #
    my $final_class =
      Moo::Role->create_class_with_roles( $driver_class, @roles );

    my $cache_object = $final_class->new(
        chi_root_class => $chi_root_class,
        driver_class   => $driver_class,
        %params
    );

    # Memoize if appropriate
    #
    if ($cache_object_key) {
        $cache_objects->{$cache_object_key} = $cache_object;
    }

    return $cache_object;
}

1;

__END__