t/op/repeat.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 require './test.pl';
   9 plan(tests => 45);
  10
  11 use Config;
  12
  13 # compile time
  14
  15 is('-' x 5, '-----',    'compile time x');
  16 is('-' x 3.1, '---',    'compile time 3.1');
  17 is('-' x 3.9, '---',    'compile time 3.9');
  18 is('-' x 1, '-',        '  x 1');
  19 is('-' x 0, '',         '  x 0');
  20 is('-' x -1, '',        '  x -1');
  21 is('-' x undef, '',     '  x undef');
  22 is('-' x "foo", '',     '  x "foo"');
  23 is('-' x "3rd", '---',  '  x "3rd"');
  24
  25 is('ab' x 3, 'ababab',  '  more than one char');
  26
  27 # run time
  28
  29 $a = '-';
  30 is($a x 5, '-----',     'run time x');
  31 is($a x 3.1, '---',     '  x 3.1');
  32 is($a x 3.9, '---',     '  x 3.9');
  33 is($a x 1, '-',         '  x 1');
  34 is($a x 0, '',          '  x 0');
  35 is($a x -3, '',         '  x -3');
  36 is($a x undef, '',      '  x undef');
  37 is($a x "foo", '',      '  x "foo"');
  38 is($a x "3rd", '---',   '  x "3rd"');
  39
  40 $a = 'ab';
  41 is($a x 3, 'ababab',    '  more than one char');
  42 $a = 'ab';
  43 is($a x 0, '',          '  more than one char');
  44 $a = 'ab';
  45 is($a x -12, '',        '  more than one char');
  46
  47 $a = 'xyz';
  48 $a x= 2;
  49 is($a, 'xyzxyz',        'x=2');
  50 $a x= 1;
  51 is($a, 'xyzxyz',        'x=1');
  52 $a x= 0;
  53 is($a, '',              'x=0');
  54
  55 @x = (1,2,3);
  56
  57 is(join('', @x x 4),        '3333',                 '@x x Y');
  58 is(join('', (@x) x 4),      '123123123123',         '(@x) x Y');
  59 is(join('', (@x,()) x 4),   '123123123123',         '(@x,()) x Y');
  60 is(join('', (@x,1) x 4),    '1231123112311231',     '(@x,1) x Y');
  61 is(join(':', () x 4),       '',                     '() x Y');
  62 is(join(':', (9) x 4),      '9:9:9:9',              '(X) x Y');
  63 is(join(':', (9,9) x 4),    '9:9:9:9:9:9:9:9',      '(X,X) x Y');
  64 is(join('', (split(//,"123")) x 2), '123123',       'split and x');
  65
  66 is(join('', @x x -12),      '',                     '@x x -12');
  67 is(join('', (@x) x -14),    '',                     '(@x) x -14');
  68
  69
  70 # This test is actually testing for Digital C compiler optimizer bug,
  71 # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
  72 # found in December 1998.  The bug was reported to Digital^WCompaq as
  73 #     DECC 2745 (21-Dec-1998)
  74 # GEM_BUGS 7619 (23-Dec-1998)
  75 # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned
  76 # to be fixed also in 4.0G.
  77 #
  78 # The bug was as follows: broken code was produced for util.c:repeatcpy()
  79 # (a utility function for the 'x' operator) in the case *all* these
  80 # four conditions held:
  81 #
  82 # (1) len == 1
  83 # (2) "from" had the 8th bit on in its single character
  84 # (3) count > 7 (the 'x' count > 16)
  85 # (4) the highest optimization level was used in compilation
  86 #     (which is the default when compiling Perl)
  87 #
  88 # The bug looked like this (. being the eight-bit character and ? being \xff):
  89 #
  90 # 16 ................
  91 # 17 .........???????.
  92 # 18 .........???????..
  93 # 19 .........???????...
  94 # 20 .........???????....
  95 # 21 .........???????.....
  96 # 22 .........???????......
  97 # 23 .........???????.......
  98 # 24 .........???????.???????
  99 # 25 .........???????.???????.
 100 #
 101 # The bug was triggered in the "if (len == 1)" branch.  The fix
 102 # was to introduce a new temporary variable.  In diff -u format:
 103 #
 104 #     register char *frombase = from;
 105 #
 106 #     if (len == 1) {
 107 #-       todo = *from;
 108 #+       register char c = *from;
 109 #        while (count-- > 0)
 110 #-           *to++ = todo;
 111 #+           *to++ = c;
 112 #        return;
 113 #     }
 114 #
 115 # The bug could also be (obscurely) avoided by changing "from" to
 116 # be an unsigned char pointer.
 117 #
 118 # This obscure bug was not found by the then test suite but instead
 119 # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.
 120 #
 121 # jhi@iki.fi
 122 #
 123 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');
 124
 125
 126 # When we use a list repeat in a scalar context, it behaves like
 127 # a scalar repeat. Make sure that works properly, and doesn't leave
 128 # extraneous values on the stack.
 129 #  -- robin@kitsite.com
 130
 131 my ($x, $y) = scalar ((1,2)x2);
 132 is($x, "22",    'list repeat in scalar context');
 133 is($y, undef,   '  no extra values on stack');
 134
 135 # Make sure the stack doesn't get truncated too much - the left
 136 # operand of the eq binop needs to remain!
 137 is(77, scalar ((1,7)x2),    'stack truncation');
 138
 139
 140 # perlbug 20011113.110 works in 5.6.1, broken in 5.7.2
 141 {
 142     my $x= [("foo") x 2];
 143     is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' );
 144 }
 145
 146 # [ID 20010809.028] x operator not copying elements in 'for' list?
 147 {
 148     local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]";
 149     my $x = 'abcd';
 150     my $y = '';
 151     for (($x =~ /./g) x 2) {
 152         $y .= chop;
 153     }
 154     is($y, 'abcdabcd');
 155 }
 156
 157 # Test the "malloc wrappage" guards introduced in Perl 5.8.4.
 158
 159 # Note that the guards do not catch everything: for example
 160 # "0"x0x7f...f is fine because it will attempt to allocate
 161 # "only" 0x7f...f+1 bytes: no wrappage there.
 162
 163 if ($Config{ptrsize} == 4) {
 164     eval '@a=(0)x0x7fffffff';
 165     like($@, qr/Out of memory during list extend/,   "list extend");
 166
 167     eval '@a=(0)x0x80000000';
 168     like($@, qr/Out of memory during list extend/,   "list extend");
 169
 170     eval '$a="012"x0x7fffffff';
 171     like($@, qr/Out of memory during string extend/, "string extend");
 172
 173     eval '$a="012"x0x80000000';
 174     like($@, qr/Out of memory during string extend/, "string extend");
 175 } elsif ($Config{ptrsize} == 8) {
 176     eval '@a=(0)x0x7fffffffffffffff';
 177     like($@, qr/Out of memory during list extend/,   "list extend");
 178
 179     eval '@a=(0)x0x8000000000000000';
 180     like($@, qr/Out of memory during list extend/,   "list extend");
 181
 182     eval '$a="012"x0x7fffffffffffffff';
 183     like($@, qr/Out of memory during string extend/, "string extend");
 184
 185     eval '$a="012"x0x8000000000000000';
 186     like($@, qr/Out of memory during string extend/, "string extend");
 187 } else {
 188     die "\$Config{ptrsize} == $Config{ptrsize}?";
 189 }
 190