summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/pler.pm
blob: f4830f1558ed52a02fedcf4407a3d543407720ff (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
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