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;

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

@loop{qw(SUBST SUB EVAL NULL)} = ();
$loop{LOOP}    = TRUE;

sub dopoptoloop{
    my($startingblock) = @_;

    for(my $i = $startingblock; $i >= 0; --$i){
        my $cx   = $PL_cxstack[$i];
        my $type = $cx->type;

        if(exists $loop{$type}){
            if(!$loop{$type}){
                apvm_warn 'Exsiting %s via %s', $type, $PL_op->name;
                $i = -1 if $type eq 'NULL';
            }
            return $i;
        }
    }
    return -1;
}
sub dopoptolabel{
    my($label) = @_;

    for(my $i = $#PL_cxstack; $i >= 0; --$i){
        my $cx   = $PL_cxstack[$i];
        my $type = $cx->type;

        if(exists $loop{$type}){
            if(!$loop{$type}){
                apvm_warn 'Exsiting %s via %s', $type, $PL_op->name;
                return $type eq 'NULL' ? -1 : $i;
            }
            elsif($cx->label && $cx->label eq $label){
                return $i;
            }
        }
    }
    return -1;
}

sub OP_GIMME{ # op.h
    my($op, $default) = @_;
    my $op_gimme = $op->flags & OPf_WANT;
    return $op_gimme == OPf_WANT_VOID   ? G_VOID
        :  $op_gimme == OPf_WANT_SCALAR ? G_SCALAR
        :  $op_gimme == OPf_WANT_LIST   ? G_ARRAY
        :                                 $default;
}

sub OP_GIMME_REVERSE{ # op.h
    my($flags) = @_;
    $flags &= G_WANT;
    return $flags == G_VOID   ? OPf_WANT_VOID
        :  $flags == G_SCALAR ? OPf_WANT_SCALAR
        :                       OPf_WANT_LIST;
}

sub gimme2want{
    my($gimme) = @_;
    $gimme &= G_WANT;
    return $gimme == G_VOID   ? undef
        :  $gimme == G_SCALAR ? 0
        :                       1;
}
sub want2gimme{
    my($wantarray) = @_;

    return !defined($wantarray) ? G_VOID
        :          !$wantarray  ? G_SCALAR
        :                         G_ARRAY;
}

sub block_gimme{
    my $cxix = dopoptosub($#PL_cxstack);

    if($cxix < 0){
        return G_VOID;
    }

    return $PL_cxstack[$cxix]->gimme;
}

sub GIMME_V(){ # op.h
    my $gimme = OP_GIMME($PL_op, -1);
    return $gimme != -1 ? $gimme : block_gimme();
}

sub LVRET(){ # cf. is_lvalue_sub() in pp_ctl.h
    if($PL_op->flags & OPpMAYBE_LVSUB){
        my $cxix = dopoptosub($#PL_cxstack);

        if($PL_cxstack[$cxix]->lval && $PL_cxstack[$cxix]->cv->CvFLAGS & CVf_LVALUE){
            not_implemented 'lvalue';
            return TRUE;
        }
    }
    return FALSE;
}

sub SVOP_sv{
    my($op) = @_;
    return USE_ITHREADS ? PAD_SV($op->padix) : $op->sv;
}
sub GVOP_gv{
    my($op) = @_;
    return USE_ITHREADS ? PAD_SV($op->padix) : $op->gv;
}

sub vivify_ref{
    not_implemented 'vivify_ref';
}

sub sv_newmortal{
    my $sv;
    push @PL_tmps, \$sv;
    return B::svref_2object(\$sv);
}
sub sv_mortalcopy{
    my($sv) = @_;

    if(!defined $sv){