summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/t/comp
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/t/comp')
-rwxr-xr-xcontrib/perl5/t/comp/cmdopt.t90
-rwxr-xr-xcontrib/perl5/t/comp/colon.t138
-rwxr-xr-xcontrib/perl5/t/comp/cpp.aux39
-rwxr-xr-xcontrib/perl5/t/comp/cpp.t18
-rwxr-xr-xcontrib/perl5/t/comp/decl.t49
-rwxr-xr-xcontrib/perl5/t/comp/multiline.t46
-rwxr-xr-xcontrib/perl5/t/comp/package.t39
-rwxr-xr-xcontrib/perl5/t/comp/proto.t415
-rwxr-xr-xcontrib/perl5/t/comp/redef.t80
-rwxr-xr-xcontrib/perl5/t/comp/require.t50
-rwxr-xr-xcontrib/perl5/t/comp/script.t27
-rwxr-xr-xcontrib/perl5/t/comp/term.t70
-rwxr-xr-xcontrib/perl5/t/comp/use.t101
13 files changed, 1162 insertions, 0 deletions
diff --git a/contrib/perl5/t/comp/cmdopt.t b/contrib/perl5/t/comp/cmdopt.t
new file mode 100755
index 0000000..3f701a4
--- /dev/null
+++ b/contrib/perl5/t/comp/cmdopt.t
@@ -0,0 +1,90 @@
+#!./perl
+
+# $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $
+
+print "1..44\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 variables
+
+$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' and $x) { print "ok 25\n";} else { print "not ok 25\n";}
+if ($a ne 'a' and $x) { print "not ok 26\n";} else { print "ok 26\n";}
+$x = '';
+if ($a eq 'a' and $x) { print "not ok 27\n";} else { print "ok 27\n";}
+if ($a ne 'a' and $x) { print "not ok 28\n";} else { print "ok 28\n";}
+
+$x = 1;
+if ($a eq 'a' or $x) { print "ok 29\n";} else { print "not ok 29\n";}
+if ($a ne 'a' or $x) { print "ok 30\n";} else { print "not ok 30\n";}
+$x = '';
+if ($a eq 'a' or $x) { print "ok 31\n";} else { print "not ok 31\n";}
+if ($a ne 'a' or $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";}
+
+$x = 1;
+if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";}
+if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";}
+$x = '';
+if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";}
+if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";}
diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t
new file mode 100755
index 0000000..d2c64fe
--- /dev/null
+++ b/contrib/perl5/t/comp/colon.t
@@ -0,0 +1,138 @@
+#!./perl
+
+#
+# Ensure that syntax using colons (:) is parsed correctly.
+# The tests are done on the following tokens (by default):
+# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm
+# -- Robin Barker <rmb@cise.npl.co.uk>
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+$_ = ''; # to avoid undef warning on m// etc.
+
+sub ok {
+ my($test,$ok) = @_;
+ print "not " unless $ok;
+ print "ok $test\n";
+}
+
+$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings
+
+print "1..25\n";
+
+ok 1, (eval "package ABC; sub zyx {1}; 1;" and
+ eval "ABC::zyx" and
+ not eval "ABC:: eq ABC||" and
+ not eval "ABC::: >= 0");
+
+ok 2, (eval "package LABEL; sub zyx {1}; 1;" and
+ eval "LABEL::zyx" and
+ not eval "LABEL:: eq LABEL||" and
+ not eval "LABEL::: >= 0");
+
+ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and
+ eval "XYZZY::zyx" and
+ not eval "XYZZY:: eq XYZZY||" and
+ not eval "XYZZY::: >= 0");
+
+ok 4, (eval "package m; sub zyx {1}; 1;" and
+ not eval "m::zyx" and
+ eval "m:: eq m||" and
+ not eval "m::: >= 0");
+
+ok 5, (eval "package q; sub zyx {1}; 1;" and
+ not eval "q::zyx" and
+ eval "q:: eq q||" and
+ not eval "q::: >= 0");
+
+ok 6, (eval "package qq; sub zyx {1}; 1;" and
+ not eval "qq::zyx" and
+ eval "qq:: eq qq||" and
+ not eval "qq::: >= 0");
+
+ok 7, (eval "package qw; sub zyx {1}; 1;" and
+ not eval "qw::zyx" and
+ eval "qw:: eq qw||" and
+ not eval "qw::: >= 0");
+
+ok 8, (eval "package qx; sub zyx {1}; 1;" and
+ not eval "qx::zyx" and
+ eval "qx:: eq qx||" and
+ not eval "qx::: >= 0");
+
+ok 9, (eval "package s; sub zyx {1}; 1;" and
+ not eval "s::zyx" and
+ not eval "s:: eq s||" and
+ eval "s::: >= 0");
+
+ok 10, (eval "package tr; sub zyx {1}; 1;" and
+ not eval "tr::zyx" and
+ not eval "tr:: eq tr||" and
+ eval "tr::: >= 0");
+
+ok 11, (eval "package y; sub zyx {1}; 1;" and
+ not eval "y::zyx" and
+ not eval "y:: eq y||" and
+ eval "y::: >= 0");
+
+ok 12, (eval "ABC:1" and
+ not eval "ABC:echo: eq ABC|echo|" and
+ not eval "ABC:echo:ohce: >= 0");
+
+ok 13, (eval "LABEL:1" and
+ not eval "LABEL:echo: eq LABEL|echo|" and
+ not eval "LABEL:echo:ohce: >= 0");
+
+ok 14, (eval "XYZZY:1" and
+ not eval "XYZZY:echo: eq XYZZY|echo|" and
+ not eval "XYZZY:echo:ohce: >= 0");
+
+ok 15, (not eval "m:1" and
+ eval "m:echo: eq m|echo|" and
+ not eval "m:echo:ohce: >= 0");
+
+ok 16, (not eval "q:1" and
+ eval "q:echo: eq q|echo|" and
+ not eval "q:echo:ohce: >= 0");
+
+ok 17, (not eval "qq:1" and
+ eval "qq:echo: eq qq|echo|" and
+ not eval "qq:echo:ohce: >= 0");
+
+ok 18, (not eval "qw:1" and
+ eval "qw:echo: eq qw|echo|" and
+ not eval "qw:echo:ohce: >= 0");
+
+ok 19, (not eval "qx:1" and
+ eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn
+ not eval "qx:echo:ohce: >= 0");
+
+ok 20, (not eval "s:1" and
+ not eval "s:echo: eq s|echo|" and
+ eval "s:echo:ohce: >= 0");
+
+ok 21, (not eval "tr:1" and
+ not eval "tr:echo: eq tr|echo|" and
+ eval "tr:echo:ohce: >= 0");
+
+ok 22, (not eval "y:1" and
+ not eval "y:echo: eq y|echo|" and
+ eval "y:echo:ohce: >= 0");
+
+ok 23, (eval "AUTOLOAD:1" and
+ not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and
+ not eval "AUTOLOAD:echo:ohce: >= 0");
+
+ok 24, (eval "and:1" and
+ not eval "and:echo: eq and|echo|" and
+ not eval "and:echo:ohce: >= 0");
+
+ok 25, (eval "alarm:1" and
+ not eval "alarm:echo: eq alarm|echo|" and
+ not eval "alarm:echo:ohce: >= 0");
diff --git a/contrib/perl5/t/comp/cpp.aux b/contrib/perl5/t/comp/cpp.aux
new file mode 100755
index 0000000..bb93d21
--- /dev/null
+++ b/contrib/perl5/t/comp/cpp.aux
@@ -0,0 +1,39 @@
+#!./perl -P
+
+# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $
+
+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/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t
new file mode 100755
index 0000000..86e7359
--- /dev/null
+++ b/contrib/perl5/t/comp/cpp.t
@@ -0,0 +1,18 @@
+#!./perl
+
+# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+if ( $^O eq 'MSWin32' or
+ ($Config{'cppstdin'} =~ /\bcppstdin\b/) and
+ ( ! -x $Config{'binexp'} . "/cppstdin") ) {
+ print "1..0\n";
+ exit; # Cannot test till after install, alas.
+}
+
+system "./perl -P comp/cpp.aux"
diff --git a/contrib/perl5/t/comp/decl.t b/contrib/perl5/t/comp/decl.t
new file mode 100755
index 0000000..32b8509
--- /dev/null
+++ b/contrib/perl5/t/comp/decl.t
@@ -0,0 +1,49 @@
+#!./perl
+
+# $RCSfile: decl.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:19 $
+
+# 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/contrib/perl5/t/comp/multiline.t b/contrib/perl5/t/comp/multiline.t
new file mode 100755
index 0000000..ed418b8
--- /dev/null
+++ b/contrib/perl5/t/comp/multiline.t
@@ -0,0 +1,46 @@
+#!./perl
+
+# $RCSfile: multiline.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:20 $
+
+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\n\n!\n\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 == 7) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$_ = ($^O eq 'MSWin32') ? `type Comp.try` : `cat Comp.try`;
+
+if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+close(try) || (die "Can't close temp file.");
+unlink 'Comp.try' || `/bin/rm -f Comp.try`;
+
+if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";}
diff --git a/contrib/perl5/t/comp/package.t b/contrib/perl5/t/comp/package.t
new file mode 100755
index 0000000..d7d19ae
--- /dev/null
+++ b/contrib/perl5/t/comp/package.t
@@ -0,0 +1,39 @@
+#!./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::));
+
+if ('a' lt 'A') {
+ print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+} else {
+ print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+}
+print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\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/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t
new file mode 100755
index 0000000..6a59107
--- /dev/null
+++ b/contrib/perl5/t/comp/proto.t
@@ -0,0 +1,415 @@
+#!./perl
+#
+# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+#
+# So far there are tests for the following prototypes.
+# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@)
+#
+# It is impossible to test every prototype that can be specified, but
+# we should test as many as we can.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+print "1..82\n";
+
+my $i = 1;
+
+sub testing (&$) {
+ my $p = prototype(shift);
+ my $c = shift;
+ my $what = defined $c ? '(' . $p . ')' : 'no prototype';
+ print '#' x 25,"\n";
+ print '# Testing ',$what,"\n";
+ print '#' x 25,"\n";
+ print "not "
+ if((defined($p) && defined($c) && $p ne $c)
+ || (defined($p) != defined($c)));
+ printf "ok %d\n",$i++;
+}
+
+@_ = qw(a b c d);
+my @array;
+my %hash;
+
+##
+##
+##
+
+testing \&no_proto, undef;
+
+sub no_proto {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 0 == no_proto();
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == no_proto(5);
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &no_proto;
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == no_proto +6;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == no_proto(@_);
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+
+testing \&no_args, '';
+
+sub no_args () {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 0 == no_args();
+printf "ok %d\n",$i++;
+
+print "not " unless 0 == no_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == no_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &no_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &no_args(1,2);
+printf "ok %d\n",$i++;
+
+eval "no_args(1)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&one_args, '$';
+
+sub one_args ($) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == one_args(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == one_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &one_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &one_args(1,2);
+printf "ok %d\n",$i++;
+
+eval "one_args(1,2)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+eval "one_args()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub one_a_args ($) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+one_a_args(@_);
+
+##
+##
+##
+
+testing \&over_one_args, '$@';
+
+sub over_one_args ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == over_one_args(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == over_one_args(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == over_one_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &over_one_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &over_one_args(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &over_one_args(1,@_);
+printf "ok %d\n",$i++;
+
+eval "over_one_args()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub over_one_a_args ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+over_one_a_args(@_);
+over_one_a_args(@_,1);
+over_one_a_args(@_,1,2);
+over_one_a_args(@_,@_);
+
+##
+##
+##
+
+testing \&scalar_and_hash, '$%';
+
+sub scalar_and_hash ($%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == scalar_and_hash(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 3 == scalar_and_hash(1,2,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == scalar_and_hash +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &scalar_and_hash;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &scalar_and_hash(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &scalar_and_hash(1,@_);
+printf "ok %d\n",$i++;
+
+eval "scalar_and_hash()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub scalar_and_hash_a ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+scalar_and_hash_a(@_);
+scalar_and_hash_a(@_,1);
+scalar_and_hash_a(@_,1,2);
+scalar_and_hash_a(@_,@_);
+
+##
+##
+##
+
+testing \&one_or_two, '$;$';
+
+sub one_or_two ($;$) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == one_or_two(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == one_or_two(1,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == one_or_two +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &one_or_two;
+printf "ok %d\n",$i++;
+
+print "not " unless 3 == &one_or_two(1,2,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &one_or_two(1,@_);
+printf "ok %d\n",$i++;
+
+eval "one_or_two()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+eval "one_or_two(1,2,3)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub one_or_two_a ($;$) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+one_or_two_a(@_);
+one_or_two_a(@_,1);
+one_or_two_a(@_,@_);
+
+##
+##
+##
+
+testing \&a_sub, '&';
+
+sub a_sub (&) {
+ print "# \@_ = (",join(",",@_),")\n";
+ &{$_[0]};
+}
+
+sub tmp_sub_1 { printf "ok %d\n",$i++ }
+
+a_sub { printf "ok %d\n",$i++ };
+a_sub \&tmp_sub_1;
+
+@array = ( \&tmp_sub_1 );
+eval 'a_sub @array';
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&sub_aref, '&\@';
+
+sub sub_aref (&\@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ my($sub,$array) = @_;
+ print "not " unless @_ == 2 && @{$array} == 4;
+ print map { &{$sub}($_) } @{$array}
+}
+
+@array = (qw(O K)," ", $i++);
+sub_aref { lc shift } @array;
+print "\n";
+
+##
+##
+##
+
+testing \&sub_array, '&@';
+
+sub sub_array (&@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 5;
+ my $sub = shift;
+ print map { &{$sub}($_) } @_
+}
+
+@array = (qw(O K)," ", $i++);
+sub_array { lc shift } @array;
+print "\n";
+
+##
+##
+##
+
+testing \&a_hash, '%';
+
+sub a_hash (%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_);
+}
+
+print "not " unless 1 == a_hash 'a';
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == a_hash 'a','b';
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&a_hash_ref, '\%';
+
+sub a_hash_ref (\%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless ref($_[0]) && $_[0]->{'a'};
+ printf "ok %d\n",$i++;
+ $_[0]->{'b'} = 2;
+}
+
+%hash = ( a => 1);
+a_hash_ref %hash;
+print "not " unless $hash{'b'} == 2;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&array_ref_plus, '\@@';
+
+sub array_ref_plus (\@@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
+ printf "ok %d\n",$i++;
+ @{$_[0]} = (qw(ok)," ",$i++,"\n");
+}
+
+@array = ('a');
+{ my @more = ('x');
+ array_ref_plus @array, @more; }
+print "not " unless @array == 4;
+print @array;
+
+my $p;
+print "not " if defined prototype('CORE::print');
+print "ok ", $i++, "\n";
+
+print "not " if defined prototype('CORE::system');
+print "ok ", $i++, "\n";
+
+print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
+print "ok ", $i++, "\n";
+
+print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
+ if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/;
+print "ok ", $i++, "\n";
+
+# correctly note too-short parameter lists that don't end with '$',
+# a possible regression.
+
+sub foo1 ($\@);
+eval q{ foo1 "s" };
+print "not " unless $@ =~ /^Not enough/;
+print "ok ", $i++, "\n";
+
+sub foo2 ($\%);
+eval q{ foo2 "s" };
+print "not " unless $@ =~ /^Not enough/;
+print "ok ", $i++, "\n";
+
+sub X::foo3;
+*X::foo3 = sub {'ok'};
+print "# $@not " unless eval {X->foo3} eq 'ok';
+print "ok ", $i++, "\n";
+
+sub X::foo4 ($);
+*X::foo4 = sub ($) {'ok'};
+print "not " unless X->foo4 eq 'ok';
+print "ok ", $i++, "\n";
diff --git a/contrib/perl5/t/comp/redef.t b/contrib/perl5/t/comp/redef.t
new file mode 100755
index 0000000..07e978b
--- /dev/null
+++ b/contrib/perl5/t/comp/redef.t
@@ -0,0 +1,80 @@
+#!./perl -w
+#
+# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+
+BEGIN {
+ $warn = "";
+ $SIG{__WARN__} = sub { $warn .= join("",@_) }
+}
+
+sub ok ($$) {
+ print $_[1] ? "ok " : "not ok ", $_[0], "\n";
+}
+
+print "1..18\n";
+
+my $NEWPROTO = 'Prototype mismatch:';
+
+sub sub0 { 1 }
+sub sub0 { 2 }
+
+ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s;
+
+sub sub1 { 1 }
+sub sub1 () { 2 }
+
+ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1 vs ()\E[^\n]+\n//s;
+ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s;
+
+sub sub2 { 1 }
+sub sub2 ($) { 2 }
+
+ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2 vs ($)\E[^\n]+\n//s;
+ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s;
+
+sub sub3 () { 1 }
+sub sub3 { 2 }
+
+ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s;
+ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s;
+
+sub sub4 () { 1 }
+sub sub4 () { 2 }
+
+ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s;
+
+sub sub5 () { 1 }
+sub sub5 ($) { 2 }
+
+ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s;
+ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s;
+
+sub sub6 ($) { 1 }
+sub sub6 { 2 }
+
+ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s;
+ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s;
+
+sub sub7 ($) { 1 }
+sub sub7 () { 2 }
+
+ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s;
+ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s;
+
+sub sub8 ($) { 1 }
+sub sub8 ($) { 2 }
+
+ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s;
+
+sub sub9 ($@) { 1 }
+sub sub9 ($) { 2 }
+
+ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s;
+ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s;
+
+ok 18, $_ eq '';
+
+# If we got any errors that we were not expecting, then print them
+print $_ if length $_;
+
+
diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t
new file mode 100755
index 0000000..203b996
--- /dev/null
+++ b/contrib/perl5/t/comp/require.t
@@ -0,0 +1,50 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('.');
+}
+
+# don't make this lexical
+$i = 1;
+print "1..4\n";
+
+sub do_require {
+ %INC = ();
+ write_file('bleah.pm',@_);
+ eval { require "bleah.pm" };
+ my @a; # magic guard for scope violations (must be first lexical in file)
+}
+
+sub write_file {
+ my $f = shift;
+ open(REQ,">$f") or die "Can't write '$f': $!";
+ print REQ @_;
+ close REQ;
+}
+
+# interaction with pod (see the eof)
+write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
+require "bleah.pm";
+$i++;
+
+# run-time failure in require
+do_require "0;\n";
+print "# $@\nnot " unless $@ =~ /did not return a true/;
+print "ok ",$i++,"\n";
+
+# compile-time failure in require
+do_require "1)\n";
+print "# $@\nnot " unless $@ =~ /syntax error/i;
+print "ok ",$i++,"\n";
+
+# successful require
+do_require "1";
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+END { unlink 'bleah.pm'; }
+
+# ***interaction with pod (don't put any thing after here)***
+
+=pod
diff --git a/contrib/perl5/t/comp/script.t b/contrib/perl5/t/comp/script.t
new file mode 100755
index 0000000..d0c12e9
--- /dev/null
+++ b/contrib/perl5/t/comp/script.t
@@ -0,0 +1,27 @@
+#!./perl
+
+# $RCSfile: script.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:23 $
+
+print "1..3\n";
+
+$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl';
+$x = `$PERL -le "print 'ok';"`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]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 =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. Comp.script`; }
+
+if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = `$PERL <Comp.script`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; }
+
+if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";}
+
+unlink 'Comp.script' || `/bin/rm -f Comp.script`;
diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t
new file mode 100755
index 0000000..eb99680
--- /dev/null
+++ b/contrib/perl5/t/comp/term.t
@@ -0,0 +1,70 @@
+#!./perl
+
+# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $
+
+# tests that aren't important enough for base.term
+
+print "1..22\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";}
+
+# test if C<eval "{...}"> distinguishes between blocks and hashrefs
+
+$a = "{ '\\'' , 'foo' }";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";}
+
+$a = "{ '\\\\\\'abc' => 'foo' }";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";}
+
+$a = "{'a\\\n\\'b','foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";}
+
+$a = "{'\\\\\\'\\\\'=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";}
+
+$a = "{q,a'b,,'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";}
+
+$a = "{q[[']]=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";}
+
+# needs disambiguation if first term is a variable
+$a = "+{ \$a , 'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";}
+
+$a = "+{ \$a=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";}
diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t
new file mode 100755
index 0000000..a6ce2a4
--- /dev/null
+++ b/contrib/perl5/t/comp/use.t
@@ -0,0 +1,101 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..14\n";
+
+my $i = 1;
+
+eval "use 5.000;";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf "use %.5f;", $];
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+eval sprintf "use %.5f;", $] - 0.000001;
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf("use %.5f;", $] + 1);
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf "use %.5f;", $] + 0.00001;
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+
+use lib; # I know that this module will be there.
+
+
+local $lib::VERSION = 1.0;
+
+eval "use lib 0.9";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval "use lib 1.0";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval "use lib 1.01";
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+eval "use lib 0.9 qw(fred)";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " unless $INC[0] eq "fred";
+print "ok ",$i++,"\n";
+
+eval "use lib 1.0 qw(joe)";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " unless $INC[0] eq "joe";
+print "ok ",$i++,"\n";
+
+eval "use lib 1.01 qw(freda)";
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " if $INC[0] eq "freda";
+print "ok ",$i++,"\n";
OpenPOWER on IntegriCloud