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
|
#!/usr/bin/perl -w
use strict;
use Test::More;
use Fcntl qw(:flock);
use POSIX qw(EWOULDBLOCK EAGAIN);
use Config;
require Fatal;
my $EWOULDBLOCK = eval { EWOULDBLOCK() }
|| $Fatal::_EWOULDBLOCK{$^O}
|| plan skip_all => "EWOULDBLOCK not defined on this system";
my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
my $EAGAIN = eval { EAGAIN() };
my ($self_fh, $self_fh2);
eval {
use autodie;
open($self_fh, '<', $0);
open($self_fh2, '<', $0);
open(SELF, '<', $0);
};
if ($@) {
plan skip_all => "Cannot lock this test on this system.";
}
my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); };
if (not $flock_return) {
plan skip_all => "flock on my own test not supported on this system.";
}
my $flock_return2 = flock($self_fh2, LOCK_EX | LOCK_NB);
if ($flock_return2) {
plan skip_all => "this test requires locking a file twice with ".
"different filehandles to fail";
}
$flock_return = flock($self_fh, LOCK_UN);
if (not $flock_return) {
plan skip_all => "Odd, I can't unlock a file with flock on this system.";
}
# If we're here, then we can lock and unlock our own file.
plan 'no_plan';
ok( flock($self_fh, LOCK_EX | LOCK_NB), "Test file locked");
my $return;
eval {
use autodie qw(flock);
$return = flock($self_fh2, LOCK_EX | LOCK_NB);
};
if (!$try_EAGAIN) {
is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK");
} else {
ok($!+0 == $EWOULDBLOCK || $!+0 == $EAGAIN, "Double-flocking should be EWOULDBLOCK or EAGAIN");
}
ok(!$return, "flocking a file twice should fail");
is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK");
__END__
# These are old tests which I'd love to resurrect, but they need
# a reliable way of getting flock to throw exceptions but with
# minimal blocking. They may turn into author tests.
eval {
use autodie;
flock($self_fh2, LOCK_EX | LOCK_NB);
};
ok($@, "Locking a file twice throws an exception with vanilla autodie");
isa_ok($@, "autodie::exception", "Exception is from autodie::exception");
like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch");
like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch");
unlike($@, qr/GLOB/ , "error doesn't include ugly GLOB mention");
eval {
use autodie;
flock(SELF, LOCK_EX | LOCK_NB);
};
ok($@, "Locking a package filehanlde twice throws exception with vanilla autodie");
isa_ok($@, "autodie::exception", "Exception is from autodie::exception");
like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch");
like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch");
like($@, qr/SELF/ , "error mentions actual filehandle name.");
|
