Subject: [PATCH] CVE-2025-40909: Clone dirhandles without fchdir This uses fdopendir and dup to dirhandles. This means it won't change working directory during thread cloning, which prevents race conditions that can happen if a third thread is active at the same time. Backport commit 918bfff86ca8d6d4e4ec5b30994451e0bd74aba9 diff -up perl-5.26.3/Configure.cve1 perl-5.26.3/Configure --- perl-5.26.3/Configure.cve1 2025-07-01 16:14:01.993333056 +0200 +++ perl-5.26.3/Configure 2025-07-01 16:17:14.176225381 +0200 @@ -477,6 +477,7 @@ d_fd_set='' d_fds_bits='' d_fdclose='' d_fdim='' +d_fdopendir='' d_fegetround='' d_fgetpos='' d_finite='' @@ -13432,6 +13433,10 @@ esac set i_fcntl eval $setvar +: see if fdopendir exists +set fdopendir d_fdopendir +eval $inlibc + : see if fork exists set fork d_fork eval $inlibc @@ -24553,6 +24558,7 @@ d_flockproto='$d_flockproto' d_fma='$d_fma' d_fmax='$d_fmax' d_fmin='$d_fmin' +d_fdopendir='$d_fdopendir' d_fork='$d_fork' d_fp_class='$d_fp_class' d_fp_classify='$d_fp_classify' diff -up perl-5.26.3/Cross/config.sh-arm-linux.cve1 perl-5.26.3/Cross/config.sh-arm-linux --- perl-5.26.3/Cross/config.sh-arm-linux.cve1 2025-07-01 16:14:02.356103884 +0200 +++ perl-5.26.3/Cross/config.sh-arm-linux 2025-07-01 16:22:47.326303792 +0200 @@ -209,6 +209,7 @@ d_fd_macros='define' d_fd_set='define' d_fdclose='undef' d_fdim='undef' +d_fdopendir=undef d_fds_bits='undef' d_fegetround='define' d_fgetpos='define' diff -up perl-5.26.3/Cross/config.sh-arm-linux-n770.cve1 perl-5.26.3/Cross/config.sh-arm-linux-n770 --- perl-5.26.3/Cross/config.sh-arm-linux-n770.cve1 2025-07-01 16:14:02.356465600 +0200 +++ perl-5.26.3/Cross/config.sh-arm-linux-n770 2025-07-01 16:52:20.320275584 +0200 @@ -182,6 +182,7 @@ d_fcntl='define' d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' +d_fdopendir=undef d_fds_bits='undef' d_fgetpos='define' d_finite='define' diff -up perl-5.26.3/Porting/Glossary.cve1 perl-5.26.3/Porting/Glossary --- perl-5.26.3/Porting/Glossary.cve1 2018-03-23 20:34:30.000000000 +0100 +++ perl-5.26.3/Porting/Glossary 2025-07-01 16:14:02.357025809 +0200 @@ -928,6 +928,11 @@ d_fmin (d_fmin.U): This variable conditionally defines the HAS_FMIN symbol, which indicates to the C program that the fmin() routine is available. +d_fdopendir (d_fdopendir.U): + This variable conditionally defines the HAS_FORK symbol, which + indicates that the fdopen routine is available to open a + directory descriptor. + d_fork (d_fork.U): This variable conditionally defines the HAS_FORK symbol, which indicates to the C program that the fork() routine is available. diff -up perl-5.26.3/Porting/config.sh.cve1 perl-5.26.3/Porting/config.sh --- perl-5.26.3/Porting/config.sh.cve1 2025-07-01 16:14:02.357538931 +0200 +++ perl-5.26.3/Porting/config.sh 2025-07-01 17:00:56.990037450 +0200 @@ -218,6 +218,7 @@ d_fd_macros='define' d_fd_set='define' d_fdclose='undef' d_fdim='define' +d_fdopendir='define' d_fds_bits='define' d_fegetround='define' d_fgetpos='define' diff -up perl-5.26.3/config_h.SH.cve1 perl-5.26.3/config_h.SH --- perl-5.26.3/config_h.SH.cve1 2018-03-23 20:34:31.000000000 +0100 +++ perl-5.26.3/config_h.SH 2025-07-01 16:14:02.357918043 +0200 @@ -168,6 +168,12 @@ sed <$CONFIG_H -e 's!^#und */ #$d_fcntl HAS_FCNTL /**/ +/* HAS_FDOPENDIR: + * This symbol, if defined, indicates that the fdopen routine is + * available to open a directory descriptor. + */ +#$d_fdopendir HAS_FDOPENDIR /**/ + /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). diff -up perl-5.26.3/configure.com.cve1 perl-5.26.3/configure.com --- perl-5.26.3/configure.com.cve1 2025-07-01 16:14:02.358633549 +0200 +++ perl-5.26.3/configure.com 2025-07-01 17:03:59.095435784 +0200 @@ -6048,6 +6048,7 @@ $ WC "d_fd_set='" + d_fd_set + "'" $ WC "d_fd_macros='define'" $ WC "d_fdclose='undef'" $ WC "d_fdim='" + d_fdim + "'" +$ WC "d_fdopendir='undef'" $ WC "d_fds_bits='define'" $ WC "d_fegetround='undef'" $ WC "d_fgetpos='define'" diff -up perl-5.26.3/plan9/config_sh.sample.cve1 perl-5.26.3/plan9/config_sh.sample --- perl-5.26.3/plan9/config_sh.sample.cve1 2025-07-01 16:14:02.359271688 +0200 +++ perl-5.26.3/plan9/config_sh.sample 2025-07-01 17:06:27.780427041 +0200 @@ -209,6 +209,7 @@ d_fd_macros='undef' d_fd_set='undef' d_fdclose='undef' d_fdim='undef' +d_fdopendir=undef d_fds_bits='undef' d_fegetround='undef' d_fgetpos='define' diff -up perl-5.26.3/sv.c.cve1 perl-5.26.3/sv.c --- perl-5.26.3/sv.c.cve1 2025-07-01 16:14:02.026333724 +0200 +++ perl-5.26.3/sv.c 2025-07-01 17:13:18.322638398 +0200 @@ -13296,15 +13296,6 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE { DIR *ret; -#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) - DIR *pwd; - const Direntry_t *dirent; - char smallbuf[256]; /* XXX MAXPATHLEN, surely? */ - char *name = NULL; - STRLEN len = 0; - long pos; -#endif - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_DIRP_DUP; @@ -13316,89 +13307,13 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE if (ret) return ret; -#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) +#ifdef HAS_FDOPENDIR PERL_UNUSED_ARG(param); - /* create anew */ - - /* open the current directory (so we can switch back) */ - if (!(pwd = PerlDir_open("."))) return (DIR *)NULL; - - /* chdir to our dir handle and open the present working directory */ - if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) { - PerlDir_close(pwd); - return (DIR *)NULL; - } - /* Now we should have two dir handles pointing to the same dir. */ - - /* Be nice to the calling code and chdir back to where we were. */ - /* XXX If this fails, then what? */ - PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd))); - - /* We have no need of the pwd handle any more. */ - PerlDir_close(pwd); - -#ifdef DIRNAMLEN -# define d_namlen(d) (d)->d_namlen -#else -# define d_namlen(d) strlen((d)->d_name) -#endif - /* Iterate once through dp, to get the file name at the current posi- - tion. Then step back. */ - pos = PerlDir_tell(dp); - if ((dirent = PerlDir_read(dp))) { - len = d_namlen(dirent); - if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) { - /* If the len is somehow magically longer than the - * maximum length of the directory entry, even though - * we could fit it in a buffer, we could not copy it - * from the dirent. Bail out. */ - PerlDir_close(ret); - return (DIR*)NULL; - } - if (len <= sizeof smallbuf) name = smallbuf; - else Newx(name, len, char); - Move(dirent->d_name, name, len, char); - } - PerlDir_seek(dp, pos); - - /* Iterate through the new dir handle, till we find a file with the - right name. */ - if (!dirent) /* just before the end */ - for(;;) { - pos = PerlDir_tell(ret); - if (PerlDir_read(ret)) continue; /* not there yet */ - PerlDir_seek(ret, pos); /* step back */ - break; - } - else { - const long pos0 = PerlDir_tell(ret); - for(;;) { - pos = PerlDir_tell(ret); - if ((dirent = PerlDir_read(ret))) { - if (len == (STRLEN)d_namlen(dirent) - && memEQ(name, dirent->d_name, len)) { - /* found it */ - PerlDir_seek(ret, pos); /* step back */ - break; - } - /* else we are not there yet; keep iterating */ - } - else { /* This is not meant to happen. The best we can do is - reset the iterator to the beginning. */ - PerlDir_seek(ret, pos0); - break; - } - } - } -#undef d_namlen - - if (name && name != smallbuf) - Safefree(name); -#endif + ret = fdopendir(dup(my_dirfd(dp))); -#ifdef WIN32 +#elif defined(WIN32) ret = win32_dirp_dup(dp, param); #endif diff -up perl-5.26.3/t/op/threads-dirh.t.cve1 perl-5.26.3/t/op/threads-dirh.t --- perl-5.26.3/t/op/threads-dirh.t.cve1 2018-03-01 13:19:45.000000000 +0100 +++ perl-5.26.3/t/op/threads-dirh.t 2025-07-01 17:14:31.513499120 +0200 @@ -12,16 +12,12 @@ BEGIN { skip_all_without_config('useithreads'); skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); - plan(6); + plan(1); } use strict; use warnings; use threads; -use threads::shared; -use File::Path; -use File::Spec::Functions qw 'updir catdir'; -use Cwd 'getcwd'; # Basic sanity check: make sure this does not crash fresh_perl_is <<'# this is no comment', 'ok', {}, 'crash when duping dirh'; @@ -30,101 +26,3 @@ fresh_perl_is <<'# this is no comment', async{}->join for 1..2; print "ok"; # this is no comment - -my $dir; -SKIP: { - skip "telldir or seekdir not defined on this platform", 5 - if !$Config::Config{d_telldir} || !$Config::Config{d_seekdir}; - my $skip = sub { - chdir($dir); - chdir updir; - skip $_[0], 5 - }; - - if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { - $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; - } - - my @w :shared; # warnings accumulator - local $SIG{__WARN__} = sub { push @w, $_[0] }; - - $dir = catdir getcwd(), "thrext$$" . int rand() * 100000; - - rmtree($dir) if -d $dir; - mkdir($dir); - - # Create a dir structure like this: - # $dir - # | - # `- toberead - # | - # +---- thrit - # | - # +---- rile - # | - # `---- zor - - chdir($dir); - mkdir 'toberead'; - chdir 'toberead'; - {open my $fh, ">thrit" or &$skip("Cannot create file thrit")} - {open my $fh, ">rile" or &$skip("Cannot create file rile")} - {open my $fh, ">zor" or &$skip("Cannot create file zor")} - chdir updir; - - # Then test that dir iterators are cloned correctly. - - opendir my $toberead, 'toberead'; - my $start_pos = telldir $toberead; - my @first_2 = (scalar readdir $toberead, scalar readdir $toberead); - my @from_thread = @{; async { [readdir $toberead ] } ->join }; - my @from_main = readdir $toberead; - is join('-', sort @from_thread), join('-', sort @from_main), - 'dir iterator is copied from one thread to another'; - like - join('-', "", sort(@first_2, @from_thread), ""), - qr/(?join, 'undef', - 'cloned dir iterator that points to the end of the directory' - ; - } - - # Make sure the cloning code can handle file names longer than 255 chars - SKIP: { - chdir 'toberead'; - open my $fh, - ">floccipaucinihilopilification-" - . "pneumonoultramicroscopicsilicovolcanoconiosis-" - . "lopadotemachoselachogaleokranioleipsanodrimypotrimmatosilphiokarabo" - . "melitokatakechymenokichlepikossyphophattoperisteralektryonoptokephal" - . "liokinklopeleiolagoiosiraiobaphetraganopterygon" - or - chdir updir, - skip("OS does not support long file names (and I mean *long*)", 1); - chdir updir; - opendir my $dirh, "toberead"; - my $test_name - = "dir iterators can be cloned when the next fn > 255 chars"; - while() { - my $pos = telldir $dirh; - my $fn = readdir($dirh); - if(!defined $fn) { fail($test_name); last SKIP; } - if($fn =~ 'lagoio') { - seekdir $dirh, $pos; - last; - } - } - is length async { scalar readdir $dirh } ->join, 258, $test_name; - } - - is scalar @w, 0, 'no warnings during all that' or diag @w; - chdir updir; -} -rmtree($dir); diff -up perl-5.26.3/win32/config.gc.cve1 perl-5.26.3/win32/config.gc --- perl-5.26.3/win32/config.gc.cve1 2025-07-01 16:14:02.361650266 +0200 +++ perl-5.26.3/win32/config.gc 2025-07-01 17:15:40.143502836 +0200 @@ -196,6 +196,7 @@ d_fd_macros='define' d_fd_set='define' d_fdclose='undef' d_fdim='undef' +d_fdopendir='undef' d_fds_bits='define' d_fegetround='undef' d_fgetpos='define' diff -up perl-5.26.3/win32/config.vc.cve1 perl-5.26.3/win32/config.vc --- perl-5.26.3/win32/config.vc.cve1 2025-07-01 16:14:02.362022654 +0200 +++ perl-5.26.3/win32/config.vc 2025-07-01 17:16:42.743767126 +0200 @@ -196,6 +196,7 @@ d_fd_macros='define' d_fd_set='define' d_fdclose='undef' d_fdim='undef' +d_fdopendir='undef' d_fds_bits='define' d_fegetround='undef' d_fgetpos='define'