File Coverage

blib/lib/Inline/Guile.pm

Criterion	Covered	Total	%
statement	40	59	67.8
branch	1	14	7.1
condition	1	2	50.0
subroutine	12	16	75.0
pod	1	5	20.0
total	55	96	57.2

package Inline::Guile;

use strict;
use warnings;

require Inline;
our @ISA = qw(Inline);

our $VERSION = '0.001';

use Guile;
use Carp qw(croak confess);

# register for Inline
sub register {
  return {
          language => 'Guile',
          aliases  => ['GUILE'],
          type     => 'interpreted',
          suffix   => 'go',
         };
}

# check options
sub validate {
  my $self = shift;

  while(@_ >= 2) {
    my ($key, $value) = (shift, shift);
    croak("Unsupported option found: \"$key\".");
  }
}

# required method - doesn't do anything useful
sub build {
  my $self = shift;

  # magic dance steps to a successful Inline compile...
  my $path = "$self->{API}{install_lib}/auto/$self->{API}{modpname}";
  my $obj = $self->{API}{location};
  $self->mkpath($path) unless -d $path;
  $self->mkpath($self->{API}{build_dir}) unless -d $self->{API}{build_dir};

  # touch my monkey
  open(OBJECT, ">$obj") or die "Unable to open object file: $obj : $!";
  close(OBJECT)         or die "Unable to close object file: $obj : $!";
}

# load the code into the interpreter
sub load {
  my $self = shift;
  my $code = $self->{API}{code};
  my $pkg = $self->{API}{pkg} || 'main';

  # append testing mark
  $code .= "\n1\n";

  # try evaluating the code
  my $result;
  eval { $result = Guile::eval_str($code);  };
  croak("Inline::Guile : Problem evaluating Guile code:\n$code\n\nReason: $@")
    if $@;
  croak("Inline::Guile : Problem evaluating Guile code:\n$code\n")
    unless $result == 1;

  # look for possible global defines
  while($code =~ /define\s+(\S+)/g
        # + cperl-mode, I hate you.
       ){
    my $name = $1;

    # try to lookup a procedure object
    my $proc = Guile::lookup($name);

    if (Guile::procedure_p($proc)) {
      # got a live one, register it
      no strict 'refs';
      *{"${pkg}::$name"} = sub { Guile::apply($proc, [@_]); }
    }
  }

}

# no info implementation yet
sub info { }


1;
__END__