t/compat.t

   1 # (X)Emacs mode: -*- cperl -*-
   2
   3 use strict;
   4
   5 =head1 Unit Test Package for Term::ProgressBar v1.0 Compatibility
   6
   7 This script is based on the test script for Term::ProgressBar version 1.0,
   8 and is intended to test compatibility with that version.
   9
  10 =cut
  11
  12 # Utility -----------------------------
  13
  14 use Data::Dumper qw( );
  15 use Test qw( ok plan );
  16
  17 # Test Setup --------------------------
  18
  19 BEGIN {
  20   plan tests => 5,
  21        todo  => [],
  22        ;
  23 }
  24
  25 # -------------------------------------
  26
  27 # grab_output()
  28 #
  29 # Eval some code and return what was printed to stdout and stderr.
  30 #
  31 # Parameters: string of code to eval
  32 #
  33 # Returns: listref of [ stdout text, stderr text ]
  34 #
  35 sub grab_output($) {
  36     die 'usage: grab_stderr(string to eval)' if @_ != 1;
  37     my $code = shift;
  38     require POSIX;
  39     my $tmp_o = POSIX::tmpnam(); my $tmp_e = POSIX::tmpnam();
  40     local (*OLDOUT, *OLDERR);
  41
  42     # Try to get a message to the outside world if we die
  43     local $SIG{__DIE__} = sub { print $_[0]; die $_[0] };
  44
  45     open(OLDOUT, ">&STDOUT") or die "can't dup stdout: $!";
  46     open(OLDERR, ">&STDERR") or die "can't dup stderr: $!";
  47     open(STDOUT, ">$tmp_o")  or die "can't open stdout to $tmp_o: $!";
  48     open(STDERR, ">$tmp_e")  or die "can't open stderr to $tmp_e: $!";
  49     eval $code;
  50     # Doubtful whether most of these messages will ever be seen!
  51     close(STDOUT)            or die "cannot close stdout opened to $tmp_o: $!";
  52     close(STDERR)            or die "cannot close stderr opened to $tmp_e: $!";
  53     open(STDOUT, ">&OLDOUT") or die "can't dup stdout back again: $!";
  54     open(STDERR, ">&OLDERR") or die "can't dup stderr back again: $!";
  55
  56     die $@ if $@;
  57
  58     local $/ = undef;
  59     open (TMP_O, $tmp_o) or die "cannot open $tmp_o: $!";
  60     open (TMP_E, $tmp_e) or die "cannot open $tmp_e: $!";
  61     my $o = <TMP_O>; my $e = <TMP_E>;
  62     close TMP_O   or die "cannot close filehandle opened to $tmp_o: $!";
  63     close TMP_E   or die "cannot close filehandle opened to $tmp_e: $!";
  64     unlink $tmp_o or die "cannot unlink $tmp_o: $!";
  65     unlink $tmp_e or die "cannot unlink $tmp_e: $!";
  66
  67     return [ $o, $e ];
  68 }
  69
  70 # Change 1..1 below to 1..last_test_to_print .
  71 # (It may become useful if the test is moved to ./t subdirectory.)
  72
  73 use Term::ProgressBar;
  74 use POSIX qw<floor ceil>;
  75
  76 =head2 Test 1: compilation
  77
  78 This test confirms that the test script and the modules it calls compiled
  79 successfully.
  80
  81 =cut
  82
  83 ok 1, 1, 'compilation';
  84
  85 # -------------------------------------
  86
  87 $| = 1;
  88
  89 my $count = 100;
  90
  91 # Test 2: create a bar
  92 my $test_str = 'test';
  93
  94 use vars '$b';
  95 my $o = grab_output("\$b = new Term::ProgressBar '$test_str', $count");
  96 if (not $b or $o->[0] ne '' or $o->[1] ne "$test_str: ") {
  97     print Data::Dumper->Dump([$b, $o], [qw( b o )])
  98       if $ENV{TEST_DEBUG};
  99     print 'not ';
 100 }
 101 print "ok 2\n";
 102
 103 # Test 3: do half the stuff and check half the bar has printed
 104 my $halfway = floor($count / 2);
 105 $o = grab_output("update \$b foreach (0 .. $halfway - 1)");
 106 if ($o->[0] ne ''
 107     or $o->[1] ne ('#' x floor(50 / 2)) )
 108 {
 109     print Data::Dumper->Dump([$o], [qw( o )])
 110       if $ENV{TEST_DEBUG};
 111     print 'not ';
 112 }
 113 print "ok 3\n";
 114
 115 # Test 4: do the rest of the stuff and check the whole bar has printed
 116 $o = grab_output("update \$b foreach ($halfway .. $count - 1)");
 117 if ($o->[0] ne ''
 118     or $o->[1] ne ('#' x ceil(50 / 2)) . "\n" )
 119 {
 120     print Data::Dumper->Dump([$o], [qw( o )])
 121       if $ENV{TEST_DEBUG};
 122     print 'not ';
 123 }
 124 print "ok 4\n";
 125
 126 # Test 5: try to do another item and check there is an error
 127 eval { update $b };
 128 unless ( defined($@)
 129          and
 130          (substr($@, 0, length(Term::ProgressBar::ALREADY_FINISHED))
 131           eq Term::ProgressBar::ALREADY_FINISHED) ) {
 132   print Data::Dumper->Dump([$@], [qw( @ )])
 133     if $ENV{TEST_DEBUG};
 134   print 'not ';
 135 }
 136 print "ok 5\n";