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