t/op/repeat.t

   1 #!./perl
   2
   3 # $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $
   4
   5 print "1..20\n";
   6
   7 # compile time
   8
   9 if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
  10 if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
  11 if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
  12
  13 if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
  14
  15 # run time
  16
  17 $a = '-';
  18 if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
  19 if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
  20 if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
  21
  22 $a = 'ab';
  23 if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
  24
  25 $a = 'xyz';
  26 $a x= 2;
  27 if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
  28 $a x= 1;
  29 if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
  30 $a x= 0;
  31 if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
  32
  33 @x = (1,2,3);
  34
  35 print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
  36 print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
  37 print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
  38 print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
  39 print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
  40 print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
  41 print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
  42 print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
  43
  44 #
  45 # The test #20 is actually testing for Digital C compiler optimizer bug,
  46 # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
  47 # found in December 1998.  The bug was reported to Digital^WCompaq as
  48 #     DECC 2745 (21-Dec-1998)
  49 # GEM_BUGS 7619 (23-Dec-1998)
  50 # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned
  51 # to be fixed also in 4.0G.
  52 #
  53 # The bug was as follows: broken code was produced for util.c:repeatcpy()
  54 # (a utility function for the 'x' operator) in the case *all* these
  55 # four conditions held:
  56 #
  57 # (1) len == 1
  58 # (2) "from" had the 8th bit on in its single character
  59 # (3) count > 7 (the 'x' count > 16)
  60 # (4) the highest optimization level was used in compilation
  61 #     (which is the default when compiling Perl)
  62 #
  63 # The bug looked like this (. being the eight-bit character and ? being \xff):
  64 #
  65 # 16 ................
  66 # 17 .........???????.
  67 # 18 .........???????..
  68 # 19 .........???????...
  69 # 20 .........???????....
  70 # 21 .........???????.....
  71 # 22 .........???????......
  72 # 23 .........???????.......
  73 # 24 .........???????.???????
  74 # 25 .........???????.???????.
  75 #
  76 # The bug was triggered in the "if (len == 1)" branch.  The fix
  77 # was to introduce a new temporary variable.  In diff -u format:
  78 #
  79 #     register char *frombase = from;
  80 #
  81 #     if (len == 1) {
  82 #-       todo = *from;
  83 #+       register char c = *from;
  84 #        while (count-- > 0)
  85 #-           *to++ = todo;
  86 #+           *to++ = c;
  87 #        return;
  88 #     }
  89 #
  90 # The bug could also be (obscurely) avoided by changing "from" to
  91 # be an unsigned char pointer.
  92 #
  93 # This obscure bug was not found by the then test suite but instead
  94 # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.
  95 #
  96 # jhi@iki.fi
  97 #
  98 print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n";