1#!/usr/bin/perl -w
2
3use strict;
4use warnings;
5use lib 't/lib';
6
7use Test::More;
8use File::Spec;
9use TAP::Parser;
10use TAP::Harness;
11use App::Prove;
12
13diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV;
14
15my @cleanup = ();
16END { unlink @cleanup }
17
18my $test = File::Spec->catfile(
19    't',
20    'sample-tests',
21    'echo'
22);
23
24my @test = ( [ perl => $test ], make_shell_test($test) );
25
26plan tests => @test * 8 + 5;
27
28sub echo_ok {
29    my ( $type, $options ) = ( shift, shift );
30    my $name   = join( ', ', sort keys %$options ) . ", $type";
31    my @args   = @_;
32    my $parser = TAP::Parser->new( { %$options, test_args => \@args } );
33    my @got    = ();
34    while ( my $result = $parser->next ) {
35        push @got, $result;
36    }
37    my $plan = shift @got;
38    ok $plan->is_plan, "$name: is_plan";
39    is_deeply [ map { $_->description } @got ], [@args],
40      "$name: option passed OK";
41}
42
43for my $t (@test) {
44    my ( $type, $test ) = @$t;
45    for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) {
46        echo_ok( $type, { source => $test }, @$args );
47        echo_ok( $type, { exec => [ $^X, $test ] }, @$args );
48    }
49}
50
51sub make_shell_test {
52    my $test  = shift;
53    my $shell = '/bin/sh';
54    return unless -x $shell;
55    my $script = "shell_$$.sh";
56
57    push @cleanup, $script;
58    {
59        open my $sh, '>', $script;
60        print $sh "#!$shell\n\n";
61        print $sh "$^X '$test' \$*\n";
62    }
63    chmod 0775, $script;
64    return unless -x $script;
65    return [ shell => $script ];
66}
67
68{
69    for my $test_arg_type (
70        [qw( magic hat brigade )],
71        { $test => [qw( magic hat brigade )] },
72      )
73    {
74        my $harness = TAP::Harness->new(
75            { verbosity => -9, test_args => $test_arg_type } );
76        my $aggregate = $harness->runtests($test);
77
78        is $aggregate->total,  3, "ran the right number of tests";
79        is $aggregate->passed, 3, "and they passed";
80    }
81}
82
83package Test::Prove;
84
85use base 'App::Prove';
86
87sub _runtests {
88    my $self = shift;
89    push @{ $self->{_log} }, [@_];
90    return;
91}
92
93sub get_run_log {
94    my $self = shift;
95    return $self->{_log};
96}
97
98package main;
99
100{
101    my $app = Test::Prove->new;
102
103    $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' );
104    $app->run();
105    my $log = $app->get_run_log;
106    is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ],
107      "prove args match";
108}
109
110sub bigness {
111    my $str = join '', @_;
112    my @cdef = (
113        '0000000000000000', '1818181818001800', '6c6c6c0000000000',
114        '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600',
115        '386c6c386d663b00', '0c18300000000000', '0c18303030180c00',
116        '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000',
117        '0000000000181830', '0000007e00000000', '0000000000181800',
118        '00060c1830600000', '3c666e7e76663c00', '1838181818187e00',
119        '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00',
120        '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000',
121        '3c66663c66663c00', '3c66663e060c3800', '0000181800181800',
122        '0000181800181830', '0c18306030180c00', '00007e007e000000',
123        '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00',
124        '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00',
125        '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000',
126        '3c66606e66663c00', '6666667e66666600', '7e18181818187e00',
127        '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00',
128        '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00',
129        '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600',
130        '3c66603c06663c00', '7e18181818181800', '6666666666663c00',
131        '66666666663c1800', '63636b6b7f776300', '66663c183c666600',
132        '6666663c18181800', '7e060c1830607e00', '7c60606060607c00',
133        '006030180c060000', '3e06060606063e00', '183c664200000000',
134        '00000000000000ff', '1c36307c30307e00', '00003c063e663e00',
135        '60607c6666667c00', '00003c6660663c00', '06063e6666663e00',
136        '00003c667e603c00', '1c30307c30303000', '00003e66663e063c',
137        '60607c6666666600', '1800381818183c00', '1800381818181870',
138        '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300',
139        '00007c6666666600', '00003c6666663c00', '00007c66667c6060',
140        '00003e66663e0607', '00006c7660606000', '00003e603c067c00',
141        '30307c3030301c00', '0000666666663e00', '00006666663c1800',
142        '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c',
143        '00007e0c18307e00', '0c18187018180c00', '1818180018181800',
144        '3018180e18183000', '316b460000000000'
145    );
146    my @chars = unpack( 'C*', $str );
147    my @out = ();
148    for my $row ( 0 .. 7 ) {
149        for my $char (@chars) {
150            next if $char < 32 || $char > 126;
151            my $size = scalar(@cdef);
152            my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) );
153            my $bits = sprintf( '%08b', $byte );
154            $bits =~ tr/01/ #/;
155            push @out, $bits;
156        }
157        push @out, "\n";
158    }
159    return join '', @out;
160}
161