1#@!#!123s

: / proc / thread-self / root / proc / thread-self / root / home / vblioqus / karachi777.vip / in / 106014 / 900508 /
Filename : App.zip
back
PK�����dYf\�g���������Cpan.pmnu��[�����������package App::Cpan;

use strict;
use warnings;
use vars qw($VERSION);

use if $] < 5.008 => 'IO::Scalar';

$VERSION = '1.66';

=head1 NAME

App::Cpan - easily interact with CPAN from the command line

=head1 SYNOPSIS

	# with arguments and no switches, installs specified modules
	cpan module_name [ module_name ... ]

	# with switches, installs modules with extra behavior
	cpan [-cfFimtTw] module_name [ module_name ... ]

	# use local::lib
	cpan -I module_name [ module_name ... ]

	# one time mirror override for faster mirrors
	cpan -p ...

	# with just the dot, install from the distribution in the
	# current directory
	cpan .

	# without arguments, starts CPAN.pm shell
	cpan

	# without arguments, but some switches
	cpan [-ahpruvACDLOPX]

=head1 DESCRIPTION

This script provides a command interface (not a shell) to CPAN. At the
moment it uses CPAN.pm to do the work, but it is not a one-shot command
runner for CPAN.pm.

=head2 Options

=over 4

=item -a

Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.

=item -A module [ module ... ]

Shows the primary maintainers for the specified modules.

=item -c module

Runs a `make clean` in the specified module's directories.

=item -C module [ module ... ]

Show the F<Changes> files for the specified modules

=item -D module [ module ... ]

Show the module details. This prints one line for each out-of-date module
(meaning, modules locally installed but have newer versions on CPAN).
Each line has three columns: module name, local version, and CPAN
version.

=item -f

Force the specified action, when it normally would have failed. Use this
to install a module even if its tests fail. When you use this option,
-i is not optional for installing a module when you need to force it:

	% cpan -f -i Module::Foo

=item -F

Turn off CPAN.pm's attempts to lock anything. You should be careful with
this since you might end up with multiple scripts trying to muck in the
same directory. This isn't so much of a concern if you're loading a special
config with C<-j>, and that config sets up its own work directories.

=item -g module [ module ... ]

Downloads to the current directory the latest distribution of the module.

=item -G module [ module ... ]

UNIMPLEMENTED

Download to the current directory the latest distribution of the
modules, unpack each distribution, and create a git repository for each
distribution.

If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
distribution.

=item -h

Print a help message and exit. When you specify C<-h>, it ignores all
of the other options and arguments.

=item -i module [ module ... ]

Install the specified modules. With no other switches, this switch
is implied.

=item -I

Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
C<-l> was already taken.

=item -j Config.pm

Load the file that has the CPAN configuration data. This should have the
same format as the standard F<CPAN/Config.pm> file, which defines
C<$CPAN::Config> as an anonymous hash.

=item -J

Dump the configuration in the same format that CPAN.pm uses. This is useful
for checking the configuration as well as using the dump as a starting point
for a new, custom configuration.

=item -l

List all installed modules with their versions

=item -L author [ author ... ]

List the modules by the specified authors.

=item -m

Make the specified modules.

=item -M mirror1,mirror2,...

A comma-separated list of mirrors to use for just this run. The C<-P>
option can find them for you automatically.

=item -n

Do a dry run, but don't actually install anything. (unimplemented)

=item -O

Show the out-of-date modules.

=item -p

Ping the configured mirrors and print a report

=item -P

Find the best mirrors you could be using and use them for the current
session.

=item -r

Recompiles dynamically loaded modules with CPAN::Shell->recompile.

=item -s

Drop in the CPAN.pm shell. This command does this automatically if you don't
specify any arguments.

=item -t module [ module ... ]

Run a `make test` on the specified modules.

=item -T

Do not test modules. Simply install them.

=item -u

Upgrade all installed modules. Blindly doing this can really break things,
so keep a backup.

=item -v

Print the script version and CPAN.pm version then exit.

=item -V

Print detailed information about the cpan client.

=item -w

UNIMPLEMENTED

Turn on cpan warnings. This checks various things, like directory permissions,
and tells you about problems you might have.

=item -x module [ module ... ]

Find close matches to the named modules that you think you might have
mistyped. This requires the optional installation of Text::Levenshtein or
Text::Levenshtein::Damerau.

=item -X

Dump all the namespaces to standard output.

=back

=head2 Examples

	# print a help message
	cpan -h

	# print the version numbers
	cpan -v

	# create an autobundle
	cpan -a

	# recompile modules
	cpan -r

	# upgrade all installed modules
	cpan -u

	# install modules ( sole -i is optional )
	cpan -i Netscape::Booksmarks Business::ISBN

	# force install modules ( must use -i )
	cpan -fi CGI::Minimal URI

	# install modules but without testing them
	cpan -Ti CGI::Minimal URI

=head2 Environment variables

There are several components in CPAN.pm that use environment variables.
The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
while others matter to the levels above them. Some of these are specified
by the Perl Toolchain Gang:

Lancaster Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>

Oslo Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md>

=over 4

=item NONINTERACTIVE_TESTING

Assume no one is paying attention and skips prompts for distributions
that do that correctly. C<cpan(1)> sets this to C<1> unless it already
has a value (even if that value is false).

=item PERL_MM_USE_DEFAULT

Use the default answer for a prompted questions. C<cpan(1)> sets this
to C<1> unless it already has a value (even if that value is false).

=item CPAN_OPTS

As with C<PERL5OPTS>, a string of additional C<cpan(1)> options to
add to those you specify on the command line.

=item CPANSCRIPT_LOGLEVEL

The log level to use, with either the embedded, minimal logger or
L<Log::Log4perl> if it is installed. Possible values are the same as
the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
C<ERROR>, and C<FATAL>. The default is C<INFO>.

=item GIT_COMMAND

The path to the C<git> binary to use for the Git features. The default
is C</usr/local/bin/git>.

=back

=head2 Methods

=over 4

=cut

use autouse Carp => qw(carp croak cluck);
use CPAN 1.80 (); # needs no test
use Config;
use autouse Cwd => qw(cwd);
use autouse 'Data::Dumper' => qw(Dumper);
use File::Spec::Functions qw(catfile file_name_is_absolute rel2abs);
use File::Basename;
use Getopt::Std;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Internal constants
use constant TRUE  => 1;
use constant FALSE => 0;


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The return values
use constant HEY_IT_WORKED              =>   0;
use constant I_DONT_KNOW_WHAT_HAPPENED  =>   1; # 0b0000_0001
use constant ITS_NOT_MY_FAULT           =>   2;
use constant THE_PROGRAMMERS_AN_IDIOT   =>   4;
use constant A_MODULE_FAILED_TO_INSTALL =>   8;


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# set up the order of options that we layer over CPAN::Shell
BEGIN { # most of this should be in methods
use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS  @option_order
	%Method_table %Method_table_index );

@META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w x X );

$Default = 'default';

%CPAN_METHODS = ( # map switches to method names in CPAN::Shell
	$Default => 'install',
	'c'      => 'clean',
	'f'      => 'force',
	'i'      => 'install',
	'm'      => 'make',
	't'      => 'test',
	'u'      => 'upgrade',
	'T'      => 'notest',
	's'      => 'shell',
	);
@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;

@option_order = ( @META_OPTIONS, @CPAN_OPTIONS );


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# map switches to the subroutines in this script, along with other information.
# use this stuff instead of hard-coded indices and values
sub NO_ARGS   () { 0 }
sub ARGS      () { 1 }
sub GOOD_EXIT () { 0 }

%Method_table = (
# key => [ sub ref, takes args?, exit value, description ]

	# options that do their thing first, then exit
	h =>  [ \&_print_help,        NO_ARGS, GOOD_EXIT, 'Printing help'                ],
	v =>  [ \&_print_version,     NO_ARGS, GOOD_EXIT, 'Printing version'             ],
	V =>  [ \&_print_details,     NO_ARGS, GOOD_EXIT, 'Printing detailed version'    ],
	X =>  [ \&_list_all_namespaces, NO_ARGS, GOOD_EXIT, 'Listing all namespaces'      ],

	# options that affect other options
	j =>  [ \&_load_config,          ARGS, GOOD_EXIT, 'Use specified config file'    ],
	J =>  [ \&_dump_config,       NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ],
	F =>  [ \&_lock_lobotomy,     NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files'  ],
	I =>  [ \&_load_local_lib,    NO_ARGS, GOOD_EXIT, 'Loading local::lib'           ],
	M =>  [ \&_use_these_mirrors,    ARGS, GOOD_EXIT, 'Setting per session mirrors'  ],
	P =>  [ \&_find_good_mirrors, NO_ARGS, GOOD_EXIT, 'Finding good mirrors'         ],
    w =>  [ \&_turn_on_warnings,  NO_ARGS, GOOD_EXIT, 'Turning on warnings'          ],

	# options that do their one thing
	g =>  [ \&_download,             ARGS, GOOD_EXIT, 'Download the latest distro'        ],
	G =>  [ \&_gitify,               ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],

	C =>  [ \&_show_Changes,         ARGS, GOOD_EXIT, 'Showing Changes file'         ],
	A =>  [ \&_show_Author,          ARGS, GOOD_EXIT, 'Showing Author'               ],
	D =>  [ \&_show_Details,         ARGS, GOOD_EXIT, 'Showing Details'              ],
	O =>  [ \&_show_out_of_date,  NO_ARGS, GOOD_EXIT, 'Showing Out of date'          ],
	l =>  [ \&_list_all_mods,     NO_ARGS, GOOD_EXIT, 'Listing all modules'          ],

	L =>  [ \&_show_author_mods,     ARGS, GOOD_EXIT, 'Showing author mods'          ],
	a =>  [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle'          ],
	p =>  [ \&_ping_mirrors,      NO_ARGS, GOOD_EXIT, 'Pinging mirrors'              ],

	r =>  [ \&_recompile,         NO_ARGS, GOOD_EXIT, 'Recompiling'                  ],
	u =>  [ \&_upgrade,           NO_ARGS, GOOD_EXIT, 'Running `make test`'          ],
   's' => [ \&_shell,            NO_ARGS, GOOD_EXIT, 'Running `make test`'          ],

   'x' => [ \&_guess_namespace,      ARGS, GOOD_EXIT, 'Guessing namespaces'          ],
	c =>  [ \&_default,              ARGS, GOOD_EXIT, 'Running `make clean`'         ],
	f =>  [ \&_default,              ARGS, GOOD_EXIT, 'Installing with force'        ],
	i =>  [ \&_default,              ARGS, GOOD_EXIT, 'Running `make install`'       ],
   'm' => [ \&_default,              ARGS, GOOD_EXIT, 'Running `make`'               ],
	t =>  [ \&_default,              ARGS, GOOD_EXIT, 'Running `make test`'          ],
	T =>  [ \&_default,              ARGS, GOOD_EXIT, 'Installing with notest'       ],
	);

%Method_table_index = (
	code        => 0,
	takes_args  => 1,
	exit_value  => 2,
	description => 3,
	);
}


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# finally, do some argument processing

sub _stupid_interface_hack_for_non_rtfmers
	{
	no warnings 'uninitialized';
	shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
	}

sub _process_options
	{
	my %options;

	push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';

	# if no arguments, just drop into the shell
	if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
	else
		{
		Getopt::Std::getopts(
		  join( '', @option_order ), \%options );
		 \%options;
		}
	}

sub _process_setup_options
	{
	my( $class, $options ) = @_;

	if( $options->{j} )
		{
		$Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
		delete $options->{j};
		}
	elsif ( ! $options->{h} ) # h "ignores all of the other options and arguments"
		{
		# this is what CPAN.pm would do otherwise
		local $CPAN::Be_Silent = 1;
		CPAN::HandleConfig->load(
			# be_silent  => 1, deprecated
			write_file => 0,
			);
		}

	$class->_turn_off_testing if $options->{T};

	foreach my $o ( qw(F I w P M) )
		{
		next unless exists $options->{$o};
		$Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
		delete $options->{$o};
		}

	if( $options->{o} )
		{
		my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
		foreach my $pair ( @pairs )
			{
			my( $setting, $value ) = @$pair;
			$CPAN::Config->{$setting} = $value;
		#	$logger->debug( "Setting [$setting] to [$value]" );
			}
		delete $options->{o};
		}

	my $option_count = grep { $options->{$_} } @option_order;
	no warnings 'uninitialized';

	# don't count options that imply installation
	foreach my $opt ( qw(f T) ) { # don't count force or notest
		$option_count -= $options->{$opt};
		}

	# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
	# if there are no options, set -i (this line fixes RT ticket 16915)
	$options->{i}++ unless $option_count;
	}

sub _setup_environment {
# should we override or set defaults? If this were a true interactive
# session, we'd be in the CPAN shell.

# https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
	$ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
	$ENV{PERL_MM_USE_DEFAULT}    = 1 unless defined $ENV{PERL_MM_USE_DEFAULT};
	}

=item run()

Just do it.

The C<run> method returns 0 on success and a positive number on
failure. See the section on EXIT CODES for details on the values.

=cut

my $logger;

sub run
	{
	my $class = shift;

	my $return_value = HEY_IT_WORKED; # assume that things will work

	$logger = $class->_init_logger;
	$logger->debug( "Using logger from @{[ref $logger]}" );

	$class->_hook_into_CPANpm_report;
	$logger->debug( "Hooked into output" );

	$class->_stupid_interface_hack_for_non_rtfmers;
	$logger->debug( "Patched cargo culting" );

	my $options = $class->_process_options;
	$logger->debug( "Options are @{[Dumper($options)]}" );

	$class->_process_setup_options( $options );

	$class->_setup_environment( $options );

	OPTION: foreach my $option ( @option_order )
		{
		next unless $options->{$option};

		my( $sub, $takes_args, $description ) =
			map { $Method_table{$option}[ $Method_table_index{$_} ] }
			qw( code takes_args description );

		unless( ref $sub eq ref sub {} )
			{
			$return_value = THE_PROGRAMMERS_AN_IDIOT;
			last OPTION;
			}

		$logger->info( "[$option] $description -- ignoring other arguments" )
			if( @ARGV && ! $takes_args );

		$return_value = $sub->( \ @ARGV, $options );

		last;
		}

	return $return_value;
	}

{
package
  Local::Null::Logger; # hide from PAUSE

sub new { bless \ my $x, $_[0] }
sub AUTOLOAD { 1 }
sub DESTROY { 1 }
}

# load a module without searching the default entry for the current
# directory
sub _safe_load_module {
    my $name = shift;

    local @INC = @INC;
    pop @INC if $INC[-1] eq '.';

    eval "require $name; 1";
}

sub _init_logger
	{
	my $log4perl_loaded = _safe_load_module("Log::Log4perl");

    unless( $log4perl_loaded )
        {
        print STDERR "Loading internal null logger. Install Log::Log4perl for logging messages\n";
        $logger = Local::Null::Logger->new;
        return $logger;
        }

	my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';

	Log::Log4perl::init( \ <<"HERE" );
log4perl.rootLogger=$LEVEL, A1
log4perl.appender.A1=Log::Log4perl::Appender::Screen
log4perl.appender.A1.layout=PatternLayout
log4perl.appender.A1.layout.ConversionPattern=%m%n
HERE

	$logger = Log::Log4perl->get_logger( 'App::Cpan' );
	}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

sub _default
	{
	my( $args, $options ) = @_;

	my $switch = '';

	# choose the option that we're going to use
	# we'll deal with 'f' (force) later, so skip it
	foreach my $option ( @CPAN_OPTIONS )
		{
		next if ( $option eq 'f' or $option eq 'T' );
		next unless $options->{$option};
		$switch = $option;
		last;
		}

	# 1. with no switches, but arguments, use the default switch (install)
	# 2. with no switches and no args, start the shell
	# 3. With a switch but no args, die! These switches need arguments.
	   if( not $switch and     @$args ) { $switch = $Default;  }
	elsif( not $switch and not @$args ) { return CPAN::shell() }
	elsif(     $switch and not @$args )
		{ die "Nothing to $CPAN_METHODS{$switch}!\n"; }

	# Get and check the method from CPAN::Shell
	my $method = $CPAN_METHODS{$switch};
	die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );

	# call the CPAN::Shell method, with force or notest if specified
	my $action = do {
		   if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ )  } }
		elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } }
		else                   { sub { CPAN::Shell->$method( @_ )         } }
		};

	# How do I handle exit codes for multiple arguments?
	my @errors = ();

	foreach my $arg ( @$args )
		{
		# check the argument and perhaps capture typos
		my $module = _expand_module( $arg ) or do {
			$logger->error( "Skipping $arg because I couldn't find a matching namespace." );
			next;
			};

		_clear_cpanpm_output();
		$action->( $arg );

		my $error = _cpanpm_output_indicates_failure();
		push @errors, $error if $error;
		}

	return do {
		if( @errors ) { $errors[0] }
		else { HEY_IT_WORKED }
		};

	}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

=for comment

CPAN.pm sends all the good stuff either to STDOUT, or to a temp
file if $CPAN::Be_Silent is set. I have to intercept that output
so I can find out what happened.

=cut

BEGIN {
my $scalar = '';

sub _hook_into_CPANpm_report
	{
	no warnings 'redefine';

	*CPAN::Shell::myprint = sub {
		my($self,$what) = @_;
		$scalar .= $what;
		$self->print_ornamented($what,
			$CPAN::Config->{colorize_print}||'bold blue on_white',
			);
		};

	*CPAN::Shell::mywarn = sub {
		my($self,$what) = @_;
		$scalar .= $what;
		$self->print_ornamented($what,
			$CPAN::Config->{colorize_warn}||'bold red on_white'
			);
		};

	}

sub _clear_cpanpm_output { $scalar = '' }

sub _get_cpanpm_output   { $scalar }

# These are lines I don't care about in CPAN.pm output. If I can
# filter out the informational noise, I have a better chance to
# catch the error signal
my @skip_lines = (
	qr/^\QWarning \(usually harmless\)/,
	qr/\bwill not store persistent state\b/,
	qr(//hint//),
	qr/^\s+reports\s+/,
	qr/^Try the command/,
	qr/^\s+$/,
	qr/^to find objects/,
	qr/^\s*Database was generated on/,
	qr/^Going to read/,
	qr|^\s+i\s+/|,    # the i /Foo::Whatever/ line when it doesn't know
	);

sub _get_cpanpm_last_line
	{
	my $fh;

	if( $] < 5.008 ) {
		$fh = IO::Scalar->new( \ $scalar );
		}
	else {
		eval q{ open $fh, '<', \\ $scalar; };
		}

	my @lines = <$fh>;

    # This is a bit ugly. Once we examine a line, we have to
    # examine the line before it and go through all of the same
    # regexes. I could do something fancy, but this works.
    REGEXES: {
	foreach my $regex ( @skip_lines )
		{
		if( $lines[-1] =~ m/$regex/ )
            {
            pop @lines;
            redo REGEXES; # we have to go through all of them for every line!
            }
		}
	}

    $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );

	$lines[-1];
	}
}

BEGIN {
my $epic_fail_words = join '|',
	qw( Error stop(?:ping)? problems force not unsupported
		fail(?:ed)? Cannot\s+install );

sub _cpanpm_output_indicates_failure
	{
	my $last_line = _get_cpanpm_last_line();

	my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
	return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;

	$result || ();
	}
}

sub _cpanpm_output_indicates_success
	{
	my $last_line = _get_cpanpm_last_line();

	my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
	$result || ();
	}

sub _cpanpm_output_is_vague
	{
	return FALSE if
		_cpanpm_output_indicates_failure() ||
		_cpanpm_output_indicates_success();

	return TRUE;
	}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _turn_on_warnings {
	carp "Warnings are implemented yet";
	return HEY_IT_WORKED;
	}

sub _turn_off_testing {
	$logger->debug( 'Trusting test report history' );
	$CPAN::Config->{trust_test_report_history} = 1;
	return HEY_IT_WORKED;
	}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _print_help
	{
	$logger->info( "Use perldoc to read the documentation" );
	exec "perldoc $0";
	}

sub _print_version # -v
	{
	$logger->info(
		"$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );

	return HEY_IT_WORKED;
	}

sub _print_details # -V
	{
	_print_version();

	_check_install_dirs();

	$logger->info( '-' x 50 . "\nChecking configured mirrors..." );
	foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
		_print_ping_report( $mirror );
		}

	$logger->info( '-' x 50 . "\nChecking for faster mirrors..." );

	{
	require CPAN::Mirrors;

      if ( $CPAN::Config->{connect_to_internet_ok} ) {
        $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
        eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
          or $CPAN::Frontend->mywarn(<<'HERE');
We failed to get a copy of the mirror list from the Internet.
You will need to provide CPAN mirror URLs yourself.
HERE
        $CPAN::Frontend->myprint("\n");
      }

	my $mirrors   = CPAN::Mirrors->new( _mirror_file() );
	my @continents = $mirrors->find_best_continents;

	my @mirrors   = $mirrors->get_mirrors_by_continents( $continents[0] );
	my @timings   = $mirrors->get_mirrors_timings( \@mirrors );

	foreach my $timing ( @timings ) {
		$logger->info( sprintf "%s (%0.2f ms)",
			$timing->hostname, $timing->rtt );
		}
	}

	return HEY_IT_WORKED;
	}

sub _check_install_dirs
	{
	my $makepl_arg   = $CPAN::Config->{makepl_arg};
	my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};

	my @custom_dirs;
	# PERL_MM_OPT
	push @custom_dirs,
		$makepl_arg   =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
		$mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;

	if( @custom_dirs ) {
		foreach my $dir ( @custom_dirs ) {
			_print_inc_dir_report( $dir );
			}
		}

	# XXX: also need to check makepl_args, etc

	my @checks = (
		[ 'core',         [ grep $_, @Config{qw(installprivlib installarchlib)}      ] ],
		[ 'vendor',       [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
		[ 'site',         [ grep $_, @Config{qw(installsitelib installsitearch)}     ] ],
		[ 'PERL5LIB',     _split_paths( $ENV{PERL5LIB} ) ],
		[ 'PERLLIB',      _split_paths( $ENV{PERLLIB} )  ],
		);

	$logger->info( '-' x 50 . "\nChecking install dirs..." );
	foreach my $tuple ( @checks ) {
		my( $label ) = $tuple->[0];

		$logger->info( "Checking $label" );
		$logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
		foreach my $dir ( @{ $tuple->[1] } ) {
			_print_inc_dir_report( $dir );
			}
		}

	}

sub _split_paths
	{
	[ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
	}


=pod

Stolen from File::Path::Expand

=cut

sub _expand_filename
	{
    my( $path ) = @_;
    no warnings 'uninitialized';
    $logger->debug( "Expanding path $path\n" );
    $path =~ s{\A~([^/]+)?}{
		_home_of( $1 || $> ) || "~$1"
    	}e;
    return $path;
	}

sub _home_of
	{
	require User::pwent;
    my( $user ) = @_;
    my $ent = User::pwent::getpw($user) or return;
    return $ent->dir;
	}

sub _get_default_inc
	{
	require Config;

	[ @Config::Config{ _vars() }, '.' ];
	}

sub _vars {
	qw(
	installarchlib
	installprivlib
	installsitearch
	installsitelib
	);
	}

sub _ping_mirrors {
	my $urls   = $CPAN::Config->{urllist};
	require URI;

	foreach my $url ( @$urls ) {
		my( $obj ) = URI->new( $url );
		next unless _is_pingable_scheme( $obj );
		my $host = $obj->host;
		_print_ping_report( $obj );
		}

	}

sub _is_pingable_scheme {
	my( $uri ) = @_;

	$uri->scheme eq 'file'
	}

sub _mirror_file {
	my $file = do {
		my $file = 'MIRRORED.BY';
		my $local_path = File::Spec->catfile(
			$CPAN::Config->{keep_source_where}, $file );

		if( -e $local_path ) { $local_path }
		else {
			require CPAN::FTP;
			CPAN::FTP->localize( $file, $local_path, 3, 1 );
			$local_path;
			}
		};
	}

sub _find_good_mirrors {
	require CPAN::Mirrors;

	my $mirrors = CPAN::Mirrors->new( _mirror_file() );

	my @mirrors = $mirrors->best_mirrors(
		how_many   => 5,
		verbose    => 1,
		);

	foreach my $mirror ( @mirrors ) {
		next unless eval { $mirror->can( 'http' ) };
		_print_ping_report( $mirror->http );
		}

	$CPAN::Config->{urllist} = [
		map { $_->http } @mirrors
		];
	}

sub _print_inc_dir_report
	{
	my( $dir ) = shift;

	my $writeable = -w $dir ? '+' : '!!! (not writeable)';
	$logger->info( "\t$writeable $dir" );
	return -w $dir;
	}

sub _print_ping_report
	{
	my( $mirror ) = @_;

	my $rtt = eval { _get_ping_report( $mirror ) };
	my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';

	$logger->info(
		sprintf "\t%s %s", $result, $mirror
		);
	}

sub _get_ping_report
	{
	require URI;
	my( $mirror ) = @_;
	my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
	require Net::Ping;

	my $ping = Net::Ping->new( 'tcp', 1 );

	if( $url->scheme eq 'file' ) {
		return -e $url->file;
		}

    my( $port ) = $url->port;

    return unless $port;

    if ( $ping->can('port_number') ) {
        $ping->port_number($port);
    	}
    else {
        $ping->{'port_num'} = $port;
    	}

    $ping->hires(1) if $ping->can( 'hires' );
    my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
	$alive ? $rtt : undef;
	}

sub _load_local_lib # -I
	{
	$logger->debug( "Loading local::lib" );

	my $rc = _safe_load_module("local::lib");
	unless( $rc ) {
		$logger->logdie( "Could not load local::lib" );
		}

	local::lib->import;

	return HEY_IT_WORKED;
	}

sub _use_these_mirrors # -M
	{
	$logger->debug( "Setting per session mirrors" );
	unless( $_[0] ) {
		$logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
		}

	$CPAN::Config->{urllist} = [ split /,/, $_[0] ];

	$logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );

	}

sub _create_autobundle
	{
	$logger->info(
		"Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );

	CPAN::Shell->autobundle;

	return HEY_IT_WORKED;
	}

sub _recompile
	{
	$logger->info( "Recompiling dynamically-loaded extensions" );

	CPAN::Shell->recompile;

	return HEY_IT_WORKED;
	}

sub _upgrade
	{
	$logger->info( "Upgrading all modules" );

	CPAN::Shell->upgrade();

	return HEY_IT_WORKED;
	}

sub _shell
	{
	$logger->info( "Dropping into shell" );

	CPAN::shell();

	return HEY_IT_WORKED;
	}

sub _load_config # -j
	{
	my $argument = shift;

	my $file = file_name_is_absolute( $argument ) ? $argument : rel2abs( $argument );
	croak( "cpan config file [$file] for -j does not exist!\n" ) unless -e $file;

	# should I clear out any existing config here?
	$CPAN::Config = {};
	delete $INC{'CPAN/Config.pm'};

	my $rc = eval "require '$file'";

	# CPAN::HandleConfig::require_myconfig_or_config looks for this
	$INC{'CPAN/MyConfig.pm'} = 'fake out!';

	# CPAN::HandleConfig::load looks for this
	$CPAN::Config_loaded = 'fake out';

	croak( "Could not load [$file]: $@\n") unless $rc;

	return HEY_IT_WORKED;
	}

sub _dump_config # -J
	{
	my $args = shift;
	require Data::Dumper;

	my $fh = $args->[0] || \*STDOUT;

	local $Data::Dumper::Sortkeys = 1;
	my $dd = Data::Dumper->new(
		[$CPAN::Config],
		['$CPAN::Config']
		);

	print $fh $dd->Dump, "\n1;\n__END__\n";

	return HEY_IT_WORKED;
	}

sub _lock_lobotomy # -F
	{
	no warnings 'redefine';

	*CPAN::_flock    = sub { 1 };
	*CPAN::checklock = sub { 1 };

	return HEY_IT_WORKED;
	}

sub _download
	{
	my $args = shift;

	local $CPAN::DEBUG = 1;

	my %paths;

	foreach my $arg ( @$args ) {
		$logger->info( "Checking $arg" );

		my $module = _expand_module( $arg ) or next;
		my $path = $module->cpan_file;

		$logger->debug( "Inst file would be $path\n" );

		$paths{$arg} = _get_file( _make_path( $path ) );

		$logger->info( "Downloaded [$arg] to [$paths{$module}]" );
		}

	return \%paths;
	}

sub _make_path { join "/", qw(authors id), $_[0] }

sub _get_file
	{
	my $path = shift;

	my $loaded = _safe_load_module("LWP::Simple");
	croak "You need LWP::Simple to use features that fetch files from CPAN\n"
		unless $loaded;

	my $file = substr $path, rindex( $path, '/' ) + 1;
	my $store_path = catfile( cwd(), $file );
	$logger->debug( "Store path is $store_path" );

	foreach my $site ( @{ $CPAN::Config->{urllist} } )
		{
		my $fetch_path = join "/", $site, $path;
		$logger->debug( "Trying $fetch_path" );
	    last if LWP::Simple::getstore( $fetch_path, $store_path );
		}

	return $store_path;
	}

sub _gitify
	{
	my $args = shift;

	my $loaded = _safe_load_module("Archive::Extract");
	croak "You need Archive::Extract to use features that gitify distributions\n"
		unless $loaded;

	my $starting_dir = cwd();

	foreach my $arg ( @$args )
		{
		$logger->info( "Checking $arg" );
		my $store_paths = _download( [ $arg ] );
		$logger->debug( "gitify Store path is $store_paths->{$arg}" );
		my $dirname = dirname( $store_paths->{$arg} );

		my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
		$ae->extract( to => $dirname );

		chdir $ae->extract_path;

		my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
		croak "Could not find $git"    unless -e $git;
		croak "$git is not executable" unless -x $git;

		# can we do this in Pure Perl?
		system( $git, 'init'    );
		system( $git, qw( add . ) );
		system( $git, qw( commit -a -m ), 'initial import' );
		}

	chdir $starting_dir;

	return HEY_IT_WORKED;
	}

sub _show_Changes
	{
	my $args = shift;

	foreach my $arg ( @$args )
		{
		$logger->info( "Checking $arg\n" );

		my $module = _expand_module( $arg ) or next;

		my $out = _get_cpanpm_output();

		next unless eval { $module->inst_file };
		#next if $module->uptodate;

		( my $id = $module->id() ) =~ s/::/\-/;

		my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
			$id . "-" . $module->cpan_version() . "/";

		#print "URL: $url\n";
		_get_changes_file($url);
		}

	return HEY_IT_WORKED;
	}

sub _get_changes_file
	{
	croak "Reading Changes files requires LWP::Simple and URI\n"
		unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");

    my $url = shift;

    my $content = LWP::Simple::get( $url );
    $logger->info( "Got $url ..." ) if defined $content;
	#print $content;

	my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;

	my $changes_url = URI->new_abs( $change_link, $url );
 	$logger->debug( "Change link is: $changes_url" );

	my $changes =  LWP::Simple::get( $changes_url );

	print $changes;

	return HEY_IT_WORKED;
	}

sub _show_Author
	{
	my $args = shift;

	foreach my $arg ( @$args )
		{
		my $module = _expand_module( $arg ) or next;

		unless( $module )
			{
			$logger->info( "Didn't find a $arg module, so no author!" );
			next;
			}

		my $author = CPAN::Shell->expand( "Author", $module->userid );

		next unless $module->userid;

		printf "%-25s %-8s %-25s %s\n",
			$arg, $module->userid, $author->email, $author->name;
		}

	return HEY_IT_WORKED;
	}

sub _show_Details
	{
	my $args = shift;

	foreach my $arg ( @$args )
		{
		my $module = _expand_module( $arg ) or next;
		my $author = CPAN::Shell->expand( "Author", $module->userid );

		next unless $module->userid;

		print "$arg\n", "-" x 73, "\n\t";
		print join "\n\t",
			$module->description ? $module->description : "(no description)",
			$module->cpan_file ? $module->cpan_file : "(no cpanfile)",
			$module->inst_file ? $module->inst_file :"(no installation file)" ,
			'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"),
			'CPAN:      ' . $module->cpan_version . '  ' .
				($module->uptodate ? "" : "Not ") . "up to date",
			$author->fullname . " (" . $module->userid . ")",
			$author->email;
		print "\n\n";

		}

	return HEY_IT_WORKED;
	}

BEGIN {
my $modules;
sub _get_all_namespaces
	{
	return $modules if $modules;
	$modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
	}
}

sub _show_out_of_date
	{
	my $modules = _get_all_namespaces();

	printf "%-40s  %6s  %6s\n", "Module Name", "Local", "CPAN";
	print "-" x 73, "\n";

	foreach my $module ( @$modules )
		{
                next unless $module = _expand_module($module);
                next unless $module->inst_file;
		next if $module->uptodate;
		printf "%-40s  %.4f  %.4f\n",
			$module->id,
			$module->inst_version ? $module->inst_version : '',
			$module->cpan_version;
		}

	return HEY_IT_WORKED;
	}

sub _show_author_mods
	{
	my $args = shift;

	my %hash = map { lc $_, 1 } @$args;

	my $modules = _get_all_namespaces();

	foreach my $module ( @$modules ) {
		next unless exists $hash{ lc $module->userid };
		print $module->id, "\n";
		}

	return HEY_IT_WORKED;
	}

sub _list_all_mods # -l
	{
	require File::Find;

	my $args = shift;


	my $fh = \*STDOUT;

	INC: foreach my $inc ( @INC )
		{
		my( $wanted, $reporter ) = _generator();
		File::Find::find( { wanted => $wanted }, $inc );

		my $count = 0;
		FILE: foreach my $file ( @{ $reporter->() } )
			{
			my $version = _parse_version_safely( $file );

			my $module_name = _path_to_module( $inc, $file );
			next FILE unless defined $module_name;

			print $fh "$module_name\t$version\n";

			#last if $count++ > 5;
			}
		}

	return HEY_IT_WORKED;
	}

sub _generator
	{
	my @files = ();

	sub { push @files,
		File::Spec->canonpath( $File::Find::name )
		if m/\A\w+\.pm\z/ },
	sub { \@files },
	}

sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
	{
	my( $file ) = @_;

	local $/ = "\n";
	local $_; # don't mess with the $_ in the map calling this

	return unless open FILE, "<$file";

	my $in_pod = 0;
	my $version;
	while( <FILE> )
		{
		chomp;
		$in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
		next if $in_pod || /^\s*#/;

		next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
		my( $sigil, $var ) = ( $1, $2 );

		$version = _eval_version( $_, $sigil, $var );
		last;
		}
	close FILE;

	return 'undef' unless defined $version;

	return $version;
	}

sub _eval_version
	{
	my( $line, $sigil, $var ) = @_;

        # split package line to hide from PAUSE
	my $eval = qq{
		package
                  ExtUtils::MakeMaker::_version;

		local $sigil$var;
		\$$var=undef; do {
			$line
			}; \$$var
		};

	my $version = do {
		local $^W = 0;
		no strict;
		eval( $eval );
		};

	return $version;
	}

sub _path_to_module
	{
	my( $inc, $path ) = @_;
	return if length $path < length $inc;

	my $module_path = substr( $path, length $inc );
	$module_path =~ s/\.pm\z//;

	# XXX: this is cheating and doesn't handle everything right
	my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
	shift @dirs;

	my $module_name = join "::", @dirs;

	return $module_name;
	}


sub _expand_module
	{
	my( $module ) = @_;

	my $expanded = CPAN::Shell->expandany( $module );
        return $expanded if $expanded;
        $expanded = CPAN::Shell->expand( "Module", $module );
	unless( defined $expanded ) {
		$logger->error( "Could not expand [$module]. Check the module name." );
		my $threshold = (
			grep { int }
			sort { length $a <=> length $b }
				length($module)/4, 4
			)[0];

		my $guesses = _guess_at_module_name( $module, $threshold );
		if( defined $guesses and @$guesses ) {
			$logger->info( "Perhaps you meant one of these:" );
			foreach my $guess ( @$guesses ) {
				$logger->info( "\t$guess" );
				}
			}
		return;
		}

	return $expanded;
	}

my $guessers = [
	[ qw( Text::Levenshtein::XS distance 7 ) ],
	[ qw( Text::Levenshtein::Damerau::XS     xs_edistance 7 ) ],

	[ qw( Text::Levenshtein     distance 7 ) ],
	[ qw( Text::Levenshtein::Damerau::PP     pp_edistance 7 ) ],

	];

# for -x
sub _guess_namespace
	{
	my $args = shift;

	foreach my $arg ( @$args )
		{
		$logger->debug( "Checking $arg" );
		my $guesses = _guess_at_module_name( $arg );

		foreach my $guess ( @$guesses ) {
			print $guess, "\n";
			}
		}

	return HEY_IT_WORKED;
	}

sub _list_all_namespaces {
	my $modules = _get_all_namespaces();

	foreach my $module ( @$modules ) {
		print $module, "\n";
		}
	}

BEGIN {
my $distance;
sub _guess_at_module_name
	{
	my( $target, $threshold ) = @_;

	unless( defined $distance ) {
		foreach my $try ( @$guessers ) {
			my $can_guess = eval "require $try->[0]; 1" or next;

			no strict 'refs';
			$distance = \&{ join "::", @$try[0,1] };
			$threshold ||= $try->[2];
			}
		}

	unless( $distance ) {
		my $modules = join ", ", map { $_->[0] } @$guessers;
		substr $modules, rindex( $modules, ',' ), 1, ', and';

		$logger->info( "I can suggest names if you install one of $modules" );
		return;
		}

	my $modules = _get_all_namespaces();
	$logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );

	my %guesses;
	foreach my $guess ( @$modules ) {
		my $distance = $distance->( $target, $guess );
		next if $distance > $threshold;
		$guesses{$guess} = $distance;
		}

	my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
	return [ grep { defined } @guesses[0..9] ];
	}
}

1;

=back

=head1 EXIT VALUES

The script exits with zero if it thinks that everything worked, or a
positive number if it thinks that something failed. Note, however, that
in some cases it has to divine a failure by the output of things it does
not control. For now, the exit codes are vague:

	1	An unknown error

	2	The was an external problem

	4	There was an internal problem with the script

	8	A module failed to install

=head1 TO DO

* There is initial support for Log4perl if it is available, but I
haven't gone through everything to make the NullLogger work out
correctly if Log4perl is not installed.

* When I capture CPAN.pm output, I need to check for errors and
report them to the user.

* Warnings switch

* Check then exit

=head1 BUGS

* none noted

=head1 SEE ALSO

L<CPAN>, L<App::cpanminus>

=head1 SOURCE AVAILABILITY

This code is in Github in the CPAN.pm repository:

	https://github.com/andk/cpanpm

The source used to be tracked separately in another GitHub repo,
but the canonical source is now in the above repo.

=head1 CREDITS

Japheth Cleaver added the bits to allow a forced install (C<-f>).

Jim Brandt suggest and provided the initial implementation for the
up-to-date and Changes features.

Adam Kennedy pointed out that C<exit()> causes problems on Windows
where this script ends up with a .bat extension

David Golden helps integrate this into the C<CPAN.pm> repos.

=head1 AUTHOR

brian d foy, C<< <bdfoy@cpan.org> >>

=head1 COPYRIGHT

Copyright (c) 2001-2015, brian d foy, All Rights Reserved.

You may redistribute this under the same terms as Perl itself.

=cut
PK�����dYf\�g^e�-���-����Prove/State.pmnu��[�����������package App::Prove::State;

use strict;
use warnings;

use File::Find;
use File::Spec;
use Carp;

use App::Prove::State::Result;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use base 'TAP::Base';

BEGIN {
    __PACKAGE__->mk_methods('result_class');
}

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant NEED_GLOB => IS_WIN32;

=head1 NAME

App::Prove::State - State storage for the C<prove> command.

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 DESCRIPTION

The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module implements that state
and the operations that may be performed on it.

=head1 SYNOPSIS

    # Re-run failed tests
    $ prove --state=failed,save -rbv

=cut

=head1 METHODS

=head2 Class Methods

=head3 C<new>

Accepts a hashref with the following key/value pairs:

=over 4

=item * C<store>

The filename of the data store holding the data that App::Prove::State reads.

=item * C<extensions> (optional)

The test name extensions.  Defaults to C<.t>.

=item * C<result_class> (optional)

The name of the C<result_class>.  Defaults to C<App::Prove::State::Result>.

=back

=cut

# override TAP::Base::new:
sub new {
    my $class = shift;
    my %args = %{ shift || {} };

    my $self = bless {
        select     => [],
        seq        => 1,
        store      => delete $args{store},
        extensions => ( delete $args{extensions} || ['.t'] ),
        result_class =>
          ( delete $args{result_class} || 'App::Prove::State::Result' ),
    }, $class;

    $self->{_} = $self->result_class->new(
        {   tests      => {},
            generation => 1,
        }
    );
    my $store = $self->{store};
    $self->load($store)
      if defined $store && -f $store;

    return $self;
}

=head2 C<result_class>

Getter/setter for the name of the class used for tracking test results.  This
class should either subclass from C<App::Prove::State::Result> or provide an
identical interface.

=cut

=head2 C<extensions>

Get or set the list of extensions that files must have in order to be
considered tests. Defaults to ['.t'].

=cut

sub extensions {
    my $self = shift;
    $self->{extensions} = shift if @_;
    return $self->{extensions};
}

=head2 C<results>

Get the results of the last test run.  Returns a C<result_class()> instance.

=cut

sub results {
    my $self = shift;
    $self->{_} || $self->result_class->new;
}

=head2 C<commit>

Save the test results. Should be called after all tests have run.

=cut

sub commit {
    my $self = shift;
    if ( $self->{should_save} ) {
        $self->save;
    }
}

=head2 Instance Methods

=head3 C<apply_switch>

 $self->apply_switch('failed,save');

Apply a list of switch options to the state, updating the internal
object state as a result. Nothing is returned.

Diagnostics:
    - "Illegal state option: %s"

=over

=item C<last>

Run in the same order as last time

=item C<failed>

Run only the failed tests from last time

=item C<passed>

Run only the passed tests from last time

=item C<all>

Run all tests in normal order

=item C<hot>

Run the tests that most recently failed first

=item C<todo>

Run the tests ordered by number of todos.

=item C<slow>

Run the tests in slowest to fastest order.

=item C<fast>

Run test tests in fastest to slowest order.

=item C<new>

Run the tests in newest to oldest order.

=item C<old>

Run the tests in oldest to newest order.

=item C<save>

Save the state on exit.

=back

=cut

sub apply_switch {
    my $self = shift;
    my @opts = @_;

    my $last_gen      = $self->results->generation - 1;
    my $last_run_time = $self->results->last_run_time;
    my $now           = $self->get_time;

    my @switches = map { split /,/ } @opts;

    my %handler = (
        last => sub {
            $self->_select(
                limit => shift,
                where => sub { $_->generation >= $last_gen },
                order => sub { $_->sequence }
            );
        },
        failed => sub {
            $self->_select(
                limit => shift,
                where => sub { $_->result != 0 },
                order => sub { -$_->result }
            );
        },
        passed => sub {
            $self->_select(
                limit => shift,
                where => sub { $_->result == 0 }
            );
        },
        all => sub {
            $self->_select( limit => shift );
        },
        todo => sub {
            $self->_select(
                limit => shift,
                where => sub { $_->num_todo != 0 },
                order => sub { -$_->num_todo; }
            );
        },
        hot => sub {
            $self->_select(
                limit => shift,
                where => sub { defined $_->last_fail_time },
                order => sub { $now - $_->last_fail_time }
            );
        },
        slow => sub {
            $self->_select(
                limit => shift,
                order => sub { -$_->elapsed }
            );
        },
        fast => sub {
            $self->_select(
                limit => shift,
                order => sub { $_->elapsed }
            );
        },
        new => sub {
            $self->_select(
                limit => shift,
                order => sub { -$_->mtime }
            );
        },
        old => sub {
            $self->_select(
                limit => shift,
                order => sub { $_->mtime }
            );
        },
        fresh => sub {
            $self->_select(
                limit => shift,
                where => sub { $_->mtime >= $last_run_time }
            );
        },
        save => sub {
            $self->{should_save}++;
        },
        adrian => sub {
            unshift @switches, qw( hot all save );
        },
    );

    while ( defined( my $ele = shift @switches ) ) {
        my ( $opt, $arg )
          = ( $ele =~ /^([^:]+):(.*)/ )
          ? ( $1, $2 )
          : ( $ele, undef );
        my $code = $handler{$opt}
          || croak "Illegal state option: $opt";
        $code->($arg);
    }
    return;
}

sub _select {
    my ( $self, %spec ) = @_;
    push @{ $self->{select} }, \%spec;
}

=head3 C<get_tests>

Given a list of args get the names of tests that should run

=cut

sub get_tests {
    my $self    = shift;
    my $recurse = shift;
    my @argv    = @_;
    my %seen;

    my @selected = $self->_query;

    unless ( @argv || @{ $self->{select} } ) {
        @argv = $recurse ? '.' : 't';
        croak qq{No tests named and '@argv' directory not found}
          unless -d $argv[0];
    }

    push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
    return grep { !$seen{$_}++ } @selected;
}

sub _query {
    my $self = shift;
    if ( my @sel = @{ $self->{select} } ) {
        warn "No saved state, selection will be empty\n"
          unless $self->results->num_tests;
        return map { $self->_query_clause($_) } @sel;
    }
    return;
}

sub _query_clause {
    my ( $self, $clause ) = @_;
    my @got;
    my $results = $self->results;
    my $where = $clause->{where} || sub {1};

    # Select
    for my $name ( $results->test_names ) {
        next unless -f $name;
        local $_ = $results->test($name);
        push @got, $name if $where->();
    }

    # Sort
    if ( my $order = $clause->{order} ) {
        @got = map { $_->[0] }
          sort {
                 ( defined $b->[1] <=> defined $a->[1] )
              || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
          } map {
            [   $_,
                do { local $_ = $results->test($_); $order->() }
            ]
          } @got;
    }

    if ( my $limit = $clause->{limit} ) {
        @got = splice @got, 0, $limit if @got > $limit;
    }

    return @got;
}

sub _get_raw_tests {
    my $self    = shift;
    my $recurse = shift;
    my @argv    = @_;
    my @tests;

    # Do globbing on Win32.
    if (NEED_GLOB) {
        eval "use File::Glob::Windows";    # [49732]
        @argv = map { glob "$_" } @argv;
    }
    my $extensions = $self->{extensions};

    for my $arg (@argv) {
        if ( '-' eq $arg ) {
            push @argv => <STDIN>;
            chomp(@argv);
            next;
        }

        push @tests,
            sort -d $arg
          ? $recurse
              ? $self->_expand_dir_recursive( $arg, $extensions )
              : map { glob( File::Spec->catfile( $arg, "*$_" ) ) }
              @{$extensions}
          : $arg;
    }
    return @tests;
}

sub _expand_dir_recursive {
    my ( $self, $dir, $extensions ) = @_;

    my @tests;
    my $ext_string = join( '|', map {quotemeta} @{$extensions} );

    find(
        {   follow      => 1,      #21938
            follow_skip => 2,
            wanted      => sub {
                -f 
                  && /(?:$ext_string)$/
                  && push @tests => $File::Find::name;
              }
        },
        $dir
    );
    return @tests;
}

=head3 C<observe_test>

Store the results of a test.

=cut

# Store:
#     last fail time
#     last pass time
#     last run time
#     most recent result
#     most recent todos
#     total failures
#     total passes
#     state generation
#     parser

sub observe_test {

    my ( $self, $test_info, $parser ) = @_;
    my $name = $test_info->[0];
    my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
    my $todo = scalar( $parser->todo );
    my $start_time = $parser->start_time;
    my $end_time   = $parser->end_time,

      my $test = $self->results->test($name);

    $test->sequence( $self->{seq}++ );
    $test->generation( $self->results->generation );

    $test->run_time($end_time);
    $test->result($fail);
    $test->num_todo($todo);
    $test->elapsed( $end_time - $start_time );

    $test->parser($parser);

    if ($fail) {
        $test->total_failures( $test->total_failures + 1 );
        $test->last_fail_time($end_time);
    }
    else {
        $test->total_passes( $test->total_passes + 1 );
        $test->last_pass_time($end_time);
    }
}

=head3 C<save>

Write the state to a file.

=cut

sub save {
    my ($self) = @_;

    my $store = $self->{store} or return;
    $self->results->last_run_time( $self->get_time );

    my $writer = TAP::Parser::YAMLish::Writer->new;
    local *FH;
    open FH, ">$store" or croak "Can't write $store ($!)";
    $writer->write( $self->results->raw, \*FH );
    close FH;
}

=head3 C<load>

Load the state from a file

=cut

sub load {
    my ( $self, $name ) = @_;
    my $reader = TAP::Parser::YAMLish::Reader->new;
    local *FH;
    open FH, "<$name" or croak "Can't read $name ($!)";

    # XXX this is temporary
    $self->{_} = $self->result_class->new(
        $reader->read(
            sub {
                my $line = <FH>;
                defined $line && chomp $line;
                return $line;
            }
        )
    );

    # $writer->write( $self->{tests} || {}, \*FH );
    close FH;
    $self->_regen_seq;
    $self->_prune_and_stamp;
    $self->results->generation( $self->results->generation + 1 );
}

sub _prune_and_stamp {
    my $self = shift;

    my $results = $self->results;
    my @tests   = $self->results->tests;
    for my $test (@tests) {
        my $name = $test->name;
        if ( my @stat = stat $name ) {
            $test->mtime( $stat[9] );
        }
        else {
            $results->remove($name);
        }
    }
}

sub _regen_seq {
    my $self = shift;
    for my $test ( $self->results->tests ) {
        $self->{seq} = $test->sequence + 1
          if defined $test->sequence && $test->sequence >= $self->{seq};
    }
}

1;
PK�����dYf\���Z
��Z
����Prove/State/Result/Test.pmnu��[�����������package App::Prove::State::Result::Test;

use strict;
use warnings;

=head1 NAME

App::Prove::State::Result::Test - Individual test results.

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 DESCRIPTION

The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module encapsulates the results for a
single test.

=head1 SYNOPSIS

    # Re-run failed tests
    $ prove --state=failed,save -rbv

=cut

my %methods = (
    name           => { method => 'name' },
    elapsed        => { method => 'elapsed', default => 0 },
    gen            => { method => 'generation', default => 1 },
    last_pass_time => { method => 'last_pass_time', default => undef },
    last_fail_time => { method => 'last_fail_time', default => undef },
    last_result    => { method => 'result', default => 0 },
    last_run_time  => { method => 'run_time', default => undef },
    last_todo      => { method => 'num_todo', default => 0 },
    mtime          => { method => 'mtime', default => undef },
    seq            => { method => 'sequence', default => 1 },
    total_passes   => { method => 'total_passes', default => 0 },
    total_failures => { method => 'total_failures', default => 0 },
    parser         => { method => 'parser' },
);

while ( my ( $key, $description ) = each %methods ) {
    my $default = $description->{default};
    no strict 'refs';
    *{ $description->{method} } = sub {
        my $self = shift;
        if (@_) {
            $self->{$key} = shift;
            return $self;
        }
        return $self->{$key} || $default;
    };
}

=head1 METHODS

=head2 Class Methods

=head3 C<new>

=cut

sub new {
    my ( $class, $arg_for ) = @_;
    $arg_for ||= {};
    bless $arg_for => $class;
}

=head2 Instance Methods

=head3 C<name>

The name of the test.  Usually a filename.

=head3 C<elapsed>

The total elapsed times the test took to run, in seconds from the epoch..

=head3 C<generation>

The number for the "generation" of the test run.  The first generation is 1
(one) and subsequent generations are 2, 3, etc.

=head3 C<last_pass_time>

The last time the test program passed, in seconds from the epoch.

Returns C<undef> if the program has never passed.

=head3 C<last_fail_time>

The last time the test suite failed, in seconds from the epoch.

Returns C<undef> if the program has never failed.

=head3 C<mtime>

Returns the mtime of the test, in seconds from the epoch.

=head3 C<raw>

Returns a hashref of raw test data, suitable for serialization by YAML.

=head3 C<result>

Currently, whether or not the test suite passed with no 'problems' (such as
TODO passed).

=head3 C<run_time>

The total time it took for the test to run, in seconds.  If C<Time::HiRes> is
available, it will have finer granularity.

=head3 C<num_todo>

The number of tests with TODO directives.

=head3 C<sequence>

The order in which this test was run for the given test suite result. 

=head3 C<total_passes>

The number of times the test has passed.

=head3 C<total_failures>

The number of times the test has failed.

=head3 C<parser>

The underlying parser object.  This is useful if you need the full
information for the test program.

=cut

sub raw {
    my $self = shift;
    my %raw  = %$self;

    # this is backwards-compatibility hack and is not guaranteed.
    delete $raw{name};
    delete $raw{parser};
    return \%raw;
}

1;
PK�����dYf\E��EQ��Q����Prove/State/Result.pmnu��[�����������package App::Prove::State::Result;

use strict;
use warnings;
use Carp 'croak';

use App::Prove::State::Result::Test;

use constant STATE_VERSION => 1;

=head1 NAME

App::Prove::State::Result - Individual test suite results.

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 DESCRIPTION

The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module encapsulates the results for a
single test suite run.

=head1 SYNOPSIS

    # Re-run failed tests
    $ prove --state=failed,save -rbv

=cut

=head1 METHODS

=head2 Class Methods

=head3 C<new>

    my $result = App::Prove::State::Result->new({
        generation => $generation,
        tests      => \%tests,
    });

Returns a new C<App::Prove::State::Result> instance.

=cut

sub new {
    my ( $class, $arg_for ) = @_;
    $arg_for ||= {};
    my %instance_data = %$arg_for;    # shallow copy
    $instance_data{version} = $class->state_version;
    my $tests = delete $instance_data{tests} || {};
    my $self = bless \%instance_data => $class;
    $self->_initialize($tests);
    return $self;
}

sub _initialize {
    my ( $self, $tests ) = @_;
    my %tests;
    while ( my ( $name, $test ) = each %$tests ) {
        $tests{$name} = $self->test_class->new(
            {   %$test,
                name => $name
            }
        );
    }
    $self->tests( \%tests );
    return $self;
}

=head2 C<state_version>

Returns the current version of state storage.

=cut

sub state_version {STATE_VERSION}

=head2 C<test_class>

Returns the name of the class used for tracking individual tests.  This class
should either subclass from C<App::Prove::State::Result::Test> or provide an
identical interface.

=cut

sub test_class {
    return 'App::Prove::State::Result::Test';
}

my %methods = (
    generation    => { method => 'generation',    default => 0 },
    last_run_time => { method => 'last_run_time', default => undef },
);

while ( my ( $key, $description ) = each %methods ) {
    my $default = $description->{default};
    no strict 'refs';
    *{ $description->{method} } = sub {
        my $self = shift;
        if (@_) {
            $self->{$key} = shift;
            return $self;
        }
        return $self->{$key} || $default;
    };
}

=head3 C<generation>

Getter/setter for the "generation" of the test suite run. The first
generation is 1 (one) and subsequent generations are 2, 3, etc.

=head3 C<last_run_time>

Getter/setter for the time of the test suite run.

=head3 C<tests>

Returns the tests for a given generation. This is a hashref or a hash,
depending on context called. The keys to the hash are the individual
test names and the value is a hashref with various interesting values.
Each k/v pair might resemble something like this:

 't/foo.t' => {
    elapsed        => '0.0428488254547119',
    gen            => '7',
    last_pass_time => '1219328376.07815',
    last_result    => '0',
    last_run_time  => '1219328376.07815',
    last_todo      => '0',
    mtime          => '1191708862',
    seq            => '192',
    total_passes   => '6',
  }

=cut

sub tests {
    my $self = shift;
    if (@_) {
        $self->{tests} = shift;
        return $self;
    }
    my %tests = %{ $self->{tests} };
    my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
    return wantarray ? @tests : \@tests;
}

=head3 C<test>

 my $test = $result->test('t/customer/create.t');

Returns an individual C<App::Prove::State::Result::Test> instance for the
given test name (usually the filename).  Will return a new
C<App::Prove::State::Result::Test> instance if the name is not found.

=cut

sub test {
    my ( $self, $name ) = @_;
    croak("test() requires a test name") unless defined $name;

    my $tests = $self->{tests} ||= {};
    if ( my $test = $tests->{$name} ) {
        return $test;
    }
    else {
        my $test = $self->test_class->new( { name => $name } );
        $self->{tests}->{$name} = $test;
        return $test;
    }
}

=head3 C<test_names>

Returns an list of test names, sorted by run order.

=cut

sub test_names {
    my $self = shift;
    return map { $_->name } $self->tests;
}

=head3 C<remove>

 $result->remove($test_name);            # remove the test
 my $test = $result->test($test_name);   # fatal error

Removes a given test from results.  This is a no-op if the test name is not
found.

=cut

sub remove {
    my ( $self, $name ) = @_;
    delete $self->{tests}->{$name};
    return $self;
}

=head3 C<num_tests>

Returns the number of tests for a given test suite result.

=cut

sub num_tests { keys %{ shift->{tests} } }

=head3 C<raw>

Returns a hashref of raw results, suitable for serialization by YAML.

=cut

sub raw {
    my $self = shift;
    my %raw  = %$self;

    my %tests;
    for my $test ( $self->tests ) {
        $tests{ $test->name } = $test->raw;
    }
    $raw{tests} = \%tests;
    return \%raw;
}

1;
PK�����dYf\��CU/J��/J����Prove.pmnu��[�����������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<prove> command.

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 DESCRIPTION

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

=head1 SYNOPSIS

    use App::Prove;

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

=cut

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

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

use constant PLUGINS => '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__->mk_methods(@ATTR);
}

=head1 METHODS

=head2 Class Methods

=head3 C<new>

Create a new C<App::Prove>. 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->{$key} = [];
    }

    for my $attr (@ATTR) {
        if ( exists $args->{$attr} ) {

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

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

=head3 C<state_class>

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

=head3 C<state_manager>

Getter/setter for the instance of the C<state_class>.

=cut

=head3 C<add_rc_file>

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

Called before C<process_args> to prepend the contents of an rc file to
the options.

=cut

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

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

=head3 C<process_args>

    $prove->process_args(@args);

Processes the command-line arguments. Attributes will be set
appropriately. Any filenames may be found in the C<argv> 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->{test_args} = \@test_args;
    }

    # Grab options from RC files
    $self->add_rc_file($_) for grep -f, @rc;
    unshift @args, @{ $self->{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'  => \$self->{verbose},
            'f|failures' => \$self->{failures},
            'o|comments' => \$self->{comments},
            'l|lib'      => \$self->{lib},
            'b|blib'     => \$self->{blib},
            's|shuffle'  => \$self->{shuffle},
            'color!'     => \$self->{color},
            'colour!'    => \$self->{color},
            'count!'     => \$self->{show_count},
            'c'          => \$self->{color},
            'D|dry'      => \$self->{dry},
            'ext=s@'     => sub {
                my ( $opt, $val ) = @_;

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

        # Stash the remainder of argv for later
        $self->{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 => $verbosity } );

    return;
}

sub _color_default {
    my $self = shift;

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

sub _get_args {
    my $self = shift;

    my %args;

    $args{trap} = 1 if $self->trap;

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

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

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

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

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

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

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

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

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

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

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

    my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
      keys %verb_map;

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

    $args{verbosity} = shift @verb_adj || 0;

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

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

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

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

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

    if ( @{ $self->rules } ) {
        my @rules;
        for ( @{ $self->rules } ) {
            if (/^par=(.*)/) {
                push @rules, $1;
            }
            elsif (/^seq=(.*)/) {
                push @rules, { seq => $1 };
            }
        }
        $args{rules} = { par => [@rules] };
    }
    $args{harness_class} = $self->{harness_class} if $self->{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->_find_module( $name, @search ) ) {
        $class->import(@args);
        if ( $class->can('load') ) {
            $class->load( { app_prove => $self, args => [@args] } );
        }
    }
    else {
        croak "Can't load module $name";
    }
}

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

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

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

                # It's a hash option.
                croak "Option $name must be consistently used as a hash"
                  if exists $config{$k} && ref $config{$k} ne 'HASH';
                $config{$k} ||= {};
                my ( $hk, $hv ) = split /(?<!\\)=/, $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} } => $v;
                }
                else {
                    $config{$k} = $v;
                }
            }
        }
    );
    $self->{argv} = \@ARGV;
    return ( $handler, \%config );
}

=head3 C<run>

Perform whatever actions the command line args specified. The C<prove>
command line tool consists of the following code:

    use App::Prove;

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

=cut

sub run {
    my $self = shift;

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

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

        $self->_load_extensions( $self->modules );
        $self->_load_extensions( $self->plugins, PLUGINS );

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

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

    return 1;
}

sub _get_tests {
    my $self = shift;

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

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

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

    return @tests;
}

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

    my $state = $self->state_manager;

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

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

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

    return !$aggregator->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->taint_fail ) {
        push @switches, '-T';
    }
    elsif ( $self->taint_warn ) {
        push @switches, '-t';
    }
    if ( $self->warnings_fail ) {
        push @switches, '-W';
    }
    elsif ( $self->warnings_warn ) {
        push @switches, '-w';
    }

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

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

    #24926
    @libs = map { File::Spec->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<require_harness>

Load a harness replacement class.

  $prove->require_harness($for => $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->{harness_class} = $class_name;

    return;
}

=head3 C<print_version>

Display the version numbers of the loaded L<TAP::Harness> 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<run>.

=over

=item C<archive>

=item C<argv>

=item C<backwards>

=item C<blib>

=item C<color>

=item C<directives>

=item C<dry>

=item C<exec>

=item C<extensions>

=item C<failures>

=item C<comments>

=item C<formatter>

=item C<harness>

=item C<ignore_exit>

=item C<includes>

=item C<jobs>

=item C<lib>

=item C<merge>

=item C<modules>

=item C<parse>

=item C<plugins>

=item C<quiet>

=item C<really_quiet>

=item C<recurse>

=item C<rules>

=item C<show_count>

=item C<show_help>

=item C<show_man>

=item C<show_version>

=item C<shuffle>

=item C<state>

=item C<state_class>

=item C<taint_fail>

=item C<taint_warn>

=item C<test_args>

=item C<timer>

=item C<verbose>

=item C<warnings_fail>

=item C<warnings_warn>

=item C<tapversion>

=item C<trap>

=back

=head1 PLUGINS

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

  prove -PMyPlugin

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

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

  prove -PMyPlugin=foo,bar,baz

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

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

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

Note that the user's arguments are also passed to your plugin's C<import()>
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->{args} };
      my $app  = $p->{app_prove};

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

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

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

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

      return 1;
  }

  1;

=head1 SEE ALSO

L<prove>, L<TAP::Harness>

=cut
PK�������dYf\�g�����������������������Cpan.pmnu��[�����������PK�������dYf\�g^e�-���-������������������Prove/State.pmnu��[�����������PK�������dYf\���Z
��Z
������������������Prove/State/Result/Test.pmnu��[�����������PK�������dYf\E��EQ��Q��������������A���Prove/State/Result.pmnu��[�����������PK�������dYf\��CU/J��/J������������������Prove.pmnu��[�����������PK���������>3���