1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9plan tests => 33; 10 11$x='banana'; 12$x=~/.a/g; 13is(pos($x), 2, "matching, pos() leaves off at offset 2"); 14 15$x=~/.z/gc; 16is(pos($x), 2, "not matching, pos() remains at offset 2"); 17 18sub f { my $p=$_[0]; return $p } 19 20$x=~/.a/g; 21is(f(pos($x)), 4, "matching again, pos() next leaves off at offset 4"); 22 23# Is pos() set inside //g? (bug id 19990615.008 (#874)) 24$x = "test string?"; $x =~ s/\w/pos($x)/eg; 25is($x, "0123 5678910?", "pos() set inside //g"); 26 27$x = "123 56"; $x =~ / /g; 28is(pos($x), 4, "matching, pos() leaves off at offset 4"); 29{ local $x } 30is(pos($x), 4, "value of pos() unaffected by intermediate localization"); 31 32# Explicit test that triggers the utf8_mg_len_cache_update() code path in 33# Perl_sv_pos_b2u(). 34 35$x = "\x{100}BC"; 36$x =~ m/.*/g; 37is(pos $x, 3, "utf8_mg_len_cache_update() test"); 38 39is(scalar pos $x, 3, "rvalue pos() utf8 test"); 40 41 42my $destroyed; 43{ package Class; DESTROY { ++$destroyed; } } 44 45$destroyed = 0; 46{ 47 my $x = ''; 48 pos($x) = 0; 49 $x = bless({}, 'Class'); 50} 51is($destroyed, 1, 'Timely scalar destruction with lvalue pos'); 52 53eval 'pos @a = 1'; 54like $@, qr/^Can't modify array dereference in match position at /, 55 'pos refuses @arrays'; 56eval 'pos %a = 1'; 57like $@, qr/^Can't modify hash dereference in match position at /, 58 'pos refuses %hashes'; 59eval 'pos *a = 1'; 60is eval 'pos *a', 1, 'pos *glob works'; 61 62# Test that UTF8-ness of $1 changing does not confuse pos 63"f" =~ /(f)/; "$1"; # first make sure UTF8-ness is off 64"\x{100}a" =~ /(..)/; # give PL_curpm a UTF8 string; $1 does not know yet 65pos($1) = 2; # set pos; was ignoring UTF8-ness 66"$1"; # turn on UTF8 flag 67is pos($1), 2, 'pos is not confused about changing UTF8-ness'; 68 69sub { 70 $_[0] = "hello"; 71 pos $_[0] = 3; 72 is pos $h{k}, 3, 'defelems can propagate pos assignment'; 73 $_[0] =~ /./g; 74 is pos $h{k}, 4, 'defelems can propagate implicit pos (via //g)'; 75 $_[0] =~ /oentuhoetn/g; 76 is pos $h{k}, undef, 'failed //g sets pos through defelem'; 77 $_[1] = "hello"; 78 pos $h{l} = 3; 79 is pos $_[1], 3, 'reading pos through a defelem'; 80 pos $h{l} = 4; 81 $_[1] =~ /(.)/g; 82 is "$1", 'o', '//g can read pos through a defelem'; 83 $_[2] = "hello"; 84 () = $_[2] =~ /l/gc; 85 is pos $h{m}, 4, '//gc in list cx can set pos through a defelem'; 86 $_[3] = "hello"; 87 $_[3] =~ 88 s<e><is pos($h{n}), 1, 's///g setting pos through a defelem'>egg; 89 $h{n} = 'hello'; 90 $_[3] =~ /e(?{ is pos $h{n},2, 're-evals set pos through defelems' })/; 91 pos $h{n} = 1; 92 ok $_[3] =~ /\Ge/, '\G works with defelem scalars'; 93}->($h{k}, $h{l}, $h{m}, $h{n}); 94 95$x = bless [], chr 256; 96pos $x=1; 97bless $x, a; 98is pos($x), 1, 'pos is not affected by reference stringification changing'; 99{ 100 my $w; 101 local $SIG{__WARN__} = sub { $w .= shift }; 102 $x = bless [], chr 256; 103 pos $x=1; 104 bless $x, "\x{1000}"; 105 is pos $x, 1, 106 'pos unchanged after increasing size of chars in stringification'; 107 is $w, undef, 'and no malformed utf8 warning'; 108} 109$x = bless [], chr 256; 110$x =~ /.(?{ 111 bless $x, a; 112 is pos($x), 1, 'pos unaffected by ref str changing (in re-eval)'; 113})/; 114{ 115 my $w; 116 local $SIG{__WARN__} = sub { $w .= shift }; 117 $x = bless [], chr(256); 118 $x =~ /.(?{ 119 bless $x, "\x{1000}"; 120 is pos $x, 1, 121 'pos unchanged in re-eval after increasing size of chars in str'; 122 })/; 123 is $w, undef, 'and no malformed utf8 warning'; 124} 125 126for my $one(pos $x) { 127 for my $two(pos $x) { 128 $one = \1; 129 $two = undef; 130 is $one, undef, 131 'no assertion failure when getting pos clobbers ref with undef'; 132 } 133} 134 135{ 136 # RT # 127518 137 my $x = "\N{U+10000}abc"; 138 my %expected = ( 139 chars => { length => 4, pos => 2 }, 140 bytes => { length => 7, pos => 5 }, 141 ); 142 my %observed; 143 $observed{chars}{length} = length($x); 144 $x =~ m/a/g; 145 $observed{chars}{pos} = pos($x); 146 147 { 148 use bytes; 149 $observed{bytes}{length} = length($x); 150 $observed{bytes}{pos} = pos($x); 151 } 152 153 is( $observed{chars}{length}, $expected{chars}{length}, 154 "Got expected length in chars"); 155 is( $observed{chars}{pos}, $expected{chars}{pos}, 156 "Got expected pos in chars"); 157 is( $observed{bytes}{length}, $expected{bytes}{length}, 158 "Got expected length in bytes"); 159 is( $observed{bytes}{pos}, $expected{bytes}{pos}, 160 "Got expected pos in bytes"); 161} 162