view release on metacpan or  search on metacpan

lib/Acme/Perl/VM/B.pm  view on Meta::CPAN

package Acme::Perl::VM::B;

use strict;
use warnings;

use Exporter qw(import);

use B();
our @EXPORT = grep{ /^[A-Z]/ } @B::EXPORT_OK; # constants
push @EXPORT, qw(sv_undef svref_2object);
B->import(@EXPORT);

unless(defined &OPpPAD_STATE){
    constant->import(OPpPAD_STATE => 0x00);
    push @EXPORT, qw(OPpPAD_STATE);
}
unless(defined &G_WANT){
    constant->import(G_WANT => G_SCALAR() | G_ARRAY() | G_VOID());
    push @EXPORT, qw(G_WANT);
}
unless(defined &OPpITER_REVERSED){
    constant->import(OPpITER_REVERSED => 0x00);
    push @EXPORT, qw(OPpITER_REVERSED);
}

push @EXPORT, qw(NULL TRUE FALSE USE_ITHREADS sv_yes sv_no);
use constant {
    NULL         => bless(\do{ my $addr = 0 }, 'B::SPECIAL'),
    TRUE         => 1,
    FALSE        => 0,
    USE_ITHREADS => defined(&B::regex_padav),

    sv_yes       => B::sv_yes,
    sv_no        => B::sv_no,
};


package
    B::OBJECT;

use B qw(class);

sub dump{
    my($obj) = @_;
    require Devel::Peek;
    Devel::Peek::Dump($obj->object_2svref);
    return;
}

package
    B::OP;

sub dump{
    my($obj) = @_;
    require B::Debug;

    $obj->debug;
    return;
}

package
    B::SPECIAL;

my %special_sv = (
    ${ B::sv_undef() } => \(undef),
    ${ B::sv_yes() }   => \(1 == 1),
    ${ B::sv_no() }    => \(1 != 1),
);

unless(@B::specialsv_name){
    @B::specialsv_name = qw(
        Nullsv
        &PL_sv_undef
        &PL_sv_yes
        &PL_sv_no
        pWARN_ALL
        pWARN_NONE
        pWARN_STD
    );
}

sub object_2svref{
    my($obj) = @_;

    return $special_sv{ $$obj } || do{
        Carp::confess($obj->special_name, ' is not a normal SV object');
    };
}

sub setval{
    my($obj) = @_;

    Acme::Perl::VM::apvm_die('Modification of read-only value (%s) attempted', $obj->special_name);
}

sub STASH(){ undef }

sub POK(){ 0 }
sub ROK(){ 0 }

sub special_name{
    my($obj) = @_;
    return $B::specialsv_name[$$obj] || sprintf 'SPECIAL(0x%x)', $$obj;
}

package
    B::SV;

# for sv_setsv()
sub setsv{
    my($dst, $src) = @_;

    my $dst_ref = $dst->object_2svref;
    ${$dst_ref} = ${$src->object_2svref};
    bless $dst, ref(B::svref_2object( $dst_ref ));

    return $dst;
}

# for sv_setpv()/sv_setiv()/sv_setnv() etc.
sub setval{
    my($dst, $val) = @_;

    my $dst_ref = $dst->object_2svref;
    ${$dst_ref} = $val;
    bless $dst, ref(B::svref_2object( $dst_ref ));

    return $dst;
}

sub clear{
    my($sv) = @_;

    ${$sv->object_2svref} = undef;
    return;
}

sub toCV{
    my($sv) = @_;
    Carp::croak(sprintf 'Cannot convert %s to a CV', B::class($sv));
}

sub STASH(){ undef }

package
    B::PVMG;

sub ROK{
    my($obj) = @_;
    my $dummy = ${ $obj->object_2svref }; # invoke mg_get()
    return $obj->SUPER::ROK;
}

package
    B::CV;

sub toCV{ $_[0] }

sub clear{
    Carp::croak('Cannot clear a CV');
}

sub ROK(){ 0 }

package
    B::GV;


sub toCV{ $_[0]->CV }

sub clear{
    Carp::croak('Cannot clear a CV');
}

sub ROK(){ 0 }

package
    B::AV;

sub setsv{
    my($sv) = @_;
    Carp::croak('Cannot call setsv() for ' . B::class($sv));
}

sub clear{
    my($sv) = @_;