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