File Coverage

blib/lib/Mutex/Util.pm
Criterion Covered Total %
statement 35 90 38.8
branch 6 60 10.0
condition 0 6 0.0
subroutine 9 14 64.2
pod 4 4 100.0
total 54 174 31.0


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Utility functions for Mutex.
4             ##
5             ###############################################################################
6              
7             package Mutex::Util;
8              
9 2     2   872 use strict;
  2         4  
  2         47  
10 2     2   8 use warnings;
  2         2  
  2         46  
11              
12 2     2   7 no warnings qw( threads recursion uninitialized );
  2         4  
  2         80  
13              
14             our $VERSION = '1.009';
15              
16             ## no critic (BuiltinFunctions::ProhibitStringyEval)
17              
18 2     2   951 use IO::Handle ();
  2         10598  
  2         45  
19 2     2   936 use Socket qw( AF_UNIX );
  2         6621  
  2         251  
20 2     2   388 use Errno ();
  2         1117  
  2         173  
21              
22             my ($is_winenv, $zero_bytes, %sock_ready);
23              
24             BEGIN {
25 2 50   2   16 $is_winenv = ( $^O =~ /mswin|mingw|msys|cygwin/i ) ? 1 : 0;
26 2         1941 $zero_bytes = pack('L', 0);
27             }
28              
29             sub CLONE {
30 0     0   0 %sock_ready = ();
31             }
32              
33             ###############################################################################
34             ## ----------------------------------------------------------------------------
35             ## Public functions.
36             ##
37             ###############################################################################
38              
39             sub destroy_pipes {
40 2     2 1 5 my ($obj, @params) = @_;
41 2         4 local ($!,$?); local $SIG{__DIE__};
  2         7  
42              
43 2         3 for my $p (@params) {
44 4 50       9 next unless (defined $obj->{$p});
45              
46 4 50       9 if (ref $obj->{$p} eq 'ARRAY') {
47 0         0 for my $i (0 .. @{ $obj->{$p} } - 1) {
  0         0  
48 0 0       0 next unless (defined $obj->{$p}[$i]);
49 0 0       0 close $obj->{$p}[$i] if (fileno $obj->{$p}[$i]);
50 0         0 undef $obj->{$p}[$i];
51             }
52             }
53             else {
54 4 50       45 close $obj->{$p} if (fileno $obj->{$p});
55 4         15 undef $obj->{$p};
56             }
57             }
58              
59 2         11 return;
60             }
61              
62             sub destroy_socks {
63 0     0 1 0 my ($obj, @params) = @_;
64 0         0 local ($!,$?,$@); local $SIG{__DIE__};
  0         0  
65              
66 0         0 for my $p (@params) {
67 0 0       0 next unless (defined $obj->{$p});
68              
69 0 0       0 if (ref $obj->{$p} eq 'ARRAY') {
70 0         0 for my $i (0 .. @{ $obj->{$p} } - 1) {
  0         0  
71 0 0       0 next unless (defined $obj->{$p}[$i]);
72 0 0       0 if (fileno $obj->{$p}[$i]) {
73 0 0       0 syswrite($obj->{$p}[$i], '0') if $is_winenv;
74 0         0 eval q{ CORE::shutdown($obj->{$p}[$i], 2) };
75 0         0 close $obj->{$p}[$i];
76             }
77 0         0 undef $obj->{$p}[$i];
78             }
79             }
80             else {
81 0 0       0 if (fileno $obj->{$p}) {
82 0 0       0 syswrite($obj->{$p}, '0') if $is_winenv;
83 0         0 eval q{ CORE::shutdown($obj->{$p}, 2) };
84 0         0 close $obj->{$p};
85             }
86 0         0 undef $obj->{$p};
87             }
88             }
89              
90 0         0 return;
91             }
92              
93             sub pipe_pair {
94 2     2 1 3 my ($obj, $r_sock, $w_sock, $i) = @_;
95 2         13 local $!;
96              
97 2 50       4 if (defined $i) {
98             # remove tainted'ness
99 0         0 ($i) = $i =~ /(.*)/;
100 0 0       0 pipe($obj->{$r_sock}[$i], $obj->{$w_sock}[$i]) or die "pipe: $!\n";
101 0         0 $obj->{$w_sock}[$i]->autoflush(1);
102             }
103             else {
104 2 50       63 pipe($obj->{$r_sock}, $obj->{$w_sock}) or die "pipe: $!\n";
105 2         12 $obj->{$w_sock}->autoflush(1);
106             }
107              
108 2         77 return;
109             }
110              
111             sub sock_pair {
112 0     0 1   my ($obj, $r_sock, $w_sock, $i) = @_;
113 0           local $!;
114              
115 0 0         if (defined $i) {
116             # remove tainted'ness
117 0           ($i) = $i =~ /(.*)/;
118 0 0         socketpair( $obj->{$r_sock}[$i], $obj->{$w_sock}[$i],
119             AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n";
120 0           $obj->{$r_sock}[$i]->autoflush(1);
121 0           $obj->{$w_sock}[$i]->autoflush(1);
122             }
123             else {
124 0 0         socketpair( $obj->{$r_sock}, $obj->{$w_sock},
125             AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n";
126 0           $obj->{$r_sock}->autoflush(1);
127 0           $obj->{$w_sock}->autoflush(1);
128             }
129              
130 0           return;
131             }
132              
133             sub _sock_ready {
134 0     0     my ($socket, $timeout) = @_;
135 0 0 0       return '' if !defined $timeout && $sock_ready{"$socket"} > 1;
136              
137 0           my ($val_bytes, $delay, $start) = (pack('L', 0), 0, time);
138              
139 0 0         if (!defined $timeout) {
140 0           $sock_ready{"$socket"}++;
141             }
142             else {
143 0 0         $timeout = undef if $timeout < 0;
144 0 0         $timeout += $start if $timeout;
145             }
146              
147 0           while (1) {
148             # MSWin32 FIONREAD - from winsock2.h macro
149 0           ioctl($socket, 0x4004667f, $val_bytes);
150              
151 0 0         return '' if $val_bytes ne $zero_bytes;
152 0 0 0       return 1 if $timeout && time > $timeout;
153              
154             # delay after a while to not consume a CPU core
155 0 0         sleep(0.015), next if $delay;
156 0 0         $delay = 1 if time - $start > 0.030;
157             }
158             }
159              
160             sub _sysread {
161             ( @_ == 3
162             ? CORE::sysread($_[0], $_[1], $_[2])
163             : CORE::sysread($_[0], $_[1], $_[2], $_[3])
164             )
165 0 0   0     or do {
    0          
166 0 0         goto \&_sysread if ($! == Errno::EINTR());
167             };
168             }
169              
170             1;
171              
172             __END__