contrib/perl5/t/op/sort.t

   1 #!./perl
   2
   3 print "1..29\n";
   4
   5 # XXX known to leak scalars
   6 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
   7
   8 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
   9
  10 my $upperfirst = 'A' lt 'a';
  11
  12 # Beware: in future this may become hairier because of possible
  13 # collation complications: qw(A a B c) can be sorted at least as
  14 # any of the following
  15 #
  16 #       A a B b
  17 #       A B a b
  18 #       a b A B
  19 #       a A b B
  20 #
  21 # All the above orders make sense.
  22 #
  23 # That said, EBCDIC sorts all small letters first, as opposed
  24 # to ASCII which sorts all big letters first.
  25
  26 @harry = ('dog','cat','x','Cain','Abel');
  27 @george = ('gone','chased','yz','punished','Axed');
  28
  29 $x = join('', sort @harry);
  30 $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
  31 print "# 1: x = '$x', expected = '$expected'\n";
  32 print ($x eq $expected ? "ok 1\n" : "not ok 1\n");
  33
  34 $x = join('', sort( backwards @harry));
  35 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
  36 print "# 2: x = '$x', expected = '$expected'\n";
  37 print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
  38
  39 $x = join('', sort @george, 'to', @harry);
  40 $expected = $upperfirst ?
  41     'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
  42     'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
  43 print "# 3: x = '$x', expected = '$expected'\n";
  44 print ($x eq $expected ?"ok 3\n":"not ok 3\n");
  45
  46 @a = ();
  47 @b = reverse @a;
  48 print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
  49
  50 @a = (1);
  51 @b = reverse @a;
  52 print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
  53
  54 @a = (1,2);
  55 @b = reverse @a;
  56 print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
  57
  58 @a = (1,2,3);
  59 @b = reverse @a;
  60 print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
  61
  62 @a = (1,2,3,4);
  63 @b = reverse @a;
  64 print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
  65
  66 @a = (10,2,3,4);
  67 @b = sort {$a <=> $b;} @a;
  68 print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
  69
  70 $sub = 'backwards';
  71 $x = join('', sort $sub @harry);
  72 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
  73 print "# 10: x = $x, expected = '$expected'\n";
  74 print ($x eq $expected ? "ok 10\n" : "not ok 10\n");
  75
  76 # literals, combinations
  77
  78 @b = sort (4,1,3,2);
  79 print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n");
  80 print "# x = '@b'\n";
  81
  82 @b = sort grep { $_ } (4,1,3,2);
  83 print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n");
  84 print "# x = '@b'\n";
  85
  86 @b = sort map { $_ } (4,1,3,2);
  87 print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
  88 print "# x = '@b'\n";
  89
  90 @b = sort reverse (4,1,3,2);
  91 print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
  92 print "# x = '@b'\n";
  93
  94 $^W = 0;
  95 # redefining sort sub inside the sort sub should fail
  96 sub twoface { *twoface = sub { $a <=> $b }; &twoface }
  97 eval { @b = sort twoface 4,1,3,2 };
  98 print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n");
  99
 100 # redefining sort subs outside the sort should not fail
 101 eval { *twoface = sub { &backwards } };
 102 print $@ ? "not ok 16\n" : "ok 16\n";
 103
 104 eval { @b = sort twoface 4,1,3,2 };
 105 print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n");
 106
 107 *twoface = sub { *twoface = *backwards; $a <=> $b };
 108 eval { @b = sort twoface 4,1 };
 109 print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n");
 110
 111 *twoface = sub {
 112                  eval 'sub twoface { $a <=> $b }';
 113                  die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n");
 114                  $a <=> $b;
 115                };
 116 eval { @b = sort twoface 4,1 };
 117 print $@ ? "$@" : "not ok 19\n";
 118
 119 eval <<'CODE';
 120     my @result = sort main'backwards 'one', 'two';
 121 CODE
 122 print $@ ? "not ok 20\n# $@" : "ok 20\n";
 123
 124 eval <<'CODE';
 125     # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
 126     my @result = sort 'one', 'two';
 127 CODE
 128 print $@ ? "not ok 21\n# $@" : "ok 21\n";
 129
 130 {
 131   my $sortsub = \&backwards;
 132   my $sortglob = *backwards;
 133   my $sortglobr = \*backwards;
 134   my $sortname = 'backwards';
 135   @b = sort $sortsub 4,1,3,2;
 136   print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");
 137   @b = sort $sortglob 4,1,3,2;
 138   print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");
 139   @b = sort $sortname 4,1,3,2;
 140   print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
 141   @b = sort $sortglobr 4,1,3,2;
 142   print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
 143 }
 144
 145 {
 146   local $sortsub = \&backwards;
 147   local $sortglob = *backwards;
 148   local $sortglobr = \*backwards;
 149   local $sortname = 'backwards';
 150   @b = sort $sortsub 4,1,3,2;
 151   print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
 152   @b = sort $sortglob 4,1,3,2;
 153   print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
 154   @b = sort $sortname 4,1,3,2;
 155   print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
 156   @b = sort $sortglobr 4,1,3,2;
 157   print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
 158 }
 159