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; | |
9c8416b2 | 12 | skip_all_without_config('useithreads'); |
62e452a4 | 13 | skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); |
11a11ecf FC |
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 | my $skip = sub { | |
37 | chdir($dir); | |
38 | chdir updir; | |
39 | skip $_[0], 5 | |
40 | }; | |
41 | ||
60b22aca JD |
42 | if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { |
43 | $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; | |
11a11ecf FC |
44 | } |
45 | ||
46 | my @w :shared; # warnings accumulator | |
47 | local $SIG{__WARN__} = sub { push @w, $_[0] }; | |
48 | ||
49 | $dir = catdir getcwd(), "thrext$$" . int rand() * 100000; | |
50 | ||
51 | rmtree($dir); | |
52 | mkdir($dir); | |
53 | ||
54 | # Create a dir structure like this: | |
55 | # $dir | |
56 | # | | |
57 | # `- toberead | |
58 | # | | |
59 | # +---- thrit | |
60 | # | | |
61 | # +---- rile | |
62 | # | | |
63 | # `---- zor | |
64 | ||
65 | chdir($dir); | |
66 | mkdir 'toberead'; | |
67 | chdir 'toberead'; | |
68 | {open my $fh, ">thrit" or &$skip("Cannot create file thrit")} | |
69 | {open my $fh, ">rile" or &$skip("Cannot create file rile")} | |
70 | {open my $fh, ">zor" or &$skip("Cannot create file zor")} | |
71 | chdir updir; | |
72 | ||
73 | # Then test that dir iterators are cloned correctly. | |
74 | ||
75 | opendir my $toberead, 'toberead'; | |
76 | my $start_pos = telldir $toberead; | |
77 | my @first_2 = (scalar readdir $toberead, scalar readdir $toberead); | |
78 | my @from_thread = @{; async { [readdir $toberead ] } ->join }; | |
79 | my @from_main = readdir $toberead; | |
80 | is join('-', sort @from_thread), join('-', sort @from_main), | |
81 | 'dir iterator is copied from one thread to another'; | |
82 | like | |
83 | join('-', "", sort(@first_2, @from_thread), ""), | |
84 | qr/(?<!-rile)-rile-thrit-zor-(?!zor-)/i, | |
85 | 'cloned iterator iterates exactly once over everything not already seen'; | |
86 | ||
87 | seekdir $toberead, $start_pos; | |
88 | readdir $toberead for 1 .. @first_2+@from_thread; | |
1ac6561f FC |
89 | { |
90 | local $::TODO; # This always passes when dir handles are not cloned. | |
91 | is | |
92 | async { readdir $toberead // 'undef' } ->join, 'undef', | |
93 | 'cloned dir iterator that points to the end of the directory' | |
94 | ; | |
95 | } | |
11a11ecf FC |
96 | |
97 | # Make sure the cloning code can handle file names longer than 255 chars | |
98 | SKIP: { | |
99 | chdir 'toberead'; | |
100 | open my $fh, | |
101 | ">floccipaucinihilopilification-" | |
102 | . "pneumonoultramicroscopicsilicovolcanoconiosis-" | |
103 | . "lopadotemachoselachogaleokranioleipsanodrimypotrimmatosilphiokarabo" | |
104 | . "melitokatakechymenokichlepikossyphophattoperisteralektryonoptokephal" | |
1c20db1b | 105 | . "liokinklopeleiolagoiosiraiobaphetraganopterygon" |
11a11ecf FC |
106 | or |
107 | chdir updir, | |
108 | skip("OS does not support long file names (and I mean *long*)", 1); | |
109 | chdir updir; | |
110 | opendir my $dirh, "toberead"; | |
111 | my $test_name | |
112 | = "dir iterators can be cloned when the next fn > 255 chars"; | |
113 | while() { | |
114 | my $pos = telldir $dirh; | |
115 | my $fn = readdir($dirh); | |
116 | if(!defined $fn) { fail($test_name); last SKIP; } | |
117 | if($fn =~ 'lagoio') { | |
118 | seekdir $dirh, $pos; | |
119 | last; | |
120 | } | |
121 | } | |
1c20db1b | 122 | is length async { scalar readdir $dirh } ->join, 258, $test_name; |
11a11ecf FC |
123 | } |
124 | ||
125 | is scalar @w, 0, 'no warnings during all that' or diag @w; | |
126 | chdir updir; | |
127 | } | |
128 | rmtree($dir); |