view release on metacpan or  search on metacpan

misc/old_pugs_perl5_backend/Perl6-Value/t/code.t  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;

use Perl6::Code;
# use Data::Dumper;
use PadWalker;

use Test::More tests => 21;

%Perl6::MultiSub::SUBS = ();
%Perl6::NamedSub::SUBS = ();

sub body (&) { @_ }
sub params {
    [ map { Perl6::Param->new( 'type' => undef, 'name' => $_ ) } @_ ]  
}
sub mksub {
    my ($params, $body) = @_;
    return Sub->new( '$.body' => $body, '$.params' => $params);
}
sub mk_named_sub {
    my ($name, $params, $body) = @_;
    my $sub = Sub->new( '$.name' => $name, '$.body' => $body, '$.params' => $params);
    $Perl6::NamedSub::SUBS{$name} = $sub;
}
sub call_named_sub {
    my ($name, @args) = @_;
    (exists $Perl6::NamedSub::SUBS{$name})
        || die "No sub found called '$name'";
    my $sub = $Perl6::NamedSub::SUBS{$name};
    $sub->do(@args);
    # $sub->return_value;
}
sub mk_multi_sub {
    my ($name, @subs) = @_;
    my $sub = MultiSub->new( '$.name' => $name, '@.subs' => \@subs);
    $Perl6::MultiSub::SUBS{$name} = $sub;
}
sub call_multi_sub {
    my ($name, @args) = @_;
    (exists $Perl6::MultiSub::SUBS{$name})
        || die "No sub found called '$name'";
    my $sub = $Perl6::MultiSub::SUBS{$name};
    $sub->do(@args);
    # $sub->return_value;
}

# see t/80_Code.t
#    sub bind_params { ...

{
    # un-named Sub

    my $sub = mksub params('$name'), body {
            my $sub = shift;
            my %param = $sub->bind_params( @_ );  
            "Hello from $param{'$name'}";        
    };
    isa_ok($sub, 'Sub', 'un-named Sub');
    isa_ok($sub, 'Code', '... Code');
    is( $sub->perl->unboxed, 'sub (Any $name) {...}', '... $sub.perl' );
    is( $sub->arity, 1, '... $sub.arity' );
    is( $sub->name, undef, '... $sub.name' );

    # $sub->do('Stevan');
    is( $sub->do('Stevan'), 'Hello from Stevan', '... got the right return value');