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 15 plan(6); 16} 17 18use strict; 19use warnings; 20use threads; 21use threads::shared; 22use File::Path; 23use File::Spec::Functions qw 'updir catdir'; 24use Cwd 'getcwd'; 25 26# Basic sanity check: make sure this does not crash 27fresh_perl_is <<'# this is no comment', 'ok', {}, 'crash when duping dirh'; 28 use threads; 29 opendir dir, 'op'; 30 async{}->join for 1..2; 31 print "ok"; 32# this is no comment 33 34my $dir; 35SKIP: { 36 my $skip = sub { 37 chdir($dir); 38 chdir updir; 39 skip $_[0], 5 40 }; 41 42 if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") { 43 $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms'; 44 } 45 46 my @w :shared; # warnings accumulator 47 local $SIG{__WARN__} = sub { push @w, $_[0] }; 48 49 $dir = catdir getcwd(), "thrext$$" . int rand() * 100000; 50 51 rmtree($dir); 52 mkdir($dir); 53 54 # Create a dir structure like this: 55 # $dir 56 # | 57 # `- toberead 58 # | 59 # +---- thrit 60 # | 61 # +---- rile 62 # | 63 # `---- zor 64 65 chdir($dir); 66 mkdir 'toberead'; 67 chdir 'toberead'; 68 {open my $fh, ">thrit" or &$skip("Cannot create file thrit")} 69 {open my $fh, ">rile" or &$skip("Cannot create file rile")} 70 {open my $fh, ">zor" or &$skip("Cannot create file zor")} 71 chdir updir; 72 73 # Then test that dir iterators are cloned correctly. 74 75 opendir my $toberead, 'toberead'; 76 my $start_pos = telldir $toberead; 77 my @first_2 = (scalar readdir $toberead, scalar readdir $toberead); 78 my @from_thread = @{; async { [readdir $toberead ] } ->join }; 79 my @from_main = readdir $toberead; 80 is join('-', sort @from_thread), join('-', sort @from_main), 81 'dir iterator is copied from one thread to another'; 82 like 83 join('-', "", sort(@first_2, @from_thread), ""), 84 qr/(?<!-rile)-rile-thrit-zor-(?!zor-)/i, 85 'cloned iterator iterates exactly once over everything not already seen'; 86 87 seekdir $toberead, $start_pos; 88 readdir $toberead for 1 .. @first_2+@from_thread; 89 { 90 local $::TODO; # This always passes when dir handles are not cloned. 91 is 92 async { readdir $toberead // 'undef' } ->join, 'undef', 93 'cloned dir iterator that points to the end of the directory' 94 ; 95 } 96 97 # Make sure the cloning code can handle file names longer than 255 chars 98 SKIP: { 99 chdir 'toberead'; 100 open my $fh, 101 ">floccipaucinihilopilification-" 102 . "pneumonoultramicroscopicsilicovolcanoconiosis-" 103 . "lopadotemachoselachogaleokranioleipsanodrimypotrimmatosilphiokarabo" 104 . "melitokatakechymenokichlepikossyphophattoperisteralektryonoptokephal" 105 . "liokinklopeleiolagoiosiraiobaphetraganopterygon" 106 or 107 chdir updir, 108 skip("OS does not support long file names (and I mean *long*)", 1); 109 chdir updir; 110 opendir my $dirh, "toberead"; 111 my $test_name 112 = "dir iterators can be cloned when the next fn > 255 chars"; 113 while() { 114 my $pos = telldir $dirh; 115 my $fn = readdir($dirh); 116 if(!defined $fn) { fail($test_name); last SKIP; } 117 if($fn =~ 'lagoio') { 118 seekdir $dirh, $pos; 119 last; 120 } 121 } 122 is length async { scalar readdir $dirh } ->join, 258, $test_name; 123 } 124 125 is scalar @w, 0, 'no warnings during all that' or diag @w; 126 chdir updir; 127} 128rmtree($dir); 129