t/12-fail.t

   1 use strict;
   2
   3 use Test::More qw(no_plan);
   4
   5 use File::Temp qw( tempdir tempfile );
   6 my $perl  = $^X || 'perl';
   7 my $inc = join(' -I ', map { qq{"$_"} } @INC) || '';
   8 $inc = "-I $inc" if $inc;
   9
  10 {
  11     my ( $dir, $filename ) = make_raw_badfile();
  12     local $/ = undef;
  13     open my $fh, '<', $filename or die $!;
  14     binmode( $fh, ':raw' );
  15     my $content = <$fh>;
  16     is( $content, ascii_string(), 'Data written to file is there when we look for it later' );
  17
  18 }
  19 {
  20     my $dir = make_bad_file_1();
  21     run_ok( "all_perl_files_ok( '$dir' )",
  22             qr/^not ok 1 - No incorrect line endings in '[^']*' \Qon line 4: [\r]/m,
  23             'windows EOL found in tmp file 1' );
  24 }
  25 {
  26     my $dir = make_bad_file_2();
  27     run_ok( "all_perl_files_ok( '$dir' )",
  28             qr/^not ok 1 - No incorrect line endings in '[^']*' \Qon line 8: [\r][\r][\r][\r][\r][\r][\r]/m,
  29             'windows EOL found in tmp file2 ' );
  30 }
  31 {
  32     my ($dir, $file) = make_bad_file_3();
  33     run_ok( "all_perl_files_ok( '$file' )",
  34             qr/^not ok 1 - No incorrect line endings in '[^']*' \Qon line 9: [\r][\r][\r]/m,
  35             'windows EOL found in tmp file 3' );
  36 }
  37
  38 {
  39     my $dir = make_bad_file_4();
  40     run_ok( "all_perl_files_ok({trailing_whitespace => 1}, '$dir' )",
  41             qr/^not ok 1 - No incorrect line endings in '[^']*' \Qon line 13: [\s][\t][\s][\s]/m,
  42             'Trailing ws EOL found in tmp file 4' );
  43 }
  44
  45 sub run_ok {
  46     my ($code, $match, $test_name) = @_;
  47     my $line = (caller)[2];
  48     die "code containing double quotes is not portable on Win32 in one-liners" if $code =~ /"/;
  49     my (undef, $outfile) = tempfile();
  50     is( `$perl $inc -MTest::EOL -e "$code" > $outfile 2>&1`, '', "test sub program at line $line: output redirected" );
  51     is( $? >> 8, 1, "test sub program at line $line: exit code is 1" );
  52     local $/ = undef;
  53     open my $fh, '<', $outfile or die $!;
  54     my $content = <$fh>;
  55     like( $content, $match, $test_name );
  56     unlink $outfile;
  57 }
  58
  59 sub ascii_string {
  60   my $o = "<before \r\n between \r\n after \n normal >";
  61   return $o x 3;
  62 }
  63
  64 sub make_raw_badfile {
  65   my $tmpdir = tempdir( CLEANUP => 1 );
  66   my ( $fh, $filename ) = tempfile( DIR => $tmpdir, SUFFIX =>  '.tXt' );
  67   binmode $fh, ':raw';
  68   print $fh ascii_string();
  69   close $fh;
  70   return ( $tmpdir, $filename );
  71 }
  72
  73
  74 sub make_bad_file_1 {
  75   my $tmpdir = tempdir( CLEANUP => 1 );
  76   my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pL' );
  77   binmode $fh, ':raw';
  78   my $str = <<"DUMMY";
  79 #!perl
  80
  81 sub main {
  82     print "Hello!\r\n";
  83 }
  84 DUMMY
  85   print $fh $str;
  86
  87   return $tmpdir;
  88 }
  89
  90 sub make_bad_file_2 {
  91   my $tmpdir = tempdir( CLEANUP => 1 );
  92   my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pL' );
  93   binmode $fh, ':raw';
  94   print $fh <<"DUMMY";
  95 #!perl
  96
  97 =pod
  98
  99 =head1 NAME
 100
 101 test.pL -       A test script
 102 \r\r\r\r\r\r\r\r
 103 =cut
 104
 105 sub main {
 106     print "Hello!\n";
 107 }
 108 DUMMY
 109   return $tmpdir;
 110 }
 111
 112 sub make_bad_file_3 {
 113   my $tmpdir = tempdir( CLEANUP => 1 );
 114   my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pm' );
 115   binmode $fh, ':raw';
 116   print $fh <<"DUMMY";
 117 use strict;\r
 118 \r
 119 package My::Test;\r
 120 \r
 121 sub new {\r
 122     my (\$class) = @_;\r
 123     my \$self = bless { }, \$class;\r
 124     return \$self;\r
 125 }\r\r\r\r
 126
 127 \r
 128 1;\r
 129 DUMMY
 130   close $fh;
 131   return ($tmpdir, $filename);
 132 }
 133
 134 sub make_bad_file_4 {
 135   my $tmpdir = tempdir( CLEANUP => 1 );
 136   my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pL' );
 137   binmode $fh, ':raw';
 138   print $fh <<"DUMMY";
 139 #!perl
 140
 141 =pod
 142
 143 =head1 NAME
 144
 145 test.pL -       A test script
 146
 147 =cut
 148
 149 sub main {
 150 DUMMY
 151
 152 print $fh qq{    print "Hello!\n"; \t  \n}; # <-- whitespace
 153 print $fh '}';
 154
 155   return $tmpdir;
 156 }
 157