Commit | Line | Data |
---|---|---|
11a11ecf FC |
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 | ||
60b22aca JD |
48 | if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { |
49 | $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; | |
11a11ecf FC |
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); |