File Coverage

lib/Test/NoBreakpoints.pm

Criterion	Covered	Total	%
statement	60	65	92.3
branch	24	34	70.5
condition	3	6	50.0
subroutine	9	10	90.0
pod	3	3	100.0
total	99	118	83.9

=head1 NAME

Test::NoBreakpoints - test that files do not contain soft breakpoints

=head1 SYNOPSIS

 use Test::NoBreakpoints;
 plan tests => $num_tests;
 no_breakpoints_ok( $file, 'Contains no soft breakpoints' );

Module authors can include the following in a t/nobreakpoints.t file to add
such checking to a module distribution:

  use Test::More;
  eval "use Test::NoBreakpoints 0.10";
  plan skip_all => "Test::NoBreakpoints 0.10 required for testing" if $@;
  all_files_no_breakpoints_ok();

=head1 DESCRIPTION

I love soft breakpoints (C<$DB::single = 1>) in the Perl debugger.
Unfortunately, I have a habit of putting them in my code during development
and forgetting to take them out before I upload it to CPAN, necessitating a
hasty fix/package/bundle cycle followed by much cursing.

Test::NoBreakpoints checks that files contain neither the string
C<$DB::single = 1> nor C<$DB::signal = 1>.  By adding such a test to all my
modules, I swear less and presumably lighten the load on the CPAN in some
small way.

=cut

package Test::NoBreakpoints;

use strict;

use File::Spec;
use File::Find;
use Test::Builder;

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION = '0.17';

@ISA       = 'Exporter';
@EXPORT    = qw|
    all_files_no_breakpoints_ok
    all_files_no_brkpts_ok
    no_breakpoints_ok
    no_brkpts_ok
|;
@EXPORT_OK = qw|all_perl_files|;
%EXPORT_TAGS = (
    all => [ @EXPORT, @EXPORT_OK ],
);

# get a Test singleton to use
my $Test = Test::Builder->new;

# a regular expression to find soft breakpoints
my $brkpt_rx = qr/
    (                   # match it
        \$DB            # The DB package
        (?:::|')        # Perl 4 or 5 package seperator
        si(?:ngle|gnal) # signal or single
        \s*=\s*         # an equal with optional whitespace
        [1-9]           # a digit other than zero
                        # (am I being stupid here?  Is there
    )                   #  no easier way to say that?)
/x;

# check that there are no breakpoints in a file
sub no_breakpoints_ok($;$)
{

    my($file, $name) = @_;
    $name ||= "no breakpoint test of $file";

    # slurp in the file
    my $fh;
    unless( open($fh, $file) ) {
        $Test->ok(0, $name);
        $Test->diag("could not open $file: $!");
        return;
    }
    my $text = do { local( $/ ) ; <$fh> } ;
    close($fh);

    # check the file against our regex
    my($matched) = $text =~ m/$brkpt_rx/;
    if( ! $matched ) {
        $Test->ok(1, $name);
    }
    else {
        $Test->ok(0, $name);
        $Test->diag("breakpoint found in $file: $matched");
    }

    return $matched ? 0 : 1;

}

# find all perl files in a given directory
# graciously borrwed from Test::Pod::all_pod_files by
# Andy Lester / brian d foy
sub all_perl_files
{

    my @queue = @_ ? @_ : _starting_points();
    my @files = ();

    while ( @queue ) {
        my $file = shift @queue;
        if ( -d $file ) {
            local *DH;
            opendir DH, $file or next;
            my @newfiles = readdir DH;
            closedir DH;

            @newfiles = File::Spec->no_upwards( @newfiles );
            @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles;

            push @queue, map "$file/$_", @newfiles;
        }
        if ( -f $file ) {
            push @files, $file if _is_perl( $file );
        }
    } # while

    return @files;

}


sub _starting_points {
    return 'blib' if -e 'blib';
    return 'lib';
}

sub _is_perl {
    my $file = shift;

    return 1 if $file =~ /\.PL$/;
    return 1 if $file =~ /\.p(l|m)$/;
    return 1 if $file =~ /\.t$/;

    local *FH;
    open FH, $file or return;
    my $first = ;
    close FH;

    return 1 if defined $first && ($first =~ /^#!.*perl/);

    return;
}

# run no_breakpoints_ok on all files in a given directory
sub all_files_no_breakpoints_ok
{

    my @files = @_ ? @_ : all_perl_files();

    my $ok = 1; # presume all succeed
    for( @files ) {
        no_breakpoints_ok($_) or $ok = 0;
    }
    return $ok;

}

# keep require happy
1;


__END__