diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/pler.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/pler.pm | 482 |
1 files changed, 482 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/pler.pm b/Master/tlpkg/tlperl/lib/pler.pm new file mode 100755 index 00000000000..f4830f1558e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/pler.pm @@ -0,0 +1,482 @@ +package pler; + +# See 'sub main' for main functionality + +use 5.00503; +use strict; +use Config; +use Carp (); +use Cwd 3.00 (); +use File::Which 0.05 (); +use File::Spec 0.80 (); +use File::Spec::Functions ':ALL'; +use File::Find::Rule 0.20 (); +use Getopt::Long 0 (); +use Probe::Perl 0.01 (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.05'; +} + +# Does exec work on this platform +use constant EXEC_OK => ($^O ne 'MSWin32' and $^O ne 'cygwin'); + +# Can you overwrite an open file on this platform +use constant OVERWRITE_OK => !! ( $^O ne 'MSWin32' ); + + + + + + +##################################################################### +# Resource Locations + +sub MakefilePL () { + catfile( curdir(), 'Makefile.PL' ); +} + +sub BuildPL () { + catfile( curdir(), 'Build.PL' ); +} + +sub Makefile () { + catfile( curdir(), 'Makefile' ); +} + +sub Build () { + catfile( curdir(), 'Build' ); +} + +sub perl () { + Probe::Perl->find_perl_interpreter; +} + +# Look for make in $Config +sub make () { + my $make = $Config::Config{make}; + my $found = File::Which::which( $make ); + unless ( $found ) { + Carp::croak("Failed to find '$make' (as specified by \$Config{make})"); + } + return $found; +} + +sub blib () { + catdir( curdir(), 'blib' ); +} + +sub inc () { + catdir( curdir(), 'inc' ); +} + +sub lib () { + catdir( curdir(), 'lib' ); +} + +sub t () { + catdir( curdir(), 't' ); +} + +sub xt () { + catdir( curdir(), 'xt' ); +} + + + + + +##################################################################### +# Convenience Logic + +sub has_makefilepl () { + !! -f MakefilePL; +} + +sub has_buildpl () { + !! -f BuildPL; +} + +sub has_makefile () { + !! -f Makefile; +} + +sub has_build () { + !! -f Build; +} + +sub has_blib () { + !! -d blib; +} + +sub blibpm () { + eval { + require blib; + }; + return ! $@; +} + +sub has_inc () { + !! -f inc; +} + +sub has_lib () { + !! -d lib; +} + +sub has_t () { + !! -d t; +} + +sub has_xt () { + !! -d xt; +} + +sub in_distroot () { + !! ( + has_makefilepl or (has_lib and has_t) + ); +} + +sub in_subdir () { + !! ( + -f catfile( updir(), 'Makefile.PL' ) + or + -d catdir( updir(), 't' ) + ); +} + +sub needs_makefile () { + has_makefilepl and ! has_makefile; +} + +sub needs_build () { + has_buildpl and ! has_build; +} + +sub mtime ($) { + (stat($_[0]))[9]; +} + +sub old_makefile () { + has_makefile + and + has_makefilepl + and + mtime(Makefile) < mtime(MakefilePL); +} + +sub old_build () { + has_build + and + has_buildpl + and + mtime(Build) < mtime(BuildPL); +} + + + + + +##################################################################### +# Utility Functions + +# Support verbosity +use vars qw{$VERBOSE}; +BEGIN { + $VERBOSE ||= 0; +} + +sub is_verbose { + $VERBOSE; +} + +sub verbose ($) { + message( $_[0] ) if $VERBOSE; +} + +sub message ($) { + print $_[0]; +} + +sub error (@) { + print ' ' . join '', map { "$_\n" } ('', @_, ''); + exit(255); +} + +sub run ($) { + my $cmd = shift; + verbose( "> $cmd" ); + system( $cmd ); +} + +sub handoff (@) { + my $cmd = join ' ', @_; + verbose( "> $cmd" ); + $ENV{HARNESS_ACTIVE} = 1; + $ENV{RELEASE_TESTING} = 1; + if ( EXEC_OK ) { + exec( @_ ) or Carp::croak("Failed to exec '$cmd'"); + } else { + system( @_ ); + exit(0); + } +} + + + + + +##################################################################### +# Main Script + +my @SWITCHES = (); + +sub main { + Getopt::Long::Configure('no_ignore_case'); + Getopt::Long::GetOptions( + 'help' => \&help, + 'V' => sub { print "pler $VERSION\n"; exit(0) }, + 'w' => sub { push @SWITCHES, '-w' }, + ); + + # Get the script name + my $script = shift @ARGV; + unless ( defined $script ) { + print "# No file name pattern provided, using 't'...\n"; + $script = 't'; + } + + # Abuse the highly mature logic in Cwd to define an $ENV{PWD} value + # by chdir'ing to the current directory. + # This lets us get the current directory without losing symlinks. + Cwd::chdir(curdir()); + my $orig = $ENV{PWD} or die "Failed to get original directory"; + + # Can we locate the distribution root + my ($v,$d,$f) = splitpath($ENV{PWD}, 'nofile'); + my @dirs = splitdir($d); + while ( @dirs ) { + my $buildpl = catpath( + $v, catdir(@dirs), BuildPL, + ); + my $makefilepl = catpath( + $v, catdir(@dirs), MakefilePL, + ); + unless ( -f $buildpl or -f $makefilepl ) { + pop @dirs; + next; + } + + # This is a distroot + my $distroot = catpath( $v, catdir(@dirs), undef ); + Cwd::chdir($distroot); + last; + } + unless ( in_distroot ) { + error "Failed to locate the distribution root"; + } + + # Makefile.PL? Or Build.PL? + my $BUILD_SYSTEM = has_buildpl ? 'build' : has_makefilepl ? 'make' : ''; + if ( $BUILD_SYSTEM eq 'build' ) { + # Because Module::Build always runs with warnings on, + # pler will as well when you use a Build.PL + unless ( grep { $_ eq '-w' } @SWITCHES ) { + push @SWITCHES, '-w'; + } + } + + # If needed, regenerate the Makefile or Build file + # Currently we do not remember Makefile.PL or Build.PL params + if ( $BUILD_SYSTEM eq 'make' ) { + if ( needs_makefile or (old_makefile and ! OVERWRITE_OK) ) { + run( join ' ', perl, MakefilePL ); + } + } elsif ( $BUILD_SYSTEM eq 'build' ) { + if ( needs_build or old_build ) { + run( join ' ', perl, BuildPL ); + } + } + + # Locate the test script to run + if ( $script =~ /\.t$/ ) { + # EITHER + # 1. They tab-completed the script relative to the original directory (most likely) + # OR + # 2. They typed the entire name of the test script + my $tab_completed = File::Spec->catfile( $orig, $script ); + if ( -f $tab_completed ) { + if ( $orig eq $ENV{PWD} ) { + $script = $script; # Included for clarity + } else { + $script = File::Spec->abs2rel( $tab_completed, $ENV{PWD} ); + } + } + + } else { + # Get the list of possible tests + my @directory = ( 't', has_xt ? 'xt' : () ); + my @possible = File::Find::Rule->name('*.t')->file->in(@directory); + + # Filter by the search terms to find matching tests + my $matches = filter( + [ $script, @ARGV ], + [ @possible ], + ); + unless ( @$matches ) { + error "No tests match '$script'"; + } + if ( @$matches > 1 ) { + error( + "More than one possible test", + map { " $_" } sort @$matches, + ); + } + $script = $matches->[0]; + + # Localize the path + $script = File::Spec->catfile( split /\//, $script ); + } + unless ( -f $script ) { + error "Test script '$script' does not exist"; + } + + # Rerun make or Build if needed + if ( $BUILD_SYSTEM eq 'make' ) { + # Do NOT run make if there is no Makefile.PL, because it likely means + # there is a hand-written Makefile and NOT one derived from Makefile.PL, + # and we have no idea what functionality we might trigger. + if ( in_distroot and has_makefile and has_makefilepl ) { + run( make ); + } + } elsif ( $BUILD_SYSTEM eq 'build' ) { + if ( in_distroot and has_build and has_buildpl ) { + run( Build ); + } + } + + # Passing includes via -I params is not good enough + # because you can't subshell them, and it's also not + # how MakeMaker does it anyway. + # We need to hack/extend PERL5LIB instead. + my $path_sep = $Config{path_sep}; + my @PERL5LIB = (); + + # Build the command to execute + my @flags = @SWITCHES; + if ( has_blib ) { + if ( has_inc ) { + push @PERL5LIB, inc; + } + push @PERL5LIB, File::Spec->catdir( + blib, 'lib', + ); + push @PERL5LIB, File::Spec->catdir( + blib, 'arch', + ); + } elsif ( has_lib ) { + push @PERL5LIB, lib; + } + + # Hand off to the perl debugger + unless ( pler->is_verbose ) { + message( "# Debugging $script...\n" ); + } + my @cmd = ( perl, @flags, '-d', $script ); + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? join( $path_sep, @PERL5LIB, $ENV{PERL5LIB} ) + : join( $path_sep, @PERL5LIB ); + handoff( @cmd ); +} + +# Encapsulates the smart filtering as a function +sub filter { + my $terms = shift; + my $possible = shift; + my @matches = @$possible; + + while ( @$terms ) { + my $term = shift @$terms; + + if ( ref $term eq 'Regexp' ) { + # If the term is a regexp apply it directly + @matches = grep { $_ =~ $term } @matches; + } elsif ( $term =~ /^[1-9]\d*$/ ) { + # If the search is a pure integer (without leading + # zeros) attempt a specialised numeric filter. + @matches = grep { /\b0*${term}[^0-9]/ } @matches; + } else { + # Otherwise treat it as a naive string match + $term = quotemeta $term; + @matches = grep { /$term/i } @matches; + } + } + + return \@matches; +} + +sub help { print <<'END_HELP'; exit(0); } +Usage: + pler [options] [file/pattern] + +Options: + -V Print the pler version + -h, --help Display this help + -w Run test with the -w warnings flag +END_HELP + +1; + +=pod + +=head1 NAME + +pler - The DWIM Perl Debugger + +=head1 DESCRIPTION + +B<pler> is a small script which provides a sanity layer for debugging +test scripts in Perl distributions. + +While L<prove> has proven itself to be a highly useful program for +manually running one or more groups of scripts in a distribution, +what we also need is something that provides a similar level of +intelligence in a debugging context. + +B<pler> checks that the environment is sound, runs some cleanup tasks +if needed, makes sure you are in the right directory, and then hands off +to the perl debugger as normal. + +=head1 TO DO + +- Tweak some small terminal related issues on Win32 + +=head1 SUPPORT + +All bugs should be filed via the bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=pler> + +For other issues, or commercial enhancement and support, contact the author + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<prove>, L<http://ali.as/> + +=head1 COPYRIGHT + +Copyright 2006 - 2010 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut |