summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/App
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/App')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/App/Cpan.pm1067
-rwxr-xr-xMaster/tlpkg/tlperl/lib/App/Prove.pm806
-rwxr-xr-xMaster/tlpkg/tlperl/lib/App/Prove/State.pm517
-rwxr-xr-xMaster/tlpkg/tlperl/lib/App/Prove/State/Result.pm233
-rwxr-xr-xMaster/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm153
5 files changed, 2776 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/App/Cpan.pm b/Master/tlpkg/tlperl/lib/App/Cpan.pm
new file mode 100755
index 00000000000..cfc12908e52
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Cpan.pm
@@ -0,0 +1,1067 @@
+package App::Cpan;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+$VERSION = '1.5701';
+
+=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 [-cfFimt] module_name [ module_name ... ]
+
+ # use local::lib
+ cpan -l module_name [ module_name ... ]
+
+ # 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 [-ahruvACDLO]
+
+=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
+
+Install the specified modules.
+
+=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
+
+Use C<local::lib>.
+
+=item -L author [ author ... ]
+
+List the modules by the specified authors.
+
+=item -m
+
+Make the specified modules.
+
+=item -O
+
+Show the out-of-date modules.
+
+=item -t
+
+Run a `make test` on the specified modules.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=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.
+
+=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
+
+
+=head2 Methods
+
+=over 4
+
+=cut
+
+use autouse Carp => qw(carp croak cluck);
+use CPAN ();
+use autouse Cwd => qw(cwd);
+use autouse 'Data::Dumper' => qw(Dumper);
+use File::Spec::Functions;
+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 g G C A D O l L a r j: J );
+
+$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',
+ );
+@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' ],
+
+ # 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' ],
+
+ # options that do their one thing
+ g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
+ G => [ \&_gitify, NO_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' ],
+ r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
+ u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+
+ 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`' ],
+
+ );
+
+%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;
+
+ # 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};
+ }
+ else
+ {
+ # this is what CPAN.pm would do otherwise
+ CPAN::HandleConfig->load(
+ # be_silent => 1, # candidate to be ripped out forever
+ write_file => 0,
+ );
+ }
+
+ if( $options->{F} )
+ {
+ $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} );
+ delete $options->{F};
+ }
+
+ my $option_count = grep { $options->{$_} } @option_order;
+ no warnings 'uninitialized';
+ $option_count -= $options->{'f'}; # don't count force
+
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # if there are no options, set -i (this line fixes RT ticket 16915)
+ $options->{i}++ unless $option_count;
+ }
+
+
+=item run()
+
+Just do it.
+
+The C<run> method returns 0 on success and a postive 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 );
+
+ 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 );
+
+ unless( ref $sub eq ref sub {} )
+ {
+ $return_value = THE_PROGRAMMERS_AN_IDIOT;
+ last OPTION;
+ }
+
+ $logger->info( "$description -- ignoring other arguments" )
+ if( @ARGV && ! $takes_args );
+
+ $return_value = $sub->( \ @ARGV, $options );
+
+ last;
+ }
+
+ return $return_value;
+ }
+
+{
+package Local::Null::Logger;
+
+sub new { bless \ my $x, $_[0] }
+sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} }
+sub DESTROY { 1 }
+}
+
+sub _init_logger
+ {
+ my $log4perl_loaded = eval "require Log::Log4perl; 1";
+
+ unless( $log4perl_loaded )
+ {
+ $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';
+ 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 if specified
+ my $action = do {
+ if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
+ else { sub { CPAN::Shell->$method( @_ ) } }
+ };
+
+ # How do I handle exit codes for multiple arguments?
+ my $errors = 0;
+
+ foreach my $arg ( @$args )
+ {
+ _clear_cpanpm_output();
+ $action->( $arg );
+
+ $errors += defined _cpanpm_output_indicates_failure();
+ }
+
+ $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED;
+ }
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+
+=for comment
+
+CPAN.pm sends all the good stuff either to STDOUT. I have to intercept
+that output so I can find out what happened.
+
+=cut
+
+{
+my $scalar = '';
+
+sub _hook_into_CPANpm_report
+ {
+ no warnings 'redefine';
+
+ *CPAN::Shell::myprint = sub {
+ my($self,$what) = @_;
+ $scalar .= $what if defined $what;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_print}||'bold blue on_white',
+ );
+ };
+
+ *CPAN::Shell::mywarn = sub {
+ my($self,$what) = @_;
+ $scalar .= $what if defined $what;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_warn}||'bold red on_white'
+ );
+ };
+
+ }
+
+sub _clear_cpanpm_output { $scalar = '' }
+
+sub _get_cpanpm_output { $scalar }
+
+BEGIN {
+my @skip_lines = (
+ qr/^\QWarning \(usually harmless\)/,
+ qr/\bwill not store persistent state\b/,
+ qr(//hint//),
+ qr/^\s+reports\s+/,
+ );
+
+sub _get_cpanpm_last_line
+ {
+ open my($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)? );
+
+sub _cpanpm_output_indicates_failure
+ {
+ my $last_line = _get_cpanpm_last_line();
+
+ my $result = $last_line =~ /\b(?:$epic_fail_words)\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 _print_help
+ {
+ $logger->info( "Use perldoc to read the documentation" );
+ exec "perldoc $0";
+ }
+
+sub _print_version
+ {
+ $logger->info(
+ "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
+
+ return HEY_IT_WORKED;
+ }
+
+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 _load_config # -j
+ {
+ my $file = shift || '';
+
+ # should I clear out any existing config here?
+ $CPAN::Config = {};
+ delete $INC{'CPAN/Config.pm'};
+ croak( "Config file [$file] does not exist!\n" ) unless -e $file;
+
+ 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
+ {
+ my $args = shift;
+ require Data::Dumper;
+
+ my $fh = $args->[0] || \*STDOUT;
+
+ my $dd = Data::Dumper->new(
+ [$CPAN::Config],
+ ['$CPAN::Config']
+ );
+
+ print $fh $dd->Dump, "\n1;\n__END__\n";
+
+ return HEY_IT_WORKED;
+ }
+
+sub _lock_lobotomy
+ {
+ 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 $module ( @$args )
+ {
+ $logger->info( "Checking $module" );
+ my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+
+ $logger->debug( "Inst file would be $path\n" );
+
+ $paths{$module} = _get_file( _make_path( $path ) );
+ }
+
+ return \%paths;
+ }
+
+sub _make_path { join "/", qw(authors id), $_[0] }
+
+sub _get_file
+ {
+ my $path = shift;
+
+ my $loaded = eval "require LWP::Simple; 1;";
+ 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 = eval "require Archive::Extract; 1;";
+ croak "You need Archive::Extract to use features that gitify distributions\n"
+ unless $loaded;
+
+ my $starting_dir = cwd();
+
+ foreach my $module ( @$args )
+ {
+ $logger->info( "Checking $module" );
+ my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+
+ my $store_paths = _download( [ $module ] );
+ $logger->debug( "gitify Store path is $store_paths->{$module}" );
+ my $dirname = dirname( $store_paths->{$module} );
+
+ my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
+ $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 = eval { CPAN::Shell->expand( "Module", $arg ) };
+ 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 eval "require LWP::Simple; require URI; 1";
+
+ 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 = CPAN::Shell->expand( "Module", $arg );
+ 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->fullname;
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_Details
+ {
+ my $args = shift;
+
+ foreach my $arg ( @$args )
+ {
+ my $module = CPAN::Shell->expand( "Module", $arg );
+ 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->inst_file,
+ 'Installed: ' . $module->inst_version,
+ 'CPAN: ' . $module->cpan_version . ' ' .
+ ($module->uptodate ? "" : "Not ") . "up to date",
+ $author->fullname . " (" . $module->userid . ")",
+ $author->email;
+ print "\n\n";
+
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_out_of_date
+ {
+ my @modules = CPAN::Shell->expand( "Module", "/./" );
+
+ printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
+ print "-" x 73, "\n";
+
+ foreach my $module ( @modules )
+ {
+ 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 = CPAN::Shell->expand( "Module", "/./" );
+
+ foreach my $module ( @modules )
+ {
+ next unless exists $hash{ lc $module->userid };
+ print $module->id, "\n";
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _list_all_mods
+ {
+ 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 ) = @_;
+
+ 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;
+ }
+
+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.
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 SOURCE AVAILABILITY
+
+This code is in Github:
+
+ git://github.com/briandfoy/cpan_script.git
+
+=head1 CREDITS
+
+Japheth Cleaver added the bits to allow a forced install (-f).
+
+Jim Brandt suggest and provided the initial implementation for the
+up-to-date and Changes features.
+
+Adam Kennedy pointed out that exit() causes problems on Windows
+where this script ends up with a .bat extension
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
+
+You may redistribute this under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/App/Prove.pm b/Master/tlpkg/tlperl/lib/App/Prove.pm
new file mode 100755
index 00000000000..dd9b797e089
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove.pm
@@ -0,0 +1,806 @@
+package App::Prove;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Harness;
+use TAP::Parser::Utils qw( split_shell );
+use File::Spec;
+use Getopt::Long;
+use App::Prove::State;
+use Carp;
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=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 {
+ @ISA = qw(TAP::Object);
+
+ @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 extension ignore_exit rules state_manager
+ normalize sources
+ );
+ __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 || {};
+
+ # setup defaults:
+ for my $key (
+ qw( argv rc_opts includes modules state plugins rules sources ))
+ {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ my %env_provides_default = (
+ HARNESS_TIMER => 'timer',
+ );
+
+ while ( my ( $env, $attr ) = each %env_provides_default ) {
+ $self->{$attr} = 1 if $ENV{$env};
+ }
+ $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' => \$self->{extension},
+ '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},
+ '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},
+ ) 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} && !IS_WIN32;
+}
+
+sub _get_args {
+ my $self = shift;
+
+ my %args;
+
+ 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 ) );
+
+ 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] };
+ }
+
+ return ( \%args, $self->{harness_class} );
+}
+
+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 ( undef, $k, $v ) = @_;
+ 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 => 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->extension;
+ $state->extension($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, $harness_class, @tests ) = @_;
+ my $harness = $harness_class->new($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';
+ }
+
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
+
+ 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;
+ 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<extension>
+
+=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>
+
+=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
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State.pm b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
new file mode 100755
index 00000000000..ffe1a229cb3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
@@ -0,0 +1,517 @@
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+
+use App::Prove::State::Result;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __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.20
+
+=cut
+
+$VERSION = '3.20';
+
+=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=fail,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<extension> (optional)
+
+The test name extension. 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},
+ extension => ( delete $args{extension} || '.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<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+=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(
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->result == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->elapsed } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->elapsed } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->mtime } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( 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;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ follow_skip => 2,
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && 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;
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
new file mode 100755
index 00000000000..3b9d82f4b98
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
@@ -0,0 +1,233 @@
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=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=fail,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;
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
new file mode 100755
index 00000000000..a7bebb39be4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
@@ -0,0 +1,153 @@
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.20
+
+=cut
+
+$VERSION = '3.20';
+
+=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=fail,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;