From: Steve Hancock Date: Tue, 15 Feb 2022 14:58:59 +0000 (-0800) Subject: clean up testing utils X-Git-Tag: 20220217~2 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=430f4ff6be3bd01acc95441557f13a40cb35aa2b;p=perltidy.git clean up testing utils --- diff --git a/CHANGES.md b/CHANGES.md index 6a3e048d..64812e3f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -109,7 +109,7 @@ without parens around the call args. Some examples: # OLD - mkTextConfi2022 Helen Hancockg $c, $x, $y, -anchor => 'se', $color; + mkTextConfig $c, $x, $y, -anchor => 'se', $color; mkTextConfig $c, $x + 30, $y, -anchor => 's', $color; mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color; mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color; diff --git a/docs/ChangeLog.html b/docs/ChangeLog.html index 9f953cad..a7ea3a84 100644 --- a/docs/ChangeLog.html +++ b/docs/ChangeLog.html @@ -110,7 +110,7 @@ without parens around the call args. Some examples: # OLD - mkTextConfi2022 Helen Hancockg $c, $x, $y, -anchor => 'se', $color; + mkTextConfig $c, $x, $y, -anchor => 'se', $color; mkTextConfig $c, $x + 30, $y, -anchor => 's', $color; mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color; mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color; diff --git a/t/snippets/dump_negated_switches.pl b/t/snippets/dump_negated_switches.pl index a74dd95e..0cd8cc38 100755 --- a/t/snippets/dump_negated_switches.pl +++ b/t/snippets/dump_negated_switches.pl @@ -39,7 +39,6 @@ foreach (@skip) { if ( $abbrev{$_} ) { delete $abbrev{$_} } } - # Select the short names which can be negated my @short_list; foreach my $long (@binary_long_names) { @@ -52,21 +51,21 @@ foreach my $long (@binary_long_names) { # special aliases not obtained automatically my @special = qw( -oll -dac -tac -html -sob -baa -bbs -kgb -icp -otr -sot -sct -sac -sobb -conv + oll + dac + tac + html + sob + baa + bbs + kgb + icp + otr + sot + sct + sac + sobb + conv ); my $FIELD_WIDTH = 6; @@ -74,7 +73,7 @@ my $WORDS_PER_LINE = 10; my $line = " "; my $count = 0; -foreach my $word ( sort (@short_list, @special) ) { +foreach my $word ( sort ( @short_list, @special ) ) { my $len = length($word); my $nsp = $FIELD_WIDTH - $len + 1; $word .= " " x $nsp; diff --git a/t/snippets/make_coverage_report.pl b/t/snippets/make_coverage_report.pl index c57e58f1..a00e1971 100755 --- a/t/snippets/make_coverage_report.pl +++ b/t/snippets/make_coverage_report.pl @@ -4,22 +4,25 @@ use warnings; use Perl::Tidy; use Data::Dumper; +#-------------------------------------------------------------------------- +# NOTE: While this gives useful information, I have concluded that due to +# the large number of parameters and their possible interactions, automated +# random testing is a better way to be sure perltidy parameters are tested. +# So this program is no longer used. +#-------------------------------------------------------------------------- + # This will eventually read all of the '.par' files and write a report # showing the parameter coverage. # The starting point for this program is 'examples/perltidyrc_dump.pl' -# The plan is: +# The plan is: # read each '.par' file # use perltidy's options-dump feature to convert to long names and return in a hash # combine all of these results and write back to standard output in sorted order # # It will also be useful to output a list of unused parameters -# NOTE: While this gives useful information, I have concluded that due to -# the large number of parameters and their possible interactions, automated -# random testing is a better way to be sure perltidy parameters are tested. - my $usage = <{$long_name}) ) { + if ( defined( $rOpts_default->{$long_name} ) ) { my $val = $rOpts_default->{$long_name}; $rsaw_values->{$long_name} = [$val]; } @@ -74,13 +77,12 @@ foreach my $long_name ( keys %{$rGetopt_flags} ) { # Store a 0 default for all switches with no default value my $flag = $rGetopt_flags->{$long_name}; if ( $flag eq '!' ) { - my $val=0; + my $val = 0; $rsaw_values->{$long_name} = [$val]; } } } - # Loop over config files foreach my $config_file (@files) { @@ -107,23 +109,23 @@ foreach my $long_name ( keys %{$rGetopt_flags} ) { my @uniq = uniq(@vals); my @sorted = sort { $a cmp $b } @uniq; $rsaw_values->{$long_name} = \@sorted; - my $options_flag = $rGetopt_flags->{$long_name}; - - # Consider switches with just one value as not seen - if ($options_flag eq '!' && @sorted<2) { - push @not_seen, $long_name; - } - else { - push @seen, $long_name; - } + my $options_flag = $rGetopt_flags->{$long_name}; + + # Consider switches with just one value as not seen + if ( $options_flag eq '!' && @sorted < 2 ) { + push @not_seen, $long_name; + } + else { + push @seen, $long_name; + } } else { - push @not_seen, $long_name; + push @not_seen, $long_name; } } # Remove the unseen from the big hash -foreach my $long_name(@not_seen) { +foreach my $long_name (@not_seen) { delete $rsaw_values->{$long_name}; } @@ -143,7 +145,7 @@ print "wrote $fnot_seen\n"; #print Data::Dumper->Dump($rsaw_values); my $fseen = "coverage_values.txt"; open( $fh, ">", $fseen ) || die "can open $fseen: $!\n"; -$fh->print( Dumper($rsaw_values)); +$fh->print( Dumper($rsaw_values) ); $fh->close(); print "wrote $fseen\n"; @@ -286,6 +288,7 @@ sub dump_options { "# ERROR in dump_options: unrecognized flag $flag for $long_name\n"; } } + =pod # These long option names have no abbreviations or are treated specially @option_string = qw( @@ -301,18 +304,17 @@ sub dump_options { # print the long version of the parameter # with the short version as a side comment - my $short_name = $short_name{$long_name}; - my $long_option = $prefix . $long_name . $suffix; - - - # A few options do not have a short abbreviation - # so we will make it the same as the long option - # These include 'recombine' and 'valign', which are mainly - # for debugging. - my $short_option = $long_option; - if ($short_name) { - $short_option = $short_prefix . $short_name . $suffix; - } + my $short_name = $short_name{$long_name}; + my $long_option = $prefix . $long_name . $suffix; + + # A few options do not have a short abbreviation + # so we will make it the same as the long option + # These include 'recombine' and 'valign', which are mainly + # for debugging. + my $short_option = $long_option; + if ($short_name) { + $short_option = $short_prefix . $short_name . $suffix; + } my $note = $requals_default->{$long_name} ? " [=default]" : ""; if ( $rmy_opts->{s} ) { @@ -392,8 +394,10 @@ sub get_perltidy_options { } } - return ( $error_message, \%Getopt_flags, \%sections, \%abbreviations, - \%Opts_default, ); + return ( + $error_message, \%Getopt_flags, \%sections, + \%abbreviations, \%Opts_default, + ); } sub read_perltidyrc { @@ -417,12 +421,12 @@ sub read_perltidyrc { my %abbreviations; Perl::Tidy::perltidy( - perltidyrc => $config_file, - dump_options => \%Opts, - dump_options_type => 'perltidyrc', # default is 'perltidyrc' - dump_abbreviations => \%abbreviations, - stderr => \$stderr, - argv => \$argv, + perltidyrc => $config_file, + dump_options => \%Opts, + dump_options_type => 'perltidyrc', # default is 'perltidyrc' + dump_abbreviations => \%abbreviations, + stderr => \$stderr, + argv => \$argv, ); # try to capture any errors generated by perltidy call @@ -437,7 +441,7 @@ sub read_perltidyrc { print "$key -> $Opts{$key}\n"; } } - return ( $error_message, \%Opts); + return ( $error_message, \%Opts ); } sub xx_read_perltidyrc { diff --git a/t/snippets/make_expect.pl b/t/snippets/make_expect.pl index e80e23a9..48ec58e7 100755 --- a/t/snippets/make_expect.pl +++ b/t/snippets/make_expect.pl @@ -72,13 +72,14 @@ my $get_param = sub { my ($pname) = @_; if ( $pname && !defined( $rparams->{$pname} ) ) { my $pstring = $get_string->( $pname . ".par" ); - chomp $pstring; -# my $pstring = $read_parameters->( $pname . ".par" ); -# if ($pstring) { -# $pstring =~ s/\n/ /g; -# $pstring =~ s/\s+/ /; -# $pstring =~ s/\s*$//; -# } + chomp $pstring; + + # my $pstring = $read_parameters->( $pname . ".par" ); + # if ($pstring) { + # $pstring =~ s/\n/ /g; + # $pstring =~ s/\s+/ /; + # $pstring =~ s/\s*$//; + # } $rparams->{$pname} = $pstring; } }; @@ -92,8 +93,8 @@ if ( !defined( $rparams->{$defname} ) ) { # To speed up testing, you may enter specific files # if none are given all are used my @files = @ARGV; -if (!@files) { - @files = glob('*.in *.par'); +if ( !@files ) { + @files = glob('*.in *.par'); } foreach my $file (@files) { @@ -117,22 +118,22 @@ foreach my $sname ( keys %{$rsources} ) { my @pnames; @pnames = keys %{$rparams}; foreach my $pname (@pnames) { - my $proot = ( $pname =~ /^([^\d]+)/ ) ? $1 : $pname; + my $proot = ( $pname =~ /^([^\d]+)/ ) ? $1 : $pname; my $match = - # exact match of source and parameter file base names - $pname eq $sname + # exact match of source and parameter file base names + $pname eq $sname - # match of source root to parameter file base name + # match of source root to parameter file base name || $pname eq $sroot - # match of source base name to parameter root + # match of source base name to parameter root || $proot eq $sname - # defaults apply to all files + # defaults apply to all files || $pname eq $defname; - next unless ($match); + next unless ($match); my $output; my $source = $rsources->{$sname}; @@ -143,22 +144,22 @@ foreach my $sname ( keys %{$rsources} ) { source => \$source, destination => \$output, perltidyrc => \$params, - argv => '', # don't let perltidy look at my @ARGV + argv => '', # don't let perltidy look at my @ARGV stderr => \$stderr_string, - errorfile => \$errorfile_string, # not used when -se flag is set + errorfile => \$errorfile_string, # not used when -se flag is set ); if ($stderr_string) { - print STDERR "---------------------\n"; + print STDERR "---------------------\n"; print STDERR "<>\n$stderr_string\n"; - print STDERR "---------------------\n"; + print STDERR "---------------------\n"; die "The above error was received with $source + $params\n"; } - if ($errorfile_string) { - print STDERR "---------------------\n"; + if ($errorfile_string) { + print STDERR "---------------------\n"; print STDERR "<<.ERR file>>\n$errorfile_string\n"; - print STDERR "---------------------\n"; + print STDERR "---------------------\n"; die "The above .ERR was received with $source + $params\n"; - } + } if ($err) { die "error calling Perl::Tidy with $source + $params\n"; } @@ -184,8 +185,8 @@ foreach my $basename (@olist) { my $tname = $opath . $basename; my $ename = $epath . $basename; if ( !-e $ename ) { - my $new_file = "tmp/$basename"; - push @new, $new_file; + my $new_file = "tmp/$basename"; + push @new, $new_file; print "$new_file is a new file\n"; push @mv, "cp $tname $ename"; } @@ -198,8 +199,8 @@ foreach my $basename (@olist) { } } -my $diff_file="diff.txt"; -if ( -e "$diff_file" ) { unlink("$diff_file") } +my $diff_file = "diff.txt"; +if ( -e "$diff_file" ) { unlink("$diff_file") } if (@same) { my $num = @same; print "$num Unchanged files\n"; @@ -226,7 +227,7 @@ my $runme = "RUNME.sh"; if ( !@mv ) { print "No differences\n"; - if (-e $runme) {unlink $runme} + if ( -e $runme ) { unlink $runme } exit; } @@ -287,21 +288,24 @@ If the differences and any new results look okay, then Enter ./$runme to move results from tmp/ to expect/ and make new .t files EOM } + sub query { my ($msg) = @_; print $msg; my $ans = ; chomp $ans; + #my $val=$ans; return $ans; } + sub ifyes { - # Updated to have default, which should be "Y" or "N" - my ($msg, $default)=@_; + # Updated to have default, which should be "Y" or "N" + my ( $msg, $default ) = @_; my $count = 0; ASK: - my $ans = query($msg); + my $ans = query($msg); if ( defined($default) ) { $ans = $default unless ($ans); } diff --git a/t/snippets/make_t.pl b/t/snippets/make_t.pl index 3d85de6a..9164d32d 100755 --- a/t/snippets/make_t.pl +++ b/t/snippets/make_t.pl @@ -84,15 +84,15 @@ EOM # methods work. It can be necessary to switch between these # methods if something goes wrong during development. #my $rpacking_list=get_packing_list($fpacking_list); -my $rpacking_list=get_packing_list(); +my $rpacking_list = get_packing_list(); my @exp = glob("$ipath*"); #print "exp=(@exp)\n"; -my $ix = 0; +my $ix = 0; my $rix_lookup = {}; my %is_basename; -foreach my $file_exp (sort @exp) { +foreach my $file_exp ( sort @exp ) { my $estring = $get_string->($file_exp); my $ename = $file_exp; if ( $ename =~ /([^\/]+)$/ ) { $ename = $1 } @@ -110,10 +110,10 @@ foreach my $file_exp (sort @exp) { # Find the base names. NOTE: I tried packing by basename, which makes tracking # down errors a little easier, and makes the files change less frequently, but # the run times increased too much over the 'snippets*.t' packing method. For -# example, here are times recorded in April 2020 +# example, here are times recorded in April 2020 -# packing in 20 files, snippets1.t ... snippets20.t: 17.7 s -# packing in 226 files, 105484.t ... wngnu1.t: 44.7 s +# packing in 20 files, snippets1.t ... snippets20.t: 17.7 s +# packing in 226 files, 105484.t ... wngnu1.t: 44.7 s # so there is over a factor of 2 increase in run time for the convenience of # packing by base name. The extra time is due to continually reloading @@ -143,15 +143,15 @@ foreach my $item ( @{$rtests} ) { print STDERR "Unexpected filename $sname.$pname, using basename=$basename\n"; } - push @{$item}, $basename; + push @{$item}, $basename; push @{ $rpacking_by_basename->{$basename} }, $item; } -# assign indexes to existing packing locations +# assign indexes to existing packing locations my $rassigned; my $rcount; -my $high_file=""; -my $high_digits=0; +my $high_file = ""; +my $high_digits = 0; foreach my $item ( @{$rpacking_list} ) { my ( $ofile, $ename ) = @{$item}; $rcount->{$ofile}++; @@ -170,7 +170,7 @@ foreach my $item ( @{$rpacking_list} ) { } # Pack all new items. Continue with last file in the list -my $ofile_last = $high_file; ##$rpacking_list->[-1]->[0]; +my $ofile_last = $high_file; ##$rpacking_list->[-1]->[0]; my $case_count = $rcount->{$ofile_last} + 1; my $file_count = $high_digits; @@ -205,9 +205,9 @@ foreach my $ofile ( sort keys %{$rpacking_hash} ) { } else { - # a file no longer exists, we should delete or move it + # a file no longer exists, we should delete or move it push @empty_files, $ofile; - system "mv $ofile $ofile.bak"; + system "mv $ofile $ofile.bak"; } } @@ -227,7 +227,7 @@ NOTE: These old files did nnot have any cases, so I moved them to .bak EOM } -write_packing_list("$fpacking_list", $rpacking_list); +write_packing_list( "$fpacking_list", $rpacking_list ); print "Now run a 'make test' from the top directory to check these\n"; # Example showing how to pack the snippet files using base names @@ -249,7 +249,7 @@ if (0) { sub write_packing_list { my ( $ofile, $rpacking ) = @_; - if (-e $ofile) {system "mv $ofile $ofile.bak"} + if ( -e $ofile ) { system "mv $ofile $ofile.bak" } open my $fh, '>', $ofile or die "cannot open $ofile: $!\n"; $fh->print("# This file is automatically generated by make_t.pl\n"); foreach my $item ( @{$rpacking} ) { @@ -321,13 +321,13 @@ sub make_snippet_t { # pull out the parameters and sources we need my $rparams = {}; my $rsources = {}; - my $nn=0; + my $nn = 0; foreach my $item ( @{$rtests} ) { my ( $ename, $pname, $sname, $estring ) = @{$item}; $rparams->{$pname} = $rparams_all->{$pname}; $rsources->{$sname} = $rsources_all->{$sname}; - $nn++; - $ename_string .= "#$nn $ename\n"; + $nn++; + $ename_string .= "#$nn $ename\n"; } my $count = 0; @@ -507,7 +507,7 @@ EOM my $err = Perl::Tidy::perltidy( source => \$script, destination => \$output, - argv => '', # hide any ARGV from perltidy + argv => '', # hide any ARGV from perltidy stderr => \$stderr_string, errorfile => \$errorfile_string, # not used when -se flag is set ); @@ -579,7 +579,7 @@ sub truncate_string { if ( length($string) > $short_length ) { $long = $string; my @words = split( /[\s\-\_\(\)\,\&\+]/, $string ); - my $num = @words; + my $num = @words; $short = shift(@words); for ( my $i = 0 ; $i < $num ; $i++ ) { my $word = shift(@words); diff --git a/t/snippets/perltidy_common_flags.pl b/t/snippets/perltidy_common_flags.pl index d15f392e..296d8b20 100755 --- a/t/snippets/perltidy_common_flags.pl +++ b/t/snippets/perltidy_common_flags.pl @@ -2,6 +2,7 @@ use strict; my @files = @ARGV; my %saw; + # Look at a number of .pro profiles and show their common flags. # This can help pinpoint the flags which are causing an issue. foreach my $file (@files) { @@ -15,8 +16,8 @@ foreach my $file (@files) { } close IN; } -my $nfiles=@files; -foreach my $key(sort keys %saw) { - next if ($saw{$key} != $nfiles); - print $key,"\n"; +my $nfiles = @files; +foreach my $key ( sort keys %saw ) { + next if ( $saw{$key} != $nfiles ); + print $key, "\n"; }