diff options
Diffstat (limited to 'contrib/perl5/t/comp')
-rwxr-xr-x | contrib/perl5/t/comp/cmdopt.t | 90 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/colon.t | 138 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/cpp.aux | 39 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/cpp.t | 18 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/decl.t | 49 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/multiline.t | 46 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/package.t | 39 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/proto.t | 415 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/redef.t | 80 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/require.t | 50 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/script.t | 27 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/term.t | 70 | ||||
-rwxr-xr-x | contrib/perl5/t/comp/use.t | 101 |
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"; |