perl 4.0.00: (no release announcement available)perl-4.0.00

So far, 4.0 is still a beta test version.  For the last production
version, look in pub/perl.3.0/kits@44.

7 files changed, 302 insertions, 0 deletions

diff --git a/t/comp/cmdopt.t b/t/comp/cmdopt.t
new file mode 100644
index 0000000000..e6e2abff75
--- /dev/null
+++ b/t/comp/cmdopt.t
@@ -0,0 +1,83 @@
+#!./perl
+
+# $Header: cmdopt.t,v 4.0 91/03/20 01:49:58 lwall Locked $
+
+print "1..40\n";
+
+# test the optimization of constants
+
+if (1) { print "ok 1\n";} else { print "not ok 1\n";}
+unless (0) { print "ok 2\n";} else { print "not ok 2\n";}
+
+if (0) { print "not ok 3\n";} else { print "ok 3\n";}
+unless (1) { print "not ok 4\n";} else { print "ok 4\n";}
+
+unless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
+if (!0) { print "ok 6\n";} else { print "not ok 6\n";}
+
+unless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
+if (!1) { print "not ok 8\n";} else { print "ok 8\n";}
+
+$x = 1;
+if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
+if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
+$x = '';
+if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
+if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
+
+$x = 1;
+if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
+if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
+$x = '';
+if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
+if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
+
+
+# test the optimization of registers
+
+$x = 1;
+if ($x) { print "ok 17\n";} else { print "not ok 17\n";}
+unless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
+
+$x = '';
+if ($x) { print "not ok 19\n";} else { print "ok 19\n";}
+unless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
+
+# test optimization of string operations
+
+$a = 'a';
+if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
+if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
+
+if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
+if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
+# test interaction of logicals and other operations
+
+$a = 'a';
+$x = 1;
+if ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
+if ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
+$x = '';
+if ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
+if ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
+
+$x = 1;
+if ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
+if ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
+$x = '';
+if ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
+if ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
+
+$x = 1;
+if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
+if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
+$x = '';
+if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
+    if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
+
+$x = 1;
+if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
+if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
+$x = '';
+if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
+if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
diff --git a/t/comp/cpp.t b/t/comp/cpp.t
new file mode 100644
index 0000000000..0e2b6fa681
--- /dev/null
+++ b/t/comp/cpp.t
@@ -0,0 +1,39 @@
+#!./perl -P
+
+# $Header: cpp.t,v 4.0 91/03/20 01:50:05 lwall Locked $
+
+print "1..3\n";
+
+#this is a comment
+#define MESS "ok 1\n"
+print MESS;
+
+#If you capitalize, it's a comment.
+#ifdef MESS
+	print "ok 2\n";
+#else
+	print "not ok 2\n";
+#endif
+
+open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file.";
+
+($prog = <<'END') =~ s/X//g;
+X$ok = "not ok 3\n";
+X#include "Comp.cpp.inc"
+X#ifdef OK
+X$ok = OK;
+X#endif
+Xprint $ok;
+END
+print TRY $prog;
+close TRY;
+
+open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file.");
+print TRY '#define OK "ok 3\n"' . "\n";
+close TRY;
+
+$pwd=`pwd`;
+$pwd =~ s/\n//;
+$x = `./perl -P Comp.cpp.tmp`;
+print $x;
+unlink "Comp.cpp.tmp", "Comp.cpp.inc";
diff --git a/t/comp/decl.t b/t/comp/decl.t
new file mode 100644
index 0000000000..af8bf05ba8
--- /dev/null
+++ b/t/comp/decl.t
@@ -0,0 +1,49 @@
+#!./perl
+
+# $Header: decl.t,v 4.0 91/03/20 01:50:09 lwall Locked $
+
+# check to see if subroutine declarations work everwhere
+
+sub one {
+    print "ok 1\n";
+}
+format one =
+ok 5
+.
+
+print "1..7\n";
+
+do one();
+do two();
+
+sub two {
+    print "ok 2\n";
+}
+format two =
+@<<<
+$foo
+.
+
+if ($x eq $x) {
+    sub three {
+	print "ok 3\n";
+    }
+    do three();
+}
+
+do four();
+$~ = 'one';
+write;
+$~ = 'two';
+$foo = "ok 6";
+write;
+$~ = 'three';
+write;
+
+format three =
+ok 7
+.
+
+sub four {
+    print "ok 4\n";
+}
diff --git a/t/comp/multiline.t b/t/comp/multiline.t
new file mode 100644
index 0000000000..55650813f4
--- /dev/null
+++ b/t/comp/multiline.t
@@ -0,0 +1,40 @@
+#!./perl
+
+# $Header: multiline.t,v 4.0 91/03/20 01:50:15 lwall Locked $
+
+print "1..5\n";
+
+open(try,'>Comp.try') || (die "Can't open temp file.");
+
+$x = 'now is the time
+for all good men
+to come to.
+';
+
+$y = 'now is the time' . "\n" .
+'for all good men' . "\n" .
+'to come to.' . "\n";
+
+if ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";}
+
+print try $x;
+close try;
+
+open(try,'Comp.try') || (die "Can't reopen temp file.");
+$count = 0;
+$z = '';
+while (<try>) {
+    $z .= $_;
+    $count = $count + 1;
+}
+
+if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$_ = `cat Comp.try`;
+
+if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
+`/bin/rm -f Comp.try`;
+
+if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";}
diff --git a/t/comp/package.t b/t/comp/package.t
new file mode 100644
index 0000000000..5237011a62
--- /dev/null
+++ b/t/comp/package.t
@@ -0,0 +1,33 @@
+#!./perl
+
+print "1..7\n";
+
+$blurfl = 123;
+$foo = 3;
+
+package XYZ;
+
+$bar = 4;
+
+{
+    package ABC;
+    $blurfl = 5;
+    $main'a = $'b;
+}
+
+$ABC'dyick = 6;
+
+$xyz = 2;
+
+$main = join(':', sort(keys _main));
+$XYZ = join(':', sort(keys _XYZ));
+$ABC = join(':', sort(keys _ABC));
+
+print $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n";
+print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2\n";
+print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
+package ABC;
+print $blurfl == 5 ? "ok 4\n" : "not ok 4\n";
+eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";';
+eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";';
+print $blurfl == 5 ? "ok 7\n" : "not ok 7\n";
diff --git a/t/comp/script.t b/t/comp/script.t
new file mode 100644
index 0000000000..8e882933ce
--- /dev/null
+++ b/t/comp/script.t
@@ -0,0 +1,23 @@
+#!./perl
+
+# $Header: script.t,v 4.0 91/03/20 01:50:26 lwall Locked $
+
+print "1..3\n";
+
+$x = `./perl -e 'print "ok\n";'`;
+
+if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+open(try,">Comp.script") || (die "Can't open temp file.");
+print try 'print "ok\n";'; print try "\n";
+close try;
+
+$x = `./perl Comp.script`;
+
+if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = `./perl <Comp.script`;
+
+if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";}
+
+`/bin/rm -f Comp.script`;
diff --git a/t/comp/term.t b/t/comp/term.t
new file mode 100644
index 0000000000..1012f949ba
--- /dev/null
+++ b/t/comp/term.t
@@ -0,0 +1,35 @@
+#!./perl
+
+# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
+
+# tests that aren't important enough for base.term
+
+print "1..14\n";
+
+$x = "\\n";
+print "#1\t:$x: eq " . ':\n:' . "\n";
+if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$x = "#2\t:$x: eq :\\n:\n";
+print $x;
+unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$one = 'a';
+
+if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
+if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
+if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
+if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
+if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
+if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
+
+if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = (1,2,3);
+if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
+if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
+$" = '::';
+if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}