From: Ilya Zakharevich <ilya@math.berkeley.edu>
Date: Wed, 28 Oct 1998 01:20:33 +0000 (-0500)
Subject: Make sort respect overloading
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d0ecd44c5964f10ab34d28eea63e112aa8c61503;p=p5sagit%2Fp5-mst-13.2.git

Make sort respect overloading

	Message-Id: <199810280620.BAA06893@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@2117
---

diff --git a/pp_ctl.c b/pp_ctl.c
index f90eff9..5a8cf00 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -41,6 +41,8 @@ static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
 static OP *doeval _((int gimme, OP** startop));
+static I32 amagic_cmp _((SV *str1, SV *str2));
+static I32 amagic_cmp_locale _((SV *str1, SV *str2));
 #endif
 
 PP(pp_wantarray)
@@ -747,6 +749,61 @@ PP(pp_mapwhile)
     }
 }
 
+#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
+	  *svp = Nullsv;				\
+          if (PL_amagic_generation) { \
+	    if (SvAMAGIC(left)||SvAMAGIC(right))\
+		*svp = amagic_call(left, \
+				   right, \
+				   CAT2(meth,_amg), \
+				   0); \
+	  } \
+	} STMT_END
+
+STATIC I32
+amagic_cmp(register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
+    if (tmpsv) {
+    	double d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_cmp(str1, str2);
+}
+
+STATIC I32
+amagic_cmp_locale(register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
+    if (tmpsv) {
+    	double d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_cmp_locale(str1, str2);
+}
+
 PP(pp_sort)
 {
     djSP; dMARK; dORIGMARK;
@@ -758,6 +815,7 @@ PP(pp_sort)
     CV *cv;
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
+    I32 overloading = 0;
 
     if (gimme != G_ARRAY) {
 	SP = MARK;
@@ -810,8 +868,12 @@ PP(pp_sort)
 	/*SUPPRESS 560*/
 	if (*up = *++MARK) {			/* Weed out nulls. */
 	    SvTEMP_off(*up);
-	    if (!PL_sortcop && !SvPOK(*up))
-		(void)sv_2pv(*up, &PL_na);
+	    if (!PL_sortcop && !SvPOK(*up)) {
+	        if (SvAMAGIC(*up))
+	            overloading = 1;
+	        else
+		    (void)sv_2pv(*up, &PL_na);
+	    }
 	    up++;
 	}
     }
@@ -858,8 +920,12 @@ PP(pp_sort)
 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
 	    qsortsv(ORIGMARK+1, max,
 		    (PL_op->op_private & OPpLOCALE)
-		    ? FUNC_NAME_TO_PTR(sv_cmp_locale)
-		    : FUNC_NAME_TO_PTR(sv_cmp));
+		    ? ( overloading
+		        ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
+		        : FUNC_NAME_TO_PTR(sv_cmp_locale))
+		    : ( overloading 
+		        ? FUNC_NAME_TO_PTR(amagic_cmp)
+		        : FUNC_NAME_TO_PTR(sv_cmp) ));
 	}
     }
     LEAVE;
diff --git a/proto.h b/proto.h
index 246112e..0aec76d 100644
--- a/proto.h
+++ b/proto.h
@@ -760,6 +760,9 @@ I32 dopoptosub _((I32 startingblock));
 I32 dopoptosub_at _((PERL_CONTEXT* cxstk, I32 startingblock));
 void save_lines _((AV *array, SV *sv));
 OP *doeval _((int gimme, OP** startop));
+I32 amagic_cmp _((SV *str1, SV *str2));
+I32 amagic_cmp_locale _((SV *str1, SV *str2));
+
 SV *mul128 _((SV *sv, U8 m));
 SV *is_an_int _((char *s, STRLEN l));
 int div128 _((SV *pnum, bool *done));
diff --git a/t/pragma/overload.t b/t/pragma/overload.t
index afba8a3..0682266 100755
--- a/t/pragma/overload.t
+++ b/t/pragma/overload.t
@@ -694,5 +694,17 @@ test($c, "bareword");	# 135
   test( scalar ($seven =~ /i/), '1')
 }
 
+{
+  package sorting;
+  use overload 'cmp' => \&comp;
+  sub new { my ($p, $v) = @_; bless \$v, $p }
+  sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
+}
+{
+  my @arr = map sorting->new($_), 0..12;
+  my @sorted1 = sort @arr;
+  my @sorted2 = map $$_, @sorted1;
+  test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3';
+}
 # Last test is:
-sub last {173}
+sub last {174}