view release on metacpan or  search on metacpan

t/19_surrounds.t  view on Meta::CPAN

   my $orig = Acme::EyeDrops::slurp_yerself();
   # Split $orig into the source ($src) and the pod ($doc).
   my ($src, $doc) = split(/\n1;\n/, $orig, 2);
   # Remove the line containing $eye_dir = __FILE__ ...
   # because this line confuses eval.
   $src =~ s/^(my \$eye_dir\b.*)$//m;
   # Return the new sightly version of EyeDrops.pm.
   $1 . sightly( { Regex         => 0,
                   Compact       => 1,
                   TrapEvalDie   => 1,
                   FillerVar     => ';#',
                   InformHandler => sub {},
                   Shape         => 'camel',
                   Gap           => 1,
                   SourceString  => $src } )
   . ";\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'.
# If you are naughtily running the tests from the t directory,
# base will probably be set to '.'.
my $frombase = $base eq 't' ? '.' : '..';

rm_f_dir($genbase);
create_eyedrops_tree($frombase, $genbase);

# --------------------------------------------------
# This saving and re-directing of STDOUT/STDERR in temporary files
# (implemented in test_one() below) is simple but not very clean.
# An alternative may be to use tie in some way, for example:
#    my $knob;
#    package MyStdout;
#    sub TIEHANDLE {
#       my $class = shift;
#       bless [], $class;
#    }
#    sub PRINT { my $self = shift; $knob .= join('', @_) }
#    sub PRINTF {
#       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";
}

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

my %attrs = (
   Shape          => 'camel',
   Regex          => 0,
   Compact        => 1,
   TrapEvalDie    => 1,
   InformHandler  => sub {},
   Shape          => 'camel',
   Gap            => 1
);

my @unames = (
   '00_Coffee.t',
   '01_mug.t',