develooper Front page | perl.perl5.porters | Postings from October 2003

[PATCH] stacked filetest operators

Thread Next
From:
Rafael Garcia-Suarez
Date:
October 10, 2003 13:21
Subject:
[PATCH] stacked filetest operators
Message ID:
20031010222257.15ba59c2.rgarciasuarez@free.fr
This patch implements stacked filetest operators. With it, the combined
expression C<-f -w -x $file> is equivalent to C<-x $file && -w _ && -f _>. It
does so by adding a new private flag to filetest operators, OPpFT_STACKED,
meaning that the immediate kid of a filetest operator is itself a filetest
operator. A filetest op that has this flag short-circuits if the previous
filetest returned false or undef, and uses the stat buffer if not.

IIRC Perl 6 will provide this syntax (as well as the less
backwards-compatible C<-fwx $file> combination, which I don't
think is suitable for Perl 5.)

The patch provides concise docs and tests, but no perldelta.pod
patch. I think it's suitable for 5.8.2.

Comments ?

Index: doio.c
===================================================================
--- doio.c	(revision 2678)
+++ doio.c	(working copy)
@@ -1338,6 +1338,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;
@@ -1364,6 +1367,8 @@ Perl_my_stat(pTHX)
     }
 }
 
+static char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
+
 I32
 Perl_my_lstat(pTHX)
 {
@@ -1374,7 +1379,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)) {
@@ -1383,6 +1388,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;
Index: pod/perlfunc.pod
===================================================================
--- pod/perlfunc.pod	(revision 2678)
+++ pod/perlfunc.pod	(working copy)
@@ -366,6 +366,9 @@ Example:
     print "Text\n" if -T _;
     print "Binary\n" if -B _;
 
+As of Perl 5.10, you can stack file test operators, in a way that
+C<-f -w -x $file> is equivalent to C<-x $file && -w _ && -f _>.
+
 =item abs VALUE
 
 =item abs
Index: t/op/filetest.t
===================================================================
--- t/op/filetest.t	(revision 2678)
+++ t/op/filetest.t	(working copy)
@@ -6,25 +6,17 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
 use Config;
-print "1..10\n";
-
-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";
+plan(tests => 22);
 
-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
 
 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 
 
 # 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?
 
-print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op";
-print "ok 10\n";
+is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" );
+
+# Test stackability of filetest operators
+
+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 );
Index: ext/B/B/Concise.pm
===================================================================
--- ext/B/B/Concise.pm	(revision 2678)
+++ ext/B/B/Concise.pm	(working copy)
@@ -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");
 
 sub private_flags {
     my($name, $x) = @_;
Index: op.c
===================================================================
--- op.c	(revision 2691)
+++ op.c	(working copy)
@@ -5023,6 +5023,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);
Index: op.h
===================================================================
--- op.h	(revision 2678)
+++ op.h	(working copy)
@@ -207,6 +207,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 ||	\
Index: dump.c
===================================================================
--- dump.c	(revision 2678)
+++ dump.c	(working copy)
@@ -624,9 +624,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO 
 	    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");
Index: pp_sys.c
===================================================================
--- pp_sys.c	(revision 2678)
+++ pp_sys.c	(working copy)
@@ -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))
@@ -3288,6 +3350,8 @@ PP(pp_fttext)
     GV *gv;
     STRLEN n_a;
     PerlIO *fp;
+
+    STACKED_FTEST_CHECK;
 
     if (PL_op->op_flags & OPf_REF)
 	gv = cGVOP_gv;

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About