Commit | Line | Data |
a9153838 |
1 | #!perl -w |
2 | |
3 | BEGIN { |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't'; |
6 | @INC = '../lib'; |
7 | } |
8 | } |
9 | |
30e302f8 |
10 | |
11 | # Turn on threads here, if available, since this test tends to find |
12 | # lots of threading bugs. |
13 | use Config; |
14 | BEGIN { |
15 | if( $] >= 5.008 && $Config{useithreads} ) { |
16 | require threads; |
17 | 'threads'->import; |
18 | } |
19 | } |
20 | |
21 | |
a9153838 |
22 | use strict; |
a9153838 |
23 | |
89c1e84a |
24 | use Test::More tests => 7; |
a9153838 |
25 | |
26 | my $Test = Test::More->builder; |
27 | |
28 | # now make a filehandle where we can send data |
29 | my $output; |
30 | tie *FAKEOUT, 'FakeOut', \$output; |
31 | |
89c1e84a |
32 | # force diagnostic output to a filehandle, glad I added this to |
33 | # Test::Builder :) |
a9153838 |
34 | my @lines; |
89c1e84a |
35 | my $ret; |
a9153838 |
36 | { |
37 | local $TODO = 1; |
38 | $Test->todo_output(\*FAKEOUT); |
39 | |
40 | diag("a single line"); |
41 | |
42 | push @lines, $output; |
43 | $output = ''; |
44 | |
89c1e84a |
45 | $ret = diag("multiple\n", "lines"); |
a9153838 |
46 | push @lines, split(/\n/, $output); |
47 | } |
48 | |
49 | is( @lines, 3, 'diag() should send messages to its filehandle' ); |
50 | like( $lines[0], '/^#\s+/', ' should add comment mark to all lines' ); |
51 | is( $lines[0], "# a single line\n", ' should send exact message' ); |
52 | is( $output, "# multiple\n# lines\n", ' should append multi messages'); |
89c1e84a |
53 | ok( !$ret, 'diag returns false' ); |
a9153838 |
54 | |
55 | { |
89c1e84a |
56 | $Test->failure_output(\*FAKEOUT); |
a9153838 |
57 | $output = ''; |
89c1e84a |
58 | $ret = diag("# foo"); |
a9153838 |
59 | } |
89c1e84a |
60 | $Test->failure_output(\*STDERR); |
a9153838 |
61 | is( $output, "# # foo\n", "diag() adds a # even if there's one already" ); |
89c1e84a |
62 | ok( !$ret, 'diag returns false' ); |
a9153838 |
63 | |
64 | package FakeOut; |
65 | |
66 | sub TIEHANDLE { |
67 | bless( $_[1], $_[0] ); |
68 | } |
69 | |
70 | sub PRINT { |
71 | my $self = shift; |
72 | $$self .= join('', @_); |
73 | } |