Acme-AsciiArtinator
view release on metacpan or search on metacpan
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
package Acme::AsciiArtinator;
use Carp;
use base 'Exporter';
use strict;
use warnings;
our $VERSION = '0.04';
our @EXPORT = qw(asciiartinate);
$| = 1;
my $DEBUG = 0;
#############################################################################
#
# run ASCII Artinization on a picture and a code string.
#
sub asciiartinate {
my %opts = @_;
if (@_ == 1 && ref $_[0] eq "HASH") {
%opts = @{$_[0]};
}
my ($PIC, $CODE, $OUTPUT);
if (defined $opts{"debug"} && $opts{"debug"}) {
$DEBUG = 1;
}
if (defined $opts{"art_file"}) {
my $fh;
local $/ = undef;
open($fh, "<", $opts{"art_file"}) || croak "Invalid art_file specification: $!\n";
$PIC = <$fh>;
close $fh;
} elsif (defined $opts{"art_string"}) {
$PIC = $opts{"art_string"};
} elsif (defined $opts{"art"}) {
$PIC = $opts{"art"};
} else {
croak "Invalid spec. Must specify art, art_file, or art_string \n";
}
$Acme::AsciiArtinator::PIC = $PIC;
if (defined $opts{"code_file"}) {
my $fh;
local $/ = undef;
open($fh, "<", $opts{"code_file"}) || croak "Invalid code_file specification: $!\n";
$CODE = <$fh>;
close $fh;
} elsif ($opts{"code_string"}) {
$CODE = $opts{"code_string"};
} elsif ($opts{"code"}) {
$CODE = $opts{"code"};
} else {
croak "Invalid spec. Must specify code, code_file, or code_string \n";
}
if (defined $opts{"output"}) {
$OUTPUT = $opts{"output"};
} else {
print STDERR "Output will go to \"ascii-art.pl\"\n" if $DEBUG;
$OUTPUT = "ascii-art.pl";
}
if (defined $opts{"compile-check"}) {
my $fh;
open($fh, ">", "ascii-art.$$.pl");
print $fh $CODE;
close $fh;
my $c1 = &compile_check("ascii-art.$$.pl");
unlink "ascii-art.$$.pl";
if ($c1 > 0) {
croak "Initial code in ",$opts{"code"},$opts{"code_string"},
$opts{"code_file"}," does not compile!\n";
}
}
my $ntest = 1;
while (defined $opts{"test_argv$ntest"} || defined $opts{"test_input$ntest"}) {
my (@test_argv, @test_stdin) = ();
@test_argv = @{$opts{"test_argv$ntest"}} if defined $opts{"test_argv$ntest"};
@test_stdin = @{$opts{"test_input$ntest"}} if defined $opts{"test_input$ntest"};
my $fh;
if (open($fh, ">", "ascii-art-test-$ntest-$$.pl")) {
print $fh $CODE;
close $fh;
my $output = "";
if (defined $opts{"test_input$ntest"}) {
open($fh, ">", "ascii-art-test-$ntest-$$.stdin");
print $fh @test_stdin;
close $fh;
print qq{Running test: $^X ascii-art-test-$ntest-$$.pl @test_argv < ascii-art-test-$ntest-$$.stdin\n} if $DEBUG;
$output = qx{$^X ascii-art-test-$ntest-$$.pl @test_argv < ascii-art-test-$ntest-$$.stdin};
unlink "ascii-art-test-$ntest-$$.stdin";
} else {
print qq{Running test: $^X ascii-art-test-$ntest-$$.pl @test_argv\n};
$output = qx{$^X ascii-art-test-$ntest-$$.pl @test_argv};
}
print "Ran pre-test # $ntest with argv: \"@test_argv\", stdin: \"@test_stdin\"\n";
$Acme::AsciiArtinator::TestOutput[$ntest] = $output;
unlink "ascii-art-test-$ntest-$$.pl";
} else {
carp "Could not write code to disk in order to run pre-test.\n";
}
} continue {
$ntest++;
}
###############################################
my $max_tries = $opts{"retry"} || 100;
my @tokens = &asciiindex_code($CODE);
my @contexts = @asciiartinate::contexts;
my @blocks = &asciiindex_art($PIC);
my $ipad;
for ($ipad = 0; $ipad < $max_tries; $ipad++) {
print "\n\n\n\nPad try # $ipad\n\n\n\n";
my ($newt,$newc) = &pad(\@tokens, \@contexts, \@blocks);
if (defined $newc) {
for (my $i=0; $i<@$newt; $i++) {
print $newt->[$i], "\t", $newc->[$i], "\n";
}
@tokens = @$newt;
if ($opts{"filler"} != 0) {
&tweak_padding($opts{"filler"}, \@tokens, \@contexts);
}
print_code_to_pic($PIC, @tokens);
my $fh;
open($fh, ">", $OUTPUT);
select $fh;
print_code_to_pic($PIC, @tokens);
select STDOUT;
close $fh;
my $c1 = &compile_check($OUTPUT);
if ($c1 > 0) {
croak "Artinated code does not compile! Darn.\n";
exit $c1 >> 8;
}
##################################################
#
# artination complete
#
##################################################
open($fh,"<", $OUTPUT);
my @output = <$fh>;
close $fh;
# test output
#
# make sure artinated code produces same outputs
# as the original code on the test cases.
#
$ntest = 1;
if (defined $opts{"test_argv1"}) {
print "Running post-tests on artinated code\n";
}
while (defined $opts{"test_argv$ntest"} || defined $opts{"test_input$ntest"}) {
my (@test_argv, @test_stdin) = ();
print "Testing output # $ntest:\n";
@test_argv = @{$opts{"test_argv$ntest"}} if defined $opts{"test_argv$ntest"};
@test_stdin = @{$opts{"test_input$ntest"}} if defined $opts{"test_input$ntest"};
my $fh;
next if !defined $Acme::AsciiArtinator::TestOutput[$ntest];
my $output = "";
if (defined $opts{"test_input$ntest"}) {
open($fh, ">", "ascii-art-test-$ntest-$$.stdin");
print $fh @test_stdin;
close $fh;
$output = qx{$^X "$OUTPUT" @test_argv < ascii-art-test-$ntest-$$.stdin};
unlink "ascii-art-test-$ntest-$$.stdin";
} else {
$output = qx{$^X "$OUTPUT" @test_argv};
}
print "Ran post-test # $ntest with argv: \"@test_argv\", stdin: \"@test_stdin\"\n";
if ($output eq $Acme::AsciiArtinator::TestOutput[$ntest]) {
print "Post-test # $ntest: PASS\n";
$Acme::AsciiArtinator::TestResult[$ntest] = "PASS";
} else {
print "Post-test # $ntest: FAIL\n";
$Acme::AsciiArtinator::TestResult[$ntest] = "FAIL";
print STDERR "-- " x 13, "\n";
print STDERR "Original results for test # $ntest:\n";
print STDERR "-- " x 7, "\n";
print STDERR $Acme::AsciiArtinator::TestOutput[$ntest];
print STDERR "\n", "-- " x 13, "\n";
print STDERR "Final results for test # $ntest:\n";
print STDERR $output;
print STDERR "\n", "-- " x 13, "\n\n";
}
} continue {
$ntest++;
}
return @output;
}
}
if ($ipad >= $max_tries) {
croak "The ASCII Artinator was unable to embed your code in the picture ",
"after $max_tries tries.\n";
}
}
#
# run a file containing Perl code for a Perl compilation check
#
sub compile_check {
my ($file) = @_;
print "\n";
print "- " x 20, "\n";
print "Compile check for $file:\n";
print "- " x 20, "\n";
print `$^X -cw "$file"`;
print "- " x 20, "\n";
return $?;
}
sub tweak_padding {
my ($filler, $tref, $cref) = @_;
# TODO: if there are many consecutive characters of padding
# in the code, we can improve its appearance by
# inserting some quoted text in void context.
}
#############################################################################
#
# code tokenization -- split code into tokens that should
# not be further divisible by whitespace
#
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
my @token_keywords = qw(&&= ||= <<= >>= <=> ... **= //=
&& || ++ -- == != <= >= -> ** =~ !~
<= >= => .. += -= *= /= %= |= &= ^= << >> .= <> //);
# //= is an operator in perl 5.10, I believe
# // is usually a regular expression, or a perl 5.10 operator
my %sigil = qw($ 1 @ 2 % 3 & 4 & 0);
#
# does the current string begin with an "operator keyword"?
# if so, return it
#
sub find_token_keyword {
my ($q) = @_;
foreach my $k (@token_keywords) {
if (substr($q,0,length($k)) eq $k) {
return $k;
}
}
return;
}
#
# find position of a scalar in an array.
#
sub STRPOS {
my ($word, @array) = @_;
my $pos = -1;
for (my $i=0; $i<@array; $i++) {
$pos = $i if $array[$i] =~ /$word/;
}
return $pos;
}
#
# what does the "/" token that we just encountered mean?
# this is a hard game to play.
# see http://www.perlmonks.org/index.pl?node_id=44722
#
sub regex_or_divide {
my ($tokenref, $contextref) = @_;
my @tokens = @$tokenref;
my @contexts = @$contextref;
# regex is expected following an operator,
# at the beginning of a statement
# divide is expected following a scalar,
# or any token that could complete an expression
my $c = $#contexts;
$c-- while $contexts[$c] eq "whitespace";
return "regex" if $contexts[$c] eq "operator";
return "regex" if $tokens[$c] eq ";" && $tokens[$c-1] ne "SIGIL";
return "divide";
}
sub tokenize_code {
my ($INPUT) = @_;
local $" = '';
my @INPUT = grep { /[^\n]/ } split //, $INPUT;
# tokens are:
# quotes strings
# numeric literals
# regular expression specifications
# except with //x and s///x
# alphanumeric strings
# punctuation strings from @token_keywords
#
my ($i, $j, $Q, @tokens, $token, $sigil, @contexts, @blocks);
$sigil = 0;
for ($i = 0; $i < @INPUT; $i++) {
$_ = $INPUT[$i];
$Q = "@INPUT[$i..$#INPUT]";
print STDERR "\$Q = ", substr($Q,0,8), "... SIGIL=$sigil\n" if $_ eq "q" && $DEBUG;
# $# could be "the output format of printed numbers"
# or it could be the start of an expression like $#X or $#{@$X}
# in the latter case we need $# + one more token to be contiguous
if ($Q =~ /^\$\#\{/ || $Q =~ /^\$\#\w+/) {
$token = $&;
push @tokens, $token;
push @contexts, "\$# operator";
$i = $i - 1 + length $token;
$sigil = 0;
next;
}
if ($sigil{$_} && $Q !~ /^\$\#/) {
$sigil = $sigil{$_};
push @tokens, $_;
push @contexts, "SIGIL";
next;
}
if (!$sigil && ($_ eq "'" || $_ eq '"' ||
$_ eq "/" && regex_or_divide(\@tokens,\@contexts) eq "regex")) {
# walk through @INPUT looking for the end of the string
# manage a boolean $escaped variable handy to allow
# escaped strings inside strings.
my $escaped = 0;
my $terminator = $_;
for($j = $i + 1; $j <= $#INPUT; $j++) {
if ($INPUT[$j] eq "\\") {
$escaped = !$escaped;
next;
}
last if $INPUT[$j] eq $terminator && !$escaped;
$escaped = 0;
}
my $token = "@INPUT[$i..$j]";
if ($_ eq "/" && (length $token > 30 || $j >= $#INPUT)) {
# this regex is pretty long. Maybe we made a mistake.
my $toke2 = find_token_keyword($Q) || "/";
$token = $toke2;
$_ = "/!";
}
push @tokens, $token;
if ($_ eq "/!") {
push @contexts, "misanalyzed regex or operator";
} elsif ($_ eq "/") {
push @contexts, "regular expression C ///";
} else {
push @contexts, "quoted string";
}
$i = $j;
} elsif (!$sigil && $Q =~ /^[0-9]*\.{0,1}[0-9]+([eE][-+]?[0-9]+)?/) {
# if first char starts a numeric literal, include all characters
# from the number in the token
$token = $&;
push @tokens, $token;
push @contexts, "numeric literal A";
$i = $i - 1 + length $token;
} elsif (!$sigil && $Q =~ /^[0-9]+\.{0,1}[0-9]*([eE][-+]?[0-9]+)?/) {
$token = $&;
push @tokens, $token;
push @contexts, "numeric literal B";
$i += length $token;
} elsif (!$sigil && ($Q =~ /^m\W/ || $Q =~ /^qr\W/ || $Q =~ /^q[^\w\s]/ || $Q =~ /^qq\W/)) {
$j = $Q =~ /^q[rq]\W/ ? $i + 3 : $i + 2;
my $terminator = $INPUT[$j - 1];
$terminator =~ tr!{}<>[]{}()!}{><][}{)(!;
my $escaped = 0;
for(; $j <= $#INPUT; $j++) {
if ($INPUT[$j] eq "\\") {
$escaped = !$escaped;
next;
}
last if $INPUT[$j] eq $terminator && !$escaped;
# XXX - if regex has 'x' modifier,
# then
$escaped = 0;
}
push @tokens, "@INPUT[$i..$j]";
push @contexts, "regular expression A /$terminator/";
$i = $j;
} elsif (!$sigil && ($Q =~ /^s\W/ || $Q =~ /^y\W/ || $Q =~ /^tr\W/)) {
$j = $_ eq "t" ? $i + 3 : $i + 2;
my $terminator = $INPUT[$j-1];
$terminator =~ tr!{}<>[]{}()!}{><][}{)(!;
my $escaped = 0;
my $terminators_found = 0;
for (; $j <= $#INPUT; $j++) {
if ($INPUT[$j] eq "\\") {
$escaped = !$escaped;
next;
}
if ($INPUT[$j] eq $terminator && !$escaped) {
if ($terminators_found++) {
last;
}
}
$escaped = 0;
}
push @tokens, "@INPUT[$i..$j]";
push @contexts, "regular expression B /$terminator/";
$i = $j;
} elsif ($Q =~ /^[a-zA-Z_]\w*/) {
$token = $&;
# "T"x90 should be ["T",x,90] not ["T",x90]
# x90 should be x,90 when previous token is a scalar
if ($token =~ /^x\d+$/) {
if ($tokens[-1] =~ /^[\'\"]/ || $tokens[-1] eq ")"
|| $contexts[-1] =~ /name/) {
$token = "x";
}
}
push @tokens, $token;
if ($sigil) {
push @contexts, "name";
} elsif ($contexts[-1] =~ /regular expression ([ABC]) \/(.)\//) {
push @contexts, "regular expression modifier";
my $regex_type = $1;
my $terminator = $2;
# with some modifiers we can be more flexible with the earlier tokens ...
# e - second pattern is an expression that can be flexible
# x - first and/or second pattern can contain whitespace
if (0 && $token =~ /e/ && $token =~ /x/ && $tokens[-2] =~ /^s/) {
$DB::single=1;
pop @tokens;
pop @contexts;
my $regex = pop @tokens;
my $regex_context = pop @contexts;
my $terminator2 = $terminator;
$terminator2 =~ tr/])}>/[({</; # >})]
my $t1 = index($regex,$terminator2);
my $t2 = index($regex,$terminator,$t1+1);
push @tokens, substr($regex,0,$t1+1);
push @contexts, "regular expression x /$terminator/";
for (my $t=$t1+1; $t<=$t2; $t++) {
if (substr($regex,$t,1) =~ /\S/) {
push @tokens, substr($regex,$t,1);
push @contexts, "content of regex/x";
}
}
$i -= length($token) + length($regex) - $t2 - 1;
# positions $i to the start of the 2nd pattern,
# which can be tokenized as a perl expression.
# Hopefully the terminator can be recognized
} elsif ($token =~ /x/) {
pop @tokens;
pop @contexts;
my $regex = pop @tokens;
my $regex_context = pop @contexts;
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
} else {
push @tokens, $_;
if ($sigil) {
push @contexts, "name";
} elsif (/\s/) {
push @contexts, "whitespace";
} elsif (/;/ && !$sigil) {
push @contexts, "end of statement";
} elsif (/\//) {
push @contexts, "operator or misanalyzed regex";
} elsif (/[\+\-\*\/\%\^\|\&\!\~\?\:\.]/) {
push @contexts, "operator";
} elsif (/\{/ && $sigil) {
push @contexts, "name container";
} elsif (/\}/ && STRPOS("name contained",@contexts) > STRPOS("name decontainer",@contexts)) {
push @contexts, "name decontainer";
} else {
push @contexts, "unknown";
}
}
$sigil = 0;
}
if ($DEBUG) {
print "- " x 20,"\n";
my @c = @contexts;
foreach $token (@tokens) {
my $cc = shift @c;
print $token,"\t",$cc,"\n";
}
print "- " x 20,"\n";
print "Total token count: ", scalar @tokens, "\n";
}
@asciiartinate::contexts = @contexts;
@asciiartinate::tokens = @tokens;
@tokens;
}
sub asciiindex_code {
my ($X) = @_;
my $endpos = index($X,"\n__END__\n");
if ($endpos >= 0) {
substr($X,$endpos) = "\n";
}
$X =~ s/\n\s*#[^\n]*\n/\n/g;
$X =~ s/\n\s*#[^\n]*\n/\n/g;
&tokenize_code($X);
}
#############################################################################
sub tokenize_art {
my ($INPUT) = @_;
my @INPUT = split //, $INPUT;
my $white = 1;
my $block_size = 0;
my @blocks = ();
foreach my $char (@INPUT) {
if ($char eq " " || $char eq "\n" || $char eq "\t") {
if ($block_size > 0) {
push @blocks, $block_size;
$block_size = 0;
}
# certain token combos like the special Perl vars
# ($$ $" $| $! etc.) can be separated by spaces and tabs
# but not by newlines! Let's use block of size 0 to
# indicate where a newline is.
if ($char eq "\n") {
push @blocks, 0;
}
} else {
++$block_size;
}
}
if ($block_size > 0) {
push @blocks, $block_size;
}
return @blocks;
}
sub asciiindex_art {
my ($X) = @_;
&tokenize_art($X);
}
#
# replace darkspace on the pic with characters from the code
#
sub print_code_to_pic {
my ($pic, @tokens) = @_;
local $" = '';
my $code = "@tokens";
my @code = split //, $code;
$pic =~ s/(\S)/@code==0?"#":shift @code/ge;
print $pic;
}
#
# find misalignment between multi-character tokens and blocks
# and report position where additional padding is needed for
# alignment
#
sub padding_needed {
my @tokens = @{$_[0]};
my @contexts = @{$_[1]};
my @blocks = @{$_[2]};
my $ib = 0;
my $tc = 0;
my $bc = $blocks[$ib++];
my $it = 0;
while ($bc == 0) {
$bc = $blocks[$ib++];
if ($ib > @blocks) {
( run in 6.482 seconds using v1.01-cache-2.11-cpan-5e09290becf )