Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
18b94ad2 CK |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
18b94ad2 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
18b94ad2 CK |
7 | } |
8 | ||
9 | ##Literal test count since evals below can fail | |
10 | plan tests => 13; | |
8d063cd8 LW |
11 | |
12 | $a = 'ab' . 'c'; # compile time | |
13 | $b = 'def'; | |
14 | ||
15 | $c = $a . $b; | |
18b94ad2 | 16 | is( $c, 'abcdef', 'compile time concatenation' ); |
8d063cd8 LW |
17 | |
18 | $c .= 'xyz'; | |
18b94ad2 | 19 | is( $c, 'abcdefxyz', 'concat to self'); |
8d063cd8 LW |
20 | |
21 | $_ = $a; | |
22 | $_ .= $b; | |
18b94ad2 | 23 | is( $_, 'abcdef', 'concat using $_'); |
15bb2692 HS |
24 | |
25 | # test that when right argument of concat is UTF8, and is the same | |
26 | # variable as the target, and the left argument is not UTF8, it no | |
27 | # longer frees the wrong string. | |
28 | { | |
29 | sub r2 { | |
30 | my $string = ''; | |
31 | $string .= pack("U0a*", 'mnopqrstuvwx'); | |
32 | $string = "abcdefghijkl$string"; | |
33 | } | |
34 | ||
18b94ad2 CK |
35 | isnt(r2(), '', 'UTF8 concat does not free the wrong string'); |
36 | isnt(r2(), '', 'second check'); | |
15bb2692 HS |
37 | } |
38 | ||
39 | # test that nul bytes get copied | |
40 | { | |
2d708654 JH |
41 | my ($a, $ab) = ("a", "a\0b"); |
42 | my ($ua, $uab) = map pack("U0a*", $_), $a, $ab; | |
1d996145 | 43 | |
2d708654 | 44 | my $ub = pack("U0a*", 'b'); |
1d996145 | 45 | |
18b94ad2 | 46 | #aa\0b |
15bb2692 | 47 | my $t1 = $a; $t1 .= $ab; |
18b94ad2 | 48 | like( $t1, qr/b/, 'null bytes do not stop string copy, aa\0b'); |
1d996145 | 49 | |
18b94ad2 | 50 | #a\0a\0b |
2d708654 | 51 | my $t2 = $a; $t2 .= $uab; |
76445bb0 | 52 | ok( eval '$t2 =~ /$ub/', '... a\0a\0b' ); |
18b94ad2 CK |
53 | |
54 | #\0aa\0b | |
2d708654 | 55 | my $t3 = $ua; $t3 .= $ab; |
76445bb0 | 56 | ok( eval '$t3 =~ /$ub/', '... \0aa\0b' ); |
18b94ad2 | 57 | |
2d708654 | 58 | my $t4 = $ua; $t4 .= $uab; |
76445bb0 | 59 | ok( eval '$t4 =~ /$ub/', '... \0a\0a\0b' ); |
18b94ad2 | 60 | |
15bb2692 | 61 | my $t5 = $a; $t5 = $ab . $t5; |
18b94ad2 CK |
62 | like( $t5, qr/$ub/, '... a\0ba' ); |
63 | ||
2d708654 | 64 | my $t6 = $a; $t6 = $uab . $t6; |
76445bb0 | 65 | ok( eval '$t6 =~ /$ub/', '... \0a\0ba' ); |
18b94ad2 | 66 | |
2d708654 | 67 | my $t7 = $ua; $t7 = $ab . $t7; |
18b94ad2 CK |
68 | like( $t7, qr/$ub/, '... a\0b\0a' ); |
69 | ||
2d708654 | 70 | my $t8 = $ua; $t8 = $uab . $t8; |
76445bb0 | 71 | ok( eval '$t8 =~ /$ub/', '... \0a\0b\0a' ); |
15bb2692 | 72 | } |