summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/pler.pm
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/pler.pm
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/pler.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/pler.pm482
1 files changed, 0 insertions, 482 deletions
diff --git a/Master/tlpkg/tlperl/lib/pler.pm b/Master/tlpkg/tlperl/lib/pler.pm
deleted file mode 100755
index f4830f1558e..00000000000
--- a/Master/tlpkg/tlperl/lib/pler.pm
+++ /dev/null
@@ -1,482 +0,0 @@
-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