diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/App | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/App')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/App/Cpan.pm | 1067 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/App/Prove.pm | 806 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/App/Prove/State.pm | 517 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm | 233 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm | 153 |
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; |