view release on metacpan or  search on metacpan

t/testcc.sh  view on Meta::CPAN

sub y($) { @_ } #cvproto
my $p = prototype \&y;
if ($p eq q($)) {print "k"}else{print $p};
require bytes;
sub my::length ($) { # possible prototype mismatch vs _
  if ( bytes->can(q(length)) ) {
     *length = *bytes::length;
     goto &bytes::length;
  }
  return CORE::length( $_[0] );
}
print my::length($p);'
result[81]='ok1'
tests[90]='my $s = q(test string);
$s =~ s/(?<first>test) (?<second>string)/\2 \1/g;
print q(o) if $s eq q(string test);
q(test string) =~ /(?<first>\w+) (?<second>\w+)/;
print q(k) if $+{first} eq q(test);'
tests[901]='my %errs = %!; # t/op/magic.t Errno compiled in
print q(ok) if defined ${"!"}{ENOENT};'
tests[902]='my %errs = %{"!"}; # t/op/magic.t Errno to be loaded at run-time
print q(ok) if defined ${"!"}{ENOENT};'
# issue #199
tests[903]='"abc" =~ /(.)./; print "ok" if "21" eq join"",@+;'
# issue #220
tests[904]='my $content = "ok\n";
while ( $content =~ m{\w}g ) {
    $_ .= "$-[0]$+[0]";
}
print "ok" if $_ eq "0112";'
# IO handles
tests[91]='# issue59
use strict;
use warnings;
use IO::Socket;
my $remote = IO::Socket::INET->new( Proto => "tcp", PeerAddr => "perl.org", PeerPort => "80" );
print $remote "GET / HTTP/1.0" . "\r\n\r\n";
my $result = <$remote>;
$result =~ m|HTTP/1.1 200 OK| ? print "ok" : print $result;
close $remote;'
tests[93]='#SKIP
my ($pid, $out, $in);
BEGIN {
  local(*FPID);
  $pid = open(FPID, "echo <<EOF |");    # DIE
  open($out, ">&STDOUT");		# EASY
  open(my $tmp, ">", "pcc.tmp");	# HARD to get filename, WARN
  print $tmp "test\n";
  close $tmp;				# OK closed
  open($in, "<", "pcc.tmp");		# HARD to get filename, WARN
}
# === run-time ===
print $out "o";
kill 0, $pid; 			     # BAD! warn? die?
print "k" if "test" eq read $in, my $x, 4;
unlink "pcc.tmp";
'
result[93]='o'
tests[931]='my $f;BEGIN{open($f,"<README");}read $f,my $in, 2; print "ok"'
tests[932]='my $f;BEGIN{open($f,">&STDOUT");}print $f "ok"'
tests[95]='use IO::Socket::SSL();
my IO::Handle $handle = IO::Socket::SSL->new(SSL_verify_mode =>0);
$handle->blocking(0);
print "ok";'
tests[96]='defined(&B::OP::name) || print q(ok)'
tests[97]='use v5.12; print q(ok);'

# from here on we test CC specifics only

# CC types and arith
tests[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;'
result[101]='12'
# CC cond_expr, stub, scope
tests[102]='if ($x eq "2"){}else{print "ok"}'
# CC stringify, srefgen
tests[103]='require B; my $x=1e1; my $s="$x"; print ref B::svref_2object(\$s)'
result[103]='B::PV'
# CC reset
tests[104]='@a=(1..4);while($a=shift@a){print $a;}continue{$a=~/2/ and reset q(a);}'
result[104]='12'
# CC -ftype-attr
#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;'
tests[105]='%int::;%double::;my int $r;my int $i=2;our double $d=3.0; $r=$i*$i; $r*=$d; print $r;'
result[105]='12'
# issue 296
tests[106]='my $s=q{ok};END{print $s}END{$x = 0}'

# issue31
tests[131]='package Ccode31i;my $regex = qr/\w+/;sub test {print ("word" =~ m/^$regex$/o ? "ok\n" : "not ok\n");}
package main; &Ccode31i::test();'
# issue35
tests[110]='sub new{}sub test{{my $x=1;my $y=$x+1;}my $x=2;if($x!=3){4;}} print q(ok)'
# issue36
tests[111]='sub f{shift==2}sub test{while(1){last if f(2);}while(1){last if f(2);}} print q(ok)'
# issue37
tests[112]='my $x;$x||=1;print "ok" if $x;'
# issue38
tests[113]='my $x=2;$x=$x||3;print "ok" if $x==2;'
# issue39
tests[114]='sub f1{0}sub f2{my $x;if(f1()){}if($x){}else{[$x]}}my @a=f2();print "ok";'
# issue42
tests[115]='sub f1{1}f1();print do{7;2},"\n";'
result[115]='2'
# issue44
tests[116]='my @a=(1,2);print $a[0],"\n";'
result[116]='1'
# issue45
tests[117]='my $x;$x//=1;print "ok" if $x;'
# issue46
tests[118]='my $pattern="x";"foo"=~/$pattern/o;print "ok";'
# issue47
tests[119]='my $f=sub{while(1){return(1);}};print $f->(),"\n";'
result[119]='1'
# issue48
tests[120]='sub f{()}print((my ($v)=f())?1:2,"\n");'
result[120]='2'
# issue49
tests[121]='while(1){while(1){last;}last;}print "ok"'
# issue51
tests[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"}'
result[122]='http'
# issue52

t/testcc.sh  view on Meta::CPAN

package D1; sub testmeth { "wrong" }
package C1; our @ISA = qw/D1/; sub testmeth { "right" }
package B1; our @ISA = qw/D1/;
package A1; use mro "c3"; our @ISA = qw/B1 C1/; sub testmeth { shift->next::method }
A1->testmeth() eq "right" and print "ok\n"'
fi
if [[ $v518 -gt 0 && $v524 -eq 0 ]]; then
  tests[299]='no warnings qw{experimental::lexical_topic}; my $s = "ok\n"; my $_ = "not ok\n"; my $r = $s =~ /ok(?{ print qq[$_] })/;'
fi
tests[2990]='#TODO version
package Pickup; use UNIVERSAL qw( VERSION ); print qq{ok\n} if VERSION "UNIVERSAL";'
tests[300]='format STDERR =
.
my $stdout = *STDOUT{IO};
my $stderr = *STDERR{FORMAT};
print ref($stdout).q/ || /.ref($stderr)'
result[300]='IO::File || FORMAT'
tests[3000]='use mro;print @{mro::get_linear_isa("mro")};'
result[3000]='mro'
tests[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";'
tests[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;'
result[301]="W1W2"
if [[ $v518 -gt 0 ]]; then
  tests[302]='use feature "say"; eval q{say "ok"}; print $@ if($@);'
  tests[304]='no warnings; use feature "lexical_subs"; my sub a; print qq/ok\n/'
  tests[305]='my $gen = sub { sub () { 8 } }; my $sub = &$gen; print qq/ok\n/'
fi
tests[3050]='use constant ASCII => eval { require Encode; Encode::find_encoding("ascii"); } || 0; print ASCII->encode("www.google.com")'
result[3050]='www.google.com'
tests[3051]='INIT{ sub ASCII { eval { require Encode; Encode::find_encoding("ASCII"); } || 0; }} print ASCII->encode("www.google.com")'
result[3051]='www.google.com'
tests[3052]='use Net::DNS::Resolver; my $res = Net::DNS::Resolver->new; $res->send("www.google.com"), print q(ok)'
tests[365]='use constant JP => eval { require Encode; Encode::find_encoding("euc-jp"); } || 0; print JP->encode("www.google.com")'
result[365]='www.google.com'
tests[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();'
tests[308]='print (eval q{require Net::SSLeay;} ? qq{ok\n} : $@);'
tests[309]='#-O0 only
sub Regexp::DESTROY() { print qq/ok\n/ } my $rx = qr//; undef($rx)'
tests[3090]='print $_,": ",(eval q{require }.$_.q{;} ? qq{ok\n} : $@) for qw(Net::LibIDN Net::SSLeay);'
result[3090]='Net::LibIDN: ok
Net::SSLeay: ok'
tests[310]='package foo;
sub dada { my $line = <DATA> }
print dada;
__DATA__
ok
b
c
'
tests[312]='require Scalar::Util; eval "require List::Util"; print "ok"'
tests[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"'
tests[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"'
tests[316]='
package Diamond_A; sub foo {};
package Diamond_B; use base "Diamond_A";
package Diamond_C; use base "Diamond_A";
package Diamond_D; use base ("Diamond_B", "Diamond_C"); use mro "c3";
package main; my $order = mro::get_linear_isa("Diamond_D");
              print $order->[3] eq "Diamond_A" ? "ok" : "not ok"; print "\n"'

tests[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)'
tests[3180]='{ local $\ = "ok" ; print "" }'

if [[ $v518 -gt 0 ]]; then
  tests[317]='my $ok;
  sub kt { $ok = 1 }
  our $nested = qr/ (.) (??{ kt $1 }) /x;
  my $re = qr/^ ( (??{ $nested }) ) $ /x;
  "foo" =~ $re;
  print "ok\n" if $ok'
fi

tests[319]='#TODO Wide character warnings missing (bytes layer ignored)
use 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'
if [[ $v518 -gt 0 ]]; then
    tests[318]='use utf8; ＬＯＯＰ: { last ＬＯＯＰ } print qq(ok\n)'
    tests[320]='use utf8; sub участники { print qq{ok\n} } $::{"участники"}->()'

    tests[321]='use utf8;
    {
        # illegal character for one identifier
       my $chr = "\N{POUND SIGN}";
       # commenting this eval make the test pass
       eval "\$$chr = 1;";
    }
    {
        my $i = 0x100;
        my $chr = chr($i);
        eval "my \$$chr = 42;";
        my $re = qr/^\p{_Perl_IDStart}$/;
        print qq/ok\n/ if $chr =~ $re;
    }'
fi
tests[3200]='#TODO No warnings reading in invalid utf8 stream (utf8 layer ignored)
use 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 =...
tests[324]='package Master;
use mro "c3";
sub me { "Master" }
package Slave;
use mro "c3";
use base "Master";
sub me { "Slave of ".(shift)->next::method }
package main;
print Master->me()."\n";
print Slave->me()."\n";
'
result[324]='Master
Slave of Master'
tests[326]='
package 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;'
tests[328]='#WONTFIX re-eval lex/global mixup
my $code = q[{$blah = 45}]; our $blah = 12; eval "/(?$code)/"; print "$blah\n"'
result[328]=45
# probably a duplicate of 295
tests[329]='#WONTFIX re-eval lex/global mixup
$_ = 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"'
result[329]='ok
axxxx aaa a aaa aa'
tests[330]='"\x{101}a" =~ qr/\x{100}/i && print "ok\n"'
tests[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::)}'
tests[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"'