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"); | |
3f7ce339 | 14 | skip_all("runs out of memory on some EBCDIC") if $ENV{PERL_SKIP_BIG_MEM_TESTS}; |
1ce8be81 | 15 | |
07d51b53 JK |
16 | plan(6); |
17 | } | |
1ce8be81 | 18 | |
11a11ecf FC |
19 | use strict; |
20 | use warnings; | |
07d51b53 JK |
21 | use threads; |
22 | use threads::shared; | |
11a11ecf FC |
23 | use File::Path; |
24 | use File::Spec::Functions qw 'updir catdir'; | |
25 | use Cwd 'getcwd'; | |
26 | ||
27 | # Basic sanity check: make sure this does not crash | |
28 | fresh_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 | ||
35 | my $dir; | |
36 | SKIP: { | |
05fc2f9f BF |
37 | skip "telldir or seekdir not defined on this platform", 5 |
38 | if !$Config::Config{d_telldir} || !$Config::Config{d_seekdir}; | |
11a11ecf FC |
39 | my $skip = sub { |
40 | chdir($dir); | |
41 | chdir updir; | |
42 | skip $_[0], 5 | |
43 | }; | |
44 | ||
60b22aca JD |
45 | if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { |
46 | $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; | |
11a11ecf FC |
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 | ||
bfab0499 | 54 | rmtree($dir) if -d $dir; |
11a11ecf FC |
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; | |
1ac6561f FC |
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 | } | |
11a11ecf FC |
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" | |
1c20db1b | 108 | . "liokinklopeleiolagoiosiraiobaphetraganopterygon" |
11a11ecf FC |
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 | } | |
1c20db1b | 125 | is length async { scalar readdir $dirh } ->join, 258, $test_name; |
11a11ecf FC |
126 | } |
127 | ||
128 | is scalar @w, 0, 'no warnings during all that' or diag @w; | |
129 | chdir updir; | |
130 | } | |
131 | rmtree($dir); |