view release on metacpan or  search on metacpan

lib/CHI/Driver.pm  view on Meta::CPAN

            predicate => 1,
        },
        storage => {
            is => 'ro',
        },
    );
    push @common_params, keys %attr;
    for my $attr ( keys %attr ) {
        has $attr => %{ $attr{$attr} };
    }
}

sub _build_has_subcaches { undef }

# These methods must be implemented by subclass
foreach my $method (qw(fetch store remove get_keys get_namespaces)) {
    no strict 'refs';
    *{$method} = sub { die "method '$method' must be implemented by subclass" };
}

# Given a hash of params, return the subset that are not in CHI's common parameters.
#
push @common_params, qw(
  discard_policy
  discard_timeout
  l1_cache
  max_size
  max_size_reduction_factor
  mirror_cache
  parent_cache
  subcache_type
  subcaches
);
my %common_params = map { ( $_, 1 ) } @common_params;

sub non_common_constructor_params {
    my ( $class, $params ) = @_;

    return {
        map { ( $_, $params->{$_} ) }
        grep { !$common_params{$_} } keys(%$params)
    };
}

sub declare_unsupported_methods {
    my ( $class, @methods ) = @_;

    foreach my $method (@methods) {
        no strict 'refs';
        *{"$class\::$method"} =
          sub { croak "method '$method' not supported by '$class'" };
    }
}

sub cache_object_class { 'CHI::CacheObject' }

# To override time() for testing - must be writable in a dynamically scoped way from tests
our $Test_Time;    ## no critic (ProhibitPackageVars)
our $Build_Depth = 0;    ## no critic (ProhibitPackageVars)

sub valid_get_options { qw(expire_if busy_lock) }
sub valid_set_options { qw(expires_at expires_in expires_variance) }

sub BUILD {
    my ( $self, $params ) = @_;

    # Ward off infinite build recursion, e.g. from circular subcache configuration.
    #
    local $Build_Depth = $Build_Depth + 1;
    die "$Build_Depth levels of CHI cache creation; infinite recursion?"
      if ( $Build_Depth > $self->max_build_depth );

    # Save off constructor params. Used to create metacache, for
    # example. Hopefully this will not cause circular references...
    #
    $self->{constructor_params} = {%$params};
    foreach my $param (qw(l1_cache mirror_cache parent_cache)) {
        delete( $self->{constructor_params}->{$param} );
    }

    # If stats enabled, add ns_stats slot for keeping track of stats
    #
    my $stats = $self->chi_root_class->stats;
    if ( $stats->enabled ) {
        $self->{ns_stats} = $stats->stats_for_driver($self);
    }

    # Call BUILD_roles on any of the roles that need initialization.
    #
    $self->BUILD_roles($params);
}

sub BUILD_roles {

    # Will be modified by roles that need it
}

sub _build_short_driver_name {
    my ($self) = @_;

    ( my $name = $self->driver_class ) =~ s/^CHI::Driver:://;

    return $name;
}

sub _build_label {
    my ($self) = @_;

    return $self->short_driver_name;
}

sub _build_metacache {
    my $self = shift;

    return CHI::Driver::Metacache->new( owner_cache => $self );
}

sub get {
    my ( $self, $key, %params ) = @_;

    croak "must specify key" unless defined($key);
    my $ns_stats     = $self->{ns_stats};
    my $log_is_debug = $log->is_debug;
    my $measure_time = defined($ns_stats) || $log_is_debug;
    my ( $start_time, $elapsed_time );

    # Fetch cache object
    #
    $start_time = gettimeofday() if $measure_time;
    my $obj = eval { $params{obj} || $self->get_object($key) };
    $elapsed_time = ( gettimeofday() - $start_time ) * 1000 if $measure_time;
    if ( my $error = $@ ) {
        $ns_stats->{'get_errors'}++ if defined($ns_stats);
        $self->_handle_get_error( $error, $key );
        return undef;
    }
    if ( !defined $obj ) {
        $self->_record_get_stats( 'absent_misses', $elapsed_time )
          if defined($ns_stats);
        $self->_log_get_result( $log, "MISS (not in cache)",
            $key, $elapsed_time )
          if $log_is_debug;
        return undef;
    }
    if ( defined( my $obj_ref = $params{obj_ref} ) ) {
        $$obj_ref = $obj;
    }

    # Check if expired
    #
    my $is_expired = $obj->is_expired()
      || ( defined( $params{expire_if} )
        && $params{expire_if}->( $obj, $self ) );
    if ($is_expired) {
        $self->_record_get_stats( 'expired_misses', $elapsed_time )
          if defined($ns_stats);
        $self->_log_get_result( $log, "MISS (expired)", $key, $elapsed_time )
          if $log_is_debug;

        # If busy_lock value provided, set a new "temporary" expiration time that many
        # seconds forward before returning undef
        #
        if ( defined( my $busy_lock = $params{busy_lock} ) ) {
            my $time = $Test_Time || time();
            my $busy_lock_time = $time + parse_duration($busy_lock);
            $obj->set_early_expires_at($busy_lock_time);
            $obj->set_expires_at($busy_lock_time);
            $self->set_object( $key, $obj );
        }

        return undef;
    }

    $self->_record_get_stats( 'hits', $elapsed_time ) if defined($ns_stats);
    $self->_log_get_result( $log, "HIT", $key, $elapsed_time ) if $log_is_debug;
    return $obj->value;
}

sub _record_get_stats {
    my ( $self, $stat, $elapsed_time ) = @_;
    $self->{ns_stats}->{$stat}++;
    $self->{ns_stats}->{'get_time_ms'} += $elapsed_time;
}

sub unpack_from_data {
    my ( $self, $key, $data ) = @_;

    return $self->cache_object_class->unpack_from_data( $key, $data,
        $self->serializer );
}

sub get_object {
    my ( $self, $key ) = @_;

    croak "must specify key" unless defined($key);
    $key = $self->transform_key($key);

    my $data = $self->fetch($key) or return undef;
    my $obj = $self->unpack_from_data( $key, $data );
    return $obj;
}

sub get_expires_at {
    my ( $self, $key ) = @_;
    croak "must specify key" unless defined($key);

    if ( my $obj = $self->get_object($key) ) {
        return $obj->expires_at;
    }
    else {
        return;
    }
}

sub exists_and_is_expired {
    my ( $self, $key ) = @_;
    croak "must specify key" unless defined($key);

    if ( my $obj = $self->get_object($key) ) {
        return $obj->is_expired;
    }
    else {
        return;
    }
}

sub is_valid {

lib/CHI/Driver.pm  view on Meta::CPAN

sub set_object {
    my ( $self, $key, $obj ) = @_;

    my $data               = $obj->pack_to_data();
    my $expires_on_backend = $self->expires_on_backend;
    my @expires_in         = (
        $expires_on_backend && $obj->expires_at < CHI_Max_Time
        ? ( ( $obj->expires_at - time ) * $expires_on_backend )
        : ()
    );
    eval { $self->store( $key, $data, @expires_in ) };
    if ( my $error = $@ ) {
        $self->{ns_stats}->{'set_errors'}++ if defined( $self->{ns_stats} );
        $self->_handle_set_error( $error, $obj );
        return 0;
    }
    return 1;
}

sub get_keys_iterator {
    my ($self) = @_;

    my @keys = $self->get_keys();
    return sub { shift(@keys) };
}

sub clear {
    my $self = shift;
    die "clear takes no arguments" if @_;

    $self->remove_multi( [ $self->get_keys() ] );
}

sub expire {
    my ( $self, $key ) = @_;
    croak "must specify key" unless defined($key);

    my $time = $Test_Time || time();
    if ( defined( my $obj = $self->get_object($key) ) ) {
        my $expires_at = $time - 1;
        $obj->set_early_expires_at($expires_at);
        $obj->set_expires_at($expires_at);
        $self->set_object( $key, $obj );
    }
}

sub compute {
    my $self      = shift;
    my $key       = shift;
    my $wantarray = wantarray();

    # Allow these in either order for backward compatibility
    my ( $code, $options ) =
      ( ref( $_[0] ) eq 'CODE' ) ? ( $_[0], $_[1] ) : ( $_[1], $_[0] );

    croak "must specify key and code" unless defined($key) && defined($code);

    my %get_options =
      ( ref($options) eq 'HASH' )
      ? slice_grep { /(?:expire_if|busy_lock)/ } $options
      : ();
    my $set_options =
        ( ref($options) eq 'HASH' )
      ? { slice_grep { !/(?:expire_if|busy_lock)/ } $options }
      : $options;

    my $value = $self->get( $key, %get_options );
    if ( !defined $value ) {
        my ( $start_time, $elapsed_time );
        my $ns_stats = $self->{ns_stats};
        $start_time = gettimeofday if defined($ns_stats);
        $value = $wantarray ? [ $code->() ] : $code->();
        $elapsed_time = ( gettimeofday() - $start_time ) * 1000
          if defined($ns_stats);
        $self->set( $key, $value, $set_options );
        if ( defined($ns_stats) ) {
            $ns_stats->{'computes'}++;
            $ns_stats->{'compute_time_ms'} += $elapsed_time;
        }
    }
    return $wantarray ? @$value : $value;
}

sub purge {
    my ($self) = @_;

    foreach my $key ( $self->get_keys() ) {
        if ( my $obj = $self->get_object($key) ) {
            if ( $obj->is_expired() ) {
                $self->remove($key);
            }
        }
    }
}

sub dump_as_hash {
    my ($self) = @_;

    my %hash;
    foreach my $key ( $self->get_keys() ) {
        if ( defined( my $value = $self->get($key) ) ) {
            $hash{$key} = $value;
        }
    }
    return \%hash;
}

sub is_empty {
    my ($self) = @_;

    return !$self->get_keys();
}

#
# (SEMI-) ATOMIC OPERATIONS
#

sub add {
    my $self = shift;
    my $key  = shift;

    if ( !$self->is_valid($key) ) {
        $self->set( $key, @_ );
    }