This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4eca3a6393f1a8817dd5f6c5622211b643646496
[perl5.git] / t / op / pos.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan tests => 21;
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)
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
40 my $destroyed;
41 { package Class; DESTROY { ++$destroyed; } }
42
43 $destroyed = 0;
44 {
45     my $x = '';
46     pos($x) = 0;
47     $x = bless({}, 'Class');
48 }
49 is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
50
51 eval 'pos @a = 1';
52 like $@, qr/^Can't modify array dereference in match position at /,
53   'pos refuses @arrays';
54 eval 'pos %a = 1';
55 like $@, qr/^Can't modify hash dereference in match position at /,
56   'pos refuses %hashes';
57 eval 'pos *a = 1';
58 is eval 'pos *a', 1, 'pos *glob works';
59
60 # Test that UTF8-ness of $1 changing does not confuse pos
61 "f" =~ /(f)/; "$1";     # first make sure UTF8-ness is off
62 "\x{100}a" =~ /(..)/;   # give PL_curpm a UTF8 string; $1 does not know yet
63 pos($1) = 2;            # set pos; was ignoring UTF8-ness
64 "$1";                   # turn on UTF8 flag
65 is pos($1), 2, 'pos is not confused about changing UTF8-ness';
66
67 sub {
68     $_[0] = "hello";
69     pos $_[0] = 3;
70     is pos $h{k}, 3, 'defelems can propagate pos assignment';
71     $_[0] =~ /./g;
72     is pos $h{k}, 4, 'defelems can propagate implicit pos (via //g)';
73     $_[0] =~ /oentuhoetn/g;
74     is pos $h{k}, undef, 'failed //g sets pos through defelem';
75     $_[1] = "hello";
76     pos $h{l} = 3;
77     is pos $_[1], 3, 'reading pos through a defelem';
78     pos $h{l} = 4;
79     $_[1] =~ /(.)/g;
80     is "$1", 'o', '//g can read pos through a defelem';
81     $_[2] = "hello";
82     () = $_[2] =~ /l/gc;
83     is pos $h{m}, 4, '//gc in list cx can set pos through a defelem';
84     $_[3] = "hello";
85     $_[3] =~
86         s<e><is pos($h{n}), 1, 's///g setting pos through a defelem'>egg;
87     $h{n} = 'hello';
88     $_[3] =~ /e(?{ is pos $h{n},2, 're-evals set pos through defelems' })/;
89     pos $h{n} = 1;
90     ok $_[3] =~ /\Ge/, '\G works with defelem scalars';
91 }->($h{k}, $h{l}, $h{m}, $h{n});