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 (file)
--- 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 (file)
--- 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 (executable)
--- 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' => \∁
+  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}