Perl_op_sibling_splice(0 remove dead code
[perl.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      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) if -d $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);