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 @INC = '../lib'; 9 require './test.pl'; 10} 11 12plan(tests => 53 + 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 if ( 226 !$fcntl_not_available and ( 227 $op eq "u" and not eval { Fcntl::S_ISUID() } or 228 $op eq "g" and not eval { Fcntl::S_ISGID() } or 229 $op eq "k" and not eval { Fcntl::S_ISVTX() } 230 ) 231 ) { 232 ($exp, $is) = (0, "not"); 233 } 234 235 $over = 0; 236 $rv = eval "-$op \$str"; 237 is($@, "", "-$op succeeds with string overloading"); 238 is( $rv, eval "-$op 'TEST'", "correct -$op on string overload" ); 239 is( $over, $exp, "string overload $is called for -$op" ); 240 241 ($exp, $is) = $op eq "l" ? (1, "is") : (0, "not"); 242 243 $over = 0; 244 eval "-$op \$gv"; 245 is( $over, $exp, "string overload $is called for -$op on GLOB" ); 246 247 # IO refs always get string overload called. This might be a bug. 248 $op eq "t" || $op eq "T" || $op eq "B" 249 and ($exp, $is) = (1, "is"); 250 251 $over = 0; 252 eval "-$op \$io"; 253 is( $over, $exp, "string overload $is called for -$op on IO"); 254 255 $rv = eval "-$op \$both"; 256 is( $rv, "-$op", "correct -$op on string/-X overload" ); 257 258 $rv = eval "-$op \$neither"; 259 is($@, "", "-$op succeeds with random overloading"); 260 is( $rv, eval "-$op \$nstr", "correct -$op with random overloading" ); 261 262 is( eval "-r -$op \$ft", "-r", "stacked overloaded -$op" ); 263 is( eval "-$op -r \$ft", "-$op", "overloaded stacked -$op" ); 264} 265 266# -l stack corruption: this bug occurred from 5.8 to 5.14 267{ 268 push my @foo, "bar", -l baz; 269 is $foo[0], "bar", '-l bareword does not corrupt the stack'; 270} 271 272# -l and fatal warnings 273stat "test.pl"; 274eval { use warnings FATAL => io; -l cradd }; 275isnt(stat _, 1, 276 'fatal warnings do not prevent -l HANDLE from setting stat status'); 277 278# File test ops should not call get-magic on the topmost SV on the stack if 279# it belongs to another op. 280{ 281 my $w; 282 sub oon::TIESCALAR{bless[],'oon'} 283 sub oon::FETCH{$w++} 284 tie my $t, 'oon'; 285 push my @a, $t, -t; 286 is $w, 1, 'file test does not call FETCH on stack item not its own'; 287} 288 289# -T and -B 290 291my $Perl = which_perl(); 292 293SKIP: { 294 skip "no -T on filehandles", 8 unless eval { -T STDERR; 1 }; 295 296 # Test that -T HANDLE sets the last stat type 297 -l "perl.c"; # last stat type is now lstat 298 -T STDERR; # should set it to stat, since -T does a stat 299 eval { -l _ }; # should die, because the last stat type is not lstat 300 like $@, qr/^The stat preceding -l _ wasn't an lstat at /, 301 '-T HANDLE sets the stat type'; 302 303 # statgv should be cleared when freed 304 fresh_perl_is 305 'open my $fh, "test.pl"; -r $fh; undef $fh; open my $fh2, ' 306 . "q\0$Perl\0; print -B _", 307 '', 308 { switches => ['-l'] }, 309 'PL_statgv should not point to freed-and-reused SV'; 310 311 # or coerced into a non-glob 312 fresh_perl_is 313 'open Fh, "test.pl"; -r($h{i} = *Fh); $h{i} = 3; undef %h;' 314 . 'open my $fh2, ' . "q\0" . which_perl() . "\0; print -B _", 315 '', 316 { switches => ['-l'] }, 317 'PL_statgv should not point to coerced-freed-and-reused GV'; 318 319 # -T _ should work after stat $ioref 320 open my $fh, 'test.pl'; 321 stat $Perl; # a binary file 322 stat *$fh{IO}; 323 is(-T _, 1, '-T _ works after stat $ioref'); 324 325 # and after -r $ioref 326 -r *$fh{IO}; 327 is(-T _, 1, '-T _ works after -r $ioref'); 328 329 # -T _ on closed filehandle should still reset stat info 330 stat $fh; 331 close $fh; 332 -T _; 333 isnt(stat _, 1, '-T _ on closed filehandle resets stat info'); 334 335 lstat "test.pl"; 336 -T $fh; # closed 337 eval { lstat _ }; 338 like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /, 339 '-T on closed handle resets last stat type'; 340 341 # Fatal warnings should not affect the setting of errno. 342 $! = 7; 343 -T cradd; 344 my $errno = $!; 345 $! = 7; 346 eval { use warnings FATAL => unopened; -T cradd }; 347 my $errno2 = $!; 348 is $errno2, $errno, 349 'fatal warnings do not affect errno after -T BADHADNLE'; 350} 351 352is runperl(prog => '-T _', switches => ['-w'], stderr => 1), "", 353 'no uninit warnings from -T with no preceding stat'; 354 355SKIP: { 356 my $rand_file_name = 'filetest-' . rand =~ y/.//dr; 357 if (-e $rand_file_name) { skip "File $rand_file_name exists", 1 } 358 stat 'test.pl'; 359 -T $rand_file_name; 360 isnt(stat _, 1, '-T "nonexistent" resets stat success status'); 361} 362 363# Unsuccessful filetests on filehandles should leave stat buffers in the 364# same state whether fatal warnings are on or off. 365{ 366 stat "test.pl"; 367 # This GV has no IO 368 -r *phlon; 369 my $failed_stat1 = stat _; 370 371 stat "test.pl"; 372 eval { use warnings FATAL => unopened; -r *phlon }; 373 my $failed_stat2 = stat _; 374 375 is $failed_stat2, $failed_stat1, 376 'failed -r($gv_without_io) with and w/out fatal warnings'; 377 378 stat "test.pl"; 379 -r cength; # at compile time autovivifies IO, but with no fp 380 $failed_stat1 = stat _; 381 382 stat "test.pl"; 383 eval { use warnings FATAL => unopened; -r cength }; 384 $failed_stat2 = stat _; 385 386 is $failed_stat2, $failed_stat1, 387 'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings'; 388} 389