t/op/threads-dirh.t

   1 #!perl
   2
   3 # Test interaction of threads and directory handles.
   4
   5 BEGIN {
   6      chdir 't' if -d 't';
   7      @INC = '../lib';
   8      require './test.pl';
   9      $| = 1;
  10
  11      require Config;
  12      skip_all_without_config('useithreads');
  13      skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
  14
  15      plan(6);
  16 }
  17
  18 use strict;
  19 use warnings;
  20 use threads;
  21 use threads::shared;
  22 use File::Path;
  23 use File::Spec::Functions qw 'updir catdir';
  24 use Cwd 'getcwd';
  25
  26 # Basic sanity check: make sure this does not crash
  27 fresh_perl_is <<'# this is no comment', 'ok', {}, 'crash when duping dirh';
  28    use threads;
  29    opendir dir, 'op';
  30    async{}->join for 1..2;
  31    print "ok";
  32 # this is no comment
  33
  34 my $dir;
  35 SKIP: {
  36  skip "telldir or seekdir not defined on this platform", 5
  37     if !$Config::Config{d_telldir} || !$Config::Config{d_seekdir};
  38  my $skip = sub {
  39    chdir($dir);
  40    chdir updir;
  41    skip $_[0], 5
  42  };
  43
  44  if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") {
  45   $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms';
  46  }
  47
  48  my @w :shared; # warnings accumulator
  49  local $SIG{__WARN__} = sub { push @w, $_[0] };
  50
  51  $dir = catdir getcwd(), "thrext$$" . int rand() * 100000;
  52
  53  rmtree($dir);
  54  mkdir($dir);
  55
  56  # Create a dir structure like this:
  57  #   $dir
  58  #     |
  59  #     `- toberead
  60  #            |
  61  #            +---- thrit
  62  #            |
  63  #            +---- rile
  64  #            |
  65  #            `---- zor
  66
  67  chdir($dir);
  68  mkdir 'toberead';
  69  chdir 'toberead';
  70  {open my $fh, ">thrit" or &$skip("Cannot create file thrit")}
  71  {open my $fh, ">rile" or &$skip("Cannot create file rile")}
  72  {open my $fh, ">zor" or &$skip("Cannot create file zor")}
  73  chdir updir;
  74
  75  # Then test that dir iterators are cloned correctly.
  76
  77  opendir my $toberead, 'toberead';
  78  my $start_pos = telldir $toberead;
  79  my @first_2 = (scalar readdir $toberead, scalar readdir $toberead);
  80  my @from_thread = @{; async { [readdir $toberead ] } ->join };
  81  my @from_main = readdir $toberead;
  82  is join('-', sort @from_thread), join('-', sort @from_main),
  83      'dir iterator is copied from one thread to another';
  84  like
  85    join('-', "", sort(@first_2, @from_thread), ""),
  86    qr/(?<!-rile)-rile-thrit-zor-(?!zor-)/i,
  87   'cloned iterator iterates exactly once over everything not already seen';
  88
  89  seekdir $toberead, $start_pos;
  90  readdir $toberead for 1 .. @first_2+@from_thread;
  91  {
  92   local $::TODO; # This always passes when dir handles are not cloned.
  93   is
  94     async { readdir $toberead // 'undef' } ->join, 'undef',
  95    'cloned dir iterator that points to the end of the directory'
  96   ;
  97  }
  98
  99  # Make sure the cloning code can handle file names longer than 255 chars
 100  SKIP: {
 101   chdir 'toberead';
 102   open my $fh,
 103     ">floccipaucinihilopilification-"
 104    . "pneumonoultramicroscopicsilicovolcanoconiosis-"
 105    . "lopadotemachoselachogaleokranioleipsanodrimypotrimmatosilphiokarabo"
 106    . "melitokatakechymenokichlepikossyphophattoperisteralektryonoptokephal"
 107    . "liokinklopeleiolagoiosiraiobaphetraganopterygon"
 108     or
 109      chdir updir,
 110      skip("OS does not support long file names (and I mean *long*)", 1);
 111   chdir updir;
 112   opendir my $dirh, "toberead";
 113   my $test_name
 114     = "dir iterators can be cloned when the next fn > 255 chars";
 115   while() {
 116    my $pos = telldir $dirh;
 117    my $fn = readdir($dirh);
 118    if(!defined $fn) { fail($test_name); last SKIP; }
 119    if($fn =~ 'lagoio') {
 120     seekdir $dirh, $pos;
 121     last;
 122    }
 123   }
 124   is length async { scalar readdir $dirh } ->join, 258, $test_name;
 125  }
 126
 127  is scalar @w, 0, 'no warnings during all that' or diag @w;
 128  chdir updir;
 129 }
 130 rmtree($dir);