view release on metacpan or  search on metacpan

lib/Java/Javap/Generator/Perl6.pm  view on Meta::CPAN

# XXX This generator has way too much data processing in it
# It should be focussed on producing output from precomputed data.

# XXX having this info here is suboptimal
# should at least be integrated with TypeCaster
# http://perlcabal.org/syn/S02.html#Undefined_types
my @perl_builtin_undefined = qw(
    Mu
    Failure
    Any
    Cool
);
# http://perlcabal.org/syn/S02.html#Immutable_types
my @perl_builtin_immutable = qw(
    Str
    !Bit
    Int
    Num
    Rat
    !FatRat
    Complex
    Bool

    Exception
    Block
    Seq
    Range

    Set
    !Bag
    Enum
    EnumMap
    Signature
    Parcel
    !Slicel
    Capture
    !Blob
    !Instant
    !Duration
    !HardRoutine
);
# http://perlcabal.org/syn/S02.html#Mutable_types
my @perl_builtin_mutable = qw(
    Iterator
    !SeqIter
    RangeIter
    !Scalar
    Array
    Hash
    !KeySet
    !KeyBag
    !KeyHash
    Pair
    !PairSeq
    Buf
    IO
    Routine
    Sub
    Method
    Submethod
    !Macro
    Regex
    Match
    !Stash
    !SoftRoutine

    DateTime
);
my @perl_builtin_roles = qw(
    Iterable
);
my $perl_builtin_types = { map { (/^!/) ? () : ($_=>1) } (
        @perl_builtin_undefined,
        @perl_builtin_immutable,
        @perl_builtin_mutable,
        @perl_builtin_roles,
    ) };

if (0) { # check that types actually are built-in to current perl6
    for my $t (keys %$perl_builtin_types) {
        system("perl6 -e 'my $t \$v'");
    }
}

sub perl6_string_literal_filter {
    my $value = shift;
    $value =~ s/([^[:print:]])/ sprintf "\\u%04x", ord($1) /eg;
    return qq{"$value"};
}


sub new {
    my $class = shift;

    my $self = bless { @_ }, $class;

    my $filters = Template::Filters->new({
        FILTERS => {
            perl6_string_literal => \&perl6_string_literal_filter,
        },
    });
    
    my $tt_args = {
        POST_CHOMP => 1,
        LOAD_FILTERS => [ $filters ],
    };
    $self->tt_args_set( $tt_args );

    return $self;
}

sub tt_args_set {
    my $self = shift;
    my $args = shift;

    $self->{__TT_ARGS__} = $args;
}

sub tt_args {
    my $self = shift;
    return $self->{__TT_ARGS__};