1#!perl
2
3# Test interaction of threads and directory handles.
4
5BEGIN {
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
19use strict;
20use warnings;
21use threads;
22use threads::shared;
23use File::Path;
24use File::Spec::Functions qw 'updir catdir';
25use Cwd 'getcwd';
26
27# Basic sanity check: make sure this does not crash
28fresh_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
35my $dir;
36SKIP: {
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}
131rmtree($dir);
132