1#!perl 2 3# Test interaction of threads and directory handles. 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = '../lib'; 8 require './test.pl'; 9 $| = 1; 10 11 require Config; 12 skip_all_without_config('useithreads'); 13 skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); 14 skip_all("runs out of memory on some EBCDIC") if $ENV{PERL_SKIP_BIG_MEM_TESTS}; 15 16 plan(6); 17} 18 19use strict; 20use warnings; 21use threads; 22use threads::shared; 23use File::Path; 24use File::Spec::Functions qw 'updir catdir'; 25use Cwd 'getcwd'; 26 27# Basic sanity check: make sure this does not crash 28fresh_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 35my $dir; 36SKIP: { 37 skip "telldir or seekdir not defined on this platform", 5 38 if !$Config::Config{d_telldir} || !$Config::Config{d_seekdir}; 39 my $skip = sub { 40 chdir($dir); 41 chdir updir; 42 skip $_[0], 5 43 }; 44 45 if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { 46 $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; 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 54 rmtree($dir) if -d $dir; 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; 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 } 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 . "liokinklopeleiolagoiosiraiobaphetraganopterygon" 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, 258, $test_name; 126 } 127 128 is scalar @w, 0, 'no warnings during all that' or diag @w; 129 chdir updir; 130} 131rmtree($dir); 132