Acme-AsciiArtinator
view release on metacpan or search on metacpan
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
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 {
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
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;
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
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";
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
} 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++) {
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
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
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;
} elsif ($token =~ /e/ && $tokens[-2] =~ /^s/) {
if ($regex_type eq "B") { # s///, tr///, y///
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,$t2+1);
push @contexts, "regular expression b /$terminator/";
$i -= length($token) + length($regex) - $t2 - 1;
}
}
} else {
push @contexts, "alphanumeric literal"; # bareword? name? label? keyword?
}
$i = $i -1 + length $token;
} elsif (($token = find_token_keyword($Q)) && !$sigil) {
push @tokens, $token;
push @contexts, "operator";
$i = $i - 1 + length $token;
} else {
push @tokens, $_;
if ($sigil) {
push @contexts, "name";
} elsif (/\s/) {
push @contexts, "whitespace";
} elsif (/;/ && !$sigil) {
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
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) {
print "Error: picture is not large enough to contain code!\n";
print map {(" ",length $_)} @tokens;
print "\n\n@blocks\n";
return [-1,-1];
}
}
foreach my $t (@tokens) {
my $tt = length $t;
defined $tt or print "! \$tt is not defined! \$it=$it \$ib=$ib\n";
defined $bc or print "! \$bc is not defined! \$it=$it \$ib=$ib \$tt=$tt\n";
if ($tt > $bc) {
if ($DEBUG) {
print "Need to pad by $bc spaces at or before position $tc\n";
} else {
print "\rNeed to pad by $bc spaces at or before position $tc ";
}
return [$it, $bc];
}
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
# for regular Perl variables ( "$x", "@bob" ), it is OK to split
# the sigil and the var name with any whitespace ("$ x", "@\n\tbob").
# For special Perl vars ( '$"', "$/", "$$" ), it is OK to split
# with spaces and tabs but not with newlines.
#
# Check for this condition here and say that padding is needed if
# a special var is currently aligned on a newline.
#
if ($bc == 0 && $blocks[$ib] == 0 && $tokens[$it] eq "\$"
&& $contexts[$it] eq "SIGIL" && $contexts[$it+1] eq "name"
&& length($tokens[$it+1]) == 1 && $tokens[$it+1] =~ /\W/) {
warn "\$tt > \$bc but padding still needed: \n",
(join " : ", @tokens[0 .. $it+1]), "\n",
(join " : ", @contexts[0 .. $it+1]), "\n",
(join " : ", @blocks[0 .. $ib+1]), "\n";
return [$it, 1] if 1;
}
while ($bc == 0) {
$bc = $blocks[$ib++];
if ($ib > @blocks) {
print "Error: picture is not large enough to contain code!\n";
print map {(" ",length $_)} @tokens;
print "\n\n@blocks\n";
return [-1,-1];
}
}
$tc += length $t;
$it++;
}
return;
}
#
# choose a random number between 0 and n-1,
# with the distribution heavily weighted toward
# the high end of the range
#
lib/Acme/AsciiArtinator.pm view on Meta::CPAN
my $npad = $howmuch > 1 ? $howmuch - hi_weighted_rand($howmuch-1) : $howmuch;
while (rand() > 0.95 && $where > 0) {
$where--;
}
while ($where >= 0 && !try_to_pad($where, $npad, \@tokens, \@contexts)) {
$where-- if rand() > 0.4;
}
my $tlength = 0;
map { $tlength += length $_ } @tokens;
if ($tlength > $nblocks) {
print "Padded length exceeds space length.\n";
if ($DEBUG) {
print_code_to_pic($Acme::AsciiArtinator::PIC, @tokens);
print "\n\n";
sleep 1;
}
return;
}
}
t/02-test_input.t view on Meta::CPAN
"it's been nice knowing you\n",
"ist been nice\n");
my @output = asciiartinate( code => $code, art => $art,
test_argv1 => [], test_input1 => \@input1,
test_argv2 => ["hello"], test_input2 => [] );
ok(defined $Acme::AsciiArtinator::TestOutput[1]);
ok(not defined $Acme::AsciiArtinator::TestOutput[0]);
ok(defined $Acme::AsciiArtinator::TestOutput[2]);
ok(length $Acme::AsciiArtinator::TestOutput[2] == 0);
ok($Acme::AsciiArtinator::TestOutput[1] eq "Hello, world!\n");
ok($Acme::AsciiArtinator::TestResult[1] eq "PASS");
ok($Acme::AsciiArtinator::TestResult[2] eq "PASS");
( run in 0.622 second using v1.01-cache-2.11-cpan-65fba6d93b7 )