Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
9c007264 JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
93430cb4 | 5 | unshift @INC, '../lib'; |
9c007264 JH |
6 | } |
7 | print "1..37\n"; | |
a687059c | 8 | |
f63ceb1c GS |
9 | # XXX known to leak scalars |
10 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; | |
11 | ||
2f52a358 | 12 | sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } |
a687059c | 13 | |
9d116dd7 JH |
14 | my $upperfirst = 'A' lt 'a'; |
15 | ||
16 | # Beware: in future this may become hairier because of possible | |
17 | # collation complications: qw(A a B c) can be sorted at least as | |
18 | # any of the following | |
19 | # | |
20 | # A a B b | |
21 | # A B a b | |
22 | # a b A B | |
23 | # a A b B | |
24 | # | |
25 | # All the above orders make sense. | |
26 | # | |
27 | # That said, EBCDIC sorts all small letters first, as opposed | |
28 | # to ASCII which sorts all big letters first. | |
29 | ||
a687059c | 30 | @harry = ('dog','cat','x','Cain','Abel'); |
2f52a358 | 31 | @george = ('gone','chased','yz','punished','Axed'); |
a687059c LW |
32 | |
33 | $x = join('', sort @harry); | |
9d116dd7 JH |
34 | $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; |
35 | print "# 1: x = '$x', expected = '$expected'\n"; | |
36 | print ($x eq $expected ? "ok 1\n" : "not ok 1\n"); | |
a687059c | 37 | |
a0d0e21e | 38 | $x = join('', sort( backwards @harry)); |
9d116dd7 JH |
39 | $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; |
40 | print "# 2: x = '$x', expected = '$expected'\n"; | |
41 | print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); | |
a687059c LW |
42 | |
43 | $x = join('', sort @george, 'to', @harry); | |
9d116dd7 JH |
44 | $expected = $upperfirst ? |
45 | 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : | |
46 | 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; | |
47 | print "# 3: x = '$x', expected = '$expected'\n"; | |
48 | print ($x eq $expected ?"ok 3\n":"not ok 3\n"); | |
03a14243 LW |
49 | |
50 | @a = (); | |
51 | @b = reverse @a; | |
52 | print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); | |
53 | ||
54 | @a = (1); | |
55 | @b = reverse @a; | |
56 | print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); | |
57 | ||
58 | @a = (1,2); | |
59 | @b = reverse @a; | |
60 | print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); | |
61 | ||
62 | @a = (1,2,3); | |
63 | @b = reverse @a; | |
64 | print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); | |
65 | ||
66 | @a = (1,2,3,4); | |
67 | @b = reverse @a; | |
68 | print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); | |
55204971 LW |
69 | |
70 | @a = (10,2,3,4); | |
71 | @b = sort {$a <=> $b;} @a; | |
72 | print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); | |
988174c1 | 73 | |
463ee0b2 | 74 | $sub = 'backwards'; |
988174c1 | 75 | $x = join('', sort $sub @harry); |
9d116dd7 JH |
76 | $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; |
77 | print "# 10: x = $x, expected = '$expected'\n"; | |
78 | print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); | |
988174c1 | 79 | |
cd5de442 GS |
80 | # literals, combinations |
81 | ||
82 | @b = sort (4,1,3,2); | |
83 | print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); | |
84 | print "# x = '@b'\n"; | |
85 | ||
86 | @b = sort grep { $_ } (4,1,3,2); | |
87 | print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); | |
88 | print "# x = '@b'\n"; | |
89 | ||
90 | @b = sort map { $_ } (4,1,3,2); | |
91 | print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); | |
92 | print "# x = '@b'\n"; | |
93 | ||
94 | @b = sort reverse (4,1,3,2); | |
95 | print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); | |
96 | print "# x = '@b'\n"; | |
7bac28a0 | 97 | |
98 | $^W = 0; | |
99 | # redefining sort sub inside the sort sub should fail | |
100 | sub twoface { *twoface = sub { $a <=> $b }; &twoface } | |
101 | eval { @b = sort twoface 4,1,3,2 }; | |
102 | print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); | |
103 | ||
104 | # redefining sort subs outside the sort should not fail | |
105 | eval { *twoface = sub { &backwards } }; | |
106 | print $@ ? "not ok 16\n" : "ok 16\n"; | |
107 | ||
108 | eval { @b = sort twoface 4,1,3,2 }; | |
109 | print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); | |
110 | ||
111 | *twoface = sub { *twoface = *backwards; $a <=> $b }; | |
112 | eval { @b = sort twoface 4,1 }; | |
113 | print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); | |
114 | ||
115 | *twoface = sub { | |
116 | eval 'sub twoface { $a <=> $b }'; | |
117 | die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); | |
118 | $a <=> $b; | |
119 | }; | |
120 | eval { @b = sort twoface 4,1 }; | |
121 | print $@ ? "$@" : "not ok 19\n"; | |
15f0808c GS |
122 | |
123 | eval <<'CODE'; | |
124 | my @result = sort main'backwards 'one', 'two'; | |
125 | CODE | |
126 | print $@ ? "not ok 20\n# $@" : "ok 20\n"; | |
127 | ||
128 | eval <<'CODE'; | |
129 | # "sort 'one', 'two'" should not try to parse "'one" as a sort sub | |
130 | my @result = sort 'one', 'two'; | |
131 | CODE | |
132 | print $@ ? "not ok 21\n# $@" : "ok 21\n"; | |
c6e96bcb GS |
133 | |
134 | { | |
135 | my $sortsub = \&backwards; | |
136 | my $sortglob = *backwards; | |
62f274bf | 137 | my $sortglobr = \*backwards; |
c6e96bcb GS |
138 | my $sortname = 'backwards'; |
139 | @b = sort $sortsub 4,1,3,2; | |
140 | print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); | |
141 | @b = sort $sortglob 4,1,3,2; | |
142 | print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); | |
143 | @b = sort $sortname 4,1,3,2; | |
144 | print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); | |
62f274bf GS |
145 | @b = sort $sortglobr 4,1,3,2; |
146 | print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); | |
c6e96bcb GS |
147 | } |
148 | ||
149 | { | |
150 | local $sortsub = \&backwards; | |
151 | local $sortglob = *backwards; | |
62f274bf | 152 | local $sortglobr = \*backwards; |
c6e96bcb GS |
153 | local $sortname = 'backwards'; |
154 | @b = sort $sortsub 4,1,3,2; | |
62f274bf | 155 | print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); |
c6e96bcb | 156 | @b = sort $sortglob 4,1,3,2; |
62f274bf | 157 | print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); |
c6e96bcb | 158 | @b = sort $sortname 4,1,3,2; |
62f274bf GS |
159 | print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); |
160 | @b = sort $sortglobr 4,1,3,2; | |
161 | print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); | |
c6e96bcb GS |
162 | } |
163 | ||
9c007264 JH |
164 | ## exercise sort builtins... ($a <=> $b already tested) |
165 | @a = ( 5, 19, 1996, 255, 90 ); | |
166 | @b = sort { $b <=> $a } @a; | |
167 | print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); | |
168 | print "# x = '@b'\n"; | |
169 | $x = join('', sort { $a cmp $b } @harry); | |
170 | $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; | |
171 | print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); | |
172 | print "# x = '$x'; expected = '$expected'\n"; | |
173 | $x = join('', sort { $b cmp $a } @harry); | |
174 | $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; | |
175 | print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); | |
176 | print "# x = '$x'; expected = '$expected'\n"; | |
177 | { | |
178 | use integer; | |
179 | @b = sort { $a <=> $b } @a; | |
180 | print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); | |
181 | print "# x = '@b'\n"; | |
182 | @b = sort { $b <=> $a } @a; | |
183 | print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); | |
184 | print "# x = '@b'\n"; | |
185 | $x = join('', sort { $a cmp $b } @harry); | |
186 | $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; | |
187 | print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); | |
188 | print "# x = '$x'; expected = '$expected'\n"; | |
189 | $x = join('', sort { $b cmp $a } @harry); | |
190 | $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; | |
191 | print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); | |
192 | print "# x = '$x'; expected = '$expected'\n"; | |
193 | } | |
194 | # test sorting in non-main package | |
195 | package Foo; | |
196 | @a = ( 5, 19, 1996, 255, 90 ); | |
197 | @b = sort { $b <=> $a } @a; | |
198 | print ("@b" eq '1996 255 90 19 5' ? "ok 37\n" : "not ok 37\n"); | |
199 | print "# x = '@b'\n"; |