1#!/bin/bash 2# Usage: 3# for p in 5.6.2 5.8.9d 5.10.1 5.11.2; do make -q clean >/dev/null; perl$p Makefile.PL; t/testplc.sh -q -c; done 4# use the actual perl from the Makefile (perld, perl5.10.0, perl5.8.8, perl5.11.0, ...) 5function help { 6 echo "t/testplc.sh [OPTIONS] [1-$ntests]" 7 echo " -s skip all B:Debug, roundtrips and options" 8 echo " -S skip all roundtrips and options but -S and Concise" 9 echo " -c continue on errors" 10 echo " -o orig. no -Mblib. only for 5.6 and 5.8" 11 echo " -q quiet" 12 echo " -v avoid -MO,-qq" 13 echo " -h help" 14 echo "t/testplc.sh -q -s -c <=> perl -Mblib t/bytecode.t" 15 echo "Without arguments try all $ntests tests. Else the given test numbers." 16} 17 18# use the actual perl from the Makefile (perl5.8.8, 19# perl5.10.0d-nt, perl5.11.0, ...) 20PERL=`grep "^PERL =" Makefile|cut -c8-` 21PERL=${PERL:-perl} 22PERL=`echo $PERL|sed -e's,^",,; s,"$,,'` 23VERS=`echo $PERL|sed -e's,.*perl,,; s,.exe$,,'` 24D="`$PERL -e'print (($] < 5.007) ? q(256) : q(v))'`" 25v518=`$PERL -e'print (($] < 5.018)?0:1)'` 26 27function init { 28 # test what? core or our module? 29 Mblib="`$PERL -e'print (($] < 5.008) ? q() : q(-Iblib/arch -Iblib/lib))'`" 30 #Mblib=${Mblib:--Mblib} # B::C is now fully 5.6+5.8 backwards compatible 31 OCMD="$PERL $Mblib -MO=Bytecode," 32 QOCMD="$PERL $Mblib -MO=-qq,Bytecode," 33 ICMD="$PERL $Mblib -MByteLoader" 34 if [ "$D" = "256" ]; then QOCMD=$OCMD; fi 35 if [ "$Mblib" = " " ]; then VERS="${VERS}_global"; fi 36} 37 38function pass { 39 echo -e -n "\033[1;32mPASS \033[0;0m" 40 echo $* 41} 42function fail { 43 echo -e -n "\033[1;31mFAIL \033[0;0m" 44 echo $* 45} 46function bcall { 47 o=$1 48 opt=${2:-s} 49 ext=${3:-plc} 50 optf=$(echo $opt|sed 's/,-//g') 51 [ -n "$Q" ] || echo ${QOCMD}-$opt,-o${o}${optf}_${VERS}.${ext} ${o}.pl 52 ${QOCMD}-$opt,-o${o}${optf}_${VERS}.${ext} ${o}.pl 53} 54function btest { 55 n=$1 56 o="bytecode$n" 57 if [ -z "$2" ]; then 58 if [ "$n" = "08" ]; then n=8; fi 59 if [ "$n" = "09" ]; then n=9; fi 60 echo "${tests[${n}]}" > ${o}.pl 61 test -z "${tests[${n}]}" && exit 62 str="${tests[${n}]}" 63 else 64 echo "$2" > ${o}.pl 65 fi 66 #bcall ${o} O6 67 rm ${o}_s_${VERS}.plc 2>/dev/null 68 69 # annotated assembler 70 if [ -z "$SKIP" -o -n "$SKI" ]; then 71 if [ "$Mblib" != " " ]; then 72 bcall ${o} S,-s asm 1 73 bcall ${o} S,-k asm 1 74 bcall ${o} S,-i,-b asm 1 75 fi 76 fi 77 if [ "$Mblib" != " " -a -z "$SKIP" ]; then 78 m=${o}s_${VERS} 79 rm ${m}.disasm ${o}_${VERS}.concise ${o}_${VERS}.dbg 2>/dev/null 80 bcall ${o} s 81 [ -n "$Q" ] || echo $PERL $Mblib script/disassemble $m.plc \> ${m}.disasm 82 $PERL $Mblib script/disassemble $m.plc > ${m}.disasm 83 [ -n "$Q" ] || echo ${ICMD} ${m}.plc 84 res=$(${ICMD} ${m}.plc) 85 if [ "X${result[$n]}" = "X" ]; then result[$n]='ok'; fi 86 if [ "X$res" != "X${result[$n]}" ]; then 87 fail "./${m}.plc" "'$str' => '$res' Expected: '${result[$n]}'" 88 fi 89 90 # understand annotations 91 m=${o}S_${VERS} 92 [ -n "$Q" ] || echo $PERL $Mblib script/assemble ${o}s_${VERS}.disasm \> $m.plc 93 $PERL $Mblib script/assemble ${o}s_${VERS}.disasm > $m.plc 94 # full assembler roundtrips 95 [ -n "$Q" ] || echo $PERL $Mblib script/disassemble $m.plc \> $m.disasm 96 $PERL $Mblib script/disassemble $m.plc > $m.disasm 97 md=${o}SD_${VERS} 98 [ -n "$Q" ] || echo $PERL $Mblib script/assemble $m.disasm \> ${md}.plc 99 $PERL $Mblib script/assemble $m.disasm > ${md}.plc 100 [ -n "$Q" ] || echo $PERL $Mblib script/disassemble ${md}.plc \> ${o}SDS_${VERS}.disasm 101 $PERL $Mblib script/disassemble ${md}.plc > ${o}SDS_${VERS}.disasm 102 103 bcall ${o} i,-b 104 m=${o}ib_${VERS} 105 $PERL $Mblib script/disassemble ${m}.plc > ${m}.disasm 106 [ -n "$Q" ] || echo ${ICMD} ${m}.plc 107 res=$(${ICMD} ${m}.plc) 108 if [ "X$res" = "X${result[$n]}" ]; then 109 pass "./${m}.plc" "=> '$res'" 110 else 111 fail "./${m}.plc" "'$str' => '$res' Expected: '${result[$n]}'" 112 fi 113 114 bcall ${o} k 115 m=${o}k_${VERS} 116 $PERL $Mblib script/disassemble ${m}.plc > ${m}.disasm 117 [ -n "$Q" ] || echo ${ICMD} ${m}.plc 118 res=$(${ICMD} ${m}.plc) 119 if [ "X$res" != "X${result[$n]}" ]; then 120 fail "./${m}.plc" "'$str' => '$res' Expected: '${result[$n]}'" 121 fi 122 123 [ -n "$Q" ] || echo $PERL $Mblib -MO=${qq}Debug,-exec ${o}.pl -o ${o}_${VERS}.dbg 124 [ -n "$Q" ] || $PERL $Mblib -MO=${qq}Debug,-exec ${o}.pl > ${o}_${VERS}.dbg 125 fi 126 if [ -z "$SKIP" -o -n "$SKI" ]; then 127 # 5.8 has a bad concise 128 [ -n "$Q" ] || echo $PERL $Mblib -MO=${qq}Concise,-exec ${o}.pl -o ${o}_${VERS}.concise 129 $PERL $Mblib -MO=${qq}Concise,-exec ${o}.pl > ${o}_${VERS}.concise 130 fi 131 if [ -z "$SKIP" ]; then 132 if [ "$Mblib" != " " ]; then 133 #bcall ${o} TI 134 bcall ${o} H 135 m="${o}H_${VERS}" 136 [ -n "$Q" ] || echo $PERL $Mblib ${m}.plc 137 res=$($PERL $Mblib ${m}.plc) 138 if [ "X$res" != "X${result[$n]}" ]; then 139 fail "./${m}.plc" "'$str' => '$res' Expected: '${result[$n]}'" 140 fi 141 fi 142 fi 143 if [ "$Mblib" != " " ]; then 144 # -s ("scan") should be the new default 145 [ -n "$Q" ] || echo ${OCMD}-s,-o${o}.plc ${o}.pl 146 ${OCMD}-s,-o${o}.plc ${o}.pl || (test -z $CONT && exit) 147 else 148 # No -s with 5.6 149 [ -n "$Q" ] || echo ${OCMD}-o${o}.plc ${o}.pl 150 ${OCMD}-o${o}.plc ${o}.pl || (test -z $CONT && exit) 151 fi 152 [ -n "$Q" ] || echo $PERL $Mblib script/disassemble ${o}.plc -o ${o}.disasm 153 $PERL $Mblib script/disassemble ${o}.plc > ${o}.disasm 154 [ -n "$Q" ] || echo ${ICMD} ${o}.plc 155 res=$(${ICMD} ${o}.plc) 156 if [ "X$res" = "X${result[$n]}" ]; then 157 pass "./${o}.plc" "=> '$res'" 158 else 159 fail "./${o}.plc" "'$str' => '$res' Expected: '${result[$n]}'" 160 if [ -z "$Q" ]; then 161 echo -n "Again with -Dv? (or Ctrl-Break)" 162 read 163 echo ${ICMD} -D$D ${o}.plc; ${ICMD} -D$D ${o}.plc 164 fi 165 test -z $CONT && exit 166 fi 167} 168 169ntests=350 170declare -a tests[$ntests] 171declare -a result[$ntests] 172tests[1]="print 'hi'" 173result[1]='hi' 174tests[2]='for (1,2,3) { print if /\d/ }' 175result[2]='123' 176tests[3]='$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/ge; print $_' 177result[3]='zzz2y2y2' 178tests[4]='$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/g; print $_' 179if [[ $v518 -gt 0 ]]; then result[4]='zzz2y2y2'; else result[4]='z2y2y2'; fi 180tests[5]='print split /a/,"bananarama"' 181result[5]='bnnrm' 182tests[6]="{package P; sub x {print 'ya'} x}" 183result[6]='ya' 184tests[7]='@z = split /:/,"b:r:n:f:g"; print @z' 185result[7]='brnfg' 186tests[8]='sub AUTOLOAD { print 1 } &{"a"}()' 187result[8]='1' 188tests[9]='my $l = 3; $x = sub { print $l }; &$x' 189result[9]='3' 190tests[10]='my $i = 1; 191my $foo = sub { 192 $i = shift if @_ 193}; print $i; 194print &$foo(3),$i;' 195result[10]='133' 196# index: do fbm_compile or not 197tests[11]='$x="Cannot use"; print index $x, "Can"' 198result[11]='0' 199tests[12]='my $i=6; eval "print \$i\n"' 200result[12]='6' 201tests[13]='BEGIN { %h=(1=>2,3=>4) } print $h{3}' 202result[13]='4' 203tests[14]='open our $T,"a"; print "ok";' 204result[14]='ok' 205tests[15]='print <DATA> 206__DATA__ 207a 208b' 209result[15]='a 210b' 211tests[16]='BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}}; print $a[1]' 212result[16]='1' 213tests[17]='my $i=3; print 1 .. $i' 214result[17]='123' 215# custom key sort 216tests[18]='my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h' 217result[18]='ba' 218# fool the sort optimizer by my $p 219tests[19]='print sort { my $p; $b <=> $a } 1,4,3' 220result[19]='431' 221# not repro: something like this is broken in original 5.6 (Net::DNS::ZoneFile::Fast) 222# see new test 33 223tests[20]='$a="abcd123";my $r=qr/\d/;print $a =~ $r;' 224result[20]='1' 225# broken on early alpha and 5.10: run-time labels. 226tests[21]='sub skip_on_odd{next NUMBER if $_[0]% 2}NUMBER:for($i=0;$i<5;$i++){skip_on_odd($i);print $i;}' 227result[21]='024' 228# broken in original perl 5.6 229tests[22]='my $fh; BEGIN { open($fh,"<","/dev/null"); } print "ok";'; 230# broken in perl 5.8 231tests[23]='package MyMod; our $VERSION = 1.3; print "ok";' 232# works in original perl 5.6, broken with latest B::C in 5.6, 5.8 233tests[24]='sub level1{return(level2()?"fail":"ok")} sub level2{0} print level1();' 234# enforce custom ncmp sort and count it. fails as CC in all. How to enforce icmp? 235# <=5.6 qsort needs two more passes here than >=5.8 merge_sort 236# 5.12 got it backwards and added 4 more passes. 237tests[25]='print sort { $i++; $b <=> $a } 1..4' 238result[25]="4321" 239# lvalue sub 240tests[26]='sub a:lvalue{my $a=26; ${\(bless \$a)}}sub b:lvalue{${\shift}}; print ${a(b)}'; 241result[26]="26" 242# xsub constants (constant folded). newlib: 0x200, glibc: 0x100 243tests[27]='use Fcntl ();my $a=Fcntl::O_CREAT(); print "ok" if ( $a >= 64 && &Fcntl::O_CREAT >= 64 );' 244# require $fname 245tests[28]='my($fname,$tmp_fh);while(!open($tmp_fh,">",($fname=q{ccode28_} . rand(999999999999)))){$bail++;die "Failed to create a tmp file after 500 tries" if $bail>500;}print {$tmp_fh} q{$x="ok";1;};close($tmp_fh);sleep 1;require $fname;END{unlink($fname);};print $x;' 246# multideref with static index and sv and dynamic gv ptrs 247tests[29]='my (%b,%h); BEGIN { %b=(1..8);@a=(1,2,3,4); %h=(1=>2,3=>4) } $i=0; my $l=-1; print $h->{$b->{3}},$h->{$a[-1]},$a[$i],$a[$l],$h{3}' 248result[29]='144' 249# special old IO handling 250tests[291]='use IO;print "ok"' 251# run-time context of .., fails in CC 252tests[30]='@a=(4,6,1,0,0,1);sub range{(shift @a)..(shift @a)}print range();while(@a){print scalar(range())}' 253result[30]='456123E0' 254# AUTOLOAD w/o goto xsub 255tests[31]='package MockShell;sub AUTOLOAD{my $p=$AUTOLOAD;$p=~s/.*:://;print(join(" ",$p,@_),";");} package main; MockShell::date();MockShell::who("am","i");MockShell::ls("-l");' 256result[31]='date;who am i;ls -l;' 257# CC entertry/jmpenv_jump/leavetry 258tests[32]='eval{print "1"};eval{die 1};print "2";' 259result[32]='12' 260# C qr test was broken in 5.6 -- needs to load an actual file to test. See test 20. 261# used to error with Can't locate object method "save" via package "U??WVS?-" (perhaps you forgot to load "U??WVS?-"?) at /usr/lib/perl5/5.6.2/i686-linux/B/C.pm line 676. 262# fails with new constant only. still not repro (r-magic probably) 263tests[33]='BEGIN{unshift @INC,("t");} use qr_loaded_module; print "ok" if qr_loaded_module::qr_called_in_sub("name1")' 264# init of magic hashes. %ENV has e magic since a0714e2c perl.c 265# (Steven Schubiger 2006-02-03 17:24:49 +0100 3967) i.e. 5.8.9 but not 5.8.8 266tests[34]='my $x=$ENV{TMPDIR};print "ok"' 267# static method_named. fixed with 1.16 268tests[35]='package dummy;my $i=0;sub meth{print $i++};package main;dummy->meth(1);my dummy $o = bless {},"dummy";$o->meth("const");my $meth="meth";$o->$meth("const");dummy->$meth("const");dummy::meth("dummy","const")' 269result[35]='01234' 270# HV self-ref 271tests[36]='my ($rv, %hv); %hv = ( key => \$rv ); $rv = \%hv; print "ok";' 272# AV self-ref 273tests[37]='my ($rv, @av); @av = ( \$rv ); $rv = \@av; print "ok";' 274# constant autoload loop crash test 275tests[38]='for(1 .. 1024) { if (open(my $null_fh,"<","/dev/null")) { seek($null_fh,0,SEEK_SET); close($null_fh); $ok++; } }if ($ok == 1024) { print "ok"; }' 276# check re::is_regexp, and on 5.12 if being upgraded to SVt_REGEXP 277usere="`$PERL -e'print (($] < 5.011) ? q(use re;) : q())'`" 278tests[39]=$usere'$a=qr/x/;print ($] < 5.010?1:re::is_regexp($a))' 279result[39]='1' 280# String with a null byte -- used to generate broken .c on 5.6.2 with static pvs 281tests[40]='my $var="this string has a null \\000 byte in it";print "ok";' 282# Shared scalar, n magic. => Don't know how to handle magic of type \156. 283usethreads="`$PERL -MConfig -e'print ($Config{useithreads} ? q(use threads;) : q())'`" 284#usethreads='BEGIN{use Config; unless ($Config{useithreads}) {print "ok"; exit}} ' 285#;threads->create(sub{$s="ok"})->join; 286# not yet testing n, only P 287tests[41]=$usethreads'use threads::shared;{my $s="ok";share($s);print $s}' 288# Shared aggregate, P magic 289tests[42]=$usethreads'use threads::shared;my %h : shared; print "ok"' 290# Aggregate element, n + p magic 291tests[43]=$usethreads'use threads::shared;my @a : shared; $a[0]="ok"; print $a[0]' 292# perl #72922 (5.11.4 fails with magic_killbackrefs) 293tests[44]='use Scalar::Util "weaken";my $re1=qr/foo/;my $re2=$re1;weaken($re2);print "ok" if $re3=qr/$re1/;' 294# test dynamic loading 295tests[45]='use Data::Dumper ();Data::Dumper::Dumpxs({});print "ok";' 296# issue 79: Exporter:: stash missing in main:: 297#tests[46]='use Exporter; if (exists $main::{"Exporter::"}) { print "ok"; }' 298tests[46]='use Exporter; print "ok" if %main::Exporter::' 299#tests[46]='use Exporter; print "ok" if scalar(keys(%main::Exporter::)) > 2' 300# non-tied av->MAGICAL 301tests[47]='@ISA=(q(ok));print $ISA[0];' 302# END block del_backref with bytecode only 303tests[48]='my $s=q{ok};END{print $s}' 304# even this failed until r1000, overlarge AvFILL=3 endav 305#tests[48]='print q(ok);END{}' 306# no-fold 307tests[49]='print q(ok) if "test" =~ /es/i;' 308# @ISA issue 64 309tests[50]='package Top;sub top{q(ok)};package Next;our @ISA=qw(Top);package main;print Next->top();' 310# XXX TODO sigwarn $w = B::NULL without -v 311tests[51]='$SIG{__WARN__}=sub{print "ok"};warn 1;' 312# check if general signals work 313tests[511]='BEGIN{$SIG{USR1}=sub{$w++;};} kill USR1 => $$; print q(ok) if $w' 314tests[68]='package A;sub test{use Data::Dumper();$_ =~ /^(.*?)\d+$/;"Some::Package"->new();}print q(ok);' 315#------------- 316# issue27 317tests[70]='require LWP::UserAgent;print q(ok);' 318# issue24 319tests[71]='dbmopen(%H,q(f),0644);print q(ok);' 320tests[81]='%int::; #create int package for types 321sub x(int,int) { @_ } #cvproto 322my $o = prototype \&x; 323if ($o eq "int,int") {print "o"}else{print $o}; 324sub y($) { @_ } #cvproto 325my $p = prototype \&y; 326if ($p eq q($)) {print "k"}else{print $p}; 327require bytes; 328sub my::length ($) { # possible prototype mismatch vs _ 329 if ( bytes->can(q(length)) ) { 330 *length = *bytes::length; 331 goto &bytes::length; 332 } 333 return CORE::length( $_[0] ); 334} 335print my::length($p);' 336result[81]='ok1' 337tests[90]='my $s = q(test string); 338$s =~ s/(?<first>test) (?<second>string)/\2 \1/g; 339print q(o) if $s eq q(string test); 340q(test string) =~ /(?<first>\w+) (?<second>\w+)/; 341print q(k) if $+{first} eq q(test);' 342tests[901]='my %errs = %!; # t/op/magic.t Errno compiled in 343print q(ok) if defined ${"!"}{ENOENT};' 344tests[902]='my %errs = %{"!"}; # t/op/magic.t Errno to be loaded at run-time 345print q(ok) if defined ${"!"}{ENOENT};' 346# issue #199 347tests[903]='"abc" =~ /(.)./; print "ok" if "21" eq join"",@+;' 348# issue #220 349tests[904]='my $content = "ok\n"; 350while ( $content =~ m{\w}g ) { 351 $_ .= "$-[0]$+[0]"; 352} 353print "ok" if $_ eq "0112";' 354# IO handles 355tests[91]='# issue59 356use strict; 357use warnings; 358use IO::Socket; 359my $remote = IO::Socket::INET->new( Proto => "tcp", PeerAddr => "perl.org", PeerPort => "80" ); 360print $remote "GET / HTTP/1.0" . "\r\n\r\n"; 361my $result = <$remote>; 362$result =~ m|HTTP/1.1 200 OK| ? print "ok" : print $result; 363close $remote;' 364tests[93]='#SKIP 365my ($pid, $out, $in); 366BEGIN { 367 local(*FPID); 368 $pid = open(FPID, "echo <<EOF |"); # DIE 369 open($out, ">&STDOUT"); # EASY 370 open(my $tmp, ">", "pcc.tmp"); # HARD to get filename, WARN 371 print $tmp "test\n"; 372 close $tmp; # OK closed 373 open($in, "<", "pcc.tmp"); # HARD to get filename, WARN 374} 375# === run-time === 376print $out "o"; 377kill 0, $pid; # BAD! warn? die? 378print "k" if "test" eq read $in, my $x, 4; 379unlink "pcc.tmp"; 380' 381result[93]='o' 382tests[931]='my $f;BEGIN{open($f,"<README");}read $f,my $in, 2; print "ok"' 383tests[932]='my $f;BEGIN{open($f,">&STDOUT");}print $f "ok"' 384tests[95]='use IO::Socket::SSL(); 385my IO::Handle $handle = IO::Socket::SSL->new(SSL_verify_mode =>0); 386$handle->blocking(0); 387print "ok";' 388tests[96]='defined(&B::OP::name) || print q(ok)' 389tests[97]='use v5.12; print q(ok);' 390result[97]='ok' 391tests[971]='use v5.6; print q(ok);' 392result[971]='ok' 393tests[98]='BEGIN{$^H{feature_say} = 1;} 394sub test { eval(""); } 395print q(ok);' 396result[98]='ok' 397tests[105]='package A; use Storable qw/dclone/; my $a = \""; dclone $a; print q(ok);' 398result[105]='ok' 399if [[ $v518 -gt 0 ]]; then 400 tests[130]='no warnings "experimental::lexical_subs";use feature "lexical_subs";my sub p{q(ok)}; my $a=\&p;print p;' 401fi 402tests[135]='"to" =~ /t(?{ print "ok"})o/;' 403tests[138]='print map { chr $_ } qw/97 98 99/;' 404result[138]='abc' 405tests[140]='my %a;print "ok" if !%a;' 406#tests[141]='print "ok" if "1" > 0' 407tests[141]='@x=(0..1);print "ok" if $#x == "1"' 408tests[142]='$_ = "abc\x{1234}";chop;print "ok" if $_ eq "abc"' 409tests[143]='BEGIN { 410 package Net::IDN::Encode; 411 our $DOT = qr/[\.]/; #works with my! 412 my $RE = qr/xx/; 413 sub domain_to_ascii { 414 my $x = shift || ""; 415 $x =~ m/$RE/o; 416 return split( qr/($DOT)/o, $x); 417 } 418} 419package main; 420Net::IDN::Encode::domain_to_ascii(42); 421print "ok\n";' 422tests[1431]='BEGIN{package Foo;our $DOT=qr/[.]/;};package main;print "ok\n" if "dot.dot" =~ m/($Foo::DOT)/' 423tests[1432]='BEGIN{$DOT=qr/[.]/}print "ok\n" if "dot.dot" =~ m/($DOT)/' 424tests[144]='print index("long message\0xx","\0")' 425result[144]='12' 426tests[145]='my $bits = 0; for (my $i = ~0; $i; $i >>= 1) { ++$bits; }; print $bits' 427result[145]=`$PERL -MConfig -e'print 8*$Config{ivsize}'` 428tests[146]='my $a = v120.300; my $b = v200.400; $a ^= $b; print sprintf("%vd", $a);' 429result[146]='176.188' 430tests[148]='open(FH, ">", "ccode148i.tmp"); print FH "1\n"; close FH; print -s "ccode148i.tmp"' 431result[148]='2' 432tests[149]='format Comment = 433ok 434. 435 436{ 437 local $~ = "Comment"; 438 write; 439}' 440tests[150]='print NONEXISTENT "foo"; print "ok" if $! == 9' 441tests[1501]='$! = 0; print NONEXISTENT "foo"; print "ok" if $! == 9' 442tests[152]='print "ok" if find PerlIO::Layer "perlio"' 443tests[154]='$SIG{__WARN__} = sub { die "warning: $_[0]" }; opendir(DIR, ".");closedir(DIR);print q(ok)' 444tests[156]='use warnings; 445no warnings qw(portable); 446use XSLoader; 447XSLoader::load() if $ENV{force_xsloader}; # trick for perlcc to force xloader to be compiled 448{ 449 my $q = 12345678901; 450 my $x = sprintf("%llx", $q); 451 print "ok\n" if hex $x == 0x2dfdc1c35; 452 exit; 453}' 454tests[157]='$q = 18446744073709551615;print scalar($q)."\n";print scalar(18446744073709551615)."\n";' 455result[157]='18446744073709551615 45618446744073709551615' 457tests[1571]='my $a = 9223372036854775807; print "ok\n" if ++$a == 9223372036854775808;' 458# duplicate of 148 459tests[158]='open W, ">ccodetmp" or die "1: $!";print W "foo";close W;open R, "ccodetmp" or die "2: $!";my $e=eof R ? 1 : 0;close R;print "$e\n";' 460result[158]='0' 461tests[159]='@X::ISA = "Y"; sub Y::z {"Y::z"} print "ok\n" if X->z eq "Y::z"; delete $X::{z}; exit' 462# see 188 463tests[160]='sub foo { (shift =~ m?foo?) ? 1 : 0 } 464print "ok\n";' 465tests[161]='sub PVBM () { foo } { my $dummy = index foo, PVBM } print PVBM' 466result[161]='foo' 467# duplicate of 142 468tests[162]='$x = "\x{1234}"; print "ok\n" if ord($x) == 0x1234;' 469tests[163]='# WontFix 470my $destroyed = 0; 471sub X::DESTROY { $destroyed = 1 } 472{ 473 my $x; 474 BEGIN {$x = sub { } } 475 $x = bless {}, 'X'; 476} 477print qq{ok\n} if $destroyed == 1;' 478# duplicate of 148 479tests[164]='open(DUPOUT,">&STDOUT");close(STDOUT);open(F,">&DUPOUT");print F "ok\n";' 480tests[165]='use warnings; 481sub recurse1 { 482 unshift @_, "x"; 483 no warnings "recursion"; 484 goto &recurse2; 485} 486sub recurse2 { 487 my $x = shift; 488 $_[0] ? +1 + recurse1($_[0] - 1) : 0 489} 490print "ok\n" if recurse1(500) == 500;' 491tests[166]='my $ok = 1; 492foreach my $chr (60, 200, 600, 6000, 60000) { 493 my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); 494 chop($key, $value); 495 my %utf8c = ( $key => $value ); 496 my $tempval = sprintf q($utf8c{"\x{%x}"}), $chr; 497 my $ev = eval $tempval; 498 $ok = 0 if !$ev or $ev ne $value; 499} print "ok" if $ok' 500tests[167]='$a = "a\xFF\x{100}"; 501eval {$b = crypt($a, "cd")}; 502print $@;' 503result[167]='Wide character in crypt at ccode167.pl line 2.' 504tests[168]='my $start_time = time; 505eval { 506 local $SIG{ALRM} = sub { die "ALARM !\n" }; 507 alarm 1; 508 # perlfunc recommends against using sleep in combination with alarm. 509 1 while (time - $start_time < 3); 510}; 511alarm 0; 512print $@; 513print "ok\n" if $@ eq "ALARM !\n";' 514result[168]='ALARM ! 515ok' 516tests[169]='#TODO Attribute::Handlers 517package MyTest; 518use Attribute::Handlers; 519sub Check :ATTR { 520 print "called\n"; 521 print "ok\n" if ref $_[4] eq "ARRAY" && join(",", @{$_[4]}) eq join(",", qw/a b c/); 522} 523sub a_sub :Check(qw/a b c/) { 524 return 42; 525} 526print a_sub()."\n";' 527result[169]='called 528ok 52942' 530tests[170]='eval "sub xyz (\$) : bad ;"; print "~~~~\n$@~~~~\n"' 531result[170]='~~~~ 532Invalid CODE attribute: bad at (eval 1) line 1. 533BEGIN failed--compilation aborted at (eval 1) line 1. 534~~~~' 535tests[172]='package Foo; 536use overload q("") => sub { "Foo" }; 537package main; 538my $foo = bless {}, "Foo"; 539print "ok " if "$foo" eq "Foo"; 540print "$foo\n";' 541result[172]='ok Foo' 542tests[173]='# WontFix 543use constant BEGIN => 42; print "ok 1\n" if BEGIN == 42; 544use constant INIT => 42; print "ok 2\n" if INIT == 42; 545use constant CHECK => 42; print "ok 3\n" if CHECK == 42;' 546result[173]='Prototype mismatch: sub main::BEGIN () vs none at ./ccode173.pl line 2. 547Constant subroutine BEGIN redefined at ./ccode173.pl line 2. 548ok 1 549ok 2 550ok 3' 551tests[174]=' 552my $str = "\x{10000}\x{800}"; 553no warnings "utf8"; 554{ use bytes; $str =~ s/\C\C\z//; } 555my $ref = "\x{10000}\0"; 556print "ok 1\n" if ~~$str eq $ref; 557$str = "\x{10000}\x{800}"; 558{ use bytes; $str =~ s/\C\C\z/\0\0\0/; } 559my $ref = "\x{10000}\0\0\0\0"; 560print "ok 2\n" if ~~$str eq $ref;' 561result[174]='ok 1 562ok 2' 563tests[175]='{ 564 # note that moving the use in an eval block solve the problem 565 use warnings NONFATAL => all; 566 $SIG{__WARN__} = sub { "ok - expected warning\n" }; 567 my $x = pack( "I,A", 4, "X" ); 568 print "ok\n"; 569}' 570result[175]='ok - expected warning 571ok' 572tests[176]='use Math::BigInt; print Math::BigInt::->new(5000000000);' 573result[176]='5000000000' 574tests[177]='use version; print "ok\n" if version::is_strict("4.2");' 575tests[178]='BEGIN { $hash = { pi => 3.14, e => 2.72, i => -1 } ;} print scalar keys $hash;' 576result[178]='3' 577tests[179]='#TODO smartmatch subrefs 578{ 579 package Foo; 580 sub new { bless {} } 581} 582package main; 583our $foo = Foo->new; 584our $bar = $foor; # required to generate the wrong behavior 585my $match = eval q($foo ~~ undef) ? 1 : 0; 586print "match ? $match\n";' 587result[179]='match ? 0' 588tests[180]='use feature "switch"; use integer; given(3.14159265) { when(3) { print "ok\n"; } }' 589tests[181]='sub End::DESTROY { $_[0]->() }; 590my $inx = "OOOO"; 591$SIG{__WARN__} = sub { print$_[0] . "\n" }; 592{ 593 $@ = "XXXX"; 594 my $e = bless( sub { die $inx }, "End") 595} 596print q(ok)' 597tests[182]='#TODO stash-magic delete renames to ANON 598my @c; sub foo { @c = caller(0); print $c[3] } my $fooref = delete $::{foo}; $fooref -> ();' 599result[182]='main::__ANON__' 600tests[183]='main->import(); print q(ok)' 601tests[184]='use warnings; 602sub xyz { no warnings "redefine"; *xyz = sub { $a <=> $b }; &xyz } 603eval { @b = sort xyz 4,1,3,2 }; 604print defined $b[0] && $b[0] == 1 && $b[1] == 2 && $b[2] == 3 && $b[3] == 4 ? "ok\n" : "fail\n"; 605exit; 606{ 607 package Foo; 608 use overload (qw("" foo)); 609} 610{ 611 package Bar; 612 no warnings "once"; 613 sub foo { $ENV{fake} } 614} 615' 616# usage: t/testc.sh -O3 -Dp,-UCarp 185 617tests[185]='my $a=pack("U",0xFF);use bytes;print "not " unless $a eq "\xc3\xbf" && bytes::length($a) == 2; print "ok\n";' 618tests[186]='eval q/require B/; my $sub = do { package one; \&{"one"}; }; delete $one::{one}; my $x = "boom"; print "ok\n";' 619# duplicate of 182 620tests[187]='my $glob = \*Phoo::glob; undef %Phoo::; print ( ( "$$glob" eq "*__ANON__::glob" ) ? "ok\n" : "fail with $$glob\n" );' 621tests[188]='package aiieee;sub zlopp {(shift =~ m?zlopp?) ? 1 : 0;} sub reset_zlopp {reset;} 622package main; print aiieee::zlopp(""), aiieee::zlopp("zlopp"), aiieee::zlopp(""), aiieee::zlopp("zlopp"); 623aiieee::reset_zlopp(); print aiieee::zlopp("zlopp")' 624result[188]='01001' 625tests[191]='# WontFix 626BEGIN{sub plan{42}} {package Foo::Bar;} print((exists $Foo::{"Bar::"} && $Foo::{"Bar::"} eq "*Foo::Bar::") ? "ok\n":"bad\n"); plan(fake=>0);' 627tests[192]='use warnings; 628{ 629 no warnings qw "once void"; 630 my %h; # We pass a key of this hash to the subroutine to get a PVLV. 631 sub { for(shift) { 632 # Set up our glob-as-PVLV 633 $_ = *hon; 634 # Assigning undef to the glob should not overwrite it... 635 { 636 my $w; 637 local $SIG{__WARN__} = sub { $w = shift }; 638 *$_ = undef; 639 print ( $w =~ m/Undefined value assigned to typeglob/ ? "ok" : "not ok"); 640 } 641 }}->($h{k}); 642}' 643tests[193]='unlink q{not.a.file}; $! = 0; open($FOO, q{not.a.file}); print( $! ne 0 ? "ok" : q{error: $! should not be 0}."\n"); close $FOO;' 644tests[194]='$0 = q{ccdave with long name}; #print "pid: $$\n"; 645$s=`ps w | grep "$$" | grep "[c]cdave"`; 646print ($s =~ /ccdave with long name/ ? q(ok) : $s);' 647tests[1941]='$0 = q{ccdave}; #print "pid: $$\n"; 648$s=`ps auxw | grep "$$" | grep "ccdave"|grep -v grep`; 649print q(ok) if $s =~ /ccdave/' 650# duplicate of 152 651tests[195]='use PerlIO; eval { require PerlIO::scalar }; find PerlIO::Layer "scalar"; print q(ok)' 652tests[196]='package Foo; 653sub new { bless {}, shift } 654DESTROY { $_[0] = "foo" } 655package main; 656eval q{\\($x, $y, $z) = (1, 2, 3);}; 657my $m; 658$SIG{__DIE__} = sub { $m = shift }; 659{ my $f = Foo->new } 660print "m: $m\n";' 661result[196]='m: Modification of a read-only value attempted at ccode196.pl line 3.' 662tests[197]='package FINALE; 663{ 664 $ref3 = bless ["ok - package destruction"]; 665 my $ref2 = bless ["ok - lexical destruction\n"]; 666 local $ref1 = bless ["ok - dynamic destruction\n"]; 667 1; 668} 669DESTROY { 670 print $_[0][0]; 671}' 672result[197]='ok - dynamic destruction 673ok - lexical destruction 674ok - package destruction' 675# duplicate of 150 676tests[198]='{ 677 open(my $NIL, qq{|/bin/echo 23}) or die "fork failed: $!"; 678 $! = 1; 679 close $NIL; 680 if($! == 5) { print} 681}' 682result[198]='23' 683# duplicate of 90 684tests[199]='"abc" =~ /(.)./; print @+; print "end\n"' 685result[199]='21end' 686tests[200]='%u=("\x{123}"=>"fo"); print "ok" if $u{"\x{123}"} eq "fo"' 687tests[2001]='BEGIN{%u=("\x{123}"=>"fo");} print "ok" if $u{"\x{123}"} eq "fo";' 688tests[201]='use Storable;*Storable::CAN_FLOCK=sub{1};print qq{ok\n}' 689tests[2011]='sub can {require Config; import Config;return $Config{d_flock}} 690use IO::File; 691can(); 692print "ok\n";' 693tests[203]='#TODO perlio layers 694use open(IN => ":crlf", OUT => ":encoding(cp1252)"); 695open F, "<", "/dev/null"; 696my %l = map {$_=>1} PerlIO::get_layers(F, input => 1); 697print $l{crlf} ? q(ok) : keys(%l);' 698# issue 29 699tests[2900]='use open qw(:std :utf8); 700BEGIN{ `echo ö > xx.bak`; } 701open X, "xx.bak"; 702$_ = <X>; 703print unpack("U*", $_), " "; 704print $_ if /\w/;' 705result[2900]='24610 ö' 706tests[207]='use warnings; 707sub asub { } 708asub(tests => 48); 709my $str = q{0}; 710$str =~ /^[ET1]/i; 711{ 712 no warnings qw<io deprecated>; 713 print "ok 1\n" if opendir(H, "t"); 714 print "ok 2" if open(H, "<", "TESTS"); 715}' 716result[207]='ok 1 717ok 2' 718tests[208]='sub MyKooh::DESTROY { print "${^GLOBAL_PHASE} MyKooh " } my $my =bless {}, MyKooh; 719sub OurKooh::DESTROY { print "${^GLOBAL_PHASE} OurKooh" }our $our=bless {}, OurKooh;' 720if [[ `$PERL -e'print (($] < 5.014)?0:1)'` -gt 0 ]]; then 721 result[208]='RUN MyKooh DESTRUCT OurKooh' 722else 723 result[208]=' MyKooh OurKooh' 724fi 725tests[210]='$a = 123; 726package xyz; 727sub xsub {bless [];} 728$x1 = 1; $x2 = 2; 729$s = join(":", sort(keys %xyz::)); 730package abc; 731my $foo; 732print $xyz::s' 733result[210]='s:x1:x2:xsub' 734tests[212]='$blurfl = 123; 735{ 736 package abc; 737 $blurfl = 5; 738} 739$abc = join(":", sort(keys %abc::)); 740package abc; 741print "variable: $blurfl\n"; 742print "eval: ". eval q/"$blurfl\n"/; 743package main; 744sub ok { 1 }' 745result[212]='variable: 5 746eval: 5' 747tests[214]=' 748my $expected = "foo"; 749sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) } 750$_ = $expected; 751check; 752undef $expected; 753✓ # $_ not passed' 754result[214]='ok 755ok' 756tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";' 757result[215]=':t3 758:' 759tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}' 760# multideref, also now a 29 761tests[219]='my (%b,%h); BEGIN { %b=(1..8);@a=(1,2,3,4); %h=(1=>2,3=>4) } $i=0; my $l=-1; print $h->{$b->{3}},$h->{$a[-1]},$a[$i],$a[$l],$h{3}' 762result[219]='144' 763# also at 904 764tests[220]=' 765my $content = "ok\n"; 766while ( $content =~ m{\w}g ) { 767 $_ .= "$-[0]$+[0]"; 768} 769print "ok" if $_ eq "0112";' 770tests[223]='use strict; eval q({ $x = sub }); print $@' 771result[223]='Illegal declaration of anonymous subroutine at (eval 1) line 1.' 772tests[224]='use bytes; my $p = "\xB6"; my $u = "\x{100}"; my $pu = "\xB6\x{100}"; print ( $p.$u eq $pu ? "ko\n" : "ok\n" );' 773tests[225]='$_ = $dx = "\x{10f2}"; s/($dx)/$dx$1/; $ok = 1 if $_ eq "$dx$dx"; $_ = $dx = "\x{10f2}"; print qq{end\n};' 774result[225]='end' 775tests[226]='# WontFix 776@INC = (); dbmopen(%H, $file, 0666)' 777result[226]='No dbm on this machine at -e line 1.' 778tests[227]='open IN, "/dev/null" or die $!; *ARGV = *IN; foreach my $x (<>) { print $x; } close IN; print qq{ok\n}' 779tests[229]='sub yyy () { "yyy" } print "ok\n" if( eval q{yyy} eq "yyy");' 780#issue 30 781tests[230]='sub f1 { my($self) = @_; $self->f2;} sub f2 {} sub new {} print "@ARGV\n";' 782result[230]=' ' 783tests[232]='use Carp (); exit unless Carp::longmess(); print qq{ok\n}' 784tests[234]='$c = 0; for ("-3" .. "0") { $c++ } ; print "$c"' 785result[234]='4' 786# t/testc.sh -O3 -Dp,-UCarp,-v 235 787tests[235]='BEGIN{$INC{"Carp.pm"}="/dev/null"} $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } print $ol' 788result[235]='6' 789# -O3 790tests[236]='sub t { if ($_[0] == $_[1]) { print "ok\n"; } else { print "not ok - $_[0] == $_[1]\n"; } } t(-1.2, " -1.2");' 791tests[237]='print "\000\000\000\000_"' 792result[237]='_' 793tests[238]='sub f ($); 794sub f ($) { 795 my $test = $_[0]; 796 write; 797 format STDOUT = 798ok @<<<<<<< 799$test 800. 801} 802f(""); 803' 804tests[239]='my $x="1"; 805format STDOUT = 806ok @<<<<<<< 807$x 808. 809write;print "\n";' 810result[239]='ok 1' 811tests[240]='my $a = "\x{100}\x{101}Aa"; 812print "ok\n" if "\U$a" eq "\x{100}\x{100}AA"; 813my $b = "\U\x{149}cD"; # no pb without that line' 814tests[241]='package Pickup; use UNIVERSAL qw( can ); if (can( "Pickup", "can" ) != \&UNIVERSAL::can) { print "not " } print "ok\n";' 815tests[242]='$xyz = ucfirst("\x{3C2}"); 816$a = "\x{3c3}foo.bar"; 817($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; 818print "ok\n" if $c eq "\x{3a3}foo.Bar";' 819tests[243]='use warnings "deprecated"; print hex(${^WARNINGS}) . " "; print hex(${^H})' 820result[243]='0 598' 821tests[244]='print "($_)\n" for q{-2}..undef;' 822result[244]='(-2) 823(-1) 824(0)' 825tests[245]='sub foo { 826 my ( $a, $b ) = @_; 827 print "a: ".ord($a)." ; b: ".ord($b)." [ from foo ]\n"; 828} 829print "a: ". ord(lc("\x{1E9E}"))." ; "; 830print "b: ". ord("\x{df}")."\n"; 831foo(lc("\x{1E9E}"), "\x{df}");' 832result[245]='a: 223 ; b: 223 833a: 223 ; b: 223 [ from foo ]' 834# see t/issue235.t test 2 835tests[246]='sub foo($\@); eval q/foo "s"/; print $@' 836result[246]='Not enough arguments for main::foo at (eval 1) line 1, at EOF' 837tests[247]='# WontFix 838no warnings; $[ = 1; $big = "N\xabN\xab"; print qq{ok\n} if rindex($big, "N", 3) == 3' 839tests[248]='#WONTFIX lexical $_ in re-eval 840{my $s="toto";my $_="titi";{$s =~ /to(?{ print "-$_-$s-\n";})to/;}}' 841result[248]='-titi-toto-' 842tests[249]='#TODO version 843use version; print version::is_strict(q{01}) ? 1 : 0' 844result[249]='0' 845tests[250]='#TODO version 846use warnings qw/syntax/; use version; $withversion::VERSION = undef; eval q/package withversion 1.1_;/; print $@;' 847result[250]='Misplaced _ in number at (eval 1) line 1. 848Invalid version format (no underscores) at (eval 1) line 1, near "package withversion " 849syntax error at (eval 1) line 1, near "package withversion 1.1_"' 850tests[251]='sub f;print "ok" if exists &f' 851tests[2511]='#TODO 5.18 852sub f :lvalue;print "ok" if exists &f' 853tests[2512]='sub f ();print "ok" if exists &f' 854tests[2513]='sub f ($);print "ok" if exists &f' 855tests[2514]='sub f;print "ok" if exists &f' 856# duplicate of 234 857tests[252]='my $i = 0; for ("-3".."0") { ++$i } print $i' 858result[252]='4' 859tests[253]='INIT{require "t/TestBC.pm"}plan(tests=>2);is("\x{2665}", v9829);is(v9829,"\x{2665}");' 860result[253]='1..2 861ok 1 862ok 2' 863tests[254]='#TODO destroy upgraded lexvar 864my $flag = 0; 865sub X::DESTROY { $flag = 1 } 866{ 867 my $x; # x only exists in that scope 868 BEGIN { $x = 42 } # pre-initialized as IV 869 $x = bless {}, "X"; # run-time upgrade and bless to call DESTROY 870 # undef($x); # value should be free when exiting scope 871} 872print "ok\n" if $flag;' 873# duplicate of 185, bytes_heavy 874tests[255]='$a = chr(300); 875my $l = length($a); 876my $lb; 877{ use bytes; $lb = length($a); } 878print( ( $l == 1 && $lb == 2 ) ? "ok\n" : "l -> $l ; lb -> $lb\n" );' 879tests[256]='BEGIN{ $| = 1; } print "ok\n" if $| == 1' 880tests[2561]='BEGIN{ $/ = "1"; } print "ok\n" if $/ == "1"' 881tests[259]='use JSON::XS; print encode_json([\0])' 882result[259]='[false]' 883tests[260]='sub FETCH_SCALAR_ATTRIBUTES {''} sub MODIFY_SCALAR_ATTRIBUTES {''}; my $a :x=1; print $a' 884result[260]='1' 885tests[261]='q(12-feb-2015) =~ m#(\d\d?)([\-\./])(feb|jan)(?:\2(\d\d+))?#; print $4' 886result[261]='2015' 887tests[262]='use POSIX' 888result[262]=' ' 889tests[263]='use JSON::XS; print encode_json []' 890result[263]='[]' 891tests[264]='no warnings; warn "$a.\n"' 892result[264]='.' 893tests[272]='$d{""} = qq{ok\n}; print $d{""};' 894tests[2721]='BEGIN{$d{""} = qq{ok\n};} print $d{""};' 895tests[273]='package Foo; use overload; sub import { overload::constant "integer" => sub { return shift }}; package main; BEGIN { $INC{"Foo.pm"} = "/lib/Foo.pm" }; use Foo; my $result = eval "5+6"; print "$result\n"' 896result[273]='11' 897tests[274]='package Foo; 898 899sub match { shift =~ m?xyz? ? 1 : 0; } 900sub match_reset { reset; } 901 902package Bar; 903 904sub match { shift =~ m?xyz? ? 1 : 0; } 905sub match_reset { reset; } 906 907package main; 908print "1..5\n"; 909 910print "ok 1\n" if Bar::match("xyz"); 911print "ok 2\n" unless Bar::match("xyz"); 912print "ok 3\n" if Foo::match("xyz"); 913print "ok 4\n" unless Foo::match("xyz"); 914 915Foo::match_reset(); 916print "ok 5\n" if Foo::match("xyz");' 917result[274]='1..5 918ok 1 919ok 2 920ok 3 921ok 4 922ok 5' 923tests[277]='format OUT = 924bar ~~ 925. 926open(OUT, ">/dev/null"); write(OUT); close OUT; print q(ok)' 927tests[280]='package M; $| = 1; sub DESTROY {eval {print "Farewell ",ref($_[0])};} package main; bless \$A::B, q{M}; *A:: = \*B::;' 928result[280]='Farewell M' 929tests[281]='"I like pie" =~ /(I) (like) (pie)/; "@-" eq "0 0 2 7" and print "ok\n"; print "\@- = @-\n\@+ = @+\nlen \@- = ",scalar @-' 930result[281]='ok 931@- = 0 0 2 7 932@+ = 10 1 6 10 933len @- = 4' 934tests[282]='use vars qw($glook $smek $foof); $glook = 3; $smek = 4; $foof = "halt and cool down"; my $rv = \*smek; *glook = $rv; my $pv = ""; $pv = \*smek; *foof = $pv; print "ok\n";' 935tests[283]='#238 Undefined format "STDOUT" 936format = 937ok 938. 939write' 940tests[284]='#-O3 only 941my $x="123456789"; 942format OUT = 943^<<~~ 944$x 945. 946open OUT, ">ccode.tmp"; 947write(OUT); 948close(OUT); 949print `cat "ccode.tmp"`' 950result[284]='123 951456 952789' 953tests[289]='no warnings; sub z_zwap (&); print qq{ok\n} if eval q{sub z_zwap {return @_}; 1;}' 954tests[290]='sub f;print "ok" if exists &f && not defined &f;' 955tests[293]='use Coro; print q(ok)' 956tests[295]='"zzaaabbb" =~ m/(a+)(b+)/ and print "@- : @+\n"' 957result[295]='2 2 5 : 8 5 8' 958tests[299]='#TODO version 959package Pickup; use UNIVERSAL qw( VERSION ); print qq{ok\n} if VERSION "UNIVERSAL";' 960tests[300]='use mro;print @{mro::get_linear_isa("mro")};' 961result[300]='mro' 962tests[301]='{ package A; use mro "c3"; sub foo { "A::foo" } } { package B; use base "A"; use mro "c3"; sub foo { (shift)->next::method() } } print qq{ok\n} if B->foo eq "A::foo";' 963tests[305]='use constant ASCII => eval { require Encode; Encode::find_encoding("ascii"); } || 0; print ASCII->encode("www.google.com")' 964result[305]='www.google.com' 965tests[3051]='INIT{ sub ASCII { eval { require Encode; Encode::find_encoding("ASCII"); } || 0; }} print ASCII->encode("www.google.com")' 966result[3051]='www.google.com' 967tests[3052]='use Net::DNS::Resolver; my $res = Net::DNS::Resolver->new; $res->send("www.google.com"), print q(ok)' 968tests[365]='use constant JP => eval { require Encode; Encode::find_encoding("euc-jp"); } || 0; print JP->encode("www.google.com")' 969result[365]='www.google.com' 970tests[306]='package foo; sub check_dol_slash { print ($/ eq "\n" ? "ok" : "not ok") ; print "\n"} sub begin_local { local $/;} ; package main; BEGIN { foo::begin_local() } foo::check_dol_slash();' 971tests[308]='print (eval q{require Net::SSLeay;} ? qq{ok\n} : $@);' 972tests[309]='print $_,": ",(eval q{require }.$_.q{;} ? qq{ok\n} : $@) for qw(Net::LibIDN Net::SSLeay);' 973result[309]='Net::LibIDN: ok 974Net::SSLeay: ok' 975tests[310]='package foo; 976sub dada { my $line = <DATA> } 977print dada; 978__DATA__ 979ok 980b 981c 982' 983tests[312]='require Scalar::Util; eval "require List::Util"; print "ok"' 984tests[314]='open FOO, ">", "ccode314.tmp"; print FOO "abc"; close FOO; open FOO, "<", "ccode314.tmp"; { local $/="b"; $in=<FOO>; if ($in eq "ab") { print "ok\n" } else { print qq(separator: "$/"\n\$/ is "$/"\nFAIL: "$in"\n)}}; unlink "ccode314.tmp"' 985tests[3141]='open FOO, ">", "ccode3141.tmp"; print FOO "abc"; close FOO; open FOO, "<", "ccode3141.tmp"; { $/="b"; $in=<FOO>; if ($in eq "ab") { print "ok\n" } else { print qq(separator: "$/"\n\$/ is "$/"\nFAIL: "$in"\n)}}; unlink "ccode3141.tmp"' 986tests[316]=' 987package Diamond_A; sub foo {}; 988package Diamond_B; use base "Diamond_A"; 989package Diamond_C; use base "Diamond_A"; 990package Diamond_D; use base ("Diamond_B", "Diamond_C"); use mro "c3"; 991package main; my $order = mro::get_linear_isa("Diamond_D"); 992 print $order->[3] eq "Diamond_A" ? "ok" : "not ok"; print "\n"' 993tests[317]='use Net::SSLeay();use IO::Socket::SSL();Net::SSLeay::OpenSSL_add_ssl_algorithms(); my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(SSL_server => 1); print q(ok)' 994tests[318]='{ local $\ = "ok" ; print "" }' 995tests[319]='#TODO Wide character warnings missing (bytes layer ignored) 996use warnings q{utf8}; my $w; local $SIG{__WARN__} = sub { $w = $_[0] }; my $c = chr(300); open F, ">", "a"; binmode(F, ":bytes:"); print F $c,"\n"; close F; print $w' 997tests[320]='#TODO No warnings reading in invalid utf8 stream (utf8 layer ignored) 998use warnings "utf8"; local $SIG{__WARN__} = sub { $@ = shift }; open F, ">", "a"; binmode F; my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6)); print F "foo", $chrE4, "\n"; print F "foo", $chrF6, "\n"; close F; open F, "<:utf8", "a"; undef $@; my $line = <F>; print q(ok) if $@ =~ /utf8 "\xE4" does not map to Unicode/;' 999tests[324]='package Master; 1000use mro "c3"; 1001sub me { "Master" } 1002package Slave; 1003use mro "c3"; 1004use base "Master"; 1005sub me { "Slave of ".(shift)->next::method } 1006package main; 1007print Master->me()."\n"; 1008print Slave->me()."\n"; 1009' 1010result[324]='Master 1011Slave of Master' 1012tests[326]='#TODO method const maybe::next::method 1013package Diamond_C; sub maybe { "Diamond_C::maybe" } package Diamond_D; use base "Diamond_C"; use mro "c3"; sub maybe { "Diamond_D::maybe => " . ((shift)->maybe::next::method() || 0) } package main; print "ok\n" if Diamond_D->maybe;' 1014tests[328]='#WONTFIX re-eval lex/global mixup 1015my $code = q[{$blah = 45}]; our $blah = 12; eval "/(?$code)/"; print "$blah\n"' 1016result[328]=45 1017tests[329]='#WONTFIX re-eval lex/global mixup 1018$_ = q{aaa}; my @res; pos = 1; s/\Ga(?{push @res, $_, $`})/xx/g; print "ok\n" if "$_ @res" eq "axxxx aaa a aaa aa"; print "$_ @res\n"' 1019result[329]='ok 1020axxxx aaa a aaa aa' 1021tests[330]='"\x{101}a" =~ qr/\x{100}/i && print "ok\n"' 1022tests[331]='use 5.010; use charnames ":full"; my $char = q/\N{LATIN CAPITAL LETTER A WITH MACRON}/; my $a = eval qq ["$char"]; print length($a) == 1 ? "ok\n" : "$a\n".length($a)."\n"' 1023tests[332]='#TODO re-eval no_modify, probably WONTFIX 1024use re "eval"; our ( $x, $y, $z ) = 1..3; $x =~ qr/$x(?{ $y = $z++ })/; undef $@; print "ok\n"' 1025tests[333]='use encoding "utf8"; 1026my @hiragana = map {chr} ord("ぁ")..ord("ん"); my @katakana = map {chr} ord("ァ")..ord("ン"); my $hiragana = join(q{} => @hiragana); my $katakana = join(q{} => @katakana); my %h2k; @h2k{@hiragana} = @katakana; $str = $hiragana; $str =~ s/([ぁ-ん])/$h2k{$1}/go; print $str eq $katakana ? "ok\n" : "not ok\n$hiragana\n$katakana\n";' 1027tests[338]='use utf8; my $l = "ñ"; my $re = qr/ñ/; print $l =~ $re ? qq{ok\n} : length($l)."\n".ord($l)."\n";' 1028tests[340]='eval q/use Net::DNS/; my $new = "IO::Socket::INET6"->can("new") or die "die at new"; my $inet = $new->("IO::Socket::INET6", LocalAddr => q/localhost/, Proto => "udp", LocalPort => undef); print q(ok) if ref($inet) eq "IO::Socket::INET6";' 1029# used to fail in the inc-i340 branches CORE/base/lex.t 54 1030tests[3401]='sub foo::::::bar { print "ok\n"; } foo::::::bar;' 1031# wontfix on -O3: static string *end for "main::bar" 1032tests[345]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("main::bar", sub { 42 } ); print "ok\n";' 1033# those work fine: 1034tests[3451]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("bar", sub { 42 } ); print "ok\n";' 1035tests[3452]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; $bar="main::bar"; subname($bar, sub { 42 } ); print "ok\n";' 1036tests[348]='package Foo::Bar; sub baz { 1 } 1037package Foo; sub new { bless {}, shift } sub method { print "ok\n"; } 1038package main; Foo::Bar::baz(); 1039my $foo = sub { 1040 Foo->new 1041}->(); 1042$foo->method;' 1043tests[350]='package Foo::Moose; use Moose; has bar => (is => "rw", isa => "Int"); 1044package main; my $moose = Foo::Moose->new; print "ok" if 32 == $moose->bar(32);' 1045tests[368]='use EV; print q(ok)' 1046tests[369]=' 1047use EV; 1048use Coro; 1049use Coro::Timer; 1050my @a; 1051push @a, async { 1052 while() { 1053 warn $c++; 1054 Coro::Timer::sleep 1; 1055 }; 1056}; 1057push @a, async { 1058 while() { 1059 warn $d++; 1060 Coro::Timer::sleep 0.5; 1061 }; 1062}; 1063schedule; 1064print q(ok)' 1065tests[371]='package foo;use Moose; 1066has "x" => (isa => "Int", is => "rw", required => 1); 1067has "y" => (isa => "Int", is => "rw", required => 1); 1068sub clear { my $self = shift; $self->x(0); $self->y(0); } 1069__PACKAGE__->meta->make_immutable; 1070package main; 1071my $f = foo->new( x => 5, y => 6); 1072print $f->x . "\n";' 1073result[371]='5' 1074if [[ $v518 -gt 0 ]]; then 1075 tests[372]='use utf8; require mro; my $f_gen = mro::get_pkg_gen("ᕘ"); undef %ᕘ::; mro::get_pkg_gen("ᕘ"); delete $::{"ᕘ::"}; print "ok";' 1076 result[372]='ok' 1077fi 1078tests[2050]='use utf8;package 텟ţ::ᴼ; sub ᴼ_or_Ḋ { "ok" } print ᴼ_or_Ḋ;' 1079result[2050]='ok' 1080tests[2051]='use utf8;package ƂƂƂƂ; sub ƟK { "ok" } package ƦƦƦƦ; use base "ƂƂƂƂ"; my $x = bless {}, "ƦƦƦƦ"; print $x->ƟK();' 1081result[2051]='ok' 1082tests[404]='use FCGI;sub test {my $s=" ";$s =~ s/ //g;print "ok $s\n";}test();' 1083result[404]='ok ' 1084 1085init 1086 1087while getopts "qsScohv" opt 1088do 1089 if [ "$opt" = "q" ]; then 1090 Q=1 1091 OCMD="$QOCMD" 1092 qq="-qq," 1093 if [ "$VERS" = "5.6.2" ]; then QOCMD=$OCMD; qq=""; fi 1094 fi 1095 if [ "$opt" = "v" ]; then 1096 Q= 1097 QOCMD="$OCMD" 1098 qq="" 1099 fi 1100 if [ "$opt" = "s" ]; then SKIP=1; fi 1101 if [ "$opt" = "o" ]; then Mblib=" "; SKIP=1; SKI=1; init; fi 1102 if [ "$opt" = "S" ]; then SKIP=1; SKI=1; fi 1103 if [ "$opt" = "c" ]; then CONT=1; shift; fi 1104 if [ "$opt" = "h" ]; then help; exit; fi 1105done 1106 1107if [ -z "$Q" ]; then 1108 make 1109else 1110 make -s >/dev/null 1111fi 1112 1113# need to shift the options 1114while [ -n "$1" -a "${1:0:1}" = "-" ]; do shift; done 1115 1116if [ -n "$1" ]; then 1117 while [ -n "$1" ]; do 1118 btest $1 1119 shift 1120 done 1121else 1122 for b in $(seq $ntests); do 1123 btest $b 1124 done 1125fi 1126 1127# 5.8: all PASS 1128# 5.10: FAIL: 2-5, 7, 11, 15. With -D 9-12 fail also. 1129# 5.11: FAIL: 2-5, 7, 11, 15-16 (all segfaulting in REGEX). With -D 9-12 fail also. 1130# 5.11d: WRONG 4, FAIL: 9-11, 15-16 1131# 5.11d linux: WRONG 4, FAIL: 11, 16 1132 1133#only if ByteLoader installed in @INC 1134if false; then 1135echo ${OCMD}-H,-obytecode2.plc bytecode2.pl 1136${OCMD}-H,-obytecode2.plc bytecode2.pl 1137chmod +x bytecode2.plc 1138echo ./bytecode2.plc 1139./bytecode2.plc 1140fi 1141 1142# package pmc 1143if false; then 1144echo "package MY::Test;" > bytecode1.pm 1145echo "print 'hi'" >> bytecode1.pm 1146echo ${OCMD}-m,-obytecode1.pmc bytecode1.pm 1147${OCMD}-obytecode1.pmc bytecode1.pm 1148fi 1149