File Coverage

blib/lib/Acme/Ook.pm

Criterion	Covered	Total	%
statement	45	53	84.9
branch	7	14	50.0
condition	6	11	54.5
subroutine	10	12	83.3
pod	4	4	100.0
total	72	94	76.6

package Acme::Ook;

use strict;
use vars qw($VERSION);
$VERSION = '0.11';

my %Ook = (
	   '.' => {'?'	=> '$Ook++;',
		   '.'	=> '$Ook[$Ook]++;',
		   '!'	=> '$Ook[$Ook]=read(STDIN,$Ook[$Ook],1)?ord$Ook[$Ook]:0;'},
	   '?' => {'.'	=> '$Ook--;',
		   '!'	=> '}'},
	   '!' => {'!'	=> '$Ook[$Ook]--;',
		   '.'	=> 'print chr$Ook[$Ook];',
		   '?'	=> 'while($Ook[$Ook]){',
		   }
	    );

BEGIN {
    no strict 'refs';
    *{'O?'} = sub { @_ ? $Ook{$_[0]} : %Ook };
    *{'O!'} = sub { $Ook{$_[0]} = $_[1] };
}

sub optimise {
    # Coalesce sequences of increments or decrements
    my $prog = $_[1];
    # print "Before '$prog'\n";
    foreach my $thing ('$Ook', '$Ook[$Ook]') {
	foreach my $op ('+', '-') {
	    my $left = length "$thing$op$op;";
	    $prog =~ s{((?:\Q$thing$op$op\E;){2,})}
	      {"$thing$op=".(length ($1)/$left).';'}ges;
	}
    }
    # print "After '$prog'\n";
    return $prog;
}

sub _compile {
    shift;
    chomp $_[0];
    $_[0] =~ s/\s*(Ook(.)\s*Ook(.)\s*|(\#.*)|\S.*)/$;=$Ook{$2||@@}{$3||''};$;?$;:defined$4?"$4\n":die"OOK? $_[1]:$_[2] '$1'\n"/eg;
    return $_[0];
}

sub compile {
    my $self = shift;
    my $prog;
    $prog .= $self->_compile($$self, "(new)", 0) if defined $$self && length $$self;
    if (@_) {
	local *OOK;
	while (@_) {
	    my $code = shift;
	    if (ref $code eq 'IO::Handle') {
		while (<$code>) {
		    $prog .= $self->_compile($_, $code, $.);
		}
		close(OOK);
	    } else {
		if (open(OOK, $code)) {
		    while () {
			$prog .= $self->_compile($_, $code, $.);
		    }
		    close(OOK);
		} else {
		    die "OOK! $code: $!\n";
		}
	    }
	}
    } else {
	while () {
	    $prog .= $self->_compile($_, "(stdin)", $.);
	}
    }
    return '{my($Ook,@Ook);local$^W = 0;BEGIN{eval{require bytes;bytes::import()}}' . $prog . '}';
}

sub Ook {
    eval $_[0]->optimise(&compile);
}

sub new {
    my $class = shift;
    bless \$_[0], ref $class || $class;
}

1;
__END__