summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/pler.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/pler.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/pler.pm482
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