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


line stmt bran cond sub pod time code
1             package Acme::EyeDrops;
2             require 5.006;
3 20     20   21138 use strict;
  20         29  
  20         591  
4 20     20   81 use warnings;
  20         20  
  20         495  
5 20     20   81 use vars qw($VERSION @ISA @EXPORT_OK);
  20         32  
  20         104788  
6             require Exporter; @ISA = qw(Exporter);
7             @EXPORT_OK = qw(ascii_to_sightly sightly_to_ascii
8             regex_print_sightly regex_eval_sightly clean_print_sightly
9             clean_eval_sightly regex_binmode_print_sightly
10             clean_binmode_print_sightly
11             get_eye_dir get_eye_shapes get_eye_string get_builtin_shapes
12             get_eye_properties get_eye_keywords find_eye_shapes
13             make_triangle make_siertri make_banner
14             border_shape invert_shape reflect_shape rotate_shape
15             reduce_shape expand_shape hjoin_shapes
16             pour_text pour_sightly sightly);
17             $VERSION = '1.62';
18             { # This table was generated by demo/gentable.pl.
19             my @C = (
20             q Z('!'^'!')Z,q Z('('^')')Z,q Z('<'^'>')Z,q Z('>'^'=')Z,
21             q Z('>'^':')Z,q Z('>'^';')Z,q Z('+'^'-')Z,q Z('*'^'-')Z,
22             q Z('+'^'#')Z,q Z('*'^'#')Z,q Z('!'^'+')Z,q Z('!'^'*')Z,
23             q Z('!'^'-')Z,q Z('!'^',')Z,q Z('!'^'/')Z,q Z('!'^'.')Z,
24             q Z('?'^'/')Z,q Z('<'^'-')Z,q Z('-'^'?')Z,q Z('.'^'=')Z,
25             q Z('+'^'?')Z,q Z('*'^'?')Z,q Z('?'^')')Z,q Z('<'^'+')Z,
26             q Z('%'^'=')Z,q Z('&'^'?')Z,q Z('?'^'%')Z,q Z('>'^'%')Z,
27             q Z('&'^':')Z,q Z('<'^'!')Z,q Z('?'^'!')Z,q Z('%'^':')Z,
28             q Z('{'^'[')Z,q Z'!'Z,q Z'\\\\'.'"'Z,q Z'#'Z,
29             q Z'\\\\'.'$'Z,q Z'%'Z,q Z'&'Z,q Z"'"Z,q Z'('Z,q Z')'Z,
30             q Z'*'Z,q Z'+'Z,q Z','Z,q Z'-'Z,q Z'.'Z,q Z'/'Z,
31             q Z('^'^('`'|'.'))Z,q Z('^'^('`'|'/'))Z,q Z('^'^('`'|','))Z,
32             q Z('^'^('`'|'-'))Z,q Z('^'^('`'|'*'))Z,q Z('^'^('`'|'+'))Z,
33             q Z('^'^('`'|'('))Z,q Z('^'^('`'|')'))Z,q Z(':'&'=')Z,
34             q Z(';'&'=')Z,q Z':'Z,q Z';'Z,q Z'<'Z,q Z'='Z,q Z'>'Z,q Z'?'Z,
35             q Z'\\\\'.'@'Z,q Z('`'^'!')Z,q Z('`'^'"')Z,q Z('`'^'#')Z,
36             q Z('`'^'$')Z,q Z('`'^'%')Z,q Z('`'^'&')Z,q Z('`'^"'")Z,
37             q Z('`'^'(')Z,q Z('`'^')')Z,q Z('`'^'*')Z,q Z('`'^'+')Z,
38             q Z('`'^',')Z,q Z('`'^'-')Z,q Z('`'^'.')Z,q Z('`'^'/')Z,
39             q Z('{'^'+')Z,q Z('{'^'*')Z,q Z('{'^')')Z,q Z('{'^'(')Z,
40             q Z('{'^'/')Z,q Z('{'^'.')Z,q Z('{'^'-')Z,q Z('{'^',')Z,
41             q Z('{'^'#')Z,q Z('{'^'"')Z,q Z('{'^'!')Z,q Z'['Z,
42             q Z'\\\\'.'\\\\'Z,q Z']'Z,q Z'^'Z,q Z'_'Z,
43             q Z'`'Z,q Z('`'|'!')Z,q Z('`'|'"')Z,q Z('`'|'#')Z,
44             q Z('`'|'$')Z,q Z('`'|'%')Z,q Z('`'|'&')Z,q Z('`'|"'")Z,
45             q Z('`'|'(')Z,q Z('`'|')')Z,q Z('`'|'*')Z,q Z('`'|'+')Z,
46             q Z('`'|',')Z,q Z('`'|'-')Z,q Z('`'|'.')Z,q Z('`'|'/')Z,
47             q Z('['^'+')Z,q Z('['^'*')Z,q Z('['^')')Z,q Z('['^'(')Z,
48             q Z('['^'/')Z,q Z('['^'.')Z,q Z('['^'-')Z,q Z('['^',')Z,
49             q Z('['^'#')Z,q Z('['^'"')Z,q Z('['^'!')Z,q Z'\\\\'.'{'Z,
50             q Z'|'Z,q Z'\\\\'.'}'Z,q Z'~'Z,q Z('!'^'^')Z
51             );
52             push @C, map(join('.', q#'\\\\'#, $C[120],
53             map($C[$_], unpack('C*', sprintf('%x', $_)))), 128..255);
54 162     162 1 5775 sub ascii_to_sightly { join '.', map($C[$_], unpack('C*', $_[0])) }
55             }
56 8     8 1 5561 sub sightly_to_ascii { eval eval q#'"'.# . $_[0] . q#.'"'# }
57              
58             sub regex_print_sightly {
59 4     4 1 32 q#''=~('('.'?'.'{'.# . ascii_to_sightly('print') . q#.'"'.# .
60             &ascii_to_sightly . q#.'"'.'}'.')')#;
61             }
62              
63             sub regex_binmode_print_sightly {
64 1     1 1 6 q#''=~('('.'?'.'{'.# . ascii_to_sightly('binmode(STDOUT);print')
65             . q#.'"'.# . &ascii_to_sightly . q#.'"'.'}'.')')#;
66             }
67              
68             sub regex_eval_sightly {
69 68     68 1 566 q#''=~('('.'?'.'{'.# . ascii_to_sightly('eval') . q#.'"'.# .
70             &ascii_to_sightly . q#.'"'.'}'.')')#;
71             }
72              
73             sub clean_print_sightly {
74 1     1 1 7 qq#print eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
75             }
76              
77             sub clean_binmode_print_sightly {
78 2     2 1 10 qq#binmode(STDOUT);print eval '"'.\n\n\n# .
79             &ascii_to_sightly . q#.'"'#;
80             }
81              
82             sub clean_eval_sightly {
83 5     5 1 14 qq#eval eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
84             }
85              
86             # -----------------------------------------------------------------
87              
88             sub _slurp_tfile {
89 307     307   6722 my $f = shift;
90 307         247 my $b = shift;
91 307 100       8942 open my $fh, '<', $f or die "open '$f': $!";
92 304 100       481 $b and binmode($fh);
93 304         860 local $/; my $s = <$fh>; close($fh); $s;
  304         3472  
  304         1312  
  304         1668  
94             }
95              
96             # Poor man's properties (see also YAML, java.util.Properties).
97             # Return ref to property hash.
98             sub _get_properties {
99 619     619   1226 my $f = shift;
100 619 100       11879 open my $fh, '<', $f or die "open '$f': $!";
101 618         470 my $l; my %h;
102 618         3123 while (defined($l = <$fh>)) {
103 1359         1063 chomp($l);
104 1359 100       2202 if ($l =~ s/\\$//) {
105 92         112 my $n = <$fh>; $n =~ s/^\s+//; $l .= $n;
  92         177  
  92         116  
106 92 100       195 redo unless eof($fh);
107             }
108 1280         1556 $l =~ s/^\s+//; $l =~ s/\s+$//;
  1280         1912  
109 1280 100       1552 next unless length($l);
110 1272 100       1610 next if $l =~ /^#/;
111 1259         3604 my ($k, $v) = split(/\s*:\s*/, $l, 2);
112 1259         4009 $h{$k} = $v;
113             }
114 618         2370 close($fh);
115 618         1945 return \%h;
116             }
117              
118 1     1   17 sub _def_ihandler { print STDERR $_[0] }
119              
120             # Return largest no. of tokens with total length less than $slen ($slen > 0).
121             sub _guess_ntok {
122 12321     12321   10320 my ($rtok, $sidx, $slen, $rexact) = @_; my $tlen = 0;
  12321         7858  
123 12321         11787 for my $i ($sidx .. $sidx + $slen) {
124 12321         16482 ($tlen += length($rtok->[$i])) < $slen or
125 100545 100       130580 return $i - $sidx + (${$rexact} = $tlen == $slen);
126             }
127             # should never get here
128             }
129              
130             sub _guess_compact_ntok {
131 2182     2182   1769 my ($rtok, $sidx, $slen, $rexact, $fcompact) = @_; my $tlen = 0;
  2182         1380  
132 2182         2567 for my $i ($sidx .. $sidx + $slen + $slen) {
133 573         897 ($tlen += length($rtok->[$i]) - ($i > $sidx+1 && $rtok->[$i-1] eq '.'
134             && substr($rtok->[$i], 0, 1) eq "'" && substr($rtok->[$i-2], 0, 1)
135 1351         6009 eq "'" ? (${$fcompact} = 3) : 0)) < $slen or
136 56         124 return $i - $sidx + ($tlen > $slen ? 0 : (${$rexact} = 1) +
137             ($i > $sidx && $rtok->[$i] eq '.' && substr($rtok->[$i-1], 0, 1)
138 18840 100 100     73009 eq "'" && $rtok->[$i+1] =~ /^'..$/ ? (${$fcompact} = 1) : 0));
    100 100        
    100          
    100          
139             }
140             # should never get here
141             }
142              
143             sub _compact_join {
144 167     167   180 my ($rtok, $sidx, $n) = @_; my $s = "";
  167         157  
145 167         210 for my $i ($sidx .. $sidx + $n - 1) {
146 3311 100 100     11220 if ($i > $sidx+1 && $rtok->[$i-1] eq '.' && substr($rtok->[$i], 0, 1)
      100        
      100        
147             eq "'" && substr($rtok->[$i-2], 0, 1) eq "'") {
148 433         490 substr($s, -2) = substr($rtok->[$i], 1); # 'a'.'b' to 'ab'
149             } else {
150 2878         2629 $s .= $rtok->[$i];
151             }
152             }
153 167         315 $s;
154             }
155              
156             # Pour $n tokens from @{$rtok} (starting at index $sidx) into string
157             # of length $slen. Return string or undef if unsuccessful.
158             sub _pour_chunk {
159 6364     6364   5181 my ($rtok, $sidx, $n, $slen) = @_;
160 6364         5015 my $eidx = $sidx + $n - 1; my $tlen = 0;
  6364         4046  
161 6364         5043 my $idot = my $iquote = my $i3quote = my $iparen = my $idollar = -1;
162 6364         5901 for my $i ($sidx .. $eidx) {
163 42363         29674 $tlen += length($rtok->[$i]);
164 42363 100       106989 if ($rtok->[$i] eq '.') { $idot = $i }
  5450 100       4557  
    100          
    100          
165 3739         3529 elsif ($rtok->[$i] eq '(') { $iparen = $i }
166 2950         2358 elsif (substr($rtok->[$i], 0, 1) eq '$') { $idollar = $i }
167             elsif ($rtok->[$i] =~ /^['"]/) {
168 12666 100       8116 $iquote = $i; $i3quote = $i if length($rtok->[$i]) == 3;
  12666         18239  
169             }
170             }
171 6364 50       8974 die "oops" if $tlen >= $slen;
172 6364         5201 my $i2 = (my $d = $slen - $tlen) >> 1;
173 234         516 $idot >= 0 && !($d%3) and return join("", @{$rtok}[$sidx .. $idot-1],
  234         813  
174 6364 100 100     12642 ".''" x int($d/3), @{$rtok}[$idot .. $eidx]);
175 6130 100 100     12018 if (!($d&1) and $iquote >= 0 || $idollar >= 0) {
      66        
176 1709 100       2205 $iquote = $idollar if $iquote < 0;
177 1709         3398 return join("", @{$rtok}[$sidx .. $iquote-1], '(' x $i2 .
  1709         6234  
178 1709         2029 $rtok->[$iquote] . ')' x $i2, @{$rtok}[$iquote+1 .. $eidx]);
179             }
180 2330         5024 $i3quote >= 0 and return join("", @{$rtok}[$sidx .. $i3quote-1],
  2330         8470  
181             $d == 1 ? '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' :
182             '(' x $i2 . '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' .
183 4421 50       6321 ')' x $i2, @{$rtok}[$i3quote+1 .. $eidx]);
    100          
184 2091 100       5274 return unless $d == 1;
185 513         767 $iparen >= 0 and return join("", @{$rtok}[$sidx .. $iparen-1],
  513         1700  
186 1204 100       1751 '+' . $rtok->[$iparen], @{$rtok}[$iparen+1 .. $eidx]);
187             # ouch, can't test for eq '(' in case next chunk also adds '+'
188 322         1159 $rtok->[$eidx] ne '=' && $rtok->[$sidx+$n] =~ /^['"]/ ?
189 691 100 100     3944 join("", @{$rtok}[$sidx .. $eidx], '+') : undef;
190             }
191              
192             sub _pour_compact_chunk {
193 72     72   74 my ($rtok, $sidx, $n, $slen) = @_; my @mytok;
  72         51  
194 72         126 for my $i ($sidx .. $sidx + $n - 1) {
195 1962 100 100     6732 if ($i > $sidx+1 && $rtok->[$i-1] eq '.' && substr($rtok->[$i], 0, 1)
      100        
      100        
196             eq "'" && substr($rtok->[$i-2], 0, 1) eq "'") {
197 196         127 pop(@mytok); my $qtok = pop(@mytok); # 'a'.'b' to 'ab'
  196         170  
198 196         284 push(@mytok, substr($qtok, 0, -1) . substr($rtok->[$i], 1));
199             } else {
200 1766         1980 push(@mytok, $rtok->[$i]);
201             }
202             }
203 72         92 push(@mytok, $rtok->[$sidx+$n]); # _pour_chunk checks next token
204 72         173 _pour_chunk(\@mytok, 0, $#mytok, $slen);
205             }
206              
207             # Pour unsightly text $txt into shape defined by string $tlines.
208             sub pour_text {
209 35     35 1 2458 my ($tlines, $txt, $gap, $tfill) = @_;
210 35         87 $txt =~ s/\s+//g;
211 35         52 my $ttlen = 0; my $txtend = length($txt);
  35         36  
212 35 100       1164 my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
213             split(/\n/, $tlines));
214 35         92 for my $r (grep($_, @tnlines)) {
215 232 100       156 for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
  232         666  
  1570         2036  
216             }
217 35         63 my $nshape = int($txtend/$ttlen); my $rem = $txtend % $ttlen;
  35         50  
218 35 100 100     105 if ($rem || !$nshape) {
219 29         27 ++$nshape;
220 29 100       109 $txt .= $tfill x (int(($ttlen-$rem)/length($tfill))+1)
221             if length($tfill);
222             }
223 35         38 my $s = ""; my $p = 0;
  35         29  
224 35         30 for (my $n = 1; 1; ++$n, $s .= "\n" x $gap) {
225 43         44 for my $r (@tnlines) {
226 234 100       281 if ($r) {
227 231         154 for my $i (0 .. $#{$r}) {
  231         277  
228 1514 100       1323 if ($i & 1) {
229 757         636 $s .= substr($txt, $p, $r->[$i]); $p += $r->[$i];
  757         534  
230 757 100 100     1379 return "$s\n" if !length($tfill) && $p >= $txtend;
231             } else {
232 757         802 $s .= ' ' x $r->[$i];
233             }
234             }
235             }
236 223         266 $s .= "\n";
237             }
238 32 100       68 last if $n >= $nshape;
239             }
240 24         637 $s;
241             }
242              
243             # Make filler code to stuff on end of program to fill last shape.
244             sub _make_filler {
245 91     91   219 my $fv = shift; # list reference of filler variables
246 91         143 my $nfv = @{$fv};
  91         162  
247             # Beware with these filler values.
248             # Avoid $; $" ';' (to avoid clash with " and ; in later parsing).
249             # END block is trouble because it is executed after this filler.
250             # Setting $^ or $~ (but not $:) to weird values resets $@.
251             # For example: $~='?'&'!'; (this looks like a Perl bug to me).
252             # For now, just stick with letters and numbers.
253 91         1440 my @filleqto = (
254             [ q#'.'#, '^', q^'~'^ ], [ q#'@'#, '|', q^'('^ ],
255             [ q#')'#, '^', q^'['^ ], [ q#'`'#, '|', q^'.'^ ],
256             [ q#'('#, '^', q^'}'^ ], [ q#'`'#, '|', q^'!'^ ],
257             [ q#')'#, '^', q^'}'^ ], [ q#'*'#, '|', q^'`'^ ],
258             [ q#'+'#, '^', q^'_'^ ], [ q#'&'#, '|', q^'@'^ ],
259             [ q#'['#, '&', q^'~'^ ], [ q#','#, '^', q^'|'^ ]
260             );
261 91 100       268 $nfv > @filleqto and die "too many fv";
262 90         176 my $rem = @filleqto % $nfv;
263 90 100       538 $rem and splice(@filleqto, -$rem);
264 90         104 my $v = -1;
265 90         268 map(($fv->[++$v % $nfv], '=', @{$_}, ';'), @filleqto);
  1078         2454  
266             }
267              
268             # Pour sightly program $prog into shape defined by string $tlines.
269             sub pour_sightly {
270 88     88 1 242 my ($tlines, $prog, $gap, $fillv, $compact, $ihandler) = @_;
271 88   100     234 $ihandler ||= \&_def_ihandler;
272 88         119 my $ttlen = 0;
273 88 100       19879 my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
274             split(/\n/, $tlines));
275 88         770 for my $r (grep($_, @tnlines)) {
276 4403 100       2607 for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
  4403         4561  
  23365         31031  
277             }
278 88         244 my $outstr = ""; my @ptok;
  88         415  
279 88 100       184 if ($prog) {
280 79 100       556 if ($prog =~ /^''=~/g) {
    100          
281 69 50       775 push(@ptok, ($tlines =~ /(\S+)/ ? length($1) : 0) == 3 ?
    100          
282             "'?'" : "''", '=~');
283             } elsif ($prog =~ /(.*eval.*\n\n\n)/g) {
284 7         30 $outstr .= $1;
285             }
286 79         27775 push(@ptok, $prog =~ /[().&|^]|'\\\\'|.../g); # ... is "'"|'.'
287             }
288 88         1403 my $iendprog = @ptok;
289 88 100       507 my @filler = _make_filler(ref($fillv) ? $fillv : [ '$:', '$~', '$^' ]);
290             # Note: 11 is the length of a filler item, for example, $:='.'^'~';
291             # And there are 6 tokens in each filler item: $: = '.' ^ '~' ;
292 88         6584 push(@ptok, 'Z', (@filler) x (int($ttlen/(11 * int(@filler / 6))) + 1));
293 88         133 my $sidx = 0;
294 88         1097 for (my $nshape = 1; 1; ++$nshape, $outstr .= "\n" x $gap) {
295 171         251 for my $rline (@tnlines) {
296 7775 100       9998 unless ($rline) { $outstr .= "\n"; next }
  204         156  
  204         138  
297 7571         5075 for my $it (0 .. $#{$rline}) {
  7571         9405  
298 40945 100       47062 unless ($it & 1) {$outstr .= ' ' x $rline->[$it]; next }
  20540         20572  
  20540         15300  
299 20405 100       31608 (my $tlen = $rline->[$it]) == (my $plen = length($ptok[$sidx]))
300             and $outstr .= $ptok[$sidx++], next;
301 17606 100       20301 if ($plen > $tlen) {
302 3103         2467 $outstr .= '(' x $tlen;
303 3103         10234 splice(@ptok, $sidx+1, 0, (')') x $tlen);
304 3103 100       4144 $iendprog += $tlen if $sidx < $iendprog;
305 3103         3374 next;
306             }
307 14503         10281 my $fcompact = my $fexact = 0;
308 14503 100       23797 my $n = $compact ?
309             _guess_compact_ntok(\@ptok, $sidx, $tlen, \$fexact, \$fcompact)
310             : _guess_ntok(\@ptok, $sidx, $tlen, \$fexact);
311 14503 100       19020 if ($fexact) {
312 8576 100       17927 $outstr .= $fcompact ? _compact_join(\@ptok, $sidx, $n) :
313             join("", @ptok[$sidx .. $sidx+$n-1]);
314 8576         6699 $sidx += $n; next;
  8576         9174  
315             }
316 5927         3774 my $str;
317 5927 100 100     13990 --$n while $n > 0 && !defined($str = $fcompact ?
318             _pour_compact_chunk(\@ptok, $sidx, $n, $tlen) :
319             _pour_chunk(\@ptok, $sidx, $n, $tlen));
320 5927 100       8690 if ($n) { $outstr .= $str; $sidx += $n; next }
  5108         3863  
  5108         3460  
  5108         5863  
321 819   66     4379 ++$n while $n < $tlen && length($ptok[$sidx+$n]) < 2;
322 819 50       1037 die "oops ($n >= $tlen)" if $n >= $tlen;
323 819         1241 $outstr .= join("", @ptok[$sidx .. $sidx+$n-1]);
324 819         664 $sidx += $n;
325 819         902 $outstr .= '(' x (my $nleft = $tlen - $n);
326 819         3802 splice(@ptok, $sidx+1, 0, (')') x $nleft);
327 819 100       1467 $iendprog += $nleft if $sidx < $iendprog;
328             }
329 7571         8372 $outstr .= "\n";
330             }
331 171         876 $ihandler->("$nshape shapes completed.\n");
332 170 100       1146 last if $sidx >= $iendprog;
333             }
334 87         384 my $eidx = rindex($outstr, 'Z');
335 87 100       246 substr($outstr, $eidx, 1) = ';' if $eidx >= 0;
336 87 100 100     612 return $outstr if $sidx == $iendprog || $sidx == $iendprog+1;
337 83 50       186 die "oops" if $eidx < 0;
338 83 100       712 ref($fillv) or return substr($outstr, 0, $eidx) . (length($fillv) ?
    100          
339             pour_text(substr($outstr, $eidx), "", 0, $fillv) : "\n");
340 73 50       262 (my $idx = rindex($outstr, ';')) >= 0 or return $outstr;
341 73 100       1353 my @t = substr($outstr, $idx+1) =~
342             /[()&|^=;]|\$.|'[^'\\]*(?:\\.[^'\\]*)*'|"[^"\\]*(?:\\.[^"\\]*)*"/g
343             or return $outstr;
344 70         127 my $nl = my $nr = my $ne = 0;
345 70         122 for my $c (@t) {
346 405 100       807 if ($c eq '(') {++$nl} elsif ($c eq ')') {++$nr}
  110 100       90  
  60 100       55  
  62         76  
347             elsif ($c eq '=') {++$ne}
348             }
349 70 100 100     770 if ($ne == 0 || $nl != $nr || $t[-1] eq '=') {
    100 100        
      100        
      100        
350 29         46 my $f = ';'; # Trouble: wipe out last bit with filler
351 29         74 for my $i ($idx+1 .. length($outstr)-2) {
352 2092 100       2890 substr($outstr, $i, 1) =~ tr/ \n// or
    100          
353             substr($outstr, $i, 1) = $f = $f eq '#' ? ';' : '#';
354             }
355             } elsif ($t[-1] eq '|' or $t[-1] eq '^' or $t[-1] eq '&') {
356 23         11519 $outstr =~ s/\S(\s*)$/;$1/;
357             }
358 70         8082 $outstr;
359             }
360              
361             # -----------------------------------------------------------------
362              
363             sub _border {
364 9     9   15 my ($a, $w, $c, $l, $r, $t, $b) = @_;
365 9         23 my $z = $c x ($w+$l+$r); my $f = $c x $l; my $g = $c x $r;
  9         11  
  9         10  
366 9         7 for (@{$a}) { $_ = $f . $_ . $g }
  9         17  
  531         437  
367 9         12 unshift(@{$a}, ($z) x $t); push(@{$a}, ($z) x $b);
  9         38  
  9         9  
  9         19  
368             }
369              
370             sub border_shape {
371 6     6 1 23 my ($tlines, $gl, $gr, $gt, $gb, $wl, $wr, $wt, $wb) = @_;
372 6         122 my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
  6         31  
  6         9  
373 6 100       16 for my $l (@a) { $m = length($l) if length($l) > $m }
  350         458  
374 6         17 for my $l (@a) { $l .= ' ' x ($m - length($l)) }
  350         314  
375 6 50 66     48 $gl || $gr || $gt || $gb and _border(\@a, $m, ' ', $gl, $gr, $gt, $gb);
      66        
      33        
376 6 50 66     43 $wl || $wr || $wt || $wb and _border(\@a, $m+$gl+$gr,'#',$wl,$wr,$wt,$wb);
      66        
      33        
377 6         72 join("\n", @a, "");
378             }
379              
380             sub invert_shape {
381 2     2 1 7 my $tlines = shift;
382 2         38 my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
  2         29  
  2         5  
383 2 100       6 for my $l (@a) { $m = length($l) if length($l) > $m }
  97         194  
384 2         7 for my $l (@a) { $l .= ' ' x ($m - length($l)) }
  97         132  
385 2         21 my $s = join("\n", @a, ""); $s =~ tr/ #/# /;
  2         11  
386 2         109 $s =~ s/ +$//mg; $s;
  2         9  
387             }
388              
389             sub reflect_shape {
390 5     5 1 14 my $tlines = shift;
391 5         88 my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
  5         27  
  5         8  
392 5 100       9 for my $l (@a) { $m = length($l) if length($l) > $m }
  279         349  
393 5         256 my $s = join("\n", map(scalar reverse($_ . ' ' x ($m - length)), @a), "");
394 5         345 $s =~ s/ +$//mg; $s;
  5         26  
395             }
396              
397             sub hjoin_shapes {
398 2     2 1 12 my ($g, @shapes) = @_;
399 2         2 my $ml = 0; my @lines;
  2         2  
400 2 100       3 for my $s (@shapes) { my $n = $s =~ tr/\n//; $ml = $n if $n > $ml }
  4         10  
  4         9  
401 2         4 for my $tlines (@shapes) {
402 4         25 my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
  4         11  
  4         4  
403 4 100       4 for my $l (@a) { $m = length($l) if length($l) > $m }
  99         134  
404 4         5 for my $l (@a) { $l .= ' ' x ($m - length($l) + $g) }
  99         92  
405 4         9 push(@a, (' ' x ($m + $g)) x ($ml - @a));
406 4         7 for my $i (0..$#a) { $lines[$i] .= $a[$i] }
  100         104  
407             }
408 2         352 my $s = join("\n", @lines, "");
409 2         129 $s =~ s/ +$//mg; $s;
  2         12  
410             }
411              
412             sub reduce_shape {
413 3     3 1 7 my ($tlines, $f) = @_; my $i = $f++; my $s = "";
  3         7  
  3         6  
414 3         100 for my $l (grep(!(++$i%$f), split(/\n/, $tlines))) {
415 105         138 for ($i = 0; $i < length($l); $i += $f) { $s .= substr($l, $i, 1) }
  4927         5615  
416 105         110 $s .= "\n";
417             }
418 3         94 $s =~ s/ +$//mg; $s;
  3         12  
419             }
420              
421             sub expand_shape {
422 3     3 1 7 my ($s, $f) = @_; my $i = ' ' x ++$f; my $j = '#' x $f;
  3         9  
  3         8  
423 3         400 $s =~ s/ /$i/g; $s =~ s/#/$j/g; my $t = "";
  3         585  
  3         8  
424 3         47 for my $l (split(/^/, $s, -1)) { $t .= $l x $f } $t;
  141         162  
  3         41  
425             }
426              
427             # Rotate shape clockwise: 90, 180 or 270 degrees
428             # (other angles are left as an exercise for the reader:-)
429             sub rotate_shape {
430 14     14 1 29 my ($tlines, $degrees, $rtype, $flip) = @_;
431 14 100       101 $degrees == 180 and
432             return join("\n", reverse(split(/\n/, $tlines)), "");
433 11 100       30 my $t = $rtype==0 ? 2 : 1; my $inc = $rtype==1 ? 2 : 1;
  11 100       28  
434 11         259 my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0; my $s = "";
  11         54  
  11         15  
  11         23  
435 11 100       21 for my $l (@a) { $m = length($l) if length($l) > $m }
  536         953  
436 11         21 for my $l (@a) { $l .= ' ' x ($m - length($l)) }
  536         574  
437 11 100       41 if ($degrees == 90) {
    50          
438 7 100       19 @a = reverse(@a) unless $flip;
439 7         20 for (my $i = 0; $i < $m; $i += $inc) {
440 423         309 for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
  19881         15467  
  423         637  
441             }
442             } elsif ($degrees == 270) {
443 4 100       14 @a = reverse(@a) if $flip;
444 4         17 for (my $i = $m-1; $i >= 0; $i -= $inc) {
445 289         277 for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
  15369         12111  
  289         472  
446             }
447             }
448 11         1048 $s =~ s/ +$//mg; $s;
  11         83  
449             }
450              
451             sub make_triangle {
452 5 100   5 1 261 my $w = shift; $w & 1 or ++$w; $w < 9 and $w = 9;
  5 100       22  
  5         14  
453 5         8 my $n = $w >> 1; my $s;
  5         21  
454 5         13 for (my $i=1;$i<=$w;$i+=2) { $s .= ' ' x $n-- . '#' x $i . "\n" }
  73         131  
455 5         44 $s;
456             }
457              
458             sub make_siertri {
459 8 100   8 1 488 my $w = shift; $w < 3 and $w = 5; my $n = 2 ** $w; my $s;
  8         26  
  8         12  
  8         6  
460 8         23 for my $i (0 .. $n-1) {
461 256 100       129 --$n; $s .= ' ' x $n .
  256         2370  
462             join('', map($n & $_ ? ' ' : '##', 0 .. $i)) . "\n";
463 8         52 } $s;
464             }
465              
466             sub make_banner {
467 1     1 1 93 my ($w, $src) = @_;
468             # Linux /usr/games/banner can be used.
469             # CPAN Text::Banner will hopefully be enhanced so it can be used too.
470 1         2 my $b_exe = '/usr/games/banner';
471 1 50       15 -x $b_exe or die "'$b_exe' not available on this platform.";
472 0 0       0 my $f = $w ? "-w $w" : ""; $src =~ s/\s+/ /g; $src =~ s/ $//;
  0         0  
  0         0  
473             # Following characters not in /usr/games/banner character set:
474             # \ [ ] { } < > ^ _ | ~
475             # Also must escape ' from the shell.
476 0         0 $src =~ tr#_\\[]{}<>^|~'`#-/()()()H!T""#;
477 0         0 my $s = ""; my $len = length($src);
  0         0  
478 0         0 for (my $i = 0; $i < $len; $i += 512) {
479 0         0 my $cmd = "$b_exe $f '" . substr($src, $i, 512) . "'";
480 0 0       0 $s .= `$cmd`; my $rc = $? >> 8; $rc and die "<$cmd>: rc=$rc";
  0         0  
  0         0  
481             }
482 0         0 $s =~ s/\s+$/\n/; $s =~ s/ +$//mg;
  0         0  
483             # Remove as many leading spaces as possible.
484 0         0 my $m = 32000; # regex /^ {$m}/ blows up if $m > 32766
485 0 0       0 while ($s =~ /^( *)\S/mg) { $m = length($1) if length($1) < $m }
  0         0  
486 0 0       0 $s =~ s/^ {$m}//mg if $m; $s;
  0         0  
487             }
488              
489             # -------------------------------------------------------------------------
490              
491             sub _bi_all {
492 2     2   14 join "\n" x $_[0]->{Width},
493             map(_get_eye_string($_[0]->{EyeDir}, $_), _get_eye_shapes($_[0]->{EyeDir}))
494             }
495 1     1   9 sub _bi_triangle { make_triangle($_[0]->{Width}) }
496 3     3   13 sub _bi_siertri { make_siertri($_[0]->{Width}) }
497 0     0   0 sub _bi_banner { make_banner($_[0]->{Width}, $_[0]->{BannerString}) }
498 0     0   0 sub _bi_srcbanner { make_banner($_[0]->{Width}, $_[0]->{SourceString}) }
499              
500             {
501             my %builtin_shapes = (
502             'all' => \&_bi_all,
503             'triangle' => \&_bi_triangle,
504             'siertri' => \&_bi_siertri,
505             'banner' => \&_bi_banner,
506             'srcbanner' => \&_bi_srcbanner
507             );
508 1     1 1 144 sub get_builtin_shapes { sort keys %builtin_shapes }
509             # Return built-in shape string or undef if invalid shape.
510             sub _get_builtin_string {
511 74     74   140 my $shape = shift;
512 74 100       840 return unless exists($builtin_shapes{$shape});
513 6         26 $builtin_shapes{$shape}->(shift);
514             }
515             }
516              
517             sub sightly {
518 98     98 1 644895 my $ruarg = shift; my %arg = (
  98         867  
519             Shape => "", ShapeString => "",
520             SourceFile => "", SourceString => "",
521             SourceHandle => undef, InformHandler => undef,
522             Width => 0, BannerString => "",
523             Text => 0, TextFiller => "",
524             Regex => 0, Compact => 0,
525             Print => 0, Binary => 0,
526             Gap => 0, Rotate => 0,
527             RotateType => 0, RotateFlip => 0,
528             Reflect => 0, Reduce => 0,
529             Expand => 0, Invert => 0,
530             TrailingSpaces => 0, RemoveNewlines => 0,
531             Indent => 0, BorderGap => 0,
532             BorderGapLeft => 0, BorderGapRight => 0,
533             BorderGapTop => 0, BorderGapBottom => 0,
534             BorderWidth => 0, BorderWidthLeft => 0,
535             BorderWidthRight => 0, BorderWidthTop => 0,
536             BorderWidthBottom => 0, TrapEvalDie => 0,
537             TrapWarn => 0, FillerVar => [],
538             EyeDir => get_eye_dir()
539             );
540 98         172 for my $k (keys %{$ruarg}) {
  98         512  
541 439 100       747 exists($arg{$k}) or die "invalid parameter '$k'";
542 438         695 $arg{$k} = $ruarg->{$k};
543             }
544 97 100 100     516 length($arg{SourceFile}) && $arg{SourceHandle} and
545             die "cannot specify both SourceFile and SourceHandle";
546 96 100 100     405 length($arg{SourceFile}) && length($arg{SourceString}) and
547             die "cannot specify both SourceFile and SourceString";
548 95 100 100     586 length($arg{SourceString}) && $arg{SourceHandle} and
549             die "cannot specify both SourceString and SourceHandle";
550 94 100 100     489 $arg{Shape} && $arg{ShapeString} and
551             die "cannot specify both Shape and ShapeString";
552 93 100       487 if (length($arg{SourceFile})) {
    100          
553 12         81 $arg{SourceString} = _slurp_tfile($arg{SourceFile}, $arg{Binary});
554             } elsif ($arg{SourceHandle}) {
555 5         30 local $/; $arg{SourceString} = readline($arg{SourceHandle});
  5         137  
556             }
557 92         179 my $fill = $arg{FillerVar};
558 92 100 100     651 if (ref($fill) && !$arg{Text}) {
559             # Non-rigourous check for module (package) or END block.
560 79 100 100     86 @{$fill} or $fill = ($arg{SourceString} =~ /^\s*END\b/m or
  79 50       1016  
561             $arg{SourceString} =~ /^\s*package\b/m) ?
562             [ '$:', '$~', '$^' ] :
563             [ '$:', '$~', '$^', '$/', '$,', '$\\' ];
564             }
565 92 100       269 $arg{RemoveNewlines} and $arg{SourceString} =~ tr/\n//d;
566 92         166 my $shape = my $sightly = "";
567 92 50 100     1052 length($arg{SourceString}) && !$arg{Text} and $sightly = $arg{Print} ?
    100          
    100          
    100          
    100          
    100          
568             ( $arg{Regex} ? ( $arg{Binary} ?
569             regex_binmode_print_sightly($arg{SourceString}) :
570             regex_print_sightly($arg{SourceString}) ) :
571             ( $arg{Binary} ?
572             clean_binmode_print_sightly($arg{SourceString}) :
573             clean_print_sightly($arg{SourceString}) ) ) :
574             ( $arg{Regex} ? regex_eval_sightly($arg{SourceString}) :
575             clean_eval_sightly($arg{SourceString}) );
576 92 100       867 if ($arg{ShapeString}) {
    100          
    100          
577 19         37 $shape = $arg{ShapeString};
578             } elsif ($arg{Shape}) {
579 61   66     485 $shape = join("\n" x $arg{Gap},
580             map(_get_builtin_string($_, \%arg) ||
581             (m#[./]# ? _slurp_tfile($_) : _get_eye_string($arg{EyeDir}, $_)),
582             split(/,/, $arg{Shape})));
583             } elsif ($arg{Width}) {
584 11 100 100     133 die "invalid width $arg{Width} (must be > 3)"
585             if !$arg{Text} && $arg{Width} < 4;
586 10         38 $shape = '#' x $arg{Width};
587             }
588 90 100 33     280 $shape or return "use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) . $sightly;
589 89 100       317 $arg{Rotate} and $shape = rotate_shape($shape, $arg{Rotate},
590             $arg{RotateType}, $arg{RotateFlip});
591 89 100       223 $arg{Reflect} and $shape = reflect_shape($shape);
592 89 100       232 $arg{Reduce} and $shape = reduce_shape($shape, $arg{Reduce});
593 89 100       225 $arg{Expand} and $shape = expand_shape($shape, $arg{Expand});
594 89 100       223 $arg{Invert} and $shape = invert_shape($shape);
595 89 50 100     2489 $arg{TrailingSpaces} ||
      100        
      100        
      100        
      100        
      100        
      100        
      100        
      100        
      66        
      100        
      66        
      66        
      33        
      33        
      33        
      33        
      33        
596             $arg{BorderGap} || $arg{BorderWidth} ||
597             $arg{BorderGapLeft} || $arg{BorderWidthLeft} ||
598             $arg{BorderGapRight} || $arg{BorderWidthRight} ||
599             $arg{BorderGapTop} || $arg{BorderWidthTop} ||
600             $arg{BorderGapBottom} || $arg{BorderWidthBottom} and
601             $shape = border_shape($shape,
602             $arg{BorderGapLeft} || $arg{BorderGap},
603             $arg{BorderGapRight} || $arg{BorderGap},
604             $arg{BorderGapTop} || $arg{BorderGap},
605             $arg{BorderGapBottom} || $arg{BorderGap},
606             $arg{BorderWidthLeft} || $arg{BorderWidth},
607             $arg{BorderWidthRight} || $arg{BorderWidth},
608             $arg{BorderWidthTop} || $arg{BorderWidth},
609             $arg{BorderWidthBottom} || $arg{BorderWidth});
610 89 100       220 if ($arg{Indent}) { my $s = ' ' x $arg{Indent}; $shape =~ s/^/$s/mg }
  1         5  
  1         43  
611             $arg{Text} and return
612 89 100       191 pour_text($shape, $arg{SourceString}, $arg{Gap}, $arg{TextFiller});
613 85   33     1098 "use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) .
614             'local $SIG{__WARN__}=sub{};' x $arg{TrapWarn} .
615             pour_sightly($shape, $sightly, $arg{Gap}, $fill, $arg{Compact},
616             $arg{InformHandler}) . "\n\n\n;die \$\@ if \$\@\n" x $arg{TrapEvalDie};
617             }
618              
619             # -------------------------------------------------------------------------
620              
621             sub _get_eye_shapes {
622 15     15   43 my $d = shift;
623 15 100       341 opendir my $dh, $d or die "opendir '$d': $!";
624 14         1498 my @e = sort map(/(.+)\.eye$/, readdir($dh));
625 14         212 closedir($dh); @e;
  14         137  
626             }
627              
628 190     190   647 sub _get_eye_string { _slurp_tfile($_[0] . '/' . $_[1] . '.eye') }
629              
630             sub _get_eye_properties {
631 618     618   965 my $f = $_[0] . '/' . $_[1] . '.eyp';
632 618 100       7586 -f $f or return;
633 613         690 _get_properties($f);
634             }
635              
636             sub _get_eye_keywords {
637 2     2   37 my $d = shift;
638 2         3 my %h;
639 2         3 SHAPE: for my $s (_get_eye_shapes($d)) {
640 105 100       122 my $p = _get_eye_properties($d, $s) or next SHAPE; # no properties
641 104 100       177 exists($p->{keywords}) or next SHAPE; # no keywords property
642 90 100       206 my @k = split(" ", $p->{keywords}) or next SHAPE; # no keywords
643 89         92 for my $k (@k) { push(@{$h{$k}}, $s) }
  137         88  
  137         312  
644             }
645 2         9 return \%h;
646             }
647              
648             sub _find_eye_shapes {
649 8     8   736 my $d = shift;
650 8 100       24 @_ or die "oops, no keywords given";
651 7         38 my @skey = map([split/\s+OR\s+/], @_);
652 7         7 my @ret;
653 7         12 SHAPE: for my $s (_get_eye_shapes($d)) {
654 413 100       505 my $p = _get_eye_properties($d, $s) or next SHAPE; # no properties
655 410 100       678 exists($p->{keywords}) or next SHAPE; # no keywords property
656 355 100       863 my @k = split(" ", $p->{keywords}) or next SHAPE; # no keywords
657 352         256 my %h; @h{@k} = ();
  352         497  
658 352         366 for my $k (@skey) {
659             # XXX: short-circuiting List::Util::first() better than grep here.
660 393 100       280 grep(exists($h{$_}), @{$k}) or next SHAPE; # AND, all must be true
  393         1539  
661             }
662 22         61 push(@ret, $s);
663             }
664 7         50 return @ret;
665             }
666              
667 3     3 1 44 sub get_eye_shapes { _get_eye_shapes(get_eye_dir()) }
668 120     120 1 35683 sub get_eye_string { _get_eye_string(get_eye_dir(), shift) }
669 99     99 1 1076 sub get_eye_properties { _get_eye_properties(get_eye_dir(), shift) }
670 1     1 1 350 sub get_eye_keywords { _get_eye_keywords(get_eye_dir()) }
671 5     5 1 153 sub find_eye_shapes { _find_eye_shapes(get_eye_dir(), @_) }
672              
673             # $eye_dir is the directory containing the .eye file shapes.
674             # Note: $eye_dir is only eval-hostile line in EyeDrops.pm; do not change it
675             # for t/19_surrounds.t and "EyeDropping EyeDrops.pm" section of doco relies
676             # on it. Remove ".pm" from "...Acme/EyeDrops.pm" giving directory name.
677             my $eye_dir = __FILE__; chop($eye_dir);chop($eye_dir);chop($eye_dir);
678              
679 1     1 1 13 sub slurp_yerself { _slurp_tfile($eye_dir . '.pm') }
680              
681 327     327 1 3420 sub get_eye_dir { $eye_dir }
682              
683             1;
684              
685             __END__