use Inline Parrot;

print "Start Perl\n";
_hello( 'int count' => 5, name => 'test' );
print "End Perl\n";

__END__
__Parrot__

.sub _hello   
    .param int count
    .param string name
    print "Hello world\n"
    print count
    print " "
    print name
    print "\n" 
    ret 
.end
[download]

Start Perl
Hello world
5 test
End Perl

package Inline::Parrot;
$VERSION = '0.01';
require Inline;
@ISA = qw(Inline);
use strict;
use Carp;
use File::Spec;

sub register {
    return {
        language => 'Parrot',
        aliases => ['parrot', 'pasm', 'pir'],
        type => 'interpreted',
        suffix => 'pir',
       };
}

sub usage_config { 
    my $key = shift;
    "'$key' is not a valid config option for Inline::Parrot\n";
}

sub usage_config_bar { 
    "Invalid value for Inline::Parrot config option BAR";
}

sub validate {
    my $o = shift;
    $o->{ILSM}{PATTERN} ||= 'parrot-';
    $o->{ILSM}{BAR} ||= 0;
    while (@_) {
    my ($key, $value) = splice @_, 0, 2;
    if ($key eq 'PATTERN') {
        $o->{ILSM}{PATTERN} = $value;
        next;
    }
    if ($key eq 'BAR') {
        croak usage_config_bar
          unless $value =~ /^[01]$/;
        $o->{ILSM}{BAR} = $value;
        next;
    }
    croak usage_config($key);
    }
}

sub build {
    my $o = shift;
    my $code = $o->{API}{code};
    my $pattern = $o->{ILSM}{PATTERN};
    $code =~ s/$pattern//g;
    $code =~ s/bar-//g if $o->{ILSM}{BAR};

    my ( $sub_name ) = $code =~ m/\.sub\s+(\w+)/s; 

    my $path = File::Spec->catdir($o->{API}{install_lib},'auto',$o->{A
+PI}{modpname});
    my $obj = $o->{API}{location};
    $o->mkpath($path) unless -d $path;

    open PARROT_OBJ, "> $obj"
      or croak "Can't open $obj for output\n$!";
    print PARROT_OBJ $code;
    close \*PARROT_OBJ;
}

sub load {
    my $o = shift;
    my $obj = $o->{API}{location};
    open PARROT_OBJ, "< $obj"
      or croak "Can't open $obj for output\n$!";
    my $code = join '', <PARROT_OBJ>;
    close \*PARROT_OBJ;

    #warn "Load $code\n";
    #warn "Package $o->{API}{pkg}\n";

    my ( $sub_name ) = $code =~ m/\.sub\s+(\w+)/s;

    #warn "Sub $sub_name\n";

    my $obj_normalized = $obj;
    $obj_normalized =~ tr/\\/\//;  # Windows OS
    my $cmd = 
        " package $o->{API}{pkg} ;    \n" . 
        " sub $sub_name {             \n" .
        '
            my @param_keys;
            my $skip;
            for ( @_ ) 
            {
                push @param_keys, $_ if $skip = ! $skip;
            }
            my %param = @_;

            my $local_params;
            for ( @param_keys ) 
            {
                my $name = $_;
                $name = "string " . $name
                    unless $name =~ /\s/;
                $local_params .= "    .local $name\n";
            }

            my $value_params;
            for ( @param_keys ) 
            {
                my $name = ( split ( /\s+/, $_ ) )[-1];
                $value_params .= "    $name = \"$param{$_}\"\n";
            }

            my $arg_params;
            for ( reverse @param_keys ) 
            {
                my $name = ( split ( /\s+/, $_ ) )[-1];
                $arg_params .= "    .arg $name \n";
            }

            my $cmd = \'
.pragma fastcall
' . $code . '
.sub _start_' . $sub_name . ' @MAIN
    # print "starting parrot\\n"
    \' . $local_params . \'
    \' . $value_params . \'
    \' . $arg_params . \'
    call ' . $sub_name . '
    # print "ending parrot\\n"
    end
.end
\' ;
' . <<EOT;
            open PARROT_OBJ, ">", "$obj_normalized.pir"
              or die "Can't open $obj_normalized.pir for output\\n$!";
            print PARROT_OBJ \$cmd;
            close \*PARROT_OBJ;

            open( PARROT_RUN, "|-", "parrot $obj_normalized.pir" )
                or die "Can't open $obj_normalized.pir for output\\n$!
+";
            close( PARROT_RUN );
        }
EOT

    #warn "Cmd $cmd [end Cmd]\n";
    #warn "Eval\n" . $cmd . "\n";

    eval $cmd;
    croak "Unable to load Parrot module $obj:\n$@" if $@;
}

sub info {
    my $o = shift;
}

1;

__END__
[download]