This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add test for change#4417
[perl5.git] / t / op / sort.t
index aca99a6..9abc410 100755 (executable)
@@ -1,6 +1,13 @@
 #!./perl
 
-print "1..27\n";
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+print "1..38\n";
+
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
@@ -127,6 +134,7 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
 {
   my $sortsub = \&backwards;
   my $sortglob = *backwards;
+  my $sortglobr = \*backwards;
   my $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");
@@ -134,17 +142,67 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
   print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");
   @b = sort $sortname 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
 }
 
 {
   local $sortsub = \&backwards;
   local $sortglob = *backwards;
+  local $sortglobr = \*backwards;
   local $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 22 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 23 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
   @b = sort $sortname 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 24 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+}
+
+## exercise sort builtins... ($a <=> $b already tested)
+@a = ( 5, 19, 1996, 255, 90 );
+@b = sort {
+    my $dummy;         # force blockness
+    return $b <=> $a
+} @a;
+print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n");
+print "# x = '@b'\n";
+$x = join('', sort { $a cmp $b } @harry);
+$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
+print ($x eq $expected ? "ok 31\n" : "not ok 31\n");
+print "# x = '$x'; expected = '$expected'\n";
+$x = join('', sort { $b cmp $a } @harry);
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print ($x eq $expected ? "ok 32\n" : "not ok 32\n");
+print "# x = '$x'; expected = '$expected'\n";
+{
+    use integer;
+    @b = sort { $a <=> $b } @a;
+    print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n");
+    print "# x = '@b'\n";
+    @b = sort { $b <=> $a } @a;
+    print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n");
+    print "# x = '@b'\n";
+    $x = join('', sort { $a cmp $b } @harry);
+    $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
+    print ($x eq $expected ? "ok 35\n" : "not ok 35\n");
+    print "# x = '$x'; expected = '$expected'\n";
+    $x = join('', sort { $b cmp $a } @harry);
+    $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+    print ($x eq $expected ? "ok 36\n" : "not ok 36\n");
+    print "# x = '$x'; expected = '$expected'\n";
 }
 
+# test that an optimized-away comparison block doesn't take any other
+# arguments away with it
+$x = join('', sort { $a <=> $b } 3, 1, 2);
+print $x eq "123" ? "ok 37\n" : "not ok 37\n";
+
+# test sorting in non-main package
+package Foo;
+@a = ( 5, 19, 1996, 255, 90 );
+@b = sort { $b <=> $a } @a;
+print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n");
+print "# x = '@b'\n";