File Coverage

blib/lib/Language/Befunge/lib/STRN.pm

Criterion	Covered	Total	%
statement	9	94	9.5
branch	0	18	0.0
condition	0	6	0.0
subroutine	3	17	17.6
pod	14	14	100.0
total	26	149	17.4

#
# This file is part of Language::Befunge.
# Copyright (c) 2001-2009 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 Language::Befunge::lib::STRN;

use 5.010;
use strict;
use warnings;

sub new { return bless {}, shift; }

sub A {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $b = $ip->spop_gnirts;
    my $a = $ip->spop_gnirts;
    $ip->spush_args( $b . $a );
}

sub C {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $a = $ip->spop_gnirts;
    my $b = $ip->spop_gnirts;
    $ip->spush_args( $a cmp $b );
}

sub D {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $a = $ip->spop_gnirts;
    print $a;
}

sub F {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $b = $ip->spop_gnirts;
    my $a = $ip->spop_gnirts;
    my $i = index $b, $a;
    $ip->spush_args( $i==-1 ? '' : substr $b, $i );
}

sub G {
    my ($self, $interp) = @_;
    my $ip      = $interp->get_curip;
    my $storage = $interp->get_storage;

    # pop vector
    my $pos  = $ip->spop_vec + $ip->get_storage;

    # create virtual ip to walk the storage
    my $myip = Language::Befunge::IP->new( $pos->get_dims );
    $myip->set_position($pos);

    # really walk the storage
    my $str;
    my $val = $storage->get_value( $pos );
    my %seen = ( $pos => 1 );
    while ( $val != 0 ) {
        $str .= chr $val;
        # let's move the virtual ip
        $interp->_move_ip_once($myip);
        $pos = $myip->get_position;
        return $ip->dir_reverse if $seen{$pos}++;
        $val = $storage->get_value($pos);
    }
    $ip->spush_args( $str );
}


sub I {
    my ($self, $lbi) = @_;
    my $ip = $lbi->get_curip;
    my $in = $lbi->get_input;
    return $ip->dir_reverse unless defined $in;

    while ( $in ne "\n" ) {
        $ip->spush( ord $in );
        $in = $lbi->get_input;
        return $ip->dir_reverse unless defined $in;
    }
}

sub L {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $n = $ip->spop;
    my $a = $ip->spop_gnirts;
    return $ip->dir_reverse if $n < 0;
    return $ip->spush( $a ) if $n > length $a;
    $ip->spush_args( substr( $a, 0, $n ) );
}

sub M {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $n = $ip->spop;
    my $m = $ip->spop;
    my $a = $ip->spop_gnirts;
    return $ip->dir_reverse if ($m < 0 || $m > length($a) || $n < 0);
    $ip->spush_args( substr($a, $m, $n) );
}

sub N {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $a = $ip->spop_gnirts;
    $ip->spush_args( $a, length $a );
}


sub P {
    my ($self, $interp) = @_;
    my $ip      = $interp->get_curip;
    my $storage = $interp->get_storage;

    # pop arguments
    my $pos = $ip->spop_vec + $ip->get_storage;
    my $str = $ip->spop_gnirts;
    $storage->store_binary( $str . chr(0), $pos);
}

sub R {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $n = $ip->spop;
    my $a = $ip->spop_gnirts;
    return $ip->dir_reverse if $n < 0;
    return $ip->spush( $a ) if $n > length $a;
    $ip->spush_args( substr($a, -$n) );
}

sub S {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $n = $ip->spop;
    $ip->spush( $_ ) for reverse map {ord} split //, $n.chr(0);  # force string.
}

sub V {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;
    my $n = $ip->spop_gnirts;
    $ip->spush( 0+$n );
}


1;

__END__