This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #119169] index with __PACKAGE__ for 2nd argument
[perl5.git] / t / op / index.t
CommitLineData
a687059c
LW
1#!./perl
2
c39c4c41
JH
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6448472a 6 require './test.pl';
c39c4c41 7}
a687059c 8
e609e586 9use strict;
11609d9c 10plan( tests => 121 );
a687059c 11
e3faa678
NC
12run_tests() unless caller;
13
14sub run_tests {
15
e609e586 16my $foo = 'Now is the time for all good men to come to the aid of their country.';
a687059c 17
e609e586 18my $first = substr($foo,0,index($foo,'the'));
c39c4c41 19is($first, "Now is ");
a687059c 20
e609e586 21my $last = substr($foo,rindex($foo,'the'),100);
c39c4c41 22is($last, "their country.");
a687059c
LW
23
24$last = substr($foo,index($foo,'Now'),2);
c39c4c41 25is($last, "No");
a687059c
LW
26
27$last = substr($foo,rindex($foo,'Now'),2);
c39c4c41 28is($last, "No");
a687059c
LW
29
30$last = substr($foo,index($foo,'.'),100);
c39c4c41 31is($last, ".");
a687059c
LW
32
33$last = substr($foo,rindex($foo,'.'),100);
c39c4c41 34is($last, ".");
d9d8d8de 35
c39c4c41
JH
36is(index("ababa","a",-1), 0);
37is(index("ababa","a",0), 0);
38is(index("ababa","a",1), 2);
39is(index("ababa","a",2), 2);
40is(index("ababa","a",3), 4);
41is(index("ababa","a",4), 4);
42is(index("ababa","a",5), -1);
d9d8d8de 43
c39c4c41
JH
44is(rindex("ababa","a",-1), -1);
45is(rindex("ababa","a",0), 0);
46is(rindex("ababa","a",1), 0);
47is(rindex("ababa","a",2), 2);
48is(rindex("ababa","a",3), 2);
49is(rindex("ababa","a",4), 4);
50is(rindex("ababa","a",5), 4);
4f593451 51
46f1e595
RGS
52# tests for empty search string
53is(index("abc", "", -1), 0);
54is(index("abc", "", 0), 0);
55is(index("abc", "", 1), 1);
56is(index("abc", "", 2), 2);
57is(index("abc", "", 3), 3);
58is(index("abc", "", 4), 3);
59is(rindex("abc", "", -1), 0);
60is(rindex("abc", "", 0), 0);
61is(rindex("abc", "", 1), 1);
62is(rindex("abc", "", 2), 2);
63is(rindex("abc", "", 3), 3);
64is(rindex("abc", "", 4), 3);
65
4f593451
JH
66$a = "foo \x{1234}bar";
67
c39c4c41
JH
68is(index($a, "\x{1234}"), 4);
69is(index($a, "bar", ), 5);
4f593451 70
c39c4c41
JH
71is(rindex($a, "\x{1234}"), 4);
72is(rindex($a, "foo", ), 0);
d69d2d9f
JH
73
74{
d69d2d9f
JH
75 my $needle = "\x{1230}\x{1270}";
76 my @needles = split ( //, $needle );
77 my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}";
78 foreach ( @needles ) {
79 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
80 my $b = index ( $haystack, $_ );
c39c4c41 81 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
d69d2d9f
JH
82 }
83 $needle = "\x{1270}\x{1230}"; # Transpose them.
84 @needles = split ( //, $needle );
85 foreach ( @needles ) {
86 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
87 my $b = index ( $haystack, $_ );
c39c4c41 88 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
d69d2d9f
JH
89 }
90}
e609e586
NC
91
92{
250d67eb
JH
93 my $search;
94 my $text;
8a38a836
KW
95 $search = latin1_to_native("foo \xc9 bar");
96 $text = latin1_to_native("a\xa3\xa3a $search $search quux");
e609e586
NC
97
98 my $text_utf8 = $text;
99 utf8::upgrade($text_utf8);
100 my $search_utf8 = $search;
101 utf8::upgrade($search_utf8);
102
103 is (index($text, $search), 5);
104 is (rindex($text, $search), 18);
105 is (index($text, $search_utf8), 5);
106 is (rindex($text, $search_utf8), 18);
107 is (index($text_utf8, $search), 5);
108 is (rindex($text_utf8, $search), 18);
109 is (index($text_utf8, $search_utf8), 5);
110 is (rindex($text_utf8, $search_utf8), 18);
111
112 my $text_octets = $text_utf8;
113 utf8::encode ($text_octets);
114 my $search_octets = $search_utf8;
115 utf8::encode ($search_octets);
116
117 is (index($text_octets, $search_octets), 7, "index octets, octets")
118 or _diag ($text_octets, $search_octets);
119 is (rindex($text_octets, $search_octets), 21, "rindex octets, octets");
120 is (index($text_octets, $search_utf8), -1);
121 is (rindex($text_octets, $search_utf8), -1);
122 is (index($text_utf8, $search_octets), -1);
123 is (rindex($text_utf8, $search_octets), -1);
124
125 is (index($text_octets, $search), -1);
126 is (rindex($text_octets, $search), -1);
127 is (index($text, $search_octets), -1);
128 is (rindex($text, $search_octets), -1);
129}
a2b7337b 130
6448472a
ST
131SKIP: {
132 skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193;
133
134 my $a = "\x{80000000}";
135 my $s = $a.'defxyz';
136 is(index($s, 'def'), 1, "0x80000000 is a single character");
137
138 my $b = "\x{fffffffd}";
139 my $t = $b.'pqrxyz';
140 is(index($t, 'pqr'), 1, "0xfffffffd is a single character");
141
142 local ${^UTF8CACHE} = -1;
143 is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
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
8aafe2e9 254} # end of sub run_tests