1#!./perl 2 3# There are few filetest operators that are portable enough to test. 4# See pod/perlport.pod for details. 5 6BEGIN { 7 chdir 't' if -d 't'; 8 require './test.pl'; 9 set_up_inc(qw '../lib ../cpan/Perl-OSType/lib'); 10} 11 12plan(tests => 57 + 27*14); 13 14if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) { 15 require Win32; # for IsAdminUser() 16} 17 18# Tests presume we are in t/op directory and that file 'TEST' is found 19# therein. 20is(-d 'op', 1, "-d: directory correctly identified"); 21is(-f 'TEST', 1, "-f: plain file correctly identified"); 22isnt(-f 'op', 1, "-f: directory is not a plain file"); 23isnt(-d 'TEST', 1, "-d: plain file is not a directory"); 24is(-r 'TEST', 1, "-r: file readable by effective uid/gid not found"); 25 26# Make a read only file. This happens to be empty, so we also use it later. 27my $ro_empty_file = tempfile(); 28 29{ 30 open my $fh, '>', $ro_empty_file or die "open $fh: $!"; 31 close $fh or die "close $fh: $!"; 32} 33 34chmod 0555, $ro_empty_file or die "chmod 0555, '$ro_empty_file' failed: $!"; 35 36SKIP: { 37 my $restore_root; 38 skip "Need Win32::IsAdminUser() on $^O", 1 39 if $^O =~ /MSWin32|cygwin|msys/ && is_miniperl(); 40 my $Is_WinAdminUser = ($^O =~ /MSWin32|cygwin|msys/ and Win32::IsAdminUser()) ? 1 : 0; 41 # TODO: skip("On an ACL filesystem like $^O we cannot rely on -w via uid/gid"); 42 # We have no filesystem check for ACL in core 43 if ($Is_WinAdminUser) { 44 skip("As Windows Administrator we cannot rely on -w via uid/gid"); 45 } 46 elsif ($> == 0) { 47 # root can read and write anything, so switch uid (may not be 48 # implemented) 49 eval '$> = 1'; 50 51 skip("Can't drop root privs to test read-only files") if $> == 0; 52 note("Dropped root privs to test read-only files. \$> == $>"); 53 ++$restore_root; 54 } 55 56 isnt(-w $ro_empty_file, 1, "-w: file writable by effective uid/gid"); 57 58 if ($restore_root) { 59 # If the previous assignment to $> worked, so should this: 60 $> = 0; 61 note("Restored root privs after testing read-only files. \$> == $>"); 62 } 63} 64 65# these would fail for the euid 1 66# (unless we have unpacked the source code as uid 1...) 67is(-r 'op', 1, "-r: directory readable by effective uid/gid"); 68is(-w 'op', 1, "-w: directory writable by effective uid/gid"); 69is(-x 'op', 1, "-x: executable by effective uid/gid"); # Hohum. Are directories -x everywhere? 70 71is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op", 72 "-r: found directories readable by effective uid/gid" ); 73 74# Test stackability of filetest operators 75 76is(defined( -f -d 'TEST' ), 1, "-f and -d stackable: plain file found"); 77isnt(-f -d _, 1, "-f and -d stackable: no plain file found"); 78isnt(defined( -e 'zoo' ), 1, "-e: file does not exist"); 79isnt(defined( -e -d 'zoo' ), 1, "-e and -d: neither file nor directory exists"); 80isnt(defined( -f -e 'zoo' ), 1, "-f and -e: not a plain file and does not exist"); 81is(-f -e 'TEST', 1, "-f and -e: plain file and exists"); 82is(-e -f 'TEST', 1, "-e and -f: exists and is plain file"); 83is(defined(-d -e 'TEST'), 1, "-d and -e: file at least exists"); 84is(defined(-e -d 'TEST'), 1, "-e and -d: file at least exists"); 85isnt( -f -d 'op', 1, "-f and -d: directory found but is not a plain file"); 86is(-x -d -x 'op', 1, "-x, -d and -x again: directory exists and is executable"); 87my ($size) = (stat 'TEST')[7]; 88cmp_ok($size, '>', 1, 'TEST is longer than 1 byte'); 89is( (-s -f 'TEST'), $size, "-s returns real size" ); 90is(-f -s 'TEST', 1, "-f and -s: plain file with non-zero size"); 91 92# now with an empty file 93is(-f $ro_empty_file, 1, "-f: plain file found"); 94is(-s $ro_empty_file, 0, "-s: file has 0 bytes"); 95is(-f -s $ro_empty_file, 0, "-f and -s: plain file with 0 bytes"); 96is(-s -f $ro_empty_file, 0, "-s and -f: file with 0 bytes is plain file"); 97 98# stacked -l 99eval { -l -e "TEST" }; 100like $@, qr/^The stat preceding -l _ wasn't an lstat at /, 101 'stacked -l non-lstat error with warnings off'; 102{ 103 local $^W = 1; 104 eval { -l -e "TEST" }; 105 like $@, qr/^The stat preceding -l _ wasn't an lstat at /, 106 'stacked -l non-lstat error with warnings on'; 107} 108# Make sure -l is using the previous stat buffer, and not using the previ- 109# ous op’s return value as a file name. 110# t/TEST can be a symlink under -Dmksymlinks, so use our temporary file. 111SKIP: { 112 use Perl::OSType 'os_type'; 113 if (os_type ne 'Unix') { skip "Not Unix", 3 } 114 if ( $^O =~ /android/ ) { 115 # Even the most basic toolbox in android provides ln, 116 # but not which. 117 $ln = "ln"; 118 } 119 else { 120 chomp(my $ln = `which ln`); 121 if ( ! -e $ln ) { skip "No ln" , 3 } 122 } 123 lstat $ro_empty_file; 124 `ln -s $ro_empty_file 1`; 125 isnt(-l -e _, 1, 'stacked -l uses previous stat, not previous retval'); 126 unlink 1; 127 128 # Since we already have our skip block set up, we might as well put this 129 # test here, too: 130 # -l always treats a non-bareword argument as a file name 131 system 'ln', '-s', $ro_empty_file, \*foo; 132 local $^W = 1; 133 my @warnings; 134 local $SIG{__WARN__} = sub { push @warnings, @_ }; 135 is(-l \*foo, 1, '-l \*foo is a file name'); 136 ok($warnings[0] =~ /-l on filehandle foo/, 'warning for -l $handle'); 137 unlink \*foo; 138} 139# More -l $handle warning tests 140{ 141 local $^W = 1; 142 my @warnings; 143 local $SIG{__WARN__} = sub { push @warnings, @_ }; 144 () = -l \*{"\x{3c6}oo"}; 145 like($warnings[0], qr/-l on filehandle \x{3c6}oo/, 146 '-l $handle warning is utf8-clean'); 147 () = -l *foo; 148 like($warnings[1], qr/-l on filehandle foo/, 149 '-l $handle warning occurs for globs, not just globrefs'); 150 tell foo; # vivify the IO slot 151 () = -l *foo{IO}; 152 # (element [3] because tell also warns) 153 like($warnings[3], qr/-l on filehandle at/, 154 '-l $handle warning occurs for iorefs as well'); 155} 156 157# test that _ is a bareword after filetest operators 158 159-f 'TEST'; 160is(-f _, 1, "_ is bareword after filetest operator"); 161sub _ { "this is not a file name" } 162is(-f _, 1, "_ is bareword after filetest operator"); 163 164my $over; 165{ 166 package OverFtest; 167 168 use overload 169 fallback => 1, 170 -X => sub { 171 $over = [qq($_[0]), $_[1]]; 172 "-$_[1]"; 173 }; 174} 175{ 176 package OverString; 177 178 # No fallback. -X should fall back to string overload even without 179 # it. 180 use overload q/""/ => sub { $over = 1; "TEST" }; 181} 182{ 183 package OverBoth; 184 185 use overload 186 q/""/ => sub { "TEST" }, 187 -X => sub { "-$_[1]" }; 188} 189{ 190 package OverNeither; 191 192 # Need fallback. Previous versions of perl required 'fallback' to do 193 # -X operations on an object with no "" overload. 194 use overload 195 '+' => sub { 1 }, 196 fallback => 1; 197} 198 199my $ft = bless [], "OverFtest"; 200my $ftstr = qq($ft); 201my $str = bless [], "OverString"; 202my $both = bless [], "OverBoth"; 203my $neither = bless [], "OverNeither"; 204my $nstr = qq($neither); 205 206open my $gv, "<", "TEST"; 207bless $gv, "OverString"; 208open my $io, "<", "TEST"; 209$io = *{$io}{IO}; 210bless $io, "OverString"; 211 212my $fcntl_not_available; 213eval { require Fcntl } or $fcntl_not_available = 1; 214 215for my $op (split //, "rwxoRWXOezsfdlpSbctugkTMBAC") { 216 $over = []; 217 my $rv = eval "-$op \$ft"; 218 isnt( $rv, undef, "overloaded -$op succeeds" ) 219 or diag( $@ ); 220 is( $over->[0], $ftstr, "correct object for overloaded -$op" ); 221 is( $over->[1], $op, "correct op for overloaded -$op" ); 222 is( $rv, "-$op", "correct return value for overloaded -$op"); 223 224 my ($exp, $is) = (1, "is"); 225 226 $over = 0; 227 $rv = eval "-$op \$str"; 228 is($@, "", "-$op succeeds with string overloading"); 229 is( $rv, eval "-$op 'TEST'", "correct -$op on string overload" ); 230 is( $over, $exp, "string overload $is called for -$op" ); 231 232 ($exp, $is) = $op eq "l" ? (1, "is") : (0, "not"); 233 234 $over = 0; 235 eval "-$op \$gv"; 236 is( $over, $exp, "string overload $is called for -$op on GLOB" ); 237 238 # IO refs always get string overload called. This might be a bug. 239 $op eq "t" || $op eq "T" || $op eq "B" 240 and ($exp, $is) = (1, "is"); 241 242 $over = 0; 243 eval "-$op \$io"; 244 is( $over, $exp, "string overload $is called for -$op on IO"); 245 246 $rv = eval "-$op \$both"; 247 is( $rv, "-$op", "correct -$op on string/-X overload" ); 248 249 $rv = eval "-$op \$neither"; 250 is($@, "", "-$op succeeds with random overloading"); 251 is( $rv, eval "-$op \$nstr", "correct -$op with random overloading" ); 252 253 is( eval "-r -$op \$ft", "-r", "stacked overloaded -$op" ); 254 is( eval "-$op -r \$ft", "-$op", "overloaded stacked -$op" ); 255} 256 257# -l stack corruption: this bug occurred from 5.8 to 5.14 258{ 259 push my @foo, "bar", -l baz; 260 is $foo[0], "bar", '-l bareword does not corrupt the stack'; 261} 262 263# -l and fatal warnings 264stat "test.pl"; 265eval { use warnings FATAL => io; -l cradd }; 266isnt(stat _, 1, 267 'fatal warnings do not prevent -l HANDLE from setting stat status'); 268 269# File test ops should not call get-magic on the topmost SV on the stack if 270# it belongs to another op. 271{ 272 my $w; 273 sub oon::TIESCALAR{bless[],'oon'} 274 sub oon::FETCH{$w++} 275 tie my $t, 'oon'; 276 push my @a, $t, -t; 277 is $w, 1, 'file test does not call FETCH on stack item not its own'; 278} 279 280# -T and -B 281 282my $Perl = which_perl(); 283 284SKIP: { 285 skip "no -T on filehandles", 8 unless eval { -T STDERR; 1 }; 286 287 # Test that -T HANDLE sets the last stat type 288 -l "perl.c"; # last stat type is now lstat 289 -T STDERR; # should set it to stat, since -T does a stat 290 eval { -l _ }; # should die, because the last stat type is not lstat 291 like $@, qr/^The stat preceding -l _ wasn't an lstat at /, 292 '-T HANDLE sets the stat type'; 293 294 # statgv should be cleared when freed 295 fresh_perl_is 296 'open my $fh, "test.pl"; -r $fh; undef $fh; open my $fh2, ' 297 . "q\0$Perl\0; print -B _", 298 '', 299 { switches => ['-l'] }, 300 'PL_statgv should not point to freed-and-reused SV'; 301 302 # or coerced into a non-glob 303 fresh_perl_is 304 'open Fh, "test.pl"; -r($h{i} = *Fh); $h{i} = 3; undef %h;' 305 . 'open my $fh2, ' . "q\0" . which_perl() . "\0; print -B _", 306 '', 307 { switches => ['-l'] }, 308 'PL_statgv should not point to coerced-freed-and-reused GV'; 309 310 # -T _ should work after stat $ioref 311 open my $fh, 'test.pl'; 312 stat $Perl; # a binary file 313 stat *$fh{IO}; 314 is(-T _, 1, '-T _ works after stat $ioref'); 315 316 # and after -r $ioref 317 -r *$fh{IO}; 318 is(-T _, 1, '-T _ works after -r $ioref'); 319 320 # -T _ on closed filehandle should still reset stat info 321 stat $fh; 322 close $fh; 323 -T _; 324 isnt(stat _, 1, '-T _ on closed filehandle resets stat info'); 325 326 lstat "test.pl"; 327 -T $fh; # closed 328 eval { lstat _ }; 329 like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /, 330 '-T on closed handle resets last stat type'; 331 332 # Fatal warnings should not affect the setting of errno. 333 $! = 7; 334 -T cradd; 335 my $errno = $!; 336 $! = 7; 337 eval { use warnings FATAL => unopened; -T cradd }; 338 my $errno2 = $!; 339 is $errno2, $errno, 340 'fatal warnings do not affect errno after -T BADHADNLE'; 341} 342 343is runperl(prog => '-T _', switches => ['-w'], stderr => 1), "", 344 'no uninit warnings from -T with no preceding stat'; 345 346SKIP: { 347 my $rand_file_name = 'filetest-' . rand =~ y/.//dr; 348 if (-e $rand_file_name) { skip "File $rand_file_name exists", 1 } 349 stat 'test.pl'; 350 -T $rand_file_name; 351 isnt(stat _, 1, '-T "nonexistent" resets stat success status'); 352} 353 354# Unsuccessful filetests on filehandles should leave stat buffers in the 355# same state whether fatal warnings are on or off. 356{ 357 stat "test.pl"; 358 # This GV has no IO 359 -r *phlon; 360 my $failed_stat1 = stat _; 361 362 stat "test.pl"; 363 eval { use warnings FATAL => unopened; -r *phlon }; 364 my $failed_stat2 = stat _; 365 366 is $failed_stat2, $failed_stat1, 367 'failed -r($gv_without_io) with and w/out fatal warnings'; 368 369 stat "test.pl"; 370 -r cength; # at compile time autovivifies IO, but with no fp 371 $failed_stat1 = stat _; 372 373 stat "test.pl"; 374 eval { use warnings FATAL => unopened; -r cength }; 375 $failed_stat2 = stat _; 376 377 is $failed_stat2, $failed_stat1, 378 'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings'; 379} 380 381{ 382 # [perl #131895] stat() doesn't fail on filenames containing \0 / NUL 383 ok(!-T "TEST\0-", '-T on name with \0'); 384 ok(!-B "TEST\0-", '-B on name with \0'); 385 ok(!-f "TEST\0-", '-f on name with \0'); 386 ok(!-r "TEST\0-", '-r on name with \0'); 387} 388