From f5284f61fe8b13877bd529c3798fd763ed884651 Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Thu, 29 Oct 1998 17:04:54 -0500 Subject: [PATCH] Overloaded <> and deref again Message-Id: <199810300304.WAA23291@monk.mps.ohio-state.edu> p4raw-id: //depot/perl@2150 --- gv.c | 9 +++ lib/overload.pm | 159 +++++++++++++++++++++++++++++++++++++++++- perl.h | 75 +++++++++++--------- pp.c | 4 ++ pp.h | 17 +++-- pp_hot.c | 41 +++++++++-- pp_sys.c | 2 + sv.c | 3 + t/pragma/overload.t | 195 +++++++++++++++++++++++++++++++++++++++++++++++++++- toke.c | 8 +-- 10 files changed, 463 insertions(+), 50 deletions(-) diff --git a/gv.c b/gv.c index 1d24fa4..f4f0044 100644 --- a/gv.c +++ b/gv.c @@ -1269,6 +1269,15 @@ amagic_call(SV *left, SV *right, int method, int flags) lr = 1; } break; + case iter_amg: /* XXXX Eventually should do to_gv. */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + break; default: goto not_found; } diff --git a/lib/overload.pm b/lib/overload.pm index 43fef8a..81d9a12 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -121,6 +121,8 @@ sub mycan { # Real can would leave stubs. mutators => '++ --', func => "atan2 cos sin exp abs log sqrt", conversion => 'bool "" 0+', + iterators => '<>', + dereferencing => '${} @{} %{} &{} *{}', special => 'nomethod fallback ='); sub constant { @@ -362,12 +364,29 @@ for "E" or "E=E" combined with either unary minus or subtraction. "bool", "\"\"", "0+", -If one or two of these operations are unavailable, the remaining ones can +If one or two of these operations are not overloaded, the remaining ones can be used instead. C is used in the flow control operators (like C) and for the ternary "C" operation. These functions can return any arbitrary Perl value. If the corresponding operation for this value is overloaded too, that operation will be called again with this value. +=item * I + + "<>" + +If not overloaded, the argument will be converted to a filehandle or +glob (which may require a stringification). The same overloading +happens both for the I syntax C$varE> and +I syntax C${var}E>. + +=item * I + + '${}', '@{}', '%{}', '&{}', '*{}'. + +If not overloaded, the argument will be dereferenced I, thus +should be of correct type. These functions should return a reference +of correct type, or another object with overloaded dereferencing. + =item * I "nomethod", "fallback", "=", @@ -392,6 +411,8 @@ A computer-readable form of the above table is available in the hash mutators => '++ --', func => 'atan2 cos sin exp abs log sqrt', conversion => 'bool "" 0+', + iterators => '<>', + dereferencing => '${} @{} %{} &{} *{}', special => 'nomethod fallback =' =head2 Inheritance and overloading @@ -589,6 +610,14 @@ C=E> or C: <, >, <=, >=, ==, != in terms of <=> lt, gt, le, ge, eq, ne in terms of cmp +=item I + + <> in terms of builtin operations + +=item I + + ${} @{} %{} &{} *{} in terms of builtin operations + =item I can be expressed in terms of an assignment to the dereferenced value, if this @@ -851,6 +880,134 @@ numeric value.) This prints: seven=vii, seven=7, eight=8 seven contains `i' +=head2 Two-face references + +Suppose you want to create an object which is accessible as both an +array reference, and a hash reference, similar to the builtin +L builtin Perl type. Let us make it better than the builtin +type, there will be no restriction that you cannot use the index 0 of +your array. + + package two_refs; + use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} }; + sub new { + my $p = shift; + bless \ [@_], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key] = shift; + } + sub FETCH { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key]; + } + +Now one can access an object using both the array and hash syntax: + + my $bar = new two_refs 3,4,5,6; + $bar->[2] = 11; + $bar->{two} == 11 or die 'bad hash fetch'; + +Note several important features of this example. First of all, the +I type of $bar is a scalar reference, and we do not overload +the scalar dereference. Thus we can get the I non-overloaded +contents of $bar by just using C<$$bar> (what we do in functions which +overload dereference). Similarly, the object returned by the +TIEHASH() method is a scalar reference. + +Second, we create a new tied hash each time the hash syntax is used. +This allows us not to worry about a possibility of a reference loop, +would would lead to a memory leak. + +Both these problems can be cured. Say, if we want to overload hash +dereference on a reference to an object which is I as a +hash itself, the only problem one has to circumvent is how to access +this I hash (as opposed to the I exhibited by +overloaded dereference operator). Here is one possible fetching routine: + + sub access_hash { + my ($self, $key) = (shift, shift); + my $class = ref $self; + bless $self, 'overload::dummy'; # Disable overloading of %{} + my $out = $self->{$key}; + bless $self, $class; # Restore overloading + $out; + } + +To move creation of the tied hash on each access, one may an extra +level of indirection which allows a non-circular structure of references: + + package two_refs1; + use overload '%{}' => sub { ${shift()}->[1] }, + '@{}' => sub { ${shift()}->[0] }; + sub new { + my $p = shift; + my $a = [@_]; + my %h; + tie %h, $p, $a; + bless \ [$a, \%h], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key] = shift; + } + sub FETCH { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key]; + } + +Now if $baz is overloaded like this, then C<$bar> is a reference to a +reference to the intermediate array, which keeps a reference to an +actual array, and the access hash. The tie()ing object for the access +hash is also a reference to a reference to the actual array, so + +=over + +=item * + +There are no loops of references. + +=item * + +Both "objects" which are blessed into the class C are +references to a reference to an array, thus references to a I. +Thus the accessor expression C<$$foo-E[$ind]> involves no +overloaded operations. + +=back + =head2 Symbolic calculator Put this in F in your Perl library directory: diff --git a/perl.h b/perl.h index ed72d40..9860c9b 100644 --- a/perl.h +++ b/perl.h @@ -2472,7 +2472,44 @@ EXT MGVTBL PL_vtbl_amagicelem; #ifdef OVERLOAD -#define NofAMmeth 58 +enum { + fallback_amg, abs_amg, + bool__amg, nomethod_amg, + string_amg, numer_amg, + add_amg, add_ass_amg, + subtr_amg, subtr_ass_amg, + mult_amg, mult_ass_amg, + div_amg, div_ass_amg, + modulo_amg, modulo_ass_amg, + pow_amg, pow_ass_amg, + lshift_amg, lshift_ass_amg, + rshift_amg, rshift_ass_amg, + band_amg, band_ass_amg, + bor_amg, bor_ass_amg, + bxor_amg, bxor_ass_amg, + lt_amg, le_amg, + gt_amg, ge_amg, + eq_amg, ne_amg, + ncmp_amg, scmp_amg, + slt_amg, sle_amg, + sgt_amg, sge_amg, + seq_amg, sne_amg, + not_amg, compl_amg, + inc_amg, dec_amg, + atan2_amg, cos_amg, + sin_amg, exp_amg, + log_amg, sqrt_amg, + repeat_amg, repeat_ass_amg, + concat_amg, concat_ass_amg, + copy_amg, neg_amg, + to_sv_amg, to_av_amg, + to_hv_amg, to_gv_amg, + to_cv_amg, iter_amg, + max_amg_code, +}; + +#define NofAMmeth max_amg_code + #ifdef DOINIT EXTCONST char * PL_AMG_names[NofAMmeth] = { "fallback", "abs", /* "fallback" should be the first. */ @@ -2503,7 +2540,10 @@ EXTCONST char * PL_AMG_names[NofAMmeth] = { "log", "sqrt", "x", "x=", ".", ".=", - "=", "neg" + "=", "neg", + "${}", "@{}", + "%{}", "*{}", + "&{}", "<>", }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -2533,37 +2573,6 @@ typedef struct am_table_short AMTS; #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) -enum { - fallback_amg, abs_amg, - bool__amg, nomethod_amg, - string_amg, numer_amg, - add_amg, add_ass_amg, - subtr_amg, subtr_ass_amg, - mult_amg, mult_ass_amg, - div_amg, div_ass_amg, - modulo_amg, modulo_ass_amg, - pow_amg, pow_ass_amg, - lshift_amg, lshift_ass_amg, - rshift_amg, rshift_ass_amg, - band_amg, band_ass_amg, - bor_amg, bor_ass_amg, - bxor_amg, bxor_ass_amg, - lt_amg, le_amg, - gt_amg, ge_amg, - eq_amg, ne_amg, - ncmp_amg, scmp_amg, - slt_amg, sle_amg, - sgt_amg, sge_amg, - seq_amg, sne_amg, - not_amg, compl_amg, - inc_amg, dec_amg, - atan2_amg, cos_amg, - sin_amg, exp_amg, - log_amg, sqrt_amg, - repeat_amg, repeat_ass_amg, - concat_amg, concat_ass_amg, - copy_amg, neg_amg -}; /* * some compilers like to redefine cos et alia as faster diff --git a/pp.c b/pp.c index babf2c5..6a308a8 100644 --- a/pp.c +++ b/pp.c @@ -211,6 +211,8 @@ PP(pp_rv2gv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_gv); + sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { GV *gv = (GV*) sv_newmortal(); @@ -256,6 +258,8 @@ PP(pp_rv2sv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_sv); + sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: diff --git a/pp.h b/pp.h index 8e2c7d3..08e10a7 100644 --- a/pp.h +++ b/pp.h @@ -195,19 +195,28 @@ #define AMG_CALLbinL(left,right,meth) \ amagic_call(left,right,CAT2(meth,_amg),AMGf_noright) -#define tryAMAGICunW(meth,set) STMT_START { \ +#define tryAMAGICunW(meth,set,shift) STMT_START { \ if (PL_amagic_generation) { \ SV* tmpsv; \ - SV* arg= *(sp); \ + SV* arg= sp[shift]; \ + am_again: \ if ((SvAMAGIC(arg))&&\ (tmpsv=AMG_CALLun(arg,meth))) {\ - SPAGAIN; \ + SPAGAIN; if (shift) sp += shift; \ set(tmpsv); RETURN; } \ } \ } STMT_END +#define FORCE_SETs(sv) STMT_START { sv_setsv(TARG, (sv)); SETTARG; } STMT_END + #define tryAMAGICun tryAMAGICunSET -#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs) +#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs,0) +#define tryAMAGICunTARGET(meth, shift) \ + { dSP; sp--; /* get TARGET from below PL_stack_sp */ \ + { dTARGETSTACKED; \ + { dSP; tryAMAGICunW(meth,FORCE_SETs,shift);}}} +#define setAGAIN(ref) sv = arg = ref; goto am_again; +#define tryAMAGICunDEREF(meth) tryAMAGICunW(meth,setAGAIN,0) #define opASSIGN (PL_op->op_flags & OPf_STACKED) #define SETsv(sv) STMT_START { \ diff --git a/pp_hot.c b/pp_hot.c index 26bf29c..8e35e8a 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -202,7 +202,23 @@ PP(pp_padsv) PP(pp_readline) { + tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); + if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */ + if (SvROK(PL_last_in_gv)) { + if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV) + goto hard_way; + PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); + } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + hard_way: { + dSP; + XPUSHs((SV*)PL_last_in_gv); + PUTBACK; + pp_rv2gv(ARGS); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + } + } + } return do_readline(); } @@ -403,16 +419,18 @@ PP(pp_print) PP(pp_rv2av) { - djSP; dPOPss; + djSP; dTOPss; AV *av; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_av); + av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) DIE("Not an ARRAY reference"); if (PL_op->op_flags & OPf_REF) { - PUSHs((SV*)av); + SETs((SV*)av); RETURN; } } @@ -420,7 +438,7 @@ PP(pp_rv2av) if (SvTYPE(sv) == SVt_PVAV) { av = (AV*)sv; if (PL_op->op_flags & OPf_REF) { - PUSHs((SV*)av); + SETs((SV*)av); RETURN; } } @@ -441,9 +459,11 @@ PP(pp_rv2av) DIE(PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) warner(WARN_UNINITIALIZED, PL_warn_uninit); - if (GIMME == G_ARRAY) + if (GIMME == G_ARRAY) { + POPs; RETURN; - RETPUSHUNDEF; + } + RETSETUNDEF; } sym = SvPV(sv,PL_na); if (PL_op->op_private & HINT_STRICT_REFS) @@ -456,7 +476,7 @@ PP(pp_rv2av) if (PL_op->op_private & OPpLVAL_INTRO) av = save_ary(gv); if (PL_op->op_flags & OPf_REF) { - PUSHs((SV*)av); + SETs((SV*)av); RETURN; } } @@ -464,6 +484,7 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; + POPs; /* XXXX May be optimized away? */ EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; @@ -480,7 +501,7 @@ PP(pp_rv2av) else { dTARGET; I32 maxarg = AvFILL(av) + 1; - PUSHi(maxarg); + SETi(maxarg); } RETURN; } @@ -492,6 +513,8 @@ PP(pp_rv2hv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_hv); + hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) DIE("Not a HASH reference"); @@ -2016,6 +2039,10 @@ PP(pp_entersub) cv = perl_get_cv(sym, TRUE); break; } + { + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; diff --git a/pp_sys.c b/pp_sys.c index 6ab33d4..7ae628b 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -350,6 +350,8 @@ PP(pp_backtick) PP(pp_glob) { OP *result; + tryAMAGICunTARGET(iter, -1); + ENTER; #ifndef VMS diff --git a/sv.c b/sv.c index 90a4e0d..807e63c 100644 --- a/sv.c +++ b/sv.c @@ -4047,6 +4047,9 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + cv = (CV*)SvRV(sv); if (SvTYPE(cv) != SVt_PVCV) croak("Not a subroutine reference"); diff --git a/t/pragma/overload.t b/t/pragma/overload.t index 0682266..da85771 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -706,5 +706,198 @@ test($c, "bareword"); # 135 my @sorted2 = map $$_, @sorted1; test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; } +{ + package iterator; + use overload '<>' => \&iter; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } +} +{ + my $iter = iterator->new(5); + my $acc = ''; + my $out; + $acc .= " $out" while $out = <${iter}>; + test $acc, ' 5 4 3 2 1 0'; # 175 + $iter = iterator->new(5); + test scalar <${iter}>, '5'; # 176 + $acc = ''; + $acc .= " $out" while $out = <$iter>; + test $acc, ' 4 3 2 1 0'; # 177 +} +{ + package deref; + use overload '%{}' => \&hderef, '&{}' => \&cderef, + '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub deref { + my ($self, $key) = (shift, shift); + my $class = ref $self; + bless $self, 'deref::dummy'; # Disable overloading of %{} + my $out = $self->{$key}; + bless $self, $class; # Restore overloading + $out; + } + sub hderef {shift->deref('h')} + sub aderef {shift->deref('a')} + sub cderef {shift->deref('c')} + sub gderef {shift->deref('g')} + sub sderef {shift->deref('s')} +} +{ + my $deref = bless { h => { foo => 5 , fake => 23 }, + c => sub {return shift() + 34}, + 's' => \123, + a => [11..13], + g => \*srt, + }, 'deref'; + # Hash: + my @cont = sort %$deref; + test "@cont", '23 5 fake foo'; # 178 + my @keys = sort keys %$deref; + test "@keys", 'fake foo'; # 179 + my @val = sort values %$deref; + test "@val", '23 5'; # 180 + test $deref->{foo}, 5; # 181 + test defined $deref->{bar}, ''; # 182 + my $key; + @keys = (); + push @keys, $key while $key = each %$deref; + @keys = sort @keys; + test "@keys", 'fake foo'; # 183 + test exists $deref->{bar}, ''; # 184 + test exists $deref->{foo}, 1; # 185 + # Code: + test $deref->(5), 39; # 186 + test &$deref(6), 40; # 187 + sub xxx_goto { goto &$deref } + test xxx_goto(7), 41; # 188 + my $srt = bless { c => sub {$b <=> $a} + }, 'deref'; + *srt = \&$srt; + my @sorted = sort srt 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 189 + # Scalar + test $$deref, 123; # 190 + # Glob + @sorted = sort $deref 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 191 + # Array + test "@$deref", '11 12 13'; # 192 + test $#$deref, '2'; # 193 + my $l = @$deref; + test $l, 3; # 194 + test $deref->[2], '13'; # 195 + $l = pop @$deref; + test $l, 13; # 196 + $l = 1; + test $deref->[$l], '12'; # 197 + # Repeated dereference + my $double = bless { h => $deref, + }, 'deref'; + test $double->{foo}, 5; # 198 +} + +{ + package two_refs; + use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; + sub new { + my $p = shift; + bless \ [@_], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key] = shift; + } + sub FETCH { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key]; + } +} + +my $bar = new two_refs 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 199 +$bar->{three} = 13; +test $bar->[3], 13; # 200 + +{ + package two_refs_o; + @ISA = ('two_refs'); +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 201 +$bar->{three} = 13; +test $bar->[3], 13; # 202 + +{ + package two_refs1; + use overload '%{}' => sub { ${shift()}->[1] }, + '@{}' => sub { ${shift()}->[0] }; + sub new { + my $p = shift; + my $a = [@_]; + my %h; + tie %h, $p, $a; + bless \ [$a, \%h], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key] = shift; + } + sub FETCH { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key]; + } +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 203 +$bar->{three} = 13; +test $bar->[3], 13; # 204 + +{ + package two_refs1_o; + @ISA = ('two_refs1'); +} + +$bar = new two_refs1_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 205 +$bar->{three} = 13; +test $bar->[3], 13; # 206 + # Last test is: -sub last {174} +sub last {206} diff --git a/toke.c b/toke.c index 9a2fbd6..6755b8a 100644 --- a/toke.c +++ b/toke.c @@ -5643,16 +5643,16 @@ scan_inputsymbol(char *start) if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { OP *o = newOP(OP_PADSV, 0); o->op_targ = tmp; - PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o)); + PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o); } else { GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, - newUNOP(OP_RV2GV, 0, newUNOP(OP_RV2SV, 0, - newGVOP(OP_GV, 0, gv)))); + newGVOP(OP_GV, 0, gv))); } - /* we created the ops in lex_op, so make yylval.ival a null op */ + PL_lex_op->op_flags |= OPf_SPECIAL; + /* we created the ops in PL_lex_op, so make yylval.ival a null op */ yylval.ival = OP_NULL; } -- 2.7.4