dslinux/user/perl/t/comp bproto.t cmdopt.t colon.t cpp.aux cpp.t decl.t hints.t multiline.t opsubs.t our.t package.t parser.t proto.t redef.t require.t script.t term.t use.t utf.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:49 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/t/comp
In directory antilope:/tmp/cvs-serv17422/t/comp
Added Files:
bproto.t cmdopt.t colon.t cpp.aux cpp.t decl.t hints.t
multiline.t opsubs.t our.t package.t parser.t proto.t redef.t
require.t script.t term.t use.t utf.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: utf.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
if ($ENV{PERL_CORE_MINITEST}) {
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
require Config; import Config;
if ($Config{'extensions'} !~ /\bEncode\b/) {
print "1..0 # Skip: Encode was not built\n";
exit 0;
}
}
require "./test.pl";
plan(tests => 15);
my $BOM = chr(0xFEFF);
sub test {
my ($enc, $tag, $bom) = @_;
open(UTF_PL, ">:raw:encoding($enc)", "utf.pl")
or die "utf.pl($enc,$tag,$bom): $!";
print UTF_PL $BOM if $bom;
print UTF_PL "$tag\n";
close(UTF_PL);
my $got = do "./utf.pl";
is($got, $tag);
}
test("utf16le", 123, 1);
test("utf16le", 1234, 1);
test("utf16le", 12345, 1);
test("utf16be", 123, 1);
test("utf16be", 1234, 1);
test("utf16be", 12345, 1);
test("utf8", 123, 1);
test("utf8", 1234, 1);
test("utf8", 12345, 1);
test("utf16le", 123, 0);
test("utf16le", 1234, 0);
test("utf16le", 12345, 0);
test("utf16be", 123, 0);
test("utf16be", 1234, 0);
test("utf16be", 12345, 0);
END {
1 while unlink "utf.pl";
}
--- NEW FILE: colon.t ---
#!./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 at 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");
--- NEW FILE: term.t ---
#!./perl
# tests that aren't important enough for base.term
print "1..23\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";}
$a = "{ 0x01 => 'foo'}->{0x01}";
$a = eval $a;
if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";}
--- NEW FILE: require.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '.';
push @INC, '../lib';
}
# don't make this lexical
$i = 1;
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
my $total_tests = 31;
if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; }
print "1..$total_tests\n";
sub do_require {
%INC = ();
write_file('bleah.pm', at _);
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': $!";
binmode REQ;
use bytes;
print REQ @_;
close REQ or die "Could not close $f: $!";
}
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";
{
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";
$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";
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
print "ok ",$i++,"\n";
# successful require
do_require "1";
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# 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;
# Test that scalar context is forced for require
write_file('bleah.pm', <<'**BLEAH**'
print "not " if !defined wantarray || wantarray ne '';
print "ok $i - require() context\n";
1;
**BLEAH**
);
delete $INC{"bleah.pm"}; ++$::i;
$foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i;
$foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval {require bleah};
# Test for fix of RT #24404 : "require $scalar" may load a directory
my $r = "threads";
eval { require $r };
$i++;
if($@ =~ /Directory .*threads not allowed in require/) {
print "ok $i\n";
} else {
print "not ok $i\n";
}
##########################################
# What follows are UTF-8 specific tests. #
# Add generic tests before this point. #
##########################################
# UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input
if ($Is_EBCDIC || $Is_UTF8) { exit; }
my $utf8 = chr(0xFEFF);
$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
sub bytes_to_utf16 {
my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
}
$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE
END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; }
# ***interaction with pod (don't put any thing after here)***
=pod
--- NEW FILE: parser.t ---
#!./perl
# Checks if the parser behaves correctly in edge cases
# (including weird syntax errors)
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "./test.pl";
plan( tests => 53 );
eval '%@x=0;';
like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
# Bug 20010422.005
eval q{{s//${}/; //}};
like( $@, qr/syntax error/, 'syntax error, used to dump core' );
# Bug 20010528.007
eval q/"\x{"/;
like( $@, qr/^Missing right brace on \\x/,
'syntax error in string, used to dump core' );
eval "a.b.c.d.e.f;sub";
like( $@, qr/^Illegal declaration of anonymous subroutine/,
'found by Markov chain stress testing' );
# Bug 20010831.001
eval '($a, b) = (1, 2);';
like( $@, qr/^Can't modify constant item in list assignment/,
'bareword in list assignment' );
eval 'tie FOO, "Foo";';
like( $@, qr/^Can't modify constant item in tie /,
'tying a bareword causes a segfault in 5.6.1' );
eval 'undef foo';
like( $@, qr/^Can't modify constant item in undef operator /,
'undefing constant causes a segfault in 5.6.1 [ID 20010906.019]' );
eval 'read($bla, FILE, 1);';
like( $@, qr/^Can't modify constant item in read /,
'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]' );
# This used to dump core (bug #17920)
eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } };
like( $@, qr/error/, 'lexical block discarded by yacc' );
# bug #18573, used to corrupt memory
eval q{ "\c" };
like( $@, qr/^Missing control char name in \\c/, q("\c" string) );
eval q{ qq(foo$) };
like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) );
# two tests for memory corruption problems in the said variables
# (used to dump core or produce strange results)
is( "\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Qa", "a", "PL_lex_casestack" );
eval {
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
};
is( $@, '', 'PL_lex_brackstack' );
{
# tests for bug #20716
undef $a;
undef @b;
my $a="A";
is("${a}{", "A{", "interpolation, qq//");
is("${a}[", "A[", "interpolation, qq//");
my @b=("B");
is("@{b}{", "B{", "interpolation, qq//");
is(qr/${a}{/, '(?-xism:A{)', "interpolation, qr//");
my $c = "A{";
$c =~ /${a}{/;
is($&, 'A{', "interpolation, m//");
$c =~ s/${a}{/foo/;
is($c, 'foo', "interpolation, s/...//");
$c =~ s/foo/${a}{/;
is($c, 'A{', "interpolation, s//.../");
is(<<"${a}{", "A{ A[ B{\n", "interpolation, here doc");
${a}{ ${a}[ @{b}{
${a}{
}
eval q{ sub a(;; &) { } a { } };
is($@, '', "';&' sub prototype confuses the lexer");
# Bug #21575
# ensure that the second print statement works, by playing a bit
# with the test output.
my %data = ( foo => "\n" );
print "#";
print(
$data{foo});
pass();
# Bug #21875
# { q.* => ... } should be interpreted as hash, not block
foreach my $line (split /\n/, <<'EOF')
1 { foo => 'bar' }
1 { qoo => 'bar' }
1 { q => 'bar' }
1 { qq => 'bar' }
0 { q,'bar', }
0 { q=bar= }
0 { qq=bar= }
1 { q=bar= => 'bar' }
EOF
{
my ($expect, $eval) = split / /, $line, 2;
my $result = eval $eval;
ok($@ eq '', "eval $eval");
is(ref $result, $expect ? 'HASH' : '', $eval);
}
# Bug #24212
{
local $SIG{__WARN__} = sub { }; # silence mandatory warning
eval q{ my $x = -F 1; };
like( $@, qr/(?:syntax|parse) error .* near "F 1"/, "unknown filetest operators" );
is(
eval q{ sub F { 42 } -F 1 },
'-42',
'-F calls the F function'
);
}
# Bug #24762
{
eval q{ *foo{CODE} ? 1 : 0 };
is( $@, '', "glob subscript in conditional" );
}
# Bug #27024
{
# this used to segfault (because $[=1 is optimized away to a null block)
my $x;
$[ = 1 while $x;
pass();
$[ = 0; # restore the original value for less side-effects
}
# [perl #2738] perl segfautls on input
{
eval q{ sub _ <> {} };
like($@, qr/Illegal declaration of subroutine main::_/, "readline operator as prototype");
eval q{ $s = sub <> {} };
like($@, qr/Illegal declaration of anonymous subroutine/, "readline operator as prototype");
eval q{ sub _ __FILE__ {} };
like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype");
}
# [perl #36313] perl -e "1for$[=0" crash
{
my $x;
$x = 1 for ($[) = 0;
pass('optimized assignment to $[ used to segfault in list context');
if ($[ = 0) { $x = 1 }
pass('optimized assignment to $[ used to segfault in scalar context');
$x = ($[=2.4);
is($x, 2, 'scalar assignment to $[ behaves like other variables');
$x = (($[) = 0);
is($x, 1, 'list assignment to $[ behaves like other variables');
$x = eval q{ ($[, $x) = (0) };
like($@, qr/That use of \$\[ is unsupported/,
'cannot assign to $[ in a list');
eval q{ ($[) = (0, 1) };
like($@, qr/That use of \$\[ is unsupported/,
'cannot assign list of >1 elements to $[');
eval q{ ($[) = () };
like($@, qr/That use of \$\[ is unsupported/,
'cannot assign list of <1 elements to $[');
}
--- NEW FILE: redef.t ---
#!./perl -w
#
# Contributed by Graham Barr <Graham.Barr at tiuk.ti.com>
BEGIN {
$warn = "";
$SIG{__WARN__} = sub { $warn .= join("", at _) }
}
sub ok ($$) {
print $_[1] ? "ok " : "not ok ", $_[0], "\n";
}
print "1..20\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: none 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: none 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;
BEGIN {
local $^W = 0;
eval qq(sub sub10 () {1} sub sub10 {1});
}
ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s;
ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s;
ok 20, $warn eq '';
# If we got any errors that we were not expecting, then print them
print $warn if length $warn;
--- NEW FILE: bproto.t ---
#!./perl
#
# check if builtins behave as prototyped
#
BEGIN {
chdir 't' if -d 't';
@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);
];
--- NEW FILE: proto.t ---
#!./perl
#
# Contributed by Graham Barr <Graham.Barr at 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..141\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(",", at _),")\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(",", at _),")\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(",", at _),")\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(",", at _),")\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(",", at _),")\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, at _);
printf "ok %d\n",$i++;
eval "over_one_args()";
print "not " unless $@;
printf "ok %d\n",$i++;
sub over_one_a_args ($@) {
print "# \@_ = (",join(",", at _),")\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(@_, at _);
##
##
##
testing \&scalar_and_hash, '$%';
sub scalar_and_hash ($%) {
print "# \@_ = (",join(",", at _),")\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, at _);
printf "ok %d\n",$i++;
eval "scalar_and_hash()";
print "not " unless $@;
printf "ok %d\n",$i++;
sub scalar_and_hash_a ($@) {
print "# \@_ = (",join(",", at _),")\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(@_, at _);
##
##
##
testing \&one_or_two, '$;$';
sub one_or_two ($;$) {
print "# \@_ = (",join(",", at _),")\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, at _);
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(",", at _),")\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(@_, at _);
##
##
##
testing \&a_sub, '&';
sub a_sub (&) {
print "# \@_ = (",join(",", at _),")\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 \&a_subx, '\&';
sub a_subx (\&) {
print "# \@_ = (",join(",", at _),")\n";
&{$_[0]};
}
sub tmp_sub_2 { printf "ok %d\n",$i++ }
a_subx &tmp_sub_2;
@array = ( \&tmp_sub_2 );
eval 'a_subx @array';
print "not " unless $@;
printf "ok %d\n",$i++;
##
##
##
testing \&sub_aref, '&\@';
sub sub_aref (&\@) {
print "# \@_ = (",join(",", at _),")\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(",", at _),")\n";
print "not " unless @_ == 5;
my $sub = shift;
print map { &{$sub}($_) } @_
}
@array = (qw(O K)," ", $i++);
sub_array { lc shift } @array;
sub_array { lc shift } ('O', 'K', ' ', $i++);
print "\n";
##
##
##
testing \&a_hash, '%';
sub a_hash (%) {
print "# \@_ = (",join(",", at _),")\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(",", at _),")\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(",", at _),")\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 $@ !~ /^Can't 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";
# 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 "not " unless $_[0] eq 'FOO';
print "ok $i - star FOO\n";
}; $i++;
star(FOO, sub {
print "not " unless $_[0] eq 'FOO';
print "ok $i - star(FOO)\n";
}); $i++;
star "FOO", sub {
print "not " unless $_[0] eq 'FOO';
print qq/ok $i - star "FOO"\n/;
}; $i++;
star("FOO", sub {
print "not " unless $_[0] eq 'FOO';
print qq/ok $i - star("FOO")\n/;
}); $i++;
star $star, sub {
print "not " unless $_[0] eq 'FOO';
print "ok $i - star \$star\n";
}; $i++;
star($star, sub {
print "not " unless $_[0] eq 'FOO';
print "ok $i - star(\$star)\n";
}); $i++;
star *FOO, sub {
print "not " unless $_[0] eq \*FOO;
print "ok $i - star *FOO\n";
}; $i++;
star(*FOO, sub {
print "not " unless $_[0] eq \*FOO;
print "ok $i - star(*FOO)\n";
}); $i++;
star \*FOO, sub {
print "not " unless $_[0] eq \*FOO;
print "ok $i - star \\*FOO\n";
}; $i++;
star(\*FOO, sub {
print "not " unless $_[0] eq \*FOO;
print "ok $i - star(\\*FOO)\n";
}); $i++;
star2 FOO, BAR, sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
print "ok $i - star2 FOO, BAR\n";
}; $i++;
star2(Bar::BAZ, FOO, sub {
print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO';
print "ok $i - star2(Bar::BAZ, FOO)\n"
}); $i++;
star2 BAR(), FOO, sub {
print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO';
print "ok $i - star2 BAR(), FOO\n"
}; $i++;
star2(FOO, BAR(), sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
print "ok $i - star2(FOO, BAR())\n";
}); $i++;
star2 "FOO", "BAR", sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
print qq/ok $i - star2 "FOO", "BAR"\n/;
}; $i++;
star2("FOO", "BAR", sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
print qq/ok $i - star2("FOO", "BAR")\n/;
}); $i++;
star2 $star, $star, sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
print "ok $i - star2 \$star, \$star\n";
}; $i++;
star2($star, $star, sub {
print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO';
print "ok $i - star2(\$star, \$star)\n";
}); $i++;
star2 *FOO, *BAR, sub {
print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
print "ok $i - star2 *FOO, *BAR\n";
}; $i++;
star2(*FOO, *BAR, sub {
print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR;
print "ok $i - star2(*FOO, *BAR)\n";
}); $i++;
star2 \*FOO, \*BAR, sub {
no strict 'refs';
print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
print "ok $i - star2 \*FOO, \*BAR\n";
}; $i++;
star2(\*FOO, \*BAR, sub {
no strict 'refs';
print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'};
print "ok $i - star2(\*FOO, \*BAR)\n";
}); $i++;
# test scalarref prototype
sub sreftest (\$$) {
print "not " unless ref $_[0];
print "ok $_[1] - sreftest\n";
}
{
no strict 'vars';
sreftest my $sref, $i++;
sreftest($helem{$i}, $i++);
sreftest $aelem[0], $i++;
}
# test prototypes when they are evaled and there is a syntax error
# Byacc generates the string "syntax error". Bison gives the
# string "parse error".
#
for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
no warnings 'prototype';
my $eval = "sub evaled_subroutine $p { &void *; }";
eval $eval;
print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
print "ok ", $i++, "\n";
}
# Not $$;$;$
print "not " unless prototype "CORE::substr" eq '$$;$$';
print "ok ", $i++, "\n";
# recv takes a scalar reference for its second argument
print "not " unless prototype "CORE::recv" eq '*\\$$$';
print "ok ", $i++, "\n";
{
my $myvar;
my @myarray;
my %myhash;
sub mysub { print "not calling mysub I hope\n" }
local *myglob;
sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
print "not " unless myref($myvar) =~ /^SCALAR\(/;
print "ok ", $i++, "\n";
print "not " unless myref(@myarray) =~ /^ARRAY\(/;
print "ok ", $i++, "\n";
print "not " unless myref(%myhash) =~ /^HASH\(/;
print "ok ", $i++, "\n";
print "not " unless myref(&mysub) =~ /^CODE\(/;
print "ok ", $i++, "\n";
print "not " unless myref(*myglob) =~ /^GLOB\(/;
print "ok ", $i++, "\n";
eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
print "not " unless $@ =~ /Type of arg 1 to main::multi1 must be one of/;
print "ok ", $i++, "\n";
eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
print "not " unless $@ =~ /Type of arg 1 to main::multi2 must be one of/;
print "ok ", $i++, "\n";
eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
print "not " unless $@ =~ /Type of arg 1 to main::multi3 must be one of/;
print "ok ", $i++, "\n";
eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
print "not " unless $@ =~ /Type of arg 2 to main::multi4 must be one of/;
print "ok ", $i++, "\n";
eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
print "not " unless $@ =~ /Type of arg 1 to main::multi5 must be one of/
&& $@ =~ /Not enough arguments/;
print "ok ", $i++, "\n";
}
# check that obviously bad prototypes are getting warnings
{
use warnings 'syntax';
my $warn = "";
local $SIG{__WARN__} = sub { $warn .= join("", at _) };
eval 'sub badproto (@bar) { 1; }';
print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
print "ok ", $i++, "\n";
eval 'sub badproto2 (bar) { 1; }';
print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
print "ok ", $i++, "\n";
eval 'sub badproto3 (&$bar$@) { 1; }';
print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
print "ok ", $i++, "\n";
eval 'sub badproto4 (@ $b ar) { 1; }';
print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@\$bar/;
print "ok ", $i++, "\n";
}
# make sure whitespace in prototypes works
eval "sub good (\$\t\$\n\$) { 1; }";
print "not " if $@;
print "ok ", $i++, "\n";
eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;';
print "not " unless $@ =~ /Not a HASH reference/;
print "ok ", $i++, " # TODO Ought to fail, doesn't in 5.8.2\n";
--- NEW FILE: cpp.t ---
#!./perl
# $RCSfile: cpp.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:46 $
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
}
use Config;
if ( $^O eq 'MacOS' ||
($Config{'cppstdin'} =~ /\bcppstdin\b/) &&
! -x $Config{'binexp'} . "/cppstdin" ) {
print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
exit; # Cannot test till after install, alas.
}
system qq{$^X -"P" "comp/cpp.aux"};
--- NEW FILE: our.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
print "1..7\n";
{
package TieAll;
# tie, track, and report what calls are made
my @calls;
sub AUTOLOAD {
for ($AUTOLOAD =~ /TieAll::(.*)/) {
if (/TIE/) { return bless {} }
elsif (/calls/) { return join ',', splice @calls }
else {
push @calls, $_;
# FETCHSIZE doesn't like undef
# if FIRSTKEY, see if NEXTKEY is also called
return 1 if /FETCHSIZE|FIRSTKEY/;
return;
}
}
}
}
tie $x, 'TieAll';
tie @x, 'TieAll';
tie %x, 'TieAll';
{our $x;}
is(TieAll->calls, '', 'our $x has no runtime effect');
{our ($x);}
is(TieAll->calls, '', 'our ($x) has no runtime effect');
{our %x;}
is(TieAll->calls, '', 'our %x has no runtime effect');
{our (%x);}
is(TieAll->calls, '', 'our (%x) has no runtime effect');
{our @x;}
is(TieAll->calls, '', 'our @x has no runtime effect');
{our (@x);}
is(TieAll->calls, '', 'our (@x) has no runtime effect');
$y = 1;
{
my $y = 2;
{
our $y = $y;
is($y, 2, 'our shouldnt be visible until introduced')
}
}
--- NEW FILE: hints.t ---
#!./perl
# Tests the scoping of $^H and %^H
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
BEGIN { print "1..15\n"; }
BEGIN {
print "not " if exists $^H{foo};
print "ok 1 - \$^H{foo} doesn't exist initially\n";
print "not " if $^H & 0x00020000;
print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n";
}
{
# simulate a pragma -- don't forget HINT_LOCALIZE_HH
BEGIN { $^H |= 0x00020000; $^H{foo} = "a"; }
BEGIN {
print "not " if $^H{foo} ne "a";
print "ok 3 - \$^H{foo} is now 'a'\n";
print "not " unless $^H & 0x00020000;
print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n";
}
{
BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; }
BEGIN {
print "not " if $^H{foo} ne "b";
print "ok 5 - \$^H{foo} is now 'b'\n";
}
}
BEGIN {
print "not " if $^H{foo} ne "a";
print "ok 6 - \$H^{foo} restored to 'a'\n";
}
# The pragma settings disappear after compilation
# (test at CHECK-time and at run-time)
CHECK {
print "not " if exists $^H{foo};
print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n";
print "not " if $^H & 0x00020000;
print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n";
}
print "not " if exists $^H{foo};
print "ok 11 - \$^H{foo} doesn't exist at runtime\n";
print "not " if $^H & 0x00020000;
print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n";
# op_entereval should keep the pragmas it was compiled with
eval q*
print "not " if $^H{foo} ne "a";
print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time # TODO\n";
print "not " unless $^H & 0x00020000;
print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n";
*;
}
BEGIN {
print "not " if exists $^H{foo};
print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n";
print "not " if $^H & 0x00020000;
print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n";
}
require 'test.pl';
# bug #27040: hints hash was being double-freed
my $result = runperl(
prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
stderr => 1
);
print "not " if length $result;
print "ok 15 - double-freeing hints hash\n";
print "# got: $result\n" if length $result;
--- NEW FILE: multiline.t ---
#!./perl
BEGIN: {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan(tests => 6);
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";
is($x, $y, 'test data is sane');
print TRY $x;
close TRY or die "Could not close: $!";
open(TRY,'Comp.try') || (die "Can't reopen temp file.");
$count = 0;
$z = '';
while (<TRY>) {
$z .= $_;
$count = $count + 1;
}
is($z, $y, 'basic multiline reading');
is($count, 7, ' line count');
is($., 7, ' $.' );
$out = (($^O eq 'MSWin32') || $^O eq 'NetWare' || $^O eq 'VMS') ? `type Comp.try`
: ($^O eq 'MacOS') ? `catenate Comp.try`
: `cat Comp.try`;
like($out, qr/.*\n.*\n.*\n$/);
close(TRY) || (die "Can't close temp file.");
unlink 'Comp.try' || `/bin/rm -f Comp.try`;
is($out, $y);
--- NEW FILE: use.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..28\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 ($@) {
print STDERR $@,"\n";
print "not ";
}
print "ok ",$i++,"\n";
eval sprintf "use %.6f;", $];
if ($@) {
print STDERR $@,"\n";
print "not ";
}
print "ok ",$i++,"\n";
eval sprintf "use %.6f;", $] - 0.000001;
if ($@) {
print STDERR $@,"\n";
print "not ";
}
print "ok ",$i++,"\n";
eval sprintf("use %.6f;", $] + 1);
unless ($@) {
print "not ";
}
print "ok ",$i++,"\n";
eval sprintf "use %.6f;", $] + 0.00001;
unless ($@) {
print "not ";
}
print "ok ",$i++,"\n";
{ use lib } # check that subparse saves pending tokens
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" || ($^O eq 'MacOS' && $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" || ($^O eq 'MacOS' && $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" || ($^O eq 'MacOS' && $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";
}
{
# Regression test for patch 14937:
# Check that a .pm file with no package or VERSION doesn't core.
open F, ">xxx.pm" or die "Cannot open xxx.pm: $!\n";
print F "1;\n";
close F;
eval "use lib '.'; use xxx 3;";
unless ($@ =~ /^xxx defines neither package nor VERSION--version check failed at/) {
print "not ";
}
print "ok ",$i++,"\n";
unlink 'xxx.pm';
}
--- NEW FILE: package.t ---
#!./perl
print "1..14\n";
$blurfl = 123;
$foo = 3;
package xyz;
sub new {bless [];}
$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:new:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
} else {
print $xyz eq 'ABC:bar:main:new: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";
package main;
sub c { caller(0) }
sub foo {
my $s = shift;
if ($s) {
package PQR;
main::c();
}
}
print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n");
my $Q = xyz->new();
undef %xyz::;
eval { $a = *xyz::new{PACKAGE}; };
print $a eq "__ANON__" ? "ok 9\n" : "not ok 9\n";
eval { $Q->param; };
print $@ =~ /^Can't use anonymous symbol table for method lookup/ ?
"ok 10\n" : "not ok 10\n";
print "$Q" =~ /^__ANON__=/ ? "ok 11\n" : "not ok 11\n";
print ref $Q eq "__ANON__" ? "ok 12\n" : "not ok 12\n";
package bug32562;
print __PACKAGE__ eq 'bug32562' ? "ok 13\n" : "not ok 13\n";
print eval '__PACKAGE__' eq 'bug32562' ? "ok 14\n" : "not ok 14\n";
--- NEW FILE: decl.t ---
#!./perl
# $RCSfile: decl.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:46 $
# 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";
}
--- NEW FILE: script.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl'; # for which_perl() etc
}
my $Perl = which_perl();
print "1..3\n";
$x = `$Perl -le "print 'ok';"`;
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 or die "Could not close: $!";
$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";}
unlink 'Comp.script' || `/bin/rm -f Comp.script`;
--- NEW FILE: cpp.aux ---
#!./perl -l
# There's a bug in -P where the #! line is ignored. If this test
# suddenly starts printing blank lines that bug has been fixed.
print "1..3\n";
#define MESS "ok 1\n"
print MESS;
#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 or die "Could not close Comp_cpp.tmp: $!";
open(TRY,">Comp_cpp.inc") || (die "Can't open temp include file: $!");
print TRY '#define OK "ok 3\n"' . "\n";
close TRY or die "Could not close Comp_cpp.tmp: $!";
print `$^X "-P" Comp_cpp.tmp`;
unlink "Comp_cpp.tmp", "Comp_cpp.inc";
--- NEW FILE: cmdopt.t ---
#!./perl
# $RCSfile: cmdopt.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:46 $
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";}
--- NEW FILE: opsubs.t ---
#!./perl -T
use warnings;
use strict;
$|++;
=pod
Even if you have a C<sub q{}>, calling C<q()> will be parsed as the
C<q()> operator. Calling C<&q()> or C<main::q()> gets you the function.
This test verifies this behavior for nine different operators.
=cut
use Test::More tests => 36;
sub m { return "m-".shift }
sub q { return "q-".shift }
sub qq { return "qq-".shift }
sub qr { return "qr-".shift }
sub qw { return "qw-".shift }
sub qx { return "qx-".shift }
sub s { return "s-".shift }
sub tr { return "tr-".shift }
sub y { return "y-".shift }
# m operator
can_ok( 'main', "m" );
SILENCE_WARNING: { # Complains because $_ is undef
no warnings;
isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" );
}
is( main::m('main'), "m-main", "main::m() is func" );
is( &m('amper'), "m-amper", "&m() is func" );
# q operator
can_ok( 'main', "q" );
isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" );
is( main::q('main'), "q-main", "main::q() is func" );
is( &q('amper'), "q-amper", "&q() is func" );
# qq operator
can_ok( 'main', "qq" );
isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" );
is( main::qq('main'), "qq-main", "main::qq() is func" );
is( &qq('amper'), "qq-amper", "&qq() is func" );
# qr operator
can_ok( 'main', "qr" );
isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" );
is( main::qr('main'), "qr-main", "main::qr() is func" );
is( &qr('amper'), "qr-amper", "&qr() is func" );
# qw operator
can_ok( 'main', "qw" );
isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" );
is( main::qw('main'), "qw-main", "main::qw() is func" );
is( &qw('amper'), "qw-amper", "&qw() is func" );
# qx operator
can_ok( 'main', "qx" );
eval "qx('unqualified')";
TODO: {
local $TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $TODO;
like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
}
is( main::qx('main'), "qx-main", "main::qx() is func" );
is( &qx('amper'), "qx-amper", "&qx() is func" );
# s operator
can_ok( 'main', "s" );
eval "s('unqualified')";
like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" );
is( main::s('main'), "s-main", "main::s() is func" );
is( &s('amper'), "s-amper", "&s() is func" );
# tr operator
can_ok( 'main', "tr" );
eval "tr('unqualified')";
like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" );
is( main::tr('main'), "tr-main", "main::tr() is func" );
is( &tr('amper'), "tr-amper", "&tr() is func" );
# y operator
can_ok( 'main', "y" );
eval "y('unqualified')";
like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" );
is( main::y('main'), "y-main", "main::y() is func" );
is( &y('amper'), "y-amper", "&y() is func" );
=pod
from irc://irc.perl.org/p5p 2004/08/12
<kane-xs> bug or feature?
<purl> You decide!!!!
<kane-xs> [kane at coke ~]$ perlc -le'sub y{1};y(1)'
<kane-xs> Transliteration replacement not terminated at -e line 1.
<Nicholas> bug I think
<kane-xs> i'll perlbug
<rgs> feature
<kane-xs> smiles at rgs
<kane-xs> done
<rgs> will be closed at not a bug,
<rgs> like the previous reports of this one
<Nicholas> feature being first class and second class keywords?
<rgs> you have similar ones with q, qq, qr, qx, tr, s and m
<rgs> one could say 1st class keywords, yes
<rgs> and I forgot qw
<kane-xs> hmm silly...
<Nicholas> it's acutally operators, isn't it?
<Nicholas> as in you can't call a subroutine with the same name as an
operator unless you have the & ?
<kane-xs> or fqpn (fully qualified package name)
<kane-xs> main::y() works just fine
<kane-xs> as does &y; but not y()
<Andy> If that's a feature, then let's write a test that it continues
to work like that.
=cut
More information about the dslinux-commit
mailing list