Front page | perl.perl5.porters |
Postings from February 2000
logops that use 'defined' (|||) implemented
From:
John Tobey
Date:
February 23, 2000 02:00
Subject:
logops that use 'defined' (|||) implemented
Message ID:
m12NYaB-000FPKC@feynman.localnet
Not that this stands much chance of getting accepted into Perl, but at
least I should share it with the group...
For my own amusement and edification, I have added operators |||, &&&,
and such to my copy of Perl. ||| is like || but executes the right
side if the left is DEFINED, whether or not it is TRUE. &&& of course
does the right side if the left is NOT DEFINED. |||= and &&&= behave
as one would expect.
But wait! There's more. I also added four-character versions that
check for existence of a hash element.
# Perl way
sub highly_correct_cacher {
use vars '%cache';
my ($key) = @_;
if (! exists $cache{$key}) {
$cache{$key} = doit($key);
}
return $cache{$key};
}
# Ororor way
sub highly_correct_cacher {
use vars '%cache';
return $cache{$_[0]} ||||= doit($_[0]);
}
For the curious, the complete patch is at
<URL:http://john-edwin-tobey.org/Perl/perl5.5.660-ororor.patch.gz>.
Below is the abbreviated (sans generated files) version. As the old
saw goes, All Tests Pass(tm). (apparently none use &&&foo to mean &&
&foo) Of course, this patch is completely undocumented.
Sorry if I have disturbed you.. ;-)
-John
--
John Tobey, late nite hacker <jtobey@john-edwin-tobey.org>
\\\ ///
]]] With enough bugs, all eyes are shallow. [[[
/// \\\
diff -urN perl5.5.660/MANIFEST perl5.5.660.john/MANIFEST
--- perl5.5.660/MANIFEST Tue Feb 22 23:38:14 2000
+++ perl5.5.660.john/MANIFEST Wed Feb 23 03:27:26 2000
@@ -1351,6 +1351,7 @@
t/op/numconvert.t See if accessing fields does not change numeric values
t/op/oct.t See if oct and hex work
t/op/ord.t See if ord works
+t/op/ororor.t See if |||, &&&, ||||, and &&&& work
t/op/pack.t See if pack and unpack work
t/op/pat.t See if esoteric patterns work
t/op/pos.t See if pos works
diff -urN perl5.5.660/dump.c perl5.5.660.john/dump.c
--- perl5.5.660/dump.c Tue Feb 22 23:38:15 2000
+++ perl5.5.660.john/dump.c Wed Feb 23 02:05:32 2000
@@ -506,6 +506,15 @@
if (o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
}
+ else if (o->op_type == OP_ANDASSIGN ||
+ o->op_type == OP_ORASSIGN ||
+ o->op_type == OP_AND ||
+ o->op_type == OP_OR) {
+ switch (o->op_private & OPpLOG_FLAVOR) {
+ case OPpLOG_DEFINED: sv_catpv(tmpsv, ",DEFINED"); break;
+ case OPpLOG_EXISTS: sv_catpv(tmpsv, ",EXISTS"); break;
+ }
+ }
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
if (SvCUR(tmpsv))
diff -urN perl5.5.660/op.c perl5.5.660.john/op.c
--- perl5.5.660/op.c Tue Feb 22 23:38:17 2000
+++ perl5.5.660.john/op.c Wed Feb 23 02:48:58 2000
@@ -3515,9 +3515,15 @@
}
}
if (first->op_type == OP_CONST) {
+ SV *sv = ((SVOP*)first)->op_sv;
+ I32 flav = (flags >> 8) & OPpLOG_FLAVOR;
+ if (flav == OPpLOG_EXISTS)
+ Perl_croak(aTHX_ "%s argument is not a HASH element",
+ PL_op_desc[type]);
if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
- if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
+ if ((type == OP_AND) ==
+ (flav == OPpLOG_DEFINED ? !!SvOK(sv) : SvTRUE(sv))) {
op_free(first);
*firstp = Nullop;
return other;
@@ -3592,7 +3598,7 @@
first->op_next = (OP*)logop;
first->op_sibling = other;
- o = newUNOP(OP_NULL, 0, (OP*)logop);
+ o = newUNOP(OP_NULL, 0, CHECKOP(type, logop));
other->op_next = o;
return o;
@@ -5138,6 +5144,22 @@
else if (kid->op_type != OP_HELEM)
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
PL_op_desc[o->op_type]);
+ null(kid);
+ }
+ return o;
+}
+
+OP *
+Perl_ck_logop(pTHX_ OP *o)
+{
+ if (o->op_flags & OPf_KIDS &&
+ (o->op_private & OPpLOG_FLAVOR) == OPpLOG_EXISTS) {
+ OP *kid = cLOGOPo->op_first;
+ if (kid->op_type != OP_HELEM)
+ Perl_croak(aTHX_ "%s argument is not a HASH element",
+ PL_op_desc[o->op_type]);
+ /* Replace the hash deref operation with a no-op so runtime code
+ can detect whether the hash element exists. */
null(kid);
}
return o;
diff -urN perl5.5.660/op.h perl5.5.660.john/op.h
--- perl5.5.660/op.h Sun Feb 6 14:32:59 2000
+++ perl5.5.660.john/op.h Wed Feb 23 02:05:32 2000
@@ -193,6 +193,11 @@
/* Private for OP_THREADSV */
#define OPpDONE_SVREF 64 /* Been through newSVREF once */
+/* Private for OP_AND, OP_OR, OP_ANDASSIGN, and OP_ORASSIGN */
+#define OPpLOG_FLAVOR (2|4) /* Mask */
+#define OPpLOG_DEFINED 2 /* &&&, |||, &&&=, |||= */
+#define OPpLOG_EXISTS 4 /* &&&&, ||||, &&&&=, ||||= */
+
struct op {
BASEOP
};
diff -urN perl5.5.660/opcode.pl perl5.5.660.john/opcode.pl
--- perl5.5.660/opcode.pl Tue Feb 22 23:38:17 2000
+++ perl5.5.660.john/opcode.pl Wed Feb 23 02:05:32 2000
@@ -564,12 +564,12 @@
# Control.
-and logical and (&&) ck_null |
-or logical or (||) ck_null |
+and logical and (&&) ck_logop |
+or logical or (||) ck_logop |
xor logical xor ck_null fs2 S S
cond_expr conditional expression ck_null d|
-andassign logical and assignment (&&=) ck_null s|
-orassign logical or assignment (||=) ck_null s|
+andassign logical and assignment (&&=) ck_logop s|
+orassign logical or assignment (||=) ck_logop s|
method method lookup ck_method d1
entersub subroutine entry ck_subr dmt1 L
diff -urN perl5.5.660/perly.y perl5.5.660.john/perly.y
--- perl5.5.660/perly.y Sun Feb 6 14:32:59 2000
+++ perl5.5.660.john/perly.y Wed Feb 23 02:05:32 2000
@@ -97,11 +97,11 @@
%right NOTOP
%nonassoc LSTOP LSTOPSUB
%left ','
-%right <ival> ASSIGNOP
+%right <ival> ASSIGNOP ANDASSIGNOP ORASSIGNOP
%right '?' ':'
%nonassoc DOTDOT
-%left OROR
-%left ANDAND
+%left <ival> OROR
+%left <ival> ANDAND
%left <ival> BITOROP
%left <ival> BITANDOP
%nonassoc EQOP
@@ -473,10 +473,16 @@
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
-
-
term : term ASSIGNOP term
{ $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); }
+ | term ANDASSIGNOP term
+ { $$ = newLOGOP(OP_ANDASSIGN, $2,
+ mod(scalar($1), OP_ANDASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar($3))); }
+ | term ORASSIGNOP term
+ { $$ = newLOGOP(OP_ORASSIGN, $2,
+ mod(scalar($1), OP_ORASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar($3))); }
| term POWOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
| term MULOP term
@@ -498,9 +504,9 @@
| term DOTDOT term
{ $$ = newRANGE($2, scalar($1), scalar($3));}
| term ANDAND term
- { $$ = newLOGOP(OP_AND, 0, $1, $3); }
+ { $$ = newLOGOP(OP_AND, $2, $1, $3); }
| term OROR term
- { $$ = newLOGOP(OP_OR, 0, $1, $3); }
+ { $$ = newLOGOP(OP_OR, $2, $1, $3); }
| term '?' term ':' term
{ $$ = newCONDOP(0, $1, $3, $5); }
| term MATCHOP term
diff -urN perl5.5.660/pp_ctl.c perl5.5.660.john/pp_ctl.c
--- perl5.5.660/pp_ctl.c Tue Feb 22 23:38:18 2000
+++ perl5.5.660.john/pp_ctl.c Wed Feb 23 02:05:32 2000
@@ -1426,21 +1426,91 @@
PP(pp_andassign)
{
djSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
+ switch (PL_op->op_private & OPpLOG_FLAVOR) {
+ default:
+ if (!SvTRUE(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_DEFINED:
+ if (!SvOK(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_EXISTS: {
+ SV *sv = POPs;
+ HV *hv = (HV*)POPs;
+
+ if (SvTYPE(hv) == SVt_PVHV) {
+ STRLEN klen;
+ const char *key = SvPV(sv, klen);
+ if (!hv_exists_ent(hv, sv, 0))
+ RETPUSHNO;
+ PUSHs(*hv_fetch(hv, key, klen, 1));
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ if (!av_exists((AV*)hv, SvIV(sv)))
+ RETPUSHNO;
+ PUSHs(*av_fetch((AV*)hv, SvIV(sv), 1));
+ }
+ else { /* pseudo-hash elt */
+ if (!avhv_exists_ent((AV*)hv, sv, 0))
+ RETPUSHNO;
+ PUSHs(*avhv_fetch_ent((AV*)hv, sv, 1, 0));
+ }
+ }
+ else {
+ DIE(aTHX_ "Not a HASH reference");
+ }
+ break;
+ }
+ }
+ RETURNOP(cLOGOP->op_other);
}
PP(pp_orassign)
{
djSP;
- if (SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
+ switch (PL_op->op_private & OPpLOG_FLAVOR) {
+ default:
+ if (SvTRUE(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_DEFINED:
+ if (SvOK(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_EXISTS: {
+ SV *sv = POPs;
+ HV *hv = (HV*)POPs;
+ bool existed;
+
+ if (SvTYPE(hv) == SVt_PVHV) {
+ STRLEN klen;
+ const char *key = SvPV(sv, klen);
+ existed = hv_exists_ent(hv, sv, 0);
+ PUSHs(*hv_fetch(hv, key, klen, 1));
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ existed = av_exists((AV*)hv, SvIV(sv));
+ PUSHs(*av_fetch((AV*)hv, SvIV(sv), 1));
+ }
+ else { /* pseudo-hash elt */
+ existed = avhv_exists_ent((AV*)hv, sv, 0);
+ PUSHs(*avhv_fetch_ent((AV*)hv, sv, 1, 0));
+ }
+ }
+ else {
+ DIE(aTHX_ "Not a HASH reference");
+ }
+ if (existed)
+ RETURN;
+ break;
+ }
+ }
+ RETURNOP(cLOGOP->op_other);
}
-
+
PP(pp_caller)
{
djSP;
diff -urN perl5.5.660/pp_hot.c perl5.5.660.john/pp_hot.c
--- perl5.5.660/pp_hot.c Tue Feb 22 23:38:18 2000
+++ perl5.5.660.john/pp_hot.c Wed Feb 23 02:05:33 2000
@@ -96,12 +96,39 @@
PP(pp_and)
{
djSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else {
- --SP;
+ switch (PL_op->op_private & OPpLOG_FLAVOR) {
+ default:
+ if (!SvTRUE(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_DEFINED:
+ if (!SvOK(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_EXISTS: {
+ SV *sv = POPs;
+ HV *hv = (HV*)POPs;
+
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (!hv_exists_ent(hv, sv, 0))
+ RETPUSHNO;
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ if (!av_exists((AV*)hv, SvIV(sv)))
+ RETPUSHNO;
+ }
+ else if (!avhv_exists_ent((AV*)hv, sv, 0)) /* pseudo-hash elt */
+ RETPUSHNO;
+ }
+ else {
+ DIE(aTHX_ "Not a HASH reference");
+ }
RETURNOP(cLOGOP->op_other);
}
+ }
+ --SP;
+ RETURNOP(cLOGOP->op_other);
}
PP(pp_sassign)
@@ -259,12 +286,47 @@
PP(pp_or)
{
djSP;
- if (SvTRUE(TOPs))
- RETURN;
- else {
- --SP;
+ switch (PL_op->op_private & OPpLOG_FLAVOR) {
+ default:
+ if (SvTRUE(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_DEFINED:
+ if (SvOK(TOPs))
+ RETURN;
+ break;
+ case OPpLOG_EXISTS: {
+ SV *sv = POPs;
+ HV *hv = (HV*)POPs;
+
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (hv_exists_ent(hv, sv, 0)) {
+ STRLEN klen;
+ const char *key = SvPV(sv, klen);
+ PUSHs(*hv_fetch(hv, key, klen, 0));
+ RETURN;
+ }
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ if (av_exists((AV*)hv, SvIV(sv))) {
+ PUSHs(*av_fetch((AV*)hv, SvIV(sv), FALSE));
+ RETURN;
+ }
+ }
+ else if (avhv_exists_ent((AV*)hv, sv, 0)) { /* pseudo-hash elt */
+ PUSHs(*avhv_fetch_ent((AV*)hv, sv, 0, 0));
+ RETURN;
+ }
+ }
+ else {
+ DIE(aTHX_ "Not a HASH reference");
+ }
RETURNOP(cLOGOP->op_other);
}
+ }
+ --SP;
+ RETURNOP(cLOGOP->op_other);
}
PP(pp_add)
diff -urN perl5.5.660/t/op/ororor.t perl5.5.660.john/t/op/ororor.t
--- perl5.5.660/t/op/ororor.t Wed Dec 31 19:00:00 1969
+++ perl5.5.660.john/t/op/ororor.t Wed Feb 23 03:16:17 2000
@@ -0,0 +1,58 @@
+#!./perl -w
+
+print "1..20\n";
+
+$u = undef;
+$z = 0;
+%h = (k => undef);
+$r = {k => undef};
+
+undef &&& print "not ok 1\n";
+undef ||| print "ok 1\n";
+$u &&& print "not ok 2\n";
+$u ||| print "ok 2\n";
+
+0 &&& print "ok 3\n";
+0 ||| print "not ok 3\n";
+$z &&& print "ok 4\n";
+$z ||| print "not ok 4\n";
+
+$u &&&= (print "not ");
+$u |||= (print "ok 5\n");
+$u || (print "not ");
+print "ok 6\n";
+
+$z |||= (print "not ");
+$z &&&= (print "ok 7\n");
+$z || (print "not ");
+print "ok 8\n";
+
+$h{z} &&&& print "not ok 9\n";
+$h{z} |||| print "ok 9\n";
+$$r{z} &&&& print "not ok 10\n";
+$$r{z} |||| print "ok 10\n";
+
+$h{k} &&&& print "ok 11\n";
+$h{k} |||| print "not ok 11\n";
+$$r{k} &&&& print "ok 12\n";
+$$r{k} |||| print "not ok 12\n";
+
+$h{z} &&&&= (print "not ");
+$h{z} ||||= (print "ok 13\n");
+print "not " unless exists $h{z};
+print "ok 14\n";
+
+$$r{z} &&&&= (print "not ");
+$$r{z} ||||= do {print "ok 15\n"; undef};
+print "not " unless exists $$r{z};
+print "ok 16\n";
+
+$h{k} ||||= (print "not ");
+$h{k} &&&&= (print "ok 17\n");
+$h{k} || (print "not ");
+print "ok 18\n";
+
+$$r{k} ||||= (print "not ");
+$$r{k} &&&&= (print "ok 19\n");
+$$r{k} || (print "not ");
+print "ok 20\n";
diff -urN perl5.5.660/toke.c perl5.5.660.john/toke.c
--- perl5.5.660/toke.c Tue Feb 22 23:38:19 2000
+++ perl5.5.660.john/toke.c Wed Feb 23 02:05:32 2000
@@ -169,10 +169,11 @@
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
- yylval.ival = OP_ANDASSIGN;
+ toketype = ANDASSIGNOP;
else if (toketype == OROR)
- yylval.ival = OP_ORASSIGN;
- toketype = ASSIGNOP;
+ toketype = ORASSIGNOP;
+ else
+ toketype = ASSIGNOP;
}
return toketype;
}
@@ -3090,10 +3091,20 @@
TOKEN(';');
case '&':
s++;
- tmp = *s++;
- if (tmp == '&')
+ if (*s == '&') {
+ for (tmp = 0; *++s == '&'; tmp++)
+ ;
+ switch (tmp) {
+ case 0: yylval.ival = 0; break;
+ case 1: yylval.ival = (OPpLOG_DEFINED<<8); break;
+ default:
+ Perl_warner(aTHX_ WARN_SYNTAX, "Extra '&' characters ignored"
+ " in &&&& operator");
+ /* FALL THROUGH */
+ case 2: yylval.ival = (OPpLOG_EXISTS<<8); break;
+ }
AOPERATOR(ANDAND);
- s--;
+ }
if (PL_expect == XOPERATOR) {
if (ckWARN(WARN_SEMICOLON)
&& isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
@@ -3117,10 +3128,20 @@
case '|':
s++;
- tmp = *s++;
- if (tmp == '|')
+ if (*s == '|') {
+ for (tmp = 0; *++s == '|'; tmp++)
+ ;
+ switch (tmp) {
+ case 0: yylval.ival = 0; break;
+ case 1: yylval.ival = (OPpLOG_DEFINED<<8); break;
+ default:
+ Perl_warner(aTHX_ WARN_SYNTAX, "Extra '|' characters ignored"
+ " in |||| operator");
+ /* FALL THROUGH */
+ case 2: yylval.ival = (OPpLOG_EXISTS<<8); break;
+ }
AOPERATOR(OROR);
- s--;
+ }
BOop(OP_BIT_OR);
case '=':
s++;
End of patch.