diff options
| author | Slaven Rezic <slaven@rezic.de> | 2003-05-03 20:26:49 +0200 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2003-05-03 15:30:45 +0000 |
| commit | 43b06338a7352a1850e7b7e6294bfb12026353ad (patch) | |
| tree | ed3f1cc0ab0bb6c1555d3de721520d03f1ec26be | |
| parent | feaeca788fb70f9d4aec1c392b5033f8e2c1542a (diff) | |
| download | perl-43b06338a7352a1850e7b7e6294bfb12026353ad.tar.gz | |
Re: Does filetest work at all?
Message-ID: <87ade4q9me.fsf@vran.herceg.de>
p4raw-id: //depot/perl@19394
| -rw-r--r-- | lib/filetest.t | 38 | ||||
| -rw-r--r-- | pp_sys.c | 12 |
2 files changed, 43 insertions, 7 deletions
diff --git a/lib/filetest.t b/lib/filetest.t index 096031c63d..c206f5143f 100644 --- a/lib/filetest.t +++ b/lib/filetest.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -use Test::More tests => 11; +use Test::More tests => 15; # these two should be kept in sync with the pragma itself # if hint bits are changed there, other things *will* break @@ -49,3 +49,39 @@ like( $@, qr/^$error/, 'filetest dies with missing subpragma on use' ); eval "no filetest"; like( $@, qr/^$error/, 'filetest dies with missing subpragma on unuse' ); + +SKIP: { + # A real test for filetest. + # This works for systems with /usr/bin/chflags (i.e. BSD4.4 systems). + my $chflags = "/usr/bin/chflags"; + my $tstfile = "filetest.tst"; + skip("No $chflags available", 2) if !-x $chflags; + + SKIP: { + eval { + if (!-e $tstfile) { + open(T, ">$tstfile") or die "Can't create $tstfile: $!"; + close T; + } + system($chflags, "uchg", $tstfile); + die "Can't exec $chflags uchg" if $? != 0; + }; + skip("Errors in test using chflags: $@", 2) if $@; + + { + use filetest 'access'; + is(-w $tstfile, undef, "$tstfile should not be recognized as writable"); + is(-W $tstfile, undef, "$tstfile should not be recognized as writable"); + } + { + no filetest 'access'; + is(-w $tstfile, 1, "$tstfile should be recognized as writable"); + is(-W $tstfile, 1, "$tstfile should be recognized as writable"); + } + } + + # cleanup + system($chflags, "nouchg", $tstfile); + unlink $tstfile; + warn "Can't remove $tstfile: $!" if -e $tstfile; +} @@ -2851,7 +2851,7 @@ PP(pp_ftrread) #if defined(HAS_ACCESS) && defined(R_OK) STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, R_OK); + result = access(POPpx, R_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2878,7 +2878,7 @@ PP(pp_ftrwrite) #if defined(HAS_ACCESS) && defined(W_OK) STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, W_OK); + result = access(POPpx, W_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2905,7 +2905,7 @@ PP(pp_ftrexec) #if defined(HAS_ACCESS) && defined(X_OK) STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, X_OK); + result = access(POPpx, X_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2932,7 +2932,7 @@ PP(pp_fteread) #ifdef PERL_EFF_ACCESS_R_OK STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_R_OK(TOPpx); + result = PERL_EFF_ACCESS_R_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2959,7 +2959,7 @@ PP(pp_ftewrite) #ifdef PERL_EFF_ACCESS_W_OK STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_W_OK(TOPpx); + result = PERL_EFF_ACCESS_W_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2986,7 +2986,7 @@ PP(pp_fteexec) #ifdef PERL_EFF_ACCESS_X_OK STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_X_OK(TOPpx); + result = PERL_EFF_ACCESS_X_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) |