This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/op/index.t: include all tests within run_tests()
[perl5.git] / t / op / index.t
CommitLineData
a687059c
LW
1#!./perl
2
c39c4c41
JH
3BEGIN {
4 chdir 't' if -d 't';
b21ea4ec 5 require './test.pl';
43ece5b1 6 set_up_inc('../lib');
b21ea4ec 7 require './charset_tools.pl';
c39c4c41 8}
a687059c 9
e609e586 10use strict;
25f3319b 11plan( tests => 412 );
a687059c 12
e3faa678
NC
13run_tests() unless caller;
14
15sub run_tests {
16
e609e586 17my $foo = 'Now is the time for all good men to come to the aid of their country.';
a687059c 18
e609e586 19my $first = substr($foo,0,index($foo,'the'));
c39c4c41 20is($first, "Now is ");
a687059c 21
e609e586 22my $last = substr($foo,rindex($foo,'the'),100);
c39c4c41 23is($last, "their country.");
a687059c
LW
24
25$last = substr($foo,index($foo,'Now'),2);
c39c4c41 26is($last, "No");
a687059c
LW
27
28$last = substr($foo,rindex($foo,'Now'),2);
c39c4c41 29is($last, "No");
a687059c
LW
30
31$last = substr($foo,index($foo,'.'),100);
c39c4c41 32is($last, ".");
a687059c
LW
33
34$last = substr($foo,rindex($foo,'.'),100);
c39c4c41 35is($last, ".");
d9d8d8de 36
c39c4c41
JH
37is(index("ababa","a",-1), 0);
38is(index("ababa","a",0), 0);
39is(index("ababa","a",1), 2);
40is(index("ababa","a",2), 2);
41is(index("ababa","a",3), 4);
42is(index("ababa","a",4), 4);
43is(index("ababa","a",5), -1);
d9d8d8de 44
c39c4c41
JH
45is(rindex("ababa","a",-1), -1);
46is(rindex("ababa","a",0), 0);
47is(rindex("ababa","a",1), 0);
48is(rindex("ababa","a",2), 2);
49is(rindex("ababa","a",3), 2);
50is(rindex("ababa","a",4), 4);
51is(rindex("ababa","a",5), 4);
4f593451 52
46f1e595
RGS
53# tests for empty search string
54is(index("abc", "", -1), 0);
55is(index("abc", "", 0), 0);
56is(index("abc", "", 1), 1);
57is(index("abc", "", 2), 2);
58is(index("abc", "", 3), 3);
59is(index("abc", "", 4), 3);
60is(rindex("abc", "", -1), 0);
61is(rindex("abc", "", 0), 0);
62is(rindex("abc", "", 1), 1);
63is(rindex("abc", "", 2), 2);
64is(rindex("abc", "", 3), 3);
65is(rindex("abc", "", 4), 3);
66
4f593451
JH
67$a = "foo \x{1234}bar";
68
c39c4c41
JH
69is(index($a, "\x{1234}"), 4);
70is(index($a, "bar", ), 5);
4f593451 71
c39c4c41
JH
72is(rindex($a, "\x{1234}"), 4);
73is(rindex($a, "foo", ), 0);
d69d2d9f
JH
74
75{
d69d2d9f
JH
76 my $needle = "\x{1230}\x{1270}";
77 my @needles = split ( //, $needle );
78 my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}";
79 foreach ( @needles ) {
80 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
81 my $b = index ( $haystack, $_ );
c39c4c41 82 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
d69d2d9f
JH
83 }
84 $needle = "\x{1270}\x{1230}"; # Transpose them.
85 @needles = split ( //, $needle );
86 foreach ( @needles ) {
87 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
88 my $b = index ( $haystack, $_ );
c39c4c41 89 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
d69d2d9f
JH
90 }
91}
e609e586
NC
92
93{
250d67eb
JH
94 my $search;
95 my $text;
d1cef54a
KW
96 $search = "foo " . uni_to_native("\xc9") . " bar";
97 $text = "a" . uni_to_native("\xa3\xa3") . "a $search $search quux";
e609e586
NC
98
99 my $text_utf8 = $text;
100 utf8::upgrade($text_utf8);
101 my $search_utf8 = $search;
102 utf8::upgrade($search_utf8);
103
104 is (index($text, $search), 5);
105 is (rindex($text, $search), 18);
106 is (index($text, $search_utf8), 5);
107 is (rindex($text, $search_utf8), 18);
108 is (index($text_utf8, $search), 5);
109 is (rindex($text_utf8, $search), 18);
110 is (index($text_utf8, $search_utf8), 5);
111 is (rindex($text_utf8, $search_utf8), 18);
112
113 my $text_octets = $text_utf8;
114 utf8::encode ($text_octets);
115 my $search_octets = $search_utf8;
116 utf8::encode ($search_octets);
117
118 is (index($text_octets, $search_octets), 7, "index octets, octets")
119 or _diag ($text_octets, $search_octets);
120 is (rindex($text_octets, $search_octets), 21, "rindex octets, octets");
121 is (index($text_octets, $search_utf8), -1);
122 is (rindex($text_octets, $search_utf8), -1);
123 is (index($text_utf8, $search_octets), -1);
124 is (rindex($text_utf8, $search_octets), -1);
125
126 is (index($text_octets, $search), -1);
127 is (rindex($text_octets, $search), -1);
128 is (index($text, $search_octets), -1);
129 is (rindex($text, $search_octets), -1);
130}
a2b7337b 131
713375f8
KW
132SKIP: {
133 skip("Not a 64-bit machine", 3) if length sprintf("%x", ~0) <= 8;
76513bdc 134 my $a = eval q{"\x{80000000}"};
6448472a 135 my $s = $a.'defxyz';
76513bdc 136 is(index($s, 'def'), 1, "0x80000000 is a single character");
6448472a 137
76513bdc 138 my $b = eval q{"\x{fffffffd}"};
6448472a 139 my $t = $b.'pqrxyz';
76513bdc 140 is(index($t, 'pqr'), 1, "0xfffffffd is a single character");
6448472a
ST
141
142 local ${^UTF8CACHE} = -1;
76513bdc 143 is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
6448472a 144}
e3faa678 145
10489e41
A
146
147# Tests for NUL characters.
148{
149 my @tests = (
150 ["", -1, -1, -1],
151 ["foo", -1, -1, -1],
152 ["\0", 0, -1, -1],
153 ["\0\0", 0, 0, -1],
154 ["\0\0\0", 0, 0, 0],
155 ["foo\0", 3, -1, -1],
156 ["foo\0foo\0\0", 3, 7, -1],
157 );
158 foreach my $l (1 .. 3) {
159 my $q = "\0" x $l;
160 my $i = 0;
161 foreach my $test (@tests) {
162 $i ++;
163 my $str = $$test [0];
164 my $res = $$test [$l];
165
166 {
10489e41
A
167 is (index ($str, $q), $res, "Find NUL character(s)");
168 }
169
170 #
171 # Bug #53746 shows a difference between variables and literals,
172 # so test literals as well.
173 #
174 my $test_str = qq {is (index ("$str", "$q"), $res, } .
175 qq {"Find NUL character(s)")};
176 $test_str =~ s/\0/\\0/g;
177
178 eval $test_str;
179 die $@ if $@;
180 }
181 }
182}
183
3e2d3818
NC
184{
185 # RT#75898
186 is(eval { utf8::upgrade($_ = " "); index $_, " ", 72 }, -1,
187 'UTF-8 cache handles offset beyond the end of the string');
188 $_ = "\x{100}BC";
189 is(index($_, "C", 4), -1,
190 'UTF-8 cache handles offset beyond the end of the string');
191}
192
74e0ddf7
NC
193# RT #89218
194use constant {PVBM => 'galumphing', PVBM2 => 'bang'};
195
196sub index_it {
197 is(index('galumphing', PVBM), 0,
198 "index isn't confused by format compilation");
199}
200
201index_it();
202is($^A, '', '$^A is empty');
203formline PVBM;
204is($^A, 'galumphing', "formline isn't confused by index compilation");
205index_it();
206
207$^A = '';
208# must not do index here before formline.
209is($^A, '', '$^A is empty');
210formline PVBM2;
211is($^A, 'bang', "formline isn't confused by index compilation");
212is(index('bang', PVBM2), 0, "index isn't confused by format compilation");
213
9402563a
NC
214{
215 use constant perl => "rules";
216 is(index("perl rules", perl), 5, 'first index of a constant works');
217 is(index("rules 1 & 2", perl), 0, 'second index of the same constant works');
218}
219
948d2370
FC
220# PVBM compilation should not flatten ref constants
221use constant riffraff => \our $referent;
222index "foo", riffraff;
223is ref riffraff, 'SCALAR', 'index does not flatten ref constants';
224
225package o { use overload '""' => sub { "foo" } }
226bless \our $referent, o::;
227is index("foo", riffraff), 0,
228 'index respects changes in ref stringification';
229
310f4fdb
FC
230use constant quire => ${qr/(?{})/}; # A REGEXP, not a reference to one
231index "foo", quire;
232eval ' "" =~ quire ';
233is $@, "", 'regexp constants containing code blocks are not flattened';
234
235use constant bang => $! = 8;
236index "foo", bang;
237cmp_ok bang, '==', 8, 'dualvar constants are not flattened';
238
239use constant u => undef;
240{
241 my $w;
242 local $SIG{__WARN__} = sub { $w .= shift };
243 eval '
244 use warnings;
245 sub { () = index "foo", u; }
246 ';
247 is $w, undef, 'no warnings from compiling index($foo, undef_constant)';
248}
249is u, undef, 'undef constant is still undef';
250
11609d9c
FC
251is index('the main road', __PACKAGE__), 4,
252 '[perl #119169] __PACKAGE__ as 2nd argument';
253
15c41403
JR
254utf8::upgrade my $substr = "\x{a3}a";
255
256is index($substr, 'a'), 1, 'index reply reflects characters not octets';
7e8d786b
DM
257
258# op_eq, op_const optimised away in (index() == -1) and variants
259
c87834ab 260for my $test (
25f3319b
DM
261 # expect:
262 # F: always false regardless of the expression
263 # T: always true regardless of the expression
264 # f: expect false if the string is found
265 # t: expect true if the string is found
266 #
267 # op const expect
268 [ '<', -1, 'F' ],
269 [ '<', 0, 'f' ],
270
271 [ '<=', -1, 'f' ],
272 [ '<=', 0, 'f' ],
273
274 [ '==', -1, 'f' ],
275 [ '==', 0, 'F' ],
276
277 [ '!=', -1, 't' ],
278 [ '!=', 0, 'T' ],
279
280 [ '>=', -1, 'T' ],
281 [ '>=', 0, 't' ],
282
283 [ '>', -1, 't' ],
284 [ '>', 0, 't' ],
c87834ab 285) {
25f3319b 286 my ($op, $const, $expect0) = @$test;
c87834ab
DM
287
288 my $s = "abcde";
7e8d786b
DM
289 my $r;
290
25f3319b
DM
291 for my $substr ("e", "z") {
292 my $expect =
293 $expect0 eq 'T' ? 1 == 1 :
294 $expect0 eq 'F' ? 0 == 1 :
295 $expect0 eq 't' ? ($substr eq "e") :
296 ($substr ne "e");
297
c87834ab
DM
298 for my $rindex ("", "r") {
299 for my $reverse (0, 1) {
400ffcff
DM
300 my $rop = $op;
301 if ($reverse) {
302 $rop =~ s/>/</ or $rop =~ s/</>/;
303 }
c87834ab
DM
304 for my $targmy (0, 1) {
305 my $index = "${rindex}index(\$s, '$substr')";
400ffcff 306 my $expr = $reverse ? "$const $rop $index" : "$index $rop $const";
c87834ab
DM
307 # OPpTARGET_MY variant: the '$r = ' is optimised away too
308 $expr = "\$r = ($expr)" if $targmy;
309
310 my $got = eval $expr;
311 die "eval of <$expr> gave: $@\n" if $@ ne "";
312
313 is !!$got, $expect, $expr;
314 if ($targmy) {
315 is !!$r, $expect, "$expr - r value";
316 }
317 }
318 }
319 }
320 }
321}
df84d7b0 322
c87834ab 323{
df84d7b0
DM
324 # RT #131823
325 # index with OPpTARGET_MY shouldn't do the '== -1' optimisation
c87834ab
DM
326 my $s = "abxyz";
327 my $r;
df84d7b0
DM
328
329 ok(!(($r = index($s,"z")) == -1), "(r = index(a)) == -1");
330 is($r, 4, "(r = index(a)) == -1 - r value");
331
332
7e8d786b 333}
23e9944f
DM
334
335} # end of sub run_tests