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/bproto.t44
-rwxr-xr-xcontrib/perl5/t/comp/colon.t2
-rwxr-xr-xcontrib/perl5/t/comp/cpp.aux4
-rwxr-xr-xcontrib/perl5/t/comp/cpp.t4
-rwxr-xr-xcontrib/perl5/t/comp/proto.t51
-rwxr-xr-xcontrib/perl5/t/comp/require.t85
-rwxr-xr-xcontrib/perl5/t/comp/script.t3
-rwxr-xr-xcontrib/perl5/t/comp/term.t8
-rwxr-xr-xcontrib/perl5/t/comp/use.t79
9 files changed, 255 insertions, 25 deletions
diff --git a/contrib/perl5/t/comp/bproto.t b/contrib/perl5/t/comp/bproto.t
new file mode 100755
index 0000000..01efb84
--- /dev/null
+++ b/contrib/perl5/t/comp/bproto.t
@@ -0,0 +1,44 @@
+#!./perl
+#
+# check if builtins behave as prototyped
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+}
+
+print "1..10\n";
+
+my $i = 1;
+
+sub foo {}
+my $bar = "bar";
+
+sub test_too_many {
+ eval $_[0];
+ print "not " unless $@ =~ /^Too many arguments/;
+ printf "ok %d\n",$i++;
+}
+
+sub test_no_error {
+ eval $_[0];
+ print "not " if $@;
+ printf "ok %d\n",$i++;
+}
+
+test_too_many($_) for split /\n/,
+q[ defined(&foo, $bar);
+ undef(&foo, $bar);
+ uc($bar,$bar);
+];
+
+test_no_error($_) for split /\n/,
+q[ scalar(&foo,$bar);
+ defined &foo, &foo, &foo;
+ undef &foo, $bar;
+ uc $bar,$bar;
+ grep(not($bar), $bar);
+ grep(not($bar, $bar), $bar);
+ grep((not $bar, $bar, $bar), $bar);
+];
diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t
index d2c64fe..dee5330 100755
--- a/contrib/perl5/t/comp/colon.t
+++ b/contrib/perl5/t/comp/colon.t
@@ -9,7 +9,7 @@
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ unshift @INC, '../lib';
}
use strict;
diff --git a/contrib/perl5/t/comp/cpp.aux b/contrib/perl5/t/comp/cpp.aux
index bb93d21..536268a 100755
--- a/contrib/perl5/t/comp/cpp.aux
+++ b/contrib/perl5/t/comp/cpp.aux
@@ -1,14 +1,10 @@
#!./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
diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t
index 86e7359..bbff38c 100755
--- a/contrib/perl5/t/comp/cpp.t
+++ b/contrib/perl5/t/comp/cpp.t
@@ -4,14 +4,14 @@
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ unshift @INC, '../lib';
}
use Config;
if ( $^O eq 'MSWin32' or
($Config{'cppstdin'} =~ /\bcppstdin\b/) and
( ! -x $Config{'binexp'} . "/cppstdin") ) {
- print "1..0\n";
+ print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
exit; # Cannot test till after install, alas.
}
diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t
index db6a9b5..ee17088 100755
--- a/contrib/perl5/t/comp/proto.t
+++ b/contrib/perl5/t/comp/proto.t
@@ -11,12 +11,12 @@
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ unshift @INC, '../lib';
}
use strict;
-print "1..87\n";
+print "1..107\n";
my $i = 1;
@@ -384,11 +384,11 @@ 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 "# 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/;
+ if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
print "ok ", $i++, "\n";
# correctly note too-short parameter lists that don't end with '$',
@@ -417,9 +417,52 @@ print "ok ", $i++, "\n";
# test if the (*) prototype allows barewords, constants, scalar expressions,
# globs and globrefs (just as CORE::open() does), all under stricture
sub star (*&) { &{$_[1]} }
+sub star2 (**&) { &{$_[2]} }
+sub BAR { "quux" }
+sub Bar::BAZ { "quuz" }
my $star = 'FOO';
star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
+star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
+star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
+star2 FOO, BAR, sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
+star2(Bar::BAZ, FOO, sub { print "ok $i\n"
+ if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
+star2 BAR(), FOO, sub { print "ok $i\n"
+ if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
+star2(FOO, BAR(), sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
+star2 "FOO", "BAR", sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
+star2("FOO", "BAR", sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
+star2 $star, $star, sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
+star2($star, $star, sub { print "ok $i\n"
+ if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
+star2 *FOO, *BAR, sub { print "ok $i\n"
+ if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++;
+star2(*FOO, *BAR, sub { print "ok $i\n"
+ if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++;
+star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
+ if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++;
+star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
+ if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++;
+
+# test scalarref prototype
+sub sreftest (\$$) {
+ print "ok $_[1]\n" if ref $_[0];
+}
+{
+ no strict 'vars';
+ sreftest my $sref, $i++;
+ sreftest($helem{$i}, $i++);
+ sreftest $aelem[0], $i++;
+}
diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t
index 5c41f5c..1d92687 100755
--- a/contrib/perl5/t/comp/require.t
+++ b/contrib/perl5/t/comp/require.t
@@ -2,12 +2,12 @@
BEGIN {
chdir 't' if -d 't';
- @INC = ('.', '../lib');
+ unshift @INC, ('.', '../lib');
}
# don't make this lexical
$i = 1;
-print "1..4\n";
+print "1..20\n";
sub do_require {
%INC = ();
@@ -23,6 +23,74 @@ sub write_file {
close REQ;
}
+eval {require 5.005};
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+eval { require 5.005 };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+eval { require 5.005; };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+eval {
+ require 5.005
+};
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+# new style version numbers
+
+eval { require v5.5.630; };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+eval { require 10.0.2; };
+print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
+print "ok ",$i++,"\n";
+
+eval q{ use v5.5.630; };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+eval q{ use 10.0.2; };
+print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
+print "ok ",$i++,"\n";
+
+my $ver = 5.005_63;
+eval { require $ver; };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+# check inaccurate fp
+$ver = 10.2;
+eval { require $ver; };
+print "# $@\nnot " unless $@ =~ /^Perl v10\.200\.0 required/;
+print "ok ",$i++,"\n";
+
+$ver = 10.000_02;
+eval { require $ver; };
+print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/;
+print "ok ",$i++,"\n";
+
+print "not " unless 5.5.1 gt v5.5;
+print "ok ",$i++,"\n";
+
+{
+ use utf8;
+ print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
+ print "ok ",$i++,"\n";
+
+ print "not " unless v7.15 eq "\x{7}\x{f}";
+ print "ok ",$i++,"\n";
+
+ print "not "
+ unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
+ print "ok ",$i++,"\n";
+}
+
# interaction with pod (see the eof)
write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
require "bleah.pm";
@@ -45,7 +113,18 @@ do_require "1";
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
-END { unlink 'bleah.pm'; }
+# do FILE shouldn't see any outside lexicals
+my $x = "ok $i\n";
+write_file("bleah.do", <<EOT);
+\$x = "not ok $i\\n";
+EOT
+do "bleah.do";
+dofile();
+sub dofile { do "bleah.do"; };
+print $x;
+$i++;
+
+END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; }
# ***interaction with pod (don't put any thing after here)***
diff --git a/contrib/perl5/t/comp/script.t b/contrib/perl5/t/comp/script.t
index d0c12e9..a9bc47d 100755
--- a/contrib/perl5/t/comp/script.t
+++ b/contrib/perl5/t/comp/script.t
@@ -6,7 +6,6 @@ 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";}
@@ -15,12 +14,10 @@ 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";}
diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t
index eb99680..f079eef 100755
--- a/contrib/perl5/t/comp/term.t
+++ b/contrib/perl5/t/comp/term.t
@@ -1,10 +1,8 @@
#!./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";
+print "1..23\n";
$x = "\\n";
print "#1\t:$x: eq " . ':\n:' . "\n";
@@ -68,3 +66,7 @@ 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";}
+
+$a = "{ 0x01 => 'foo'}->{0x01}";
+$a = eval $a;
+if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";}
diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t
index a6ce2a4..1f5fae3 100755
--- a/contrib/perl5/t/comp/use.t
+++ b/contrib/perl5/t/comp/use.t
@@ -2,12 +2,18 @@
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ unshift @INC, '../lib';
}
-print "1..14\n";
+print "1..27\n";
my $i = 1;
+eval "use 5.000"; # implicit semicolon
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
eval "use 5.000;";
if ($@) {
@@ -44,9 +50,7 @@ unless ($@) {
print "ok ",$i++,"\n";
-
-use lib; # I know that this module will be there.
-
+{ use lib } # check that subparse saves pending tokens
local $lib::VERSION = 1.0;
@@ -99,3 +103,68 @@ print "ok ",$i++,"\n";
print "not " if $INC[0] eq "freda";
print "ok ",$i++,"\n";
+
+{
+ local $lib::VERSION = 35.36;
+ eval "use lib v33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib v100.105";
+ unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+
+ eval "use lib 33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib 100.105";
+ unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+
+ local $lib::VERSION = '35.36';
+ eval "use lib v33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib v100.105";
+ unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+
+ eval "use lib 33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib 100.105";
+ unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+
+ local $lib::VERSION = v35.36;
+ eval "use lib v33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib v100.105";
+ unless ($@ =~ /lib v100\.105 required--this is only v35\.36/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+
+ eval "use lib 33.55";
+ print "not " if $@;
+ print "ok ",$i++,"\n";
+
+ eval "use lib 100.105";
+ unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) {
+ print "not ";
+ }
+ print "ok ",$i++,"\n";
+}
OpenPOWER on IntegriCloud