view release on metacpan or  search on metacpan

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

#!/usr/bin/perl
# 05_parrot.t (was sightly.t)

use strict;
use Acme::EyeDrops qw(sightly get_eye_string make_siertri make_triangle
                      regex_eval_sightly regex_binmode_print_sightly);

$|=1;

# --------------------------------------------------

sub build_file {
   my ($f, $d) = @_;
   local *F; open(F, '>'.$f) or die "open '$f': $!";
   print F $d or die "write '$f': $!"; close(F);
}

# --------------------------------------------------

print "1..75\n";

my $hellostr = <<'HELLO';
print "hello world\n";
HELLO
my $helloteststr = <<'HELLOTEST';
# Just a test.
use strict;
for my $i (0..3) {
   print "hello test $i\n";
}
HELLOTEST
my $hellofile = 'helloworld.pl';
my $camelstr = get_eye_string('camel');
my $larrystr = get_eye_string('larry');
my $damianstr = get_eye_string('damian');
my $umlstr = get_eye_string('uml');
my $windowstr = get_eye_string('window');
my $japhstr = get_eye_string('japh');
my $yanick4str = get_eye_string('yanick4');
my $siertristr = make_siertri(5);
my $baldprogstr = regex_eval_sightly($hellostr);
# XXX: regex_binmode_print_sightly seems dodgy, this call is just to
# improve code coverage. Investigate later.
my $dodgyprogstr = regex_binmode_print_sightly($hellostr);
my $tmpf = 'bill.tmp';
my $tmpeye = 'tmpeye.eye';
my $tmpeye2 = 'tmpeye2.eye';

build_file($hellofile, $hellostr);

# --------------------------------------------------

my $itest = 0;
my $prog;

sub test_one {
   my ($e, $ostr, $sh) = @_;
   build_file($tmpf, $prog);
   my $outstr = `$^X -Tw -Mstrict $tmpf`;
   my $rc = $? >> 8;
   $rc == 0 or print "not ";
   ++$itest; print "ok $itest - $e rc\n";
   $outstr eq $ostr or print "not ";
   ++$itest; print "ok $itest - $e output\n";
   $prog =~ s/^use re 'eval';\n// if $] >= 5.017;   # remove leading use re 'eval' line
   $prog =~ s/^.*eval.*\n\n\n//;
   $prog =~ tr/!-~/#/;
   $prog eq $sh or print "not ";
   ++$itest; print "ok $itest - $e shape\n";
}

# Camel helloworld.pl ------------------------------

$prog = sightly({ Shape         => 'camel',
                  SourceString  => $hellostr,
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('Camel helloworld', "hello world\n", $camelstr);

# uml/window helloworld.pl -------------------------

$prog = sightly({ Shape         => 'uml,window',
                  SourceString  => $hellostr,
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('uml/window helloworld', "hello world\n", $umlstr . $windowstr);

# uml/window helloworld.pl -------------------------

build_file($tmpeye, $umlstr);
build_file($tmpeye2, $windowstr);

$prog = sightly({ Shape         => 'all',
                  EyeDir        => '.',
                  SourceString  => $hellostr,
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('uml/window all helloworld', "hello world\n", $umlstr . $windowstr);

$prog = sightly({ Shape         => 'all',
                  EyeDir        => '.',
                  Width         => 2,
                  SourceString  => $hellostr,
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('uml/window all width helloworld', "hello world\n",
   $umlstr . "\n\n" . $windowstr);

# Text string print --------------------------------

my $srcstr = "Bill Gates is a pest!\n";
$prog = sightly({ Shape         => 'window',
                  SourceString  => $srcstr,
                  Regex         => 1,
                  InformHandler => sub {},
                  Print         => 1 } );
test_one('Bill Gates is a pest!', $srcstr, $windowstr);

# Text string print (eval) -------------------------

$prog = sightly({ Shape         => 'window',
                  SourceString  => $srcstr,
                  Regex         => 0,
                  InformHandler => sub {},
                  Print         => 1 } );
test_one('Bill Gates is a pest!', $srcstr, $windowstr);

# Binary encode/decode -----------------------------

my $encodestr = qq#binmode(STDOUT);print eval '"'.\n\n\n#;
$encodestr =~ tr/!-~/#/;
$encodestr .= $camelstr x 5;
$srcstr = join("", map(chr(), 0..255));
$prog = sightly({ Shape         => 'camel',
                  SourceString  => $srcstr,
                  Binary        => 1,
                  Regex         => 0,
                  InformHandler => sub {},
                  Print         => 1 } );
build_file($tmpf, $prog);
# This seems to stop on CTRL-Z on Windows!
# Something to do with binmode ??
#   $outstr = `$^X -w -Mstrict $tmpf`;
# so use a temporary file instead.
my $tmpf2 = 'bill2.tmp';
system("$^X -Tw -Mstrict $tmpf >$tmpf2");
my $rc = $? >> 8;
$rc == 0 or print "not ";
++$itest; print "ok $itest - binary str encode rc\n";
open(TT, $tmpf2) or die "open '$tmpf2': $!";
binmode(TT);
my $outstr = do { local $/; <TT> };
close(TT);
$outstr eq $srcstr or print "not ";
++$itest; print "ok $itest - binary str encode output\n";
$prog =~ tr/!-~/#/;
$prog eq $encodestr or print "not ";
++$itest; print "ok $itest - binary str encode shape\n";

$prog = sightly({ Shape         => 'camel',
                  SourceFile    => $tmpf2,
                  Binary        => 1,
                  Regex         => 0,
                  InformHandler => sub {},
                  Print         => 1 } );
build_file($tmpf, $prog);
system("$^X -Tw -Mstrict $tmpf >$tmpf2");
$rc = $? >> 8;
$rc == 0 or print "not ";
++$itest; print "ok $itest - binary file encode rc\n";
open(TT, $tmpf2) or die "open '$tmpf2': $!";
binmode(TT);
$outstr = do { local $/; <TT> };
close(TT);
$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);

# This one used to be OK with -Mstrict but not as of perl 5.8.4.
# From the perl 5.8.4 perldelta:
#   Pragmata are now correctly propagated into (?{...}) constructions in regexps.
#   Code such as
#     my $x = qr{ ... (??{ $x }) ... };
#   will now (correctly) fail under use strict.
#   (As the inner $x is and has always referred to $::x)
$outstr = `$^X -Tw $tmpf`;
$rc = $? >> 8;
$rc == 0 or print "not ";
++$itest; print "ok $itest - self-printing japh rc\n";
$outstr =~ s/^.+\n// if $] >= 5.017;   # remove leading use re 'eval' line
$outstr eq $japhstr or print "not ";
++$itest; print "ok $itest - self-printing japh output\n";

# Camel helloworld.pl (FillerVar=';')---------------

$prog = sightly({ Shape         => 'camel',
                  SourceString  => $hellostr,
                  FillerVar     => ';',
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('Camel helloworld fillervar=;', "hello world\n", $camelstr);

# Camel helloworld.pl (FillerVar=';#')--------------

$prog = sightly({ Shape         => 'camel',
                  SourceString  => $hellostr,
                  FillerVar     => ';#',
                  InformHandler => sub {},
                  Regex         => 1 } );
test_one('Camel helloworld fillervar=;#', "hello world\n", $camelstr);

# Camel helloworld.pl (FillerVar='')----------------

$prog = sightly({ Shape         => 'camel',