view release on metacpan or  search on metacpan

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

    }

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

sub apvm_warn{
    #warn APVM_DEBUG ? longmess(@_) : mess(@_);
    print STDERR longmess(@_);
}
sub apvm_die{
    # not yet implemented completely
    # cf.
    # die_where() in pp_ctl.c
    # vdie()      in util.c
    die  APVM_DEBUG ? longmess(@_) : mess(@_);
}
sub croak{
    die  APVM_DEBUG ? longmess(@_) : mess(@_);
}

sub PUSHMARK(){
    push @PL_markstack, $#PL_stack;
    return;
}
sub POPMARK(){
    return pop @PL_markstack;
}
sub TOPMARK(){
    return $PL_markstack[-1];
}

sub PUSH{
    push @PL_stack, @_;
    return;
}
sub mPUSH{
    PUSH(map{ sv_2mortal($_) } @_);
    return;
}
sub POP(){
    return pop @PL_stack;
}
sub TOP(){
    return $PL_stack[-1];
}
sub SET{
    my($sv) = @_;
    $PL_stack[-1] = $sv;
    return;
}
sub SETval{
    my($val) = @_;
    $PL_stack[-1] = PAD_SV( $PL_op->targ )->setval($val);
    return;
}

sub GET_TARGET{
    return PAD_SV($PL_op->targ);
}
sub GET_TARGETSTACKED{
    return $PL_op->flags & OPf_STACKED ? POP : PAD_SV($PL_op->targ);
}
sub GET_ATARGET{
    return $PL_op->flags & OPf_STACKED ? $PL_stack[$#PL_stack-1] : PAD_SV($PL_op->targ);
}

sub MAXARG{
    return $PL_op->private & 0x0F;
}

sub PUSHBLOCK{
    my($type, %args) = @_;

    $args{oldcop}     = $PL_curcop;
    $args{oldmarksp}  = $#PL_markstack;
    $args{oldscopesp} = $#PL_scopestack;

    my $cx = "Acme::Perl::VM::Context::$type"->new(\%args);
    push @PL_cxstack, $cx;

    if(APVM_CX){
        deb "%s" . "Entering %s\n", (q{>} x @PL_cxstack), $type;
    }

    return $cx;
}

sub POPBLOCK{
    my $cx = pop @PL_cxstack;

    $PL_curcop      = $cx->oldcop;
    $#PL_markstack  = $cx->oldmarksp;
    $#PL_scopestack = $cx->oldscopesp;

    if(APVM_CX){
        deb "%s" . "Leaving %s\n", (q{>} x (@PL_cxstack+1)), $cx->type;
    }

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

sub hv_store_ent{
    my($hv, $key, $sv) = @_;
    tie $hv->object_2svref->{ ${$key->object_2svref} },
        'Acme::Perl::VM::Alias', $sv->object_2svref;
    return;
}

sub hv_scalar{
    my($hv) = @_;
    my $sv = sv_newmortal();
    $sv->setval(scalar %{ $hv->object_2svref });
    return $sv;
}

sub defoutgv{
    no strict 'refs';
    return \*{ select() };
}

sub gv_fullname{
    my($gv, $prefix) = @_;
    $prefix = '' unless defined $prefix;

    my $stashname = $gv->STASH->NAME;
    if($stashname eq 'main'){
        $prefix .= $gv->SAFENAME;
    }
    else{
        $prefix .= join q{::}, $stashname, $gv->SAFENAME;
    }
    return $prefix;
}

# Utilities

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

    return $sv && ${$sv} && defined(${ $sv->object_2svref });
}

sub is_not_null{
    my($sv) = @_;
    return ${$sv};
}
sub is_null{
    my($sv) = @_;
    return !${$sv};
}

my %not_a_scalar;
@not_a_scalar{qw(AV HV CV IO)} = ();
sub is_scalar{
    my($sv) = @_;
    return !exists $not_a_scalar{ $sv->class };
}

sub mark_list{
    my($mark) = @_;
    return map{ ${ $_->object_2svref } } splice @PL_stack, $mark+1;
}


our %external;

sub apvm_extern{
    foreach my $arg(@_){
        if(ref $arg){
            if(ref($arg) ne 'CODE'){
                Carp::croak('Not a CODE reference for apvm_extern()');
            }
            $external{refaddr $arg} = 1;
        }
        else{
            my $stash = do{ no strict 'refs'; \%{$arg .'::'} };
            while(my $name = each %{$stash}){
                my $code_ref = do{ no strict 'refs'; *{$arg . '::' . $name}{CODE} };
                if(defined $code_ref){
                    $external{refaddr $code_ref} = 1;
                }
            }
        }
    }
    return;
}

sub cv_external{
    my($cv) = @_;
    return $cv->XSUB || $external{ ${$cv} };
}

sub ddx{
    require Data::Dumper;
    my $ddx = Data::Dumper->new(@_);
    $ddx->Indent(1);
    $ddx->Terse(TRUE);
    $ddx->Quotekeys(FALSE);
    $ddx->Useqq(TRUE);
    return $ddx if defined wantarray;

    my $name = ( split '::', (caller 2)[3] )[-1];
    print STDERR $name, ': ', $ddx->Dump(), "\n";
    return;
}
sub dump_object{
    ddx([[ map{ $_ ? $_->object_2svref : $_ } @_ ]]);
}

sub dump_value{
    ddx([\@_]);
}


sub dump_stack{
    require Data::Dumper;
    no warnings 'once';

    local $Data::Dumper::Indent    = 0;
    local $Data::Dumper::Terse     = TRUE;
    local $Data::Dumper::Quotekeys = FALSE;
    local $Data::Dumper::Useqq     = TRUE;

    deb "(%s)\n", join q{,}, map{
        # find variable name
        my $varname = '';
        my $class   = $_->class;

        if($class eq 'SPECIAL'){
            ($varname = $_->special_name) =~ s/^\&PL_//;
            $varname;
        }
        elsif($class eq 'CV'){
            $varname = '&' . gv_fullname($_->GV);
        }
        else{
            for(my $padix = 0; $padix < @PL_curpad; $padix++){
                my $padname;
                if(${ $PL_curpad[$padix] } == ${ $_ }){
                    $padname = $PL_comppad_name->ARRAYelt($padix);
                }
                elsif($_->ROK && ${$PL_curpad[$padix]} == ${ $_->RV }){
                    $padname = $PL_comppad_name->ARRAYelt($padix);
                    $varname .= '\\';
                }

                if($padname){
                    if($padname->POK){
                        $varname .= $padname->PVX . ' ';
                    }
                    last;
                }
            }
            $varname . Data::Dumper->Dump([is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref], [$_->ROK ? 'SV' : '*SV']);
        }

    } @PL_stack;

    return;
}
sub _dump_stack{
    my $warn;
    my $ddx = ddx([[map{
            if(ref $_){
                is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref;
            }
            else{
                $warn++;
                $_;
            }
    } @PL_stack]], ['*PL_stack']);
    $ddx->Indent(0);
    deb "  %s\n", $ddx->Dump();

    if($warn){
        apvm_die 'No sv found (%d)', $warn;
    }
    return;
}

sub dump_si{
    my %stack_info = (
        stack     => \@PL_stack,
        markstack => \@PL_markstack,
        cxstack   => \@PL_cxstack,
        scopstack => \@PL_scopestack,
        savestack => \@PL_savestack,
        tmps      => \@PL_tmps,
    );

    ddx([\%stack_info]);
}

sub not_implemented{
    if(!@_){
        if($PL_op && is_not_null($PL_op)){
            @_ = ($PL_op->name);
        }
        else{
            @_ = (caller 0)[3];
        }
    }

    push @_, ' is not implemented';
    goto &Carp::confess;
}


sub call_sv{ # perl.h
    my($sv, $flags) = @_;

    if($flags & G_DISCARD){
        ENTER;
        SAVETMPS;
    }

    my $cv = $sv->toCV();

    my $old_op  = $PL_op;
    my $old_cop = $PL_curcop;

    $PL_op = Acme::Perl::VM::OP_CallSV->new(
        cv    => $cv,