1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use strict; 10plan( tests => 121 ); 11 12run_tests() unless caller; 13 14sub run_tests { 15 16my $foo = 'Now is the time for all good men to come to the aid of their country.'; 17 18my $first = substr($foo,0,index($foo,'the')); 19is($first, "Now is "); 20 21my $last = substr($foo,rindex($foo,'the'),100); 22is($last, "their country."); 23 24$last = substr($foo,index($foo,'Now'),2); 25is($last, "No"); 26 27$last = substr($foo,rindex($foo,'Now'),2); 28is($last, "No"); 29 30$last = substr($foo,index($foo,'.'),100); 31is($last, "."); 32 33$last = substr($foo,rindex($foo,'.'),100); 34is($last, "."); 35 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); 43 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); 51 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 66$a = "foo \x{1234}bar"; 67 68is(index($a, "\x{1234}"), 4); 69is(index($a, "bar", ), 5); 70 71is(rindex($a, "\x{1234}"), 4); 72is(rindex($a, "foo", ), 0); 73 74{ 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, $_ ); 81 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); 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, $_ ); 88 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); 89 } 90} 91 92{ 93 my $search; 94 my $text; 95 $search = latin1_to_native("foo \xc9 bar"); 96 $text = latin1_to_native("a\xa3\xa3a $search $search quux"); 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} 130 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} 145 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 { 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 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 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 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 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 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 251is index('the main road', __PACKAGE__), 4, 252 '[perl #119169] __PACKAGE__ as 2nd argument'; 253 254} # end of sub run_tests 255