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