← Back to branch summary

~ubuntu-branches/ubuntu/maverick/libcapture-tiny-perl/maverick

« back to all changes in this revision

Viewing changes to t/lib/Cases.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-05-23 04:44:25 UTC
  • Revision ID: james.westby@ubuntu.com-20090523044425-i3cuofbmt79rqq8e
Tags: upstream-0.06
Import upstream version 0.06

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/lib/Cases.pm
 
1
package t::lib::Cases;
 
2
use strict;
 
3
use warnings;
 
4
use Test::More;
 
5
use Capture::Tiny ':all';
 
6
 
 
7
require Exporter;
 
8
our @ISA = 'Exporter';
 
9
our @EXPORT_OK = qw(
 
10
  run_test
 
11
);
 
12
 
 
13
my $have_diff = eval { 
 
14
  require Test::Differences; 
 
15
  Test::Differences->import;
 
16
  1;
 
17
};
 
18
 
 
19
sub _is_or_diff {
 
20
  my ($g,$e,$l) = @_;
 
21
  if ( $have_diff ) { eq_or_diff( $g, $e, $l ); }
 
22
  else { is( $g, $e, $l ); }
 
23
}
 
24
 
 
25
sub _binmode {
 
26
  my $text = shift;
 
27
  return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : '';
 
28
}
 
29
 
 
30
sub _set_utf8 {
 
31
  my $t = shift;
 
32
  return unless $t eq 'unicode';
 
33
  my %seen;
 
34
  my @orig_layers = grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{$_}++} PerlIO::get_layers(\*STDOUT);
 
35
  binmode(STDOUT, ":utf8") if fileno(STDOUT); 
 
36
  binmode(STDERR, ":utf8") if fileno(STDERR); 
 
37
  return @orig_layers;
 
38
}
 
39
 
 
40
sub _restore_layers {
 
41
  my ($t, @orig_layers) = @_;
 
42
  return unless $t eq 'unicode';
 
43
  binmode(STDOUT, join( ":", "", "raw", @orig_layers)) if fileno(STDOUT); 
 
44
  binmode(STDERR, join( ":", "", "raw", @orig_layers)) if fileno(STDERR); 
 
45
}
 
46
 
 
47
#--------------------------------------------------------------------------#
 
48
 
 
49
my %texts = (
 
50
  short => 'Hello World',
 
51
  multiline => 'First line\nSecond line\n',
 
52
  ( $] < 5.008 ? () : ( unicode => 'Hi! \x{263a}\n') ),
 
53
);
 
54
 
 
55
#--------------------------------------------------------------------------#
 
56
#  fcn($perl_code_string) => execute the perl in current process or subprocess
 
57
#--------------------------------------------------------------------------#
 
58
 
 
59
my %methods = (
 
60
  perl    => sub { eval $_[0] },
 
61
  sys  => sub { system($^X, '-e', $_[0]) },
 
62
);
 
63
 
 
64
#--------------------------------------------------------------------------#
 
65
 
 
66
my %channels = (
 
67
  stdout  => {
 
68
    output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}" },
 
69
    expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", "" },
 
70
  },
 
71
  stderr  => {
 
72
    output => sub { _binmode($_[0]) . "print STDERR qq{STDERR:$texts{$_[0]}}" },
 
73
    expect => sub { "", eval "qq{STDERR:$texts{$_[0]}}" },
 
74
  },
 
75
  both    => {
 
76
    output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}; print STDERR qq{STDERR:$texts{$_[0]}}" },
 
77
    expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", eval "qq{STDERR:$texts{$_[0]}}" },
 
78
  },
 
79
);
 
80
 
 
81
#--------------------------------------------------------------------------#
 
82
 
 
83
my %tests = (
 
84
  capture => {
 
85
    cnt   => 2,
 
86
    test  => sub {
 
87
      my ($m, $c, $t, $l) = @_;
 
88
      my ($got_out, $got_err) = capture {
 
89
        $methods{$m}->( $channels{$c}{output}->($t) );
 
90
      };
 
91
      my @expected = $channels{$c}{expect}->($t);
 
92
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
 
93
      _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" );
 
94
    },
 
95
  },
 
96
  capture_scalar => {
 
97
    cnt   => 1,
 
98
    test  => sub {
 
99
      my ($m, $c, $t, $l) = @_;
 
100
      my $got_out = capture {
 
101
        $methods{$m}->( $channels{$c}{output}->($t) );
 
102
      };
 
103
      my @expected = $channels{$c}{expect}->($t);
 
104
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
 
105
    },
 
106
  },
 
107
  capture_merged => {
 
108
    cnt   => 2,
 
109
    test  => sub {
 
110
      my ($m, $c, $t, $l) = @_;
 
111
      my $got_out = capture_merged {
 
112
        $methods{$m}->( $channels{$c}{output}->($t) );
 
113
      };
 
114
      my @expected = $channels{$c}{expect}->($t);
 
115
      like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" );
 
116
      like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" );
 
117
    },
 
118
  },
 
119
  tee => {
 
120
    cnt => 4,
 
121
    test => sub {
 
122
      my ($m, $c, $t, $l) = @_;
 
123
      my ($got_out, $got_err);
 
124
      my ($tee_out, $tee_err) = capture {
 
125
        ($got_out, $got_err) = tee {
 
126
          $methods{$m}->( $channels{$c}{output}->($t) );
 
127
        };
 
128
      };
 
129
      my @expected = $channels{$c}{expect}->($t);
 
130
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
 
131
      _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" );
 
132
      _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" );
 
133
      _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" );
 
134
    }
 
135
  },
 
136
  tee_scalar => {
 
137
    cnt => 3,
 
138
    test => sub {
 
139
      my ($m, $c, $t, $l) = @_;
 
140
      my ($got_out, $got_err);
 
141
      my ($tee_out, $tee_err) = capture {
 
142
        $got_out = tee {
 
143
          $methods{$m}->( $channels{$c}{output}->($t) );
 
144
        };
 
145
      };
 
146
      my @expected = $channels{$c}{expect}->($t);
 
147
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
 
148
      _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" );
 
149
      _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" );
 
150
    }
 
151
  },
 
152
  tee_merged => {
 
153
    cnt => 5,
 
154
    test => sub {
 
155
      my ($m, $c, $t, $l) = @_;
 
156
      my ($got_out, $got_err);
 
157
      my ($tee_out, $tee_err) = capture {
 
158
        $got_out = tee_merged {
 
159
          $methods{$m}->( $channels{$c}{output}->($t) );
 
160
        };
 
161
      };
 
162
      my @expected = $channels{$c}{expect}->($t);
 
163
      like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" );
 
164
      like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" );
 
165
      like( $tee_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - tee STDOUT (STDOUT)" );
 
166
      like( $tee_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - tee STDOUT (STDERR)" );
 
167
      _is_or_diff( $tee_err, '', "$l|$m|$c|$t - tee STDERR" );
 
168
    }
 
169
  },
 
170
);
 
171
 
 
172
#--------------------------------------------------------------------------#
 
173
# What I want to be able to do:
 
174
#
 
175
# test_it(
 
176
#   input => 'short',
 
177
#   channels => 'both',
 
178
#   method => 'perl'
 
179
# )
 
180
 
 
181
sub run_test {
 
182
  my $test_type = shift or return;
 
183
  my $todo = shift || '';
 
184
  for my $m ( keys %methods ) {
 
185
    for my $c ( keys %channels ) {
 
186
      for my $t ( keys %texts     ) {
 
187
        my @orig_layers = _set_utf8($t);
 
188
        local $TODO = "not yet supported"
 
189
          if $t eq $todo;
 
190
        $tests{$test_type}{test}->($m, $c, $t, $test_type);
 
191
        _restore_layers($t, @orig_layers);
 
192
      }
 
193
    }
 
194
  }
 
195
}
 
196
 
 
197
1;