Commit | Line | Data |
0b09a93a |
1 | #!/usr/bin/perl -w |
2 | use strict; |
3 | use Test::More; |
4 | use Fcntl qw(:flock); |
5 | use POSIX qw(EWOULDBLOCK); |
6 | |
7 | require Fatal; |
8 | |
9 | my $EWOULDBLOCK = eval { EWOULDBLOCK() } |
10 | || $Fatal::_EWOULDBLOCK{$^O} |
11 | || plan skip_all => "EWOULDBLOCK not defined on this system"; |
12 | |
13 | my ($self_fh, $self_fh2); |
14 | |
15 | eval { |
16 | use autodie; |
17 | open($self_fh, '<', $0); |
18 | open($self_fh2, '<', $0); |
19 | open(SELF, '<', $0); |
20 | }; |
21 | |
22 | if ($@) { |
23 | plan skip_all => "Cannot lock this test on this system."; |
24 | } |
25 | |
5472f9ed |
26 | my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); }; |
0b09a93a |
27 | |
28 | if (not $flock_return) { |
29 | plan skip_all => "flock on my own test not supported on this system."; |
30 | } |
31 | |
32 | my $flock_return2 = flock($self_fh2, LOCK_EX | LOCK_NB); |
33 | |
34 | if ($flock_return2) { |
35 | plan skip_all => "this test requires locking a file twice with ". |
36 | "different filehandles to fail"; |
37 | } |
38 | |
39 | $flock_return = flock($self_fh, LOCK_UN); |
40 | |
41 | if (not $flock_return) { |
42 | plan skip_all => "Odd, I can't unlock a file with flock on this system."; |
43 | } |
44 | |
45 | # If we're here, then we can lock and unlock our own file. |
46 | |
47 | plan 'no_plan'; |
48 | |
49 | ok( flock($self_fh, LOCK_EX | LOCK_NB), "Test file locked"); |
50 | |
51 | my $return; |
52 | |
53 | eval { |
54 | use autodie qw(flock); |
55 | $return = flock($self_fh2, LOCK_EX | LOCK_NB); |
56 | }; |
57 | |
58 | is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); |
59 | ok(!$return, "flocking a file twice should fail"); |
60 | is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK"); |
61 | |
62 | __END__ |
63 | |
64 | # These are old tests which I'd love to resurrect, but they need |
65 | # a reliable way of getting flock to throw exceptions but with |
66 | # minimal blocking. They may turn into author tests. |
67 | |
68 | eval { |
69 | use autodie; |
70 | flock($self_fh2, LOCK_EX | LOCK_NB); |
71 | }; |
72 | |
73 | ok($@, "Locking a file twice throws an exception with vanilla autodie"); |
74 | isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); |
75 | |
76 | like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); |
77 | like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); |
78 | unlike($@, qr/GLOB/ , "error doesn't include ugly GLOB mention"); |
79 | |
80 | eval { |
81 | use autodie; |
82 | flock(SELF, LOCK_EX | LOCK_NB); |
83 | }; |
84 | |
85 | ok($@, "Locking a package filehanlde twice throws exception with vanilla autodie"); |
86 | isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); |
87 | |
88 | like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); |
89 | like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); |
90 | like($@, qr/SELF/ , "error mentions actual filehandle name."); |