caller\( results from the CPAN

caller\(

B-C

view release on metacpan or search on metacpan

# Shared aggregate, P magic
tests[42]=$usethreads'use threads::shared;my %h : shared; print "ok"'
# Aggregate element, n + p magic
tests[43]=$usethreads'use threads::shared;my @a : shared; $a[0]="ok"; print $a[0]'
# perl #72922 (5.11.4 fails with magic_killbackrefs)
tests[44]='use Scalar::Util "weaken";my $re1=qr/foo/;my $re2=$re1;weaken($re2);print "ok" if $re3=qr/$re1/;'
# test dynamic loading
tests[45]='use Data::Dumper ();Data::Dumper::Dumpxs({});print "ok";'
# issue 79: Exporter:: stash missing in main::
#tests[46]='use Exporter; if (exists $main::{"Exporter::"}) { print "ok"; }'
tests[46]='use Exporter; print "ok" if %main::Exporter::'
#tests[46]='use Exporter; print "ok" if scalar(keys(%main::Exporter::)) > 2'
# non-tied av->MAGICAL
tests[47]='@ISA=(q(ok));print $ISA[0];'
# END block del_backref with bytecode only
tests[48]='my $s=q{ok};END{print $s}'
# even this failed until r1000 (AvFILL 3 of END)
#tests[48]='print q{ok};END{}'
# no-fold
tests[49]='print q(ok) if "test" =~ /es/i;'
# @ISA issue 64
tests[50]='package Top;sub top{q(ok)};package Next;our @ISA=qw(Top);package main;print Next->top();'
# XXX TODO sigwarn $w = B::NULL without -v
tests[51]='$SIG{__WARN__}=sub{print "ok"};warn 1;'
# check if general signals work
tests[511]='BEGIN{$SIG{USR1}=sub{$w++;};} kill USR1 => $$; print q(ok) if $w'
#-------------
# issue27
tests[527]='require LWP::UserAgent;print q(ok);'
#issue 24
tests[124]='my %H;dbmopen(%H,q(f),0644);print q(ok);'
tests[68]='package A;
sub test {
  use Data::Dumper ();
  /^(.*?)\d+$/;
  "Some::Package"->new();
}
print "ok"'
# issue71
tests[71]='
package my;
our @a;
sub f {
  my($alias,$name)=@_;
  unshift(@a, $alias => $name);
  my $find = "ok";
  my $val = $a[1];
  if ( ref($alias) eq "Regexp" && $find =~ $alias ) {
    eval $val;
  }
  $find
}
package main;
*f=*my::f;
print "ok" if f(qr/^(.*)$/ => q("\L$1"));'
# object call: method_named with args.
tests[72]='package dummy;sub meth{print "ok"};package main;my dummy $o = bless {},"dummy"; $o->meth("const")'
# object call: dynamic method_named with args.
tests[73]='package dummy;sub meth{print "ok"};package main;my $meth="meth";my $o = bless {},"dummy"; $o->$meth("const")'
tests[74]='package dummy;
my $invoked_as_script = !caller();
__PACKAGE__->script(@ARGV) if $invoked_as_script;
sub script {my($package,@args)=@_;print "ok"}'
# issue 71_2+3: cop_warnings issue76 and const destruction issue71 fixed
# ok with "utf-8-strict"
tests[75]='use Encode;
my $x = "abc";
print "ok" if "abc" eq Encode::decode("UTF-8", $x);'
tests[76]='use warnings;
{ no warnings q(void); # issue76 lexwarn
  length "ok";
  print "ok"
};'
tests[81]='%int::;  #create int package for types
sub x(int,int) { @_ } #cvproto
my $o = prototype \&x;
if ($o eq "int,int") {print "o"}else{print $o};
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);

t/testcc.sh view on Meta::CPAN

my $foo = bless {}, "Foo";
print "ok\n" if "$foo" eq "Foo";'
tests[173]='# WontFix
use constant BEGIN   => 42; print "ok 1\n" if BEGIN == 42;
use constant INIT   => 42; print "ok 2\n" if INIT == 42;
use constant CHECK   => 42; print "ok 3\n" if CHECK == 42;'
result[173]='Prototype mismatch: sub main::BEGIN () vs none at ./ccode173.pl line 2.
Constant subroutine BEGIN redefined at ./ccode173.pl line 2.
ok 1
ok 2
ok 3'
tests[174]='
my $str = "\x{10000}\x{800}";
no warnings "utf8";
{ use bytes; $str =~ s/\C\C\z//; }
my $ref = "\x{10000}\0";
print "ok 1\n" if ~~$str eq $ref;
$str = "\x{10000}\x{800}";
{ use bytes; $str =~ s/\C\C\z/\0\0\0/; }
my $ref = "\x{10000}\0\0\0\0";
print "ok 2\n" if ~~$str eq $ref;'
result[174]='ok 1
ok 2'
tests[175]='{
  # note that moving the use in an eval block solve the problem
  use warnings NONFATAL => all;
  $SIG{__WARN__} = sub { "ok - expected warning\n" };
  my $x = pack( "I,A", 4, "X" );
  print "ok\n";
}'
result[175]='ok - expected warning
ok'
tests[176]='use Math::BigInt; print Math::BigInt::->new(5000000000);'
result[176]='5000000000'
tests[177]='use version; print "ok\n" if version::is_strict("4.2");'
if [[ $v524 -eq 0 ]]; then
  tests[178]='BEGIN { $hash  = { pi => 3.14, e => 2.72, i => -1 } ;} print scalar keys $hash;'
  result[178]='3'
fi
tests[179]='#TODO smartmatch subrefs
{
    package Foo;
    sub new { bless {} }
}
package main;
our $foo = Foo->new;
our $bar = $foor; # required to generate the wrong behavior
my $match = eval q($foo ~~ undef) ? 1 : 0;
print "match ? $match\n";'
result[179]='match ? 0'
tests[180]='use feature "switch"; use integer; given(3.14159265) { when(3) { print "ok\n"; } }'
tests[181]='sub End::DESTROY { $_[0]->() };
my $inx = "OOOO";
$SIG{__WARN__} = sub { print$_[0] . "\n" };
{
    $@ = "XXXX";
    my $e = bless( sub { die $inx }, "End")
}
print q(ok)'
tests[182]='#TODO stash-magic delete renames to ANON
my @c; sub foo { @c = caller(0); print $c[3] } my $fooref = delete $::{foo}; $fooref -> ();'
result[182]='main::__ANON__'
tests[183]='main->import(); print q(ok)'
tests[184]='use warnings;
sub xyz { no warnings "redefine"; *xyz = sub { $a <=> $b }; &xyz }
eval { @b = sort xyz 4,1,3,2 };
print defined $b[0] && $b[0] == 1 && $b[1] == 2 && $b[2] == 3 && $b[3] == 4 ? "ok\n" : "fail\n";
exit;
{
    package Foo;
    use overload (qw("" foo));
}
{
    package Bar;
    no warnings "once";
    sub foo { $ENV{fake} }
}
'
# usage: t/testc.sh -O3 -Dp,-UCarp 185
tests[185]='my $a=pack("U",0xFF);use bytes;print "not " unless $a eq "\xc3\xbf" && bytes::length($a) == 2; print "ok\n";'
tests[186]='eval q/require B/; my $sub = do { package one; \&{"one"}; }; delete $one::{one}; my $x = "boom"; print "ok\n";'
# duplicate of 182
tests[187]='my $glob = \*Phoo::glob; undef %Phoo::; print ( ( "$$glob" eq "*__ANON__::glob" ) ? "ok\n" : "fail with $$glob\n" );'
# See also GH 252 + 360
tests[188]='package aiieee;sub zlopp {(shift =~ m?zlopp?) ? 1 : 0;} sub reset_zlopp {reset;}
package main; print aiieee::zlopp(""), aiieee::zlopp("zlopp"), aiieee::zlopp(""), aiieee::zlopp("zlopp");
aiieee::reset_zlopp(); print aiieee::zlopp("zlopp")'
result[188]='01001'
tests[191]='# WontFix
BEGIN{sub plan{42}} {package Foo::Bar;} print((exists $Foo::{"Bar::"} && $Foo::{"Bar::"} eq "*Foo::Bar::") ? "ok\n":"bad\n"); plan(fake=>0);'
tests[192]='use warnings;
{
 no warnings qw "once void";
 my %h; # We pass a key of this hash to the subroutine to get a PVLV.
 sub { for(shift) {
  # Set up our glob-as-PVLV
  $_ = *hon;
  # Assigning undef to the glob should not overwrite it...
  {
   my $w;
   local $SIG{__WARN__} = sub { $w = shift };
   *$_ = undef;
   print ( $w =~ m/Undefined value assigned to typeglob/ ? "ok" : "not ok");
  }
 }}->($h{k});
}'
tests[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;'
tests[194]='$0 = q{ccdave with long name}; #print "pid: $$\n";
$s=`ps w | grep "$$" | grep "[c]cdave"`;
print ($s =~ /ccdave with long name/ ? q(ok) : $s);'
tests[1941]='$0 = q{ccdave}; #print "pid: $$\n";
$s=`ps auxw | grep "$$" | grep "ccdave"|grep -v grep`;
print q(ok) if $s =~ /ccdave/'
# VmRSS memory usage
tests[1942]='$s=<DATA>;print `ps -p $$ -O rss,vsz,pmem`;
__DATA__
a'
# duplicate of 152
tests[195]='use PerlIO;  eval { require PerlIO::scalar }; find PerlIO::Layer "scalar"; print q(ok)'
tests[196]='package Foo;
sub new { bless {}, shift }

t/testcc.sh view on Meta::CPAN

my $str = q{0};
$str =~ /^[ET1]/i;
{
    no warnings qw<io deprecated>;
    print "ok 1\n" if opendir(H, "t");
    print "ok 2" if open(H, "<", "TESTS");
}'
result[207]='ok 1
ok 2'
tests[208]='sub MyKooh::DESTROY { print "${^GLOBAL_PHASE} MyKooh " }  my $my =bless {}, MyKooh;
sub OurKooh::DESTROY { print "${^GLOBAL_PHASE} OurKooh" }our $our=bless {}, OurKooh;'
if [[ `$PERL -e'print (($] < 5.014)?0:1)'` -gt 0 ]]; then
  result[208]='RUN MyKooh DESTRUCT OurKooh'
else
  result[208]=' MyKooh  OurKooh'
fi
tests[210]='$a = 123;
package xyz;
sub xsub {bless [];}
$x1 = 1; $x2 = 2;
$s = join(":", sort(keys %xyz::));
package abc;
my $foo;
print $xyz::s'
result[210]='s:x1:x2:xsub'
tests[212]='$blurfl = 123;
{
    package abc;
    $blurfl = 5;
}
$abc = join(":", sort(keys %abc::));
package abc;
print "variable: $blurfl\n";
print "eval: ". eval q/"$blurfl\n"/;
package main;
sub ok { 1 }'
result[212]='variable: 5
eval: 5'
tests[214]='
my $expected = "foo";
sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) }
$_ = $expected;
check;
undef $expected;
&check; # $_ not passed'
result[214]='ok
ok'
tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";'
result[215]=':t3
:'
tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}'
# priority, fails since 5.18
tests[219]='package OverloadTest; use overload qw("") => sub { ${$_[0]} }; package main;
my $foo = bless \(my $bar = "ok"), "OverloadTest"; print $foo."\n";'
tests[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"'
result[2190]='11'
# old issue 220 see 904
tests[220]='BEGIN { $^H{dooot} = 1 }
sub hint_fetch {
    my $key = shift;
    my @results = caller(0);
    $results[10]->{$key};
}
print qq{ok\n} if hint_fetch("dooot");'
tests[2201]='BEGIN { $^H{dÑ‡Ð°ÑÑ‚t} = 1 }
sub hint_fetch {
    my $key = shift;
    my @results = caller(0);
    $results[10]->{$key};
}
print qq{ok\n} if hint_fetch("dÑ‡Ð°ÑÑ‚t");'
tests[2231]='use strict; eval q({ $x = sub }); print $@'
result[2231]='Illegal declaration of anonymous subroutine at (eval 1) line 1.'
tests[222]='my $qr = qr/(?{<<END})/;
boom
END
print "ok";
'
tests[223]='<*> and print qq{ok\n}'
tests[224]='use bytes; my $p = "\xB6"; my $u = "\x{100}"; my $pu = "\xB6\x{100}"; print ( $p.$u eq $pu ? "ko\n" : "ok\n" );'
tests[225]='$_ = $dx = "\x{10f2}"; s/($dx)/$dx$1/; $ok = 1 if $_ eq "$dx$dx"; $_ = $dx = "\x{10f2}"; print qq{end\n};'
result[225]='end'
tests[226]='# WontFix
@INC = (); dbmopen(%H, $file, 0666)'
result[226]='No dbm on this machine at -e line 1.'
tests[227]='open IN, "/dev/null" or die $!; *ARGV = *IN; foreach my $x (<>) { print $x; } close IN; print qq{ok\n}'
tests[229]='sub yyy () { "yyy" } print "ok\n" if( eval q{yyy} eq "yyy");'
#issue 30
tests[230]='sub f1 { my($self) = @_; $self->f2;} sub f2 {} sub new {} print "@ARGV\n";'
result[230]=' '
tests[232]='use Carp (); exit unless Carp::longmess(); print qq{ok\n}'
tests[234]='$c = 0; for ("-3" .. "0") { $c++ } ; print "$c"'
result[234]='4'
# t/testc.sh -O3 -Dp,-UCarp,-v 235
tests[235]='BEGIN{$INC{"Carp.pm"}="/dev/null"} $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } print $ol'
result[235]='6'
# -O3
tests[236]='sub t { if ($_[0] == $_[1]) { print "ok\n"; } else { print "not ok - $_[0] == $_[1]\n"; } } t(-1.2, " -1.2");'
tests[237]='print "\000\000\000\000_"'
result[237]='_'
tests[238]='sub f ($);
sub f ($) {
  my $test = $_[0];
  write;
  format STDOUT =
ok @<<<<<<<
$test
.
}
f("");
'
tests[2381]='sub is { $_[0] eq $_[1] and print "ok\n"}
use constant INIT => 5; is(INIT, 5)'
tests[239]='my $x="1";
format STDOUT =
ok @<<<<<<<
$x
.
write;print "\n";'
result[239]='ok 1'
tests[240]='my $a = "\x{100}\x{101}Aa";
print "ok\n" if "\U$a" eq "\x{100}\x{100}AA";
my $b = "\U\x{149}cD"; # no pb without that line'
tests[241]='package Pickup; use UNIVERSAL qw( can ); if (can( "Pickup", "can" ) != \&UNIVERSAL::can) { print "not " } print "ok\n";'
tests[242]='$xyz = ucfirst("\x{3C2}");
$a = "\x{3c3}foo.bar";
($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge;
print "ok\n" if $c eq "\x{3a3}foo.Bar";'

t/testcc.sh view on Meta::CPAN

tests[342]='use IO::Socket::INET6 (); my $sock = IO::Socket::INET6->new( Blocking => 1, PeerAddr => q/127.0.0.1/, PeerPort => 22 ); print "ok\n";'
# used to fail in the inc-i340 branches CORE/base/lex.t 54
tests[3401]='sub foo::::::bar { print "ok\n"; } foo::::::bar;'
# wontfix on -O3: static string *end for "main::bar"
tests[345]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("main::bar", sub { 42 } ); print "ok\n";'
# those work fine:
tests[3451]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; subname("bar", sub { 42 } ); print "ok\n";'
tests[3452]='eval q/use Sub::Name; 1/ or die "no Sub::Name"; $bar="main::bar"; subname($bar, sub { 42 } ); print "ok\n";'
tests[348]='package Foo::Bar; sub baz { 1 }
package Foo; sub new { bless {}, shift } sub method { print "ok\n"; }
package main; Foo::Bar::baz();
my $foo = sub {
  Foo->new
}->();
$foo->method;'
tests[350]='#TODO 5.18-5.22 dbg
package Foo::Moose; use Moose; has bar => (is => "rw", isa => "Int");
package main; my $moose = Foo::Moose->new; print "ok" if 32 == $moose->bar(32);'
tests[351]='{ BEGIN { *Mover:: = *Mover2::; *Mover2:: = *foo;} 
package Mover;
@ISA = "door"; sub door::dohtem { "dohtem" } print "ok\n";}'
tests[352]='package Foo;my $rand = 0;INIT { *reader = sub () { $rand };}
print qq/ok\n/;'
tests[354]='BEGIN { push @INC, "t"; }
use Ccode354i ();
my $token = { expansion => "abcd", };
print Ccode354i::check($token);'
tests[368]='use EV; print q(ok)'
tests[369]='
use EV;
use Coro;
use Coro::Timer;
my @a;
push @a, async {
  while() {
    warn $c++;
    Coro::Timer::sleep 1;
  };
};
push @a, async {
  while() {
    warn $d++;
    Coro::Timer::sleep 0.5;
  };
};
schedule;
print q(ok)'
tests[1960]='use EV; my $w = EV::timer 1, 1,sub{print"ok\n";exit}; EV::loop'
tests[371]='package foo;use Moose;
has "x" => (isa => "Int", is => "rw", required => 1);
has "y" => (isa => "Int", is => "rw", required => 1);
sub clear { my $self = shift; $self->x(0); $self->y(0); }
__PACKAGE__->meta->make_immutable;
package main;
my $f = foo->new( x => 5, y => 6);
print $f->x . "\n";'
result[371]='5'

if [[ $v518 -gt 0 ]]; then
  tests[372]='use utf8; require mro; my $f_gen = mro::get_pkg_gen('á•˜'); undef %á•˜::; mro::get_pkg_gen('á•˜'); delete $::{"á•˜::"}; print "ok";'
  tests[373]='package foo; BEGIN {undef %foo::} sub doof { caller(0) } print qq/ok\n/ if +(doof())[3] =~ qr/::doof/'
fi
tests[2050]='use utf8;package í…ŸÅ£::á´¼; sub á´¼_or_á¸Š { "ok" } print á´¼_or_á¸Š;'
tests[2051]='use utf8;package Æ‚Æ‚Æ‚Æ‚; sub ÆŸK { "ok" } package Æ¦Æ¦Æ¦Æ¦; use base "Æ‚Æ‚Æ‚Æ‚"; my $x = bless {}, "Æ¦Æ¦Æ¦Æ¦"; print $x->ÆŸK();'
tests[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à²“();'
# silly compiler warnings test, only usable with -q
tests[2053]='use strict; BEGIN { $SIG{__WARN__} = sub { die "Dying on warning: ", @_ } } print q{ok}'
# empty keys multideref
tests[2054]='my %h; $h{""} = q/boom/; print qq{ok\n}'
tests[2055]='our %h; $h{""} = q/boom/; print qq{ok\n}'
# GH issues:
tests[2790]='*TIESCALAR = sub {}; tie my $var => "main", 42; <${var}>; print qq/ok\n/'
tests[2230]='# 5.22 SEGV with missing gv_list[0] svop_list[0]
<*.*> and print qq{ok\n}'
tests[3060]='INIT { $SIG{__WARN__} = sub { die } } print "ok\n";'
tests[3061]='END { $SIG{__WARN__} = sub { die } } print "ok\n";'
tests[2191]='sub foo1 ($\@); eval q{ foo1 "s" }; print $@ =~ /^Not enough/ ? "ok" : "";'
tests[2192]='sub foo1 ($\%); eval q{ foo1 "s" }; print $@ =~ /^Not enough/ ? "ok" : "";'
tests[2193]='{local $^W = 1; my $warn = "";
local $SIG{__WARN__} = sub { $warn .= join("",@_) };
eval q(sub badproto4 (@ $b ar) { 1; });
print $warn =~ /Prototype after .@. for main::badproto4/ ? "ok" : $warn;}'
# GH 330
tests[3300]='#WONTFIX
*STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[3301]='#WORKAROUND 3300
IO::Handle->new if $ENV{none}; *STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[367]='#BROKEN since 5.22 (METHOP for binc)
use Math::BigInt;
my $x = Math::BigInt->new('1' x 20);
print "ok" if ++$x eq "11111111111111111112";'
tests[390]='print test(); print test();
sub test() {
    *test = sub ()  { "k" };
    "o";
}'
tests[391]='use warnings "closed"; eval "warn qq(\n); print qq(ok\n)";'
tests[400]='#TODO
use Class::XSAccessor constructor => "new", accessors => [ "foo" ];
my $o = main::->new( foo => "ok" );
print $o->foo,"\n";'
tests[4001]='require Class::XSAccessor;
Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]);
my $o = main::->new( foo => "ok" );
print $o->foo,"\n";'
tests[4002]='use Class::XSAccessor;
Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]);
my $o = main::->new( foo => "ok" );
print $o->foo,"\n";'
tests[411]='#TODO run-time regcomp of \p{}
our ( $q, $myre );
BEGIN { $q = qr[\p{IsWord}] }
eval q/$myre = qr[^$q]/; # add ^ to force the RegExp to be recompiled
print qq[ok\n] if q[hello] =~ $myre;'
tests[4111]='our ( $q, $myre );
BEGIN { $q = qr[\p{IsWord}] }
eval q/$myre = qr[$q]/; # this works
print qq[ok\n] if q[hello] =~ $myre;'

( run in 1.654 second using v1.01-cache-2.11-cpan-5b529ec07f3 )