[catagits/Test-EOL.git] / lib / Test / EOL.pm

package Test::EOL;

use strict;
use warnings;

use Test::Builder;
use File::Spec;
use FindBin qw($Bin);
use File::Find;

use vars qw( $VERSION $PERL $UNTAINT_PATTERN $PERL_PATTERN);

$VERSION = '0.7';

$PERL    = $^X || 'perl';
$UNTAINT_PATTERN  = qr|^([-+@\w./:\\]+)$|;
$PERL_PATTERN     = qr/^#!.*perl/;

my %file_find_arg = ($] <= 5.006) ? () : (
    untaint => 1,
    untaint_pattern => $UNTAINT_PATTERN,
    untaint_skip => 1,
);

my $Test  = Test::Builder->new;
my $updir = File::Spec->updir();

sub import {
    my $self   = shift;
    my $caller = caller;
    {
        no strict 'refs';
        *{$caller.'::eol_unix_ok'} = \&eol_unix_ok;
        *{$caller.'::all_perl_files_ok'} = \&all_perl_files_ok;
    }
    $Test->exported_to($caller);
    $Test->plan(@_);
}

sub _all_perl_files {
    my @all_files = _all_files(@_);
    return grep { _is_perl_module($_) || _is_perl_script($_) } @all_files;
}

sub _all_files {
    my @base_dirs = @_ ? @_ : File::Spec->catdir($Bin, $updir);
    my @found;
    my $want_sub = sub {
        return if ($File::Find::dir =~ m![\\/]?CVS[\\/]|[\\/]?.svn[\\/]!); # Filter out cvs or subversion dirs/
        return if ($File::Find::dir =~ m![\\/]?blib[\\/]libdoc$!); # Filter out pod doc in dist
        return if ($File::Find::dir =~ m![\\/]?blib[\\/]man\d$!); # Filter out pod doc in dist
        return if ($File::Find::name =~ m!Build$!i); # Filter out autogenerated Build script
        return unless (-f $File::Find::name && -r _);
        push @found, File::Spec->no_upwards( $File::Find::name );
    };
    my $find_arg = {
        %file_find_arg,
        wanted   => $want_sub,
        no_chdir => 1,
    };
    find( $find_arg, @base_dirs);
    return @found;
}

# Formats various human invisible symbols
# to similar visible ones.
# Perhaps ^M or something like that 
# would be more appropriate?

sub _show_whitespace { 
    my $string = shift;
    $string =~ s/\r/[\\r]/g;
    $string =~ s/\t/[\\t]/g;
    $string =~ s/ /[\\s]/g;
    return $string;
}

# Format a line record for diagnostics.

sub _debug_line { 
    my ( $options, $line ) = @_;
    $line->[2] =~ s/\n\z//g;
    return "line $line->[1] : $line->[0] " . ( 
      $options->{show_lines} ? qq{: } . _show_whitespace( $line->[2] )  : q{} 
    );
}

sub eol_unix_ok {
    my $file = shift;
    my $test_txt;
    $test_txt   = shift if !ref $_[0];
    $test_txt ||= "No windows line endings in '$file'";
    my $options = shift if ref $_[0] eq 'HASH';
    $options ||= {
        trailing_whitespace => 0,
        all_reasons => 0,
    };
    $file = _module_to_path($file);
    
    open my $fh, $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
    # Windows-- , default is :crlf, which hides \r\n  -_-
    binmode( $fh, ':raw:utf8' );
    my $line = 0;
    my @fails;
    while (<$fh>) {
        $line++;
        if ( !$options->{trailing_whitespace} && /(\r+)$/ ) {
          my $match = $1;
          push @fails, [ _show_whitespace( $match ) , $line , $_ ];
        }
        if (  $options->{trailing_whitespace} && /([ \t]*\r+|[ \t]+)$/ ) {
          my $match = $1;
          push @fails, [ _show_whitespace($match), $line , $_ ];
        }
        # Minor short-circuit for people who don't need the whole file scanned
        # once there's an err.
        last if( @fails > 0 && !$options->{all_reasons} );
    }
    if( @fails ){ 
       $Test->ok( 0, $test_txt . " on "  . _debug_line({ show_lines => 0 } , $fails[0]  )  );
       if ( $options->{all_reasons} || 1 ){
          $Test->diag( "  Problem Lines: ");
          for ( @fails ){ 
            $Test->diag(_debug_line({ show_lines => 1 } , $_ ) );
          }
       }
       return 0;
    }
    $Test->ok(1, $test_txt);
    return 1;
}
sub all_perl_files_ok {
    my $options = shift if ref $_[0] eq 'HASH';
    my @files = _all_perl_files( @_ );
    _make_plan();
    foreach my $file ( @files ) {
      eol_unix_ok($file, $options);
    }
}

sub _is_perl_module {
    $_[0] =~ /\.pm$/i || $_[0] =~ /::/;
}

sub _is_perl_script {
    my $file = shift;
    return 1 if $file =~ /\.pl$/i;
    return 1 if $file =~ /\.t$/;
    open my $fh, $file or return;
    my $first = <$fh>;
    return 1 if defined $first && ($first =~ $PERL_PATTERN);
    return;
}

sub _module_to_path {
    my $file = shift;
    return $file unless ($file =~ /::/);
    my @parts = split /::/, $file;
    my $module = File::Spec->catfile(@parts) . '.pm';
    foreach my $dir (@INC) {
        my $candidate = File::Spec->catfile($dir, $module);
        next unless (-e $candidate && -f _ && -r _);
        return $candidate;
    }
    return $file;
}

sub _make_plan {
    unless ($Test->has_plan) {
        $Test->plan( 'no_plan' );
    }
    $Test->expected_tests;
}

sub _untaint {
    my @untainted = map { ($_ =~ $UNTAINT_PATTERN) } @_;
    return wantarray ? @untainted : $untainted[0];
}

1;
__END__

=head1 NAME

Test::EOL - Check the correct line endings in your project

=head1 SYNOPSIS

C<Test::EOL> lets you check the presence of windows line endings in your
perl code. It
report its results in standard C<Test::Simple> fashion:

  use Test::EOL tests => 1;
  eol_unix_ok( 'lib/Module.pm', 'Module is ^M free');

and to add checks for trailing whitespace:

  use Test::EOL tests => 1;
  eol_unix_ok( 'lib/Module.pm', 'Module is ^M and trailing whitespace free', { trailing_whitespace => 1 });

Module authors can include the following in a t/eol.t and have C<Test::EOL>
automatically find and check all perl files in a module distribution:

  use Test::EOL;
  all_perl_files_ok();

or

  use Test::EOL;
  all_perl_files_ok( @mydirs );

and if authors would like to check for trailing whitespace:

  use Test::EOL;
  all_perl_files_ok({ trailing_whitespace => 1 });

or

  use Test::EOL;
  all_perl_files_ok({ trailing_whitespace => 1 }, @mydirs );

=head1 DESCRIPTION

This module scans your project/distribution for any perl files (scripts,
modules, etc) for the presence of windows line endings.

=head1 EXPORT

A list of functions that can be exported.  You can delete this section
if you don't export anything, such as for a purely object-oriented module.

=head1 FUNCTIONS

=head2 all_perl_files_ok( [ \%options ], [ @directories ] )

Applies C<eol_unix_ok()> to all perl files found in C<@directories> (and sub
directories). If no <@directories> is given, the starting point is one level
above the current running script, that should cover all the files of a typical
CPAN distribution. A perl file is *.pl or *.pm or *.t or a file starting
with C<#!...perl>

If the test plan is defined:

  use Test::EOL tests => 3;
  all_perl_files_ok();

the total number of files tested must be specified.

=head2 eol_unix_ok( $file [, $text] [, \%options ]  )

Run a unix EOL check on C<$file>. For a module, the path (lib/My/Module.pm) or the
name (My::Module) can be both used.

=head1 AUTHOR

Tomas Doran (t0m) C<< <bobtfish@bobtfish.net> >>

=head1 BUGS

Testing for EOL styles other than unix (\n) currently unsupported.

The source code can be found on github, as listed in C< META.yml >,
patches are welcome.

Otherwise please report any bugs or feature requests to
C<bug-test-eol at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-EOL>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

Shamelessly ripped off from L<Test::NoTabs>.

=head1 SEE ALSO

L<Test::More>, L<Test::Pod>. L<Test::Distribution>, L<Test:NoWarnings>,
L<Test::NoTabs>, L<Module::Install::AuthorTests>.

=head1 COPYRIGHT & LICENSE

Copyright 2009 Tomas Doran, some rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
Commit	Line	Data
a83ae797	1	package Test::EOL;
	2
	3	use strict;
	4	use warnings;
	5
	6	use Test::Builder;
	7	use File::Spec;
	8	use FindBin qw($Bin);
	9	use File::Find;
	10
	11	use vars qw( $VERSION $PERL $UNTAINT_PATTERN $PERL_PATTERN);
	12
fb935bc1	13	$VERSION = '0.7';
a83ae797	14
	15	$PERL = $^X \|\| 'perl';
	16	$UNTAINT_PATTERN = qr\|^([-+@\w./:\\]+)$\|;
	17	$PERL_PATTERN = qr/^#!.*perl/;
	18
	19	my %file_find_arg = ($] <= 5.006) ? () : (
	20	untaint => 1,
	21	untaint_pattern => $UNTAINT_PATTERN,
	22	untaint_skip => 1,
	23	);
	24
	25	my $Test = Test::Builder->new;
	26	my $updir = File::Spec->updir();
	27
	28	sub import {
	29	my $self = shift;
	30	my $caller = caller;
	31	{
	32	no strict 'refs';
	33	*{$caller.'::eol_unix_ok'} = \&eol_unix_ok;
	34	*{$caller.'::all_perl_files_ok'} = \&all_perl_files_ok;
	35	}
	36	$Test->exported_to($caller);
	37	$Test->plan(@_);
	38	}
	39
	40	sub _all_perl_files {
	41	my @all_files = _all_files(@_);
	42	return grep { _is_perl_module($_) \|\| _is_perl_script($_) } @all_files;
	43	}
	44
	45	sub _all_files {
	46	my @base_dirs = @_ ? @_ : File::Spec->catdir($Bin, $updir);
	47	my @found;
	48	my $want_sub = sub {
5bcec1c9	49	return if ($File::Find::dir =~ m![\\/]?CVS[\\/]\|[\\/]?.svn[\\/]!); # Filter out cvs or subversion dirs/
a83ae797	50	return if ($File::Find::dir =~ m![\\/]?blib[\\/]libdoc$!); # Filter out pod doc in dist
	51	return if ($File::Find::dir =~ m![\\/]?blib[\\/]man\d$!); # Filter out pod doc in dist
	52	return if ($File::Find::name =~ m!Build$!i); # Filter out autogenerated Build script
	53	return unless (-f $File::Find::name && -r _);
	54	push @found, File::Spec->no_upwards( $File::Find::name );
	55	};
	56	my $find_arg = {
	57	%file_find_arg,
	58	wanted => $want_sub,
	59	no_chdir => 1,
	60	};
	61	find( $find_arg, @base_dirs);
	62	return @found;
	63	}
	64
f17f4176	65	# Formats various human invisible symbols
	66	# to similar visible ones.
	67	# Perhaps ^M or something like that
	68	# would be more appropriate?
	69
	70	sub _show_whitespace {
	71	my $string = shift;
	72	$string =~ s/\r/[\\r]/g;
	73	$string =~ s/\t/[\\t]/g;
	74	$string =~ s/ /[\\s]/g;
	75	return $string;
	76	}
	77
	78	# Format a line record for diagnostics.
	79
	80	sub _debug_line {
	81	my ( $options, $line ) = @_;
	82	$line->[2] =~ s/\n\z//g;
	83	return "line $line->[1] : $line->[0] " . (
	84	$options->{show_lines} ? qq{: } . _show_whitespace( $line->[2] ) : q{}
	85	);
	86	}
	87
a83ae797	88	sub eol_unix_ok {
a83ae797	89	my $file = shift;
91613276	90	my $test_txt;
	91	$test_txt = shift if !ref $_[0];
	92	$test_txt \|\|= "No windows line endings in '$file'";
	93	my $options = shift if ref $_[0] eq 'HASH';
	94	$options \|\|= {
	95	trailing_whitespace => 0,
f17f4176	96	all_reasons => 0,
91613276	97	};
a83ae797	98	$file = _module_to_path($file);
f17f4176	99
a83ae797	100	open my $fh, $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
f17f4176	101	# Windows-- , default is :crlf, which hides \r\n -_-
f17f4176	102	binmode( $fh, ':raw:utf8' );
a83ae797	103	my $line = 0;
f17f4176	104	my @fails;
a83ae797	105	while (<$fh>) {
a83ae797	106	$line++;
f17f4176	107	if ( !$options->{trailing_whitespace} && /(\r+)$/ ) {
	108	my $match = $1;
	109	push @fails, [ _show_whitespace( $match ) , $line , $_ ];
a83ae797	110	}
f17f4176	111	if ( $options->{trailing_whitespace} && /([ \t]*\r+\|[ \t]+)$/ ) {
	112	my $match = $1;
	113	push @fails, [ _show_whitespace($match), $line , $_ ];
	114	}
	115	# Minor short-circuit for people who don't need the whole file scanned
	116	# once there's an err.
	117	last if( @fails > 0 && !$options->{all_reasons} );
	118	}
	119	if( @fails ){
	120	$Test->ok( 0, $test_txt . " on " . _debug_line({ show_lines => 0 } , $fails[0] ) );
	121	if ( $options->{all_reasons} \|\| 1 ){
	122	$Test->diag( " Problem Lines: ");
	123	for ( @fails ){
	124	$Test->diag(_debug_line({ show_lines => 1 } , $_ ) );
	125	}
	126	}
	127	return 0;
a83ae797	128	}
	129	$Test->ok(1, $test_txt);
	130	return 1;
	131	}
a83ae797	132	sub all_perl_files_ok {
91613276	133	my $options = shift if ref $_[0] eq 'HASH';
a83ae797	134	my @files = _all_perl_files( @_ );
	135	_make_plan();
	136	foreach my $file ( @files ) {
91613276	137	eol_unix_ok($file, $options);
a83ae797	138	}
	139	}
	140
	141	sub _is_perl_module {
	142	$_[0] =~ /\.pm$/i \|\| $_[0] =~ /::/;
	143	}
	144
	145	sub _is_perl_script {
	146	my $file = shift;
	147	return 1 if $file =~ /\.pl$/i;
	148	return 1 if $file =~ /\.t$/;
	149	open my $fh, $file or return;
	150	my $first = <$fh>;
	151	return 1 if defined $first && ($first =~ $PERL_PATTERN);
	152	return;
	153	}
	154
	155	sub _module_to_path {
	156	my $file = shift;
	157	return $file unless ($file =~ /::/);
	158	my @parts = split /::/, $file;
	159	my $module = File::Spec->catfile(@parts) . '.pm';
	160	foreach my $dir (@INC) {
	161	my $candidate = File::Spec->catfile($dir, $module);
	162	next unless (-e $candidate && -f _ && -r _);
	163	return $candidate;
	164	}
	165	return $file;
	166	}
	167
	168	sub _make_plan {
	169	unless ($Test->has_plan) {
	170	$Test->plan( 'no_plan' );
	171	}
	172	$Test->expected_tests;
	173	}
	174
	175	sub _untaint {
	176	my @untainted = map { ($_ =~ $UNTAINT_PATTERN) } @_;
	177	return wantarray ? @untainted : $untainted[0];
	178	}
	179
	180	1;
	181	__END__
	182
	183	=head1 NAME
	184
	185	Test::EOL - Check the correct line endings in your project
	186
	187	=head1 SYNOPSIS
	188
29330dd1	189	C<Test::EOL> lets you check the presence of windows line endings in your
29330dd1	190	perl code. It
a83ae797	191	report its results in standard C<Test::Simple> fashion:
	192
	193	use Test::EOL tests => 1;
29330dd1	194	eol_unix_ok( 'lib/Module.pm', 'Module is ^M free');
a83ae797	195
91613276	196	and to add checks for trailing whitespace:
	197
	198	use Test::EOL tests => 1;
	199	eol_unix_ok( 'lib/Module.pm', 'Module is ^M and trailing whitespace free', { trailing_whitespace => 1 });
	200
a83ae797	201	Module authors can include the following in a t/eol.t and have C<Test::EOL>
	202	automatically find and check all perl files in a module distribution:
	203
	204	use Test::EOL;
	205	all_perl_files_ok();
	206
	207	or
	208
	209	use Test::EOL;
	210	all_perl_files_ok( @mydirs );
	211
91613276	212	and if authors would like to check for trailing whitespace:
	213
	214	use Test::EOL;
	215	all_perl_files_ok({ trailing_whitespace => 1 });
	216
	217	or
	218
	219	use Test::EOL;
	220	all_perl_files_ok({ trailing_whitespace => 1 }, @mydirs );
	221
a83ae797	222	=head1 DESCRIPTION
	223
	224	This module scans your project/distribution for any perl files (scripts,
29330dd1	225	modules, etc) for the presence of windows line endings.
a83ae797	226
	227	=head1 EXPORT
	228
	229	A list of functions that can be exported. You can delete this section
	230	if you don't export anything, such as for a purely object-oriented module.
	231
	232	=head1 FUNCTIONS
	233
91613276	234	=head2 all_perl_files_ok( [ \%options ], [ @directories ] )
a83ae797	235
	236	Applies C<eol_unix_ok()> to all perl files found in C<@directories> (and sub
	237	directories). If no <@directories> is given, the starting point is one level
	238	above the current running script, that should cover all the files of a typical
	239	CPAN distribution. A perl file is .pl or .pm or *.t or a file starting
	240	with C<#!...perl>
	241
	242	If the test plan is defined:
	243
	244	use Test::EOL tests => 3;
	245	all_perl_files_ok();
	246
	247	the total number of files tested must be specified.
	248
91613276	249	=head2 eol_unix_ok( $file [, $text] [, \%options ] )
a83ae797	250
	251	Run a unix EOL check on C<$file>. For a module, the path (lib/My/Module.pm) or the
	252	name (My::Module) can be both used.
	253
	254	=head1 AUTHOR
	255
	256	Tomas Doran (t0m) C<< <bobtfish@bobtfish.net> >>
	257
	258	=head1 BUGS
	259
	260	Testing for EOL styles other than unix (\n) currently unsupported.
	261
	262	The source code can be found on github, as listed in C< META.yml >,
	263	patches are welcome.
	264
	265	Otherwise please report any bugs or feature requests to
	266	C<bug-test-eol at rt.cpan.org>, or through the web interface at
	267	L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-EOL>.
	268	I will be notified, and then you'll automatically be notified of progress on
	269	your bug as I make changes.
	270
	271	=head1 ACKNOWLEDGEMENTS
	272
	273	Shamelessly ripped off from L<Test::NoTabs>.
	274
	275	=head1 SEE ALSO
	276
	277	L<Test::More>, L<Test::Pod>. L<Test::Distribution>, L<Test:NoWarnings>,
	278	L<Test::NoTabs>, L<Module::Install::AuthorTests>.
	279
	280	=head1 COPYRIGHT & LICENSE
	281
	282	Copyright 2009 Tomas Doran, some rights reserved.
	283
	284	This program is free software; you can redistribute it and/or modify it
	285	under the same terms as Perl itself.
	286
	287	=cut
	288