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'; | |
07d51b53 | 7 | @INC = '../lib'; |
11a11ecf FC |
8 | require './test.pl'; |
9 | $| = 1; | |
624c42e2 | 10 | |
07d51b53 JK |
11 | require Config; |
12 | skip_all_without_config('useithreads'); | |
13 | skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); | |
1ce8be81 | 14 | |
07d51b53 JK |
15 | plan(6); |
16 | } | |
1ce8be81 | 17 | |
11a11ecf FC |
18 | use strict; |
19 | use warnings; | |
07d51b53 JK |
20 | use threads; |
21 | use threads::shared; | |
11a11ecf FC |
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: { | |
05fc2f9f BF |
36 | skip "telldir or seekdir not defined on this platform", 5 |
37 | if !$Config::Config{d_telldir} || !$Config::Config{d_seekdir}; | |
11a11ecf FC |
38 | my $skip = sub { |
39 | chdir($dir); | |
40 | chdir updir; | |
41 | skip $_[0], 5 | |
42 | }; | |
43 | ||
60b22aca JD |
44 | if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { |
45 | $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; | |
11a11ecf FC |
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 | ||
bfab0499 | 53 | rmtree($dir) if -d $dir; |
11a11ecf FC |
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; | |
1ac6561f FC |
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 | } | |
11a11ecf FC |
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" | |
1c20db1b | 107 | . "liokinklopeleiolagoiosiraiobaphetraganopterygon" |
11a11ecf FC |
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 | } | |
1c20db1b | 124 | is length async { scalar readdir $dirh } ->join, 258, $test_name; |
11a11ecf FC |
125 | } |
126 | ||
127 | is scalar @w, 0, 'no warnings during all that' or diag @w; | |
128 | chdir updir; | |
129 | } | |
130 | rmtree($dir); |