File Coverage

blib/lib/Memoize/Expire/ByInstance.pm

Criterion	Covered	Total	%
statement	134	134	100.0
branch	40	46	86.9
condition	13	18	72.2
subroutine	29	29	100.0
pod	2	2	100.0
total	218	229	95.2

{

    package Memoize::Expire::ByInstance;
    use 5.006002;
    use warnings;
    use strict;
    use Time::HiRes qw(time);
    use Scalar::Util qw(weaken);
    use constant FILE_SEPERATOR => chr(0x1C);

    our $VERSION = 0.500005;

    ############################################################################################
    ## Tie the hash to this class. Support passing a HASH => \$hashref argument to permit
    ## chaining various tied-hashes together
    ############################################################################################
    sub TIEHASH
    {
        my ( $proto, %opts ) = @_;
        my $class = ref($proto) || $proto;

        my $default_lifetime = $opts{LIFETIME} || 0;
        my $default_num_uses = $opts{NUM_USES} || 0;

        my $self =
          { _meta => { _hash_data => {}, _expire => { _default => { lifetime => $default_lifetime, num_uses => $default_num_uses, }, }, } };
        $self->{_hash} = ( exists( $opts{HASH} ) && ref( $opts{HASH} ) eq 'HASH' ) ? $opts{HASH} : {};
        bless( $self, $class );

        # Memoize doesn't deal well with "memoize('Package::method', ...)"; hence it must be tied and memoized
        # in the same package that its used in... kinda annoying for unit testing... but handy in that I can use caller
        $self->__insert_destroy_wrapper( (caller)[0] ) if( $opts{AUTO_DESTROY} );
        $self->_argument_seperator( $opts{ARGUMENT_SEPERATOR} || FILE_SEPERATOR );

        return $self;
    }

    ############################################################################################
    ## Reset num_uses and last_set_time, and store the new value.
    ############################################################################################
    sub STORE
    {
        my ( $self, $key, $value ) = @_;
        ( my $instance_id, $key ) = $self->_split_instance($key);
        return unless($key);

        $self->{_meta}->{_hash_data}->{$key}->{last_set_time} = time();
        $self->{_meta}->{_hash_data}->{$key}->{num_uses}      = 0;

        $self->{_hash}->{$key} = $value;
        return $value;
    }

    ############################################################################################
    ## Increment num_uses, and return the value for the specified key
    ############################################################################################
    sub FETCH
    {
        my ( $self, $key ) = @_;
        ( my $instance_id, $key ) = $self->_split_instance($key);
        return unless($key);

        $self->{_meta}->{_hash_data}->{$key}->{num_uses}++;

        return $self->{_hash}->{$key};
    }

    ############################################################################################
    ## Return a true value if the key both exists AND has not expired for the instance fetching
    ## it
    ############################################################################################
    sub EXISTS
    {
        my ( $self, $key ) = @_;
        ( my $instance_id, $key ) = $self->_split_instance($key);
        return unless($key);

        return if( $self->_key_has_expired( $instance_id, $key ) );
        return ( exists( $self->{_hash}->{$key} ) );
    }

    ############################################################################################
    ## Delete a member from the hash
    ############################################################################################
    sub DELETE
    {
        my ( $self, $key ) = @_;
        ( my $instance_id, $key ) = $self->_split_instance($key);
        return unless($key);

        delete( $self->{_meta}->{_hash_data}->{$key} ) if( exists( $self->{_meta}->{_hash_data}->{$key} ) );
        return ( delete( $self->{_hash}->{$key} ) );
    }


    ############################################################################################
    ## Return next key in hash
    ############################################################################################
    sub NEXTKEY
    {
        my ($self) = @_;
        return ( each( %{ $self->{_hash} } ) );
    }


    ############################################################################################
    ## Return first key in hash
    ############################################################################################
    sub FIRSTKEY
    {
        my ($self) = @_;
        my @keys = keys( %{ $self->{_hash} } );
        return ( each( %{ $self->{_hash} } ) );
    }


    ############################################################################################
    ## Delete all members from hash
    ############################################################################################
    sub CLEAR
    {
        my ($self) = @_;

        map { delete( $self->{_meta}->{_hash_data}->{$_} ) } keys %{ $self->{_hash} };
        %{ $self->{_hash} } = ();
        return;
    }

    ############################################################################################
    ## Return scalar equivilency of hash
    ############################################################################################
    sub SCALAR
    {
        my ($self) = @_;
        return ( scalar %{ $self->{_hash} } );
    }

    ############################################################################################
    ## Register an instance with this tied hash, which will be used for lifetime/num_uses
    ## expiration uniqueness
    ############################################################################################
    sub register
    {
        my ( $self, $instance_id, %opts ) = @_;
        my $lifetime = defined( $opts{lifetime} ) ? $opts{lifetime} : $self->{_meta}->{_expire}->{_default}->{lifetime};
        my $num_uses = defined( $opts{num_uses} ) ? $opts{num_uses} : $self->{_meta}->{_expire}->{_default}->{num_uses};

        ## we make instance_id a string, because when its Memoized, the
        ## key will be be a string concatination of arguments
        $instance_id = "$instance_id";

        $self->{_meta}->{_expire}->{$instance_id}->{lifetime} = $lifetime
          if( $lifetime != $self->{_meta}->{_expire}->{_default}->{lifetime} );
        $self->{_meta}->{_expire}->{$instance_id}->{num_uses} = $num_uses
          if( $num_uses != $self->{_meta}->{_expire}->{_default}->{num_uses} );
        return $self;
    }

    ############################################################################################
    ## Unregister an instance from this tied hash, freeing the memory used in the hash for it
    ############################################################################################
    sub unregister
    {
        my ( $self, $instance_id ) = @_;

        ## we make instance_id a string, because when its Memoized, the
        ## key will be be a string concatination of arguments
        $instance_id = "$instance_id";

        if( exists( $self->{_meta}->{_expire}->{$instance_id} ) ) {
            ## undef explicitely to force immediate freeing of memory
            undef( $self->{_meta}->{_expire}->{$instance_id} );
            delete( $self->{_meta}->{_expire}->{$instance_id} );
        }
        return;
    }

    ############################################################################################
    ## Test if a key has expired for the particular instance testing EXISTS
    ############################################################################################
    sub _key_has_expired
    {
        my ( $self, $instance_id, $key ) = @_;

        # We will assume that if we do not have current _hash_data for the underlying storage
        # that it has expired.
        if( exists( $self->{_meta}->{_hash_data}->{$key} ) ) {
            my $last_set_time = $self->{_meta}->{_hash_data}->{$key}->{last_set_time};
            my $num_uses      = $self->{_meta}->{_hash_data}->{$key}->{num_uses};

            my $lifetime_lookup_id = '_default';
            my $num_uses_lookup_id = '_default';

            if( exists( $self->{_meta}->{_expire}->{$instance_id} ) ) {
                $lifetime_lookup_id = $instance_id if( exists( $self->{_meta}->{_expire}->{$instance_id}->{lifetime} ) );
                $num_uses_lookup_id = $instance_id if( exists( $self->{_meta}->{_expire}->{$instance_id}->{num_uses} ) );
            }

            my $max_lifetime = $self->{_meta}->{_expire}->{$lifetime_lookup_id}->{lifetime};
            my $max_num_uses = $self->{_meta}->{_expire}->{$num_uses_lookup_id}->{num_uses};

            return 1 if( ( $max_lifetime > 0 ) && ( time() >= $last_set_time + $max_lifetime ) );
            return 1 if( ( $max_num_uses > 0 ) && ( $num_uses >= $max_num_uses ) );
        }
        return;
    }

    ############################################################################################
    ## split the key apart on the ascii File-Seperater character used by Memoize when creating hash-keys
    ############################################################################################
    sub _split_instance
    {
        my ( $self, $key ) = @_;
        (my $instance_id, $key ) = split( $self->_argument_seperator(), $key, 2 );
        return($instance_id, $key) if($key);
        return( $instance_id, $instance_id ); ## XXX Hack, wont work if the key you are looking for contains argumement seperators itself
    }

    ############################################################################################
    ## get/set the seperator applicable to keys being inserted into our hash.
    ############################################################################################
    sub _argument_seperator
    {
        my ( $self, $value ) = @_;
        $self->{_meta}->{_argument_seperator} = $value if( defined($value) );
        return $self->{_meta}->{_argument_seperator};
    }

    ############################################################################################
    ## Attempt to insert a DESTROY method into the package that tied us. Wrap any existing.
    ############################################################################################
    sub __insert_destroy_wrapper
    {
        my ( $self, $class ) = @_;

        my $weakself = $self;
        weaken($weakself);
        my $sub = sub {return};

        no strict 'refs';
        $sub = *{ '::' . $class . '::DESTROY' }{CODE} if( defined( *{ '::' . $class . '::DESTROY' }{CODE} ) );
        use strict;

        no strict 'refs';
        no warnings 'redefine';
        *{ '::' . $class . '::DESTROY' } = sub {
            my ($this) = @_;
            $weakself->unregister("$this") if( defined($weakself) );
            return $sub->(@_);
        };
        use warnings;
        use strict;

        return;
    }
}
1;
__END__