t/op/append.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 ##Literal test count since evals below can fail
  10 plan tests => 13;
  11
  12 $a = 'ab' . 'c';        # compile time
  13 $b = 'def';
  14
  15 $c = $a . $b;
  16 is( $c, 'abcdef', 'compile time concatenation' );
  17
  18 $c .= 'xyz';
  19 is( $c, 'abcdefxyz', 'concat to self');
  20
  21 $_ = $a;
  22 $_ .= $b;
  23 is( $_, 'abcdef', 'concat using $_');
  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
  35     isnt(r2(), '', 'UTF8 concat does not free the wrong string');
  36     isnt(r2(), '', 'second check');
  37 }
  38
  39 # test that nul bytes get copied
  40 {
  41     my ($a, $ab)   = ("a", "a\0b");
  42     my ($ua, $uab) = map pack("U0a*", $_), $a, $ab;
  43
  44     my $ub = pack("U0a*", 'b');
  45
  46     #aa\0b
  47     my $t1 = $a; $t1 .= $ab;
  48     like( $t1, qr/b/, 'null bytes do not stop string copy, aa\0b');
  49
  50     #a\0a\0b
  51     my $t2 = $a; $t2 .= $uab;
  52     ok( eval '$t2 =~ /$ub/', '... a\0a\0b' );
  53
  54     #\0aa\0b
  55     my $t3 = $ua; $t3 .= $ab;
  56     ok( eval '$t3 =~ /$ub/', '... \0aa\0b' );
  57
  58     my $t4 = $ua; $t4 .= $uab;
  59     ok( eval '$t4 =~ /$ub/', '... \0a\0a\0b' );
  60
  61     my $t5 = $a; $t5 = $ab . $t5;
  62     like( $t5, qr/$ub/, '... a\0ba' );
  63
  64     my $t6 = $a; $t6 = $uab . $t6;
  65     ok( eval '$t6 =~ /$ub/', '... \0a\0ba' );
  66
  67     my $t7 = $ua; $t7 = $ab . $t7;
  68     like( $t7, qr/$ub/, '... a\0b\0a' );
  69
  70     my $t8 = $ua; $t8 = $uab . $t8;
  71     ok( eval '$t8 =~ /$ub/', '... \0a\0b\0a' );
  72 }