Acme-EyeDrops
view release on metacpan or search on metacpan
lib/Acme/EyeDrops.pm view on Meta::CPAN
package Acme::EyeDrops;
require 5.006;
use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT_OK);
require Exporter; @ISA = qw(Exporter);
@EXPORT_OK = qw(ascii_to_sightly sightly_to_ascii
regex_print_sightly regex_eval_sightly clean_print_sightly
clean_eval_sightly regex_binmode_print_sightly
clean_binmode_print_sightly
get_eye_dir get_eye_shapes get_eye_string get_builtin_shapes
get_eye_properties get_eye_keywords find_eye_shapes
make_triangle make_siertri make_banner
border_shape invert_shape reflect_shape rotate_shape
reduce_shape expand_shape hjoin_shapes
pour_text pour_sightly sightly);
$VERSION = '1.62';
{ # This table was generated by demo/gentable.pl.
my @C = (
q Z('!'^'!')Z,q Z('('^')')Z,q Z('<'^'>')Z,q Z('>'^'=')Z,
q Z('>'^':')Z,q Z('>'^';')Z,q Z('+'^'-')Z,q Z('*'^'-')Z,
q Z('+'^'#')Z,q Z('*'^'#')Z,q Z('!'^'+')Z,q Z('!'^'*')Z,
q Z('!'^'-')Z,q Z('!'^',')Z,q Z('!'^'/')Z,q Z('!'^'.')Z,
q Z('?'^'/')Z,q Z('<'^'-')Z,q Z('-'^'?')Z,q Z('.'^'=')Z,
q Z('+'^'?')Z,q Z('*'^'?')Z,q Z('?'^')')Z,q Z('<'^'+')Z,
q Z('%'^'=')Z,q Z('&'^'?')Z,q Z('?'^'%')Z,q Z('>'^'%')Z,
q Z('&'^':')Z,q Z('<'^'!')Z,q Z('?'^'!')Z,q Z('%'^':')Z,
q Z('{'^'[')Z,q Z'!'Z,q Z'\\\\'.'"'Z,q Z'#'Z,
q Z'\\\\'.'$'Z,q Z'%'Z,q Z'&'Z,q Z"'"Z,q Z'('Z,q Z')'Z,
q Z'*'Z,q Z'+'Z,q Z','Z,q Z'-'Z,q Z'.'Z,q Z'/'Z,
q Z('^'^('`'|'.'))Z,q Z('^'^('`'|'/'))Z,q Z('^'^('`'|','))Z,
q Z('^'^('`'|'-'))Z,q Z('^'^('`'|'*'))Z,q Z('^'^('`'|'+'))Z,
q Z('^'^('`'|'('))Z,q Z('^'^('`'|')'))Z,q Z(':'&'=')Z,
q Z(';'&'=')Z,q Z':'Z,q Z';'Z,q Z'<'Z,q Z'='Z,q Z'>'Z,q Z'?'Z,
q Z'\\\\'.'@'Z,q Z('`'^'!')Z,q Z('`'^'"')Z,q Z('`'^'#')Z,
q Z('`'^'$')Z,q Z('`'^'%')Z,q Z('`'^'&')Z,q Z('`'^"'")Z,
q Z('`'^'(')Z,q Z('`'^')')Z,q Z('`'^'*')Z,q Z('`'^'+')Z,
q Z('`'^',')Z,q Z('`'^'-')Z,q Z('`'^'.')Z,q Z('`'^'/')Z,
q Z('{'^'+')Z,q Z('{'^'*')Z,q Z('{'^')')Z,q Z('{'^'(')Z,
q Z('{'^'/')Z,q Z('{'^'.')Z,q Z('{'^'-')Z,q Z('{'^',')Z,
q Z('{'^'#')Z,q Z('{'^'"')Z,q Z('{'^'!')Z,q Z'['Z,
q Z'\\\\'.'\\\\'Z,q Z']'Z,q Z'^'Z,q Z'_'Z,
q Z'`'Z,q Z('`'|'!')Z,q Z('`'|'"')Z,q Z('`'|'#')Z,
q Z('`'|'$')Z,q Z('`'|'%')Z,q Z('`'|'&')Z,q Z('`'|"'")Z,
q Z('`'|'(')Z,q Z('`'|')')Z,q Z('`'|'*')Z,q Z('`'|'+')Z,
q Z('`'|',')Z,q Z('`'|'-')Z,q Z('`'|'.')Z,q Z('`'|'/')Z,
q Z('['^'+')Z,q Z('['^'*')Z,q Z('['^')')Z,q Z('['^'(')Z,
q Z('['^'/')Z,q Z('['^'.')Z,q Z('['^'-')Z,q Z('['^',')Z,
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#.'"'#;
}
lib/Acme/EyeDrops.pm view on Meta::CPAN
# -----------------------------------------------------------------
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";
}
lib/Acme/EyeDrops.pm view on Meta::CPAN
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;
}
sub _get_eye_string { _slurp_tfile($_[0] . '/' . $_[1] . '.eye') }
sub _get_eye_properties {
my $f = $_[0] . '/' . $_[1] . '.eyp';
-f $f or return;
_get_properties($f);
}
sub _get_eye_keywords {
my $d = shift;
my %h;
SHAPE: for my $s (_get_eye_shapes($d)) {
my $p = _get_eye_properties($d, $s) or next SHAPE; # no properties
exists($p->{keywords}) or next SHAPE; # no keywords property
my @k = split(" ", $p->{keywords}) or next SHAPE; # no keywords
for my $k (@k) { push(@{$h{$k}}, $s) }
}
return \%h;
}
sub _find_eye_shapes {
my $d = shift;
@_ or die "oops, no keywords given";
my @skey = map([split/\s+OR\s+/], @_);
my @ret;
SHAPE: for my $s (_get_eye_shapes($d)) {
lib/Acme/EyeDrops.pm view on Meta::CPAN
in the F<get_eye_dir> directory.
=item get_eye_keywords
Returns a hash reference keyed by keyword, with the
value being the list of shapes containing the keyword.
=item find_eye_shapes KEYWORDLIST
Returns a list of the I<eye> shapes in ascii-betical order
that contain all keywords in KEYWORDLIST.
The keywords in KEYWORDLIST are implicitly AND'ed together.
Additionally, you may use OR inside any KEYWORDLIST element.
If this is unclear, see the examples in "Shape Properties"
section below.
=item get_eye_string SHAPENAME
Given a .eye SHAPENAME, returns the shape string.
=item get_eye_properties SHAPENAME
Given a .eye SHAPENAME, returns a hash reference of
the shape properties or undef if the shape has no
properties.
=item slurp_yerself
Returns a string containing the contents of F<EyeDrops.pm>.
=item make_triangle WIDTH
Returns a triangle shaped string of WIDTH characters.
=item make_siertri WIDTH
Returns a Sierpinski triangle shaped string containing 2**WIDTH lines.
=item make_banner WIDTH STRING
Linux only. Returns a banner of STRING, using the Linux command
C</usr/games/banner -w WIDTH>.
=item border_shape SHAPESTRING GAP_LEFT GAP_RIGHT GAP_TOP GAP_BOTTOM
WIDTH_LEFT WIDTH_RIGHT WIDTH_TOP WIDTH_BOTTOM
Put a border around a shape.
=item invert_shape SHAPESTRING
Invert a shape.
=item reflect_shape SHAPESTRING
Reflect a shape.
=item reduce_shape SHAPESTRING FACT
Reduce the size of a shape by a factor of FACT.
=item expand_shape SHAPESTRING FACT
Expand the size of a shape by a factor of FACT.
=item rotate_shape SHAPESTRING DEGREES RTYPE FLIP
Rotate a shape clockwise thru 90, 180 or 270 degrees.
RTYPE=0 big rotated shape,
RTYPE=1 small rotated shape,
RTYPE=2 squashed rotated shape.
FLIP=1 to flip (reflect) shape in addition to rotating it.
RTYPE and FLIP do not apply to 180 degrees.
=item hjoin_shapes GAP SHAPESTRINGLIST
Join the shapes specified by SHAPESTRINGLIST horizontally with
GAP spaces between each shape.
=item pour_text SHAPESTRING TEXTSTRING GAP FILLTEXT
Given a shape string SHAPESTRING, a string TEXTSTRING, and a GAP
between successive shapes, returns a properly shaped string.
That is, pour TEXTSTRING into SHAPESTRING.
FILLTEXT (typically '#') is text to be used as a filler for any
leftover part of the shape (if not set, don't fill in leftovers).
=item pour_sightly SHAPESTRING PROGSTRING GAP RFILLVAR COMPACT IH
Given a shape string SHAPESTRING, a sightly-encoded program
string PROGSTRING, and a GAP between successive shapes,
returns a properly shaped program string.
That is, pour PROGSTRING into SHAPESTRING.
RFILLVAR is either a reference to an array of filler variables
or, alternatively, a string to fill the leftover of the last
shape with. Common filler strings are C<''> for no filler at all,
or C<'#'> or C<';'> or C<';#'>.
A filler variable is a valid Perl variable consisting
of two characters: C<$> and a punctuation character.
For example, RFILLVAR = C<[ '$:', '$^', '$~' ]>.
Do not use C<$;> or C<$"> or C<$_> as filler variables.
If COMPACT is 1, use compact sightly encoding,
if 0 use plain sightly encoding.
If IH (inform handler) is undef, 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 IH to C<sub {}>.
=item sightly HASHREF
Given a hash reference, HASHREF, describing various attributes,
returns a properly shaped program string.
There is no error return; if something is badly wrong, C<die> is
called -- so wrap the call to C<sightly> in an eval block if you
can't afford to die.
The attributes that HASHREF may contain are:
Shape Describes the shape you want.
First, a built-in shape is looked for.
Next, a 'eye' shape (.eye file in the
get_eye_dir() directory unless overridden
( run in 1.126 second using v1.01-cache-2.11-cpan-97f6503c9c8 )