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