Acme-EyeDrops
view release on metacpan or search on metacpan
lib/Acme/EyeDrops.pm view on Meta::CPAN
q Z('['^'#')Z,q Z('['^'"')Z,q Z('['^'!')Z,q Z'\\\\'.'{'Z,
q Z'|'Z,q Z'\\\\'.'}'Z,q Z'~'Z,q Z('!'^'^')Z
);
push @C, map(join('.', q#'\\\\'#, $C[120],
map($C[$_], unpack('C*', sprintf('%x', $_)))), 128..255);
sub ascii_to_sightly { join '.', map($C[$_], unpack('C*', $_[0])) }
}
sub sightly_to_ascii { eval eval q#'"'.# . $_[0] . q#.'"'# }
sub regex_print_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('print') . q#.'"'.# .
&ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub regex_binmode_print_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('binmode(STDOUT);print')
. q#.'"'.# . &ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub regex_eval_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('eval') . q#.'"'.# .
&ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub clean_print_sightly {
qq#print eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
}
sub clean_binmode_print_sightly {
qq#binmode(STDOUT);print eval '"'.\n\n\n# .
&ascii_to_sightly . q#.'"'#;
}
sub clean_eval_sightly {
qq#eval eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
}
# -----------------------------------------------------------------
sub _slurp_tfile {
my $f = shift;
my $b = shift;
open my $fh, '<', $f or die "open '$f': $!";
$b and binmode($fh);
local $/; my $s = <$fh>; close($fh); $s;
}
# Poor man's properties (see also YAML, java.util.Properties).
# Return ref to property hash.
sub _get_properties {
my $f = shift;
open my $fh, '<', $f or die "open '$f': $!";
my $l; my %h;
while (defined($l = <$fh>)) {
chomp($l);
if ($l =~ s/\\$//) {
my $n = <$fh>; $n =~ s/^\s+//; $l .= $n;
redo unless eof($fh);
}
$l =~ s/^\s+//; $l =~ s/\s+$//;
next unless length($l);
next if $l =~ /^#/;
my ($k, $v) = split(/\s*:\s*/, $l, 2);
$h{$k} = $v;
}
close($fh);
return \%h;
}
sub _def_ihandler { print STDERR $_[0] }
# Return largest no. of tokens with total length less than $slen ($slen > 0).
sub _guess_ntok {
my ($rtok, $sidx, $slen, $rexact) = @_; my $tlen = 0;
for my $i ($sidx .. $sidx + $slen) {
($tlen += length($rtok->[$i])) < $slen or
return $i - $sidx + (${$rexact} = $tlen == $slen);
}
# should never get here
}
sub _guess_compact_ntok {
my ($rtok, $sidx, $slen, $rexact, $fcompact) = @_; my $tlen = 0;
for my $i ($sidx .. $sidx + $slen + $slen) {
($tlen += length($rtok->[$i]) - ($i > $sidx+1 && $rtok->[$i-1] eq '.'
&& substr($rtok->[$i], 0, 1) eq "'" && substr($rtok->[$i-2], 0, 1)
eq "'" ? (${$fcompact} = 3) : 0)) < $slen or
return $i - $sidx + ($tlen > $slen ? 0 : (${$rexact} = 1) +
($i > $sidx && $rtok->[$i] eq '.' && substr($rtok->[$i-1], 0, 1)
eq "'" && $rtok->[$i+1] =~ /^'..$/ ? (${$fcompact} = 1) : 0));
}
# should never get here
}
sub _compact_join {
my ($rtok, $sidx, $n) = @_; my $s = "";
for my $i ($sidx .. $sidx + $n - 1) {
if ($i > $sidx+1 && $rtok->[$i-1] eq '.' && substr($rtok->[$i], 0, 1)
eq "'" && substr($rtok->[$i-2], 0, 1) eq "'") {
substr($s, -2) = substr($rtok->[$i], 1); # 'a'.'b' to 'ab'
} else {
$s .= $rtok->[$i];
}
}
$s;
}
# Pour $n tokens from @{$rtok} (starting at index $sidx) into string
# of length $slen. Return string or undef if unsuccessful.
sub _pour_chunk {
my ($rtok, $sidx, $n, $slen) = @_;
my $eidx = $sidx + $n - 1; my $tlen = 0;
my $idot = my $iquote = my $i3quote = my $iparen = my $idollar = -1;
for my $i ($sidx .. $eidx) {
$tlen += length($rtok->[$i]);
if ($rtok->[$i] eq '.') { $idot = $i }
elsif ($rtok->[$i] eq '(') { $iparen = $i }
elsif (substr($rtok->[$i], 0, 1) eq '$') { $idollar = $i }
elsif ($rtok->[$i] =~ /^['"]/) {
$iquote = $i; $i3quote = $i if length($rtok->[$i]) == 3;
}
}
die "oops" if $tlen >= $slen;
my $i2 = (my $d = $slen - $tlen) >> 1;
$idot >= 0 && !($d%3) and return join("", @{$rtok}[$sidx .. $idot-1],
".''" x int($d/3), @{$rtok}[$idot .. $eidx]);
if (!($d&1) and $iquote >= 0 || $idollar >= 0) {
$iquote = $idollar if $iquote < 0;
return join("", @{$rtok}[$sidx .. $iquote-1], '(' x $i2 .
$rtok->[$iquote] . ')' x $i2, @{$rtok}[$iquote+1 .. $eidx]);
}
$i3quote >= 0 and return join("", @{$rtok}[$sidx .. $i3quote-1],
$d == 1 ? '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' :
'(' x $i2 . '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' .
')' x $i2, @{$rtok}[$i3quote+1 .. $eidx]);
return unless $d == 1;
$iparen >= 0 and return join("", @{$rtok}[$sidx .. $iparen-1],
'+' . $rtok->[$iparen], @{$rtok}[$iparen+1 .. $eidx]);
# ouch, can't test for eq '(' in case next chunk also adds '+'
$rtok->[$eidx] ne '=' && $rtok->[$sidx+$n] =~ /^['"]/ ?
join("", @{$rtok}[$sidx .. $eidx], '+') : undef;
}
sub _pour_compact_chunk {
my ($rtok, $sidx, $n, $slen) = @_; my @mytok;
for my $i ($sidx .. $sidx + $n - 1) {
if ($i > $sidx+1 && $rtok->[$i-1] eq '.' && substr($rtok->[$i], 0, 1)
eq "'" && substr($rtok->[$i-2], 0, 1) eq "'") {
pop(@mytok); my $qtok = pop(@mytok); # 'a'.'b' to 'ab'
push(@mytok, substr($qtok, 0, -1) . substr($rtok->[$i], 1));
} else {
push(@mytok, $rtok->[$i]);
}
}
push(@mytok, $rtok->[$sidx+$n]); # _pour_chunk checks next token
_pour_chunk(\@mytok, 0, $#mytok, $slen);
}
# Pour unsightly text $txt into shape defined by string $tlines.
sub pour_text {
my ($tlines, $txt, $gap, $tfill) = @_;
$txt =~ s/\s+//g;
my $ttlen = 0; my $txtend = length($txt);
my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
split(/\n/, $tlines));
for my $r (grep($_, @tnlines)) {
for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
}
my $nshape = int($txtend/$ttlen); my $rem = $txtend % $ttlen;
if ($rem || !$nshape) {
++$nshape;
$txt .= $tfill x (int(($ttlen-$rem)/length($tfill))+1)
if length($tfill);
}
my $s = ""; my $p = 0;
for (my $n = 1; 1; ++$n, $s .= "\n" x $gap) {
for my $r (@tnlines) {
if ($r) {
for my $i (0 .. $#{$r}) {
if ($i & 1) {
$s .= substr($txt, $p, $r->[$i]); $p += $r->[$i];
return "$s\n" if !length($tfill) && $p >= $txtend;
} else {
$s .= ' ' x $r->[$i];
}
}
}
$s .= "\n";
}
last if $n >= $nshape;
}
$s;
}
# Make filler code to stuff on end of program to fill last shape.
sub _make_filler {
my $fv = shift; # list reference of filler variables
my $nfv = @{$fv};
# Beware with these filler values.
# Avoid $; $" ';' (to avoid clash with " and ; in later parsing).
# END block is trouble because it is executed after this filler.
# Setting $^ or $~ (but not $:) to weird values resets $@.
# For example: $~='?'&'!'; (this looks like a Perl bug to me).
# For now, just stick with letters and numbers.
my @filleqto = (
[ q#'.'#, '^', q^'~'^ ], [ q#'@'#, '|', q^'('^ ],
[ q#')'#, '^', q^'['^ ], [ q#'`'#, '|', q^'.'^ ],
[ q#'('#, '^', q^'}'^ ], [ q#'`'#, '|', q^'!'^ ],
[ q#')'#, '^', q^'}'^ ], [ q#'*'#, '|', q^'`'^ ],
[ q#'+'#, '^', q^'_'^ ], [ q#'&'#, '|', q^'@'^ ],
[ q#'['#, '&', q^'~'^ ], [ q#','#, '^', q^'|'^ ]
);
$nfv > @filleqto and die "too many fv";
my $rem = @filleqto % $nfv;
$rem and splice(@filleqto, -$rem);
my $v = -1;
map(($fv->[++$v % $nfv], '=', @{$_}, ';'), @filleqto);
}
# Pour sightly program $prog into shape defined by string $tlines.
sub pour_sightly {
my ($tlines, $prog, $gap, $fillv, $compact, $ihandler) = @_;
$ihandler ||= \&_def_ihandler;
my $ttlen = 0;
my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
split(/\n/, $tlines));
for my $r (grep($_, @tnlines)) {
for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
}
my $outstr = ""; my @ptok;
if ($prog) {
if ($prog =~ /^''=~/g) {
push(@ptok, ($tlines =~ /(\S+)/ ? length($1) : 0) == 3 ?
"'?'" : "''", '=~');
} elsif ($prog =~ /(.*eval.*\n\n\n)/g) {
$outstr .= $1;
}
push(@ptok, $prog =~ /[().&|^]|'\\\\'|.../g); # ... is "'"|'.'
}
my $iendprog = @ptok;
my @filler = _make_filler(ref($fillv) ? $fillv : [ '$:', '$~', '$^' ]);
# Note: 11 is the length of a filler item, for example, $:='.'^'~';
# And there are 6 tokens in each filler item: $: = '.' ^ '~' ;
push(@ptok, 'Z', (@filler) x (int($ttlen/(11 * int(@filler / 6))) + 1));
my $sidx = 0;
for (my $nshape = 1; 1; ++$nshape, $outstr .= "\n" x $gap) {
for my $rline (@tnlines) {
unless ($rline) { $outstr .= "\n"; next }
for my $it (0 .. $#{$rline}) {
unless ($it & 1) {$outstr .= ' ' x $rline->[$it]; next }
(my $tlen = $rline->[$it]) == (my $plen = length($ptok[$sidx]))
and $outstr .= $ptok[$sidx++], next;
if ($plen > $tlen) {
$outstr .= '(' x $tlen;
splice(@ptok, $sidx+1, 0, (')') x $tlen);
$iendprog += $tlen if $sidx < $iendprog;
next;
}
my $fcompact = my $fexact = 0;
my $n = $compact ?
_guess_compact_ntok(\@ptok, $sidx, $tlen, \$fexact, \$fcompact)
: _guess_ntok(\@ptok, $sidx, $tlen, \$fexact);
if ($fexact) {
$outstr .= $fcompact ? _compact_join(\@ptok, $sidx, $n) :
join("", @ptok[$sidx .. $sidx+$n-1]);
$sidx += $n; next;
}
my $str;
--$n while $n > 0 && !defined($str = $fcompact ?
_pour_compact_chunk(\@ptok, $sidx, $n, $tlen) :
_pour_chunk(\@ptok, $sidx, $n, $tlen));
if ($n) { $outstr .= $str; $sidx += $n; next }
++$n while $n < $tlen && length($ptok[$sidx+$n]) < 2;
die "oops ($n >= $tlen)" if $n >= $tlen;
$outstr .= join("", @ptok[$sidx .. $sidx+$n-1]);
$sidx += $n;
$outstr .= '(' x (my $nleft = $tlen - $n);
splice(@ptok, $sidx+1, 0, (')') x $nleft);
$iendprog += $nleft if $sidx < $iendprog;
}
$outstr .= "\n";
}
$ihandler->("$nshape shapes completed.\n");
last if $sidx >= $iendprog;
}
my $eidx = rindex($outstr, 'Z');
substr($outstr, $eidx, 1) = ';' if $eidx >= 0;
return $outstr if $sidx == $iendprog || $sidx == $iendprog+1;
die "oops" if $eidx < 0;
ref($fillv) or return substr($outstr, 0, $eidx) . (length($fillv) ?
pour_text(substr($outstr, $eidx), "", 0, $fillv) : "\n");
(my $idx = rindex($outstr, ';')) >= 0 or return $outstr;
my @t = substr($outstr, $idx+1) =~
/[()&|^=;]|\$.|'[^'\\]*(?:\\.[^'\\]*)*'|"[^"\\]*(?:\\.[^"\\]*)*"/g
or return $outstr;
my $nl = my $nr = my $ne = 0;
for my $c (@t) {
if ($c eq '(') {++$nl} elsif ($c eq ')') {++$nr}
elsif ($c eq '=') {++$ne}
}
if ($ne == 0 || $nl != $nr || $t[-1] eq '=') {
my $f = ';'; # Trouble: wipe out last bit with filler
for my $i ($idx+1 .. length($outstr)-2) {
substr($outstr, $i, 1) =~ tr/ \n// or
substr($outstr, $i, 1) = $f = $f eq '#' ? ';' : '#';
}
} elsif ($t[-1] eq '|' or $t[-1] eq '^' or $t[-1] eq '&') {
$outstr =~ s/\S(\s*)$/;$1/;
}
$outstr;
}
# -----------------------------------------------------------------
sub _border {
my ($a, $w, $c, $l, $r, $t, $b) = @_;
my $z = $c x ($w+$l+$r); my $f = $c x $l; my $g = $c x $r;
for (@{$a}) { $_ = $f . $_ . $g }
unshift(@{$a}, ($z) x $t); push(@{$a}, ($z) x $b);
}
sub border_shape {
my ($tlines, $gl, $gr, $gt, $gb, $wl, $wr, $wt, $wb) = @_;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
$gl || $gr || $gt || $gb and _border(\@a, $m, ' ', $gl, $gr, $gt, $gb);
$wl || $wr || $wt || $wb and _border(\@a, $m+$gl+$gr,'#',$wl,$wr,$wt,$wb);
join("\n", @a, "");
}
sub invert_shape {
my $tlines = shift;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
my $s = join("\n", @a, ""); $s =~ tr/ #/# /;
$s =~ s/ +$//mg; $s;
}
sub reflect_shape {
my $tlines = shift;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
my $s = join("\n", map(scalar reverse($_ . ' ' x ($m - length)), @a), "");
$s =~ s/ +$//mg; $s;
}
sub hjoin_shapes {
my ($g, @shapes) = @_;
my $ml = 0; my @lines;
for my $s (@shapes) { my $n = $s =~ tr/\n//; $ml = $n if $n > $ml }
for my $tlines (@shapes) {
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l) + $g) }
push(@a, (' ' x ($m + $g)) x ($ml - @a));
for my $i (0..$#a) { $lines[$i] .= $a[$i] }
}
my $s = join("\n", @lines, "");
$s =~ s/ +$//mg; $s;
}
sub reduce_shape {
my ($tlines, $f) = @_; my $i = $f++; my $s = "";
for my $l (grep(!(++$i%$f), split(/\n/, $tlines))) {
for ($i = 0; $i < length($l); $i += $f) { $s .= substr($l, $i, 1) }
$s .= "\n";
}
$s =~ s/ +$//mg; $s;
}
sub expand_shape {
my ($s, $f) = @_; my $i = ' ' x ++$f; my $j = '#' x $f;
$s =~ s/ /$i/g; $s =~ s/#/$j/g; my $t = "";
for my $l (split(/^/, $s, -1)) { $t .= $l x $f } $t;
}
# Rotate shape clockwise: 90, 180 or 270 degrees
# (other angles are left as an exercise for the reader:-)
sub rotate_shape {
my ($tlines, $degrees, $rtype, $flip) = @_;
$degrees == 180 and
return join("\n", reverse(split(/\n/, $tlines)), "");
my $t = $rtype==0 ? 2 : 1; my $inc = $rtype==1 ? 2 : 1;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0; my $s = "";
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
if ($degrees == 90) {
@a = reverse(@a) unless $flip;
for (my $i = 0; $i < $m; $i += $inc) {
for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
}
} elsif ($degrees == 270) {
@a = reverse(@a) if $flip;
for (my $i = $m-1; $i >= 0; $i -= $inc) {
for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
}
}
$s =~ s/ +$//mg; $s;
}
sub make_triangle {
my $w = shift; $w & 1 or ++$w; $w < 9 and $w = 9;
my $n = $w >> 1; my $s;
for (my $i=1;$i<=$w;$i+=2) { $s .= ' ' x $n-- . '#' x $i . "\n" }
$s;
}
sub make_siertri {
my $w = shift; $w < 3 and $w = 5; my $n = 2 ** $w; my $s;
for my $i (0 .. $n-1) {
--$n; $s .= ' ' x $n .
join('', map($n & $_ ? ' ' : '##', 0 .. $i)) . "\n";
} $s;
}
sub make_banner {
my ($w, $src) = @_;
# Linux /usr/games/banner can be used.
# CPAN Text::Banner will hopefully be enhanced so it can be used too.
my $b_exe = '/usr/games/banner';
-x $b_exe or die "'$b_exe' not available on this platform.";
my $f = $w ? "-w $w" : ""; $src =~ s/\s+/ /g; $src =~ s/ $//;
# Following characters not in /usr/games/banner character set:
# \ [ ] { } < > ^ _ | ~
# Also must escape ' from the shell.
$src =~ tr#_\\[]{}<>^|~'`#-/()()()H!T""#;
my $s = ""; my $len = length($src);
for (my $i = 0; $i < $len; $i += 512) {
my $cmd = "$b_exe $f '" . substr($src, $i, 512) . "'";
$s .= `$cmd`; my $rc = $? >> 8; $rc and die "<$cmd>: rc=$rc";
}
$s =~ s/\s+$/\n/; $s =~ s/ +$//mg;
# Remove as many leading spaces as possible.
my $m = 32000; # regex /^ {$m}/ blows up if $m > 32766
while ($s =~ /^( *)\S/mg) { $m = length($1) if length($1) < $m }
$s =~ s/^ {$m}//mg if $m; $s;
}
# -------------------------------------------------------------------------
sub _bi_all {
join "\n" x $_[0]->{Width},
map(_get_eye_string($_[0]->{EyeDir}, $_), _get_eye_shapes($_[0]->{EyeDir}))
}
sub _bi_triangle { make_triangle($_[0]->{Width}) }
sub _bi_siertri { make_siertri($_[0]->{Width}) }
sub _bi_banner { make_banner($_[0]->{Width}, $_[0]->{BannerString}) }
sub _bi_srcbanner { make_banner($_[0]->{Width}, $_[0]->{SourceString}) }
{
my %builtin_shapes = (
'all' => \&_bi_all,
'triangle' => \&_bi_triangle,
'siertri' => \&_bi_siertri,
'banner' => \&_bi_banner,
'srcbanner' => \&_bi_srcbanner
);
sub get_builtin_shapes { sort keys %builtin_shapes }
# Return built-in shape string or undef if invalid shape.
sub _get_builtin_string {
my $shape = shift;
return unless exists($builtin_shapes{$shape});
$builtin_shapes{$shape}->(shift);
}
}
sub sightly {
my $ruarg = shift; my %arg = (
Shape => "", ShapeString => "",
SourceFile => "", SourceString => "",
SourceHandle => undef, InformHandler => undef,
Width => 0, BannerString => "",
Text => 0, TextFiller => "",
Regex => 0, Compact => 0,
Print => 0, Binary => 0,
Gap => 0, Rotate => 0,
RotateType => 0, RotateFlip => 0,
Reflect => 0, Reduce => 0,
Expand => 0, Invert => 0,
TrailingSpaces => 0, RemoveNewlines => 0,
Indent => 0, BorderGap => 0,
BorderGapLeft => 0, BorderGapRight => 0,
BorderGapTop => 0, BorderGapBottom => 0,
BorderWidth => 0, BorderWidthLeft => 0,
BorderWidthRight => 0, BorderWidthTop => 0,
BorderWidthBottom => 0, TrapEvalDie => 0,
TrapWarn => 0, FillerVar => [],
EyeDir => get_eye_dir()
);
for my $k (keys %{$ruarg}) {
exists($arg{$k}) or die "invalid parameter '$k'";
$arg{$k} = $ruarg->{$k};
}
length($arg{SourceFile}) && $arg{SourceHandle} and
die "cannot specify both SourceFile and SourceHandle";
length($arg{SourceFile}) && length($arg{SourceString}) and
die "cannot specify both SourceFile and SourceString";
length($arg{SourceString}) && $arg{SourceHandle} and
die "cannot specify both SourceString and SourceHandle";
$arg{Shape} && $arg{ShapeString} and
die "cannot specify both Shape and ShapeString";
if (length($arg{SourceFile})) {
$arg{SourceString} = _slurp_tfile($arg{SourceFile}, $arg{Binary});
} elsif ($arg{SourceHandle}) {
local $/; $arg{SourceString} = readline($arg{SourceHandle});
}
my $fill = $arg{FillerVar};
if (ref($fill) && !$arg{Text}) {
# Non-rigourous check for module (package) or END block.
@{$fill} or $fill = ($arg{SourceString} =~ /^\s*END\b/m or
$arg{SourceString} =~ /^\s*package\b/m) ?
[ '$:', '$~', '$^' ] :
[ '$:', '$~', '$^', '$/', '$,', '$\\' ];
}
$arg{RemoveNewlines} and $arg{SourceString} =~ tr/\n//d;
my $shape = my $sightly = "";
length($arg{SourceString}) && !$arg{Text} and $sightly = $arg{Print} ?
( $arg{Regex} ? ( $arg{Binary} ?
regex_binmode_print_sightly($arg{SourceString}) :
regex_print_sightly($arg{SourceString}) ) :
( $arg{Binary} ?
clean_binmode_print_sightly($arg{SourceString}) :
clean_print_sightly($arg{SourceString}) ) ) :
( $arg{Regex} ? regex_eval_sightly($arg{SourceString}) :
clean_eval_sightly($arg{SourceString}) );
if ($arg{ShapeString}) {
$shape = $arg{ShapeString};
} elsif ($arg{Shape}) {
$shape = join("\n" x $arg{Gap},
map(_get_builtin_string($_, \%arg) ||
(m#[./]# ? _slurp_tfile($_) : _get_eye_string($arg{EyeDir}, $_)),
split(/,/, $arg{Shape})));
} elsif ($arg{Width}) {
die "invalid width $arg{Width} (must be > 3)"
if !$arg{Text} && $arg{Width} < 4;
$shape = '#' x $arg{Width};
}
$shape or return "use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) . $sightly;
$arg{Rotate} and $shape = rotate_shape($shape, $arg{Rotate},
$arg{RotateType}, $arg{RotateFlip});
$arg{Reflect} and $shape = reflect_shape($shape);
$arg{Reduce} and $shape = reduce_shape($shape, $arg{Reduce});
$arg{Expand} and $shape = expand_shape($shape, $arg{Expand});
$arg{Invert} and $shape = invert_shape($shape);
$arg{TrailingSpaces} ||
$arg{BorderGap} || $arg{BorderWidth} ||
$arg{BorderGapLeft} || $arg{BorderWidthLeft} ||
$arg{BorderGapRight} || $arg{BorderWidthRight} ||
$arg{BorderGapTop} || $arg{BorderWidthTop} ||
$arg{BorderGapBottom} || $arg{BorderWidthBottom} and
$shape = border_shape($shape,
$arg{BorderGapLeft} || $arg{BorderGap},
$arg{BorderGapRight} || $arg{BorderGap},
$arg{BorderGapTop} || $arg{BorderGap},
$arg{BorderGapBottom} || $arg{BorderGap},
$arg{BorderWidthLeft} || $arg{BorderWidth},
$arg{BorderWidthRight} || $arg{BorderWidth},
$arg{BorderWidthTop} || $arg{BorderWidth},
$arg{BorderWidthBottom} || $arg{BorderWidth});
if ($arg{Indent}) { my $s = ' ' x $arg{Indent}; $shape =~ s/^/$s/mg }
$arg{Text} and return
pour_text($shape, $arg{SourceString}, $arg{Gap}, $arg{TextFiller});
"use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) .
'local $SIG{__WARN__}=sub{};' x $arg{TrapWarn} .
pour_sightly($shape, $sightly, $arg{Gap}, $fill, $arg{Compact},
$arg{InformHandler}) . "\n\n\n;die \$\@ if \$\@\n" x $arg{TrapEvalDie};
}
# -------------------------------------------------------------------------
sub _get_eye_shapes {
my $d = shift;
opendir my $dh, $d or die "opendir '$d': $!";
my @e = sort map(/(.+)\.eye$/, readdir($dh));
closedir($dh); @e;
}
lib/Acme/EyeDrops.pm view on Meta::CPAN
Next, a 'eye' shape (.eye file in the
get_eye_dir() directory unless overridden
by the EyeDir attribute) is looked for.
Finally, a file name is looked for.
ShapeString Describes the shape you want.
This time you specify a shape string.
SourceFile The source file name to convert.
SourceHandle Specify a file handle instead of a file name.
SourceString Specify a string instead of a file name.
BannerString String to use with built-in Shape 'banner'.
Regex Regex can take the following values:
0: do not embed source program in a regex
If Regex is positive, embed the program in a regex and:
1: add a leading "use re 'eval';" for Perl 5.18+ only
2: do not add a leading "use re 'eval';"
3: add a leading "use re 'eval';"
Do not set this flag when converting complex programs.
Compact Boolean. If set, use compact sightly encoding.
Print Boolean. If set, use a print statement instead
of the default eval statement. Set this flag
when converting text files (not programs).
Binary Boolean. Set if encoding a binary file.
Text Boolean. Set if pouring unsightly text.
TextFiller Filler string used with Text attribute.
For example, TextFiller => '#'.
Gap The number of lines between successive shapes.
Rotate Rotate the shape clockwise 90, 180 or 270 degrees.
RotateType 0 = big rotated shape,
1 = small rotated shape,
2 = squashed rotated shape.
RotateFlip Boolean. Set if want to flip (reflect) the shape
in addition to rotating it.
Reflect Boolean. Reflect the shape.
Reduce Reduce the size of the shape.
Expand Expand the size of the shape.
Invert Boolean. Invert the shape.
Indent Indent the shape. The number of spaces to indent.
TrailingSpaces Boolean. Ensure all lines of the shape are of equal
length, adding trailing spaces if required.
RemoveNewlines Boolean. Remove all newlines from the source before
conversion.
BorderGap Put a border around the shape. Gap between border
and the shape.
BorderGapLeft,BorderGapRight,BorderGapTop,BorderGapBottom
You can override BorderGap with one or more from
the above.
BorderWidth Put a border around the shape. Width of border.
BorderWidthLeft,BorderWidthRight,BorderWidthTop,BorderWidthBottom
You can override BorderWidth with one or more from
the above.
Width Ignored for .eye file shapes. For built-in shapes,
interpreted appropriately for the shape, typically the
shape width in characters. If no shape is specified,
a rectangular block of Width characters is generated.
EyeDir Normally .eye files are got from the EyeDrops
directory underneath where EyeDrops.pm is located.
You can override that by specifying a directory
containing the .eye shape files.
InformHandler By default, sightly prints status of what it is
doing to STDERR; you can override this by providing
a subroutine reference taking a single inform string
argument. To shut it up, set to sub {}.
TrapEvalDie Boolean.
Add closing 'die $@ if $@' to generated program.
When an eval code block calls the die function,
the program does not die; instead the die string
is returned to eval in $@. Using this flag allows
you to convert programs that call die.
TrapWarn Boolean.
Add leading 'local $SIG{__WARN__}=sub{};' to
generated program. This shuts up some warnings.
Use this option if generated program emits
'No such signal: SIGHUP at ...' when run with
warnings enabled.
FillerVar Reference to a list of 'filler variables'.
A filler variable is a Perl variable consisting
of two characters: $ and a punctuation character.
For example, FillerVar => [ '$:', '$^' ].
Do not use $; or $" or $_ as filler variables.
Alternatively, you may set this to '' if you don't
want any filler, or to a string (e.g. '#' or ';'
or ';#') to use instead of filler variables to
fill the leftover part of the last shape with.
=back
=head2 Specifying a Shape
( run in 0.924 second using v1.01-cache-2.11-cpan-140bd7fdf52 )