view release on metacpan or  search on metacpan

lib/Cache/Memcached/PDeque.pm  view on Meta::CPAN

  my ( $self, $func, $param ) = @_;

  $self->_lock(0, timeout => 0);
    for (my $prio=$self->max_prio; $prio>=1; $prio--) {
    $self->_lock($prio, timeout => 0);
    my $href = $self->memcached->get_multi(($prio . ':head',$prio . ':tail'));
    my $head = $href->{$prio . ':head'};
    my $tail = $href->{$prio . ':tail'};
    while ( ++$head <= $tail ) {
      my $el = $self->memcached->get($prio . ':' . $head);
      $func->($el, $param );
    }
    $self->_unlock($prio);
  }
  $self->_unlock(0);
}

sub _check {
  my ( $self ) = @_;
  my $total_size = 0;
  foreach my $i ( 1 .. $self->max_prio ) {
    my $size = $self->memcached->get($i . ':size'); $total_size += $size;
    my $head = $self->memcached->get($i . ':head');
    my $tail = $self->memcached->get($i . ':tail');
    assert ( $size == $tail-$head )  if DEBUG;
  }
  assert ( $total_size == $self->memcached->get('size') ) if DEBUG;
  return 1;
}

# This is dangerous! It deletes *everything* stored in memcached.
sub _flush {
  my ( $self ) = @_;
  $self->memcached->flush_all;
}

sub _lock {
  my $self = CORE::shift;
  my $priority = CORE::shift;
  my ( %arg ) = (
    # The timeout below is supposed to set a timeout after which a lock is
    # automatically removed. Sounds great, and 1 second is an enternity, right?
    # WRONG! When set to 1, some of the test scripts sometimes fail due to a lock
    # being deleted by memcached. Which is very strange as a 1 second timeout for
    # just 1 single lock is a lot for a script that on my system requires less
    # than 300 msec to do everything... Conclusion: don't set this to 1!
    # 0, on the other hand, should be ok, as it means 'no timeout'.
    'timeout' => 2,
    @_
  );

  confess("Timeout must not be '1'") if $arg{'timeout'} == 1;

  while (1) {
    my $have_lock = $self->memcached->add("$priority:lock", $$, $arg{'timeout'});
    last if $have_lock;
    sleep(.1);
  }

  affirm {
    my $locked_by = $self->memcached->get("$priority:lock");
    $$ == $locked_by;
  };
}

sub _unlock {
  my ( $self, $priority ) = @_;

  affirm {
    my $locked_by = $self->memcached->get("$priority:lock");
    $$ == $locked_by;
  };

  $self->memcached->delete("$priority:lock");
}

no Moose;
__PACKAGE__->meta->make_immutable;

=head1 AUTHOR

Peter Haijen, C<< <peterhaijen at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-cache-memcached-pdeque at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Cache-Memcached-PDeque>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Cache::Memcached::PDeque


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Cache-Memcached-PDeque>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Cache-Memcached-PDeque>

=item * Search CPAN

L<https://metacpan.org/release/Cache-Memcached-PDeque>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2024 by Peter Haijen.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)


=cut