diff options
author | James E Keenan <jkeenan@cpan.org> | 2012-12-02 08:11:13 -0500 |
---|---|---|
committer | James E Keenan <jkeenan@cpan.org> | 2012-12-07 20:05:00 -0500 |
commit | 8a5eedb005f7c37f37bea546d40741b5a9ccfad2 (patch) | |
tree | e0622cd951f9cea9c1c8789b3f7d47452f2a079a /t/opbasic | |
parent | 2f445b24d1fcccfa186e5ac8cd8f82a820c4369d (diff) | |
download | perl-8a5eedb005f7c37f37bea546d40741b5a9ccfad2.tar.gz |
Create subdirectory t/opbasic. Move 5 test files there.
t/opbasic will hold files formerly held in t/op but which, unlike the vast
majority of tests in the latter directory, are ineligible to use t/test.pl as
a source of test functions. Affected files:
arith.t
cmp.t
concat.t
magic_phase.t
qq.t
This commit does nothing more than create the new subdirectory and move the
files into it.
For: RT #115838
Diffstat (limited to 't/opbasic')
-rw-r--r-- | t/opbasic/arith.t | 454 | ||||
-rw-r--r-- | t/opbasic/cmp.t | 318 | ||||
-rw-r--r-- | t/opbasic/concat.t | 161 | ||||
-rw-r--r-- | t/opbasic/magic_phase.t | 48 | ||||
-rw-r--r-- | t/opbasic/qq.t | 73 |
5 files changed, 1054 insertions, 0 deletions
diff --git a/t/opbasic/arith.t b/t/opbasic/arith.t new file mode 100644 index 0000000000..3c91971fda --- /dev/null +++ b/t/opbasic/arith.t @@ -0,0 +1,454 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..167\n"; + +sub try ($$$) { + print +($_[1] ? "ok" : "not ok"), " $_[0] - $_[2]\n"; +} +sub tryeq ($$$$) { + if ($_[1] == $_[2]) { + print "ok $_[0]"; + } else { + print "not ok $_[0] # $_[1] != $_[2]"; + } + print " - $_[3]\n"; +} +sub tryeq_sloppy ($$$$) { + if ($_[1] == $_[2]) { + print "ok $_[0]"; + } else { + my $error = abs (($_[1] - $_[2]) / $_[1]); + if ($error < 1e-9) { + print "ok $_[0] # $_[1] is close to $_[2], \$^O eq $^O"; + } else { + print "not ok $_[0] # $_[1] != $_[2]"; + } + } + print " - $_[3]\n"; +} + +my $T = 1; +tryeq $T++, 13 % 4, 1, 'modulo: positive positive'; +tryeq $T++, -13 % 4, 3, 'modulo: negative positive'; +tryeq $T++, 13 % -4, -3, 'modulo: positive negative'; +tryeq $T++, -13 % -4, -1, 'modulo: negative negative'; + +# Give abs() a good work-out before using it in anger +tryeq $T++, abs(0), 0, 'abs(): 0 0'; +tryeq $T++, abs(1), 1, 'abs(): 1 1'; +tryeq $T++, abs(-1), 1, 'abs(): -1 1'; +tryeq $T++, abs(2147483647), 2147483647, 'abs(): 2**31-1: pos pos'; +tryeq $T++, abs(-2147483647), 2147483647, 'abs(): 2**31-1: neg pos'; +tryeq $T++, abs(4294967295), 4294967295, 'abs(): 2**32-1: pos pos'; +tryeq $T++, abs(-4294967295), 4294967295, 'abs(): 2**32-1: neg pos'; +tryeq $T++, abs(9223372036854775807), 9223372036854775807, + 'abs(): 2**63-1: pos pos'; +tryeq $T++, abs(-9223372036854775807), 9223372036854775807, + 'abs(): 2**63-1: neg pos'; +# Assume no change whatever; no slop needed +tryeq $T++, abs(1e50), 1e50, 'abs(): 1e50: pos pos'; +# Assume only sign bit flipped +tryeq $T++, abs(-1e50), 1e50, 'abs(): 1e50: neg pos'; + +my $limit = 1e6; + +# Division (and modulo) of floating point numbers +# seem to be rather sloppy in Cray. +$limit = 1e8 if $^O eq 'unicos'; + +try $T++, abs( 13e21 % 4e21 - 1e21) < $limit, 'abs() for floating point'; +try $T++, abs(-13e21 % 4e21 - 3e21) < $limit, 'abs() for floating point'; +try $T++, abs( 13e21 % -4e21 - -3e21) < $limit, 'abs() for floating point'; +try $T++, abs(-13e21 % -4e21 - -1e21) < $limit, 'abs() for floating point'; + +tryeq $T++, 4063328477 % 65535, 27407, 'UV behaves properly: modulo'; +tryeq $T++, 4063328477 % 4063328476, 1, 'UV behaves properly: modulo'; +tryeq $T++, 4063328477 % 2031664238, 1, 'UV behaves properly: modulo'; +tryeq $T++, 2031664238 % 4063328477, 2031664238, + 'UV behaves properly: modulo'; + +tryeq $T++, 2147483647 + 0, 2147483647, + 'trigger wrapping on 32 bit IVs and UVs'; + +tryeq $T++, 2147483647 + 1, 2147483648, 'IV + IV promotes to UV'; +tryeq $T++, 2147483640 + 10, 2147483650, 'IV + IV promotes to UV'; +tryeq $T++, 2147483647 + 2147483647, 4294967294, 'IV + IV promotes to UV'; +tryeq $T++, 2147483647 + 2147483649, 4294967296, 'IV + UV promotes to NV'; +tryeq $T++, 4294967294 + 2, 4294967296, 'UV + IV promotes to NV'; +tryeq $T++, 4294967295 + 4294967295, 8589934590, 'UV + UV promotes to NV'; + +tryeq $T++, 2147483648 + -1, 2147483647, 'UV + IV promotes to IV'; +tryeq $T++, 2147483650 + -10, 2147483640, 'UV + IV promotes to IV'; +tryeq $T++, -1 + 2147483648, 2147483647, 'IV + UV promotes to IV'; +tryeq $T++, -10 + 4294967294, 4294967284, 'IV + UV promotes to IV'; +tryeq $T++, -2147483648 + -2147483648, -4294967296, 'IV + IV promotes to NV'; +tryeq $T++, -2147483640 + -10, -2147483650, 'IV + IV promotes to NV'; + +# Hmm. Do not forget the simple stuff +# addition +tryeq $T++, 1 + 1, 2, 'addition of 2 positive integers'; +tryeq $T++, 4 + -2, 2, 'addition of positive and negative integer'; +tryeq $T++, -10 + 100, 90, 'addition of negative and positive integer'; +tryeq $T++, -7 + -9, -16, 'addition of 2 negative integers'; +tryeq $T++, -63 + +2, -61, 'addition of signed negative and positive integers'; +tryeq $T++, 4 + -1, 3, 'addition of positive and negative integer'; +tryeq $T++, -1 + 1, 0, 'addition which sums to 0'; +tryeq $T++, +29 + -29, 0, 'addition which sums to 0'; +tryeq $T++, -1 + 4, 3, 'addition of signed negative and positive integers'; +tryeq $T++, +4 + -17, -13, 'addition of signed positive and negative integers'; + +# subtraction +tryeq $T++, 3 - 1, 2, 'subtraction of two positive integers'; +tryeq $T++, 3 - 15, -12, + 'subtraction of two positive integers: minuend smaller'; +tryeq $T++, 3 - -7, 10, 'subtraction of positive and negative integer'; +tryeq $T++, -156 - 5, -161, 'subtraction of negative and positive integer'; +tryeq $T++, -156 - -5, -151, 'subtraction of two negative integers'; +tryeq $T++, -5 - -12, 7, + 'subtraction of two negative integers: minuend smaller'; +tryeq $T++, -3 - -3, 0, 'subtraction of two negative integers with result of 0'; +tryeq $T++, 15 - 15, 0, 'subtraction of two positive integers with result of 0'; +tryeq $T++, 2147483647 - 0, 2147483647, 'subtraction from large integer'; +tryeq $T++, 2147483648 - 0, 2147483648, 'subtraction from large integer'; +tryeq $T++, -2147483648 - 0, -2147483648, + 'subtraction from large negative integer'; +tryeq $T++, 0 - -2147483647, 2147483647, + 'subtraction of large negative integer from 0'; +tryeq $T++, -1 - -2147483648, 2147483647, + 'subtraction of large negative integer from negative integer'; +tryeq $T++, 2 - -2147483648, 2147483650, + 'subtraction of large negative integer from positive integer'; +tryeq $T++, 4294967294 - 3, 4294967291, 'subtraction from large integer'; +tryeq $T++, -2147483648 - -1, -2147483647, + 'subtraction from large negative integer'; +tryeq $T++, 2147483647 - -1, 2147483648, 'IV - IV promote to UV'; +tryeq $T++, 2147483647 - -2147483648, 4294967295, 'IV - IV promote to UV'; +tryeq $T++, 4294967294 - -3, 4294967297, 'UV - IV promote to NV'; +tryeq $T++, -2147483648 - +1, -2147483649, 'IV - IV promote to NV'; +tryeq $T++, 2147483648 - 2147483650, -2, 'UV - UV promote to IV'; +tryeq $T++, 2000000000 - 4000000000, -2000000000, 'IV - UV promote to IV'; + +# No warnings should appear; +my $a; +$a += 1; +tryeq $T++, $a, 1, '+= with positive'; +undef $a; +$a += -1; +tryeq $T++, $a, -1, '+= with negative'; +undef $a; +$a += 4294967290; +tryeq $T++, $a, 4294967290, '+= with positive'; +undef $a; +$a += -4294967290; +tryeq $T++, $a, -4294967290, '+= with negative'; +undef $a; +$a += 4294967297; +tryeq $T++, $a, 4294967297, '+= with positive'; +undef $a; +$a += -4294967297; +tryeq $T++, $a, -4294967297, '+= with negative'; + +my $s; +$s -= 1; +tryeq $T++, $s, -1, '-= with positive'; +undef $s; +$s -= -1; +tryeq $T++, $s, +1, '-= with negative'; +undef $s; +$s -= -4294967290; +tryeq $T++, $s, +4294967290, '-= with negative'; +undef $s; +$s -= 4294967290; +tryeq $T++, $s, -4294967290, '-= with negative'; +undef $s; +$s -= 4294967297; +tryeq $T++, $s, -4294967297, '-= with positive'; +undef $s; +$s -= -4294967297; +tryeq $T++, $s, +4294967297, '-= with positive'; + +# multiplication +tryeq $T++, 1 * 3, 3, 'multiplication of two positive integers'; +tryeq $T++, -2 * 3, -6, 'multiplication of negative and positive integer'; +tryeq $T++, 3 * -3, -9, 'multiplication of positive and negative integer'; +tryeq $T++, -4 * -3, 12, 'multiplication of two negative integers'; + +# check with 0xFFFF and 0xFFFF +tryeq $T++, 65535 * 65535, 4294836225, + 'multiplication: 0xFFFF and 0xFFFF: pos pos'; +tryeq $T++, 65535 * -65535, -4294836225, + 'multiplication: 0xFFFF and 0xFFFF: pos neg'; +tryeq $T++, -65535 * 65535, -4294836225, + 'multiplication: 0xFFFF and 0xFFFF: pos neg'; +tryeq $T++, -65535 * -65535, 4294836225, + 'multiplication: 0xFFFF and 0xFFFF: neg neg'; + +# check with 0xFFFF and 0x10001 +tryeq $T++, 65535 * 65537, 4294967295, + 'multiplication: 0xFFFF and 0x10001: pos pos'; +tryeq $T++, 65535 * -65537, -4294967295, + 'multiplication: 0xFFFF and 0x10001: pos neg'; +tryeq $T++, -65535 * 65537, -4294967295, + 'multiplication: 0xFFFF and 0x10001: neg pos'; +tryeq $T++, -65535 * -65537, 4294967295, + 'multiplication: 0xFFFF and 0x10001: neg neg'; + +# check with 0x10001 and 0xFFFF +tryeq $T++, 65537 * 65535, 4294967295, + 'multiplication: 0x10001 and 0xFFFF: pos pos'; +tryeq $T++, 65537 * -65535, -4294967295, + 'multiplication: 0x10001 and 0xFFFF: pos neg'; +tryeq $T++, -65537 * 65535, -4294967295, + 'multiplication: 0x10001 and 0xFFFF: neg pos'; +tryeq $T++, -65537 * -65535, 4294967295, + 'multiplication: 0x10001 and 0xFFFF: neg neg'; + +# These should all be dones as NVs +tryeq $T++, 65537 * 65537, 4295098369, 'multiplication: NV: pos pos'; +tryeq $T++, 65537 * -65537, -4295098369, 'multiplication: NV: pos neg'; +tryeq $T++, -65537 * 65537, -4295098369, 'multiplication: NV: neg pos'; +tryeq $T++, -65537 * -65537, 4295098369, 'multiplication: NV: neg neg'; + +# will overflow an IV (in 32-bit) +tryeq $T++, 46340 * 46342, 0x80001218, + 'multiplication: overflow an IV in 32-bit: pos pos'; +tryeq $T++, 46340 * -46342, -0x80001218, + 'multiplication: overflow an IV in 32-bit: pos neg'; +tryeq $T++, -46340 * 46342, -0x80001218, + 'multiplication: overflow an IV in 32-bit: neg pos'; +tryeq $T++, -46340 * -46342, 0x80001218, + 'multiplication: overflow an IV in 32-bit: neg neg'; + +tryeq $T++, 46342 * 46340, 0x80001218, + 'multiplication: overflow an IV in 32-bit: pos pos'; +tryeq $T++, 46342 * -46340, -0x80001218, + 'multiplication: overflow an IV in 32-bit: pos neg'; +tryeq $T++, -46342 * 46340, -0x80001218, + 'multiplication: overflow an IV in 32-bit: neg pos'; +tryeq $T++, -46342 * -46340, 0x80001218, + 'multiplication: overflow an IV in 32-bit: neg neg'; + +# will overflow a positive IV (in 32-bit) +tryeq $T++, 65536 * 32768, 0x80000000, + 'multiplication: overflow a positive IV in 32-bit: pos pos'; +tryeq $T++, 65536 * -32768, -0x80000000, + 'multiplication: overflow a positive IV in 32-bit: pos neg'; +tryeq $T++, -65536 * 32768, -0x80000000, + 'multiplication: overflow a positive IV in 32-bit: neg pos'; +tryeq $T++, -65536 * -32768, 0x80000000, + 'multiplication: overflow a positive IV in 32-bit: neg neg'; + +tryeq $T++, 32768 * 65536, 0x80000000, + 'multiplication: overflow a positive IV in 32-bit: pos pos'; +tryeq $T++, 32768 * -65536, -0x80000000, + 'multiplication: overflow a positive IV in 32-bit: pos neg'; +tryeq $T++, -32768 * 65536, -0x80000000, + 'multiplication: overflow a positive IV in 32-bit: neg pos'; +tryeq $T++, -32768 * -65536, 0x80000000, + 'multiplication: overflow a positive IV in 32-bit: neg neg'; + +# 2147483647 is prime. bah. + +tryeq $T++, 46339 * 46341, 0x7ffea80f, + 'multiplication: hex product: pos pos'; +tryeq $T++, 46339 * -46341, -0x7ffea80f, + 'multiplication: hex product: pos neg'; +tryeq $T++, -46339 * 46341, -0x7ffea80f, + 'multiplication: hex product: neg pos'; +tryeq $T++, -46339 * -46341, 0x7ffea80f, + 'multiplication: hex product: neg neg'; + +# leading space should be ignored + +tryeq $T++, 1 + " 1", 2, 'ignore leading space: addition'; +tryeq $T++, 3 + " -1", 2, 'ignore leading space: subtraction'; +tryeq $T++, 1.2, " 1.2", 'floating point and string equivalent: positive'; +tryeq $T++, -1.2, " -1.2", 'floating point and string equivalent: negative'; + +# division +tryeq $T++, 28/14, 2, 'division of two positive integers'; +tryeq $T++, 28/-7, -4, 'division of positive integer by negative'; +tryeq $T++, -28/4, -7, 'division of negative integer by positive'; +tryeq $T++, -28/-2, 14, 'division of negative integer by negative'; + +tryeq $T++, 0x80000000/1, 0x80000000, + 'division of positive hex by positive integer'; +tryeq $T++, 0x80000000/-1, -0x80000000, + 'division of positive hex by negative integer'; +tryeq $T++, -0x80000000/1, -0x80000000, + 'division of negative hex by negative integer'; +tryeq $T++, -0x80000000/-1, 0x80000000, + 'division of negative hex by positive integer'; + +# The example for sloppy divide, rigged to avoid the peephole optimiser. +tryeq_sloppy $T++, "20." / "5.", 4, 'division of floating point without fractional part'; + +tryeq $T++, 2.5 / 2, 1.25, + 'division of positive floating point by positive integer'; +tryeq $T++, 3.5 / -2, -1.75, + 'division of positive floating point by negative integer'; +tryeq $T++, -4.5 / 2, -2.25, + 'division of negative floating point by positive integer'; +tryeq $T++, -5.5 / -2, 2.75, + 'division of negative floating point by negative integer'; + +# Bluuurg if your floating point can not accurately cope with powers of 2 +# [I suspect this is parsing string->float problems, not actual arith] +tryeq_sloppy $T++, 18446744073709551616/1, 18446744073709551616, + 'division of very large number by 1'; # Bluuurg +tryeq_sloppy $T++, 18446744073709551616/2, 9223372036854775808, + 'division of very large number by 2'; +tryeq_sloppy $T++, 18446744073709551616/4294967296, 4294967296, + 'division of two very large numbers'; +tryeq_sloppy $T++, 18446744073709551616/9223372036854775808, 2, + 'division of two very large numbers'; + +{ + # The peephole optimiser is wrong to think that it can substitute intops + # in place of regular ops, because i_multiply can overflow. + # Bug reported by "Sisyphus" <kalinabears@hdc.com.au> + my $n = 1127; + + my $float = ($n % 1000) * 167772160.0; + tryeq_sloppy $T++, $float, 21307064320, 'integer times floating point'; + + # On a 32 bit machine, if the i_multiply op is used, you will probably get + # -167772160. It is actually undefined behaviour, so anything may happen. + my $int = ($n % 1000) * 167772160; + tryeq $T++, $int, 21307064320, 'integer times integer'; + + my $float2 = ($n % 1000 + 0.0) * 167772160; + tryeq $T++, $float2, 21307064320, 'floating point times integer'; + + my $int2 = ($n % 1000 + 0) * 167772160; + tryeq $T++, $int2, 21307064320, 'integer plus zero times integer'; + + # zero, but in a way that ought to be able to defeat any future optimizer: + my $zero = $$ - $$; + my $int3 = ($n % 1000 + $zero) * 167772160; + tryeq $T++, $int3, 21307064320, 'defeat any future optimizer'; + + my $t = time; + my $t1000 = time() * 1000; + try $T++, abs($t1000 -1000 * $t) <= 2000, 'absolute value'; +} + +{ + # 64 bit variants + my $n = 1127; + + my $float = ($n % 1000) * 720575940379279360.0; + tryeq_sloppy $T++, $float, 9.15131444281685e+19, + '64 bit: integer times floating point'; + + my $int = ($n % 1000) * 720575940379279360; + tryeq_sloppy $T++, $int, 9.15131444281685e+19, + '64 bit: integer times integer'; + + my $float2 = ($n % 1000 + 0.0) * 720575940379279360; + tryeq_sloppy $T++, $float2, 9.15131444281685e+19, + '64 bit: floating point times integer'; + + my $int2 = ($n % 1000 + 0) * 720575940379279360; + tryeq_sloppy $T++, $int2, 9.15131444281685e+19, + '64 bit: integer plus zero times integer'; + + # zero, but in a way that ought to be able to defeat any future optimizer: + my $zero = $$ - $$; + my $int3 = ($n % 1000 + $zero) * 720575940379279360; + tryeq_sloppy $T++, $int3, 9.15131444281685e+19, + '64 bit: defeat any future optimizer'; +} + +# [perl #109542] $1 and "$1" should be treated the same way +"976562500000000" =~ /(\d+)/; +$a = ($1 * 1024); +$b = ("$1" * 1024); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" * something\n'; +$a = (1024 * $1); +$b = (1024 * "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something * \$1 vs "\$1"\n'; +$a = ($1 + 102400000000000); +$b = ("$1" + 102400000000000); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" + something\n'; +$a = (102400000000000 + $1); +$b = (102400000000000 + "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something + \$1 vs "\$1"\n'; +$a = ($1 - 10240000000000000); +$b = ("$1" - 10240000000000000); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" - something\n'; +$a = (10240000000000000 - $1); +$b = (10240000000000000 - "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something - \$1 vs "\$1"\n'; +"976562500" =~ /(\d+)/; +$a = ($1 ** 2); +$b = ("$1" ** 2); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" ** something\n'; +"32" =~ /(\d+)/; +$a = (3 ** $1); +$b = (3 ** "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something ** \$1 vs "\$1"\n'; +"97656250000000000" =~ /(\d+)/; +$a = ($1 / 10); +$b = ("$1" / 10); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" / something\n'; +"10" =~ /(\d+)/; +$a = (97656250000000000 / $1); +$b = (97656250000000000 / "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something / \$1 vs "\$1"\n'; +"97656250000000000" =~ /(\d+)/; +$a = ($1 <=> 97656250000000001); +$b = ("$1" <=> 97656250000000001); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" <=> something\n'; +$a = (97656250000000001 <=> $1); +$b = (97656250000000001 <=> "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something <=> \$1 vs "\$1"\n'; +"97656250000000001" =~ /(\d+)/; +$a = ($1 % 97656250000000002); +$b = ("$1" % 97656250000000002); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" % something\n'; +$a = (97656250000000000 % $1); +$b = (97656250000000000 % "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something % \$1 vs "\$1"\n'; + +my $vms_no_ieee; +if ($^O eq 'VMS') { + use vars '%Config'; + eval {require Config; import Config}; + $vms_no_ieee = 1 unless defined($Config{useieee}); +} + +if ($^O eq 'vos') { + print "not ok ", $T++, " # TODO VOS raises SIGFPE instead of producing infinity.\n"; +} +elsif ($vms_no_ieee) { + print $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n" +} +elsif ($^O eq 'ultrix') { + print "not ok ", $T++, " # TODO Ultrix enters deep nirvana instead of producing infinity.\n"; +} +else { + # The computation of $v should overflow and produce "infinity" + # on any system whose max exponent is less than 10**1506. + # The exact string used to represent infinity varies by OS, + # so we don't test for it; all we care is that we don't die. + # + # Perl considers it to be an error if SIGFPE is raised. + # Chances are the interpreter will die, since it doesn't set + # up a handler for SIGFPE. That's why this test is last; to + # minimize the number of test failures. --PG + + my $n = 5000; + my $v = 2; + while (--$n) + { + $v *= 2; + } + print "ok ", $T++, " - infinity\n"; +} + diff --git a/t/opbasic/cmp.t b/t/opbasic/cmp.t new file mode 100644 index 0000000000..0fbca5fc5f --- /dev/null +++ b/t/opbasic/cmp.t @@ -0,0 +1,318 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# 2s complement assumption. Won't break test, just makes the internals of +# the SVs less interesting if were not on 2s complement system. +my $uv_max = ~0; +my $uv_maxm1 = ~0 ^ 1; +my $uv_big = $uv_max; +$uv_big = ($uv_big - 20000) | 1; +my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); +$iv_max = $uv_max; # Do copy, *then* divide +$iv_max /= 2; +$iv_min = $iv_max; +{ + use integer; + $iv0 = 2 - 2; + $iv1 = 3 - 2; + $ivm1 = 2 - 3; + $iv_max -= 1; + $iv_min += 0; + $iv_big = $iv_max - 3; + $iv_small = $iv_min + 2; +} +my $uv_bigi = $iv_big; +$uv_bigi |= 0x0; + +my @array = qw(perl rules); + +my @raw, @upgraded, @utf8; +foreach ("\x{1F4A9}", chr(163), 'N') { + push @raw, $_; + my $temp = $_ . chr 256; + chop $temp; + push @upgraded, $temp; + my $utf8 = $_; + next if utf8::upgrade($utf8) == length $_; + utf8::encode($utf8); + push @utf8, $utf8; +} + +# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, + 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, + $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, + $iv_small, \$array[0], \$array[0], \$array[1], \$^X, @raw, @upgraded, + @utf8); + +$expect = 7 * ($#FOO+2) * ($#FOO+1) + 6 * @raw + 6 * @utf8; +print "1..$expect\n"; + +my $bad_NaN = 0; + +{ + # gcc's -ffast-math option may stop NaNs working correctly + use Config; + my $ccflags = $Config{ccflags} // ''; + $bad_NaN = 1 if $ccflags =~ /-ffast-math\b/; +} + +sub nok ($$$$$$$$) { + my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_; + $result = defined $result ? "'$result'" : 'undef'; + if ($bad_NaN && ($left eq 'NaN' || $right eq 'NaN')) { + print "ok $test # skipping failed NaN test under -ffast-math\n"; + } + else { + print "not ok $test # ($left $threeway $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n"; + } +} + +my $ok = 0; +for my $i (0..$#FOO) { + for my $j ($i..$#FOO) { + $ok++; + # Comparison routines may convert these internally, which would change + # what is used to determine the comparison on later runs. Hence copy + my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, + $i11, $i12, $i13, $i14, $i15, $i16, $i17) = + ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); + my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, + $j11, $j12, $j13, $j14, $j15, $j16, $j17) = + ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); + my $cmp = $i1 <=> $j1; + if (!defined($cmp) ? !($i2 < $j2) + : ($cmp == -1 && $i2 < $j2 || + $cmp == 0 && !($i2 < $j2) || + $cmp == 1 && !($i2 < $j2))) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<'); + } + $ok++; + if (!defined($cmp) ? !($i4 == $j4) + : ($cmp == -1 && !($i4 == $j4) || + $cmp == 0 && $i4 == $j4 || + $cmp == 1 && !($i4 == $j4))) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '=='); + } + $ok++; + if (!defined($cmp) ? !($i5 > $j5) + : ($cmp == -1 && !($i5 > $j5) || + $cmp == 0 && !($i5 > $j5) || + $cmp == 1 && ($i5 > $j5))) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>'); + } + $ok++; + if (!defined($cmp) ? !($i6 >= $j6) + : ($cmp == -1 && !($i6 >= $j6) || + $cmp == 0 && $i6 >= $j6 || + $cmp == 1 && $i6 >= $j6)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>='); + } + $ok++; + # OK, so the docs are wrong it seems. NaN != NaN + if (!defined($cmp) ? ($i7 != $j7) + : ($cmp == -1 && $i7 != $j7 || + $cmp == 0 && !($i7 != $j7) || + $cmp == 1 && $i7 != $j7)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!='); + } + $ok++; + if (!defined($cmp) ? !($i8 <= $j8) + : ($cmp == -1 && $i8 <= $j8 || + $cmp == 0 && $i8 <= $j8 || + $cmp == 1 && !($i8 <= $j8))) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<='); + } + $ok++; + my $pmc = $j16 <=> $i16; # cmp it in reverse + # Should give -ve of other answer, or undef for NaNs + # a + -a should be zero. not zero is truth. which avoids using == + if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed'); + } + + + # String comparisons + $ok++; + $cmp = $i9 cmp $j9; + if ($cmp == -1 && $i10 lt $j10 || + $cmp == 0 && !($i10 lt $j10) || + $cmp == 1 && !($i10 lt $j10)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt'); + } + $ok++; + if ($cmp == -1 && !($i11 eq $j11) || + $cmp == 0 && ($i11 eq $j11) || + $cmp == 1 && !($i11 eq $j11)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq'); + } + $ok++; + if ($cmp == -1 && !($i12 gt $j12) || + $cmp == 0 && !($i12 gt $j12) || + $cmp == 1 && ($i12 gt $j12)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt'); + } + $ok++; + if ($cmp == -1 && $i13 le $j13 || + $cmp == 0 && ($i13 le $j13) || + $cmp == 1 && !($i13 le $j13)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le'); + } + $ok++; + if ($cmp == -1 && ($i14 ne $j14) || + $cmp == 0 && !($i14 ne $j14) || + $cmp == 1 && ($i14 ne $j14)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne'); + } + $ok++; + if ($cmp == -1 && !($i15 ge $j15) || + $cmp == 0 && ($i15 ge $j15) || + $cmp == 1 && ($i15 ge $j15)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge'); + } + $ok++; + $pmc = $j17 cmp $i17; # cmp it in reverse + # Should give -ve of other answer + # a + -a should be zero. not zero is truth. which avoids using == + if (!($cmp + $pmc)) + { + print "ok $ok\n"; + } + else { + nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'cmp transposed'); + } + } +} + +# We know the answers for these. We can rely on the consistency checks above +# to test the other string comparisons. + +while (my ($i, $v) = each @raw) { + # Copy, to avoid any inadvertent conversion + my ($raw, $cooked, $not); + $raw = $v; + $cooked = $upgraded[$i]; + $not = $raw eq $cooked ? '' : 'not '; + printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $v; + $cooked = $upgraded[$i]; + $not = $raw ne $cooked ? 'not ' : ''; + printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $v; + $cooked = $upgraded[$i]; + $not = (($raw cmp $cooked) == 0) ? '' : 'not '; + printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; + + # And now, transposed. + $raw = $v; + $cooked = $upgraded[$i]; + $not = $cooked eq $raw ? '' : 'not '; + printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $v; + $cooked = $upgraded[$i]; + $not = $cooked ne $raw ? 'not ' : ''; + printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $v; + $cooked = $upgraded[$i]; + $not = (($cooked cmp $raw) == 0) ? '' : 'not '; + printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; +} + +while (my ($i, $v) = each @utf8) { + # Copy, to avoid any inadvertent conversion + my ($raw, $cooked, $not); + $raw = $raw[$i]; + $cooked = $v; + $not = $raw eq $cooked ? 'not ' : ''; + printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $raw[$i]; + $cooked = $v; + $not = $raw ne $cooked ? '' : 'not '; + printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $raw[$i]; + $cooked = $v; + $not = (($raw cmp $cooked) == 0) ? 'not ' : ''; + printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; + + # And now, transposed. + $raw = $raw[$i]; + $cooked = $v; + $not = $cooked eq $raw ? 'not ' : ''; + printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $raw[$i]; + $cooked = $v; + $not = $cooked ne $raw? '' : 'not '; + printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; + + $raw = $raw[$i]; + $cooked = $v; + $not = (($cooked cmp $raw) == 0) ? 'not ' : ''; + printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; +} diff --git a/t/opbasic/concat.t b/t/opbasic/concat.t new file mode 100644 index 0000000000..e2e2c667dc --- /dev/null +++ b/t/opbasic/concat.t @@ -0,0 +1,161 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# This ok() function is specially written to avoid any concatenation. +my $test = 1; +sub ok { + my($ok, $name) = @_; + + printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; + + printf "# Failed test at line %d\n", (caller)[2] unless $ok; + + $test++; + return $ok; +} + +print "1..30\n"; + +($a, $b, $c) = qw(foo bar); + +ok("$a" eq "foo", "verifying assign"); +ok("$a$b" eq "foobar", "basic concatenation"); +ok("$c$a$c" eq "foo", "concatenate undef, fore and aft"); + +# Okay, so that wasn't very challenging. Let's go Unicode. + +{ + # bug id 20000819.004 + + $_ = $dx = "\x{10f2}"; + s/($dx)/$dx$1/; + { + ok($_ eq "$dx$dx","bug id 20000819.004, back"); + } + + $_ = $dx = "\x{10f2}"; + s/($dx)/$1$dx/; + { + ok($_ eq "$dx$dx","bug id 20000819.004, front"); + } + + $dx = "\x{10f2}"; + $_ = "\x{10f2}\x{10f2}"; + s/($dx)($dx)/$1$2/; + { + ok($_ eq "$dx$dx","bug id 20000819.004, front and back"); + } +} + +{ + # bug id 20000901.092 + # test that undef left and right of utf8 results in a valid string + + my $a; + $a .= "\x{1ff}"; + ok($a eq "\x{1ff}", "bug id 20000901.092, undef left"); + $a .= undef; + ok($a eq "\x{1ff}", "bug id 20000901.092, undef right"); +} + +{ + # ID 20001020.006 + + "x" =~ /(.)/; # unset $2 + + # Without the fix this 5.7.0 would croak: + # Modification of a read-only value attempted at ... + eval {"$2\x{1234}"}; + ok(!$@, "bug id 20001020.006, left"); + + # For symmetry with the above. + eval {"\x{1234}$2"}; + ok(!$@, "bug id 20001020.006, right"); + + *pi = \undef; + # This bug existed earlier than the $2 bug, but is fixed with the same + # patch. Without the fix this 5.7.0 would also croak: + # Modification of a read-only value attempted at ... + eval{"$pi\x{1234}"}; + ok(!$@, "bug id 20001020.006, constant left"); + + # For symmetry with the above. + eval{"\x{1234}$pi"}; + ok(!$@, "bug id 20001020.006, constant right"); +} + +sub beq { use bytes; $_[0] eq $_[1]; } + +{ + # concat should not upgrade its arguments. + my($l, $r, $c); + + ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}"); + ok(beq($l.$r, $c), "concat utf8 and byte"); + ok(beq($l, "\x{101}"), "right not changed after concat u+b"); + ok(beq($r, "\x{fe}"), "left not changed after concat u+b"); + + ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}"); + ok(beq($l.$r, $c), "concat byte and utf8"); + ok(beq($l, "\x{fe}"), "right not changed after concat b+u"); + ok(beq($r, "\x{101}"), "left not changed after concat b+u"); +} + +{ + my $a; ($a .= 5) . 6; + ok($a == 5, '($a .= 5) . 6 - present since 5.000'); +} + +{ + # [perl #24508] optree construction bug + sub strfoo { "x" } + my ($x, $y); + $y = ($x = '' . strfoo()) . "y"; + ok( "$x,$y" eq "x,xy", 'figures out correct target' ); +} + +{ + # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation + + my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X + my $u = "\x{100}"; + my $b = pack 'a*', "\x{100}"; + my $pu = "\xB6\x{100}"; + my $up = "\x{100}\xB6"; + my $x1 = $p; + my $y1 = $u; + + use bytes; + ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes"); + ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes"); + ok(!beq($p.$u, $pu), "perl #26905, left ne unicode"); + ok(!beq($u.$p, $up), "perl #26905, right ne unicode"); + + $x1 .= $u; + $x2 = $p . $u; + $y1 .= $p; + $y2 = $u . $p; + + no bytes; + ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes"); + ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes"); + ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars"); + ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars"); +} + +{ + # Concatenation needs to preserve UTF8ness of left oper. + my $x = eval"qr/\x{fff}/"; + ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" ); +} + +{ + my $x; + $x = "a" . "b"; + $x .= "-append-"; + ok($x eq "ab-append-", "Appending to something initialized using constant folding"); +} diff --git a/t/opbasic/magic_phase.t b/t/opbasic/magic_phase.t new file mode 100644 index 0000000000..07b4c19f7d --- /dev/null +++ b/t/opbasic/magic_phase.t @@ -0,0 +1,48 @@ +#!./perl + +use strict; +use warnings; + +# Test ${^GLOBAL_PHASE} +# +# Test::More, test.pl, etc assert plans in END, which happens before global +# destruction, so we don't want to use those here. + +BEGIN { print "1..7\n" } + +sub ok ($$) { + print "not " if !$_[0]; + print "ok"; + print " - $_[1]" if defined $_[1]; + print "\n"; +} + +BEGIN { + ok ${^GLOBAL_PHASE} eq 'START', 'START'; +} + +CHECK { + ok ${^GLOBAL_PHASE} eq 'CHECK', 'CHECK'; +} + +INIT { + ok ${^GLOBAL_PHASE} eq 'INIT', 'INIT'; +} + +ok ${^GLOBAL_PHASE} eq 'RUN', 'RUN'; + +sub Moo::DESTROY { + ok ${^GLOBAL_PHASE} eq 'RUN', 'DESTROY is run-time too, usually'; +} + +my $tiger = bless {}, Moo::; + +sub Kooh::DESTROY { + ok ${^GLOBAL_PHASE} eq 'DESTRUCT', 'DESTRUCT'; +} + +our $affe = bless {}, Kooh::; + +END { + ok ${^GLOBAL_PHASE} eq 'END', 'END'; +} diff --git a/t/opbasic/qq.t b/t/opbasic/qq.t new file mode 100644 index 0000000000..3d1bfacb68 --- /dev/null +++ b/t/opbasic/qq.t @@ -0,0 +1,73 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print q(1..28 +); + +# This is() function is written to avoid "" +my $test = 1; +sub is { + my($left, $right) = @_; + + if ($left eq $right) { + printf 'ok %d +', $test++; + return 1; + } + foreach ($left, $right) { + # Comment out these regexps to map non-printables to ord if the perl under + # test is so broken that it's not helping + s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge; + $_ = sprintf q('%s'), $_; + s/^''\.//; + s/\.''$//; + } + printf q(not ok %d - got %s expected %s +), $test++, $left, $right; + + printf q(# Failed test at line %d +), (caller)[2]; + + return 0; +} + +is ("\x53", chr 83); +is ("\x4EE", chr (78) . 'E'); +is ("\x4i", chr (4) . 'i'); # This will warn +is ("\xh", chr (0) . 'h'); # This will warn +is ("\xx", chr (0) . 'x'); # This will warn +is ("\xx9", chr (0) . 'x9'); # This will warn. \x9 is tab in EBCDIC too? +is ("\x9_E", chr (9) . '_E'); # This will warn + +is ("\x{4E}", chr 78); +is ("\x{6_9}", chr 105); +is ("\x{_6_3}", chr 99); +is ("\x{_6B}", chr 107); + +is ("\x{9__0}", chr 9); # multiple underscores not allowed. +is ("\x{77_}", chr 119); # trailing underscore warns. +is ("\x{6FQ}z", chr (111) . 'z'); + +is ("\x{0x4E}", chr 0); +is ("\x{x4E}", chr 0); + +is ("\x{0065}", chr 101); +is ("\x{000000000000000000000000000000000000000000000000000000000000000072}", + chr 114); +is ("\x{0_06_5}", chr 101); +is ("\x{1234}", chr 4660); +is ("\x{10FFFD}", chr 1114109); +is ("\400", chr 0x100); +is ("\600", chr 0x180); +is ("\777", chr 0x1FF); +is ("a\o{120}b", "a" . chr(0x50) . "b"); +is ("a\o{400}b", "a" . chr(0x100) . "b"); +is ("a\o{1000}b", "a" . chr(0x200) . "b"); + +# This caused a memory fault +no warnings "utf8"; +is ("abc", eval qq[qq\x{8000_0000}abc\x{8000_0000}]) |