Acme-EyeDrops

 view release on metacpan or  search on metacpan

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

      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] =~ /^['"]/) {

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

   }
   $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 {

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

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

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

   $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) {

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

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

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

         $\='`'|                         '!';$:= ')'^'}';$~='*'|
          '`';$^                          ="\+"^  '_';$/='&'|'@';
           ($,)                            ='['    &'~';$\=','^'|'

=head2 Just another Perl hacker

Let's get more ambitious and create a big self-printing I<JAPH>.

    my $src = <<'FLAMING_OSTRICHES';
    open 0;
    $/ = undef;
    $x = <0>;
    close 0;
    $x =~ tr/!-~/#/;
    print $x;
    FLAMING_OSTRICHES
    print sightly( { Shape         => 'japh',
                     SourceString  => $src,
                     Regex         => 1 } );

This works. However, if we change:

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

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.

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

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

t/05_Parrot.t  view on Meta::CPAN

$outstr eq $srcstr or print "not ";
++$itest; print "ok $itest - binary file encode output\n";
$prog =~ tr/!-~/#/;
$prog eq $encodestr or print "not ";
++$itest; print "ok $itest - binary file encode shape\n";

# Self-printing JAPH -------------------------------

my $src = <<'PROG';
open 0;
$/ = undef;
$x = <0>;
close 0;
$x =~ tr/!-~/#/;
print $x;
PROG
$prog = sightly({ Shape         => 'japh',
                  SourceString  => $src,
                  InformHandler => sub {},
                  Regex         => 1 } );
build_file($tmpf, $prog);