[Date Prev][Date Next][Thread Prev][Thread Next]
[Search]
[Date Index]
[Thread Index]
[FWP] the "it" hack
Hi everyone
Here is my first piece of perl source code hacking. As predicted,
it was trivial, requiring modifications to only nine files in the
5.7.1 source:
opcode.pl
hv.c
pp.c
toke.c
intrpvar.h
mg.c
av.c
keywords.h
embed.pl
The attached patch defines a pointer-to-sv stash where the perl
operations "defined" and "exists" store a copy of whatever they
were determining the definedness or existence of; also a new
operator, C<it> which provides (read-only) access to the stash.
This has two goals.
1: now your perl code can look more like your pseudocode,
in case you ever write things like
exists ${$_}{$_[0]} and return it;
in your design notebooks.
2: improve performance by avoiding redundant data structure
descents. Your mileage may vary. If you don't use the shortcut,
and your programs use exists and defined heavily, there will
be a slight performance hit.
Instructions:
Obtain and untar the 5.7.1 source, and save the patch file that
is attached to this e-mail.
Apply it something like this:
cd perl-5.7.1 && patch -p1 < ../perl-5.7.1_it.patch
Proceed with the compilation as normal.
Example of use:
./perl -le '%r = (aa..bb);print it;print $r{ag}; print it; defined 5;
print it'
should print :
ah
5
Thanks are due:
Brian Warnock selected the discussion from perl6-language to
include in his summary of the perl 6 lists, on June 4.
Michael Schwern reluctantly admitted that he could imagine
using the "it" operator.
Simon Cozens helpfully suggested which files to edit, even though
he does not approve of the concept implemented by the patch.
--
David Nicol 816.235.1187
Signature closed for repaving, please have a nice weekend.
--- perl-5.7.1/av.c Mon Mar 5 20:04:21 2001
+++ perl-5.7.1_it/av.c Fri Jun 8 22:28:46 2001
@@ -819,4 +819,46 @@
}
+
+/*
+=for apidoc av_exists_setit
+
+ av_exists, and also sets the "it" stash
+
+=cut
+*/
+bool
+Perl_av_exists_setit(pTHX_ AV *av, I32 key)
+{
+ if (!av)
+ return FALSE;
+ if (key < 0) {
+ key += AvFILL(av) + 1;
+ if (key < 0)
+ return FALSE;
+ }
+ if (SvRMAGICAL(av)) {
+ if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
+ SV *sv = sv_newmortal();
+ MAGIC *mg;
+
+ mg_copy((SV*)av, sv, 0, key);
+ mg = mg_find(sv, 'p');
+ if (mg) {
+ magic_existspack(sv, mg);
+ return SvTRUE(sv);
+ }
+ }
+ }
+ if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
+ && AvARRAY(av)[key])
+ {
+ PL_it_pointer = AvARRAY(av)[key];
+ return TRUE;
+ }
+ else
+ return FALSE;
+}
+
+
/* AVHV: Support for treating arrays as if they were hashes. The
* first element of the array should be a hash reference that maps
@@ -904,4 +946,16 @@
return av_exists(av, avhv_index_sv(HeVAL(he)));
+}
+bool
+Perl_avhv_exists_ent_setit(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+ HV *keys = avhv_keys(av);
+ HE *he;
+
+ he = hv_fetch_ent(keys, keysv, FALSE, hash);
+ if (!he || !SvOK(HeVAL(he)))
+ return FALSE;
+
+ return av_exists_setit(av, avhv_index_sv(HeVAL(he)));
}
--- perl-5.7.1/opcode.pl Mon Mar 5 20:06:13 2001
+++ perl-5.7.1_it/opcode.pl Fri Jun 8 13:37:49 2001
@@ -849,2 +849,6 @@
setstate set statement info ck_null s;
method_named method with known name ck_null d$
+
+# the "it" hack
+it it ck_null s0
+
--- perl-5.7.1/hv.c Fri Mar 9 08:59:40 2001
+++ perl-5.7.1_it/hv.c Fri Jun 8 22:27:30 2001
@@ -922,5 +922,96 @@
bool is_utf8;
char *keysave;
+
+ if (!hv)
+ return 0;
+
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ SV* svret = sv_newmortal();
+ sv = sv_newmortal();
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ magic_existspack(svret, mg_find(sv, 'p'));
+ return SvTRUE(svret);
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ key = SvPV(keysv, klen);
+ keysv = sv_2mortal(newSVpvn(key,klen));
+ (void)strupr(SvPVX(keysv));
+ hash = 0;
+ }
+#endif
+ }
+
+ xhv = (XPVHV*)SvANY(hv);
+#ifndef DYNAMIC_ENV_FETCH
+ if (!xhv->xhv_array)
+ return 0;
+#endif
+
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+#ifdef DYNAMIC_ENV_FETCH
+ if (!xhv->xhv_array) entry = Null(HE*);
+ else
+#endif
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ if (HeKUTF8(entry) != (char)is_utf8)
+ continue;
+ if (key != keysave)
+ Safefree(key);
+ return TRUE;
+ }
+#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
+ if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+ unsigned long len;
+ char *env = PerlEnv_ENVgetenv_len(key,&len);
+ if (env) {
+ sv = newSVpvn(env,len);
+ SvTAINTED_on(sv);
+ (void)hv_store_ent(hv,keysv,sv,hash);
+ return TRUE;
+ }
+ }
+#endif
+ if (key != keysave)
+ Safefree(key);
+ return FALSE;
+}
+
+
+
+/*
+=for apidoc hv_exists_ent_setit
+
+just like hv_exists_ent, but sets the "it" stash too.
+=cut
+*/
+bool
+Perl_hv_exists_ent_setit(pTHX_ HV *hv, SV *keysv, U32 hash)
+{
+ register XPVHV* xhv;
+ register char *key;
+ STRLEN klen;
+ register HE *entry;
+ SV *sv;
+ bool is_utf8;
+ char *keysave;
+
+
if (!hv)
return 0;
@@ -974,4 +1065,5 @@
if (key != keysave)
Safefree(key);
+ PL_it_pointer = entry->hent_val;
return TRUE;
}
--- perl-5.7.1/pp.c Thu Apr 5 17:15:53 2001
+++ perl-5.7.1_it/pp.c Fri Jun 8 21:31:46 2001
@@ -778,4 +778,5 @@
sv = POPs;
+ PL_it_pointer = sv;
if (!sv || !SvANY(sv))
RETPUSHNO;
@@ -3517,8 +3518,10 @@
HV *hv;
+ PL_it_pointer = &PL_sv_undef;
if (PL_op->op_private & OPpEXISTS_SUB) {
GV *gv;
CV *cv;
SV *sv = POPs;
+ PL_it_pointer = sv;
cv = sv_2cv(sv, &hv, &gv, FALSE);
if (cv)
@@ -3531,13 +3534,13 @@
hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV) {
- if (hv_exists_ent(hv, tmpsv, 0))
+ if (hv_exists_ent_setit(hv, tmpsv, 0))
RETPUSHYES;
}
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- if (av_exists((AV*)hv, SvIV(tmpsv)))
+ if (av_exists_setit((AV*)hv, SvIV(tmpsv)))
RETPUSHYES;
}
- else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
+ else if (avhv_exists_ent_setit((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
RETPUSHYES;
}
@@ -3924,4 +3927,11 @@
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
+ RETURN;
+}
+
+PP(pp_it)
+{
+ dSP;
+ PUSHs(PL_it_pointer);
RETURN;
}
--- perl-5.7.1/toke.c Sat Mar 31 23:43:59 2001
+++ perl-5.7.1_it/toke.c Fri Jun 8 13:18:18 2001
@@ -5108,4 +5108,7 @@
UNI(OP_TIED);
+ case KEY_it:
+ FUN0(OP_IT);
+
case KEY_time:
FUN0(OP_TIME);
@@ -5479,4 +5482,5 @@
case 2:
if (strEQ(d,"if")) return KEY_if;
+ if (strEQ(d,"it")) return -KEY_it;
break;
case 3:
--- perl-5.7.1/intrpvar.h Mon Mar 5 20:05:19 2001
+++ perl-5.7.1_it/intrpvar.h Fri Jun 8 21:39:35 2001
@@ -468,4 +468,5 @@
PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+PERLVARI(Iit_pointer, SV *,0) /* stash for "it" */
/* New variables must be added to the very end for binary compatibility.
--- perl-5.7.1/mg.c Fri Mar 30 23:26:20 2001
+++ perl-5.7.1_it/mg.c Fri Jun 8 18:07:43 2001
@@ -1292,4 +1292,5 @@
Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
{
+ PL_it_pointer = sv; /* dln */
return magic_methpack(sv,mg,"EXISTS");
}
--- perl-5.7.1/keywords.h Thu Apr 5 12:48:10 2001
+++ perl-5.7.1_it/keywords.h Fri Jun 8 13:32:54 2001
@@ -252,2 +252,3 @@
#define KEY_xor 251
#define KEY_y 252
+#define KEY_it 253
--- perl-5.7.1/embed.pl Fri Apr 6 08:19:51 2001
+++ perl-5.7.1_it/embed.pl Fri Jun 8 18:12:47 2001
@@ -1402,4 +1402,5 @@
Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
+Ap |bool |avhv_exists_ent_setit|AV *ar|SV* keysv|U32 hash
Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash
Ap |SV** |avhv_store_ent |AV *ar|SV* keysv|SV* val|U32 hash
@@ -1410,4 +1411,5 @@
Apd |SV* |av_delete |AV* ar|I32 key|I32 flags
Apd |bool |av_exists |AV* ar|I32 key
+Apd |bool |av_exists_setit |AV* ar|I32 key
Apd |void |av_extend |AV* ar|I32 key
p |AV* |av_fake |I32 size|SV** svp
@@ -1591,4 +1593,5 @@
Apd |bool |hv_exists |HV* tb|const char* key|I32 klen
Apd |bool |hv_exists_ent |HV* tb|SV* key|U32 hash
+Apd |bool |hv_exists_ent_setit |HV* tb|SV* key|U32 hash
Apd |SV** |hv_fetch |HV* tb|const char* key|I32 klen|I32 lval
Apd |HE* |hv_fetch_ent |HV* tb|SV* key|I32 lval|U32 hash