Overloaded <> and deref again

	Message-Id: <199810300304.WAA23291@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@2150

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;
 	 }

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<lt>" or "E<lt>=E<gt>" 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<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", "=",
@@ -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<lt>=E<gt>> or C<cmp>:
     <, >, <=, >=, ==, != 	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
@@ -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<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:

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

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:

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 {					\