Movatterモバイル変換

[0]ホーム
URL:

Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly

 Sign up
Appearance settings
/perl5Public

Commit11a11ec

Browse files
author
Father Chrysostomos
committed
[perl #75174] Clone dir handles
On systems that support fchdir, use it to clone dir handles.On other systems, at least for now, don’t give the new thread a copyof the handle. This is not ideal, but better than crashing.
1 parent6034bce commit11a11ec

File tree

3 files changed

+224
-2
lines changed

3 files changed

+224
-2
lines changed

‎MANIFEST

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4653,6 +4653,7 @@ t/op/symbolcache.tSee if undef/delete works on stashes with functions
46534653
t/op/sysio.tSee if sysread and syswrite work
46544654
t/op/taint.tSee if tainting works
46554655
t/op/threads_create.plAncillary file for t/op/threads.t
4656+
t/op/threads-dirh.tTest interaction of threads and dir handles
46564657
t/op/threads.tMisc. tests for perl features with threads
46574658
t/op/tiearray.tSee if tie for arrays works
46584659
t/op/tie_fetch_count.tSee if FETCH is only called once on tied variables

‎sv.c

Lines changed: 92 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10838,11 +10838,101 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
1083810838
DIR*
1083910839
Perl_dirp_dup(pTHX_DIR*constdp)
1084010840
{
10841+
#ifdefHAS_FCHDIR
10842+
DIR*ret;
10843+
DIR*pwd;
10844+
registerconstDirentry_t*dirent;
10845+
charsmallbuf[256];
10846+
char*name=NULL;
10847+
STRLENlen=-1;
10848+
longpos;
10849+
#endif
10850+
1084110851
PERL_UNUSED_CONTEXT;
10852+
10853+
#ifdefHAS_FCHDIR
1084210854
if (!dp)
1084310855
return (DIR*)NULL;
10844-
/* XXX TODO */
10845-
returndp;
10856+
/* look for it in the table first */
10857+
ret= (DIR*)ptr_table_fetch(PL_ptr_table,dp);
10858+
if (ret)
10859+
returnret;
10860+
10861+
/* create anew */
10862+
10863+
/* open the current directory (so we can switch back) */
10864+
if (!(pwd=PerlDir_open(".")))return (DIR*)NULL;
10865+
10866+
/* chdir to our dir handle and open the present working directory */
10867+
if (fchdir(my_dirfd(dp))<0|| !(ret=PerlDir_open("."))) {
10868+
PerlDir_close(pwd);
10869+
return (DIR*)NULL;
10870+
}
10871+
/* Now we should have two dir handles pointing to the same dir. */
10872+
10873+
/* Be nice to the calling code and chdir back to where we were. */
10874+
fchdir(my_dirfd(pwd));/* If this fails, then what? */
10875+
10876+
/* We have no need of the pwd handle any more. */
10877+
PerlDir_close(pwd);
10878+
10879+
#ifdefDIRNAMLEN
10880+
# defined_namlen(d) (d)->d_namlen
10881+
#else
10882+
# defined_namlen(d) strlen((d)->d_name)
10883+
#endif
10884+
/* Iterate once through dp, to get the file name at the current posi-
10885+
tion. Then step back. */
10886+
pos=PerlDir_tell(dp);
10887+
if ((dirent=PerlDir_read(dp))) {
10888+
len=d_namlen(dirent);
10889+
if (len <=sizeofsmallbuf)name=smallbuf;
10890+
elseNewx(name,len,char);
10891+
Move(dirent->d_name,name,len,char);
10892+
}
10893+
PerlDir_seek(dp,pos);
10894+
10895+
/* Iterate through the new dir handle, till we find a file with the
10896+
right name. */
10897+
if (!dirent)/* just before the end */
10898+
for(;;) {
10899+
pos=PerlDir_tell(ret);
10900+
if (PerlDir_read(ret))continue;/* not there yet */
10901+
PerlDir_seek(ret,pos);/* step back */
10902+
break;
10903+
}
10904+
else {
10905+
constlongpos0=PerlDir_tell(ret);
10906+
for(;;) {
10907+
pos=PerlDir_tell(ret);
10908+
if ((dirent=PerlDir_read(ret))) {
10909+
if (len==d_namlen(dirent)
10910+
&&memEQ(name,dirent->d_name,len)) {
10911+
/* found it */
10912+
PerlDir_seek(ret,pos);/* step back */
10913+
break;
10914+
}
10915+
/* else we are not there yet; keep iterating */
10916+
}
10917+
else {/* This is not meant to happen. The best we can do is
10918+
reset the iterator to the beginning. */
10919+
PerlDir_seek(ret,pos0);
10920+
break;
10921+
}
10922+
}
10923+
}
10924+
#undef d_namlen
10925+
10926+
if (name&&name!=smallbuf)
10927+
Safefree(name);
10928+
10929+
/* pop it in the pointer table */
10930+
ptr_table_store(PL_ptr_table,dp,ret);
10931+
10932+
returnret;
10933+
#else
10934+
return (DIR*)NULL;
10935+
#endif
1084610936
}
1084710937

1084810938
/* duplicate a typeglob */

‎t/op/threads-dirh.t

Lines changed: 131 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,131 @@
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::Functionsqw '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$$" .intrand() * 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+
{openmy$fh,">thrit"or &$skip("Cannot create file thrit")}
75+
{openmy$fh,">rile"or &$skip("Cannot create file rile")}
76+
{openmy$fh,">zor"or &$skip("Cannot create file zor")}
77+
chdir updir;
78+
79+
# Then test that dir iterators are cloned correctly.
80+
81+
opendirmy$toberead,'toberead';
82+
my$start_pos =telldir$toberead;
83+
my@first_2 = (scalarreaddir$toberead,scalarreaddir$toberead);
84+
my@from_thread = @{; async { [readdir$toberead ] }->join };
85+
my@from_main =readdir$toberead;
86+
isjoin('-',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$tobereadfor 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+
openmy$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+
opendirmy$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+
islength async {scalarreaddir$dirh }->join, 257,$test_name;
126+
}
127+
128+
isscalar@w, 0,'no warnings during all that'or diag@w;
129+
chdir updir;
130+
}
131+
rmtree($dir);

0 commit comments

Comments
 (0)
[8]ページ先頭
©2009-2025 Movatter.jp