File Coverage

blib/lib/Inline/Befunge.pm

Criterion	Covered	Total	%
statement	24	56	42.8
branch	0	6	0.0
condition	1	2	50.0
subroutine	7	11	63.6
pod	5	5	100.0
total	37	80	46.2

#
# This file is part of Inline::Befunge.
# Copyright (c) 2001-2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#

package Inline::Befunge;

use strict;
use warnings;

use Carp;
use Language::Befunge;
require Inline; # use Inline forbidden.
our @ISA = qw! Inline !; # not "use base" (use will take precedence over require)
our $VERSION   = '1.1.1';


sub register {
    return
      { language => 'Befunge',
        aliases  => [ 'befunge', 'BEFUNGE', 'bef', 'BEF' ],
        type     => 'interpreted',
        suffix   => 'bef',
      };
}

sub validate {
    my $self = shift;

    # Initializes funcs.
    $self->{ILSM}{DEBUG} = 0;

    while(@_ >= 2) {
        my ($key, $value) = (shift, shift);
        $key eq "DEBUG" and $self->{ILSM}{DEBUG} = $value, next;
        croak "Unsupported option found: '$key'.";
    }
}


sub build {
    my $self = shift;
    # The magic incantations to register.
    my $path = $self->{API}{install_lib}."/auto/".$self->{API}{modpname};
    $self->mkpath($path) unless -d $path;
    my $file = $self->{API}{location};
    open FOO_OBJ, "> $file" or croak "Can't open $file for output\n$!";
    print FOO_OBJ $self->{API}{code};
    close FOO_OBJ;
}


sub load {
    # Fetch object and package.
    my $self = shift;
    my $pkg  = $self->{API}{pkg} || 'main';

    # Fetch code and create the interpreter.
    my $code = $self->{API}{code};
    my $bef  = $self->{ILSM}{bef} = Language::Befunge->new;
    $bef->store_code( $code );
    $bef->set_DEBUG( $self->{ILSM}{DEBUG} );

    # Parse the code.
    # Each subroutine should be:
    # ;:subname1; < @ ,,,,"foo"a
    # ;:subname2;
    # etc.
    my $funcs = $bef->get_torus->labels_lookup;
    $self->{ILSM}{funcs} = join " ", sort keys %$funcs;

    foreach my $subname ( keys %$funcs ) {
        no strict 'refs';
        *{"${pkg}::$subname"} =
          sub {
              # Cosmetics.
              $bef->debug( "\n-= SUBROUTINE $subname =-\n" );
              $bef->set_file( "Inline-$subname" );

              # Create the first Instruction Pointer.
              my $ip = Language::Befunge::IP->new ;

              # Move the IP at the beginning of the function.
              my $pos = Language::Befunge::Vector->new( 2,
                  $funcs->{$subname}[0],
                  $funcs->{$subname}[1],
              );
              $ip->set_position($pos);
              my $delta = Language::Befunge::Vector->new( 2,
                  $funcs->{$subname}[2],
                  $funcs->{$subname}[3],
              );
              $ip->set_delta($delta);

              # Fill the stack with arguments.
              $ip->spush_args( @_ );

              # Initialize the interpreter.
              $bef->set_ips( [ $ip ] );
              #$bef->set_kcounter(-1);
              $bef->set_retval(0);

              # Loop as long as there are IPs.
              $bef->next_tick while scalar @{ $bef->get_ips };

              # Return the exit code and the TOSS.
#               return $bef->lastip->end eq '@' ?
#                   @{ $bef->lastip->toss }  # return the TOSS.
#                 : $bef->retval;            # return exit code.
              return $bef->get_retval;  # quick'n'dirty bugfix
          };

    }
}


sub info {
    my $self = shift;
    my $text = <<'END';
The following functions have been defined via Inline::Befunge:
$self->{ILSM}{funcs}
END
    return $text;
}


1;
__END__