ext/Test/Harness/t/testargs.t

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