B-C
9 results

 view release on metacpan or  search on metacpan

ByteLoader/ppport.h  view on Meta::CPAN 


    for (;;) {
	/* we may be in a higher stacklevel, so dig down deeper */
	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
	    top_si = top_si->si_prev;
	    ccstack = top_si->si_cxstack;
	    cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
	}
	if (cxix < 0)
	    return NULL;
	/* caller() should not report the automatic calls to &DB::sub */
	if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
		ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
	    count++;
	if (!count--)
	    break;
	cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
    }

    cx = &ccstack[cxix];
    if (dbcxp) *dbcxp = cx;

    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
        const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
	   field below is defined for any cx. */
	/* caller() should not report the automatic calls to &DB::sub */
	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
	    cx = &ccstack[dbcxix];
    }

    return cx;
}

# endif
#endif /* caller_cx */
#endif /* 5.6.0 */

lib/B/Assembler.pm  view on Meta::CPAN 

sub B::Asmdata::PUT_svindex { B::Asmdata::PUT_objindex( @_, $maxsvix, 'svix' ) }
sub B::Asmdata::PUT_opindex { B::Asmdata::PUT_objindex( @_, $maxopix, 'opix' ) }
sub B::Asmdata::PUT_pvindex { B::Asmdata::PUT_objindex( @_, $maxsvix, 'pvix' ) }
sub B::Asmdata::PUT_hekindex { B::Asmdata::PUT_objindex( @_ ) }

sub B::Asmdata::PUT_strconst {
  error "Missing argument to PUT_strconst" if @_ < 1;
  my $arg = shift;
  my $str = uncstring($arg);
  if ( !defined($str) ) {
    my @callstack = caller(3);
    error "bad string constant: '$arg', called from ".$callstack[3]
      ." line:".$callstack[2] unless $callstack[3] eq 'B::PADNAME::ix'; # empty newpadnx
    $str = '';
  }
  if ( $str =~ s/\0//g ) {
    error "string constant argument contains NUL: $arg";
    $str = '';
  }
  return $str . "\0";
}

lib/B/C.pm  view on Meta::CPAN 

    $section->[-1]{values}->[0] =~ s/^NULL, 0/NULL, $len/;
  }
  foreach ( @{ $section->[-1]{values} } ) {
    my $dbg = "";
    my $ref = "";
    if (m/(s\\_[0-9a-f]+)/) {
      if (!exists($sym->{$1}) and $1 ne 's\_0') {
        $ref = $1;
        $B::C::unresolved_count++;
        if ($B::C::verbose) {
          my $caller = caller(1);
          warn "Warning: unresolved ".$section->name." symbol $ref\n"
            if $caller eq 'B::C';
        }
      }
    }
    s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
    if ($dodbg and $section->[-1]{dbg}->[$i]) {
      $dbg = " /* ".$section->[-1]{dbg}->[$i]." ".$ref." */";
    }
    if ($format eq "\t{ %s }, /* %s_list[%d] %s */%s\n") {

lib/B/C.pm  view on Meta::CPAN 

  my ($cstring,$cur,$utf8) = strlen_flags($op->pv); # utf8 in op_private as OPpPV_IS_UTF8 (0x80)
  # do not use savepvn here #362
  $init->add( sprintf( "pvop_list[%d].op_pv = savesharedpvn(%s, %u);", $ix, $cstring, $cur ));
  savesym( $op, "(OP*)&pvop_list[$ix]" );
}

# XXX Until we know exactly the package name for a method_call
# we improve the method search heuristics by maintaining this mru list.
sub push_package ($) {
  my $p = shift or return;
  warn "save package_pv \"$package_pv\" for method_name from @{[(caller(1))[3]]}\n"
    if $debug{cv} or $debug{pkg} and !grep { $p eq $_ } @package_pv;
  @package_pv = grep { $p ne $_ } @package_pv if @package_pv; # remove duplicates at the end
  unshift @package_pv, $p; 		       # prepend at the front
  mark_package($p);
}

# method_named is in 5.6.1
sub method_named {
  my $name = shift;
  return unless $name;

lib/B/C.pm  view on Meta::CPAN 


sub B::OBJECT::save { }

sub B::NULL::save {
  my ($sv, $fullname) = @_;
  my $sym = objsym($sv);
  return $sym if defined $sym;

  # debug
  if ( $$sv == 0 ) {
    warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n" if $verbose;
    return savesym( $sv, "(void*)Nullsv" );
  }

  my $i = $svsect->index + 1;
  warn "Saving SVt_NULL sv_list[$i]\n" if $debug{sv};
  $svsect->add( sprintf( "NULL, $u32fmt, 0x%x".($PERL510?", {0}":''),
                         $sv->REFCNT, $sv->FLAGS ) );
  #$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags}; # XXX where is this possible?
  if ($debug{flags} and (!$ITHREADS or $PERL514) and $DEBUG_LEAKING_SCALARS) { # add index to sv_debug_file to easily find the Nullsv
    # $svsect->debug( "ix added to sv_debug_file" );

lib/B/C.pm  view on Meta::CPAN 

      $init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
                          2*$Config{ptrsize}));
    }
  } else {
    $svsect->add(sprintf( "&xpvuv_list[%d], $u32fmt, 0x%x".
                          ($PERL510?', {'.($C99?".svu_uv=":"").$uvx."$suff}":''),
             $xpvuvsect->index, $sv->REFCNT, $sv->FLAGS));
  }
  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
  warn sprintf( "Saving IV(UV) 0x%x to xpvuv_list[%d], sv_list[%d], called from %s:%s\n",
    $sv->UVX, $xpvuvsect->index, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
    if $debug{sv};
  savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
}

sub B::IV::save {
  my ($sv, $fullname) = @_;
  my $sym = objsym($sv);
  return $sym if defined $sym;
  # Since 5.11 the RV is no special SV object anymore, just a IV (test 16)
  my $svflags = $sv->FLAGS;

lib/B/C.pm  view on Meta::CPAN 

    } else {
      $init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
                          2*$Config{ptrsize}));
    }
  } else {
    $svsect->add(sprintf( "&xpviv_list[%d], $u32fmt, 0x%x".($PERL510?', {'.($C99?".svu_iv=":"").$ivx.'}':''),
                          $xpvivsect->index, $sv->REFCNT, $svflags ));
  }
  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
  warn sprintf( "Saving IV 0x%x to xpviv_list[%d], sv_list[%d], called from %s:%s\n",
    $sv->IVX, $xpvivsect->index, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
    if $debug{sv};
  savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
}

sub B::NV::save {
  my ($sv, $fullname) = @_;
  my $sym = objsym($sv);
  return $sym if defined $sym;
  my $nv = nvx($sv->NV);
  $nv .= '.00' if $nv =~ /^-?\d+$/;

lib/B/C.pm  view on Meta::CPAN 

  my ($sv, $fullname) = @_;
  my $sv_flags = $sv->FLAGS;
  my $pkg;
  return if $fullname and $fullname eq '%B::C::';
  if ($debug{mg}) {
    my $flagspv = "";
    $fullname = '' unless $fullname;
    $flagspv = $sv->flagspv if $debug{flags} and $PERL510 and !$sv->MAGICAL;
    warn sprintf( "saving magic for %s %s (0x%x) flags=0x%x%s  - called from %s:%s\n",
		B::class($sv), $fullname, $$sv, $sv_flags, $debug{flags} ? "(".$flagspv.")" : "",
		@{[(caller(1))[3]]}, @{[(caller(1))[2]]});
  }

  # crashes on STASH=0x18 with HV PERL_MAGIC_overload_table stash %version:: flags=0x3280000c
  # issue267 GetOpt::Long SVf_AMAGIC|SVs_RMG|SVf_OOK
  # crashes with %Class::MOP::Instance:: flags=0x2280000c also
  if (ref($sv) eq 'B::HV' and $] > 5.018 and $sv->MAGICAL and $fullname =~ /::$/) {
    warn sprintf("skip SvSTASH for overloaded HV %s flags=0x%x\n", $fullname, $sv_flags)
      if $verbose;
  # [cperl #60] not only overloaded, version also
  } elsif (ref($sv) eq 'B::HV' and $] > 5.018 and $fullname =~ /(version|File)::$/) {

lib/B/C.pm  view on Meta::CPAN 

    if $sv_flags & SVf_READONLY and ref($sv) ne 'B::HV';
  $magic;
}

# Since 5.11 also called by IV::save (SV -> IV)
sub B::RV::save {
  my ($sv, $fullname) = @_;
  my $sym = objsym($sv);
  return $sym if defined $sym;
  warn sprintf( "Saving RV %s (0x%x) - called from %s:%s\n",
		B::class($sv), $$sv, @{[(caller(1))[3]]}, @{[(caller(1))[2]]})
    if $debug{sv};

  my $rv = save_rv($sv, $fullname);
  return '0' unless $rv;
  if ($PERL510) {
    $svsect->comment( "any, refcnt, flags, sv_u" );
    # 5.22 has a wrong RV->FLAGS (https://github.com/perl11/cperl/issues/63)
    my $flags = $sv->FLAGS;
    $flags = 0x801 if $flags & 9 and $PERL522; # not a GV but a ROK IV (21)
    # 5.10 has no struct xrv anymore, just sv_u.svu_rv. static or dynamic?

lib/B/C.pm  view on Meta::CPAN 

      $xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
      # Class::MOP without Moose: find Moose.pm
      $xsub{$stashname} = 'Dynamic-' . $savINC{$incpack} unless $INC{$incpack};
      if (!$savINC{$incpack}) {
        eval "require $stashname;";
        $xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
      }
      warn "Assuming xs loaded $stashname with $xsub{$stashname}\n" if $verbose;
    }
    if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic/ ) {
      # XSLoader.pm: $modlibname = (caller())[1]; needs a path at caller[1] to find auto,
      # otherwise we only have -e
      $xs++ if $xsub{$stashname} ne 'Dynamic';
      $dl++;
    }
    my $stashxsub = $stashname;
    $stashxsub =~ s/::/__/g;
    if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic-/
         and ($PERL522 or $staticxs)) {
      print "EXTERN_C void boot_$stashxsub(pTHX_ CV* cv);\n";
    }

lib/B/CC.pm  view on Meta::CPAN 

  else {
    # Careful: POPs has an auto-decrement and SvTRUE evaluates
    # its argument more than once.
    runtime("sv = POPs;");
    return "SvTRUE(sv)";
  }
}

sub write_back_lexicals {
  my $avoid = shift || 0;
  debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  my $lex;
  foreach $lex (@pad) {
    next unless ref($lex);
    $lex->write_back unless $lex->{flags} & $avoid;
  }
}

=head1 save_or_restore_lexical_state

lib/B/CC.pm  view on Meta::CPAN 

        ( $old_flags & VALID_INT ) ? $lex->load_int : $lex->invalidate_int;
      }
      if ( $changed & VALID_STR ) {
        ( $old_flags & VALID_STR ) ? $lex->load_str : $lex->invalidate_str;
      }
    }
  }
}

sub write_back_stack {
  debug "write_back_stack() ".scalar(@stack)." called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  return unless @stack;
  runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) );
  foreach my $obj (@stack) {
    runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) );
  }
  @stack = ();
}

sub invalidate_lexicals {
  my $avoid = shift || 0;
  debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
    if $debug{shadow};
  my $lex;
  foreach $lex (@pad) {
    next unless ref($lex);
    $lex->invalidate unless $lex->{flags} & $avoid;
  }
}

sub reload_lexicals {
  my $lex;

t/TestBC.pm  view on Meta::CPAN 

sub ord_native_to_latin1 {
    # given an input platform code point, return the latin1 equivalent value.
    # Anything above latin1 is itself.

    my $ord = shift;
    return $ord if $ord > 255;
    return ord native_to_latin1(chr $ord);
}

sub _where {
    my @caller = caller($Level);
    return "at $caller[1] line $caller[2]";
}

# runperl - Runs a separate perl interpreter.
# Arguments :
#   switches => [ command-line switches ]
#   nolib    => 1 # don't use -I../lib (included by default)
#   prog     => one-liner (avoid quotes)
#   progs    => [ multi-liner (avoid quotes) ]
#   progfile => perl script

t/issue220.t  view on Meta::CPAN 

use strict;
BEGIN {
  unshift @INC, 't';
  require TestBC;
}
use Test::More ($] >= 5.010 ? (tests => 1) : (skip_all => '%^H requires v5.10'));
my $script = <<'EOF';
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");
EOF

use B::C ();
my $todo = ($B::C::VERSION ge '1.52_22') ? "" : "TODO ";

ctestok(1, 'C', 'ccode200i', $script,
      $todo.'#200 hints hash saved');

t/testc.sh  view on Meta::CPAN 

  $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";

t/testc.sh  view on Meta::CPAN 

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));

t/testc.sh  view on Meta::CPAN 

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";
'

t/testc.sh  view on Meta::CPAN 

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:

t/testcc.sh  view on Meta::CPAN 

  $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";

t/testcc.sh  view on Meta::CPAN 

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));

t/testcc.sh  view on Meta::CPAN 

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";
'

t/testcc.sh  view on Meta::CPAN 

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:

t/testplc.sh  view on Meta::CPAN 

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));



( run in 0.330 second using v1.01-cache-2.11-cpan-a9ef4e587e4 )