view release on metacpan or  search on metacpan

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

        SAVETMPS FREETMPS
        SAVE SAVECOMPPAD SAVECLEARSV
        SAVEPADSV
        save_scalar save_ary save_hash

        OP_GIMME GIMME_V LVRET

        PAD_SV PAD_SET_CUR_NOSAVE PAD_SET_CUR
        CX_CURPAD_SAVE CX_CURPAD_SV

        dopoptosub dopoptoloop dopoptolabel

        deb apvm_warn apvm_die croak ddx

        GVOP_gv

        vivify_ref
        sv_newmortal sv_mortalcopy sv_2mortal
        SvPV SvNV SvIV SvTRUE
        av_assign av_store
        hv_store hv_store_ent hv_scalar

        defoutgv
        gv_fullname

        looks_like_number
        sv_defined is_null is_not_null
        mark_list
        not_implemented
        dump_object dump_value dump_stack dump_si

        apvm_extern
        cv_external

        APVM_DEBUG APVM_DUMMY
        APVM_SCOPE APVM_TRACE
    );
    our %EXPORT_TAGS = (
        perl_h => \@EXPORT_OK,
    );

    if(APVM_DEBUG && -t *STDERR){
        require Term::ANSIColor;

        *deb = \&_deb_colored;
    }
    else{
        *deb = \&_deb;
    }
}

use Scalar::Util qw(looks_like_number refaddr);
use Carp ();

use Acme::Perl::VM::Context;
use Acme::Perl::VM::Scope;
use Acme::Perl::VM::PP;
use Acme::Perl::VM::B;

our $PL_runops = (APVM_TRACE || APVM_STACK)
    ? \&runops_debug
    : \&runops_standard;

our $PL_op;
our $PL_curcop;

our @PL_stack;
our @PL_markstack;
our @PL_cxstack;
our @PL_scopestack;
our @PL_savestack;
our @PL_tmps;

our $PL_tmps_floor;

our $PL_comppad;
our $PL_comppad_name;
our @PL_curpad;

our $PL_last_in_gv;

our @PL_ppaddr;

our $color = 'GREEN BOLD'; # for debugging log

sub not_implemented;

{
    my $i = 0;
    while(my $ppname = B::ppname($i)){
        my $ppaddr = \$Acme::Perl::VM::PP::{$ppname};

        if(ref($ppaddr) eq 'GLOB'){
            $PL_ppaddr[$i] = *{$ppaddr}{CODE};
        }

        $PL_ppaddr[$i] ||= sub{ not_implemented($ppname) };

        $i++;
    }
}

sub runops_standard{ # run.c
    1 while(${ $PL_op = &{$PL_ppaddr[ $PL_op->type ]} });
    return;
}

sub _op_trace{
    my $flags = $PL_op->flags;
    my $name  = $PL_op->name;

    deb '.%s', $name;
    if(ref($PL_op) eq 'B::COP'){
        deb '(%s%s %s:%d)', 
            ($PL_op->label ? $PL_op->label.': ' : ''),
            $PL_op->stashpv,
            $PL_op->file, $PL_op->line,
        ;
    }
    elsif($name eq 'entersub'){
        my $gv = TOP;
        if(!$gv->isa('B::GV')){
            $gv = $gv->GV;
        }
        deb '(%s)', gv_fullname($gv, '&');
    }
    elsif($name eq 'aelemfast'){
        my $name;
        if($flags & OPf_SPECIAL){
            my $padname = $PL_comppad_name->ARRAYelt($PL_op->targ);
            $name = $padname->POK ? '@'.$padname->PVX : '[...]';
        }
        else{
            $name = gv_fullname(GVOP_gv($PL_op), '@');
        }
        deb '[%s[%s]]', $name, $PL_op->private;
    }
    elsif($PL_op->targ && $name !~ /leave/){
        if($name eq 'const' || $name eq 'method_named'){
            my $sv = PAD_SV($PL_op->targ);

            if(is_scalar($sv)){
                deb '(%s)', $sv->POK ? B::perlstring($sv->PVX) : $sv->as_string;
            }
            else{
                deb '(%s)', ddx([$sv->object_2svref])->Indent(0)->Dump;
            }
        }
        else{
            my $padname = $PL_comppad_name->ARRAYelt($PL_op->targ);
            if($padname->POK){
                deb '(%s)', $padname->PVX;
                deb ' INTRO' if $PL_op->private & OPpLVAL_INTRO;
            }
        }
    }
    elsif($PL_op->can('sv')){
        my $sv = SVOP_sv($PL_op);
        if($sv->class eq 'GV'){
            my $prefix = $name eq 'gvsv' ? '$' : '*';
            deb '(%s)', gv_fullname($sv, $prefix);
            deb ' INTRO' if $PL_op->private & OPpLVAL_INTRO;
        }
        else{
            deb '(%s)', B::perlstring(SvPV(SVOP_sv($PL_op)));
        }
    }

    deb ' VOID'    if( ($flags & OPf_WANT) == OPf_WANT_VOID   );
    deb ' SCALAR'  if( ($flags & OPf_WANT) == OPf_WANT_SCALAR );
    deb ' LIST'    if( ($flags & OPf_WANT) == OPf_WANT_LIST   );

    deb ' KIDS'    if $flags & OPf_KIDS;
    deb ' PARENS'  if $flags & OPf_PARENS;
    deb ' REF'     if $flags & OPf_REF;
    deb ' MOD'     if $flags & OPf_MOD;
    deb ' STACKED' if $flags & OPf_STACKED;
    deb ' SPECIAL' if $flags & OPf_SPECIAL;

    deb "\n";
}

sub runops_debug{
    _op_trace();
    while(${ $PL_op = &{$PL_ppaddr[$PL_op->type]} }){
        if(APVM_STACK){
            dump_stack();
        }

        _op_trace();
    }
    if(APVM_STACK){
        dump_stack();
    }
    return;
}

sub _deb_colored{
    my($fmt, @args) = @_;
    printf STDERR Term::ANSIColor::colored($fmt, $color), @args;
    return;
}
sub _deb{
    my($fmt, @args) = @_;
    printf STDERR $fmt, @args;
    return;
}

sub mess{ # util.c
    my($fmt, @args) = @_;
    my $msg = sprintf $fmt, @args;
    return sprintf "[APVM] %s in %s at %s line %d.\n",
        $msg, $PL_op->desc, $PL_curcop->file, $PL_curcop->line;
}

sub longmess{
    my $msg = mess(@_);
    my $cxix = $#PL_cxstack;
    while( ($cxix = dopoptosub($cxix)) >= 0 ){
        my $cx   = $PL_cxstack[$cxix];
        my $cop  = $cx->oldcop;

        my $args;

        if($cx->argarray){
            $args = sprintf '(%s)', join q{,},
            map{ defined($_) ? qq{'$_'} : 'undef' }
                @{ $cx->argarray->object_2svref };
        }
        else{
            $args = '';
        }

        my $cvgv = $cx->cv->GV;
        $msg .= sprintf qq{[APVM]   %s%s called at %s line %d.\n},
            gv_fullname($cvgv), $args,
            $cop->file, $cop->line;

        $cxix--;
    }
    return $msg;
}