view release on metacpan or  search on metacpan

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

}
sub pp_method_named{
    my $sv = is_not_null($PL_op->sv) ? $PL_op->sv : PAD_SV($PL_op->targ);

    PUSH(_method_common($sv));
    return $PL_op->next;
}

sub pp_entersub{
    my $sv = POP;
    my $cv = $sv->toCV();

    if(is_null($cv)){
        apvm_die 'Undefined subroutine %s called', gv_fullname($sv, '&');
    }
    my $hasargs = ($PL_op->flags & OPf_STACKED) != 0;

    ENTER;
    SAVETMPS;

    my $mark  = POPMARK;
    my $gimme = GIMME_V;

    if(!cv_external($cv)){
        my $cx = PUSHBLOCK(SUB =>
            oldsp => $mark,
            gimme => $gimme,

            cv      => $cv,
            hasargs => $hasargs,
            retop   => $PL_op->next,
        );

        #XXX: How to do {$cv->DEPTH++}?
        PAD_SET_CUR($cv->PADLIST, $cv->DEPTH+1);

        if($hasargs){
            my $av = PAD_SV(0);

            $cx->savearray(\@_);
            *_ = $av->object_2svref;
            $cx->CURPAD_SAVE();
            $cx->argarray($av);

            #@_ = mark_list($mark);
            av_assign($av, splice @PL_stack, $mark+1);
        }

        return $cv->START;
    }
    else{
        my @args;
        av_assign(svref_2object(\@args), splice @PL_stack, $mark+1);

        if($gimme == G_SCALAR){
            my $ret = $cv->object_2svref->(@args);
            mPUSH(svref_2object(\$ret));
        }
        elsif($gimme == G_ARRAY){
            my @ret = $cv->object_2svref->(@args);
            mPUSH(map{ svref_2object(\$_) } @ret);
        }
        else{
            $cv->object_2svref->(@args);
        }
        return $PL_op->next;
    }
}

sub pp_leavesub{
    my $cx    = POPBLOCK;
    my $newsp = $cx->oldsp;
    my $gimme = $cx->gimme;

    if($gimme == G_SCALAR){
        my $mark = $newsp + 1;

        if($mark <= $#PL_stack){
            $PL_stack[$mark] = sv_mortalcopy(TOP);
        }
        else{
            $PL_stack[$mark] = sv_undef;
        }
        $#PL_stack = $mark;
    }
    elsif($gimme == G_ARRAY){
        for(my $mark = $newsp + 1; $mark <= $#PL_stack; $mark++){
            $PL_stack[$mark] = sv_mortalcopy($PL_stack[$mark]);
        }
    }
    else{
        $#PL_stack = $newsp;
    }

    LEAVE;

    POPSUB($cx);
    # XXX: How to do {$cv->DEPTH = $cx->olddepth}?

    return $cx->retop;
}
sub pp_return{
    my $mark = POPMARK;

    my $cxix = dopoptosub($#PL_cxstack);
    if($cxix < 0){
        apvm_die q{Can't return outside a subroutine};
    }

    if($cxix < $#PL_cxstack){
        dounwind($cxix);
    }

    my $cx = POPBLOCK;
    my $popsub2;
    my $retop;

    if($cx->type eq 'SUB'){
        $popsub2 = TRUE;
        $retop   = $cx->retop;
    }

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

    my $right = POP;
    my $left  = TOP;
    SET(SvPV($left) gt SvPV($right) ? sv_yes : sv_no);
    return $PL_op->next;
}
sub pp_sge{
    my $right = POP;
    my $left  = TOP;
    SET(SvPV($left) ge SvPV($right) ? sv_yes : sv_no);
    return $PL_op->next;
}
sub pp_scmp{
    my $right = POP;
    my $left  = TOP;
    SET(SvPV($left) cmp SvPV($right));
    return $PL_op->next;
}


sub pp_add{
    my $targ  = GET_ATARGET;
    my $right = POP;
    my $left  = TOP;

    SET( $targ->setval(SvNV($left) + SvNV($right)) );
    return $PL_op->next;
}

sub pp_multiply{
    my $targ  = GET_ATARGET;
    my $right = POP;
    my $left  = TOP;

    SET( $targ->setval(SvNV($left) * SvNV($right)) );
    return $PL_op->next;
}

sub pp_concat{
    my $targ = GET_ATARGET;
    my $right= POP;
    my $left = TOP;

    SET( $targ->setval(SvPV($left) . SvPV($right)) );
    return $PL_op->next;
}

sub pp_readline{
    $PL_last_in_gv = POP;
    if($PL_last_in_gv->class ne 'GV'){
        PUSH($PL_last_in_gv);
        &pp_rv2gv;
        $PL_last_in_gv = POP;
    }

    # do_readline
    my $targ    = GET_TARGETSTACKED;
    my $istream = $PL_last_in_gv->object_2svref;

    my $gimme = GIMME_V;
    if($gimme == G_ARRAY){
        mPUSH(map{ svref_2object(\$_) } readline $istream);
    }
    else{
        $targ->setval(scalar readline $istream);
        PUSH($targ);
    }

    return $PL_op->next;
}

sub pp_print{
    my $mark     = POPMARK;
    my $origmark = $mark;
    my $gv   = ($PL_op->flags & OPf_STACKED) ? $PL_stack[++$mark]->object_2svref : defoutgv;

    my $ret  = print {$gv} mark_list($mark);

    $#PL_stack = $origmark;
    PUSH( $ret ? sv_yes : sv_no );
    return $PL_op->next;
}
sub pp_say{
    my $mark     = POPMARK;
    my $origmark = $mark;
    my $gv   = ($PL_op->flags & OPf_STACKED) ? $PL_stack[++$mark]->object_2svref : defoutgv;

    local $\ = "\n";
    my $ret  = print {$gv} mark_list($mark);

    $#PL_stack = $origmark;
    PUSH( $ret ? sv_yes : sv_no );
    return $PL_op->next;
}

sub pp_bless{
    my $pkg;
    if(MAXARG == 1){
        $pkg = $PL_curcop->stashpv;
    }
    else{
        my $sv = POP;
        if($sv->ROK){
            apvm_die 'Attempt to bless into a reference';
        }
        $pkg = SvPV($sv);
        if($pkg eq ''){
            apvm_warn q{Explicit blessing to '' (assuming package main)};
        }
    }
    bless ${TOP->object_2svref}, $pkg;
    return $PL_op->next;
}

sub pp_push{
    my $mark = POPMARK;
    my $av   = $PL_stack[++$mark];
    my $n    = push @{$av->object_2svref}, mark_list($mark);
    SETval($n);
    return $PL_op->next;
}