File Coverage

blib/lib/Language/Befunge/lib/FILE.pm

Criterion	Covered	Total	%
statement	15	97	15.4
branch	0	24	0.0
condition	0	2	0.0
subroutine	5	15	33.3
pod	10	10	100.0
total	30	148	20.2

#
# 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::FILE;

use 5.010;
use strict;
use warnings;

use Class::XSAccessor accessors => {
    _iohs => '_iohs',
    _bufs => '_bufs',
};
use IO::File;

sub new { return bless { _iohs=>{}, _bufs=>{} }, shift; }


#
# C( $fid )
#
# Close filehandle corresponding to $fid
#
sub C {
    my ($self, $interp) = @_;
    my $ip = $interp->get_curip;

    my $fid = $ip->spop;
    my $fh = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    #use Data::Dumper; print Dumper($self);
    #warn ">>>$fid=$fh<<<\n";
    delete $self->_iohs->{$fid};
    delete $self->_bufs->{$fid};

    $fh->close or $ip->dir_reverse;
}

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

    my $file = $ip->spop_gnirts;
    unlink $file or $ip->dir_reverse;
}

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

    my $fid = $ip->spop;
    my $fh  = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    my $line = $fh->getline // '';
    $ip->spush_args( $fid, $line, length($line) );
}

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

    my $fid = $ip->spop;
    my $fh  = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;
    my $pos = $fh->tell;
    $pos == -1
        ? $ip->dir_reverse
        : $ip->spush( $fid, $pos );
}

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

    # pop the values
    my $path = $ip->spop_gnirts;
    my $mode = $ip->spop;
    my $vec  = $ip->spop_vec;

    # try to open the file
    my @modes = ( '<', '>', '>>', '+<', '+>', '+>>' );
    my $fh = IO::File->new;
    $fh->open( $path, $modes[$mode] ) or return $ip->dir_reverse;

    # store handles & whatnots
    my $fid = $fh->fileno;
    $self->_iohs->{$fid} = $fh;
    $self->_bufs->{$fid} = $vec;

    $ip->spush( $fid );
}

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

    my $str = $ip->spop_gnirts;
    my $fid = $ip->spop;
    my $fh  = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    $fh->print($str) or return $ip->dir_reverse;
    $ip->spush($fid);
}

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

    my $c    = $ip->spop;
    my $fid  = $ip->spop;
    my $fh   = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    my $buf;
    $fh->read( $buf, $c );
    $ip->spush( $fid );

    my $storage = $interp->get_storage;
    my $vec     = $self->_bufs->{$fid};
    $storage->store_binary( $buf, $vec );
}

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

    # pop the values
    my $pos  = $ip->spop;
    my $from = $ip->spop;
    my $fid  = $ip->spop;
    my $fh   = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    $fh->seek( $pos, $from );
    $ip->spush( $fid );
}

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

    # pop the values
    my $c    = $ip->spop;
    my $fid  = $ip->spop;
    my $fh   = $self->_iohs->{$fid};
    defined $fh or return $ip->dir_reverse;

    my $storage = $interp->get_storage;
    my $pos     = $self->_bufs->{$fid};
    my $size    = Language::Befunge::Vector->new_zeroes( $pos->get_dims );
    $size->set_component($_,1) for 1 .. $pos->get_dims - 1;
    $size->set_component(0, $c);
    my $buf     = $storage->rectangle($pos, $size);
    $fh->syswrite( $buf );
    $ip->spush( $fid );
}

1;

__END__