Front page | perl.perl5.porters |
Postings from November 1999
[PATCH 5.005_62] my Dog $spot and prepare - again
Thread Next
From:
Ilya Zakharevich
Date:
November 21, 1999 00:01
Subject:
[PATCH 5.005_62] my Dog $spot and prepare - again
Message ID:
199911210801.DAA02476@monk.mps.ohio-state.edu
This is the reworked version of my old 'PREPARE on my Dog $spot'
patch. Documentation is in the first chunks.
I also catched a possibility to remove a defined out chunk of gv.c.
Ilya
P.S. I inserted stuff into embed.pl in alphabetical order: it is not
clear *where* the actual end is... :-(
--- ./pod/perlsub.pod.orig Sat Sep 25 01:25:28 1999
+++ ./pod/perlsub.pod Sun Nov 21 02:39:08 1999
@@ -407,6 +407,22 @@ have to be in the symbol table of some p
L<perlref/"Function Templates"> for something of a work-around to
this.
+When my() is used with a variable which is declared as being of class
+C<Foo>, as in
+
+ my Foo $foo = 'foobar';
+
+and if C<Foo> overloads C<prepare> operation, the method for this operation
+is called via C<'Foo'>. Say, if the package C<Foo> has a declaration
+
+ use overload prepare => 'PREPARE';
+
+then the above statement behaves as if
+
+ 'Foo'->PREPARE($foo);
+
+was called before assigning C<'foobar'> to $foo.
+
=head2 Persistent Private Variables
Just because a lexical variable is lexically (also called statically)
--- ./lib/overload.pm.orig Fri Aug 20 10:51:32 1999
+++ ./lib/overload.pm Sun Nov 21 02:51:18 1999
@@ -123,7 +123,7 @@ sub mycan { # Real can would leave st
conversion => 'bool "" 0+',
iterators => '<>',
dereferencing => '${} @{} %{} &{} *{}',
- special => 'nomethod fallback =');
+ special => 'nomethod fallback = prepare');
sub constant {
# Arguments: what, sub
@@ -406,7 +406,7 @@ A computer-readable form of the above ta
conversion => 'bool "" 0+',
iterators => '<>',
dereferencing => '${} @{} %{} &{} *{}',
- special => 'nomethod fallback ='
+ special => 'nomethod fallback = prepare'
=head2 Inheritance and overloading
@@ -553,6 +553,25 @@ C<'='> was overloaded with C<\&clone>.
Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for
C<$b = $a; ++$a>.
+
+=head2 C<prepare>
+
+The value for C<"prepare"> is a reference to a function with two
+arguments. If a class C<Int> overloads C<prepare> to a method C<PREPARE>,
+then the statement
+
+ my Int $i = 17;
+
+calls a method C<Int-E<gt>PREPARE($i)> before the assignment is performed.
+The same call is done for
+
+ my Int $i;
+
+One possible usage of this would be to C<tie $i> into another package,
+say C<Int::Tied>, with C<STORE> method which autoconverts to the class C<Int>.
+
+See L<Metaphor clash> for an explanation why this may be needed to
+support some interfaces.
=head1 MAGIC AUTOGENERATION
--- ./t/pragma/overload.t.orig Tue Oct 12 11:17:16 1999
+++ ./t/pragma/overload.t Sun Nov 21 02:19:58 1999
@@ -922,6 +922,120 @@ unless ($aaa) {
test 'is not', 'ok';
}
+{
+ package NNN::Tie;
+
+ sub TIESCALAR { bless [] }
+ sub FETCH {'<' . shift->[0] . '>' }
+ sub STORE { my $me = shift; $me->[0] = '(' . shift() . ')'; }
+
+ package NNN;
+
+ use overload prepare => sub { tie $_[1], 'NNN::Tie' };
+}
+
+my NNN $aa5 = 5;
+test $aa5, '<(5)>';
+
+{
+ package NN::Ovl;
+
+ use overload '""' => \&stringify;
+ sub stringify { '[' . (join '', @{shift()}) . ']'}
+ sub TIESCALAR { bless [] }
+ sub FETCH { shift }
+ sub STORE { my $me = shift; @$me = ('(' , shift , ')' ); }
+
+ package NN;
+
+ use overload prepare => sub { tie $_[1], 'NN::Ovl' };
+}
+
+my NN $aa4 = 4;
+test "$aa4", '[(4)]';
+
+{
+ package NN1::Tie;
+
+ sub TIESCALAR { bless [] }
+ sub FETCH { shift->[0] }
+ sub STORE {
+ my ($me, $in) = @_;
+ @$me = $in, return if UNIVERSAL::isa $in, 'NN1::Ovl';
+ @$me = bless [$in], 'NN1::Ovl';
+ }
+
+ package NN1::Ovl;
+
+ use overload '""' => \&stringify, '+' => \&add;
+ sub stringify { '[' . (join '', @{shift()}) . ']'}
+ sub add { bless [ "$_[0] + $_[1]" ] }
+
+ package NN1;
+
+ use overload prepare => sub { tie $_[1], 'NN1::Tie' }
+}
+
+my NN1 $aa3 = 3;
+test "$aa3", '[3]';
+my $x3 = $aa3 + 5;
+test "$x3", '[[3] + 5]';
+my NN1 $x33 = $aa3 + 5;
+test "$x33", '[[3] + 5]';
+
+{
+ package NN2;
+
+ sub TIESCALAR { bless [] }
+ sub FETCH { shift->[0] }
+ sub STORE {
+ my ($me, $in) = @_;
+ @$me = $in, return if UNIVERSAL::isa $in, __PACKAGE__;
+ @$me = __PACKAGE__->new($in);
+ }
+
+ sub new {my $class = shift; bless [shift], $class }
+
+ use overload '""' => \&stringify, '+' => \&add;
+ sub stringify { '[' . (join '', @{shift()}) . ']'}
+ sub add { __PACKAGE__->new("$_[0] + $_[1]") }
+
+ use overload prepare => sub { tie $_[1], __PACKAGE__ }
+}
+
+my NN2 $bb3 = 3;
+test "$bb3", '[3]';
+my $y3 = $bb3 + 5;
+test "$y3", '[[3] + 5]';
+my NN2 $y33 = $bb3 + 5;
+test "$y33", '[[3] + 5]';
+
+{
+ package NN3;
+
+ sub TIESCALAR { bless [] }
+ sub FETCH { shift }
+ sub STORE {
+ my ($me, $in) = @_;
+ @$me = @$in, return if UNIVERSAL::isa $in, __PACKAGE__;
+ @$me = @{__PACKAGE__->new($in)};
+ }
+
+ sub new {my $class = shift; bless [shift], $class }
+
+ use overload '""' => \&stringify, '+' => \&add;
+ sub stringify { '[' . (join '', @{shift()}) . ']'}
+ sub add { __PACKAGE__->new("$_[0] + $_[1]") }
+
+ use overload prepare => sub { tie $_[1], __PACKAGE__ }
+}
+
+my NN2 $bb3 = 3;
+test "$bb3", '[3]';
+my $y3 = $bb3 + 5;
+test "$y3", '[[3] + 5]';
+my NN2 $y33 = $bb3 + 5;
+test "$y33", '[[3] + 5]';
# Last test is:
-sub last {208}
+sub last {219}
--- ./pp.c.orig Tue Nov 2 19:40:50 1999
+++ ./pp.c Sun Nov 21 01:07:50 1999
@@ -5610,3 +5610,26 @@ PP(pp_threadsv)
DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
#endif /* USE_THREADS */
}
+
+PP(pp_svalloc)
+{
+ djSP; dTARGET;
+ AV *av = (AV*)cSVOP->op_sv;
+ SV **svp = AvARRAY(av);
+
+ SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ if (PL_op->op_flags & OPf_MOD && PL_op->op_private & OPpDEREF) {
+ vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
+ SPAGAIN;
+ }
+ ENTER;
+ PUSHMARK(SP);
+ XPUSHs(svp[0]);
+ XPUSHs(TARG);
+ PUTBACK;
+ call_sv(svp[1],G_VOID);
+ SPAGAIN;
+ LEAVE;
+ SETs(TARG);
+ RETURN;
+}
--- ./op.c.orig Wed Nov 3 03:42:50 1999
+++ ./op.c Sun Nov 21 02:17:10 1999
@@ -688,6 +688,7 @@ S_op_clear(pTHX_ OP *o)
SvREFCNT_dec(cGVOPo->op_gv);
cGVOPo->op_gv = Nullgv;
break;
+ case OP_SVALLOC:
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = Nullsv;
@@ -919,6 +920,7 @@ Perl_scalarvoid(pTHX_ OP *o)
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
+ case OP_SVALLOC:
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
@@ -1424,6 +1426,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
goto nomod;
/* FALL THROUGH */
case OP_PADSV:
+ case OP_SVALLOC:
PL_modcount++;
if (!type)
Perl_croak(aTHX_ "Can't localize lexical variable %s",
@@ -1612,6 +1615,7 @@ Perl_ref(pTHX_ OP *o, I32 type)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
+ case OP_SVALLOC:
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
@@ -1743,8 +1747,30 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
return o;
- } else if (type != OP_PADSV &&
- type != OP_PADAV &&
+ } else if (type == OP_PADSV) {
+ SV **descrp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
+ HV *stash;
+ CV *cv;
+ int dummy;
+
+ if ( SvOBJECT(*descrp)
+ && (stash = SvSTASH(*descrp))
+ && (cv = Perl_gv_overload_cv(pTHX_ stash, "prepare", &dummy)) ) {
+ AV *av = newAV();
+ SV *name = newSVpv(HvNAME(stash), 0);
+ OP *o2 = newSVOP(OP_SVALLOC, 0, (SV*)av);
+
+ /* As in gv_fullname3(name, ???, Nullch) */
+ av_extend(av, 1);
+ av_store(av, 0, name);
+ av_store(av, 1, SvREFCNT_inc(cv));
+ o2->op_targ = o->op_targ;
+ op_free(o);
+ o = o2;
+ }
+ if (attrs)
+ goto do_attrs;
+ } else if (type != OP_PADAV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
{
@@ -1756,6 +1782,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
SV *padsv;
SV **namesvp;
+ do_attrs:
/* check for C<my Dog $spot> when deciding package */
namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
@@ -3115,6 +3142,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *le
SvCUR(gv) = PL_generation;
}
else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_SVALLOC ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
curop->op_type == OP_PADANY) {
@@ -5877,6 +5905,7 @@ Perl_ck_subr(pTHX_ OP *o)
case '$':
if (o2->op_type != OP_RV2SV
&& o2->op_type != OP_PADSV
+ && o2->op_type != OP_SVALLOC
&& o2->op_type != OP_HELEM
&& o2->op_type != OP_AELEM
&& o2->op_type != OP_THREADSV)
@@ -6149,7 +6178,9 @@ Perl_peep(pTHX_ register OP *o)
|| ((BINOP*)o)->op_last->op_type != OP_CONST)
break;
rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ if (rop->op_type != OP_RV2HV
+ || (rop->op_first->op_type != OP_PADSV
+ && rop->op_first->op_type != OP_SVALLOC))
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
if (!SvOBJECT(lexname))
--- ./opcode.pl.orig Thu Oct 7 21:23:22 1999
+++ ./opcode.pl Sun Nov 21 01:07:50 1999
@@ -801,3 +801,4 @@ threadsv per-thread value ck_null ds0
# Control (contd.)
setstate set statement info ck_null s;
method_named method with known name ck_null d$
+svalloc typed lexical allocation ck_null ds$
--- ./lib/Opcode.pm.orig Mon Nov 15 23:59:06 1999
+++ ./lib/Opcode.pm Sun Nov 21 02:29:38 1999
@@ -414,6 +414,8 @@ These are a hotchpotch of opcodes still
entertry leavetry -- can be used to 'hide' fatal errors
+ svalloc -- calls an overloaded method
+
=item :base_math
These ops are not included in :base_core because of the risk of them being
--- ./embed.pl-pre Tue Nov 2 19:42:46 1999
+++ ./embed.pl Sun Nov 21 01:49:36 1999
@@ -1179,6 +1179,7 @@ p |void |gv_fullname |SV* sv|GV* gv
p |void |gv_fullname3 |SV* sv|GV* gv|const char* prefix
p |void |gv_init |GV* gv|HV* stash|const char* name \
|STRLEN len|int multi
+p |CV * |gv_overload_cv |HV* stash, const char *cp, int *filledp
p |HV* |gv_stashpv |const char* name|I32 create
p |HV* |gv_stashpvn |const char* name|U32 namelen|I32 create
p |HV* |gv_stashsv |SV* sv|I32 create
--- ./gv.c-pre Sat Sep 25 01:25:26 1999
+++ ./gv.c Sun Nov 21 01:49:30 1999
@@ -1000,6 +1000,50 @@ register GV *gv;
}
#endif /* Microport 2.4 hack */
+CV *
+Perl_gv_overload_cv(pTHX_ HV* stash, const char *cp, int *filledp)
+{
+ SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp));
+ CV *cv = Nullcv;
+ GV *gv, *ngv;
+ STRLEN n_a;
+
+ DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
+ cp, HvNAME(stash)) );
+ /* don't fill the cache while looking up! */
+ gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+ if(gv && (cv = GvCV(gv))) {
+ if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+ /* GvSV contains the name of the method. */
+ GV *ngv;
+
+ DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
+ SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
+ if (!SvPOK(GvSV(gv))
+ || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+ FALSE)))
+ {
+ /* Can be an import stub (created by `can'). */
+ if (GvCVGEN(gv)) {
+ Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ } else
+ Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ }
+ cv = GvCV(gv = ngv);
+ }
+ DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
+ cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
+ GvNAME(CvGV(cv))) );
+ *filledp = 1;
+ }
+ return cv;
+}
+
/* Updates and caches the CV's */
bool
@@ -1009,18 +1053,16 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
GV** gvp;
HV* hv;
GV* gv;
- CV* cv;
- MAGIC* mg=mg_find((SV*)stash,'c');
+ MAGIC* mg = mg_find((SV*)stash,'c');
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- STRLEN n_a;
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
return AMT_AMAGIC(amtp);
if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
int i;
- for (i=1; i<NofAMmeth; i++) {
+ for (i = 1; i < NofAMmeth; i++) {
if (amtp->table[i]) {
SvREFCNT_dec(amtp->table[i]);
}
@@ -1035,70 +1077,14 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
amt.fallback = AMGfallNO;
amt.flags = 0;
-#ifdef OVERLOAD_VIA_HASH
- gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
- if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
- int filled=0;
- int i;
- char *cp;
- SV* sv;
- SV** svp;
-
- /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
-
- if (( cp = (char *)PL_AMG_names[0] ) &&
- (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
- if (SvTRUE(sv)) amt.fallback=AMGfallYES;
- else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
- }
- for (i = 1; i < NofAMmeth; i++) {
- cv = 0;
- cp = (char *)PL_AMG_names[i];
-
- svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
- if (svp && ((sv = *svp) != &PL_sv_undef)) {
- switch (SvTYPE(sv)) {
- default:
- if (!SvROK(sv)) {
- if (!SvOK(sv)) break;
- gv = gv_fetchmethod(stash, SvPV(sv, n_a));
- if (gv) cv = GvCV(gv);
- break;
- }
- cv = (CV*)SvRV(sv);
- if (SvTYPE(cv) == SVt_PVCV)
- break;
- /* FALL THROUGH */
- case SVt_PVHV:
- case SVt_PVAV:
- Perl_croak(aTHX_ "Not a subroutine reference in overload table");
- return FALSE;
- case SVt_PVCV:
- cv = (CV*)sv;
- break;
- case SVt_PVGV:
- if (!(cv = GvCVu((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, FALSE);
- break;
- }
- if (cv) filled=1;
- else {
- Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
- cp,HvNAME(stash));
- return FALSE;
- }
- }
-#else
{
- int filled = 0;
+ int fill = 0;
int i;
- const char *cp;
SV* sv = NULL;
- SV** svp;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
- if ( cp = PL_AMG_names[0] ) {
+ if ( PL_AMG_names[0] ) {
/* Try to find via inheritance. */
gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
if (gv) sv = GvSV(gv);
@@ -1108,46 +1094,11 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
}
- for (i = 1; i < NofAMmeth; i++) {
- SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
- DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
- cp, HvNAME(stash)) );
- /* don't fill the cache while looking up! */
- gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
- cv = 0;
- if(gv && (cv = GvCV(gv))) {
- if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
- && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
- /* GvSV contains the name of the method. */
- GV *ngv;
-
- DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
- SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
- if (!SvPOK(GvSV(gv))
- || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
- FALSE)))
- {
- /* Can be an import stub (created by `can'). */
- if (GvCVGEN(gv)) {
- Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
- (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
- cp, HvNAME(stash));
- } else
- Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
- (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
- cp, HvNAME(stash));
- }
- cv = GvCV(gv = ngv);
- }
- DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
- cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
- GvNAME(CvGV(cv))) );
- filled = 1;
- }
-#endif
- amt.table[i]=(CV*)SvREFCNT_inc(cv);
- }
- if (filled) {
+ for (i = 1; i < NofAMmeth; i++)
+ amt.table[i]
+ = (CV*)SvREFCNT_inc(Perl_gv_overload_cv(aTHX_ stash,
+ PL_AMG_names[i], &fill));
+ if (fill) {
AMT_AMAGIC_on(&amt);
sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
return TRUE;
Thread Next
-
[PATCH 5.005_62] my Dog $spot and prepare - again
by Ilya Zakharevich