+print "1..65\n";

+# make sure reification behaves

+my $t = 63;

+sub reify { $_[1] = ++$t; print "@_\n"; }

+reify('ok');

+reify('ok');

+ 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'],

+ printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query;

+ print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8);

+print "1..36\n";

+

+my $b = 'wrong';

+my $X = sub {

+ my $b = "right";

+ print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";

+};

+&$X();

+

+

+# check navigation of multiple eval boundaries to find lexicals

+

+my $x = 25;

+eval <<'EOT'; die if $@;

+ print "# $x\n"; # clone into eval's pad

+ sub do_eval1 {

+ eval $_[0]; die if $@;

+ }

+EOT

+do_eval1('print "ok $x\n"');

+$x++;

+do_eval1('eval q[print "ok $x\n"]');

+$x++;

+do_eval1('sub { eval q[print "ok $x\n"] }->()');

+$x++;

+

+# calls from within eval'' should clone outer lexicals

+

+eval <<'EOT'; die if $@;

+ sub do_eval2 {

+ eval $_[0]; die if $@;

+ }

+do_eval2('print "ok $x\n"');

+$x++;

+do_eval2('eval q[print "ok $x\n"]');

+$x++;

+do_eval2('sub { eval q[print "ok $x\n"] }->()');

+$x++;

+EOT

+

+# calls outside eval'' should NOT clone lexicals from called context

+

+$main::x = 'ok';

+eval <<'EOT'; die if $@;

+ # $x unbound here

+ sub do_eval3 {

+ eval $_[0]; die if $@;

+ }

+EOT

+do_eval3('print "$x ' . $x . '\n"');

+$x++;

+do_eval3('eval q[print "$x ' . $x . '\n"]');

+$x++;

+do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');

+$x++;

+

+# can recursive subroutine-call inside eval'' see its own lexicals?

+sub recurse {

+ my $l = shift;

+ if ($l < $x) {

+ ++$l;

+ eval 'print "# level $l\n"; recurse($l);';

+ die if $@;

+ }

+ else {

+ print "ok $l\n";

+ }

+}

+{

+ local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };

+ recurse($x-5);

+}

+$x++;

+

+# do closures created within eval bind correctly?

+eval <<'EOT';

+ sub create_closure {

+ my $self = shift;

+ return sub {

+ print $self;

+ };

+ }

+EOT

+create_closure("ok $x\n")->();

+$x++;

+

+# does lexical search terminate correctly at subroutine boundary?

+$main::r = "ok $x\n";

+sub terminal { eval 'print $r' }

+{

+ my $r = "not ok $x\n";

+ eval 'terminal($r)';

+}

+$x++;

+

+print "1..13\n";

+print "ok 13\n";

+# see if a modified @_ propagates

+{

+ package Foo;

+ sub DESTROY { my $s = shift; print "ok $s->[0]\n"; }

+ sub show { print "# @_\nnot ok $_[0][0]\n" if @_ != 5; }

+ sub start { push @_, 1, "foo", {}; goto &show; }

+ for (9..11) { start(bless([$_]), 'bar'); }

+}

+

+sub auto {

+ goto &loadit;

+}

+

+sub AUTOLOAD { print @_ }

+

+auto("ok 12\n");

+

+#!./perl

+

+#

+# grep() and map() tests

+#

+

+print "1..3\n";

+

+$test = 1;

+

+sub ok {

+ my ($got,$expect) = @_;

+ print "# expected [$expect], got [$got]\nnot " if $got ne $expect;

+ print "ok $test\n";

+}

+

+{

+ my @lol = ([qw(a b c)], [], [qw(1 2 3)]);

+ my @mapped = map {scalar @$_} @lol;

+ ok "@mapped", "3 0 3";

+ $test++;

+

+ my @grepped = grep {scalar @$_} @lol;

+ ok "@grepped", "$lol[0] $lol[2]";

+ $test++;

+

+ @grepped = grep { $_ } @mapped;

+ ok "@grepped", "3 3";

+ $test++;

+}

+

+print "1..69\n";

+# does implicit localization in foreach skip magic?

+

+$_ = "ok 59,ok 60,";

+my $iter = 0;

+while (/(o.+?),/gc) {

+ print "$1\n";

+ foreach (1..1) { $iter++ }

+ if ($iter > 2) { print "not ok 60\n"; last; }

+}

+

+{

+ package UnderScore;

+ sub TIESCALAR { bless \my $self, shift }

+ sub FETCH { die "read \$_ forbidden" }

+ sub STORE { die "write \$_ forbidden" }

+ tie $_, __PACKAGE__;

+ my $t = 61;

+ my @tests = (

+ "Nesting" => sub { print '#'; for (1..3) { print }

+ print "\n" }, 1,

+ "Reading" => sub { print }, 0,

+ "Matching" => sub { $x = /badness/ }, 0,

+ "Concat" => sub { $_ .= "a" }, 0,

+ "Chop" => sub { chop }, 0,

+ "Filetest" => sub { -x }, 0,

+ "Assignment" => sub { $_ = "Bad" }, 0,

+ # XXX whether next one should fail is debatable

+ "Local \$_" => sub { local $_ = 'ok?'; print }, 0,

+ "for local" => sub { for("#ok?\n"){ print } }, 1,

+ );

+ while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {

+ print "# Testing $name\n";

+ eval { &$code };

+ print(($ok xor $@) ? "ok $t\n" : "not ok $t\n");

+ ++$t;

+ }

+ untie $_;

+}

+

+# bison says 'parse error' instead of 'syntax error',

+# various yaccs may or may not capitalize 'syntax'.

+ $results =~ s/^(syntax|parse) error/syntax error/mig;

+BEGIN {

+ $| = 1;

+ $SIG{__WARN__} = sub {

+ eval { print $_[0] };

+ die "bar\n";

+ };

+ warn "foo\n";

+}

+EXPECT

+foo

+bar

+BEGIN failed--compilation aborted at - line 8.

+########

+use strict;

+my $foo = "ZZZ\n";

+END { print $foo }

+EXPECT

+ZZZ

+########

+eval '

+use strict;

+my $foo = "ZZZ\n";

+END { print $foo }

+';

+EXPECT

+ZZZ

+print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n");

+print "1..9\n";

+print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n";

+BEGIN {

+ chdir 't' if -d 't';

+ unshift @INC, '../lib' if -d '../lib';

+ require Config; import Config;

+}

+print "1..142\n";

+$sum = 103 if ($Config{ebcdic} eq 'define');

+# Note that first uuencoding known 'text' data and then checking the

+# binary values of the uuencoded version would not be portable between

+# character sets. Uuencoding is meant for encoding binary data, not

+# text data.

+

+$in = pack 'C*', 0 .. 255;

+# 61..72: test the ascii template types (A, a, Z)

+

+print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 ";

+print "ok ", $test++, "\n";

+

+print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 ";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar";

+print "ok ", $test++, "\n";

+

+print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 ";

+print "ok ", $test++, "\n";

+

+print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar ";

+print "ok ", $test++, "\n";

+

+print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 ";

+print "ok ", $test++, "\n";

+

+print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('Z*', "foo\0bar \0") eq "foo";

+print "ok ", $test++, "\n";

+

+print "not " unless unpack('Z8', "foo\0bar \0") eq "foo";

+print "ok ", $test++, "\n";

+

+# 73..78: packing native shorts/ints/longs

+

+# integrated from mainline and don't want to change numbers all the way

+# down. native ints are not supported in _0x so comment out checks

+#print "not " unless length(pack("s!", 0)) == $Config{shortsize};

+print "ok ", $test++, "\n";

+

+#print "not " unless length(pack("i!", 0)) == $Config{intsize};

+print "ok ", $test++, "\n";

+

+#print "not " unless length(pack("l!", 0)) == $Config{longsize};

+print "ok ", $test++, "\n";

+

+#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0));

+print "ok ", $test++, "\n";

+

+#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0));

+print "ok ", $test++, "\n";

+

+#print "not " unless length(pack("i!", 0)) == length(pack("i", 0));

+print "ok ", $test++, "\n";

+

+# 79..138: pack <-> unpack bijectionism

+

+# 79.. 83 c

+foreach my $c (-128, -1, 0, 1, 127) {

+ print "not " unless unpack("c", pack("c", $c)) == $c;

+ print "ok ", $test++, "\n";

+}

+

+# 84.. 88: C

+foreach my $C (0, 1, 127, 128, 255) {

+ print "not " unless unpack("C", pack("C", $C)) == $C;

+ print "ok ", $test++, "\n";

+}

+

+# 89.. 93: s

+foreach my $s (-32768, -1, 0, 1, 32767) {

+ print "not " unless unpack("s", pack("s", $s)) == $s;

+ print "ok ", $test++, "\n";

+}

+

+# 94.. 98: S

+foreach my $S (0, 1, 32767, 32768, 65535) {

+ print "not " unless unpack("S", pack("S", $S)) == $S;

+ print "ok ", $test++, "\n";

+}

+

+# 99..103: i

+foreach my $i (-2147483648, -1, 0, 1, 2147483647) {

+ print "not " unless unpack("i", pack("i", $i)) == $i;

+ print "ok ", $test++, "\n";

+}

+

+# 104..108: I

+foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) {

+ print "not " unless unpack("I", pack("I", $I)) == $I;

+ print "ok ", $test++, "\n";

+}

+

+# 109..113: l

+foreach my $l (-2147483648, -1, 0, 1, 2147483647) {

+ print "not " unless unpack("l", pack("l", $l)) == $l;

+ print "ok ", $test++, "\n";

+}

+

+# 114..118: L

+foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) {

+ print "not " unless unpack("L", pack("L", $L)) == $L;

+ print "ok ", $test++, "\n";

+}

+

+# 119..123: n

+foreach my $n (0, 1, 32767, 32768, 65535) {

+ print "not " unless unpack("n", pack("n", $n)) == $n;

+ print "ok ", $test++, "\n";

+}

+

+# 124..128: v

+foreach my $v (0, 1, 32767, 32768, 65535) {

+ print "not " unless unpack("v", pack("v", $v)) == $v;

+ print "ok ", $test++, "\n";

+}

+

+# 129..133: N

+foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) {

+ print "not " unless unpack("N", pack("N", $N)) == $N;

+ print "ok ", $test++, "\n";

+}

+

+# 134..138: V

+foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) {

+ print "not " unless unpack("V", pack("V", $V)) == $V;

+ print "ok ", $test++, "\n";

+}

+

+# 139..142: pack nvNV byteorders

+

+print "not " unless pack("n", 0xdead) eq "\xde\xad";

+print "ok ", $test++, "\n";

+

+print "not " unless pack("v", 0xdead) eq "\xad\xde";

+print "ok ", $test++, "\n";

+

+print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef";

+print "ok ", $test++, "\n";

+

+print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde";

+print "ok ", $test++, "\n";

+print "1..142\n";

+# see if matching against temporaries (created via pp_helem()) is safe

+{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;

+print "$1\n";

+$test++;

+

+print "1..12\n";

+# check bounds

+@a = 0x7ffffffe..0x7fffffff;

+print "not " unless "@a" eq "2147483646 2147483647";

+print "ok 11\n";

+

+@a = -0x7fffffff..-0x7ffffffe;

+print "not " unless "@a" eq "-2147483647 -2147483646";

+print "ok 12\n";

+

+((a{4})+) aaaaaaaaa y $1 aaaaaaaa

+(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa

+(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa

+(^|x)(c) ca y $2 c

+a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - -

+round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz

+print "1..20\n";

+

+#

+# The test #20 is actually testing for Digital C compiler optimizer bug.

+#

+# Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS) used

+# to produce (as of December 1998) broken code for util.c:repeatcpy()

+# (a utility function for the 'x' operator) in the case *all* these

+# four conditions held:

+#

+# (1) len == 1

+# (2) "from" had the 8th bit on in its single character

+# (3) count > 7 (the 'x' count > 16)

+# (4) the highest optimization level was used in compilation

+# (which is the default when compiling Perl)

+#

+# The bug looked like this (. being the eight-bit character and ? being \xff):

+#

+# 16 ................

+# 17 .........???????.

+# 18 .........???????..

+# 19 .........???????...

+# 20 .........???????....

+# 21 .........???????.....

+# 22 .........???????......

+# 23 .........???????.......

+# 24 .........???????.???????

+# 25 .........???????.???????.

+#

+# The bug could be (obscurely) avoided by changing "from" to

+# be an unsigned char pointer.

+#

+# The bug was triggered in the "if (len == 1)" branch. The fix

+# was to introduce a new temporary variable. In diff -u format:

+#

+# register char *frombase = from;

+#

+# if (len == 1) {

+#- todo = *from;

+#+ register char c = *from;

+# while (count-- > 0)

+#- *to++ = todo;

+#+ *to++ = c;

+# return;

+# }

+#

+# This obscure bug was not found by the then test suite but instead

+# by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.

+#

+# jhi@iki.fi

+#

+print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n";

+########

+package TEST;

+

+sub TIEARRAY {

+ return bless [qw(foo fee fie foe)], $_[0];

+}

+sub FETCH {

+ my ($s,$i) = @_;

+ if ($i) {

+ goto bbb;

+ }

+bbb:

+ return $s->[$i];

+}

+

+package main;

+tie my @bar, 'TEST';

+print join('|', @bar[0..3]), "\n";

+EXPECT

+foo|fee|fie|foe

+print "1..29\n";

+# XXX known to leak scalars

+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;

+

+{

+ my $sortsub = \&backwards;

+ my $sortglob = *backwards;

+ my $sortglobr = \*backwards;

+ my $sortname = 'backwards';

+ @b = sort $sortsub 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");

+ @b = sort $sortglob 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");

+ @b = sort $sortname 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");

+ @b = sort $sortglobr 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");

+}

+

+{

+ local $sortsub = \&backwards;

+ local $sortglob = *backwards;

+ local $sortglobr = \*backwards;

+ local $sortname = 'backwards';

+ @b = sort $sortsub 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");

+ @b = sort $sortglob 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");

+ @b = sort $sortname 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");

+ @b = sort $sortglobr 4,1,3,2;

+ print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");

+}

+

+print "1..39\n";

+$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ||

+ $^O eq 'mpeix');

+# with implicit length argument

+print 'not ' unless (syswrite(O, $x) == 3);

+print "ok 29\n";

+

+# $a still intact

+print 'not ' unless ($x eq "abc");

+print "ok 30\n";

+

+# $outfile should have grown now

+if ($reopen) { # must close file to update EOF marker for stat

+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";

+}

+print 'not ' unless (-s $outfile == 10);

+print "ok 31\n";

+

+print 'not ' unless (sysread(I, $b, 100) == 10);

+print "ok 32\n";

+print 'not ' unless ($b eq '#!ererlabc');

+print "ok 33\n";

+print "ok 34\n";

+print "ok 35\n";

+print "ok 36\n";

+print "ok 37\n";

+print "ok 38\n";

+print "ok 39\n";

+ test 73, $!{ENOENT} ||

+ $! == 2 || # File not found

+ ($Is_Dos && $! == 22) ||

+ ($^O eq 'mint' && $! == 33);

+########

+

+# verify no leak when underlying object is selfsame tied variable

+my ($a, $b);

+sub Self::TIEHASH { bless $_[1], $_[0] }

+sub Self::DESTROY { $b = $_[0] + 0; }

+{

+ my %b5;

+ $a = \%b5 + 0;

+ tie %b5, 'Self', \%b5;

+}

+die unless $a == $b;

+EXPECT

+ length($data);

+print "1..29\n";

+$buf = "qwerty";

+@expect = (WRITE => $ob, $buf, 4);

+$data = "";

+$r = syswrite $fh,$buf,4;

+ok($r == 4);

+ok($data eq "qwer");

+

+$buf = "qwerty";

+@expect = (WRITE => $ob, $buf, 6);

+$data = "";

+$r = syswrite $fh,$buf;

+ok($r == 6);

+ok($data eq "qwerty");

+

+# tr.t

+

+print "1..4\n";

+

+$_ = "abcdefghijklmnopqrstuvwxyz";

+

+tr/a-z/A-Z/;

+

+print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";

+print "ok 1\n";

+

+tr/A-Z/a-z/;

+

+print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";

+print "ok 2\n";

+

+tr/b-y/B-Y/;

+

+print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";

+print "ok 3\n";

+

+# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.

+# Yes, discontinuities. Regardless, the \xca in the below should stay

+# untouched (and not became \x8a).

+

+$_ = "I\xcaJ";

+

+tr/I-J/i-j/;

+

+print "not " unless $_ eq "i\xcaj";

+print "ok 4\n";

+

+#

+print "1..23\n";

+

+eval { undef $1 };

+print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n";

+

+eval { $1 = undef };

+print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n";

+

+print "1..6\n";

+$^A = '';

+

+# more test

+

+format OUT3 =

+^<<<<<<...

+$foo

+.

+

+open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";

+

+$foo = 'fit ';

+write(OUT3);

+close OUT3;

+

+$right =

+"fit\n";

+

+if (`$CAT Op_write.tmp` eq $right)

+ { print "ok 6\n"; unlink 'Op_write.tmp'; }

+else

+ { print "not ok 6\n"; }

+