xref: /openbsd-src/gnu/usr.bin/perl/t/opbasic/concat.t (revision c90a81c56dcebd6a1b73fe4aff9b03385b8e63b3) 
1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6}
7
8# ok() functions from other sources (e.g., t/test.pl) may use concatenation,
9# but that is what is being tested in this file.  Hence, we place this file
10# in the directory where do not use t/test.pl, and we write an ok() function
11# specially written to avoid any concatenation.
12
13my $test = 1;
14sub ok {
15    my($ok, $name) = @_;
16
17    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
18
19    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
20
21    $test++;
22    return $ok;
23}
24
25print "1..31\n";
26
27($a, $b, $c) = qw(foo bar);
28
29ok("$a"     eq "foo",    "verifying assign");
30ok("$a$b"   eq "foobar", "basic concatenation");
31ok("$c$a$c" eq "foo",    "concatenate undef, fore and aft");
32
33# Okay, so that wasn't very challenging.  Let's go Unicode.
34
35{
36    # bug id 20000819.004
37
38    $_ = $dx = "\x{10f2}";
39    s/($dx)/$dx$1/;
40    {
41        ok($_ eq  "$dx$dx","bug id 20000819.004, back");
42    }
43
44    $_ = $dx = "\x{10f2}";
45    s/($dx)/$1$dx/;
46    {
47        ok($_ eq  "$dx$dx","bug id 20000819.004, front");
48    }
49
50    $dx = "\x{10f2}";
51    $_  = "\x{10f2}\x{10f2}";
52    s/($dx)($dx)/$1$2/;
53    {
54        ok($_ eq  "$dx$dx","bug id 20000819.004, front and back");
55    }
56}
57
58{
59    # bug id 20000901.092
60    # test that undef left and right of utf8 results in a valid string
61
62    my $a;
63    $a .= "\x{1ff}";
64    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef left");
65    $a .= undef;
66    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef right");
67}
68
69{
70    # ID 20001020.006
71
72    "x" =~ /(.)/; # unset $2
73
74    # Without the fix this 5.7.0 would croak:
75    # Modification of a read-only value attempted at ...
76    eval {"$2\x{1234}"};
77    ok(!$@, "bug id 20001020.006, left");
78
79    # For symmetry with the above.
80    eval {"\x{1234}$2"};
81    ok(!$@, "bug id 20001020.006, right");
82
83    *pi = \undef;
84    # This bug existed earlier than the $2 bug, but is fixed with the same
85    # patch. Without the fix this 5.7.0 would also croak:
86    # Modification of a read-only value attempted at ...
87    eval{"$pi\x{1234}"};
88    ok(!$@, "bug id 20001020.006, constant left");
89
90    # For symmetry with the above.
91    eval{"\x{1234}$pi"};
92    ok(!$@, "bug id 20001020.006, constant right");
93}
94
95sub beq { use bytes; $_[0] eq $_[1]; }
96
97{
98    # concat should not upgrade its arguments.
99    my($l, $r, $c);
100
101    ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}");
102    ok(beq($l.$r, $c), "concat utf8 and byte");
103    ok(beq($l, "\x{101}"), "right not changed after concat u+b");
104    ok(beq($r, "\x{fe}"), "left not changed after concat u+b");
105
106    ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}");
107    ok(beq($l.$r, $c), "concat byte and utf8");
108    ok(beq($l, "\x{fe}"), "right not changed after concat b+u");
109    ok(beq($r, "\x{101}"), "left not changed after concat b+u");
110}
111
112{
113    my $a; ($a .= 5) . 6;
114    ok($a == 5, '($a .= 5) . 6 - present since 5.000');
115}
116
117{
118    # [perl #24508] optree construction bug
119    sub strfoo { "x" }
120    my ($x, $y);
121    $y = ($x = '' . strfoo()) . "y";
122    ok( "$x,$y" eq "x,xy", 'figures out correct target' );
123}
124
125{
126    # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation
127
128    my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X
129    my $u = "\x{100}";
130    my $b = pack 'a*', "\x{100}";
131    my $pu = "\xB6\x{100}";
132    my $up = "\x{100}\xB6";
133    my $x1 = $p;
134    my $y1 = $u;
135
136    use bytes;
137    ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes");
138    ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes");
139    ok(!beq($p.$u, $pu),  "perl #26905, left ne unicode");
140    ok(!beq($u.$p, $up),  "perl #26905, right ne unicode");
141
142    $x1 .= $u;
143    $x2 = $p . $u;
144    $y1 .= $p;
145    $y2 = $u . $p;
146
147    no bytes;
148    ok(beq($x1, $x2), "perl #26905, left,  .= vs = . in bytes");
149    ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes");
150    ok(($x1 eq $x2),  "perl #26905, left,  .= vs = . in chars");
151    ok(($y1 eq $y2),  "perl #26905, right, .= vs = . in chars");
152}
153
154{
155    # Concatenation needs to preserve UTF8ness of left oper.
156    my $x = eval"qr/\x{fff}/";
157    ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" );
158}
159
160{
161    my $x;
162    $x = "a" . "b";
163    $x .= "-append-";
164    ok($x eq "ab-append-", "Appending to something initialized using constant folding");
165}
166
167# [perl #124160]
168package o { use overload "." => sub { $_[0] }, fallback => 1 }
169$o = bless [], "o";
170ok(ref(CORE::state $y = "a $o b") eq 'o',
171  'state $y = "foo $bar baz" does not stringify; only concats');
172