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 + 48 +
if(!$Config::Config{d_fchdir}) {
49 +
$::TODO = 'dir handle cloning currently requires fchdir';
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);
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4