This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #75174] Clone dir handles
[perl5.git] / 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}) {
49   $::TODO = 'dir handle cloning currently requires fchdir';
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  is
96    async { readdir $toberead // 'undef' } ->join, 'undef',
97   'cloned dir iterator that points to the end of the directory'
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    . "liokinklopeleiolagoiosiraibaphetraganopterygon"
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, 257, $test_name;
126  }
127
128  is scalar @w, 0, 'no warnings during all that' or diag @w;
129  chdir updir;
130 }
131 rmtree($dir);