1#!/bin/bash 2# t/testc.sh -c -Du,-q -B static 2>&1 |tee c.log|grep FAIL 3# for p in 5.6.2 5.8.8-nt 5.8.9d 5.10.1d 5.10.1d-nt 5.11.2d 5.11.2d-nt; do make -s clean; echo perl$p; perl$p Makefile.PL; t/testc.sh -q -O0 31; done 4# quiet c only: t/testc.sh -q -O0 5# t/testcc.sh -DOscpSql,-v,-UB::Concise,-UIO::File,-UIO::Handle,-Uwarnings 6function help { 7 echo "t/testc.sh [OPTIONS] [1-$ntests]" 8 echo " -D<debugflags> for O=C or O=CC. Default: C,-DspmF,-v resp. CC,-DOscpSql,-v" 9 echo " -O<0-4> optimization level" 10 echo " -f<opt> special optimization" 11 echo " -B<static|dynamic> pass to cc_harness" 12 echo " -c continue on errors" 13 echo " -k keep temp. files on PASS" 14 echo " -E dump preprocessed source file with cc -E as _E.c" 15 echo " -o orig. no -Mblib, use installed modules (5.6, 5.8)" 16 echo " -a all. undo -Du. Unsilence scanning unused sub" 17 echo " -A -DALLOW_PERL_OPTIONS" 18 echo " -L make CORE test symlinks and exit" 19 echo " -X<num> view the test" 20 echo " -q quiet" 21 echo " -h help" 22 echo "Without arguments try all $ntests tests. Without Option -Ox try -O0 to -O3 optimizations." 23} 24 25# use the actual perl from the Makefile (perl5.8.8, 26# perl5.10.0d-nt, perl5.11.0, ...) 27PERL=`grep "^FULLPERL =" Makefile|cut -c12-` 28test -z $PERL && PERL=`grep "^PERL =" Makefile|cut -c8-` 29PERL=${PERL:-perl} 30PERL=`echo $PERL|sed -e's,^",,; s,"$,,'` 31v510=`$PERL -e'print (($] < 5.010)?0:1)'` 32v518=`$PERL -e'print (($] < 5.018)?0:1)'` 33v524=`$PERL -e'print (($] < 5.024)?0:1)'` 34#v522=`$PERL -e'print (($] < 5.022)?0:1)'` 35PERLV=v5.`$PERL -e'print substr($],3,2)'` 36XTESTC="t/CORE/$PERLV/C-COMPILED/xtestc" 37 38function init { 39BASE=`basename $0` 40# if $] < 5.9 you may want to remove -Mblib for testing the core lib. -o 41#Mblib="`$PERL -e'print (($] < 5.009005) ? q() : q(-Mblib))'`" 42Mblib=${Mblib:--Iblib/arch -Iblib/lib} # B::C is now fully 5.6+5.8 backwards compatible 43test -z $PERL_CORE || Mblib=-I../../lib 44v513="`$PERL -e'print (($] < 5.013005) ? q() : q(-fno-fold,-fno-warnings,))'`" 45# OCMD=${OCMD}${v513} 46if [ -z "$Mblib" ]; then 47 VERS="${VERS}_global"; 48 OCMD="$PERL $Mblib -MO=C,${v513}-Dcsp," 49 if [ $BASE = "testcc.sh" ]; then # DrOsplt 50 OCMD="$PERL $Mblib -MO=CC,${v513}-DOsplt," 51 fi 52else 53 OCMD="$PERL $Mblib -MO=C,${v513}-DspF,-v," 54 if [ $BASE = "testcc.sh" ]; then # DoOscprSql 55 OCMD="$PERL $Mblib -MO=CC,${v513}-DOpscpTql,-v," 56 fi 57fi 58CONT= 59# 5.6: rather use -B static 60#CCMD="$PERL script/cc_harness -g3" 61# rest. -DALLOW_PERL_OPTIONS for -Dtlv 62#CCMD="$PERL $Mblib script/cc_harness -g3 -DALLOW_PERL_OPTIONS" 63CCMD="$PERL $Mblib script/cc_harness" 64test -z $PERL_CORE || CCMD="$CCMD -I../.. -L../.." 65LCMD= 66# On some perls I also had to add $archlib/DynaLoader/DynaLoader.a to libs in Config.pm 67} 68 69function vcmd { 70 test -n "$QUIET" || echo $* 71 $* 72} 73 74function pass { 75 echo -e -n "\033[1;32mPASS \033[0;0m" 76 echo $* 77} 78function fail { 79 echo -e -n "\033[1;31mFAIL \033[0;0m" 80 echo $* 81} 82 83function runopt { 84 o=$1 85 optim=$2 86 OCMDO1="$(echo $OCMD|sed -e s/C,/C,-O$optim,/)" 87 suff="_o${optim}" 88 if [ "$optim" == "0" ]; then suff=""; fi 89 rm ${o}${suff} ${o}${suff}.c 2> /dev/null 90 if [ $optim -lt 5 ]; then CMD=$OCMDO1 91 else CMD=$OCMD 92 fi 93 if [ "$o" = "ccode46" -o "$o" = "cccode46" ]; then 94 CMD="$CMD-fstash," 95 fi 96 if [ -z $qq ]; then 97 vcmd ${CMD}-o${o}${suff}.c $o.pl 2>&1 | grep -v "$o.pl syntax OK" 98 else 99 vcmd ${CMD}-o${o}${suff}.c $o.pl 100 fi 101 test -z $CPP || vcmd $CCMD ${o}${suff}.c -c -E -o ${o}${suff}_E.c 102 test -n "$QUIET" || echo ${CMD}-o${o}${suff}.c $o.pl 103 vcmd $CCMD ${o}${suff}.c $LCMD -o ${o}${suff} 104 test -x ${o}${suff} || (test -z $CONT && exit) 105 if [ -z "$QUIET" ]; then echo "./${o}${suff}" 106 else echo -n "./${o}${suff} " 107 fi 108 mem=$(ulimit -m 2>/dev/null) 109 err=$? 110 test -z $err && ulimit -S -m 50000 111 res=$(./${o}${suff}) || fail "./${o}${suff}" "errcode $?" 112 test -z $err && ulimit -S -m $mem 113 if [ "X${result[$n]}" = "X" ]; then result[$n]='ok'; fi 114 if [ "X$res" = "X${result[$n]}" ]; then 115 test "X$res" = "X${result[$n]}" && pass "./${o}${suff}" "=> '$res'" 116 if [ -z $KEEP ]; then rm ${o}${suff}_E.c ${o}${suff}.c ${o}${suff} 2>/dev/null; fi 117 true 118 else 119 fail "./${o}${suff}" "=> '$str' => '$res'. Expected: '${result[$n]}'" 120 false 121 fi 122} 123 124function emit_test { 125 n=$(expr $1 + 0) 126 CONTENT="${tests[${n}]}" 127 if [ "x$CONTENT" != "x" ]; then 128 echo -E "$CONTENT" 129 echo 130 if [ "x${result[$n]}" = "x" ]; then result[$n]='ok'; fi 131 echo -E "### RESULT:${result[$n]}" 132 fi 133} 134 135function make_t_symlink { 136 n=$(expr $1 + 0) 137 CONTENT="${tests[${n}]}" 138 if [ "x$CONTENT" != "x" ]; then 139 FILE_NUM=$(printf "%04d" $n) 140 FILE="$XTESTC/${FILE_NUM}.t" 141 test -e $FILE && unlink $FILE 142 ln -s ../testc.pl $FILE 143 fi 144} 145 146function make_symlinks { 147 MAX=9999 148 test -d $XTESTC || mkdir $XTESTC 149 rm -f $XTESTC/*.t ||: 150 for b in $(seq $MAX); do 151 make_t_symlink $b 152 done 153} 154 155function ctest { 156 n=$(expr $1 + 0) 157 str=$2 158 159 if [ $BASE = "testcc.sh" ]; then 160 o="cccode$n" 161 else 162 o="ccode$n" 163 fi 164 if [ -z "$str" ]; then 165 if [ "$n" = "08" ]; then n=8; fi 166 if [ "$n" = "09" ]; then n=9; fi 167 echo "${tests[${n}]}" > ${o}.pl 168 str="${tests[${n}]}" 169 else 170 echo "$str" > ${o}.pl 171 fi 172 if [ -z "$str" ]; then 173 true 174 else 175 if [ $OPTIM -ge 0 ]; then 176 runopt "$o" "$OPTIM" 177 else # -1 178 rm $o.c $o ${o}_o.c ${o}_o 2> /dev/null 179 vcmd ${OCMD}-o$o.c $o.pl 180 test -s $o.c || (echo "empty $o.c"; test -z $CONT && exit 2) 181 test -z $CPP || vcmd $CCMD $o.c -c -E -o ${o}_E.c 182 test -n "$QUIET" || echo ${OCMD}-o$o.c $o.pl 183 vcmd $CCMD $o.c $LCMD -o $o 184 test -x $o || (test -z $CONT && exit) 185 if [ -z "$QUIET" ]; then echo "./$o" 186 else echo -n "./$o " 187 fi 188 res=$(./$o) || (fail "./${o}${suff}" "'$?' = $?"; test -z $CONT && exit 1) 189 if [ "X${result[$n]}" = "X" ]; then result[$n]='ok'; fi 190 if [ "X$res" = "X${result[$n]}" ]; then 191 pass "./$o" "'$str' => '$res'" 192 if [ -z $KEEP ]; then rm ${o}_E.c ${o}.c ${o} 2>/dev/null; fi 193 if [ $BASE = "testcc.sh" ]; then 194 runopt $o 1 && \ 195 runopt $o 2 196 else 197 runopt $o 1 && \ 198 runopt $o 2 && \ 199 runopt $o 3 && \ 200 true #runopt $o 4 201 fi 202 true 203 else 204 fail "./$o" "'$str' => '$res' Expected: '${result[$n]}'" 205 test -z $CONT && exit 3 206 fi 207 fi 208 fi 209} 210 211ntests=3000 212declare -a tests[$ntests] 213declare -a result[$ntests] 214ncctests=23 215declare -a cctests[$((100+$ncctests))] 216declare -a ccresult[$((100+$ncctests))] 217tests[1]='print "hi"' 218result[1]='hi' 219tests[2]='for (1,2,3) { print if /\d/ }' 220result[2]='123' 221tests[3]='$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/ge; print $_' 222result[3]='zzz2y2y2' 223tests[4]='$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/g; print $_' 224if [[ $v518 -gt 0 ]]; then 225 result[4]='zzz2y2y2' 226else 227 result[4]='z2y2y2' 228fi 229tests[5]='print split /a/,"bananarama"' 230result[5]='bnnrm' 231tests[6]="{package P; sub x {print 'ya'} x}" 232result[6]='ya' 233tests[7]='@z = split /:/,"b:r:n:f:g"; print @z' 234result[7]='brnfg' 235tests[8]='sub AUTOLOAD { print 1 } &{"a"}()' 236result[8]='1' 237tests[9]='my $l_i = 3; $x = sub { print $l_i }; &$x' 238result[9]='3' 239tests[10]='my $i_i = 1; 240my $foo = sub { 241 $i_i = shift if @_ 242}; print $i_i; 243print &$foo(3),$i_i;' 244result[10]='133' 245# index: do fbm_compile or not 246tests[11]='$x="Cannot use"; print index $x, "Can"' 247result[11]='0' 248tests[12]='my $i_i=6; eval "print \$i_i\n"; print ""' 249result[12]='6' 250tests[13]='BEGIN { %h=(1=>2,3=>4) } print $h{3}' 251result[13]='4' 252tests[14]='open our $T,"a"; print "ok";' 253# __DATA__ handles still broken non-threaded 5.10 254tests[15]='print <DATA> 255__DATA__ 256a 257b' 258result[15]='a 259b' 260tests[16]='BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}}; print $a[1]' 261result[16]='1' 262tests[17]='my $i_ir=3; print 1 .. $i_ir' 263result[17]='123' 264# custom key sort 265tests[18]='my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h' 266result[18]='ba' 267# fool the sort optimizer by my $p, pp_sort works ok on CC 268tests[19]='print sort { my $p; $b <=> $a } 1,4,3' 269result[19]='431' 270# not repro: something like this is broken in original 5.6 (Net::DNS::ZoneFile::Fast) 271# see new test 33 272tests[20]='$a="abcd123";my $r=qr/\d/;print $a =~ $r;' 273result[20]='1' 274# broken on early alpha and 5.10: run-time labels. 275tests[21]='sub skip_on_odd{next NUMBER if $_[0]% 2}NUMBER:for($i=0;$i<5;$i++){skip_on_odd($i);print $i;}' 276result[21]='024' 277# broken in original perl 5.6 278tests[22]='my $fh; BEGIN { open($fh,"<","/dev/null"); } print "ok";'; 279# broken in perl 5.8 280tests[23]='package MyMod; our $VERSION = 1.3; print "ok";' 281# works in original perl 5.6, broken with latest B::C in 5.6, 5.8 282tests[24]='sub level1{return(level2()?"fail":"ok")} sub level2{0} print level1();' 283# enforce custom ncmp sort and count it. fails as CC in all. How to enforce icmp? 284# <=5.6 qsort needs two more passes here than >=5.8 merge_sort 285# 5.12 got it backwards and added 4 more passes. 286tests[25]='print sort { $i++; $b <=> $a } 1..4' 287result[25]="4321" 288# lvalue sub 289tests[26]='sub a:lvalue{my $a=26; ${\(bless \$a)}}sub b:lvalue{${\shift}}; print ${a(b)}'; 290result[26]="26" 291# xsub constants (constant folded). newlib: 0x200, glibc: 0x100 292tests[27]='use Fcntl ();my $a=Fcntl::O_CREAT(); print "ok" if ( $a >= 64 && &Fcntl::O_CREAT >= 64 );' 293# require $fname 294tests[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;' 295# multideref with static index and sv and dynamic gv ptrs 296tests[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}' 297result[29]='144' 298# special old IO handling 299tests[291]='use IO;print "ok"' 300# run-time context of .., fails in CC 301tests[30]='@a=(4,6,1,0,0,1);sub range{(shift @a)..(shift @a)}print range();while(@a){print scalar(range())}' 302result[30]='456123E0' 303# AUTOLOAD w/o goto xsub 304tests[31]='package MockShell;sub AUTOLOAD{my $p=$AUTOLOAD;$p=~s/.*:://;print(join(" ",$p,@_),";");} package main; MockShell::date();MockShell::who("am","i");MockShell::ls("-l");' 305result[31]='date;who am i;ls -l;' 306# CC entertry/jmpenv_jump/leavetry 307tests[32]='eval{print "1"};eval{die 1};print "2";' 308result[32]='12' 309# C qr test was broken in 5.6 -- needs to load an actual file to test. See test 20. 310# 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. 311# fails with new constant only. still not repro (r-magic probably) 312tests[33]='BEGIN{unshift @INC,("t");} use qr_loaded_module; print "ok" if qr_loaded_module::qr_called_in_sub("name1")' 313# init of magic hashes. %ENV has e magic since a0714e2c perl.c 314# (Steven Schubiger 2006-02-03 17:24:49 +0100 3967) i.e. 5.8.9 but not 5.8.8 315tests[34]='my $x=$ENV{TMPDIR};print "ok"' 316# static method_named. fixed with 1.16 317tests[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")' 318result[35]='01234' 319# HV self-ref 320tests[36]='my ($rv, %hv); %hv = ( key => \$rv ); $rv = \%hv; print "ok";' 321# AV self-ref 322tests[37]='my ($rv, @av); @av = ( \$rv ); $rv = \@av; print "ok";' 323# constant autoload loop crash test 324tests[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"; }' 325# check re::is_regexp, and on 5.12 if being upgraded to SVt_REGEXP 326# => Undefined subroutine &re::is_regexp with B-C-1.19, even with -ure 327tests[39]='{$a=qr/x/;print($]<5.010?1:re::is_regexp($a))}' 328result[39]='1' 329# String with a null byte -- used to generate broken .c on 5.6.2 with static pvs 330tests[40]='my $var="this string has a null \\000 byte in it";print "ok";' 331# Shared scalar, n magic. => Don't know how to handle magic of type \156. 332usethreads="" 333#usethreads="`$PERL -MConfig -e'print ($Config{useithreads} ? q(use threads;) : q())'`" 334#usethreads='BEGIN{use Config; unless ($Config{useithreads}) {print "ok"; exit}} ' 335#;threads->create(sub{$s="ok"})->join; 336# not yet testing n, only P 337tests[41]=$usethreads'use threads::shared;{my $s="ok";share($s);print $s}' 338# Shared aggregate, P magic 339tests[42]=$usethreads'use threads::shared;my %h : shared; print "ok"' 340# Aggregate element, n + p magic 341tests[43]=$usethreads'use threads::shared;my @a : shared; $a[0]="ok"; print $a[0]' 342# perl #72922 (5.11.4 fails with magic_killbackrefs) 343tests[44]='use Scalar::Util "weaken";my $re1=qr/foo/;my $re2=$re1;weaken($re2);print "ok" if $re3=qr/$re1/;' 344# test dynamic loading 345tests[45]='use Data::Dumper ();Data::Dumper::Dumpxs({});print "ok";' 346# issue 79: Exporter:: stash missing in main:: 347#tests[46]='use Exporter; if (exists $main::{"Exporter::"}) { print "ok"; }' 348tests[46]='use Exporter; print "ok" if %main::Exporter::' 349#tests[46]='use Exporter; print "ok" if scalar(keys(%main::Exporter::)) > 2' 350# non-tied av->MAGICAL 351tests[47]='@ISA=(q(ok));print $ISA[0];' 352# END block del_backref with bytecode only 353tests[48]='my $s=q{ok};END{print $s}' 354# even this failed until r1000 (AvFILL 3 of END) 355#tests[48]='print q{ok};END{}' 356# no-fold 357tests[49]='print q(ok) if "test" =~ /es/i;' 358# @ISA issue 64 359tests[50]='package Top;sub top{q(ok)};package Next;our @ISA=qw(Top);package main;print Next->top();' 360# XXX TODO sigwarn $w = B::NULL without -v 361tests[51]='$SIG{__WARN__}=sub{print "ok"};warn 1;' 362# check if general signals work 363tests[511]='BEGIN{$SIG{USR1}=sub{$w++;};} kill USR1 => $$; print q(ok) if $w' 364#------------- 365# issue27 366tests[527]='require LWP::UserAgent;print q(ok);' 367#issue 24 368tests[124]='my %H;dbmopen(%H,q(f),0644);print q(ok);' 369tests[68]='package A; 370sub test { 371 use Data::Dumper (); 372 /^(.*?)\d+$/; 373 "Some::Package"->new(); 374} 375print "ok"' 376# issue71 377tests[71]=' 378package my; 379our @a; 380sub f { 381 my($alias,$name)=@_; 382 unshift(@a, $alias => $name); 383 my $find = "ok"; 384 my $val = $a[1]; 385 if ( ref($alias) eq "Regexp" && $find =~ $alias ) { 386 eval $val; 387 } 388 $find 389} 390package main; 391*f=*my::f; 392print "ok" if f(qr/^(.*)$/ => q("\L$1"));' 393# object call: method_named with args. 394tests[72]='package dummy;sub meth{print "ok"};package main;my dummy $o = bless {},"dummy"; $o->meth("const")' 395# object call: dynamic method_named with args. 396tests[73]='package dummy;sub meth{print "ok"};package main;my $meth="meth";my $o = bless {},"dummy"; $o->$meth("const")' 397tests[74]='package dummy; 398my $invoked_as_script = !caller(); 399__PACKAGE__->script(@ARGV) if $invoked_as_script; 400sub script {my($package,@args)=@_;print "ok"}' 401# issue 71_2+3: cop_warnings issue76 and const destruction issue71 fixed 402# ok with "utf-8-strict" 403tests[75]='use Encode; 404my $x = "abc"; 405print "ok" if "abc" eq Encode::decode("UTF-8", $x);' 406tests[76]='use warnings; 407{ no warnings q(void); # issue76 lexwarn 408 length "ok"; 409 print "ok" 410};' 411tests[81]='%int::; #create int package for types 412sub x(int,int) { @_ } #cvproto 413my $o = prototype \&x; 414if ($o eq "int,int") {print "o"}else{print $o}; 415sub y($) { @_ } #cvproto 416my $p = prototype \&y; 417if ($p eq q($)) {print "k"}else{print $p}; 418require bytes; 419sub my::length ($) { # possible prototype mismatch vs _ 420 if ( bytes->can(q(length)) ) { 421 *length = *bytes::length; 422 goto &bytes::length; 423 } 424 return CORE::length( $_[0] ); 425} 426print my::length($p);' 427result[81]='ok1' 428tests[90]='my $s = q(test string); 429$s =~ s/(?<first>test) (?<second>string)/\2 \1/g; 430print q(o) if $s eq q(string test); 431q(test string) =~ /(?<first>\w+) (?<second>\w+)/; 432print q(k) if $+{first} eq q(test);' 433tests[901]='my %errs = %!; # t/op/magic.t Errno compiled in 434print q(ok) if defined ${"!"}{ENOENT};' 435tests[902]='my %errs = %{"!"}; # t/op/magic.t Errno to be loaded at run-time 436print q(ok) if defined ${"!"}{ENOENT};' 437# issue #199 438tests[903]='"abc" =~ /(.)./; print "ok" if "21" eq join"",@+;' 439# issue #220 440tests[904]='my $content = "ok\n"; 441while ( $content =~ m{\w}g ) { 442 $_ .= "$-[0]$+[0]"; 443} 444print "ok" if $_ eq "0112";' 445# IO handles 446tests[91]='# issue59 447use strict; 448use warnings; 449use IO::Socket; 450my $remote = IO::Socket::INET->new( Proto => "tcp", PeerAddr => "perl.org", PeerPort => "80" ); 451print $remote "GET / HTTP/1.0" . "\r\n\r\n"; 452my $result = <$remote>; 453$result =~ m|HTTP/1.1 200 OK| ? print "ok" : print $result; 454close $remote;' 455tests[93]='#SKIP 456my ($pid, $out, $in); 457BEGIN { 458 local(*FPID); 459 $pid = open(FPID, "echo <<EOF |"); # DIE 460 open($out, ">&STDOUT"); # EASY 461 open(my $tmp, ">", "pcc.tmp"); # HARD to get filename, WARN 462 print $tmp "test\n"; 463 close $tmp; # OK closed 464 open($in, "<", "pcc.tmp"); # HARD to get filename, WARN 465} 466# === run-time === 467print $out "o"; 468kill 0, $pid; # BAD! warn? die? 469print "k" if "test" eq read $in, my $x, 4; 470unlink "pcc.tmp"; 471' 472result[93]='o' 473tests[931]='my $f;BEGIN{open($f,"<README");}read $f,my $in, 2; print "ok"' 474tests[932]='my $f;BEGIN{open($f,">&STDOUT");}print $f "ok"' 475tests[95]='use IO::Socket::SSL(); 476my IO::Handle $handle = IO::Socket::SSL->new(SSL_verify_mode =>0); 477$handle->blocking(0); 478print "ok";' 479tests[96]='defined(&B::OP::name) || print q(ok)' 480tests[97]='use v5.12; print q(ok);' 481 482# from here on we test CC specifics only 483 484# CC types and arith 485tests[101]='my ($r_i,$i_i,$d_d)=(0,2,3.0); $r_i=$i_i*$i_i; $r_i*=$d_d; print $r_i;' 486result[101]='12' 487# CC cond_expr, stub, scope 488tests[102]='if ($x eq "2"){}else{print "ok"}' 489# CC stringify, srefgen 490tests[103]='require B; my $x=1e1; my $s="$x"; print ref B::svref_2object(\$s)' 491result[103]='B::PV' 492# CC reset 493tests[104]='@a=(1..4);while($a=shift@a){print $a;}continue{$a=~/2/ and reset q(a);}' 494result[104]='12' 495# CC -ftype-attr 496#tests[105]='$int::dummy=0;$double::dummy=0;my int $r;my $i:int=2;our double $d=3.0; $r=$i*$i; $r*=$d; print $r;' 497tests[105]='%int::;%double::;my int $r;my int $i=2;our double $d=3.0; $r=$i*$i; $r*=$d; print $r;' 498result[105]='12' 499# issue 296 500tests[106]='my $s=q{ok};END{print $s}END{$x = 0}' 501 502# issue31 503tests[131]='package Ccode31i;my $regex = qr/\w+/;sub test {print ("word" =~ m/^$regex$/o ? "ok\n" : "not ok\n");} 504package main; &Ccode31i::test();' 505# issue35 506tests[110]='sub new{}sub test{{my $x=1;my $y=$x+1;}my $x=2;if($x!=3){4;}} print q(ok)' 507# issue36 508tests[111]='sub f{shift==2}sub test{while(1){last if f(2);}while(1){last if f(2);}} print q(ok)' 509# issue37 510tests[112]='my $x;$x||=1;print "ok" if $x;' 511# issue38 512tests[113]='my $x=2;$x=$x||3;print "ok" if $x==2;' 513# issue39 514tests[114]='sub f1{0}sub f2{my $x;if(f1()){}if($x){}else{[$x]}}my @a=f2();print "ok";' 515# issue42 516tests[115]='sub f1{1}f1();print do{7;2},"\n";' 517result[115]='2' 518# issue44 519tests[116]='my @a=(1,2);print $a[0],"\n";' 520result[116]='1' 521# issue45 522tests[117]='my $x;$x//=1;print "ok" if $x;' 523# issue46 524tests[118]='my $pattern="x";"foo"=~/$pattern/o;print "ok";' 525# issue47 526tests[119]='my $f=sub{while(1){return(1);}};print $f->(),"\n";' 527result[119]='1' 528# issue48 529tests[120]='sub f{()}print((my ($v)=f())?1:2,"\n");' 530result[120]='2' 531# issue49 532tests[121]='while(1){while(1){last;}last;}print "ok"' 533# issue51 534tests[122]='my ($p1,$p2)=(80,80);if($p1<=23&&23<=$p2){print "telnet\n";}elsif ($p1 <= 80 && 80 <= $p2){print "http\n";}else{print "fail\n"}' 535result[122]='http' 536# issue52 537tests[123]='my $x;my $y = 1;$x and $y == 2;print $y == 1 ? "ok\n" : "fail\n";' 538# issue55 539tests[124]='LOOP:{my $sub=sub{last LOOP;}; $sub->() } print "ok";' 540# issue125 DynaLoader::bootstrap_inherit [perl #119577] 541tests[125]='use Net::LibIDN; print q(ok);' 542# saving recursive functions sometimes recurses in the compiler. this not, but Moose stucks in Pod::Simple 543tests[99]='package my;sub recurse{my $i=shift;recurse(++$i)unless $i>5000;print"ok";exit};package main;my::recurse(1)' 544if [[ $v518 -gt 0 ]]; then 545 tests[130]='no warnings "experimental::lexical_subs";use feature "lexical_subs";my sub p{q(ok)}; my $a=\&p;print p;' 546fi 547tests[137]='"to" =~ /t(?{ print "ok"})o/;' 548tests[138]='print map { chr $_ } qw/97 98 99/;' 549result[138]='abc' 550tests[140]='my %a;print "ok" if !%a;' 551#tests[141]='print "ok" if "1" > 0' 552tests[141]='@x=(0..1);print "ok" if $#x == "1"' 553tests[142]='$_ = "abc\x{1234}";chop;print $_ eq "abc" ? "ok" : $_;' 554tests[143]='BEGIN { 555 package Net::IDN::Encode; 556 our $DOT = qr/[\.]/; #works with my! 557 my $RE = qr/xx/; 558 sub domain_to_ascii { 559 my $x = shift || ""; 560 $x =~ m/$RE/o; 561 return split( qr/($DOT)/o, $x); 562 } 563} 564package main; 565Net::IDN::Encode::domain_to_ascii(42); 566print "ok\n";' 567tests[1431]='BEGIN{package Foo;our $DOT=qr/[.]/;};package main;print "ok\n" if "dot.dot" =~ m/($Foo::DOT)/' 568tests[1432]='BEGIN{$DOT=qr/[.]/}print "ok\n" if "dot.dot" =~ m/($DOT)/' 569tests[144]='print index("long message\0xx","\0")' 570result[144]='12' 571tests[145]='my $bits = 0; for (my $i = ~0; $i; $i >>= 1) { ++$bits; }; print $bits' 572result[145]=`$PERL -MConfig -e'print 8*$Config{ivsize}'` 573if [[ $v524 -eq 0 ]]; then # Use of strings with code points over 0xFF as arguments to bitwise xor (^) operator is deprecated in perl 5.24 574 tests[146]='my $a = v120.300; my $b = v200.400; $a ^= $b; print sprintf("%vd", $a);' 575 result[146]='176.188' 576fi 577tests[148]='open(FH, ">", "ccode148i.tmp"); print FH "1\n"; close FH; print -s "ccode148i.tmp"' 578result[148]='2' 579tests[149]='format Comment = 580ok 581. 582 583{ 584 local $~ = "Comment"; 585 write; 586}' 587tests[150]='print NONEXISTENT "foo"; print "ok" if $! == 9' 588tests[1501]='$! = 0; print NONEXISTENT "foo"; print "ok" if $! == 9' 589tests[152]='print "ok" if find PerlIO::Layer "perlio"' 590tests[154]='$SIG{__WARN__} = sub { die "warning: $_[0]" }; opendir(DIR, ".");closedir(DIR);print q(ok)' 591tests[156]='use warnings; 592no warnings qw(portable); 593use XSLoader; 594XSLoader::load() if $ENV{force_xsloader}; # trick for perlcc to force xloader to be compiled 595{ 596 my $q = 12345678901; 597 my $x = sprintf("%llx", $q); 598 print "ok\n" if hex $x == 0x2dfdc1c35; 599 exit; 600}' 601tests[157]='$q = 18446744073709551615;print scalar($q)."\n";print scalar(18446744073709551615)."\n";' 602result[157]='18446744073709551615 60318446744073709551615' 604tests[1571]='my $a = 9223372036854775807; print "ok\n" if ++$a == 9223372036854775808;' 605# duplicate of 148 606tests[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";' 607result[158]='0' 608tests[159]='@X::ISA = "Y"; sub Y::z {"Y::z"} print "ok\n" if X->z eq "Y::z"; delete $X::{z}; exit' 609# see 188 610tests[160]='sub foo { (shift =~ m?foo?) ? 1 : 0 } 611print "ok\n";' 612tests[161]='sub PVBM () { foo } { my $dummy = index foo, PVBM } print PVBM' 613result[161]='foo' 614# duplicate of 142 615tests[162]='$x = "\x{1234}"; print "ok\n" if ord($x) == 0x1234;' 616tests[163]='# WontFix 617my $destroyed = 0; 618sub X::DESTROY { $destroyed = 1 } 619{ 620 my $x; 621 BEGIN {$x = sub { } } 622 $x = bless {}, 'X'; 623} 624print qq{ok\n} if $destroyed == 1;' 625# duplicate of 148 626tests[164]='open(DUPOUT,">&STDOUT");close(STDOUT);open(F,">&DUPOUT");print F "ok\n";' 627tests[165]='use warnings; 628sub recurse1 { 629 unshift @_, "x"; 630 no warnings "recursion"; 631 goto &recurse2; 632} 633sub recurse2 { 634 my $x = shift; 635 $_[0] ? +1 + recurse1($_[0] - 1) : 0 636} 637print "ok\n" if recurse1(500) == 500;' 638tests[166]='my $ok = 1; 639foreach my $chr (60, 200, 600, 6000, 60000) { 640 my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); 641 chop($key, $value); 642 my %utf8c = ( $key => $value ); 643 my $tempval = sprintf q($utf8c{"\x{%x}"}), $chr; 644 my $ev = eval $tempval; 645 $ok = 0 if !$ev or $ev ne $value; 646} print "ok" if $ok' 647tests[167]='$a = "a\xFF\x{100}"; 648eval {$b = crypt($a, "cd")}; 649print $@;' 650result[167]='Wide character in crypt at ccode167.pl line 2.' 651tests[168]='my $start_time = time; 652eval { 653 local $SIG{ALRM} = sub { die "ALARM !\n" }; 654 alarm 1; 655 # perlfunc recommends against using sleep in combination with alarm. 656 1 while (time - $start_time < 3); 657}; 658alarm 0; 659print $@; 660print "ok\n" if $@ eq "ALARM !\n";' 661result[168]='ALARM ! 662ok' 663tests[169]='#TODO Attribute::Handlers 664package MyTest; 665use Attribute::Handlers; 666sub Check :ATTR { 667 print "called\n"; 668 print "ok\n" if ref $_[4] eq "ARRAY" && join(",", @{$_[4]}) eq join(",", qw/a b c/); 669} 670sub a_sub :Check(qw/a b c/) { 671 return 42; 672} 673print a_sub()."\n";' 674result[169]='called 675ok 67642' 677tests[170]='eval "sub xyz (\$) : bad ;"; print "~~~~\n$@~~~~\n"' 678result[170]='~~~~ 679Invalid CODE attribute: bad at (eval 1) line 1. 680BEGIN failed--compilation aborted at (eval 1) line 1. 681~~~~' 682tests[172]='package Foo; 683use overload q("") => sub { "Foo" }; 684package main; 685my $foo = bless {}, "Foo"; 686print "ok\n" if "$foo" eq "Foo";' 687tests[173]='# WontFix 688use constant BEGIN => 42; print "ok 1\n" if BEGIN == 42; 689use constant INIT => 42; print "ok 2\n" if INIT == 42; 690use constant CHECK => 42; print "ok 3\n" if CHECK == 42;' 691result[173]='Prototype mismatch: sub main::BEGIN () vs none at ./ccode173.pl line 2. 692Constant subroutine BEGIN redefined at ./ccode173.pl line 2. 693ok 1 694ok 2 695ok 3' 696tests[174]=' 697my $str = "\x{10000}\x{800}"; 698no warnings "utf8"; 699{ use bytes; $str =~ s/\C\C\z//; } 700my $ref = "\x{10000}\0"; 701print "ok 1\n" if ~~$str eq $ref; 702$str = "\x{10000}\x{800}"; 703{ use bytes; $str =~ s/\C\C\z/\0\0\0/; } 704my $ref = "\x{10000}\0\0\0\0"; 705print "ok 2\n" if ~~$str eq $ref;' 706result[174]='ok 1 707ok 2' 708tests[175]='{ 709 # note that moving the use in an eval block solve the problem 710 use warnings NONFATAL => all; 711 $SIG{__WARN__} = sub { "ok - expected warning\n" }; 712 my $x = pack( "I,A", 4, "X" ); 713 print "ok\n"; 714}' 715result[175]='ok - expected warning 716ok' 717tests[176]='use Math::BigInt; print Math::BigInt::->new(5000000000);' 718result[176]='5000000000' 719tests[177]='use version; print "ok\n" if version::is_strict("4.2");' 720if [[ $v524 -eq 0 ]]; then 721 tests[178]='BEGIN { $hash = { pi => 3.14, e => 2.72, i => -1 } ;} print scalar keys $hash;' 722 result[178]='3' 723fi 724tests[179]='#TODO smartmatch subrefs 725{ 726 package Foo; 727 sub new { bless {} } 728} 729package main; 730our $foo = Foo->new; 731our $bar = $foor; # required to generate the wrong behavior 732my $match = eval q($foo ~~ undef) ? 1 : 0; 733print "match ? $match\n";' 734result[179]='match ? 0' 735tests[180]='use feature "switch"; use integer; given(3.14159265) { when(3) { print "ok\n"; } }' 736tests[181]='sub End::DESTROY { $_[0]->() }; 737my $inx = "OOOO"; 738$SIG{__WARN__} = sub { print$_[0] . "\n" }; 739{ 740 $@ = "XXXX"; 741 my $e = bless( sub { die $inx }, "End") 742} 743print q(ok)' 744tests[182]='#TODO stash-magic delete renames to ANON 745my @c; sub foo { @c = caller(0); print $c[3] } my $fooref = delete $::{foo}; $fooref -> ();' 746result[182]='main::__ANON__' 747tests[183]='main->import(); print q(ok)' 748tests[184]='use warnings; 749sub xyz { no warnings "redefine"; *xyz = sub { $a <=> $b }; &xyz } 750eval { @b = sort xyz 4,1,3,2 }; 751print defined $b[0] && $b[0] == 1 && $b[1] == 2 && $b[2] == 3 && $b[3] == 4 ? "ok\n" : "fail\n"; 752exit; 753{ 754 package Foo; 755 use overload (qw("" foo)); 756} 757{ 758 package Bar; 759 no warnings "once"; 760 sub foo { $ENV{fake} } 761} 762' 763# usage: t/testc.sh -O3 -Dp,-UCarp 185 764tests[185]='my $a=pack("U",0xFF);use bytes;print "not " unless $a eq "\xc3\xbf" && bytes::length($a) == 2; print "ok\n";' 765tests[186]='eval q/require B/; my $sub = do { package one; \&{"one"}; }; delete $one::{one}; my $x = "boom"; print "ok\n";' 766# duplicate of 182 767tests[187]='my $glob = \*Phoo::glob; undef %Phoo::; print ( ( "$$glob" eq "*__ANON__::glob" ) ? "ok\n" : "fail with $$glob\n" );' 768# See also GH 252 + 360 769tests[188]='package aiieee;sub zlopp {(shift =~ m?zlopp?) ? 1 : 0;} sub reset_zlopp {reset;} 770package main; print aiieee::zlopp(""), aiieee::zlopp("zlopp"), aiieee::zlopp(""), aiieee::zlopp("zlopp"); 771aiieee::reset_zlopp(); print aiieee::zlopp("zlopp")' 772result[188]='01001' 773tests[191]='# WontFix 774BEGIN{sub plan{42}} {package Foo::Bar;} print((exists $Foo::{"Bar::"} && $Foo::{"Bar::"} eq "*Foo::Bar::") ? "ok\n":"bad\n"); plan(fake=>0);' 775tests[192]='use warnings; 776{ 777 no warnings qw "once void"; 778 my %h; # We pass a key of this hash to the subroutine to get a PVLV. 779 sub { for(shift) { 780 # Set up our glob-as-PVLV 781 $_ = *hon; 782 # Assigning undef to the glob should not overwrite it... 783 { 784 my $w; 785 local $SIG{__WARN__} = sub { $w = shift }; 786 *$_ = undef; 787 print ( $w =~ m/Undefined value assigned to typeglob/ ? "ok" : "not ok"); 788 } 789 }}->($h{k}); 790}' 791tests[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;' 792tests[194]='$0 = q{ccdave with long name}; #print "pid: $$\n"; 793$s=`ps w | grep "$$" | grep "[c]cdave"`; 794print ($s =~ /ccdave with long name/ ? q(ok) : $s);' 795tests[1941]='$0 = q{ccdave}; #print "pid: $$\n"; 796$s=`ps auxw | grep "$$" | grep "ccdave"|grep -v grep`; 797print q(ok) if $s =~ /ccdave/' 798# VmRSS memory usage 799tests[1942]='$s=<DATA>;print `ps -p $$ -O rss,vsz,pmem`; 800__DATA__ 801a' 802# duplicate of 152 803tests[195]='use PerlIO; eval { require PerlIO::scalar }; find PerlIO::Layer "scalar"; print q(ok)' 804tests[196]='package Foo; 805sub new { bless {}, shift } 806DESTROY { $_[0] = "foo" } 807package main; 808eval q{\\($x, $y, $z) = (1, 2, 3);}; 809my $m; 810$SIG{__DIE__} = sub { $m = shift }; 811{ my $f = Foo->new } 812print "m: $m\n";' 813result[196]='m: Modification of a read-only value attempted at ccode196.pl line 3.' 814tests[197]='package FINALE; 815{ 816 $ref3 = bless ["ok - package destruction"]; 817 my $ref2 = bless ["ok - lexical destruction\n"]; 818 local $ref1 = bless ["ok - dynamic destruction\n"]; 819 1; 820} 821DESTROY { 822 print $_[0][0]; 823}' 824result[197]='ok - dynamic destruction 825ok - lexical destruction 826ok - package destruction' 827# duplicate of 150 828tests[198]='{ 829 open(my $NIL, qq{|/bin/echo 23}) or die "fork failed: $!"; 830 $! = 1; 831 close $NIL; 832 if($! == 5) { print} 833}' 834result[198]='23' 835# duplicate of 90 836tests[199]='"abc" =~ /(.)./; print @+; print "end\n"' 837result[199]='21end' 838tests[200]='use Encode::Byte; use Encode::KR; print "ok\n"' 839tests[2000]='%u=("\x{123}"=>"fo"); print "ok" if $u{"\x{123}"} eq "fo"' 840tests[2001]='BEGIN{%u=("\x{123}"=>"fo");} print "ok" if $u{"\x{123}"} eq "fo";' 841tests[201]='use Storable;*Storable::CAN_FLOCK=sub{1};print qq{ok\n}' 842tests[2011]='sub can {require Config; import Config;return $Config{d_flock}} 843use IO::File; 844can(); 845print "ok\n";' 846tests[203]='#TODO <5.22 perlio layers 847use open(IN => ":crlf", OUT => ":encoding(cp1252)"); 848open F, "<", "/dev/null"; 849my %l = map {$_=>1} PerlIO::get_layers(F, input => 1); 850print $l{crlf} ? q(ok) : keys(%l);' 851# issue 29 852tests[2900]='use open qw(:std :utf8); 853BEGIN{ `echo ö > xx.bak`; } 854open X, "xx.bak"; 855$_ = <X>; 856print unpack("U*", $_), " "; 857print $_ if /\w/;' 858result[2900]='24610 ö' 859tests[207]='use warnings; 860sub asub { } 861asub(tests => 48); 862my $str = q{0}; 863$str =~ /^[ET1]/i; 864{ 865 no warnings qw<io deprecated>; 866 print "ok 1\n" if opendir(H, "t"); 867 print "ok 2" if open(H, "<", "TESTS"); 868}' 869result[207]='ok 1 870ok 2' 871tests[208]='sub MyKooh::DESTROY { print "${^GLOBAL_PHASE} MyKooh " } my $my =bless {}, MyKooh; 872sub OurKooh::DESTROY { print "${^GLOBAL_PHASE} OurKooh" }our $our=bless {}, OurKooh;' 873if [[ `$PERL -e'print (($] < 5.014)?0:1)'` -gt 0 ]]; then 874 result[208]='RUN MyKooh DESTRUCT OurKooh' 875else 876 result[208]=' MyKooh OurKooh' 877fi 878tests[210]='$a = 123; 879package xyz; 880sub xsub {bless [];} 881$x1 = 1; $x2 = 2; 882$s = join(":", sort(keys %xyz::)); 883package abc; 884my $foo; 885print $xyz::s' 886result[210]='s:x1:x2:xsub' 887tests[212]='$blurfl = 123; 888{ 889 package abc; 890 $blurfl = 5; 891} 892$abc = join(":", sort(keys %abc::)); 893package abc; 894print "variable: $blurfl\n"; 895print "eval: ". eval q/"$blurfl\n"/; 896package main; 897sub ok { 1 }' 898result[212]='variable: 5 899eval: 5' 900tests[214]=' 901my $expected = "foo"; 902sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) } 903$_ = $expected; 904check; 905undef $expected; 906✓ # $_ not passed' 907result[214]='ok 908ok' 909tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";' 910result[215]=':t3 911:' 912tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}' 913# priority, fails since 5.18 914tests[219]='package OverloadTest; use overload qw("") => sub { ${$_[0]} }; package main; 915my $foo = bless \(my $bar = "ok"), "OverloadTest"; print $foo."\n";' 916tests[2190]='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"' 917result[2190]='11' 918# old issue 220 see 904 919tests[220]='BEGIN { $^H{dooot} = 1 } 920sub hint_fetch { 921 my $key = shift; 922 my @results = caller(0); 923 $results[10]->{$key}; 924} 925print qq{ok\n} if hint_fetch("dooot");' 926tests[2201]='BEGIN { $^H{dчастt} = 1 } 927sub hint_fetch { 928 my $key = shift; 929 my @results = caller(0); 930 $results[10]->{$key}; 931} 932print qq{ok\n} if hint_fetch("dчастt");' 933tests[2231]='use strict; eval q({ $x = sub }); print $@' 934result[2231]='Illegal declaration of anonymous subroutine at (eval 1) line 1.' 935tests[222]='my $qr = qr/(?{<<END})/; 936boom 937END 938print "ok"; 939' 940tests[223]='<*> and print qq{ok\n}' 941tests[224]='use bytes; my $p = "\xB6"; my $u = "\x{100}"; my $pu = "\xB6\x{100}"; print ( $p.$u eq $pu ? "ko\n" : "ok\n" );' 942tests[225]='$_ = $dx = "\x{10f2}"; s/($dx)/$dx$1/; $ok = 1 if $_ eq "$dx$dx"; $_ = $dx = "\x{10f2}"; print qq{end\n};' 943result[225]='end' 944tests[226]='# WontFix 945@INC = (); dbmopen(%H, $file, 0666)' 946result[226]='No dbm on this machine at -e line 1.' 947tests[227]='open IN, "/dev/null" or die $!; *ARGV = *IN; foreach my $x (<>) { print $x; } close IN; print qq{ok\n}' 948tests[229]='sub yyy () { "yyy" } print "ok\n" if( eval q{yyy} eq "yyy");' 949#issue 30 950tests[230]='sub f1 { my($self) = @_; $self->f2;} sub f2 {} sub new {} print "@ARGV\n";' 951result[230]=' ' 952tests[232]='use Carp (); exit unless Carp::longmess(); print qq{ok\n}' 953tests[234]='$c = 0; for ("-3" .. "0") { $c++ } ; print "$c"' 954result[234]='4' 955# t/testc.sh -O3 -Dp,-UCarp,-v 235 956tests[235]='BEGIN{$INC{"Carp.pm"}="/dev/null"} $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } print $ol' 957result[235]='6' 958# -O3 959tests[236]='sub t { if ($_[0] == $_[1]) { print "ok\n"; } else { print "not ok - $_[0] == $_[1]\n"; } } t(-1.2, " -1.2");' 960tests[237]='print "\000\000\000\000_"' 961result[237]='_' 962tests[238]='sub f ($); 963sub f ($) { 964 my $test = $_[0]; 965 write; 966 format STDOUT = 967ok @<<<<<<< 968$test 969. 970} 971f(""); 972' 973tests[2381]='sub is { $_[0] eq $_[1] and print "ok\n"} 974use constant INIT => 5; is(INIT, 5)' 975tests[239]='my $x="1"; 976format STDOUT = 977ok @<<<<<<< 978$x 979. 980write;print "\n";' 981result[239]='ok 1' 982tests[240]='my $a = "\x{100}\x{101}Aa"; 983print "ok\n" if "\U$a" eq "\x{100}\x{100}AA"; 984my $b = "\U\x{149}cD"; # no pb without that line' 985tests[241]='package Pickup; use UNIVERSAL qw( can ); if (can( "Pickup", "can" ) != \&UNIVERSAL::can) { print "not " } print "ok\n";' 986tests[242]='$xyz = ucfirst("\x{3C2}"); 987$a = "\x{3c3}foo.bar"; 988($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; 989print "ok\n" if $c eq "\x{3a3}foo.Bar";' 990tests[243]='use warnings "deprecated"; print hex(${^WARNINGS}) . " "; print hex(${^H})' 991result[243]='0 598' 992tests[244]='print "($_)\n" for q{-2}..undef;' 993result[244]='(-2) 994(-1) 995(0)' 996tests[245]='%INC = (); require XSLoader; XSLoader::load("Cwd"); print qq{ok}' 997tests[2450]='sub foo { 998 my ( $a, $b ) = @_; 999 print "a: ".ord($a)." ; b: ".ord($b)." [ from foo ]\n"; 1000} 1001print "a: ". ord(lc("\x{1E9E}"))." ; "; 1002print "b: ". ord("\x{df}")."\n"; 1003foo(lc("\x{1E9E}"), "\x{df}");' 1004result[2450]='a: 223 ; b: 223 1005a: 223 ; b: 223 [ from foo ]' 1006tests[246]='no warnings "experimental::const_attr"; print qq{ok} if &{sub () : const { 42 }} == 42;' 1007# see t/issue235.t test 2 1008tests[2460]='sub foo($\@); eval q/foo "s"/; print $@' 1009result[2460]='Not enough arguments for main::foo at (eval 1) line 1, at EOF' 1010tests[247]='# WontFix 1011no warnings; $[ = 1; $big = "N\xabN\xab"; print qq{ok\n} if rindex($big, "N", 3) == 3' 1012tests[248]='#WONTFIX lexical $_ in re-eval 1013{my $s="toto";my $_="titi";{$s =~ /to(?{ print "-$_-$s-\n";})to/;}}' 1014result[248]='-titi-toto-' 1015tests[249]='use version; print version::is_strict(q{01}) ? 1 : q(ok)' 1016tests[2501]='#TODO version 1017use warnings qw/syntax/; use version; $withversion::VERSION = undef; eval q/package withversion 1.1_;/; print $@;' 1018result[2501]='Misplaced _ in number at (eval 1) line 1. 1019Invalid version format (no underscores) at (eval 1) line 1, near "package withversion " 1020syntax error at (eval 1) line 1, near "package withversion 1.1_"' 1021if [[ $v518 -gt 0 ]]; then 1022 tests[250]='use feature q/evalbytes/; print "ok\n" if evalbytes("1+7") == 8' 1023fi 1024tests[251]='sub f;print "ok" if exists &f' 1025tests[2511]='#TODO 5.18 1026sub f :lvalue;print "ok" if exists &f' 1027tests[2512]='sub f ();print "ok" if exists &f' 1028tests[2513]='sub f ($);print "ok" if exists &f' 1029tests[2514]='sub f;print "ok" if exists &f' 1030# see also 188 1031tests[252]='package bar; sub search { shift =~ m?bar? ? 1 : 0 } sub reset_zlopp { reset } package foo; sub ZZIP { shift =~ m?ZZIP? ? 1 : 0 } package main; foo::ZZIP("ZZIP"); bar::reset_zlopp(); !foo::ZZIP("ZZIP") and print "ok"' 1032# same as 188 1033tests[2520]='package aiieee;sub zlopp {(shift =~ m?zlopp?) ? 1 : 0;} sub reset_zlopp {reset;} 1034package main; print aiieee::zlopp(""), aiieee::zlopp("zlopp"), aiieee::zlopp(""), aiieee::zlopp("zlopp"); 1035aiieee::reset_zlopp(); print "ok" if aiieee::zlopp("zlopp") eq "01001"' 1036tests[2521]='package aiieee;sub zlopp { (shift =~ m?zlopp?) ? 1 : 0 } sub reset_zlopp { reset } 1037package main; 1038aiieee::zlopp(""); 1039aiieee::zlopp("zlopp"); 1040aiieee::reset_zlopp(); 1041print "ok\n" if aiieee::zlopp("zlopp");' 1042tests[253]='use Unicode::UCD q/prop_invmap/; my @list = prop_invmap("Uppercase_Mapping"); print "ok"' 1043tests[2530]='INIT{require "t/TestBC.pm"}plan(tests=>2);is("\x{2665}", v9829);is(v9829,"\x{2665}");' 1044result[2530]='1..2 1045ok 1 1046ok 2' 1047tests[254]='Foo->UNIVERSAL::can("boogie"); print "ok" unless eval q/Foo->boogie(); 1/;' 1048tests[2540]='#TODO destroy upgraded lexvar 1049my $flag = 0; 1050sub X::DESTROY { $flag = 1 } 1051{ 1052 my $x; # x only exists in that scope 1053 BEGIN { $x = 42 } # pre-initialized as IV 1054 $x = bless {}, "X"; # run-time upgrade and bless to call DESTROY 1055 # undef($x); # value should be free when exiting scope 1056} 1057print "ok\n" if $flag;' 1058# duplicate of 185, bytes_heavy 1059tests[255]='$a = chr(300); 1060my $l = length($a); 1061my $lb; 1062{ use bytes; $lb = length($a); } 1063print( ( $l == 1 && $lb == 2 ) ? "ok\n" : "l -> $l ; lb -> $lb\n" );' 1064tests[256]='BEGIN{ $| = 1; } print "ok\n" if $| == 1' 1065tests[2561]='BEGIN{ $/ = "1"; } print "ok\n" if $/ == "1"' 1066tests[259]='use JSON::XS; print encode_json([\0])' 1067result[259]='[false]' 1068tests[260]='sub FETCH_SCALAR_ATTRIBUTES {''} sub MODIFY_SCALAR_ATTRIBUTES {''}; my $a :x=1; print $a' 1069result[260]='1' 1070tests[261]='q(12-feb-2015) =~ m#(\d\d?)([\-\./])(feb|jan)(?:\2(\d\d+))?#; print $4' 1071result[261]='2015' 1072tests[262]='use POSIX' 1073result[262]=' ' 1074tests[263]='use JSON::XS; print encode_json []' 1075result[263]='[]' 1076tests[264]='no warnings; warn "$a.\n"' 1077result[264]='.' 1078tests[269]='use constant roref => \2; eval { for (roref) { $_ = 42 } }; print $@' 1079tests[270]='*x = *STDOUT; print {*x{IO}} "ok\n";' 1080tests[271]='my $FALSE = 0; 1081END { delete $ENV{"Boom"} if $FALSE } 1082 1083my $kid = open my $fh, "-|"; 1084if ($kid) { # parent 1085 my $read = <$fh>; 1086 close($fh) or die "cannot close pipe from kid proc: $!"; 1087 print "ok\n"; 1088} 1089else { # child 1090 print "$$\n"; 1091 exit; 1092}' 1093tests[272]='$d{""} = qq{ok\n}; print $d{""};' 1094tests[2721]='BEGIN{$d{""} = qq{ok\n};} print $d{""};' 1095tests[273]='package _charnames; sub foo { ($name =~ /^(\p{_Perl_Charname_Begin})/) and return; } print "ok\n";' 1096tests[2731]='print "ok" if "\N{KELVIN SIGN}" eq "\N{KELVIN SIGN}"' 1097tests[274]='package Foo; 1098sub match { shift =~ m?xyz? ? 1 : 0; } 1099sub match_reset { reset; } 1100package Bar; 1101sub match { shift =~ m?xyz? ? 1 : 0; } 1102sub match_reset { reset; } 1103package main; 1104print "1..5\n"; 1105print "ok 1\n" if Bar::match("xyz"); 1106print "ok 2\n" unless Bar::match("xyz"); 1107print "ok 3\n" if Foo::match("xyz"); 1108print "ok 4\n" unless Foo::match("xyz"); 1109Foo::match_reset(); 1110print "ok 5\n" if Foo::match("xyz"); 1111print "ok 6\n" if !Bar::match("xyz"); 1112' 1113result[274]='1..5 1114ok 1 1115ok 2 1116ok 3 1117ok 4 1118ok 5' 1119# ignored xop 1120tests[2740]='use Devel::Peek; my %hash = ( a => 1 ); Dump(%hash) if $ENV{FALSE}; print "ok\n"' 1121# call xop (failed with -O1) 1122tests[2741]='use Devel::Peek; my %hash = ( a => 1 ); Dump(%hash); print "ok\n"' 1123if [[ $v518 -gt 0 ]]; then 1124 tests[276]='sub t2 : lvalue; print qq/ok\n/' 1125fi 1126tests[277]='sub t2 : lvalue; print "ok"' 1127tests[2770]='format OUT = 1128bar ~~ 1129. 1130open(OUT, ">/dev/null"); write(OUT); close OUT; print q(ok)' 1131tests[278]='my $ok; sub X::DESTROY { $ok = 1 } { my $x; BEGIN { $x = 42 } $x = bless {}, "X"; } print qq/ok\n/ if $ok;' 1132tests[279]='*TIESCALAR = sub {}; tie my $var => "main", 42; <${var}>; print qq/ok\n/' 1133tests[280]='my $z=0; my $li2="c"; my $rh={foo=>["ok"]}; print $rh->{"foo"}->[$li2+$z];' 1134tests[2800]='package M; $| = 1; sub DESTROY {eval {print "Farewell ",ref($_[0])};} package main; bless \$A::B, q{M}; *A:: = \*B::;' 1135result[2800]='Farewell M' 1136tests[2811]='"I like pie" =~ /(I) (like) (pie)/; "@-" eq "0 0 2 7" and print "ok\n"; print "\@- = @-\n\@+ = @+\nlen \@- = ",scalar @-' 1137result[2811]='ok 1138@- = 0 0 2 7 1139@+ = 10 1 6 10 1140len @- = 4' 1141if [[ $v518 -gt 0 ]]; then 1142 tests[281]='# nested formats >5.18 1143open(NEST, ">Op_write.tmp"); 1144format NEST = 1145@<<< 1146{ 1147 my $birds = "birds"; 1148 local *NEST = *BIRDS{FORMAT}; 1149 write NEST; 1150 format BIRDS = 1151@<<<<< 1152$birds; 1153. 1154 "nest" 1155} 1156. 1157write NEST; close NEST; 1158print `cat Op_write.tmp`;' 1159 result[281]='birds 1160nest' 1161fi 1162tests[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";' 1163tests[283]='#238 Undefined format "STDOUT" 1164format = 1165ok 1166. 1167write' 1168tests[2841]='#-O3 only 1169my $x="123456789"; 1170format OUT = 1171^<<~~ 1172$x 1173. 1174open OUT, ">ccode.tmp"; 1175write(OUT); 1176close(OUT); 1177print `cat "ccode.tmp"`' 1178result[2841]='123 1179456 1180789' 1181 1182# issue 287 with Inf and NaN 1183tests[2870]='my $i = "Inf" + 0; print $i <= 0 ? "not $i " : "", "ok\n";' 1184tests[2871]='my $i = "-Inf" + 0; print $i >= 0 ? "not $i " : "", "ok\n";' 1185tests[2872]='my $i = "NaN" + 0; print $i <= 0 ? "not $i " : "", "ok\n"' 1186 1187tests[284]='use Encode; find_encoding("euc-jp") and print qq/ok\n/' 1188# mojibake 1189tests[288]='use utf8; package Diᚪၚd_A; sub ᕘ { "A" } package Diᚪၚd_B; our @ISA = ("Diᚪၚd_A"); sub ᕘ { "B => " . (shift)->SUPER::ᕘ } package Diᚪၚd_C; our @ISA = ("Diᚪၚd_B"); sub ᕘ { "C => " . (shift)->SUPER::ᕘ } Diᚪၚd_C->ᕘ eq "C => B => A" and print "ok";' 1190tests[289]='no warnings; sub z_zwap (&); print qq{ok\n} if eval q{sub z_zwap {return @_}; 1;}' 1191tests[2901]='sub f;print "ok" if exists &f && not defined &f;' 1192tests[290]='print "ok\n"if "IO::File" eq ref *STDOUT{IO}' 1193tests[293]='use Coro; print q(ok)' 1194tests[294]='#!perl -w 1195BEGIN { $SIG{__WARN__} = sub { my $s = shift; do { warn $s; die $s } if $s =~ qr{Constant subroutine.*redefined}i }; } 1196use File::Glob; 1197File::Glob->can("XXX")->() if $ENV{ABCD}; 1198print qq/ok\n/' 1199if [[ $v518 -gt 0 ]]; then 1200 tests[295]='my @a = qw/ok/; my @to = (); s/(\w)(?{push @to, $1})/,$1,/g for @a; print "ok\n" if "@to" eq "o k";' 1201fi 1202tests[2950]='"zzaaabbb" =~ m/(a+)(b+)/ and print "@- : @+\n"' 1203result[2950]='2 2 5 : 8 5 8' 1204if [[ $v510 -gt 0 ]]; then 1205 tests[298]=' 1206package D1; sub testmeth { "wrong" } 1207package C1; our @ISA = qw/D1/; sub testmeth { "right" } 1208package B1; our @ISA = qw/D1/; 1209package A1; use mro "c3"; our @ISA = qw/B1 C1/; sub testmeth { shift->next::method } 1210A1->testmeth() eq "right" and print "ok\n"' 1211fi 1212if [[ $v518 -gt 0 && $v524 -eq 0 ]]; then 1213 tests[299]='no warnings qw{experimental::lexical_topic}; my $s = "ok\n"; my $_ = "not ok\n"; my $r = $s =~ /ok(?{ print qq[$_] })/;' 1214fi 1215tests[2990]='#TODO version 1216package Pickup; use UNIVERSAL qw( VERSION ); print qq{ok\n} if VERSION "UNIVERSAL";' 1217tests[300]='format STDERR = 1218. 1219my $stdout = *STDOUT{IO}; 1220my $stderr = *STDERR{FORMAT}; 1221print ref($stdout).q/ || /.ref($stderr)' 1222result[300]='IO::File || FORMAT' 1223tests[3000]='use mro;print @{mro::get_linear_isa("mro")};' 1224result[3000]='mro' 1225tests[3010]='{ 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";' 1226tests[301]='use utf8; use warnings; sub Ṩp맅싵Ş { "foo" } sub abcd { "bar" } my $w; $SIG{__WARN__} = sub { $w = $_[0] }; *{"Ṩp맅싵Ş"} = \&{"xyz"}; print "W1" if $w; $w = ""; *{"abcd"} = \&{"xyz"}; print "W2" if $w;' 1227result[301]="W1W2" 1228if [[ $v518 -gt 0 ]]; then 1229 tests[302]='use feature "say"; eval q{say "ok"}; print $@ if($@);' 1230 tests[304]='no warnings; use feature "lexical_subs"; my sub a; print qq/ok\n/' 1231 tests[305]='my $gen = sub { sub () { 8 } }; my $sub = &$gen; print qq/ok\n/' 1232fi 1233tests[3050]='use constant ASCII => eval { require Encode; Encode::find_encoding("ascii"); } || 0; print ASCII->encode("www.google.com")' 1234result[3050]='www.google.com' 1235tests[3051]='INIT{ sub ASCII { eval { require Encode; Encode::find_encoding("ASCII"); } || 0; }} print ASCII->encode("www.google.com")' 1236result[3051]='www.google.com' 1237tests[3052]='use Net::DNS::Resolver; my $res = Net::DNS::Resolver->new; $res->send("www.google.com"), print q(ok)' 1238tests[365]='use constant JP => eval { require Encode; Encode::find_encoding("euc-jp"); } || 0; print JP->encode("www.google.com")' 1239result[365]='www.google.com' 1240tests[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();' 1241tests[308]='print (eval q{require Net::SSLeay;} ? qq{ok\n} : $@);' 1242tests[309]='#-O0 only 1243sub Regexp::DESTROY() { print qq/ok\n/ } my $rx = qr//; undef($rx)' 1244tests[3090]='print $_,": ",(eval q{require }.$_.q{;} ? qq{ok\n} : $@) for qw(Net::LibIDN Net::SSLeay);' 1245result[3090]='Net::LibIDN: ok 1246Net::SSLeay: ok' 1247tests[310]='package foo; 1248sub dada { my $line = <DATA> } 1249print dada; 1250__DATA__ 1251ok 1252b 1253c 1254' 1255tests[312]='require Scalar::Util; eval "require List::Util"; print "ok"' 1256tests[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"' 1257tests[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"' 1258tests[316]=' 1259package Diamond_A; sub foo {}; 1260package Diamond_B; use base "Diamond_A"; 1261package Diamond_C; use base "Diamond_A"; 1262package Diamond_D; use base ("Diamond_B", "Diamond_C"); use mro "c3"; 1263package main; my $order = mro::get_linear_isa("Diamond_D"); 1264 print $order->[3] eq "Diamond_A" ? "ok" : "not ok"; print "\n"' 1265 1266tests[3170]='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)' 1267tests[3180]='{ local $\ = "ok" ; print "" }' 1268 1269if [[ $v518 -gt 0 ]]; then 1270 tests[317]='my $ok; 1271 sub kt { $ok = 1 } 1272 our $nested = qr/ (.) (??{ kt $1 }) /x; 1273 my $re = qr/^ ( (??{ $nested }) ) $ /x; 1274 "foo" =~ $re; 1275 print "ok\n" if $ok' 1276fi 1277 1278tests[319]='#TODO Wide character warnings missing (bytes layer ignored) 1279use 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' 1280if [[ $v518 -gt 0 ]]; then 1281 tests[318]='use utf8; LOOP: { last LOOP } print qq(ok\n)' 1282 tests[320]='use utf8; sub участники { print qq{ok\n} } $::{"участники"}->()' 1283 1284 tests[321]='use utf8; 1285 { 1286 # illegal character for one identifier 1287 my $chr = "\N{POUND SIGN}"; 1288 # commenting this eval make the test pass 1289 eval "\$$chr = 1;"; 1290 } 1291 { 1292 my $i = 0x100; 1293 my $chr = chr($i); 1294 eval "my \$$chr = 42;"; 1295 my $re = qr/^\p{_Perl_IDStart}$/; 1296 print qq/ok\n/ if $chr =~ $re; 1297 }' 1298fi 1299tests[3200]='#TODO No warnings reading in invalid utf8 stream (utf8 layer ignored) 1300use 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/;' 1301tests[324]='package Master; 1302use mro "c3"; 1303sub me { "Master" } 1304package Slave; 1305use mro "c3"; 1306use base "Master"; 1307sub me { "Slave of ".(shift)->next::method } 1308package main; 1309print Master->me()."\n"; 1310print Slave->me()."\n"; 1311' 1312result[324]='Master 1313Slave of Master' 1314tests[326]=' 1315package 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;' 1316tests[328]='#WONTFIX re-eval lex/global mixup 1317my $code = q[{$blah = 45}]; our $blah = 12; eval "/(?$code)/"; print "$blah\n"' 1318result[328]=45 1319# probably a duplicate of 295 1320tests[329]='#WONTFIX re-eval lex/global mixup 1321$_ = 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"' 1322result[329]='ok 1323axxxx aaa a aaa aa' 1324tests[330]='"\x{101}a" =~ qr/\x{100}/i && print "ok\n"' 1325tests[331]='package Count;sub getline {print "ok\n"};BEGIN { *The::Count:: = \*Count::; };exists &The::Count::getline ? The::Count->getline() : do {eval "require Devel::Peek;"; Dump(\%The::Count::)}' 1326tests[3310]='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"' 1327tests[332]='#TODO re-eval no_modify, probably WONTFIX 1328use re "eval"; our ( $x, $y, $z ) = 1..3; $x =~ qr/$x(?{ $y = $z++ })/; undef $@; print "ok\n"' 1329tests[333]='use encoding "utf8"; 1330my @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";' 1331tests[335]='use POSIX (); print POSIX::M_SQRT2;' 1332result[335]='1.41421356237309' 1333tests[338]='use utf8; my $l = "ñ"; my $re = qr/ñ/; print $l =~ $re ? qq{ok\n} : length($l)."\n".ord($l)."\n";' 1334tests[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";' 1335tests[342]='use IO::Socket::INET6 (); my $sock = IO::Socket::INET6->new( Blocking => 1, PeerAddr => q/127.0.0.1/, PeerPort => 22 ); print "ok\n";' 1336# used to fail in the inc-i340 branches CORE/base/lex.t 54 1337tests[3401]='sub foo::::::bar { print "ok\n"; } foo::::::bar;' 1338# wontfix on -O3: static string *end for "main::bar" 1339tests[345]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("main::bar", sub { 42 } ); print "ok\n";' 1340# those work fine: 1341tests[3451]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("bar", sub { 42 } ); print "ok\n";' 1342tests[3452]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; $bar="main::bar"; subname($bar, sub { 42 } ); print "ok\n";' 1343tests[348]='package Foo::Bar; sub baz { 1 } 1344package Foo; sub new { bless {}, shift } sub method { print "ok\n"; } 1345package main; Foo::Bar::baz(); 1346my $foo = sub { 1347 Foo->new 1348}->(); 1349$foo->method;' 1350tests[350]='#TODO 5.18-5.22 dbg 1351package Foo::Moose; use Moose; has bar => (is => "rw", isa => "Int"); 1352package main; my $moose = Foo::Moose->new; print "ok" if 32 == $moose->bar(32);' 1353tests[351]='{ BEGIN { *Mover:: = *Mover2::; *Mover2:: = *foo;} 1354package Mover; 1355@ISA = "door"; sub door::dohtem { "dohtem" } print "ok\n";}' 1356tests[352]='package Foo;my $rand = 0;INIT { *reader = sub () { $rand };} 1357print qq/ok\n/;' 1358tests[354]='BEGIN { push @INC, "t"; } 1359use Ccode354i (); 1360my $token = { expansion => "abcd", }; 1361print Ccode354i::check($token);' 1362tests[368]='use EV; print q(ok)' 1363tests[369]=' 1364use EV; 1365use Coro; 1366use Coro::Timer; 1367my @a; 1368push @a, async { 1369 while() { 1370 warn $c++; 1371 Coro::Timer::sleep 1; 1372 }; 1373}; 1374push @a, async { 1375 while() { 1376 warn $d++; 1377 Coro::Timer::sleep 0.5; 1378 }; 1379}; 1380schedule; 1381print q(ok)' 1382tests[1960]='use EV; my $w = EV::timer 1, 1,sub{print"ok\n";exit}; EV::loop' 1383tests[371]='package foo;use Moose; 1384has "x" => (isa => "Int", is => "rw", required => 1); 1385has "y" => (isa => "Int", is => "rw", required => 1); 1386sub clear { my $self = shift; $self->x(0); $self->y(0); } 1387__PACKAGE__->meta->make_immutable; 1388package main; 1389my $f = foo->new( x => 5, y => 6); 1390print $f->x . "\n";' 1391result[371]='5' 1392 1393if [[ $v518 -gt 0 ]]; then 1394 tests[372]='use utf8; require mro; my $f_gen = mro::get_pkg_gen('ᕘ'); undef %ᕘ::; mro::get_pkg_gen('ᕘ'); delete $::{"ᕘ::"}; print "ok";' 1395 tests[373]='package foo; BEGIN {undef %foo::} sub doof { caller(0) } print qq/ok\n/ if +(doof())[3] =~ qr/::doof/' 1396fi 1397tests[2050]='use utf8;package 텟ţ::ᴼ; sub ᴼ_or_Ḋ { "ok" } print ᴼ_or_Ḋ;' 1398tests[2051]='use utf8;package ƂƂƂƂ; sub ƟK { "ok" } package ƦƦƦƦ; use base "ƂƂƂƂ"; my $x = bless {}, "ƦƦƦƦ"; print $x->ƟK();' 1399tests[2052]='{ package Diӑmond_A; sub fಓ { "ok" } } { package Diӑmond_B; use base q{Diӑmond_A}; use mro "c3"; sub fಓ { (shift)->next::method() } } print Diӑmond_B->fಓ();' 1400# silly compiler warnings test, only usable with -q 1401tests[2053]='use strict; BEGIN { $SIG{__WARN__} = sub { die "Dying on warning: ", @_ } } print q{ok}' 1402# empty keys multideref 1403tests[2054]='my %h; $h{""} = q/boom/; print qq{ok\n}' 1404tests[2055]='our %h; $h{""} = q/boom/; print qq{ok\n}' 1405# GH issues: 1406tests[2790]='*TIESCALAR = sub {}; tie my $var => "main", 42; <${var}>; print qq/ok\n/' 1407tests[2230]='# 5.22 SEGV with missing gv_list[0] svop_list[0] 1408<*.*> and print qq{ok\n}' 1409tests[3060]='INIT { $SIG{__WARN__} = sub { die } } print "ok\n";' 1410tests[3061]='END { $SIG{__WARN__} = sub { die } } print "ok\n";' 1411tests[2191]='sub foo1 ($\@); eval q{ foo1 "s" }; print $@ =~ /^Not enough/ ? "ok" : "";' 1412tests[2192]='sub foo1 ($\%); eval q{ foo1 "s" }; print $@ =~ /^Not enough/ ? "ok" : "";' 1413tests[2193]='{local $^W = 1; my $warn = ""; 1414local $SIG{__WARN__} = sub { $warn .= join("",@_) }; 1415eval q(sub badproto4 (@ $b ar) { 1; }); 1416print $warn =~ /Prototype after .@. for main::badproto4/ ? "ok" : $warn;}' 1417# GH 330 1418tests[3300]='#WONTFIX 1419*STDOUT; sub IO::Handle::self { $_[0] }; 1420(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"' 1421tests[3301]='#WORKAROUND 3300 1422IO::Handle->new if $ENV{none}; *STDOUT; sub IO::Handle::self { $_[0] }; 1423(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"' 1424tests[367]='#BROKEN since 5.22 (METHOP for binc) 1425use Math::BigInt; 1426my $x = Math::BigInt->new('1' x 20); 1427print "ok" if ++$x eq "11111111111111111112";' 1428tests[390]='print test(); print test(); 1429sub test() { 1430 *test = sub () { "k" }; 1431 "o"; 1432}' 1433tests[391]='use warnings "closed"; eval "warn qq(\n); print qq(ok\n)";' 1434tests[400]='#TODO 1435use Class::XSAccessor constructor => "new", accessors => [ "foo" ]; 1436my $o = main::->new( foo => "ok" ); 1437print $o->foo,"\n";' 1438tests[4001]='require Class::XSAccessor; 1439Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]); 1440my $o = main::->new( foo => "ok" ); 1441print $o->foo,"\n";' 1442tests[4002]='use Class::XSAccessor; 1443Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]); 1444my $o = main::->new( foo => "ok" ); 1445print $o->foo,"\n";' 1446tests[411]='#TODO run-time regcomp of \p{} 1447our ( $q, $myre ); 1448BEGIN { $q = qr[\p{IsWord}] } 1449eval q/$myre = qr[^$q]/; # add ^ to force the RegExp to be recompiled 1450print qq[ok\n] if q[hello] =~ $myre;' 1451tests[4111]='our ( $q, $myre ); 1452BEGIN { $q = qr[\p{IsWord}] } 1453eval q/$myre = qr[$q]/; # this works 1454print qq[ok\n] if q[hello] =~ $myre;' 1455 1456init 1457 1458# 1459# getopts for -q -k -E -Du,-q -v -O2, -a -c -fro-inc 1460while getopts "XLhaAckoED:B:O:f:q" opt 1461do 1462 if [ "$opt" = "q" ]; then 1463 QUIET=1 1464 CCMD="$CCMD -q" 1465 fi 1466 if [ "$opt" = "o" ]; then Mblib=" "; init; fi 1467 if [ "$opt" = "c" ]; then CONT=1; fi 1468 if [ "$opt" = "k" ]; then KEEP=1; fi 1469 if [ "$opt" = "E" ]; then CPP=1; fi 1470 if [ "$opt" = "h" ]; then help; exit; fi 1471 # -D options: u,-q for quiet, no -D for verbose, -D- for no gcc warnings 1472 if [ "$opt" = "D" ]; then 1473 OCMD="$PERL $Mblib -MO=C,-D${OPTARG}," 1474 if [ $BASE = "testcc.sh" ]; then 1475 OCMD="$PERL $Mblib -MO=CC,-D${OPTARG}," 1476 fi 1477 if [ -z "${OPTARG/-/}" ]; then 1478 CCMD="$CCMD -d" 1479 fi 1480 fi 1481 # -B dynamic or -B static 1482 if [ "$opt" = "B" ]; then 1483 CCMD="$CCMD -B${OPTARG}" 1484 fi 1485 if [ "$opt" = "O" ]; then OPTIM="$OPTARG"; fi 1486 if [ "$opt" = "f" ]; then 1487 OCMD="$(echo $OCMD|sed -e "s/C,/C,-f$OPTARG,/")" 1488 fi 1489 if [ "$opt" = "a" ]; then # replace -Du, by -Do 1490 OCMD="$(echo $OCMD|sed -r -e 's/(-D.*)u,/\1o,/')" 1491 fi 1492 if [ "$opt" = "A" ]; then 1493 CCMD="$CCMD -DALLOW_PERL_OPTIONS" 1494 fi 1495 if [ "$opt" = "L" ]; then 1496 make_symlinks 1497 exit 1498 fi 1499 if [ "$opt" = "X" ]; then 1500 shift 1501 emit_test $1 1502 exit 1503 fi 1504done 1505 1506if [ "$(perl -V:gccversion)" != "gccversion='';" ]; then 1507 if [ "$(uname)" = "xxDarwin" ]; then 1508 CCMD="$CCMD -g -fno-var-tracking" 1509 else 1510 CCMD="$CCMD -g3" 1511 fi 1512fi 1513 1514if [ -z $OPTIM ]; then OPTIM=-1; fi # all 1515 1516if [ -z "$QUIET" ]; then 1517 make 1518else 1519 # O from 5.6 does not support -qq 1520 qq="`$PERL -e'print (($] < 5.007) ? q() : q(-qq,))'`" 1521 # replace -D*,-v by -q 1522 OCMD="$(echo $OCMD |sed -e 's/-D.*,//' -e 's/,-v,/,/' -e s/-MO=/-MO=$qq/)" 1523 OCMDO1="$(echo $OCMDO1|sed -e 's/-D.*,//' -e 's/,-v,/,/' -e s/-MO=/-MO=$qq/)" 1524 OCMDO2="$(echo $OCMDO2|sed -e 's/-D.*,//' -e 's/,-v,/,/' -e s/-MO=/-MO=$qq/)" 1525 OCMDO3="$(echo $OCMDO3|sed -e 's/-D.*,//' -e 's/,-v,/,/' -e s/-MO=/-MO=$qq/)" 1526 OCMDO4="$(echo $OCMDO4|sed -e 's/-D.*,//' -e 's/,-v,/,/' -e s/-MO=/-MO=$qq/)" 1527 # gnu make? 1528 make -s >/dev/null || make 2&>1 >/dev/null 1529fi 1530 1531# need to shift the options 1532while [ -n "$1" -a "${1:0:1}" = "-" ]; do shift; done 1533 1534if [ -n "$1" ]; then 1535 while [ -n "$1" ]; do 1536 ctest $1 1537 shift 1538 done 1539else 1540 for b in $(seq $ntests); do 1541 ctest $b 1542 done 1543 if [ $BASE = "testcc.sh" ]; then 1544 for b in $(seq 101 $(($ncctests+100))); do 1545 ctest $b 1546 done 1547 fi 1548fi 1549 1550# 562 c: 15,25,27 1551# 58 c: 27,29_i 1552# 58 cc: 15,18,21,25,26_o,27,29 1553# 510 c: 15 1554# 510 cc: 11,15,29 1555# 511 c: 11,15,16,29 1556 1557# http://www.nntp.perl.org/group/perl.perl5.porters/2005/07/msg103315.html 1558# FAIL for B::CC should be covered by test 18 1559