File Coverage

blib/lib/Acme/EyeDrops.pm

Criterion	Covered	Total	%
statement	430	450	95.5
branch	255	276	92.3
condition	142	170	83.5
subroutine	51	53	96.2
pod	29	29	100.0
total	907	978	92.7

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.61';
{  # 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#.'"'#;
}

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;
}

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)) {
      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
      my %h; @h{@k} = ();
      for my $k (@skey) {
         # XXX: short-circuiting List::Util::first() better than grep here.
         grep(exists($h{$_}), @{$k}) or next SHAPE;  # AND, all must be true
      }
      push(@ret, $s);
   }
   return @ret;
}

sub get_eye_shapes     { _get_eye_shapes(get_eye_dir()) }
sub get_eye_string     { _get_eye_string(get_eye_dir(), shift) }
sub get_eye_properties { _get_eye_properties(get_eye_dir(), shift) }
sub get_eye_keywords   { _get_eye_keywords(get_eye_dir()) }
sub find_eye_shapes    { _find_eye_shapes(get_eye_dir(), @_) }

# $eye_dir is the directory containing the .eye file shapes.
# Note: $eye_dir is only eval-hostile line in EyeDrops.pm; do not change it
# for t/19_surrounds.t and "EyeDropping EyeDrops.pm" section of doco relies
# on it. Remove ".pm" from "...Acme/EyeDrops.pm" giving directory name.
my $eye_dir = __FILE__; chop($eye_dir);chop($eye_dir);chop($eye_dir);

sub slurp_yerself { _slurp_tfile($eye_dir . '.pm') }

sub get_eye_dir { $eye_dir }

1;

__END__