| 1 | #!./perl
|
|---|
| 2 |
|
|---|
| 3 | BEGIN {
|
|---|
| 4 | chdir 't' if -d 't';
|
|---|
| 5 | @INC = '../lib';
|
|---|
| 6 | require './test.pl'; # for which_perl() etc
|
|---|
| 7 | }
|
|---|
| 8 |
|
|---|
| 9 | use Config;
|
|---|
| 10 | use File::Spec;
|
|---|
| 11 |
|
|---|
| 12 | plan tests => 86;
|
|---|
| 13 |
|
|---|
| 14 | my $Perl = which_perl();
|
|---|
| 15 |
|
|---|
| 16 | $Is_Amiga = $^O eq 'amigaos';
|
|---|
| 17 | $Is_Cygwin = $^O eq 'cygwin';
|
|---|
| 18 | $Is_Darwin = $^O eq 'darwin';
|
|---|
| 19 | $Is_Dos = $^O eq 'dos';
|
|---|
| 20 | $Is_MacOS = $^O eq 'MacOS';
|
|---|
| 21 | $Is_MPE = $^O eq 'mpeix';
|
|---|
| 22 | $Is_MSWin32 = $^O eq 'MSWin32';
|
|---|
| 23 | $Is_NetWare = $^O eq 'NetWare';
|
|---|
| 24 | $Is_OS2 = $^O eq 'os2';
|
|---|
| 25 | $Is_Solaris = $^O eq 'solaris';
|
|---|
| 26 | $Is_VMS = $^O eq 'VMS';
|
|---|
| 27 | $Is_DGUX = $^O eq 'dgux';
|
|---|
| 28 | $Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid';
|
|---|
| 29 | $Is_Rhapsody= $^O eq 'rhapsody';
|
|---|
| 30 |
|
|---|
| 31 | $Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
|
|---|
| 32 |
|
|---|
| 33 | $Is_UFS = $Is_Darwin && (() = `df -t ufs .`) == 2;
|
|---|
| 34 |
|
|---|
| 35 | my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE,
|
|---|
| 36 | $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12);
|
|---|
| 37 |
|
|---|
| 38 | my $Curdir = File::Spec->curdir;
|
|---|
| 39 |
|
|---|
| 40 |
|
|---|
| 41 | my $tmpfile = 'Op_stat.tmp';
|
|---|
| 42 | my $tmpfile_link = $tmpfile.'2';
|
|---|
| 43 |
|
|---|
| 44 |
|
|---|
| 45 | 1 while unlink $tmpfile;
|
|---|
| 46 | open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
|
|---|
| 47 | close FOO;
|
|---|
| 48 |
|
|---|
| 49 | open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
|
|---|
| 50 |
|
|---|
| 51 | my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME];
|
|---|
| 52 | SKIP: {
|
|---|
| 53 | skip "No link count", 1 if $Is_VMS;
|
|---|
| 54 |
|
|---|
| 55 | is($nlink, 1, 'nlink on regular file');
|
|---|
| 56 | }
|
|---|
| 57 |
|
|---|
| 58 | SKIP: {
|
|---|
| 59 | skip "mtime and ctime not reliable", 2
|
|---|
| 60 | if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_MacOS;
|
|---|
| 61 |
|
|---|
| 62 | ok( $mtime, 'mtime' );
|
|---|
| 63 | is( $mtime, $ctime, 'mtime == ctime' );
|
|---|
| 64 | }
|
|---|
| 65 |
|
|---|
| 66 |
|
|---|
| 67 | # Cygwin seems to have a 3 second granularity on its timestamps.
|
|---|
| 68 | my $funky_FAT_timestamps = $Is_Cygwin;
|
|---|
| 69 | sleep 3 if $funky_FAT_timestamps;
|
|---|
| 70 |
|
|---|
| 71 | print FOO "Now is the time for all good men to come to.\n";
|
|---|
| 72 | close(FOO);
|
|---|
| 73 |
|
|---|
| 74 | sleep 2;
|
|---|
| 75 |
|
|---|
| 76 |
|
|---|
| 77 | SKIP: {
|
|---|
| 78 | unlink $tmpfile_link;
|
|---|
| 79 | my $lnk_result = eval { link $tmpfile, $tmpfile_link };
|
|---|
| 80 | skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
|
|---|
| 81 |
|
|---|
| 82 | is( $@, '', 'link() implemented' );
|
|---|
| 83 | ok( $lnk_result, 'linked tmp testfile' );
|
|---|
| 84 | ok( chmod(0644, $tmpfile), 'chmoded tmp testfile' );
|
|---|
| 85 |
|
|---|
| 86 | my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME];
|
|---|
| 87 |
|
|---|
| 88 | SKIP: {
|
|---|
| 89 | skip "No link count", 1 if $Config{dont_use_nlink};
|
|---|
| 90 | skip "Cygwin9X fakes hard links by copying", 1
|
|---|
| 91 | if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i;
|
|---|
| 92 |
|
|---|
| 93 | is($nlink, 2, 'Link count on hard linked file' );
|
|---|
| 94 | }
|
|---|
| 95 |
|
|---|
| 96 | SKIP: {
|
|---|
| 97 | my $cwd = File::Spec->rel2abs($Curdir);
|
|---|
| 98 | skip "Solaris tmpfs has different mtime/ctime link semantics", 2
|
|---|
| 99 | if $Is_Solaris and $cwd =~ m#^/tmp# and
|
|---|
| 100 | $mtime && $mtime == $ctime;
|
|---|
| 101 | skip "AFS has different mtime/ctime link semantics", 2
|
|---|
| 102 | if $cwd =~ m#$Config{'afsroot'}/#;
|
|---|
| 103 | skip "AmigaOS has different mtime/ctime link semantics", 2
|
|---|
| 104 | if $Is_Amiga;
|
|---|
| 105 | # Win32 could pass $mtime test but as FAT and NTFS have
|
|---|
| 106 | # no ctime concept $ctime is ALWAYS == $mtime
|
|---|
| 107 | # expect netware to be the same ...
|
|---|
| 108 | skip "No ctime concept on this OS", 2
|
|---|
| 109 | if $Is_MSWin32 ||
|
|---|
| 110 | ($Is_Darwin && $Is_UFS);
|
|---|
| 111 |
|
|---|
| 112 | if( !ok($mtime, 'hard link mtime') ||
|
|---|
| 113 | !isnt($mtime, $ctime, 'hard link ctime != mtime') ) {
|
|---|
| 114 | print STDERR <<DIAG;
|
|---|
| 115 | # Check if you are on a tmpfs of some sort. Building in /tmp sometimes
|
|---|
| 116 | # has this problem. Building on the ClearCase VOBS filesystem may also
|
|---|
| 117 | # cause this failure.
|
|---|
| 118 | #
|
|---|
| 119 | # Darwin's UFS doesn't have a ctime concept, and thus is expected to fail
|
|---|
| 120 | # this test.
|
|---|
| 121 | DIAG
|
|---|
| 122 | }
|
|---|
| 123 | }
|
|---|
| 124 |
|
|---|
| 125 | }
|
|---|
| 126 |
|
|---|
| 127 | # truncate and touch $tmpfile.
|
|---|
| 128 | open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
|
|---|
| 129 | ok(-z \*F, '-z on empty filehandle');
|
|---|
| 130 | ok(! -s \*F, ' and -s');
|
|---|
| 131 | close F;
|
|---|
| 132 |
|
|---|
| 133 | ok(-z $tmpfile, '-z on empty file');
|
|---|
| 134 | ok(! -s $tmpfile, ' and -s');
|
|---|
| 135 |
|
|---|
| 136 | open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
|
|---|
| 137 | print F "hi\n";
|
|---|
| 138 | close F;
|
|---|
| 139 |
|
|---|
| 140 | open(F, "<$tmpfile") || DIE("Can't open temp test file: $!");
|
|---|
| 141 | ok(!-z *F, '-z on empty filehandle');
|
|---|
| 142 | ok( -s *F, ' and -s');
|
|---|
| 143 | close F;
|
|---|
| 144 |
|
|---|
| 145 | ok(! -z $tmpfile, '-z on non-empty file');
|
|---|
| 146 | ok(-s $tmpfile, ' and -s');
|
|---|
| 147 |
|
|---|
| 148 |
|
|---|
| 149 | # Strip all access rights from the file.
|
|---|
| 150 | ok( chmod(0000, $tmpfile), 'chmod 0000' );
|
|---|
| 151 |
|
|---|
| 152 | SKIP: {
|
|---|
| 153 | skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS;
|
|---|
| 154 |
|
|---|
| 155 | SKIP: {
|
|---|
| 156 | # Going to try to switch away from root. Might not work.
|
|---|
| 157 | my $olduid = $>;
|
|---|
| 158 | eval { $> = 1; };
|
|---|
| 159 | skip "Can't test -r or -w meaningfully if you're superuser", 2
|
|---|
| 160 | if $> == 0;
|
|---|
| 161 |
|
|---|
| 162 | SKIP: {
|
|---|
| 163 | skip "Can't test -r meaningfully?", 1 if $Is_Dos || $Is_Cygwin;
|
|---|
| 164 | ok(!-r $tmpfile, " -r");
|
|---|
| 165 | }
|
|---|
| 166 |
|
|---|
| 167 | ok(!-w $tmpfile, " -w");
|
|---|
| 168 |
|
|---|
| 169 | # switch uid back (may not be implemented)
|
|---|
| 170 | eval { $> = $olduid; };
|
|---|
| 171 | }
|
|---|
| 172 |
|
|---|
| 173 | ok(! -x $tmpfile, ' -x');
|
|---|
| 174 | }
|
|---|
| 175 |
|
|---|
| 176 |
|
|---|
| 177 |
|
|---|
| 178 | ok(chmod(0700,$tmpfile), 'chmod 0700');
|
|---|
| 179 | ok(-r $tmpfile, ' -r');
|
|---|
| 180 | ok(-w $tmpfile, ' -w');
|
|---|
| 181 |
|
|---|
| 182 | SKIP: {
|
|---|
| 183 | skip "-x simply determines if a file ends in an executable suffix", 1
|
|---|
| 184 | if $Is_Dosish || $Is_MacOS;
|
|---|
| 185 |
|
|---|
| 186 | ok(-x $tmpfile, ' -x');
|
|---|
| 187 | }
|
|---|
| 188 |
|
|---|
| 189 | ok( -f $tmpfile, ' -f');
|
|---|
| 190 | ok(! -d $tmpfile, ' !-d');
|
|---|
| 191 |
|
|---|
| 192 | # Is this portable?
|
|---|
| 193 | ok( -d $Curdir, '-d cwd' );
|
|---|
| 194 | ok(! -f $Curdir, '!-f cwd' );
|
|---|
| 195 |
|
|---|
| 196 |
|
|---|
| 197 | SKIP: {
|
|---|
| 198 | unlink($tmpfile_link);
|
|---|
| 199 | my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link };
|
|---|
| 200 | skip "symlink not implemented", 3 if $@ =~ /unimplemented/;
|
|---|
| 201 |
|
|---|
| 202 | is( $@, '', 'symlink() implemented' );
|
|---|
| 203 | ok( $symlink_rslt, 'symlink() ok' );
|
|---|
| 204 | ok(-l $tmpfile_link, '-l');
|
|---|
| 205 | }
|
|---|
| 206 |
|
|---|
| 207 | ok(-o $tmpfile, '-o');
|
|---|
| 208 |
|
|---|
| 209 | ok(-e $tmpfile, '-e');
|
|---|
| 210 |
|
|---|
| 211 | unlink($tmpfile_link);
|
|---|
| 212 | ok(! -e $tmpfile_link, ' -e on unlinked file');
|
|---|
| 213 |
|
|---|
| 214 | SKIP: {
|
|---|
| 215 | skip "No character, socket or block special files", 6
|
|---|
| 216 | if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
|
|---|
| 217 | skip "/dev isn't available to test against", 6
|
|---|
| 218 | unless -d '/dev' && -r '/dev' && -x '/dev';
|
|---|
| 219 | skip "Skipping: unexpected ls output in MP-RAS", 6
|
|---|
| 220 | if $Is_MPRAS;
|
|---|
| 221 |
|
|---|
| 222 | my $LS = $Config{d_readlink} ? "ls -lL" : "ls -l";
|
|---|
| 223 | my $CMD = "$LS /dev 2>/dev/null";
|
|---|
| 224 | my $DEV = qx($CMD);
|
|---|
| 225 |
|
|---|
| 226 | skip "$CMD failed", 6 if $DEV eq '';
|
|---|
| 227 |
|
|---|
| 228 | my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () };
|
|---|
| 229 |
|
|---|
| 230 | skip "opendir failed: $!", 6 if @DEV == 0;
|
|---|
| 231 |
|
|---|
| 232 | # /dev/stdout might be either character special or a named pipe,
|
|---|
| 233 | # or a symlink, or a socket, depending on which OS and how are
|
|---|
| 234 | # you running the test, so let's censor that one away.
|
|---|
| 235 | # Similar remarks hold for stderr.
|
|---|
| 236 | $DEV =~ s{^[cpls].+?\sstdout$}{}m;
|
|---|
| 237 | @DEV = grep { $_ ne 'stdout' } @DEV;
|
|---|
| 238 | $DEV =~ s{^[cpls].+?\sstderr$}{}m;
|
|---|
| 239 | @DEV = grep { $_ ne 'stderr' } @DEV;
|
|---|
| 240 |
|
|---|
| 241 | # /dev/printer is also naughty: in IRIX it shows up as
|
|---|
| 242 | # Srwx-----, not srwx------.
|
|---|
| 243 | $DEV =~ s{^.+?\sprinter$}{}m;
|
|---|
| 244 | @DEV = grep { $_ ne 'printer' } @DEV;
|
|---|
| 245 |
|
|---|
| 246 | # If running as root, we will see .files in the ls result,
|
|---|
| 247 | # and readdir() will see them always. Potential for conflict,
|
|---|
| 248 | # so let's weed them out.
|
|---|
| 249 | $DEV =~ s{^.+?\s\..+?$}{}m;
|
|---|
| 250 | @DEV = grep { ! m{^\..+$} } @DEV;
|
|---|
| 251 |
|
|---|
| 252 | # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'.
|
|---|
| 253 | if ($^O eq 'irix') {
|
|---|
| 254 | $DEV =~ s{^S(.+?)}{s$1}mg;
|
|---|
| 255 | }
|
|---|
| 256 |
|
|---|
| 257 | my $try = sub {
|
|---|
| 258 | my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg];
|
|---|
| 259 | my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV];
|
|---|
| 260 | my $c1 = scalar @c1;
|
|---|
| 261 | my $c2 = scalar @c2;
|
|---|
| 262 | is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
|
|---|
| 263 | };
|
|---|
| 264 |
|
|---|
| 265 | SKIP: {
|
|---|
| 266 | skip("DG/UX ls -L broken", 3) if $Is_DGUX;
|
|---|
| 267 |
|
|---|
| 268 | $try->('b', '-b');
|
|---|
| 269 | $try->('c', '-c');
|
|---|
| 270 | $try->('s', '-S');
|
|---|
| 271 |
|
|---|
| 272 | }
|
|---|
| 273 |
|
|---|
| 274 | ok(! -b $Curdir, '!-b cwd');
|
|---|
| 275 | ok(! -c $Curdir, '!-c cwd');
|
|---|
| 276 | ok(! -S $Curdir, '!-S cwd');
|
|---|
| 277 |
|
|---|
| 278 | }
|
|---|
| 279 |
|
|---|
| 280 | SKIP: {
|
|---|
| 281 | my($cnt, $uid);
|
|---|
| 282 | $cnt = $uid = 0;
|
|---|
| 283 |
|
|---|
| 284 | # Find a set of directories that's very likely to have setuid files
|
|---|
| 285 | # but not likely to be *all* setuid files.
|
|---|
| 286 | my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin);
|
|---|
| 287 | skip "Can't find a setuid file to test with", 3 unless @bin;
|
|---|
| 288 |
|
|---|
| 289 | for my $bin (@bin) {
|
|---|
| 290 | opendir BIN, $bin or die "Can't opendir $bin: $!";
|
|---|
| 291 | while (defined($_ = readdir BIN)) {
|
|---|
| 292 | $_ = "$bin/$_";
|
|---|
| 293 | $cnt++;
|
|---|
| 294 | $uid++ if -u;
|
|---|
| 295 | last if $uid && $uid < $cnt;
|
|---|
| 296 | }
|
|---|
| 297 | }
|
|---|
| 298 | closedir BIN;
|
|---|
| 299 |
|
|---|
| 300 | skip "No setuid programs", 3 if $uid == 0;
|
|---|
| 301 |
|
|---|
| 302 | isnt($cnt, 0, 'found some programs');
|
|---|
| 303 | isnt($uid, 0, ' found some setuid programs');
|
|---|
| 304 | ok($uid < $cnt, " they're not all setuid");
|
|---|
| 305 | }
|
|---|
| 306 |
|
|---|
| 307 |
|
|---|
| 308 | # To assist in automated testing when a controlling terminal (/dev/tty)
|
|---|
| 309 | # may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
|
|---|
| 310 | # can be set to skip the tests that need a tty.
|
|---|
| 311 | SKIP: {
|
|---|
| 312 | skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
|
|---|
| 313 |
|
|---|
| 314 | my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty";
|
|---|
| 315 |
|
|---|
| 316 | SKIP: {
|
|---|
| 317 | skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
|
|---|
| 318 | skip "No TTY to test -t with", 2 unless -e $TTY;
|
|---|
| 319 |
|
|---|
| 320 | open(TTY, $TTY) ||
|
|---|
| 321 | warn "Can't open $TTY--run t/TEST outside of make.\n";
|
|---|
| 322 | ok(-t TTY, '-t');
|
|---|
| 323 | ok(-c TTY, 'tty is -c');
|
|---|
| 324 | close(TTY);
|
|---|
| 325 | }
|
|---|
| 326 | ok(! -t TTY, '!-t on closed TTY filehandle');
|
|---|
| 327 |
|
|---|
| 328 | {
|
|---|
| 329 | local $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS;
|
|---|
| 330 | ok(-t, '-t on STDIN');
|
|---|
| 331 | }
|
|---|
| 332 | }
|
|---|
| 333 |
|
|---|
| 334 | my $Null = File::Spec->devnull;
|
|---|
| 335 | SKIP: {
|
|---|
| 336 | skip "No null device to test with", 1 unless -e $Null;
|
|---|
| 337 | skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32;
|
|---|
| 338 |
|
|---|
| 339 | open(NULL, $Null) or DIE("Can't open $Null: $!");
|
|---|
| 340 | ok(! -t NULL, 'null device is not a TTY');
|
|---|
| 341 | close(NULL);
|
|---|
| 342 | }
|
|---|
| 343 |
|
|---|
| 344 |
|
|---|
| 345 | # These aren't strictly "stat" calls, but so what?
|
|---|
| 346 | my $statfile = File::Spec->catfile($Curdir, 'op', 'stat.t');
|
|---|
| 347 | ok( -T $statfile, '-T');
|
|---|
| 348 | ok(! -B $statfile, '!-B');
|
|---|
| 349 |
|
|---|
| 350 | SKIP: {
|
|---|
| 351 | skip("DG/UX", 1) if $Is_DGUX;
|
|---|
| 352 | ok(-B $Perl, '-B');
|
|---|
| 353 | }
|
|---|
| 354 |
|
|---|
| 355 | ok(! -T $Perl, '!-T');
|
|---|
| 356 |
|
|---|
| 357 | open(FOO,$statfile);
|
|---|
| 358 | SKIP: {
|
|---|
| 359 | eval { -T FOO; };
|
|---|
| 360 | skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/;
|
|---|
| 361 |
|
|---|
| 362 | is( $@, '', '-T on filehandle causes no errors' );
|
|---|
| 363 |
|
|---|
| 364 | ok(-T FOO, ' -T');
|
|---|
| 365 | ok(! -B FOO, ' !-B');
|
|---|
| 366 |
|
|---|
| 367 | $_ = <FOO>;
|
|---|
| 368 | like($_, qr/perl/, 'after readline');
|
|---|
| 369 | ok(-T FOO, ' still -T');
|
|---|
| 370 | ok(! -B FOO, ' still -B');
|
|---|
| 371 | close(FOO);
|
|---|
| 372 |
|
|---|
| 373 | open(FOO,$statfile);
|
|---|
| 374 | $_ = <FOO>;
|
|---|
| 375 | like($_, qr/perl/, 'reopened and after readline');
|
|---|
| 376 | ok(-T FOO, ' still -T');
|
|---|
| 377 | ok(! -B FOO, ' still !-B');
|
|---|
| 378 |
|
|---|
| 379 | ok(seek(FOO,0,0), 'after seek');
|
|---|
| 380 | ok(-T FOO, ' still -T');
|
|---|
| 381 | ok(! -B FOO, ' still !-B');
|
|---|
| 382 |
|
|---|
| 383 | # It's documented this way in perlfunc *shrug*
|
|---|
| 384 | () = <FOO>;
|
|---|
| 385 | ok(eof FOO, 'at EOF');
|
|---|
| 386 | ok(-T FOO, ' still -T');
|
|---|
| 387 | ok(-B FOO, ' now -B');
|
|---|
| 388 | }
|
|---|
| 389 | close(FOO);
|
|---|
| 390 |
|
|---|
| 391 |
|
|---|
| 392 | SKIP: {
|
|---|
| 393 | skip "No null device to test with", 2 unless -e $Null;
|
|---|
| 394 |
|
|---|
| 395 | ok(-T $Null, 'null device is -T');
|
|---|
| 396 | ok(-B $Null, ' and -B');
|
|---|
| 397 | }
|
|---|
| 398 |
|
|---|
| 399 |
|
|---|
| 400 | # and now, a few parsing tests:
|
|---|
| 401 | $_ = $tmpfile;
|
|---|
| 402 | ok(-f, 'bare -f uses $_');
|
|---|
| 403 | ok(-f(), ' -f() "');
|
|---|
| 404 |
|
|---|
| 405 | unlink $tmpfile or print "# unlink failed: $!\n";
|
|---|
| 406 |
|
|---|
| 407 | # bug id 20011101.069
|
|---|
| 408 | my @r = \stat($Curdir);
|
|---|
| 409 | is(scalar @r, 13, 'stat returns full 13 elements');
|
|---|
| 410 |
|
|---|
| 411 | stat $0;
|
|---|
| 412 | eval { lstat _ };
|
|---|
| 413 | like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
|
|---|
| 414 | 'lstat _ croaks after stat' );
|
|---|
| 415 | eval { -l _ };
|
|---|
| 416 | like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
|
|---|
| 417 | '-l _ croaks after stat' );
|
|---|
| 418 |
|
|---|
| 419 | lstat $0;
|
|---|
| 420 | eval { lstat _ };
|
|---|
| 421 | is( "$@", "", "lstat _ ok after lstat" );
|
|---|
| 422 | eval { -l _ };
|
|---|
| 423 | is( "$@", "", "-l _ ok after lstat" );
|
|---|
| 424 |
|
|---|
| 425 | SKIP: {
|
|---|
| 426 | skip "No lstat", 2 unless $Config{d_lstat};
|
|---|
| 427 |
|
|---|
| 428 | # bug id 20020124.004
|
|---|
| 429 | # If we have d_lstat, we should have symlink()
|
|---|
| 430 | my $linkname = 'dolzero';
|
|---|
| 431 | symlink $0, $linkname or die "# Can't symlink $0: $!";
|
|---|
| 432 | lstat $linkname;
|
|---|
| 433 | -T _;
|
|---|
| 434 | eval { lstat _ };
|
|---|
| 435 | like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
|
|---|
| 436 | 'lstat croaks after -T _' );
|
|---|
| 437 | eval { -l _ };
|
|---|
| 438 | like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
|
|---|
| 439 | '-l _ croaks after -T _' );
|
|---|
| 440 | unlink $linkname or print "# unlink $linkname failed: $!\n";
|
|---|
| 441 | }
|
|---|
| 442 |
|
|---|
| 443 | print "# Zzz...\n";
|
|---|
| 444 | sleep(3);
|
|---|
| 445 | my $f = 'tstamp.tmp';
|
|---|
| 446 | unlink $f;
|
|---|
| 447 | ok (open(S, "> $f"), 'can create tmp file');
|
|---|
| 448 | close S or die;
|
|---|
| 449 | my @a = stat $f;
|
|---|
| 450 | print "# time=$^T, stat=(@a)\n";
|
|---|
| 451 | my @b = (-M _, -A _, -C _);
|
|---|
| 452 | print "# -MAC=(@b)\n";
|
|---|
| 453 | ok( (-M _) < 0, 'negative -M works');
|
|---|
| 454 | ok( (-A _) < 0, 'negative -A works');
|
|---|
| 455 | ok( (-C _) < 0, 'negative -C works');
|
|---|
| 456 | ok(unlink($f), 'unlink tmp file');
|
|---|
| 457 |
|
|---|
| 458 | {
|
|---|
| 459 | ok(open(F, ">", $tmpfile), 'can create temp file');
|
|---|
| 460 | close F;
|
|---|
| 461 | chmod 0077, $tmpfile;
|
|---|
| 462 | my @a = stat($tmpfile);
|
|---|
| 463 | my $s1 = -s _;
|
|---|
| 464 | -T _;
|
|---|
| 465 | my $s2 = -s _;
|
|---|
| 466 | is($s1, $s2, q(-T _ doesn't break the statbuffer));
|
|---|
| 467 | unlink $tmpfile;
|
|---|
| 468 | }
|
|---|
| 469 |
|
|---|
| 470 | END {
|
|---|
| 471 | 1 while unlink $tmpfile;
|
|---|
| 472 | }
|
|---|
