view release on metacpan or  search on metacpan

lib/Acme/EyeDrops.pm  view on Meta::CPAN

}

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

lib/Acme/EyeDrops.pm  view on Meta::CPAN

   # 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 {