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;
}
mutators => '++ --',
func => "atan2 cos sin exp abs log sqrt",
conversion => 'bool "" 0+',
+ iterators => '<>',
+ dereferencing => '${} @{} %{} &{} *{}',
special => 'nomethod fallback =');
sub constant {
"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<bool> is used in the flow control operators
(like C<while>) 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<Iteration>
+
+ "<>"
+
+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<read-filehandle> syntax C<E<lt>$varE<gt>> and
+I<globbing> syntax C<E<lt>${var}E<gt>>.
+
+=item * I<Dereferencing>
+
+ '${}', '@{}', '%{}', '&{}', '*{}'.
+
+If not overloaded, the argument will be dereferenced I<as is>, thus
+should be of correct type. These functions should return a reference
+of correct type, or another object with overloaded dereferencing.
+
=item * I<Special>
"nomethod", "fallback", "=",
mutators => '++ --',
func => 'atan2 cos sin exp abs log sqrt',
conversion => 'bool "" 0+',
+ iterators => '<>',
+ dereferencing => '${} @{} %{} &{} *{}',
special => 'nomethod fallback ='
=head2 Inheritance and overloading
<, >, <=, >=, ==, != in terms of <=>
lt, gt, le, ge, eq, ne in terms of cmp
+=item I<Iterator>
+
+ <> in terms of builtin operations
+
+=item I<Dereferencing>
+
+ ${} @{} %{} &{} *{} in terms of builtin operations
+
=item I<Copy operator>
can be expressed in terms of an assignment to the dereferenced value, if this
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<array-accessible-as-a-hash|perlref/"Pseudo-hashes: Using an array as
+a hash"> 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<actual> type of $bar is a scalar reference, and we do not overload
+the scalar dereference. Thus we can get the I<actual> 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<implemented> as a
+hash itself, the only problem one has to circumvent is how to access
+this I<actual> hash (as opposed to the I<virtual> 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<two_refs1> are
+references to a reference to an array, thus references to a I<scalar>.
+Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no
+overloaded operations.
+
+=back
+
=head2 Symbolic calculator
Put this in F<symbolic.pm> in your Perl library directory:
#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. */
"log", "sqrt",
"x", "x=",
".", ".=",
- "=", "neg"
+ "=", "neg",
+ "${}", "@{}",
+ "%{}", "*{}",
+ "&{}", "<>",
};
#else
EXTCONST char * PL_AMG_names[NofAMmeth];
#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
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_gv);
+
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV *gv = (GV*) sv_newmortal();
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_sv);
+
sv = SvRV(sv);
switch (SvTYPE(sv)) {
case SVt_PVAV:
#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 { \
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();
}
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;
}
}
if (SvTYPE(sv) == SVt_PVAV) {
av = (AV*)sv;
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
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)
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;
}
}
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL(av) + 1;
+ POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
U32 i;
else {
dTARGET;
I32 maxarg = AvFILL(av) + 1;
- PUSHi(maxarg);
+ SETi(maxarg);
}
RETURN;
}
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");
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;
PP(pp_glob)
{
OP *result;
+ tryAMAGICunTARGET(iter, -1);
+
ENTER;
#ifndef VMS
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");
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}
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;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff