/usr/share/perl5/MCE/Mutex/Channel.pm is in libmce-perl 1.833-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | ###############################################################################
## ----------------------------------------------------------------------------
## MCE::Mutex::Channel - Mutex locking via a pipe or socket.
##
###############################################################################
package MCE::Mutex::Channel;
use strict;
use warnings;
no warnings qw( threads recursion uninitialized once );
our $VERSION = '1.833';
use base 'MCE::Mutex';
use Scalar::Util qw(refaddr weaken);
use MCE::Util ();
my $has_threads = $INC{'threads.pm'} ? 1 : 0;
my $tid = $has_threads ? threads->tid() : 0;
my @MUTEX;
sub CLONE {
$tid = threads->tid() if $has_threads;
}
sub DESTROY {
my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_);
syswrite($obj->{_w_sock}, '0'), $obj->{ $pid } = 0 if $obj->{ $pid };
if ($obj->{'_init_pid'} eq $pid) {
my $addr = refaddr $obj;
($^O eq 'MSWin32')
? MCE::Util::_destroy_pipes($obj, qw(_w_sock _r_sock))
: MCE::Util::_destroy_socks($obj, qw(_w_sock _r_sock));
@MUTEX = map { refaddr($_) == $addr ? () : $_ } @MUTEX;
}
return;
}
sub _destroy {
# Called by MCE::_exit && MCE::Hobo::_exit. Must iterate a copy.
if ( @MUTEX ) { local $_; &DESTROY($_) for @{[ @MUTEX ]}; }
}
###############################################################################
## ----------------------------------------------------------------------------
## Public methods.
##
###############################################################################
sub new {
my ($class, %obj) = (@_, impl => 'Channel');
$obj{'_init_pid'} = $has_threads ? $$ .'.'. $tid : $$;
($^O eq 'MSWin32')
? MCE::Util::_pipe_pair(\%obj, qw(_r_sock _w_sock))
: MCE::Util::_sock_pair(\%obj, qw(_r_sock _w_sock));
1 until syswrite($obj{_w_sock}, '0') || ($! && !$!{'EINTR'});
if (caller !~ /^MCE:?/ || caller(1) !~ /^MCE:?/) {
push(@MUTEX, \%obj); weaken($MUTEX[-1]);
}
return bless(\%obj, $class);
}
sub lock {
my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_);
sysread($obj->{_r_sock}, my($b), 1), $obj->{ $pid } = 1
unless $obj->{ $pid };
return;
}
*lock_exclusive = \&lock;
*lock_shared = \&lock;
sub unlock {
my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_);
syswrite($obj->{_w_sock}, '0'), $obj->{ $pid } = 0
if $obj->{ $pid };
return;
}
sub synchronize {
my ($pid, $obj, $code, @ret) = (
$has_threads ? $$ .'.'. $tid : $$, shift, shift
);
return unless ref($code) eq 'CODE';
# lock, run, unlock - inlined for performance
sysread($obj->{_r_sock}, my($b), 1), $obj->{ $pid } = 1
unless $obj->{ $pid };
(defined wantarray)
? @ret = wantarray ? $code->(@_) : scalar $code->(@_)
: $code->(@_);
syswrite($obj->{_w_sock}, '0'), $obj->{ $pid } = 0;
return wantarray ? @ret : $ret[-1];
}
*enter = \&synchronize;
1;
__END__
###############################################################################
## ----------------------------------------------------------------------------
## Module usage.
##
###############################################################################
=head1 NAME
MCE::Mutex::Channel - Mutex locking via a pipe or socket
=head1 VERSION
This document describes MCE::Mutex::Channel version 1.833
=head1 DESCRIPTION
A pipe-socket implementation for L<MCE::Mutex>. See documentation there.
=head1 AUTHOR
Mario E. Roy, S<E<lt>marioeroy AT gmail DOT comE<gt>>
=cut
|