t/op/pos.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 plan tests => 33;
  10
  11 $x='banana';
  12 $x=~/.a/g;
  13 is(pos($x), 2, "matching, pos() leaves off at offset 2");
  14
  15 $x=~/.z/gc;
  16 is(pos($x), 2, "not matching, pos() remains at offset 2");
  17
  18 sub f { my $p=$_[0]; return $p }
  19
  20 $x=~/.a/g;
  21 is(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;
  25 is($x, "0123 5678910?", "pos() set inside //g");
  26
  27 $x = "123 56"; $x =~ / /g;
  28 is(pos($x), 4, "matching, pos() leaves off at offset 4");
  29 { local $x }
  30 is(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;
  37 is(pos $x, 3, "utf8_mg_len_cache_update() test");
  38
  39 is(scalar pos $x, 3, "rvalue pos() utf8 test");
  40
  41
  42 my $destroyed;
  43 { package Class; DESTROY { ++$destroyed; } }
  44
  45 $destroyed = 0;
  46 {
  47     my $x = '';
  48     pos($x) = 0;
  49     $x = bless({}, 'Class');
  50 }
  51 is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
  52
  53 eval 'pos @a = 1';
  54 like $@, qr/^Can't modify array dereference in match position at /,
  55   'pos refuses @arrays';
  56 eval 'pos %a = 1';
  57 like $@, qr/^Can't modify hash dereference in match position at /,
  58   'pos refuses %hashes';
  59 eval 'pos *a = 1';
  60 is 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
  65 pos($1) = 2;            # set pos; was ignoring UTF8-ness
  66 "$1";                   # turn on UTF8 flag
  67 is pos($1), 2, 'pos is not confused about changing UTF8-ness';
  68
  69 sub {
  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;
  96 pos $x=1;
  97 bless $x, a;
  98 is 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
 126 for 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 }