File perl-dirdup.diff of Package perl
--- sv.c.orig 2025-06-05 10:34:12.229139274 +0000
+++ sv.c 2025-06-05 10:34:58.397076081 +0000
@@ -13944,15 +13944,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;
@@ -13964,87 +13955,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE
if (ret)
return ret;
-#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
-
- 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
ret = win32_dirp_dup(dp, param);
--- t/op/threads-dirh.t.orig 2023-11-28 11:57:28.000000000 +0000
+++ t/op/threads-dirh.t 2025-06-05 10:34:23.701123572 +0000
@@ -13,16 +13,12 @@ BEGIN {
skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
skip_all("runs out of memory on some EBCDIC") if $ENV{PERL_SKIP_BIG_MEM_TESTS};
- 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';
@@ -31,101 +27,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/(?<!-rile)-rile-thrit-zor-(?!zor-)/i,
- 'cloned iterator iterates exactly once over everything not already seen';
-
- seekdir $toberead, $start_pos;
- readdir $toberead for 1 .. @first_2+@from_thread;
- {
- local $::TODO; # This always passes when dir handles are not cloned.
- is
- async { readdir $toberead // 'undef' } ->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);
