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 is a small script which provides a sanity layer for debugging test scripts in Perl distributions. While L 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 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 For other issues, or commercial enhancement and support, contact the author =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L, L =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