Implement stacked filetest operators (-f -w -x $file).

p4raw-id: //depot/perl@22294

diff --git a/doio.c b/doio.c
index dc192d4..f0b036a 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1336,6 +1336,9 @@ Perl_my_stat(pTHX)
            return (PL_laststatval = -1);
        }
     }
+    else if (PL_op->op_private & OPpFT_STACKED) {
+       return PL_laststatval;
+    }
     else {
        SV* sv = POPs;
        char *s;
@@ -1362,6 +1365,8 @@ Perl_my_stat(pTHX)
     }
 }
 
+static char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
+
 I32
 Perl_my_lstat(pTHX)
 {
@@ -1372,7 +1377,7 @@ Perl_my_lstat(pTHX)
        EXTEND(SP,1);
        if (cGVOP_gv == PL_defgv) {
            if (PL_laststype != OP_LSTAT)
-               Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
+               Perl_croak(aTHX_ no_prev_lstat);
            return PL_laststatval;
        }
        if (ckWARN(WARN_IO)) {
@@ -1381,6 +1386,9 @@ Perl_my_lstat(pTHX)
            return (PL_laststatval = -1);
        }
     }
+    else if (ckWARN(WARN_IO) && PL_laststype != OP_LSTAT
+           && (PL_op->op_private & OPpFT_STACKED))
+       Perl_croak(aTHX_ no_prev_lstat);
 
     PL_laststype = OP_LSTAT;
     PL_statgv = Nullgv;

diff --git a/dump.c b/dump.c
index 75124c6..5f56689 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -624,9 +624,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
            if (o->op_private & OPpHUSH_VMSISH)
                sv_catpv(tmpsv, ",HUSH_VMSISH");
        }
-       else if (OP_IS_FILETEST_ACCESS(o)) {
-            if (o->op_private & OPpFT_ACCESS)
-                 sv_catpv(tmpsv, ",FT_ACCESS");
+       else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
+           if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
+               sv_catpv(tmpsv, ",FT_ACCESS");
+           if (o->op_private & OPpFT_STACKED)
+               sv_catpv(tmpsv, ",FT_STACKED");
        }
        if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
            sv_catpv(tmpsv, ",INTRO");

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 7aadd0b..2b8a612 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -423,6 +423,12 @@ $priv{"threadsv"}{64} = "SVREFd";
 $priv{"exit"}{128} = "VMS";
 $priv{$_}{2} = "FTACCESS"
   for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
+$priv{$_}{4} = "FTSTACKED"
+  for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+       "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+       "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+       "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+       "ftbinary");
 $priv{$_}{2} = "GREPLEX"
   for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 

diff --git a/op.c b/op.c
index 83c6fc1..e45b664 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5058,6 +5058,9 @@ Perl_ck_ftst(pTHX_ OP *o)
              OP_IS_FILETEST_ACCESS(o))
            o->op_private |= OPpFT_ACCESS;
        }
+       if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
+               && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+           o->op_private |= OPpFT_STACKED;
     }
     else {
        op_free(o);

diff --git a/op.h b/op.h
index aeaae1c..e957e1b 100644 (file)
--- a/op.h
+++ b/op.h
@@ -209,6 +209,7 @@ Deprecated.  Use C<GIMME_V> instead.
 
 /* Private of OP_FTXXX */
 #define OPpFT_ACCESS           2       /* use filetest 'access' */
+#define OPpFT_STACKED          4       /* stacked filetest, as in "-f -x $f" */
 #define OP_IS_FILETEST_ACCESS(op)              \
        (((op)->op_type) == OP_FTRREAD  ||      \
         ((op)->op_type) == OP_FTRWRITE ||      \

diff --git a/pod/perl591delta.pod b/pod/perl591delta.pod
index bf26c2b..564db34 100644 (file)
--- a/pod/perl591delta.pod
+++ b/pod/perl591delta.pod
@@ -57,6 +57,12 @@ L<perlform> has been improved, and miscellaneous bugs fixed.
 Now applying C<:unique> to lexical variables and to subroutines will
 result in a compilation error.
 
+=head2 Stacked filetest operators
+
+As a new form of syntactic sugar, it's now possible to stack up filetest
+operators. You can now write C<-f -w -x $file> in a row to mean
+C<-x $file && -w _ && -f _>. See L<perlfunc/-X>.
+
 =head1 Modules and Pragmata
 
 =over 4

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 13cfdab..a0ae4b1 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -366,6 +366,12 @@ Example:
     print "Text\n" if -T _;
     print "Binary\n" if -B _;
 
+As of Perl 5.9.1, as a form of purely syntactic sugar, you can stack file
+test operators, in a way that C<-f -w -x $file> is equivalent to
+C<-x $file && -w _ && -f _>. (This is only syntax fancy : if you use
+the return value of C<-f $file> as an argument to another filetest
+operator, no special magic will happen.)
+
 =item abs VALUE
 
 =item abs

diff --git a/pp_sys.c b/pp_sys.c
index 3de073d..d6f095b 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2877,13 +2877,23 @@ PP(pp_stat)
     RETURN;
 }
 
+/* This macro is used by the stacked filetest operators :
+ * if the previous filetest failed, short-circuit and pass its value.
+ * Else, discard it from the stack and continue. --rgs
+ */
+#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
+       if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
+       else { (void)POPs; PUTBACK; } \
+    }
+
 PP(pp_ftrread)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #if defined(HAS_ACCESS) && defined(R_OK)
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = access(POPpx, R_OK);
        if (result == 0)
            RETPUSHYES;
@@ -2908,9 +2918,10 @@ PP(pp_ftrwrite)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #if defined(HAS_ACCESS) && defined(W_OK)
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = access(POPpx, W_OK);
        if (result == 0)
            RETPUSHYES;
@@ -2935,9 +2946,10 @@ PP(pp_ftrexec)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #if defined(HAS_ACCESS) && defined(X_OK)
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = access(POPpx, X_OK);
        if (result == 0)
            RETPUSHYES;
@@ -2962,9 +2974,10 @@ PP(pp_fteread)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #ifdef PERL_EFF_ACCESS_R_OK
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = PERL_EFF_ACCESS_R_OK(POPpx);
        if (result == 0)
            RETPUSHYES;
@@ -2989,9 +3002,10 @@ PP(pp_ftewrite)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #ifdef PERL_EFF_ACCESS_W_OK
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = PERL_EFF_ACCESS_W_OK(POPpx);
        if (result == 0)
            RETPUSHYES;
@@ -3016,9 +3030,10 @@ PP(pp_fteexec)
 {
     I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
 #ifdef PERL_EFF_ACCESS_X_OK
-    STRLEN n_a;
     if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+       STRLEN n_a;
        result = PERL_EFF_ACCESS_X_OK(POPpx);
        if (result == 0)
            RETPUSHYES;
@@ -3041,8 +3056,11 @@ PP(pp_fteexec)
 
 PP(pp_ftis)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     RETPUSHYES;
@@ -3055,8 +3073,11 @@ PP(pp_fteowned)
 
 PP(pp_ftrowned)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
@@ -3067,8 +3088,11 @@ PP(pp_ftrowned)
 
 PP(pp_ftzero)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (PL_statcache.st_size == 0)
@@ -3078,8 +3102,11 @@ PP(pp_ftzero)
 
 PP(pp_ftsize)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP; dTARGET;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
 #if Off_t_size > IVSIZE
@@ -3092,8 +3119,11 @@ PP(pp_ftsize)
 
 PP(pp_ftmtime)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP; dTARGET;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
@@ -3102,8 +3132,11 @@ PP(pp_ftmtime)
 
 PP(pp_ftatime)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP; dTARGET;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
@@ -3112,8 +3145,11 @@ PP(pp_ftatime)
 
 PP(pp_ftctime)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP; dTARGET;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
@@ -3122,8 +3158,11 @@ PP(pp_ftctime)
 
 PP(pp_ftsock)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISSOCK(PL_statcache.st_mode))
@@ -3133,8 +3172,11 @@ PP(pp_ftsock)
 
 PP(pp_ftchr)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISCHR(PL_statcache.st_mode))
@@ -3144,8 +3186,11 @@ PP(pp_ftchr)
 
 PP(pp_ftblk)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISBLK(PL_statcache.st_mode))
@@ -3155,8 +3200,11 @@ PP(pp_ftblk)
 
 PP(pp_ftfile)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISREG(PL_statcache.st_mode))
@@ -3166,8 +3214,11 @@ PP(pp_ftfile)
 
 PP(pp_ftdir)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISDIR(PL_statcache.st_mode))
@@ -3177,8 +3228,11 @@ PP(pp_ftdir)
 
 PP(pp_ftpipe)
 {
-    I32 result = my_stat();
+    I32 result;
     dSP;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
+    SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISFIFO(PL_statcache.st_mode))
@@ -3201,7 +3255,9 @@ PP(pp_ftsuid)
 {
     dSP;
 #ifdef S_ISUID
-    I32 result = my_stat();
+    I32 result;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3215,7 +3271,9 @@ PP(pp_ftsgid)
 {
     dSP;
 #ifdef S_ISGID
-    I32 result = my_stat();
+    I32 result;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3229,7 +3287,9 @@ PP(pp_ftsvtx)
 {
     dSP;
 #ifdef S_ISVTX
-    I32 result = my_stat();
+    I32 result;
+    STACKED_FTEST_CHECK;
+    result = my_stat();
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3247,6 +3307,8 @@ PP(pp_fttty)
     char *tmps = Nullch;
     STRLEN n_a;
 
+    STACKED_FTEST_CHECK;
+
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
     else if (isGV(TOPs))
@@ -3289,6 +3351,8 @@ PP(pp_fttext)
     STRLEN n_a;
     PerlIO *fp;
 
+    STACKED_FTEST_CHECK;
+
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
     else if (isGV(TOPs))

diff --git a/t/op/filetest.t b/t/op/filetest.t
index fcded7a..d0ca69a 100755 (executable)
--- a/t/op/filetest.t
+++ b/t/op/filetest.t
@@ -6,25 +6,17 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
 use Config;
-print "1..10\n";
+plan(tests => 22);
 
-print "not " unless -d 'op';
-print "ok 1\n";
-
-print "not " unless -f 'TEST';
-print "ok 2\n";
-
-print "not " if -f 'op';
-print "ok 3\n";
-
-print "not " if -d 'TEST';
-print "ok 4\n";
-
-print "not " unless -r 'TEST';
-print "ok 5\n";
+ok( -d 'op' );
+ok( -f 'TEST' );
+ok( !-f 'op' );
+ok( !-d 'TEST' );
+ok( -r 'TEST' );
 
 # make sure TEST is r-x
 eval { chmod 0555, 'TEST' };
@@ -35,18 +27,19 @@ eval '$> = 1';              # so switch uid (may not be implemented)
 
 print "# oldeuid = $oldeuid, euid = $>\n";
 
-if (!$Config{d_seteuid}) {
-    print "ok 6 #skipped, no seteuid\n";
-} 
-elsif ($Config{config_args} =~/Dmksymlinks/) {
-    print "ok 6 #skipped, we cannot chmod symlinks\n";
-}
-elsif ($bad_chmod) {
-    print "#[$@]\nok 6 #skipped\n";
-}
-else {
-    print "not " if -w 'TEST';
-    print "ok 6\n";
+SKIP: {
+    if (!$Config{d_seteuid}) {
+       skip('no seteuid');
+    } 
+    elsif ($Config{config_args} =~/Dmksymlinks/) {
+       skip('we cannot chmod symlinks');
+    }
+    elsif ($bad_chmod) {
+       skip( $@ );
+    }
+    else {
+       ok( !-w 'TEST' );
+    }
 }
 
 # Scripts are not -x everywhere so cannot test that.
@@ -55,20 +48,33 @@ eval '$> = $oldeuid';       # switch uid back (may not be implemented)
 
 # this would fail for the euid 1
 # (unless we have unpacked the source code as uid 1...)
-print "not " unless -r 'op';
-print "ok 7\n";
+ok( -r 'op' );
 
 # this would fail for the euid 1
 # (unless we have unpacked the source code as uid 1...)
-if ($Config{d_seteuid}) {
-    print "not " unless -w 'op';
-    print "ok 8\n";
-} else {
-    print "ok 8 #skipped, no seteuid\n";
+SKIP: {
+    if ($Config{d_seteuid}) {
+       ok( -w 'op' );
+    } else {
+       skip('no seteuid');
+    }
 }
 
-print "not " unless -x 'op'; # Hohum.  Are directories -x everywhere?
-print "ok 9\n";
+ok( -x 'op' ); # Hohum.  Are directories -x everywhere?
+
+is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" );
+
+# Test stackability of filetest operators
 
-print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op";
-print "ok 10\n";
+ok( defined( -f -d 'TEST' ) && ! -f -d _ );
+ok( !defined( -e 'zoo' ) );
+ok( !defined( -e -d 'zoo' ) );
+ok( !defined( -f -e 'zoo' ) );
+ok( -f -e 'TEST' );
+ok( -e -f 'TEST' );
+ok( defined(-d -e 'TEST') );
+ok( defined(-e -d 'TEST') );
+ok( ! -f -d 'op' );
+ok( -x -d -x 'op' );
+ok( (-s -f 'TEST' > 1), "-s returns real size" );
+ok( -f -s 'TEST' == 1 );