locked results from the CPAN

Cache-FastMmap

Also remember that I<write_cb> may be called in a different process
to the one that placed the data in the cache in the first place

=item * B<delete_cb>

Callback to delete data from the underlying data store.  Called as:

  $delete_cb->($context, $Key)

Called as soon as I<remove(...)> is called on the Cache::FastMmap class

=item * B<cache_not_found>

If set to true, then if the I<read_cb> is called and it returns
undef to say nothing was found, then that information is stored
in the cache, so that next time a I<get(...)> is called on that
key, undef is returned immediately rather than again calling
the I<read_cb>

=item * B<write_action>

Either 'write_back' or 'write_through'. (default: write_through)

=item * B<allow_recursive>

If you're using a callback function, then normally the cache is not
re-enterable, and attempting to call a get/set on the cache will
cause an error. By setting this to one, the cache will unlock any
pages before calling the callback. During the unlock time, other
processes may change data in current cache page, causing possible
unexpected effects. You shouldn't set this unless you know you
want to be able to recall to the cache within a callback.
(default: 0)

=item * B<empty_on_exit>

When you have 'write_back' mode enabled, then
you really want to make sure all values from the cache are expunged
when your program exits so any changes are written back.

The trick is that we only want to do this in the parent process,
we don't want any child processes to empty the cache when they exit.
So if you set this, it takes the PID via $$, and only calls
empty in the DESTROY method if $$ matches the pid we captured
at the start. (default: 0)

=item * B<unlink_on_exit>

Unlink the share file when the cache is destroyed.

As with empty_on_exit, this will only unlink the file if the
DESTROY occurs in the same PID that the cache was created in
so that any forked children don't unlink the file.

This value defaults to 1 if the share_file specified does
not already exist. If the share_file specified does already
exist, it defaults to 0.

=item * B<catch_deadlocks>

Sets an alarm(10) before each page is locked via fcntl(F_SETLKW) to catch
any deadlock. This used to be the default behaviour, but it's not really
needed in the default case and could clobber sub-second Time::HiRes
alarms setup by other code. Defaults to 0.

=back

=cut
sub new {
  my $Proto = shift;
  my $Class = ref($Proto) || $Proto;

  # If first item is a hash ref, use it as arguments
  my %Args = ref($_[0]) eq 'HASH' ? %{shift()} : @_;

  my $Self = {};
  bless ($Self, $Class);

  # Work out cache file and whether to init
  my $share_file = $Args{share_file};
  if (!$share_file) {
    my $tmp_dir = File::Spec->tmpdir;
    $share_file = File::Spec->catfile($tmp_dir, "sharefile");
    $share_file .= "-" . $$ . "-" . time . "-" . int(rand(100000));
  }
  !ref($share_file) || die "share_file argument was a reference";
  $Self->{share_file} = $share_file;
  my $permissions = $Args{permissions};

  my $init_file = $Args{init_file} ? 1 : 0;
  my $test_file = $Args{test_file} ? 1 : 0;
  my $enable_stats = $Args{enable_stats} ? 1 : 0;
  my $catch_deadlocks = $Args{catch_deadlocks} ? 1 : 0;

  # Worth out unlink default if not specified
  if (!exists $Args{unlink_on_exit}) {
    $Args{unlink_on_exit} = -f($share_file) ? 0 : 1;
  }

  # Serialise stored values?
  my $serializer = $Args{serializer};
  $serializer = ($Args{raw_values} ? '' : 'storable') if !defined $serializer;

  if ($serializer) {
    if (ref $serializer eq 'ARRAY') {
      $Self->{serialize}   = $serializer->[0];
      $Self->{deserialize} = $serializer->[1];
    } elsif ($serializer eq 'storable') {
      eval "require Storable;"
        || die "Could not load serialization package: Storable : $@";
      $Self->{serialize}   = Storable->can("freeze");
      $Self->{deserialize} = Storable->can("thaw");
    } elsif ($serializer eq 'sereal') {
      eval "require Sereal::Encoder; require Sereal::Decoder;"
        || die "Could not load serialization package: Sereal : $@";
      my $SerealEnc = Sereal::Encoder->new();
      my $SerealDec = Sereal::Decoder->new();
      $Self->{serialize} = sub { $SerealEnc->encode(@_); };
      $Self->{deserialize} = sub { $SerealDec->decode(@_); };
    } elsif ($serializer eq 'json') {
      eval "require JSON;"

lib/Cache/FastMmap.pm view on Meta::CPAN


This method returns true if the value was stored in the cache,
false otherwise. See the PAGE SIZE AND KEY/VALUE LIMITS section
for more details.

=cut
sub set {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  my $Val = $Self->{serialize} ? $Self->{serialize}(\$_[2]) : $_[2];
  $Val = $Self->{compress}($Val) if $Self->{compress};

  # Get opts, make compatible with Cache::Cache interface
  my $Opts = defined($_[3]) ? (ref($_[3]) ? $_[3] : { expire_time => $_[3] }) : undef;
  # expire_on takes precedence, otherwise use expire_time if present
  my $expire_on = defined($Opts) ? (
    defined $Opts->{expire_on} ? $Opts->{expire_on} :
      (defined $Opts->{expire_time} ? parse_expire_time($Opts->{expire_time}, _time()): -1)
  ) : -1;

  # Hash value, lock page
  my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]);

  # If skip_lock is passed, it's a *reference* to an existing lock we
  #  have to take and delete so we can cleanup below before calling
  #  the callback
  my $Unlock = $Opts && $Opts->{skip_lock};
  if ($Unlock) {
    ($Unlock, $$Unlock) = ($$Unlock, undef);
  } else {
    $Unlock = $Self->_lock_page($HashPage);
  }

  # Are we doing writeback's? If so, need to mark as dirty in cache
  my $write_back = $Self->{write_back};

  # Get key/value len (we've got 'use bytes'), and do expunge check to
  #  create space if needed
  my $KVLen = length($_[1]) + (defined($Val) ? length($Val) : 0);
  $Self->_expunge_page(2, 1, $KVLen);

  # Now store into cache
  my $DidStore = fc_write($Cache, $HashSlot, $_[1], $Val, $expire_on, $write_back ? FC_ISDIRTY : 0);

  # Unlock page
  $Unlock = undef;

  # If we're doing write-through, or write-back and didn't get into cache,
  #  write back to the underlying store
  if ((!$write_back || !$DidStore) && (my $write_cb = $Self->{write_cb})) {
    eval { $write_cb->($Self->{context}, $_[1], $_[2]); };
  }

  return $DidStore;
}

=item I<get_and_set($Key, $AtomicSub)>

Atomically retrieve and set the value of a Key.

The page is locked while retrieving the $Key and is unlocked only after
the value is set, thus guaranteeing the value does not change between
the get and set operations.

$AtomicSub is a reference to a subroutine that is called to calculate the
new value to store. $AtomicSub gets $Key, the current value from the
cache, and an options hash as paramaters. Currently the only option
passed is the expire_on of the item.

It should return the new value to set in the cache for the given $Key,
and an optional hash of arguments in the same format as would be passed
to a C<set()> call.

If $AtomicSub returns an empty list, no value is stored back
in the cache. This avoids updating the expiry time on an entry
if you want to do a "get if in cache, store if not present" type
callback.

For example:

=over 4

=item *

To atomically increment a value in the cache

  $Cache->get_and_set($Key, sub { return $_[1]+1; });

=item *

To add an item to a cached list and set the expiry time
depending on the size of the list

  $Cache->get_and_set($Key, sub ($, $v) {
    push @$v, $item;
    return ($v, { expire_time => @$v > 2 ? '10s' : '2m' });
  });

=item *

To update a counter, but maintain the original expiry time

  $Cache->get_and_set($Key, sub {
    return ($_[1]+1, { expire_on => $_[2]->{expire_on} );
  });


=back

In scalar context the return value from C<get_and_set()>, is the
*new* value stored back into the cache.

In list context, a two item array is returned; the new value stored
back into the cache and a boolean that's true if the value was stored
in the cache, false otherwise. See the PAGE SIZE AND KEY/VALUE LIMITS
section for more details.

Notes:

=over 4

=item *

Do not perform any get/set operations from the callback sub, as these
operations lock the page and you may end up with a dead lock!

=item *

If your sub does a die/throws an exception, the page will correctly
be unlocked (1.15 onwards)

=back

=cut
sub get_and_set {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  my ($Value, $Unlock, $Opts) = $Self->get($_[1], { skip_unlock => 1 });

  # If this throws an error, $Unlock ref will still unlock page
  my @NewValue = $_[2]->($_[1], $Value, $Opts);

  my $DidStore = 0;
  if (@NewValue) {
    ($Value, my $Opts) = @NewValue;
    $DidStore = $Self->set($_[1], $Value, { skip_lock => \$Unlock, %{$Opts || {}} });
  }

  return wantarray ? ($Value, $DidStore) : $Value;
}

=item I<exists($Key)>

Search cache for given Key. Returns false if not found or true
if found. This will *not* call the I<read_cb> if not found.

This is also an optimisation over C<get()> as it will not uncompress or
deserialize the value if found in the cache.

=cut
sub exists {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  # Hash value, lock page, read result
  my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]);
  my $Unlock = $Self->_lock_page($HashPage);
  my (undef, $Flags, $Found, $ExpireOn) = fc_read($Cache, $HashSlot, $_[1]);

  return $Found;
}

=item I<remove($Key, [ \%Options ])>

Delete the given key from the cache

I<%Options> is optional, and is used by get_and_remove() to control
the locking behaviour. For now, you should probably ignore it
unless you read the code to understand how it works

=cut
sub remove {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  # Hash value, lock page, read result
  my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]);

  # If skip_lock is passed, it's a *reference* to an existing lock we
  #  have to take and delete so we can cleanup below before calling
  #  the callback
  my $Unlock = $_[2] && $_[2]->{skip_lock};
  if ($Unlock) {
    ($Unlock, $$Unlock) = ($$Unlock, undef);
  } else {
    $Unlock = $Self->_lock_page($HashPage);
  }

  my ($DidDel, $Flags) = fc_delete($Cache, $HashSlot, $_[1]);
  $Unlock = undef;

  # If we deleted from the cache, and it's not dirty, also delete
  #  from underlying store
  if ((!$DidDel || ($DidDel && !($Flags & FC_ISDIRTY)))
     && (my $delete_cb = $Self->{delete_cb})) {
    eval { $delete_cb->($Self->{context}, $_[1]); };
  }
  
  return $DidDel;
}

=item I<get_and_remove($Key)>

Atomically retrieve value of a Key while removing it from the cache.

The page is locked while retrieving the $Key and is unlocked only after
the value is removed, thus guaranteeing the value stored by someone else
isn't removed by us.

=cut
sub get_and_remove {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  my ($Value, $Unlock) = $Self->get($_[1], { skip_unlock => 1 });
  my $DidDel = $Self->remove($_[1], { skip_lock => \$Unlock });
  return wantarray ? ($Value, $DidDel) : $Value;
}

=item I<expire($Key)>

Explicitly expire the given $Key. For a cache in write-back mode, this
will cause the item to be written back to the underlying store if dirty,
otherwise it's the same as removing the item. 

=cut
sub expire {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  # Hash value, lock page, read result
  my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]);
  my $Unlock = $Self->_lock_page($HashPage);
  my ($Val, $Flags, $Found) = fc_read($Cache, $HashSlot, $_[1]);

  # If we found it, remove it
  if ($Found) {
    (undef, $Flags) = fc_delete($Cache, $HashSlot, $_[1]);
  }
  $Unlock = undef;

  # If it's dirty, write it back
  if (($Flags & FC_ISDIRTY) && (my $write_cb = $Self->{write_cb})) {
    eval { $write_cb->($Self->{context}, $_[1], $Val); };
  }

  return $Found;
}

=item I<clear()>

Clear all items from the cache

Note: If you're using callbacks, this has no effect
on items in the underlying data store. No delete
callbacks are made

=cut
sub clear {
  my $Self = shift;
  $Self->_expunge_all(1, 0);
}

=item I<purge()>

Clear all expired items from the cache

Note: If you're using callbacks, this has no effect

lib/Cache/FastMmap.pm view on Meta::CPAN

sub get_keys {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  my $Mode = $_[1] || 0;
  my ($Uncompress, $Deserialize) = @$Self{qw(uncompress deserialize)};

  return fc_get_keys($Cache, $Mode)
    if $Mode <= 1 || ($Mode == 2 && !$Uncompress && !$Deserialize);

  # If we're getting values as well, and they're not raw, unfreeze them
  my @Details = fc_get_keys($Cache, 2);

  for (@Details) {
    my $Val = $_->{value};
    if (defined $Val) {
      $Val = $Uncompress->($Val) if $Uncompress;
      $Val = ${$Deserialize->($Val)} if $Deserialize;
      $_->{value} = $Val;
    }
  }
  return @Details;
}

=item I<get_statistics($Clear)>

Returns a two value list of (nreads, nreadhits). This
only works if you passed enable_stats in the constructor

nreads is the total number of read attempts done on the
cache since it was created

nreadhits is the total number of read attempts done on
the cache since it was created that found the key/value
in the cache

If $Clear is true, the values are reset immediately after
they are retrieved

=cut
sub get_statistics {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});
  my $Clear = $_[1];

  my ($NReads, $NReadHits) = (0, 0);
  for (0 .. $Self->{num_pages}-1) {
    my $Unlock = $Self->_lock_page($_);
    my ($PNReads, $PNReadHits) = fc_get_page_details($Cache);
    $NReads += $PNReads;
    $NReadHits += $PNReadHits;
    fc_reset_page_details($Cache) if $Clear;
    $Unlock = undef;
  }
  return ($NReads, $NReadHits);
}

=item I<multi_get($PageKey, [ $Key1, $Key2, ... ])>

The two multi_xxx routines act a bit differently to the
other routines. With the multi_get, you pass a separate
PageKey value and then multiple keys. The PageKey value
is hashed, and that page locked. Then that page is
searched for each key. It returns a hash ref of
Key => Value items found in that page in the cache.

The main advantage of this is just a speed one, if you
happen to need to search for a lot of items on each call.

For instance, say you have users and a bunch of pieces
of separate information for each user. On a particular
run, you need to retrieve a sub-set of that information
for a user. You could do lots of get() calls, or you
could use the 'username' as the page key, and just
use one multi_get() and multi_set() call instead.

A couple of things to note:

=over 4

=item 1.

This makes multi_get()/multi_set() and get()/set()
incompatible. Don't mix calls to the two, because
you won't find the data you're expecting

=item 2.

The writeback and callback modes of operation do
not work with multi_get()/multi_set(). Don't attempt
to use them together.

=back

=cut
sub multi_get {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  # Hash value page key, lock page
  my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]);
  my $Unlock = $Self->_lock_page($HashPage);

  # For each key to find
  my ($Keys, %KVs) = ($_[2]);
  for (@$Keys) {

    # Hash key to get slot in this page and read
    my $FinalKey = "$_[1]-$_";
    (undef, $HashSlot) = fc_hash($Cache, $FinalKey);
    my ($Val, $Flags, $Found, $ExpireOn) = fc_read($Cache, $HashSlot, $FinalKey);
    next unless $Found;

    # If not using raw values, use thaw() to turn data back into object
    $Val = $Self->{uncompress}($Val) if defined($Val) && $Self->{compress};
    $Val = ${$Self->{deserialize}($Val)} if defined($Val) && $Self->{deserialize};

    # Save to return
    $KVs{$_} = $Val;
  }

  # Unlock page and return any found value
  $Unlock = undef;

lib/Cache/FastMmap.pm view on Meta::CPAN

=item I<_expunge_all($Mode, $WB)>

Expunge all items from the cache

Expunged items (that have not expired) are written
back to the underlying store if write_back is enabled

=cut
sub _expunge_all {
  my ($Self, $Cache, $Mode, $WB) = ($_[0], $_[0]->{Cache}, $_[1], $_[2]);

  # Repeat expunge for each page
  for (0 .. $Self->{num_pages}-1) {
    my $Unlock = $Self->_lock_page($_);
    $Self->_expunge_page($Mode, $WB, -1);
    $Unlock = undef;
  }

}

=item I<_expunge_page($Mode, $WB, $Len)>

Expunge items from the current page to make space for
$Len bytes key/value items

Expunged items (that have not expired) are written
back to the underlying store if write_back is enabled

=cut
sub _expunge_page {
  my ($Self, $Cache, $Mode, $WB, $Len) = ($_[0], $_[0]->{Cache}, @_[1 .. 3]);

  # If writeback mode, need to get expunged items to write back
  my $write_cb = $Self->{write_back} && $WB ? $Self->{write_cb} : undef;

  my @WBItems = fc_expunge($Cache, $Mode, $write_cb ? 1 : 0, $Len);

  my ($Uncompress, $Deserialize) = @$Self{qw(uncompress deserialize)};

  for (@WBItems) {
    next if !($_->{flags} & FC_ISDIRTY);

    my $Val = $_->{value};
    if (defined $Val) {
      $Val = $Uncompress->($Val) if $Uncompress;
      $Val = ${$Deserialize->($Val)} if $Deserialize;
    }
    eval { $write_cb->($Self->{context}, $_->{key}, $Val, $_->{expire_on}); };
  }
}

=item I<_lock_page($Page)>

Lock a given page in the cache, and return an object
reference that when DESTROYed, unlocks the page

=cut
sub _lock_page {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});
  my $Unlock = Cache::FastMmap::OnLeave->new(sub {
    fc_unlock($Cache) if fc_is_locked($Cache);
  });
  fc_lock($Cache, $_[1]);
  return $Unlock;
}

sub _time {
  $time_override ? $time_override : time;
}

sub _set_time_override {
  my $Time = shift;
  $time_override = $Time;
  fc_set_time_override($Time || 0);
}

my %Times = ('' => 1, s => 1, m => 60, h => 60*60, d => 24*60*60, w => 7*24*60*60);

sub parse_expire_time {
  my $expire_time = shift || '';
  return 0 if $expire_time eq 'never';
  return @_ ? shift : 1 if $expire_time eq 'now';
  my $offset = $expire_time =~ /^(\d+)\s*([mhdws]?)/i ? $1 * $Times{lc($2)} : 0;
  return $offset + (@_ ? shift : 0);
}

sub cleanup {
  my ($Self, $Cache) = ($_[0], $_[0]->{Cache});

  # Avoid potential double cleanup
  return if $Self->{cleaned};
  $Self->{cleaned} = 1;

  # Expunge all entries on exit if requested and in parent process
  if ($Self->{empty_on_exit} && $Cache && $Self->{pid} == $$) {
    $Self->empty();
  }

  if ($Cache) {
    fc_close($Cache);
    $Cache = undef;
    delete $Self->{Cache};
  }

  unlink($Self->{share_file})
    if $Self->{unlink_on_exit} && $Self->{pid} == $$;

}

sub DESTROY {
  my $Self = shift;
  $Self->cleanup();
  delete $LiveCaches{ref($Self)} if $Self->{empty_on_exit};
}

sub END {
  while (my (undef, $Self) = each %LiveCaches) {
    # Weak reference, might be undef already
    $Self->cleanup() if $Self;
  }
  %LiveCaches = ();

( run in 1.951 second using v1.01-cache-2.11-cpan-39bf76dae61 )