• Your recent searches
Acme-Perl-VM
16 results

 view release on metacpan or  search on metacpan

example/methcall.pl  view on Meta::CPAN 

#!perl -w
use strict;
use FindBin qw($Bin);
use lib "$Bin/../lib";

use Acme::Perl::VM;

sub Foo::hello{
    my(undef, $s) = @_;

    print "Hello, $s world!\n";
}

run_block {
    Foo->hello("Acme::Perl::VM");
    Foo->hello("APVM");
};

example/trace.pl  view on Meta::CPAN 

#!perl -w
BEGIN{ $ENV{APVM_DEBUG} = 'trace' }
use strict;
use FindBin qw($Bin);
use lib "$Bin/../lib";

use Acme::Perl::VM::Run;

sub Foo::hello{
    my(undef, $msg) = @_;

    print "Hello, $msg world!\n";
}

for(my $i = 1; $i <= 1; $i++){
    Foo->hello('APVM');
}

example/warn.pl  view on Meta::CPAN 

#!perl -w
use strict;
use FindBin qw($Bin);
use lib "$Bin/../lib";

use Acme::Perl::VM;

sub f{
    print 42 + undef, "\n";
}
sub g{
    f(42);
}

run_block {
    &g;
};

inc/Module/Install.pm  view on Meta::CPAN 

BEGIN {
	# All Module::Install core packages now require synchronised versions.
	# This will be used to ensure we don't accidentally load old or
	# different versions of modules.
	# This is not enforced yet, but will be some time in the next few
	# releases once we can make sure it won't clash with custom
	# Module::Install extensions.
	$VERSION = '0.91';

	# Storage for the pseudo-singleton
	$MAIN    = undef;

	*inc::Module::Install::VERSION = *VERSION;
	@inc::Module::Install::ISA     = __PACKAGE__;

}

inc/Module/Install.pm  view on Meta::CPAN 

}

# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
	(
		defined $_[0]
		and
		! ref $_[0]
		and
		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
	) ? $_[0] : undef;
}

1;

# Copyright 2008 - 2009 Adam Kennedy.

inc/Module/Install/Metadata.pm  view on Meta::CPAN 

    artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
    lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
    lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
    lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
    bsd          => 'http://opensource.org/licenses/bsd-license.php',
    gpl          => 'http://opensource.org/licenses/gpl-license.php',
    gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
    gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
    mit          => 'http://opensource.org/licenses/mit-license.php',
    mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
    open_source  => undef,
    unrestricted => undef,
    restrictive  => undef,
    unknown      => undef,
);

sub license {
	my $self = shift;
	return $self->{values}->{license} unless @_;
	my $license = shift or die(
		'Did not provide a value to license()'
	);
	$self->{values}->{license} = $license;

inc/Module/Install/Metadata.pm  view on Meta::CPAN 

	Module::Install::_write(
		'MYMETA.json',
		JSON->new->pretty(1)->canonical->encode($meta),
	);
}

sub _write_mymeta_data {
	my $self = shift;

	# If there's no existing META.yml there is nothing we can do
	return undef unless -f 'META.yml';

	# We need Parse::CPAN::Meta to load the file
	unless ( eval { require Parse::CPAN::Meta; 1; } ) {
		return undef;
	}

	# Merge the perl version into the dependencies
	my $val  = $self->Meta->{values};
	my $perl = delete $val->{perl_version};
	if ( $perl ) {
		$val->{requires} ||= [];
		my $requires = $val->{requires};

		# Canonize to three-dot version after Perl 5.6

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

    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;

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

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

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

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

    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) = @_;

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

        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

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

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

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

sub BUILD{
    my($cx) = @_;

    $cx->label($PL_curcop->label);
    $cx->myop($PL_op);
    $cx->nextop($PL_op->nextop);

    return;
}

sub ITERVAR(){ undef }

no Mouse;
__PACKAGE__->meta->make_immutable();

package Acme::Perl::VM::Context::FOREACH;
use Mouse;
use Acme::Perl::VM::B qw(USE_ITHREADS);
extends 'Acme::Perl::VM::Context::LOOP';

has padvar => (

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

    if(GIMME_V == G_ARRAY){
        while(++$mark <= $#PL_stack){
            $PL_stack[$mark] = _refto($PL_stack[$mark]);
        }
    }
    else{
        if(++$mark <= $#PL_stack){
            $PL_stack[$mark] = _refto($PL_stack[-1]);
        }
        else{
            $PL_stack[$mark] = _refto(sv_undef);
        }
        $#PL_stack = $mark;
    }
    return $PL_op->next;
}

sub pp_list{
    my $mark = POPMARK;

    if(GIMME_V != G_ARRAY){
        if(++$mark <= $#PL_stack){
            $PL_stack[$mark] = $PL_stack[-1];
        }
        else{
            $PL_stack[$mark] = sv_undef;
        }
        $#PL_stack = $mark;
    }
    return $PL_op->next;
}


sub _method_common{
    my($meth) = @_;

    my $name = SvPV($meth);
    my $sv   = $PL_stack[ TOPMARK() + 1];

    if(!sv_defined($sv)){
        apvm_die q{Can't call method "%s" on an undefined value}, $name;
    }

    my $invocant = ${$sv->object_2svref};

    my $code = do{
        local $@;
        eval{ $invocant->can($name) };
    };

    if(!$code){

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

    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;

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

        not_implemented 'return for ' . $cx->type
    }

    my $newsp = $cx->oldsp;
    my $gimme = $cx->gimme;
    if($gimme == G_SCALAR){
        if($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy(TOP);
        }
        else{
            $PL_stack[++$newsp] = sv_undef;
        }
    }
    elsif($gimme == G_ARRAY){
        while(++$mark <= $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[$mark]);
        }
    }
    $#PL_stack = $newsp;

    LEAVE;

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


    if($gimme == G_VOID){
        $#PL_stack = $newsp;
    }
    elsif($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;
    }
    else{ # G_ARRAY
        for(my $mark = $newsp + 1; $mark <= $#PL_stack; $mark++){
            $PL_stack[$mark] = sv_mortalcopy($PL_stack[$mark]);
        }
    }

    LEAVE;

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


    my $mark  = $cx->oldsp;
    my $gimme = $cx->gimme;
    my $newsp = $cx->resetsp;

    if($gimme == G_SCALAR){
        if($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[-1]);
        }
        else{
            $PL_stack[++$newsp] = sv_undef;
        }
    }
    elsif($gimme == G_ARRAY){
        while($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[++$mark]);
        }
    }

    $#PL_stack = $newsp;

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

    $#PL_stack = $PL_cxstack[-1]->oldsp;

    FREETMPS;
    LEAVE_SCOPE($PL_scopestack[-1]);

    return $PL_op->next;
}

sub pp_stub{
    if(GIMME_V == G_SCALAR){
        PUSH(sv_undef);
    }
    return $PL_op->next;
}


sub _dopoptoloop{
    my $cxix;
    if($PL_op->flags & OPf_SPECIAL){
        $cxix = dopoptoloop($#PL_cxstack);
        if($cxix < 0){

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

    else{
        not_implemented "last($type)";
    }

    my $gimme = $cx->gimme;
    if($gimme == G_SCALAR){
        if($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[-1]);
        }
        else{
            $PL_stack[++$newsp] = sv_undef;
        }
    }
    elsif($gimme == G_SCALAR){
        while($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[-1]);
        }
    }
    $#PL_stack = $newsp;
    LEAVE;

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

        }
        elsif($sv->class eq 'HV'){
            $hv = $sv;
            $hash_ref = $sv->object_2svref;
            %{$hash_ref} = ();

            while($r_elem < $last_r_elem){
                my $key = $PL_stack[$r_elem++];
                my $val = $PL_stack[$r_elem++];

                $sv->store_ent($key, $val || sv_undef);
            }

            if($r_elem == $last_r_elem){
                apvm_warn 'Odd number of elements in hash assignment';
                $r_elem++;
            }
        }
        else{
            if($$sv == ${sv_undef()}){ # (undef) = (...)
                if($r_elem <= $last_r_elem){
                    $r_elem++;
                }
            }
            elsif($r_elem <= $last_r_elem){
                $sv->setsv($PL_stack[$r_elem]);
                $PL_stack[$r_elem++] = $sv;
            }
        }
    }

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

    if($gimme == G_VOID){
        $#PL_stack = $first_r_elem - 1;
    }
    elsif($gimme == G_SCALAR){
        $#PL_stack = $first_r_elem;
        SETval($last_r_elem - $first_r_elem + 1);
    }
    else{
        $l_elem = $first_l_elem + ($r_elem + $first_r_elem);
        while($r_elem <= $#PL_stack){
            $PL_stack[$r_elem++] = ($l_elem <= $last_l_elem) ? $PL_stack[$l_elem++] : sv_undef;
        }

        if($ary_ref){
            $#PL_stack = $last_r_elem;
        }
        elsif($hash_ref){
            $#PL_stack = $first_r_elem;
            SET($hv);

            return &_do_kv;

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

sub pp_keys{
    return &_do_kv;
}
sub pp_values{
    return &_do_kv;
}

sub pp_wantarray{
    my $cxix = dopoptosub($#PL_cxstack);
    if($cxix < 0){
        PUSH(sv_undef);
    }
    else{
        my $gimme = $PL_cxstack[$cxix]->gimme;
        if($gimme == G_ARRAY){
            PUSH(sv_yes);
        }
        elsif($gimme == G_SCALAR){
            PUSH(sv_no);
        }
        else{
            PUSH(sv_undef);
        }
    }
    return $PL_op->next;
}

sub pp_undef{
    if(!$PL_op->private){
        PUSH(sv_undef);
        return $PL_op->next;
    }

    not_implemented 'undef(expr)';
}

sub pp_scalar{
    return $PL_op->next;
}

sub pp_not{
    SET( !SvTRUE(TOP) ? sv_yes : sv_no );
    return $PL_op->next;
}

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

=item pp_concat

=item pp_print

=item pp_aelemfast

=item pp_aelem

=item pp_helem

=item pp_undef

=item pp_scalar

=item pp_not

=item pp_anonhash

=item pp_anonlist

=item pp_defined

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

}

sub type{
    my($self) = @_;
    my $class = ref $self;
    $class =~ s/^Acme::Perl::VM::Scope:://;
    return $class;
}

sub _save{
    my(undef, $file, $line) = caller(2);
    $file =~ s{\A .* Acme/Perl .* /}{}xmsi;
    my $proc = $PL_op ? ('in '.$PL_op->name.' ') : '';
    return sprintf q{saved %s}.q{at %s line %d}, $proc, $file, $line;
}

no Mouse;
__PACKAGE__->meta->make_immutable();

package Acme::Perl::VM::Scope::Value;
use Mouse;

t/03_assign.t  view on Meta::CPAN 

#!perl -w

use strict;
use Test::More tests => 16;

use Acme::Perl::VM;
use Acme::Perl::VM qw(:perl_h);

is scalar(run_block{ my $x }),         undef, 'padsv (intro)';
is scalar(run_block{ my $x = 10 }),       10, 'sassign';

my $y = 20;
is scalar(run_block{ my $x = $y }), 20, 'sassign';

is_deeply [run_block{ my($x) = (10) }],         [10],        'aassign';
is_deeply [run_block{ my($x, $y) = (10, 20) }], [10, 20],    'aassign';
is_deeply [run_block{ my($x, $y) = (10) }],     [10, undef], 'aassign';

is_deeply [scalar run_block{ my $x = 50;        $x }], [50];
is_deeply [scalar run_block{ my $x = 60; return $x }], [60];

is_deeply [run_block{ my $x = 50;        $x }], [50];
is_deeply [run_block{ my $x = 60; return $x }], [60];

is_deeply \@PL_stack,      [], '@PL_stack is empty';
is_deeply \@PL_markstack,  [], '@PL_markstack is empty';
is_deeply \@PL_scopestack, [], '@PL_scopestack is empty';

t/05_methcall.t  view on Meta::CPAN 

#!perl -w

use strict;
use Test::More tests => 18;

use Acme::Perl::VM;
use Acme::Perl::VM qw(:perl_h);

sub Foo::f{ 42 }
sub Foo::g{
    my(undef, $value) = @_;
    $value++;
    return $value;
}
sub Foo::h{
    @_
}

my $x;

$x = run_block{

t/08_array.t  view on Meta::CPAN 

    return $gary[$i];
};
is $x,       'barx';
is $gary[1], 'barx';

@ary = run_block{
    my @a = ();
    $a[1] = 10;
    return @a;
};
is_deeply \@ary, [undef, 10];

sub f{
    my @a;
    $a[0]++;
    return $a[0];
}

is run_block(\&f), 1;
is run_block(\&f), 1;

t/09_hash.t  view on Meta::CPAN 

    our %h = (foo => 10, bar => 20);
    return \$h{foo};
};
is_deeply $x, \10;

sub f{
    my %h;
    return \$h{foo};
}
$x = run_block(\&f);
is_deeply $x, \undef;
$$x++;
is_deeply run_block(\&f), \undef;

my %h = (foo => 10, bar => 20);
is_deeply [ run_block{        keys   %h } ], [        keys   %h ], 'keys';
is_deeply [ run_block{        values %h } ], [        values %h ], 'values';
is_deeply [ run_block{ scalar keys   %h } ], [ scalar keys   %h ];
is_deeply [ run_block{ scalar values %h } ], [ scalar values %h ];
is_deeply \%h, {foo => 10, bar => 20};

is_deeply \@PL_stack,      [], '@PL_stack is empty';
is_deeply \@PL_markstack,  [], '@PL_markstack is empty';

t/14_assign2.t  view on Meta::CPAN 

#!perl -w

use strict;
use Test::More tests => 10;

use Acme::Perl::VM;
use Acme::Perl::VM qw(:perl_h);

is_deeply [run_block{ my(@a, $b) = (1, 2, 3); (\@a, $b) }], [[1, 2, 3], undef];
is_deeply [run_block{ my($a, @b) = (1, 2, 3); ($a, \@b) }], [1, [2, 3]];

is_deeply [run_block{ my($a, $b) = (10, 20); ($b, $a) = ($a, $b); ($a, $b) }], [20, 10];

is_deeply [run_block{ my(%a, $b) = (foo => 42); (\%a, $b) }], [{foo => 42}, undef];

is_deeply \@PL_stack,      [], '@PL_stack is empty';
is_deeply \@PL_markstack,  [], '@PL_markstack is empty';
is_deeply \@PL_scopestack, [], '@PL_scopestack is empty';
is_deeply \@PL_cxstack,    [], '@PL_cxstack is empty';
is_deeply \@PL_savestack,  [], '@PL_savestack is empty';
is_deeply \@PL_tmps,       [], '@PL_tmps is empty';

t/16_wantarray.t  view on Meta::CPAN 


use Acme::Perl::VM;
use Acme::Perl::VM qw(:perl_h);

my $x;
sub f{
    $x = wantarray;
}

run_block \&f;
is $x, undef;

scalar(run_block \&f);
is $x, "";

() = run_block \&f;
is $x, 1;


run_block { &f };
is $x, undef;

scalar(run_block { &f });
is $x, "";

() = run_block { &f };
is $x, 1;


run_block { do{ &f } };
is $x, undef;

scalar(run_block { do{ &f } });
is $x, "";

() = run_block { do{ &f } };
is $x, 1;

run_block { { &f } };
is $x, undef;

scalar(run_block { { &f } });
is $x, "";

() = run_block { { &f } };
is $x, 1;

is_deeply \@PL_stack,      [], '@PL_stack is empty';
is_deeply \@PL_markstack,  [], '@PL_markstack is empty';
is_deeply \@PL_scopestack, [], '@PL_scopestack is empty';



( run in 2.562 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )