t/op/repeat.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 => 49);
  10
  11 # compile time
  12
  13 is('-' x 5, '-----',    'compile time x');
  14 is('-' x 3.1, '---',    'compile time 3.1');
  15 is('-' x 3.9, '---',    'compile time 3.9');
  16 is('-' x 1, '-',        '  x 1');
  17 is('-' x 0, '',         '  x 0');
  18 is('-' x -1, '',        '  x -1');
  19 is('-' x undef, '',     '  x undef');
  20 is('-' x "foo", '',     '  x "foo"');
  21 is('-' x "3rd", '---',  '  x "3rd"');
  22
  23 is('ab' x 3, 'ababab',  '  more than one char');
  24
  25 # run time
  26
  27 $a = '-';
  28 is($a x 5, '-----',     'run time x');
  29 is($a x 3.1, '---',     '  x 3.1');
  30 is($a x 3.9, '---',     '  x 3.9');
  31 is($a x 1, '-',         '  x 1');
  32 is($a x 0, '',          '  x 0');
  33 is($a x -3, '',         '  x -3');
  34 is($a x undef, '',      '  x undef');
  35 is($a x "foo", '',      '  x "foo"');
  36 is($a x "3rd", '---',   '  x "3rd"');
  37
  38 $a = 'ab';
  39 is($a x 3, 'ababab',    '  more than one char');
  40 $a = 'ab';
  41 is($a x 0, '',          '  more than one char');
  42 $a = 'ab';
  43 is($a x -12, '',        '  more than one char');
  44
  45 $a = 'xyz';
  46 $a x= 2;
  47 is($a, 'xyzxyz',        'x=2');
  48 $a x= 1;
  49 is($a, 'xyzxyz',        'x=1');
  50 $a x= 0;
  51 is($a, '',              'x=0');
  52
  53 @x = (1,2,3);
  54
  55 is(join('', @x x 4),        '3333',                 '@x x Y');
  56 is(join('', (@x) x 4),      '123123123123',         '(@x) x Y');
  57 is(join('', (@x,()) x 4),   '123123123123',         '(@x,()) x Y');
  58 is(join('', (@x,1) x 4),    '1231123112311231',     '(@x,1) x Y');
  59 is(join(':', () x 4),       '',                     '() x Y');
  60 is(join(':', (9) x 4),      '9:9:9:9',              '(X) x Y');
  61 is(join(':', (9,9) x 4),    '9:9:9:9:9:9:9:9',      '(X,X) x Y');
  62 is(join('', (split(//,"123")) x 2), '123123',       'split and x');
  63
  64 is(join('', @x x -12),      '',                     '@x x -12');
  65 is(join('', (@x) x -14),    '',                     '(@x) x -14');
  66
  67 ($a, (undef)x5, $b) = 1..10;
  68 is ("$a $b", "1 7", '(undef)xCONST on lhs of list assignment');
  69 (($a)x3,$b) = 1..10;
  70 is ("$a, $b", "3, 4", '($x)xCONST on lhs of list assignment');
  71 ($a, (undef)x${\6}, $b) = "a".."z";
  72 is ("$a$b", "ah", '(undef)x$foo on lhs of list assignment');
  73
  74
  75 # This test is actually testing for Digital C compiler optimizer bug,
  76 # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
  77 # found in December 1998.  The bug was reported to Digital^WCompaq as
  78 #     DECC 2745 (21-Dec-1998)
  79 # GEM_BUGS 7619 (23-Dec-1998)
  80 # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned
  81 # to be fixed also in 4.0G.
  82 #
  83 # The bug was as follows: broken code was produced for util.c:repeatcpy()
  84 # (a utility function for the 'x' operator) in the case *all* these
  85 # four conditions held:
  86 #
  87 # (1) len == 1
  88 # (2) "from" had the 8th bit on in its single character
  89 # (3) count > 7 (the 'x' count > 16)
  90 # (4) the highest optimization level was used in compilation
  91 #     (which is the default when compiling Perl)
  92 #
  93 # The bug looked like this (. being the eight-bit character and ? being \xff):
  94 #
  95 # 16 ................
  96 # 17 .........???????.
  97 # 18 .........???????..
  98 # 19 .........???????...
  99 # 20 .........???????....
 100 # 21 .........???????.....
 101 # 22 .........???????......
 102 # 23 .........???????.......
 103 # 24 .........???????.???????
 104 # 25 .........???????.???????.
 105 #
 106 # The bug was triggered in the "if (len == 1)" branch.  The fix
 107 # was to introduce a new temporary variable.  In diff -u format:
 108 #
 109 #     register char *frombase = from;
 110 #
 111 #     if (len == 1) {
 112 #-       todo = *from;
 113 #+       register char c = *from;
 114 #        while (count-- > 0)
 115 #-           *to++ = todo;
 116 #+           *to++ = c;
 117 #        return;
 118 #     }
 119 #
 120 # The bug could also be (obscurely) avoided by changing "from" to
 121 # be an unsigned char pointer.
 122 #
 123 # This obscure bug was not found by the then test suite but instead
 124 # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.
 125 #
 126 # jhi@iki.fi
 127 #
 128 is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug');
 129
 130
 131 # When we use a list repeat in a scalar context, it behaves like
 132 # a scalar repeat. Make sure that works properly, and doesn't leave
 133 # extraneous values on the stack.
 134 #  -- robin@kitsite.com
 135
 136 my ($x, $y) = scalar ((1,2)x2);
 137 is($x, "22",    'list repeat in scalar context');
 138 is($y, undef,   '  no extra values on stack');
 139
 140 # Make sure the stack doesn't get truncated too much - the first
 141 # argument to is() needs to remain!
 142 is(77, scalar ((1,7)x2),    'stack truncation');
 143
 144 # ( )x in void context should not read preceding stack items
 145 package Tiecount {
 146     sub TIESCALAR { bless[]} sub FETCH { our $Tiecount++; study; 3 }
 147 }
 148 sub nil {}
 149 tie my $t, "Tiecount";
 150 { push my @temp, $t, scalar((nil) x 3, 1) }
 151 is($Tiecount::Tiecount, 1,
 152    '(...)x... in void context in list (via scalar comma)');
 153
 154
 155 # perlbug 20011113.110 (#7902) works in 5.6.1, broken in 5.7.2
 156 {
 157     my $x= [("foo") x 2];
 158     is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110 (#7902)]' );
 159 }
 160
 161 # [perl #35885]
 162 is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' );
 163
 164 # [perl #78194] x aliasing op return values
 165 sub {
 166     is(\$_[0], \$_[1],
 167       '[perl #78194] \$_[0] == \$_[1] when @_ aliases elems repeated by x')
 168 }
 169  ->(("${\''}")x2);
 170
 171 $#that_array = 7;
 172 for(($#that_array)x2) {
 173     $_ *= 2;
 174 }
 175 is($#that_array, 28, 'list repetition propagates lvalue cx to its lhs');
 176
 177 # [perl #126309] huge list counts should give an error
 178
 179
 180 fresh_perl_like(
 181  '@a = (1) x ~1',
 182   qr/Out of memory/,
 183   {  },
 184  '(1) x ~1',
 185 );
 186
 187 # [perl #130247] Perl_rpeep(OP *): Assertion `oldop' failed
 188 #
 189 # the 'x 0' optimising code in rpeep didn't expect the repeat expression
 190 # to occur on the op_other side of an op_next chain.
 191 # This used to give an assertion failure
 192
 193 eval q{() = (() or ((0) x 0)); 1};
 194 is($@, "", "RT #130247");