view release on metacpan or  search on metacpan

lib/IPC/SRLock.pm  view on Meta::CPAN

around 'BUILDARGS' => sub {
   my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args );

   my $builder = $attr->{builder};
   my $conf    = $builder && $builder->can( 'config' ) ? $builder->config : 0;

   $conf and $conf->can( 'lock_attributes' )
         and merge_attributes $attr, $conf->lock_attributes,
                           [ keys %{ $conf->lock_attributes } ];

   $attr->{name} //= lc join '_', split m{ :: }mx, __PACKAGE__, -1;

   my $type = delete $attr->{type}; $attr = { _implementation_attr => $attr };

   $type and $type !~ m{ \A ([a-zA-Z0-9\:\+]+) \z }mx
         and die "Type ${type} tainted";
   $type and $attr->{type} = $1;

   return $attr;
};

lib/IPC/SRLock/Memcached.pm  view on Meta::CPAN

my $_list = sub {
   my $self = shift;

   $self->memd->add( $self->lockfile, 1, $self->patience + 30 ) or return 0;

   my $shm_content = $self->memd->get( $self->shmfile ) // {};
   my $list        = []; $self->$_unlock_share;

   for my $key (sort keys %{ $shm_content }) {
      my @fields = split m{ , }mx, $shm_content->{ $key };

      push @{ $list }, { key     => $key,
                         pid     => $fields[ 0 ],
                         stime   => $fields[ 1 ],
                         timeout => $fields[ 2 ] };
   }

   return $list;
};

my $_reset = sub {
   my ($self, $args, $now) = @_; my $key = $args->{k}; my $pid = $args->{p};

   $self->memd->add( $self->lockfile, 1, $self->patience + 30 ) or return 0;

   my $shm_content = $self->memd->get( $self->shmfile ) // {};

   my $lock; exists $shm_content->{ $key }
      and $lock = $shm_content->{ $key }
      and (split m{ , }mx, $lock)[ 0 ] != $pid
      and $self->$_unlock_share
      and throw 'Lock [_1] set by another process', [ $key ];

   not delete $shm_content->{ $key } and $self->$_unlock_share
      and throw 'Lock [_1] not set', [ $key ];

   $self->memd->set( $self->shmfile, $shm_content ); $self->$_unlock_share;
   return 1;
};

my $_set = sub {
   my ($self, $args, $now) = @_;

   my $key = $args->{k}; my $pid = $args->{p}; my $timeout = $args->{t};

   $self->memd->add( $self->lockfile, 1, $self->patience + 30 ) or return 0;

   my $shm_content = $self->memd->get( $self->shmfile ) // {}; my $lock;

   if ($lock = $shm_content->{ $key }) {
      my @fields = split m{ , }mx, $lock;

      $fields[ 2 ] and $now > $fields[ 1 ] + $fields[ 2 ]
         and $lock = $self->$_expire_lock( $shm_content, $key, @fields );
   }

   $lock and $self->$_unlock_share and return 0;

   $shm_content->{ $key } = "${pid},${now},${timeout}";
   $self->memd->set( $self->shmfile, $shm_content ); $self->$_unlock_share;
   $self->log->debug( "Lock ${key} set by ${pid}" );