view release on metacpan or  search on metacpan

perl5/Pugs-Compiler-Perl6/lib/Pugs/Runtime/Perl6.pm  view on Meta::CPAN

package Pugs::Runtime::Perl6;

use strict;
use warnings;

use Data::Dumper;
use Data::Bind;
#use Lexical::Alias;
use Sub::Multi;
use PadWalker;
use IO::File ();
use Pugs::Compiler::Regex ();
use List::Util; # 'reduce'

$::_V6_BACKEND = 'BACKEND_PERL5';

# TODO - see Pugs::Runtime::Grammar for metaclass stuff

use constant Inf => 100**100**100;
use constant NaN => Inf - Inf;
    
    sub pad_depth {
        local $@;
        my $idx = 0;
        $idx++ while eval { PadWalker::peek_my($idx) };
        $idx;
    }
    
    sub eval_preprocess {
        my ($string, $lang);
        Data::Bind->arg_bind(\@_);
        $lang ||= 'perl6';
        my $eval_string;
        Data::Bind::bind_op2(\$eval_string, \$string);
        # print "LANG: $lang\n";
        if ($lang eq 'yaml') {
            # print "YAML: $eval_string\n";
            my $code = 
            'do{
                require YAML::Syck;
                # interoperability with other YAML/Syck bindings:
                $YAML::Syck::ImplicitTyping = 1;
                YAML::Syck::Load(\'' . $string . '\' );
            }';
            Data::Bind::bind_op2(\$eval_string, \$code);
            # print "YAML: $eval_string\n";
        }
        elsif ($lang eq 'perl6') {
            require Pugs::Compiler::Perl6;
            my $p6 = Pugs::Compiler::Perl6->compile( $string );
            Data::Bind::bind_op2(\$eval_string, \$p6->{perl5});
        }
        elsif ($lang ne 'perl5') {
            die;
        }
        return $eval_string;
    }
    
    Data::Bind->sub_signature(\&eval_preprocess, { var => '$string' }, { var => '$lang', optional => 1});
    
    sub setup_class {
        my ($class) = caller;
        no strict 'refs';
        my @foo = split /::/, $class;
        my $last = pop @foo;
        no strict 'refs';
        no warnings 'redefine';  # Moose already does this?
        *{'::'.$class} = sub { $class->meta->name };
    }

package Pugs::Runtime::Perl6::IO;
    use base 'IO::Handle';
    
    unless ( defined $::_V6_STDIN ) {
        $::_V6_STDIN = new Pugs::Runtime::Perl6::IO;
        unless ($::_V6_STDIN->fdopen(fileno(STDIN),"r")) {
            warn "Can't open \$*IN";
        }
    }
    
    sub slurp {
        my $self = $_[0];
        my $content;
        local $/; 
        $content = <$self>;