From: Steve Hancock Date: Thu, 19 Aug 2021 23:54:12 +0000 (-0700) Subject: added utility to test for problems with tab characters X-Git-Tag: 20210717.02~36 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=d46162180343e147731448982fb874f1b4205cb8;p=perltidy.git added utility to test for problems with tab characters --- diff --git a/dev-bin/perltidy_tab_test.pl b/dev-bin/perltidy_tab_test.pl new file mode 100755 index 00000000..a8bbc1df --- /dev/null +++ b/dev-bin/perltidy_tab_test.pl @@ -0,0 +1,230 @@ +#!/usr/bin/perl -w +use strict; +use warnings; + +# This is a utility to stress test perltidy by changing all code blank characters +# into tabs. + +# Usage: + +# 1. Important: work in a new temporary empty directory below a directory full of +# perl scripts. + +# 2. Then enter: +# +# perltidy_tab_test.pl >out.txt 2>err.txt +# +# to operate on all regular files in the parent directory, i.e. '../*' + +# More generally: +# perltidy_tab_test.pl file1 [ file2 ... +# where file1 .. are the files to operate on + +# 3. Look at the err.txt and any files remaining after the run. + +# 4. When done, remove the temporary directory + +# NOTE: +# Files with format-skipping will be reported as errors since they will +# get tabs which will not be removed. These should be the only results +# reported with errors. + +my $cmd; +my @files = @ARGV; +if ( !@files ) { @files = glob('../*'); } +my $total_error_count = 0; +foreach my $file (@files) { + + unless ( -e $file && -f $file && -s $file ) { + print STDERR "skipping $file\n"; + next; + } + + # Best to skip files written by perltidy + if ( $file =~ /\.(tdy|ERR|LOG|DEBUG)$/ ) { + print STDERR "skipping $file\n"; + next; + } + + # Skip a file which produces an error + my $tmp = "tmp.out"; + my $cmd = "perltidy $file -o $tmp"; + system($cmd); + my $efile = "$file.ERR"; + if ( -e $efile ) { + unlink $efile; + unlink $tmp; + next; + print "Skipping $file: produces error\n"; + } + + my $tab_count_0 = file_tab_count($file); + + my $basename = $file; + if ( $basename =~ /^(.*)\/([^\/]+)$/ ) { $basename = $2 } + my $file1 = "$basename.1"; + my $file2 = "$basename.2"; + + add_tabs( $file, $file1 ); + my $tab_count_1 = file_tab_count($file1); + + $cmd = "perltidy $file1 -o $file2"; + system($cmd); + my $tab_count_2 = file_tab_count($file2); + + # If the tab count increases, note this as an error to be checked. + my $status = "OK"; + if ( $tab_count_2 > $tab_count_0 ) { + $status = "ERROR"; + $total_error_count++; + } + + print "$file: $tab_count_0 $tab_count_1 $tab_count_2 $status\n"; + if ( $status ne "OK" ) { + print STDERR "$file: $tab_count_0 $tab_count_1 $tab_count_2 $status\n"; + } + + # Clean up files if no error, otherwise leave them + if ( $status eq "OK" && !-e $file2 . ".ERR" ) { + unlink $file1; + unlink $file2; + } + +} + +if ($total_error_count) { + print "\nERROR COUNT: $total_error_count\n"; + print STDERR "\nERROR COUNT: $total_error_count\n"; +} +else { + print "\nOK\n"; +} + +sub get_string { + my ($file) = @_; + open my $fh, '<', $file or die "cannot open $file: $!\n"; + local $/ = undef; + my $string = <$fh>; + close $fh; + return $string; +} + +sub file_tab_count { + my ($file) = @_; + my $str = get_string($file); + return string_tab_count($str); +} + +sub string_tab_count { + my ($str) = @_; + return 0 unless ($str); + return $str =~ tr /\t//; +} + +sub write_file { + my ( $fname, $string, $msg ) = @_; + open my $fh, '>', $fname or die "cannot open $fname: $!\n"; + if ( utf8::is_utf8($string) ) { + binmode $fh, ":raw:encoding(UTF-8)"; + } + $fh->print($string); + $fh->close(); + print STDERR "Wrote $fname\n" if ($msg); + return; +} + +use Perl::Tidy; +sub add_tabs { + my ( $ifile, $ofile ) = @_; + + # Given file named $ifile, + # convert code spaces to tabs and write result to $ofile + + # create a mask for use in avoiding placing tabs in unsafe places + my ( @lines ); + + my %args = ( + _source => $ifile, + _roriginal_file => \@lines, + ); + + # run perltidy, which will call $formatter's write_line() for each line + my $err = perltidy( + 'source' => $ifile, + 'formatter' => bless( \%args, __PACKAGE__ ), # callback object + 'argv' => "-npro -se", # -npro : ignore .perltidyrc, + # -se : errors to STDOUT + ); + + if ($err) { + my $name = $args{_source}; + print STDERR "perltidy returns error flag for source=$name\n"; + } + + my $string2 = join "", @lines; + write_file( $ofile, $string2 ); + + return; +} + +sub print_line { + + # called from write_line to dispatch one line + # here we'll either append it to a string or array, as appropriate + my ( $rfile, $line ) = @_; + if ( defined($rfile) ) { + if ( ref($rfile) eq 'SCALAR' ) { + $$rfile .= $line . "\n"; + } + elsif ( ref($rfile) eq 'ARRAY' ) { + push @{$rfile}, $line . "\n"; + } + } +} + +sub write_line { + + # This is called from perltidy line-by-line + my ( $self, $line_of_tokens ) = @_; + my $roriginal_file = $self->{_roriginal_file}; + + my $line_type = $line_of_tokens->{_line_type}; + my $input_line_number = $line_of_tokens->{_line_number}; + my $input_line = $line_of_tokens->{_line_text}; + my $rtoken_type = $line_of_tokens->{_rtoken_type}; + my $rtokens = $line_of_tokens->{_rtokens}; + chomp $input_line; + + # Output non-CODE lines unchanged + if ( $line_type ne 'CODE' ) { + print_line( $roriginal_file, $input_line ) if $roriginal_file; + return; + } + + my $tab_line = ""; + + # loop over tokens to make the changes + for ( my $j = 0 ; $j < @$rtoken_type ; $j++ ) { + + my $token = $rtokens->[$j]; + + ###################### + # Convert space to tab + ###################### + if ( $$rtoken_type[$j] eq 'b' ) { + $token =~ s/ /\t/g; + } + elsif ( $$rtoken_type[$j] eq 'i' ) { + $token =~ s/ /\t/g; + } + + $tab_line .= $token; + } + print_line( $roriginal_file, $tab_line ) if $roriginal_file; +} + +# called once after the last line of a file +sub finish_formatting { + my $self = shift; + return; +} diff --git a/local-docs/BugLog.pod b/local-docs/BugLog.pod index 470f64b0..994d9607 100644 --- a/local-docs/BugLog.pod +++ b/local-docs/BugLog.pod @@ -5,7 +5,7 @@ =item B This update fixes some problems found in random testing with tab characters. -For example, In the following snippet there is a tab character after 'sub' +For example, in the following snippet there is a tab character after 'sub' do sub : lvalue { return; @@ -37,7 +37,7 @@ and corrected. This fixes issue c062. -18 Aug 2021. +18 Aug 2021, d86787f. =item B @@ -68,7 +68,7 @@ This update corrects the problem: This fixes case c061; -18 Aug 2021. +18 Aug 2021, 3bb2b2c. =item B