Acme-EyeDrops
view release on metacpan or search on metacpan
- new shape: tpr
1.07 Sun Mar 31 15:12:17 2002
- improved documentation, added Buffy looking in the mirror
- fixed EyeDrops.pm to work with Perl 5.7.3
only needed to change:
$src =~ tr#\\[]{}<>^_|~'`#/()()()H-!T""#;
to:
$src =~ tr#_\\[]{}<>^|~'`#-/()()()H!T""#;
due to 'invalid range' H-! error
- minor change to shapes: damian, camel
- new shape: kermit (thanks Jason)
- new shape: pgolf (thanks `/anick)
- fixed bug where EyeDrops sometimes generated an
invalid program or more shapes than it needed to
- new test: limit2.t to verify above bug fixed
- new test: sightly2.t
- made sure test programs clean up all .tmp files
- added -Mstrict to all test programs to ensure
they work with -w and 'use strict' too
- added camel shape to Makefile.PL/Build.PL
- Support PERL_SMOKE environment variable for long-running tests
(see http://archive.develooper.com/perl-qa@perl.org/msg01927.html,
thanks merlyn)
1.42 Sun Aug 3 12:02:08 2003
- Bug fix release for Perl 5.8.1 (see Perl bug #23143).
- For the first time, the EyeDrops test suite uncovered a Perl bug
(dance a little jig): recur.t, test 4 failed on Perl 5.8.1-RC2
with the error: panic: pad_free curpad. Thanks merlyn for reporting.
Since this bug won't be fixed for 5.8.1, we workaround
it by never using $_ as a filler variable
- sightly.t: run generated test programs in taint mode
- tests: renamed to more appropriate names
- tests: new long running test 13_to.t
- documentation: added "Getting Started" section
- documentation: fixed program in "Naked Arm Wrestling" section
- documentation: updated 'Abbreviated History of Perl 6' section
1.43 Sun Aug 31 17:12:55 2003
lib/Acme/EyeDrops.pm view on Meta::CPAN
'!').('`'|')').('`'|'.').'.'.(('!')^ '+')
.'"'.'}'.')');$:='.'^'~';$~='@'|'(';$^=
')'^'[';$/='`'|'.';$,='('^'}';$\='`'
|'!';$:=')'^'}';$~='*'|'`';$^=
'+'^'_';$/='&'|('@');$,=
'['&'~';$\=','^'|'
=head2 Error Handling
The C<sightly> function returns a properly shaped program string;
there is no error return. If something is badly wrong, C<die> is called.
So if you are calling C<sightly> in an environment where it's
unacceptable to die, be sure to wrap the C<sightly> call in
an C<eval> block. For example:
eval {
$prog = sightly( { Shape => 'invalid-shape',
SourceFile => 'eyesore.pl',
InformHandler => sub {} } );
};
if ($@) { warn "sightly died: $@\n" }
lib/Acme/EyeDrops.pm view on Meta::CPAN
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
can't afford to die.
The attributes that HASHREF may contain are:
Shape Describes the shape you want.
First, a built-in shape is looked for.
Next, a 'eye' shape (.eye file in the
get_eye_dir() directory unless overridden
by the EyeDir attribute) is looked for.
lib/Acme/EyeDrops.pm view on Meta::CPAN
will defeat the shape-pouring algorithm.
You can eliminate all alphanumerics (via Regex => 1) only if the
program to be converted is careful with its use of regular
expressions and C<$_>.
To convert complex programs, you must use Regex => 0, which
emits a leading unsightly double C<eval>.
The code generated by non-zero Regex requires Perl 5.005 or higher
in order to run; when run on earlier versions, you will likely
see the error message: C<Sequence (?{...) not recognized>.
If using Perl 5.18+, the generated file needs a leading
"use re 'eval'" when a postive value for Regex is used.
The converted program runs inside an C<eval> which may cause
problems for non-trivial programs. A C<die> statement or
an C<INIT> block, for instance, may cause trouble.
If desperate, give the C<TrapEvalDie> and C<TrapWarn>
attributes a go, and see if they fix the problem.
$outstr =~ tr/!-~/#/;
$outstr eq $buffyprogstr and print "not ";
++$itest; print "ok $itest - buffy shape\n";
$outstr =~ s/ +$//mg;
$outstr =~ s/^.+\n// if $] >= 5.017; # remove leading use re 'eval' line
$outstr eq $buffymirrorstr or print "not ";
++$itest; print "ok $itest - buffy shape mirror\n";
# -------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
t/02_shatters.t view on Meta::CPAN
# $rc == 0 or print "not ";
# ++$itest; print "ok $itest - MyEye.pm rc\n";
# $outstr eq "My Name is mark\n" or print "not ";
# ++$itest; print "ok $itest - MyEye.pm output\n";
# $prog =~ tr/!-~/#/;
# $prog eq $camelstr or print "not ";
# ++$itest; print "ok $itest - shape\n";
# --------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
unlink('MyEye.pm') or die "error: unlink 'MyEye.pm': $!";
t/03_Larry.t view on Meta::CPAN
$fchar eq ')' or print "not ";
++$itest; print "ok $itest\n";
length($prog) == 2*($exact-1)+1 or print "not ";
++$itest; print "ok $itest\n";
$nprog = $lines[0] . $fchar;
$nprog eq $sightlystr or print "not ";
++$itest; print "ok $itest\n";
# --------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
t/04_Apocalyptic.t view on Meta::CPAN
test_one_empty("############ ##### ### #\n");
test_one_empty("############ ### #### #\n");
test_one_empty("############ #\n");
test_one_empty("############ ##\n");
test_one_empty("############ ###\n");
test_one_empty("############ ####\n");
test_one_empty("############\n");
# -----------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
t/05_Parrot.t view on Meta::CPAN
$prog = sightly({ Shape => "larry,triangle,$tmpf2",
SourceFile => $hellofile,
Gap => 2,
InformHandler => sub {},
Regex => 1 } );
test_one('larry/triangle/camelshapefile helloworld', "hello world\n",
join("\n\n", $larrystr, make_triangle(0), $camelstr));
# ----------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
unlink($tmpf2) or die "error: unlink '$tmpf2': $!";
unlink($tmpeye) or die "error: unlink '$tmpeye': $!";
unlink($tmpeye2) or die "error: unlink '$tmpeye2': $!";
unlink($hellofile) or die "error: unlink '$hellofile': $!";
InformHandler => sub {},
Regex => 1 } );
test_one('reflected test shape', "hello world\n");
$prog =~ s/^use re 'eval';\n// if $] >= 5.017; # remove leading use re 'eval' line
$prog =~ tr/!-~/#/;
$prog eq $ref_testshape or print "not ";
++$itest; print "ok $itest - reflected test shape prog\n";
# -------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
unlink($tmpeye) or die "error: unlink '$tmpeye': $!";
eq
sightly( { Shape => 'camel,mongers',
SourceString => $hellostr,
Gap => 1,
InformHandler => sub {},
Regex => 1 } ) or print "not ";
++$itest; print "ok $itest - join v gap the same\n";
# -------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
t/08_hoax.t view on Meta::CPAN
$outstr eq "" or print "not ";
++$itest; print "ok $itest - die inside eval output\n";
Acme::EyeDrops::_slurp_tfile($tmpf2) eq "hello die\n" or print "not ";
++$itest; print "ok $itest - die inside die output\n";
$prog =~ tr/!-~/#/;
$prog eq $teststr or print "not ";
++$itest; print "ok $itest - die inside die shape\n";
# --------------------------------------------------
unlink($tmpf2) or die "error: unlink '$tmpf2': $!";
unlink($tmpf) or die "error: unlink '$tmpf': $!";
# --------------------------------------------------
# Test slurp of non-existent file.
eval { Acme::EyeDrops::_slurp_tfile($tmpf) };
$@ =~ m|open \Q'$tmpf'\E| or print "not ";
++$itest; print "ok $itest - slurp of non-existent file\n";
t/09_Gallop.t view on Meta::CPAN
$rc == 0 or print "not ";
++$itest; print "ok $itest - twice rc\n";
$outstr eq "hello world\n" or print "not ";
++$itest; print "ok $itest - twice output\n";
$prog =~ tr/!-~/#/;
$prog =~ s/^.+\n// if $] >= 5.017; # remove leading use re 'eval' line
$prog eq $camelstr or print "not ";
++$itest; print "ok $itest - twice shape\n";
# Prior to Acme::EyeDrops v1.42, test 4 fails on Perl 5.8.1
# with the error: panic: pad_free curpad (Perl bug #23143).
# And you can make it fail again, by adding the attribute:
# FillerVar => [ '$_' ],
# to all sightly() calls in this test program.
$prog = sightly({ Shape => 'camel,window',
SourceString => $progorig,
InformHandler => sub {},
Regex => 1 } );
build_file($tmpf, $prog);
# Fails with "Out of memory!" with perl 5.10.0: comment out tests 4-6 for now.
t/09_Gallop.t view on Meta::CPAN
# ++$itest; print "ok $itest - twice rc\n";
# $outstr eq "hello world\n" or print "not ";
# ++$itest; print "ok $itest - twice output\n";
# my $teststr = $camelstr x 16;
# $prog =~ tr/!-~/#/;
# $prog eq $teststr or print "not ";
# ++$itest; print "ok $itest - twice shape\n";
# --------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
# --------------------------------------------------
# Original Perl bug report #23143 follows:
# The following program works under Perl 5.8.0 but fails under
# 5.8.1 with the error: "panic: pad_free curpad".
#
# ''=~m<(?{eval'print 4;$_=9'})>;($_)=9;
#
# If you change it to:
#
# ''=~m<(?{eval'print 4;$_=9'})>;$_=9;
#
# it works fine. Take out the eval:
#
# ''=~m<(?{print 4;$_=9})>;($_)=9;
" wall:larry\\\nnot wall russ\n\tConway: The Damian \t\n",
{ 'wall' => 'larrynot wall russ',
'Conway' => 'The Damian' }
);
# -----------------------------------------------------------------------
# get_eye_properties() tests.
{
my $tmpeyp = 'tmpeye.eyp';
-f $tmpeyp and (unlink($tmpeyp) or die "error unlink '$tmpeyp': $!");
my $h = Acme::EyeDrops::_get_eye_properties('.', 'tmpeye');
defined($h) and print "not ";
++$itest; print "ok $itest - get_eye_properties, no props\n";
}
{
# XXX: need to update test when update shape properties.
my $h = get_eye_properties('camel');
ref($h) eq 'HASH' or print "not ";
++$itest; print "ok $itest - get_eye_properties, camel 1\n";
++$itest; print "ok $itest - get_eye_keywords, '$k'\n";
}
}
# -----------------------------------------------------------------------
# Old tests -- function set_eye_dir() has been removed.
# my $mypwd = Cwd::cwd();
# my $mytesteyedir = "$mypwd/eyedir.tmp";
# my $mytesteyefile = "$mytesteyedir/tmp.eye";
# -d $mytesteyedir or (mkdir($mytesteyedir, 0777) or die "error: mkdir '$mytesteyedir': $!");
# build_file($mytesteyefile, $mytestshapestr);
# set_eye_dir($mytesteyedir);
# get_eye_dir() eq $mytesteyedir or print "not ";
# ++$itest; print "ok $itest - set_eye_dir sane\n";
# my @eyes = get_eye_shapes();
# @eyes==1 or print "not ";
# ++$itest; print "ok $itest - set_eye_dir number\n";
# $eyes[0] eq 'tmp' or print "not ";
# ++$itest; print "ok $itest - set_eye_dir filename\n";
# test_one_shape('tmp', get_eye_string('tmp'));
# This is just a simple example of testing die inside EyeDrops.pm.
# eval { set_eye_dir($mytesteyefile) };
# $@ or print "not ";
# ++$itest; print "ok $itest - set_eye_dir eval die\n";
# $@ eq "error set_eye_dir '" . $mytesteyefile . "': no such directory\n"
# or print "not ";
# ++$itest; print "ok $itest - set_eye_dir eval die string\n";
# -----------------------------------------------------------------------
# unlink($mytesteyefile) or die "error: unlink '$mytesteyefile': $!";
# rmdir($mytesteyedir) or die "error: rmdir '$mytesteyedir': $!";
# --------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
# ----------------------------------------------------------------
# Test for file that does not exist.
eval { Acme::EyeDrops::_get_properties($tmpf) };
$@ =~ /'\Q$tmpf\E':/ or print "not ";
++$itest; print "ok $itest - _get_properties, file not found\n";
eval { Acme::EyeDrops::_get_eye_shapes($tmpf) };
$@ =~ /'\Q$tmpf\E':/ or print "not ";
t/14_gulp.t view on Meta::CPAN
test_one('hellotest SourceFile string',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
# For different ways to pass a handle, see Perl Cookbook, 2nd edition,
# Recipe 7.5:
# 1) *FH typeglob
# 2) \*FH ref to typeglob
# 3) *FH{IO} I/O object
open(FH, $hellotestfile) or die "error: open '$hellotestfile': $!";
$prog = sightly({ Shape => 'yanick4',
SourceHandle => *FH,
InformHandler => sub {},
Regex => 1 } );
close(FH) or die "error: close '$hellotestfile': $!";
test_one('hellotest SourceHandle typeglob',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
open(FH, $hellotestfile) or die "error: open '$hellotestfile': $!";
$prog = sightly({ Shape => 'yanick4',
SourceHandle => \*FH,
InformHandler => sub {},
Regex => 1 } );
close(FH) or die "error: close '$hellotestfile': $!";
test_one('hellotest SourceHandle typeglob ref',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
open(FH, $hellotestfile) or die "error: open '$hellotestfile': $!";
$prog = sightly({ Shape => 'yanick4',
SourceHandle => *FH{IO},
InformHandler => sub {},
Regex => 1 } );
close(FH) or die "error: close '$hellotestfile': $!";
test_one('hellotest SourceHandle I/O object',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
require IO::File;
my $fh = IO::File->new();
$fh->open($hellotestfile) or die "error: open '$hellotestfile': $!";
$prog = sightly({ Shape => 'yanick4',
SourceHandle => $fh,
InformHandler => sub {},
Regex => 1 } );
$fh->close() or die "error: close '$hellotestfile': $!";
test_one('hellotest SourceHandle IO::File',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
if ($] < 5.006) {
skip_one("hellotest SourceHandle autovivify, perl version less than 5.006");
} else {
open(my $fh, $hellotestfile) or die "error: open '$hellotestfile': $!";
$prog = sightly({ Shape => 'yanick4',
SourceHandle => $fh,
InformHandler => sub {},
Regex => 1 } );
close($fh) or die "error: close '$hellotestfile': $!";
test_one('hellotest SourceHandle autovivify',
"hello test 0\nhello test 1\nhello test 2\nhello test 3\n",
$yanick4str x 3);
}
$prog = sightly({ Shape => 'yanick4',
SourceFile => $zerotestfile,
InformHandler => sub {},
Regex => 1 } );
test_one('hellotest zero SourceFile string',
t/14_gulp.t view on Meta::CPAN
eval {
sightly({ Width => 3,
SourceString => $helloteststr } );
};
$@ =~ /invalid width/ or print "not ";
++$itest; print "ok $itest - Invalid Width\n";
# ----------------------------------------------------------------
unlink($tmpf) or die "error: unlink '$tmpf': $!";
unlink($hellotestfile) or die "error: unlink '$hellotestfile': $!";
unlink($zerotestfile) or die "error: unlink '$zerotestfile': $!";
# ----------------------------------------------------------------
# Test for file that does not exist.
eval {
sightly({ Shape => 'yanick4',
SourceFile => $hellotestfile,
InformHandler => sub {},
Regex => 1 } );
};
t/19_surrounds.t view on Meta::CPAN
sub get_first_line {
my $f = shift; local *T; open(T, $f) or die "open '$f': $!";
my $s = <T>; close(T); $s;
}
sub rm_f_dir
{
my $d = shift;
-d $d or return;
File::Path::rmtree($d, 0, 0);
-d $d and die "error: could not delete everything in '$d': $!";
}
# --------------------------------------------------
skip_test('Skipping long running generator tests unless $ENV{PERL_SMOKE} is true')
unless $ENV{PERL_SMOKE};
print STDERR "Long running generated tests running...\n";
print STDERR "(these are only run if PERL_SMOKE environment variable is true).\n";
t/19_surrounds.t view on Meta::CPAN
. ";\n1;\n" . $doc;
}
# Copy lib/Acme to temporary new $genbase.
sub create_eyedrops_tree {
my ($fromdir, $todir) = @_;
my $fromdrops = "$fromdir/lib/Acme/EyeDrops";
my $todrops = "$todir/lib/Acme/EyeDrops";
File::Path::mkpath($todrops, 0, 0777) or
die "error: mkpath '$todrops': $!";
local *D;
opendir(D, $fromdrops) or die "error: opendir '$fromdrops': $!";
my @eye = grep(/\.ey[ep]$/, readdir(D));
closedir(D);
for my $f (@eye) {
File::Copy::copy("$fromdrops/$f", "$todrops/$f")
or die "error: File::Copy::copy '$f': $!";
}
build_file("$todir/lib/Acme/EyeDrops.pm", eye_drop_eyedrops_pm());
}
# --------------------------------------------------
my $genbase = 'knob';
my $base = File::Basename::dirname($0);
# In the normal case, $base will be set to 't'.
t/19_surrounds.t view on Meta::CPAN
# my $self = shift; my $fmt = shift;
# $knob .= sprintf($fmt, @_);
# }
# package main;
# tie *STDOUT, 'MyStdout';
# See, for example, TieOut.pm in the t/lib directory of ExtUtils-MakeMaker.
# (TieOut.pm is a little invention of chromatic's).
my $outf = 'out.tmp';
my $errf = 'err.tmp';
-f $outf and (unlink($outf) or die "error: unlink '$outf': $!");
-f $errf and (unlink($errf) or die "error: unlink '$errf': $!");
my $itest = 0;
sub test_one {
my ($e, $rtests) = @_;
local *SAVERR; open(SAVERR, ">&STDERR"); # save original STDERR
local *SAVOUT; open(SAVOUT, ">&STDOUT"); # save original STDOUT
open(STDOUT, '>'.$outf) or die "Could not create '$outf': $!";
open(STDERR, '>'.$errf) or die "Could not create '$errf': $!";
my $status = Test::Harness::runtests(@{$rtests});
# XXX: Test harness does not like the next two closes.
# close(STDOUT) or die "error: close STDOUT: $!";
# close(STDERR) or die "error: close STDERR: $!";
open(STDERR, ">&SAVERR") or die "error: restore STDERR: $!";
open(STDOUT, ">&SAVOUT") or die "error: restore STDOUT: $!";
# XXX: is this necessary to prevent leaks?
close(SAVOUT) or die "error: close SAVOUT: $!";
close(SAVERR) or die "error: close SAVERR: $!";
my $outstr = Acme::EyeDrops::_slurp_tfile($outf);
my $errstr = Acme::EyeDrops::_slurp_tfile($errf);
print STDERR "\nstdout of TestHarness::runtests:\n$outstr\n";
print STDERR "stderr of TestHarness::runtests:\n$errstr\n";
$status or print "not ";
++$itest; print "ok $itest - TestHarness::runtests of $e\n";
}
t/19_surrounds.t view on Meta::CPAN
# Now run with generated EyeDrops.pm.
{
local @INC = @INC; unshift(@INC, "$genbase/lib");
test_one('sightly EyeDrops.pm, plain tests', \@tests);
test_one('sightly EyeDrops.pm, generated tests', \@ztests);
}
# ----------------------------------------------------
for my $t (@ztests) { unlink($t) or die "error: unlink '$t': $!" }
rm_f_dir($genbase);
unlink($outf) or die "error: unlink '$outf': $!";
unlink($errf) or die "error: unlink '$errf': $!";
( run in 0.617 second using v1.01-cache-2.11-cpan-74e6d1fb12f )