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