view release on metacpan or  search on metacpan

t/testc.sh  view on Meta::CPAN

tests[2741]='use Devel::Peek; my %hash = ( a => 1 ); Dump(%hash); print "ok\n"'
if [[ $v518 -gt 0 ]]; then
  tests[276]='sub t2 : lvalue; print qq/ok\n/'
fi
tests[277]='sub t2 : lvalue; print "ok"'
tests[2770]='format OUT =
bar ~~
.
open(OUT, ">/dev/null"); write(OUT); close OUT; print q(ok)'
tests[278]='my $ok; sub X::DESTROY { $ok = 1 } { my $x; BEGIN { $x = 42 } $x = bless {}, "X"; } print qq/ok\n/ if $ok;'
tests[279]='*TIESCALAR = sub {}; tie my $var => "main", 42; <${var}>; print qq/ok\n/'
tests[280]='my $z=0; my $li2="c"; my $rh={foo=>["ok"]}; print $rh->{"foo"}->[$li2+$z];'
tests[2800]='package M; $| = 1; sub DESTROY {eval {print "Farewell ",ref($_[0])};} package main; bless \$A::B, q{M}; *A:: = \*B::;'
result[2800]='Farewell M'
tests[2811]='"I like pie" =~ /(I) (like) (pie)/; "@-" eq  "0 0 2 7" and print "ok\n"; print "\@- = @-\n\@+ = @+\nlen \@- = ",scalar @-'
result[2811]='ok
@- = 0 0 2 7
@+ = 10 1 6 10
len @- = 4'
if [[ $v518 -gt 0 ]]; then
    tests[281]='# nested formats >5.18
open(NEST, ">Op_write.tmp");
format NEST =
@<<<
{
    my $birds = "birds";
    local *NEST = *BIRDS{FORMAT};
    write NEST;
    format BIRDS =
@<<<<<
$birds;
.
    "nest"
}
.
write NEST; close NEST;
print `cat Op_write.tmp`;'
    result[281]='birds
nest'
fi
tests[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";'
tests[283]='#238 Undefined format "STDOUT"
format =
ok
.
write'
tests[2841]='#-O3 only
my $x="123456789";
format OUT =
^<<~~
$x
.
open OUT, ">ccode.tmp";
write(OUT);
close(OUT);
print `cat "ccode.tmp"`'
result[2841]='123
456
789'

# issue 287 with Inf and NaN
tests[2870]='my $i = "Inf" + 0; print $i <= 0 ? "not $i " : "", "ok\n";'
tests[2871]='my $i = "-Inf" + 0; print $i >= 0 ? "not $i " : "", "ok\n";'
tests[2872]='my $i = "NaN" + 0; print $i <= 0 ? "not $i " : "", "ok\n"'

tests[284]='use Encode; find_encoding("euc-jp") and print qq/ok\n/'
# mojibake
tests[288]='use utf8; package Ｄiᚪၚd_A; sub ᕘ { "A" } package Ｄiᚪၚd_B; our @ISA = ("Ｄiᚪၚd_A"); sub ᕘ { "B => " . (shift)->SUPER::ᕘ } package Ｄiᚪၚd_C; our @ISA = ("Ｄiᚪၚd_B"); sub ᕘ { "C => " . (shift)->SUPER::ᕘ }...
tests[289]='no warnings; sub z_zwap (&); print qq{ok\n} if eval q{sub z_zwap {return @_}; 1;}'
tests[2901]='sub f;print "ok" if exists &f && not defined &f;'
tests[290]='print "ok\n"if "IO::File" eq ref *STDOUT{IO}'
tests[293]='use Coro; print q(ok)'
tests[294]='#!perl -w
BEGIN { $SIG{__WARN__} = sub { my $s = shift; do { warn $s; die $s } if $s =~ qr{Constant subroutine.*redefined}i }; }
use File::Glob;
File::Glob->can("XXX")->() if $ENV{ABCD};
print qq/ok\n/'
if [[ $v518 -gt 0 ]]; then
  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";'
fi
tests[2950]='"zzaaabbb" =~ m/(a+)(b+)/ and print "@- : @+\n"'
result[2950]='2 2 5 : 8 5 8'
if [[ $v510 -gt 0 ]]; then
  tests[298]='
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