@@ -13,16 +13,12 @@ BEGIN {
1313 skip_all_if_miniperl(" no dynamic loading on miniperl, no threads"
1414 skip_all(" runs out of memory on some EBCDIC" if $ENV {PERL_SKIP_BIG_MEM_TESTS };
1515
16- plan(6 );
16+ plan(1 );
1717}
1818
1919use strict;
2020use warnings;
2121use threads;
22- use threads::shared;
23- use File::Path;
24- use File::Spec::Functions qw ' updir catdir'
25- use Cwd ' getcwd'
2622
2723# Basic sanity check: make sure this does not crash
2824fresh_perl_is <<'# this is no comment' ' ok' ' crash when duping dirh'
@@ -31,101 +27,3 @@ fresh_perl_is <<'# this is no comment', 'ok', {}, 'crash when duping dirh';
3127 async{}->join for 1..2;
3228 print "ok";
3329# this is no comment
34-
35- my $dir ;
36- SKIP: {
37- skip " telldir or seekdir not defined on this platform"
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 // 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*)"
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 );
0 commit comments