cpan/autodie/t/flock.t

   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
  26 my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); };
  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.");