<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package App::Prove;

use strict;
use warnings;

use TAP::Harness::Env;
use Text::ParseWords qw(shellwords);
use File::Spec;
use Getopt::Long;
use App::Prove::State;
use Carp;

use base 'TAP::Object';

=head1 NAME

App::Prove - Implements the C&lt;prove&gt; command.

=head1 VERSION

Version 3.44

=cut

our $VERSION = '3.44';

=head1 DESCRIPTION

L&lt;Test::Harness&gt; provides a command, C&lt;prove&gt;, which runs a TAP based
test suite and prints a report. The C&lt;prove&gt; command is a minimal
wrapper around an instance of this module.

=head1 SYNOPSIS

    use App::Prove;

    my $app = App::Prove-&gt;new;
    $app-&gt;process_args(@ARGV);
    $app-&gt;run;

=cut

use constant IS_WIN32 =&gt; ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS =&gt; $^O eq 'VMS';
use constant IS_UNIXY =&gt; !( IS_VMS || IS_WIN32 );

use constant STATE_FILE =&gt; IS_UNIXY ? '.prove'   : '_prove';
use constant RC_FILE    =&gt; IS_UNIXY ? '.proverc' : '_proverc';

use constant PLUGINS =&gt; 'App::Prove::Plugin';

my @ATTR;

BEGIN {
    @ATTR = qw(
      archive argv blib show_count color directives exec failures comments
      formatter harness includes modules plugins jobs lib merge parse quiet
      really_quiet recurse backwards shuffle taint_fail taint_warn timer
      verbose warnings_fail warnings_warn show_help show_man show_version
      state_class test_args state dry extensions ignore_exit rules state_manager
      normalize sources tapversion trap
      statefile
    );
    __PACKAGE__-&gt;mk_methods(@ATTR);
}

=head1 METHODS

=head2 Class Methods

=head3 C&lt;new&gt;

Create a new C&lt;App::Prove&gt;. Optionally a hash ref of attribute
initializers may be passed.

=cut

# new() implementation supplied by TAP::Object

sub _initialize {
    my $self = shift;
    my $args = shift || {};

    my @is_array = qw(
      argv rc_opts includes modules state plugins rules sources
    );

    # setup defaults:
    for my $key (@is_array) {
        $self-&gt;{$key} = [];
    }

    for my $attr (@ATTR) {
        if ( exists $args-&gt;{$attr} ) {

            # TODO: Some validation here
            $self-&gt;{$attr} = $args-&gt;{$attr};
        }
    }

    $self-&gt;state_class('App::Prove::State');
    return $self;
}

=head3 C&lt;state_class&gt;

Getter/setter for the name of the class used for maintaining state.  This
class should either subclass from C&lt;App::Prove::State&gt; or provide an identical
interface.

=head3 C&lt;state_manager&gt;

Getter/setter for the instance of the C&lt;state_class&gt;.

=cut

=head3 C&lt;add_rc_file&gt;

    $prove-&gt;add_rc_file('myproj/.proverc');

Called before C&lt;process_args&gt; to prepend the contents of an rc file to
the options.

=cut

sub add_rc_file {
    my ( $self, $rc_file ) = @_;

    local *RC;
    open RC, "&lt;$rc_file" or croak "Can't read $rc_file ($!)";
    while ( defined( my $line = &lt;RC&gt; ) ) {
        push @{ $self-&gt;{rc_opts} },
          grep { defined and not /^#/ }
          $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
    }
    close RC;
}

=head3 C&lt;process_args&gt;

    $prove-&gt;process_args(@args);

Processes the command-line arguments. Attributes will be set
appropriately. Any filenames may be found in the C&lt;argv&gt; attribute.

Dies on invalid arguments.

=cut

sub process_args {
    my $self = shift;

    my @rc = RC_FILE;
    unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;

    # Preprocess meta-args.
    my @args;
    while ( defined( my $arg = shift ) ) {
        if ( $arg eq '--norc' ) {
            @rc = ();
        }
        elsif ( $arg eq '--rc' ) {
            defined( my $rc = shift )
              or croak "Missing argument to --rc";
            push @rc, $rc;
        }
        elsif ( $arg =~ m{^--rc=(.+)$} ) {
            push @rc, $1;
        }
        else {
            push @args, $arg;
        }
    }

    # Everything after the arisdottle '::' gets passed as args to
    # test programs.
    if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
        my @test_args = splice @args, $stop_at;
        shift @test_args;
        $self-&gt;{test_args} = \@test_args;
    }

    # Grab options from RC files
    $self-&gt;add_rc_file($_) for grep -f, @rc;
    unshift @args, @{ $self-&gt;{rc_opts} };

    if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
        die "Long options should be written with two dashes: ",
          join( ', ', @bad ), "\n";
    }

    # And finally...

    {
        local @ARGV = @args;
        Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));

        # Don't add coderefs to GetOptions
        GetOptions(
            'v|verbose'  =&gt; \$self-&gt;{verbose},
            'f|failures' =&gt; \$self-&gt;{failures},
            'o|comments' =&gt; \$self-&gt;{comments},
            'l|lib'      =&gt; \$self-&gt;{lib},
            'b|blib'     =&gt; \$self-&gt;{blib},
            's|shuffle'  =&gt; \$self-&gt;{shuffle},
            'color!'     =&gt; \$self-&gt;{color},
            'colour!'    =&gt; \$self-&gt;{color},
            'count!'     =&gt; \$self-&gt;{show_count},
            'c'          =&gt; \$self-&gt;{color},
            'D|dry'      =&gt; \$self-&gt;{dry},
            'ext=s@'     =&gt; sub {
                my ( $opt, $val ) = @_;

                # Workaround for Getopt::Long 2.25 handling of
                # multivalue options
                push @{ $self-&gt;{extensions} ||= [] }, $val;
            },
            'harness=s'    =&gt; \$self-&gt;{harness},
            'ignore-exit'  =&gt; \$self-&gt;{ignore_exit},
            'source=s@'    =&gt; $self-&gt;{sources},
            'formatter=s'  =&gt; \$self-&gt;{formatter},
            'r|recurse'    =&gt; \$self-&gt;{recurse},
            'reverse'      =&gt; \$self-&gt;{backwards},
            'p|parse'      =&gt; \$self-&gt;{parse},
            'q|quiet'      =&gt; \$self-&gt;{quiet},
            'Q|QUIET'      =&gt; \$self-&gt;{really_quiet},
            'e|exec=s'     =&gt; \$self-&gt;{exec},
            'm|merge'      =&gt; \$self-&gt;{merge},
            'I=s@'         =&gt; $self-&gt;{includes},
            'M=s@'         =&gt; $self-&gt;{modules},
            'P=s@'         =&gt; $self-&gt;{plugins},
            'state=s@'     =&gt; $self-&gt;{state},
            'statefile=s'  =&gt; \$self-&gt;{statefile},
            'directives'   =&gt; \$self-&gt;{directives},
            'h|help|?'     =&gt; \$self-&gt;{show_help},
            'H|man'        =&gt; \$self-&gt;{show_man},
            'V|version'    =&gt; \$self-&gt;{show_version},
            'a|archive=s'  =&gt; \$self-&gt;{archive},
            'j|jobs=i'     =&gt; \$self-&gt;{jobs},
            'timer'        =&gt; \$self-&gt;{timer},
            'T'            =&gt; \$self-&gt;{taint_fail},
            't'            =&gt; \$self-&gt;{taint_warn},
            'W'            =&gt; \$self-&gt;{warnings_fail},
            'w'            =&gt; \$self-&gt;{warnings_warn},
            'normalize'    =&gt; \$self-&gt;{normalize},
            'rules=s@'     =&gt; $self-&gt;{rules},
            'tapversion=s' =&gt; \$self-&gt;{tapversion},
            'trap'         =&gt; \$self-&gt;{trap},
        ) or croak('Unable to continue');

        # Stash the remainder of argv for later
        $self-&gt;{argv} = [@ARGV];
    }

    return;
}

sub _first_pos {
    my $want = shift;
    for ( 0 .. $#_ ) {
        return $_ if $_[$_] eq $want;
    }
    return;
}

sub _help {
    my ( $self, $verbosity ) = @_;

    eval('use Pod::Usage 1.12 ()');
    if ( my $err = $@ ) {
        die 'Please install Pod::Usage for the --help option '
          . '(or try `perldoc prove`.)'
          . "\n ($@)";
    }

    Pod::Usage::pod2usage( { -verbose =&gt; $verbosity } );

    return;
}

sub _color_default {
    my $self = shift;

    return -t STDOUT &amp;&amp; !$ENV{HARNESS_NOTTY};
}

sub _get_args {
    my $self = shift;

    my %args;

    $args{trap} = 1 if $self-&gt;trap;

    if ( defined $self-&gt;color ? $self-&gt;color : $self-&gt;_color_default ) {
        $args{color} = 1;
    }
    if ( !defined $self-&gt;show_count ) {
        $args{show_count} = 1;
    }
    else {
        $args{show_count} = $self-&gt;show_count;
    }

    if ( $self-&gt;archive ) {
        $self-&gt;require_harness( archive =&gt; 'TAP::Harness::Archive' );
        $args{archive} = $self-&gt;archive;
    }

    if ( my $jobs = $self-&gt;jobs ) {
        $args{jobs} = $jobs;
    }

    if ( my $harness_opt = $self-&gt;harness ) {
        $self-&gt;require_harness( harness =&gt; $harness_opt );
    }

    if ( my $formatter = $self-&gt;formatter ) {
        $args{formatter_class} = $formatter;
    }

    for my $handler ( @{ $self-&gt;sources } ) {
        my ( $name, $config ) = $self-&gt;_parse_source($handler);
        $args{sources}-&gt;{$name} = $config;
    }

    if ( $self-&gt;ignore_exit ) {
        $args{ignore_exit} = 1;
    }

    if ( $self-&gt;taint_fail &amp;&amp; $self-&gt;taint_warn ) {
        die '-t and -T are mutually exclusive';
    }

    if ( $self-&gt;warnings_fail &amp;&amp; $self-&gt;warnings_warn ) {
        die '-w and -W are mutually exclusive';
    }

    for my $a (qw( lib switches )) {
        my $method = "_get_$a";
        my $val    = $self-&gt;$method();
        $args{$a} = $val if defined $val;
    }

    # Handle verbose, quiet, really_quiet flags
    my %verb_map = ( verbose =&gt; 1, quiet =&gt; -1, really_quiet =&gt; -2, );

    my @verb_adj = map { $self-&gt;$_() ? $verb_map{$_} : () }
      keys %verb_map;

    die "Only one of verbose, quiet or really_quiet should be specified\n"
      if @verb_adj &gt; 1;

    $args{verbosity} = shift @verb_adj if @verb_adj;

    for my $a (qw( merge failures comments timer directives normalize )) {
        $args{$a} = 1 if $self-&gt;$a();
    }

    $args{errors} = 1 if $self-&gt;parse;

    # defined but zero-length exec runs test files as binaries
    $args{exec} = [ split( /\s+/, $self-&gt;exec ) ]
      if ( defined( $self-&gt;exec ) );

    $args{version} = $self-&gt;tapversion if defined( $self-&gt;tapversion );

    if ( defined( my $test_args = $self-&gt;test_args ) ) {
        $args{test_args} = $test_args;
    }

    if ( @{ $self-&gt;rules } ) {
        my @rules;
        for ( @{ $self-&gt;rules } ) {
            if (/^par=(.*)/) {
                push @rules, $1;
            }
            elsif (/^seq=(.*)/) {
                push @rules, { seq =&gt; $1 };
            }
        }
        $args{rules} = { par =&gt; [@rules] };
    }
    $args{harness_class} = $self-&gt;{harness_class} if $self-&gt;{harness_class};

    return \%args;
}

sub _find_module {
    my ( $self, $class, @search ) = @_;

    croak "Bad module name $class"
      unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;

    for my $pfx (@search) {
        my $name = join( '::', $pfx, $class );
        eval "require $name";
        return $name unless $@;
    }

    eval "require $class";
    return $class unless $@;
    return;
}

sub _load_extension {
    my ( $self, $name, @search ) = @_;

    my @args = ();
    if ( $name =~ /^(.*?)=(.*)/ ) {
        $name = $1;
        @args = split( /,/, $2 );
    }

    if ( my $class = $self-&gt;_find_module( $name, @search ) ) {
        $class-&gt;import(@args);
        if ( $class-&gt;can('load') ) {
            $class-&gt;load( { app_prove =&gt; $self, args =&gt; [@args] } );
        }
    }
    else {
        croak "Can't load module $name";
    }
}

sub _load_extensions {
    my ( $self, $ext, @search ) = @_;
    $self-&gt;_load_extension( $_, @search ) for @$ext;
}

sub _parse_source {
    my ( $self, $handler ) = @_;

    # Load any options.
    ( my $opt_name = lc $handler ) =~ s/::/-/g;
    local @ARGV = @{ $self-&gt;{argv} };
    my %config;
    Getopt::Long::GetOptions(
        "$opt_name-option=s%" =&gt; sub {
            my ( $name, $k, $v ) = @_;
            if ( $v =~ /(?&lt;!\\)=/ ) {

                # It's a hash option.
                croak "Option $name must be consistently used as a hash"
                  if exists $config{$k} &amp;&amp; ref $config{$k} ne 'HASH';
                $config{$k} ||= {};
                my ( $hk, $hv ) = split /(?&lt;!\\)=/, $v, 2;
                $config{$k}{$hk} = $hv;
            }
            else {
                $v =~ s/\\=/=/g;
                if ( exists $config{$k} ) {
                    $config{$k} = [ $config{$k} ]
                      unless ref $config{$k} eq 'ARRAY';
                    push @{ $config{$k} } =&gt; $v;
                }
                else {
                    $config{$k} = $v;
                }
            }
        }
    );
    $self-&gt;{argv} = \@ARGV;
    return ( $handler, \%config );
}

=head3 C&lt;run&gt;

Perform whatever actions the command line args specified. The C&lt;prove&gt;
command line tool consists of the following code:

    use App::Prove;

    my $app = App::Prove-&gt;new;
    $app-&gt;process_args(@ARGV);
    exit( $app-&gt;run ? 0 : 1 );  # if you need the exit code

=cut

sub run {
    my $self = shift;

    unless ( $self-&gt;state_manager ) {
        $self-&gt;state_manager(
            $self-&gt;state_class-&gt;new( { store =&gt; $self-&gt;statefile || STATE_FILE } ) );
    }

    if ( $self-&gt;show_help ) {
        $self-&gt;_help(1);
    }
    elsif ( $self-&gt;show_man ) {
        $self-&gt;_help(2);
    }
    elsif ( $self-&gt;show_version ) {
        $self-&gt;print_version;
    }
    elsif ( $self-&gt;dry ) {
        print "$_\n" for $self-&gt;_get_tests;
    }
    else {

        $self-&gt;_load_extensions( $self-&gt;modules );
        $self-&gt;_load_extensions( $self-&gt;plugins, PLUGINS );

        local $ENV{TEST_VERBOSE} = 1 if $self-&gt;verbose;

        return $self-&gt;_runtests( $self-&gt;_get_args, $self-&gt;_get_tests );
    }

    return 1;
}

sub _get_tests {
    my $self = shift;

    my $state = $self-&gt;state_manager;
    my $ext   = $self-&gt;extensions;
    $state-&gt;extensions($ext) if defined $ext;
    if ( defined( my $state_switch = $self-&gt;state ) ) {
        $state-&gt;apply_switch(@$state_switch);
    }

    my @tests = $state-&gt;get_tests( $self-&gt;recurse, @{ $self-&gt;argv } );

    $self-&gt;_shuffle(@tests) if $self-&gt;shuffle;
    @tests = reverse @tests if $self-&gt;backwards;

    return @tests;
}

sub _runtests {
    my ( $self, $args, @tests ) = @_;
    my $harness = TAP::Harness::Env-&gt;create($args);

    my $state = $self-&gt;state_manager;

    $harness-&gt;callback(
        after_test =&gt; sub {
            $state-&gt;observe_test(@_);
        }
    );

    $harness-&gt;callback(
        after_runtests =&gt; sub {
            $state-&gt;commit(@_);
        }
    );

    my $aggregator = $harness-&gt;runtests(@tests);

    return !$aggregator-&gt;has_errors;
}

sub _get_switches {
    my $self = shift;
    my @switches;

    # notes that -T or -t must be at the front of the switches!
    if ( $self-&gt;taint_fail ) {
        push @switches, '-T';
    }
    elsif ( $self-&gt;taint_warn ) {
        push @switches, '-t';
    }
    if ( $self-&gt;warnings_fail ) {
        push @switches, '-W';
    }
    elsif ( $self-&gt;warnings_warn ) {
        push @switches, '-w';
    }

    return @switches ? \@switches : ();
}

sub _get_lib {
    my $self = shift;
    my @libs;
    if ( $self-&gt;lib ) {
        push @libs, 'lib';
    }
    if ( $self-&gt;blib ) {
        push @libs, 'blib/lib', 'blib/arch';
    }
    if ( @{ $self-&gt;includes } ) {
        push @libs, @{ $self-&gt;includes };
    }

    #24926
    @libs = map { File::Spec-&gt;rel2abs($_) } @libs;

    # Huh?
    return @libs ? \@libs : ();
}

sub _shuffle {
    my $self = shift;

    # Fisher-Yates shuffle
    my $i = @_;
    while ($i) {
        my $j = rand $i--;
        @_[ $i, $j ] = @_[ $j, $i ];
    }
    return;
}

=head3 C&lt;require_harness&gt;

Load a harness replacement class.

  $prove-&gt;require_harness($for =&gt; $class_name);

=cut

sub require_harness {
    my ( $self, $for, $class ) = @_;

    my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;

    # Emulate Perl's -MModule=arg1,arg2 behaviour
    $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;

    eval("use $class;");
    die "$class_name is required to use the --$for feature: $@" if $@;

    $self-&gt;{harness_class} = $class_name;

    return;
}

=head3 C&lt;print_version&gt;

Display the version numbers of the loaded L&lt;TAP::Harness&gt; and the
current Perl.

=cut

sub print_version {
    my $self = shift;
    require TAP::Harness;
    printf(
        "TAP::Harness v%s and Perl v%vd\n",
        $TAP::Harness::VERSION, $^V
    );

    return;
}

1;

# vim:ts=4:sw=4:et:sta

__END__

=head2 Attributes

After command line parsing the following attributes reflect the values
of the corresponding command line switches. They may be altered before
calling C&lt;run&gt;.

=over

=item C&lt;archive&gt;

=item C&lt;argv&gt;

=item C&lt;backwards&gt;

=item C&lt;blib&gt;

=item C&lt;color&gt;

=item C&lt;directives&gt;

=item C&lt;dry&gt;

=item C&lt;exec&gt;

=item C&lt;extensions&gt;

=item C&lt;failures&gt;

=item C&lt;comments&gt;

=item C&lt;formatter&gt;

=item C&lt;harness&gt;

=item C&lt;ignore_exit&gt;

=item C&lt;includes&gt;

=item C&lt;jobs&gt;

=item C&lt;lib&gt;

=item C&lt;merge&gt;

=item C&lt;modules&gt;

=item C&lt;parse&gt;

=item C&lt;plugins&gt;

=item C&lt;quiet&gt;

=item C&lt;really_quiet&gt;

=item C&lt;recurse&gt;

=item C&lt;rules&gt;

=item C&lt;show_count&gt;

=item C&lt;show_help&gt;

=item C&lt;show_man&gt;

=item C&lt;show_version&gt;

=item C&lt;shuffle&gt;

=item C&lt;state&gt;

=item C&lt;state_class&gt;

=item C&lt;taint_fail&gt;

=item C&lt;taint_warn&gt;

=item C&lt;test_args&gt;

=item C&lt;timer&gt;

=item C&lt;verbose&gt;

=item C&lt;warnings_fail&gt;

=item C&lt;warnings_warn&gt;

=item C&lt;tapversion&gt;

=item C&lt;trap&gt;

=back

=head1 PLUGINS

C&lt;App::Prove&gt; provides support for 3rd-party plugins.  These are currently
loaded at run-time, I&lt;after&gt; arguments have been parsed (so you can not
change the way arguments are processed, sorry), typically with the
C&lt;&lt; -PI&lt;plugin&gt; &gt;&gt; switch, eg:

  prove -PMyPlugin

This will search for a module named C&lt;App::Prove::Plugin::MyPlugin&gt;, or failing
that, C&lt;MyPlugin&gt;.  If the plugin can't be found, C&lt;prove&gt; will complain &amp; exit.

You can pass an argument to your plugin by appending an C&lt;=&gt; after the plugin
name, eg C&lt;-PMyPlugin=foo&gt;.  You can pass multiple arguments using commas:

  prove -PMyPlugin=foo,bar,baz

These are passed in to your plugin's C&lt;load()&gt; class method (if it has one),
along with a reference to the C&lt;App::Prove&gt; object that is invoking your plugin:

  sub load {
      my ($class, $p) = @_;

      my @args = @{ $p-&gt;{args} };
      # @args will contain ( 'foo', 'bar', 'baz' )
      $p-&gt;{app_prove}-&gt;do_something;
      ...
  }

Note that the user's arguments are also passed to your plugin's C&lt;import()&gt;
function as a list, eg:

  sub import {
      my ($class, @args) = @_;
      # @args will contain ( 'foo', 'bar', 'baz' )
      ...
  }

This is for backwards compatibility, and may be deprecated in the future.

=head2 Sample Plugin

Here's a sample plugin, for your reference:

  package App::Prove::Plugin::Foo;

  # Sample plugin, try running with:
  # prove -PFoo=bar -r -j3
  # prove -PFoo -Q
  # prove -PFoo=bar,My::Formatter

  use strict;
  use warnings;

  sub load {
      my ($class, $p) = @_;
      my @args = @{ $p-&gt;{args} };
      my $app  = $p-&gt;{app_prove};

      print "loading plugin: $class, args: ", join(', ', @args ), "\n";

      # turn on verbosity
      $app-&gt;verbose( 1 );

      # set the formatter?
      $app-&gt;formatter( $args[1] ) if @args &gt; 1;

      # print some of App::Prove's state:
      for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
          my $val = $app-&gt;$attr;
          $val    = 'undef' unless defined( $val );
          print "$attr: $val\n";
      }

      return 1;
  }

  1;

=head1 SEE ALSO

L&lt;prove&gt;, L&lt;TAP::Harness&gt;

=cut
</pre></body></html>