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