From 48db3ca359d698724cd9d6a9104baf421f900dc5 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Thu, 24 Sep 2020 07:21:26 -0700 Subject: [PATCH] updated utilities for testing perltidy --- t/snippets/perltidy_random_run.pl | 693 ++++++++++++++++ t/snippets/perltidy_random_setup.pl | 1147 +++++++++++++++++++++++++++ 2 files changed, 1840 insertions(+) create mode 100755 t/snippets/perltidy_random_run.pl create mode 100755 t/snippets/perltidy_random_setup.pl diff --git a/t/snippets/perltidy_random_run.pl b/t/snippets/perltidy_random_run.pl new file mode 100755 index 00000000..9adeb6f5 --- /dev/null +++ b/t/snippets/perltidy_random_run.pl @@ -0,0 +1,693 @@ +#!/usr/bin/perl -w +use strict; +use warnings; + +# This program stress-tests perltidy by running it repeatedly +# with random parameters on a variety of files. + +my $usage = < 1 ) { + print STDERR "Too many args\n"; + die $usage; +} +elsif ($ARGV[0]) { + my $arg=$ARGV[0]; + if ( $arg && $arg =~ /^(\d+)\.(\d+)$/ ) { + $nf_beg = $1; + $np_beg = $2; + print STDERR "\nRestarting with arg $arg\n" + } + else { + print STDERR "First arg '$arg' not of form m.n\n"; + die $usage; + } +} + +read_config($config_file); + +my $chain_mode = $rsetup->{chain_mode}; +my $do_syntax_check = $rsetup->{syntax_check}; +my $delete_good_output = $rsetup->{delete_good_output}; +my $FILES_file = $rsetup->{files}; +my $PROFILES_file = $rsetup->{profiles}; + +$FILES_file = "FILES.txt" unless ($FILES_file); +$PROFILES_file = "PROFILES.txt" unless ($PROFILES_file); +$chain_mode = 0 unless defined($chain_mode); +$do_syntax_check = 0 unless defined($do_syntax_check); +$delete_good_output = 1 unless defined($delete_good_output); + +my $rfiles = read_list($FILES_file); +my $rprofiles = read_list($PROFILES_file); + +my @files = @{$rfiles}; +my $nfiles = @files; +print STDOUT "got $nfiles files\n"; +if ( !@files ) { die "No files found\n" } + +if ( !@files ) { die "$usage" } + +# look for profiles +my @profiles = @{$rprofiles}; +if ( !@profiles ) { + print STDOUT "No profiles found .. creating a default\n"; + my $fname = "profile.1"; + open OUT, ">", $fname || die "cannot open $fname: $!\n"; + my $rrandom_parameters = [""]; + foreach ( @{$rrandom_parameters} ) { + print OUT "$_\n"; + } + close OUT; + push @profiles, $fname; +} + +my $rsummary = []; +my @problems; + +my $stop_file = 'stop.now'; +if ( -e $stop_file ) { unlink $stop_file } + +my @chkfile_errors; +my @size_errors; +my @syntax_errors; +my @saved_for_deletion; + +if ( $nf_beg < 1 ) { $nf_beg = 1 } +if ( $np_beg < 1 ) { $np_beg = 1 } +my $nf_end = @files; +my $np_end = @profiles; +if ( $nf_beg > $nf_end || $np_beg > $np_end ) { + + die < 1 ) { $ext = "$file_count.$case" } + + my $ofile = "ofile.$ext"; + my $chkfile = "chkfile.$ext"; + + print STDERR "\n-----\nRun '$nf.$np' : profile='$profile', ifile='$ifile'\n"; + + my $cmd = "perltidy <$ifile >$ofile -pro=$profile"; + print STDERR "$cmd\n"; + system $cmd; + my $efile = "perltidy.ERR"; + my $logfile = "perltidy.LOG"; + if ( -e $efile ) { rename $efile, "ERR.$ext" } + if ( -e $logfile ) { rename $logfile, "LOG.$ext" } + + if ( !-e $ofile ) { + print STDERR "**Warning** missing output $ofile\n"; + $missing_ofile_count++; + $error_flag = 1; + $error_count_this_file++; + $error_count_this_case++; + } + + else { + my $ofile_size = -s $ofile; + if ( !defined($ofile_size_min) ) { + $ofile_size_min = $ofile_size_max = $ofile_size; + $ofile_case_min = $ofile_case_max = $ofile; + } + else { + if ( $ofile_size < $ofile_size_min ) { + $ofile_size_min = $ofile_size; + $ofile_case_min = $ofile; + } + if ( $ofile_size > $ofile_size_max ) { + $ofile_size_max = $ofile_size; + $ofile_case_max = $ofile; + } + } + + # Min possible size is the min of cases 2 and 3 + # Save this to check other results for file truncation + if ( $case == 2 ) { $ofile_size_min_expected = $ofile_size } + elsif ( $case == 3 ) { + if ( $ofile_size < $ofile_size_min_expected ) { + $ofile_size_min_expected = $ofile_size; + } + } + + # Check for unexpectedly very small file size + elsif ( $case > 3 && $ofile_size < 0.6 * $ofile_size_min_expected ) + { + print STDERR +"**ERROR for ofile=$ofile: size = $ofile_size < $ofile_size_min_expected = min expected\n"; + push @size_errors, $ofile; + $error_count_this_file++; + $error_count_this_case++; + } + + } + + my $efile_size = 0; + if ( -e $efile ) { + $efile_size = -s $efile; + $efile_count++; + if ( !defined($efile_size_min) ) { + $efile_size_min = $efile_size_max = $efile_size; + $efile_case_min = $efile_case_max = $efile; + } + else { + if ( $efile_size < $efile_size_min ) { + $efile_size_min = $efile_size; + $efile_case_min = $efile; + } + if ( $efile_size > $efile_size_max ) { + $efile_size_max = $efile_size; + $efile_case_max = $efile; + } + } + } + + # Do a syntax check if requested + if ( $do_syntax_check && $starting_syntax_ok ) { + my $synfile = "$ofile.syntax"; + my $cmd = "perl -c $ofile 2>$synfile"; + system($cmd); + my $fh; + if ( open( $fh, '<', $synfile ) ) { + my @lines = <$fh>; + my $syntax_ok = @lines && $lines[-1] =~ /syntax OK/i; + if ( $case == 1 ) { + $starting_syntax_ok = $syntax_ok; + unlink $synfile; + if ($syntax_ok) { print STDERR "syntax OK for $ofile\n"; } + } + elsif ($syntax_ok) { + unlink $synfile; + } + else { + print STDERR "**ERROR syntax** see $synfile\n"; + $error_count++; + push @syntax_errors, $synfile; + $error_count_this_file++; + $error_count_this_case++; + } + $fh->close(); + } + } + + # run perltidy on the output to see if it can be reformatted + # without errors + my $cmd2 = "perltidy <$ofile >$chkfile"; + system $cmd2; + print STDERR "$cmd2\n"; + my $err; + if ( -e $efile ) { + rename $efile, "$chkfile.ERR"; + $err = 1; + if ( $case == 1 ) { + $has_starting_error = 1; + } + elsif ( !$has_starting_error ) { + print STDERR "**ERROR reformatting** see $chkfile.ERR\n"; + $error_count++; + push @chkfile_errors, $chkfile; + $error_count_this_file++; + $error_count_this_case++; + } + } + if ( !-e $chkfile ) { + print STDERR "**WARNING** missing checkfile output $chkfile\n"; + $missing_chkfile_count++; + $err = 1; + $error_count_this_file++; + $error_count_this_case++; + } + else { + my $chkfile_size = -s $chkfile; + if ( !defined($chkfile_size_min) ) { + $chkfile_size_min = $chkfile_size_max = $chkfile_size; + $chkfile_case_min = $chkfile_case_max = $chkfile; + } + else { + if ( $chkfile_size < $chkfile_size_min ) { + $chkfile_size_min = $chkfile_size; + $chkfile_case_min = $chkfile; + } + if ( $chkfile_size > $chkfile_size_max ) { + $chkfile_size_max = $chkfile_size; + $chkfile_case_max = $chkfile; + } + } + } + + # do not delete the ofile yet if it did not come from the original + my $do_not_delete = $ifile ne $ifile_original; + + # Set input file for next run + $ifile = $ifile_original; + if ( $case < 4 ) { + $ifile = $ofile; + } + elsif ( $chain_mode && !$err ) { + # 'Chaining' means the next run formats the output of the previous + # run instead of formatting the original file. + # 0 = no chaining + # 1 = always chain unless error + # 2 = random chaining + + if ( $chain_mode == 1 || int( rand(1) + 0.5 ) ) { + { $ifile = $ofile } + } + } + + # do not delete the ofile if it is the input for the next run + $do_not_delete ||= $ifile eq $ofile; + + if ( $rsetup->{delete_good_output} ) { + + # Files created this run + my @created = + ( $ofile, $chkfile, "LOG.$ext", "ERR.$ext", "$chkfile.ERR" ); + + # keep history if there was an error + if ($error_count_this_file) { + @saved_for_deletion = (); + } + + # postpone deletion if next file depends upon it + elsif ($do_not_delete) { + foreach (@created) + { #( $ofile, $chkfile, "LOG.$ext", "ERR.$ext", "$chkfile.ERR" ) { + push @saved_for_deletion, $_; + } + } + + # otherwise, delete these files and the history + else { + foreach (@created) { + unlink $_ if ( -e $_ ); + ##print STDERR "deleting $_\n"; + } + foreach (@saved_for_deletion) { + unlink $_ if ( -e $_ ); + ##print STDERR "deleting $_\n"; + } + @saved_for_deletion = (); + print STDERR "deleting $ofile, not needed\n"; + } + } + + if ( -e $stop_file ) { + print STDERR "$stop_file seen; exiting\n"; + last MAIN_LOOP; + } + + # give up on a file if too many errors + if ( $error_count_this_file > 2 ) { + print STDERR +"**ERROR** Giving up on file $file, error count = $error_count_this_file\n"; + last; + } + } + + # Summary for one file run with all profiles + $rsummary->[$file_count] = { + input_original_name => $ifile_original, + input_size => $ifile_size, + error_count => $error_count, + efile_count => $efile_count, + missing_ofile_count => $missing_ofile_count, + missing_chkfile_count => $missing_chkfile_count, + minimum_output_size => $ofile_size_min, + maximum_output_size => $ofile_size_max, + minimum_output_case => $ofile_case_min, + maximum_output_case => $ofile_case_max, + minimum_rerun_size => $chkfile_size_min, + maximum_rerun_size => $chkfile_size_max, + minimum_rerun_case => $chkfile_case_min, + maximum_rerun_case => $chkfile_case_max, + minimum_error_size => $efile_size_min, + maximum_error_size => $efile_size_max, + minimum_error_case => $efile_case_min, + maximum_error_case => $efile_case_max, + }; + + report_results( $rsummary->[$file_count] ); + + # Note if it looks like results for this file needs attention + if ( + + # check file had an error but not with defaults + $error_count + + # There were missing output files + || $missing_ofile_count + + # There were missing output files when rerun with defaults + || $missing_chkfile_count + + # an output file had zero size + || $ofile_size_min == 0 + + # an output file had zero size when rerun with defaults + || $chkfile_size_min == 0 + ) + { + push @problems, $file_count; + } ## end inner loop over profiles +} ## end outer loop over files + +# Summarize results.. +if (@problems) { + print STDERR <[$nf] ); + } + if (@chkfile_errors) { + local $" = ')('; + my $num = @chkfile_errors; + $num = 20 if ( $num > 20 ); + print STDERR < 20 ); + print STDERR < 20 ); + print STDERR <{input_original_name}; + my $ifile_size = $rh->{input_size}; + my $error_count = $rh->{error_count}; + my $efile_count = $rh->{efile_count}; + my $missing_ofile_count = $rh->{missing_ofile_count}; + my $missing_chkfile_count = $rh->{missing_chkfile_count}; + my $ofile_size_min = $rh->{minimum_rerun_size}; + my $ofile_size_max = $rh->{maximum_rerun_size}; + my $ofile_case_min = $rh->{minimum_rerun_case}; + my $ofile_case_max = $rh->{maximum_rerun_case}; + my $chkfile_size_min = $rh->{minimum_output_size}; + my $chkfile_size_max = $rh->{maximum_output_size}; + my $chkfile_case_min = $rh->{minimum_output_case}; + my $chkfile_case_max = $rh->{maximum_output_case}; + my $efile_size_min = $rh->{minimum_error_size}; + my $efile_size_max = $rh->{maximum_error_size}; + my $efile_case_min = $rh->{minimum_error_case}; + my $efile_case_max = $rh->{maximum_error_case}; + + print STDERR <', $runme ) || die "cannot open $runme: $!\n"; + $fh->print(<>nohup.my 2>>nohup.my +EOM + system("chmod +x $runme"); + print STDOUT "To restart, enter ./$runme\n"; +} + +sub write_runme { + + # Write a script RUNME.pl which can find problems in nohup.my + my $runme = 'RUNME.pl'; + if ( open( RUN, '>', $runme ) ) { + print RUN <<'EOM'; +#!/usr/bin/perl -w +my $nohup = "nohup.my"; +my $ofile = "nohup.my.err"; +open( IN, '<', $nohup ) || die "cannot open $nohup: $!\n"; +open( OUT, '>', $ofile ) || die "cannot open $ofile: $!\n"; +my $lno = 0; +my $count = 0; +my @lines=; +my $nlines=@lines; +foreach my $line (@lines) { + $lno++; + if ( $line =~ /uninitialized/ + || $line =~ /A fault was/ + || length($line) > 80 ) + { + + # ignore last few lines + next if ( $lno > $nlines - 4 ); + $count++; + print OUT "$lno: $line"; + print STDERR "$lno: $line"; + } +} +close IN; +close OUT; +my $gfile="nohup.my.grep"; +my $cmd1 = "grep 'Thank you' ERR.* >>$gfile"; +my $cmd2 = "grep 'Thank you' *.ERR >>$gfile"; +system ($cmd1); +system ($cmd2); +print STDERR "$count problems seen in $nohup\n"; +if ($count) { + print STDERR "please see $ofile\n"; +} +if (-s $gfile) { + print STDERR "please see $gfile\n"; +} +EOM + close RUN; + system("chmod +x $runme"); + print "Wrote '$runme'\n"; + return; + } +} + +sub read_config { + + my ($ifile) = @_; + $rsetup = undef; + + # be sure the file has correct perl syntax + my $syntax_check = qx/perl -cw $ifile 2>&1/; + if ( $syntax_check !~ /syntax OK/ ) { + print STDERR < ) { + $line =~ s/^\s+//; + $line =~ s/\s+$//; + next if $line =~ /^#/; + push @{$rlist}, $line; + } + $fh->close(); + return $rlist; +} diff --git a/t/snippets/perltidy_random_setup.pl b/t/snippets/perltidy_random_setup.pl new file mode 100755 index 00000000..363c4fa2 --- /dev/null +++ b/t/snippets/perltidy_random_setup.pl @@ -0,0 +1,1147 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Data::Dumper; + +# This program sets up a run of perltidy with random parameters and files. +# This is an interactive program which writes a config file and a run script +# for the actual run. + +our $rsetup; # the setup hash +my $config_file = "config.txt"; +my $FILES_file = "FILES.txt"; +my $PROFILES_file = "PROFILES.txt"; +my $rfiles = []; +my $rprofiles = []; + +# Run this in a temporary directory to setup the actual run +query(<. + +EOM + +# Defaults +default_config(); + +if ( -e $config_file ) { + if ( ifyes("Read the existing config.txt file? [Y/N]") ) { + read_config($config_file); + } +} + +if ( -e $FILES_file ) { + if (ifyes("Found $FILES_file, read it ? [Y/N]") ) { + $rfiles = read_list($FILES_file); + my $nfiles=@{$rfiles}; + print STDOUT "found $nfiles files\n"; + } +} + +if ( !@{$rfiles} ) { + define_files(); + $rfiles = filter_files($rfiles); +} + +if ( -e $PROFILES_file ) { + if (ifyes("Found $PROFILES_file, read it ? [Y/N]") ) { + $rprofiles = read_list($PROFILES_file); + my $nfiles=@{$rprofiles}; + print STDOUT "found $nfiles profiles\n"; + } +} + +if ( !@{$rprofiles} ) { + make_profiles(); + $rprofiles = filter_profiles($rprofiles); +} + +$rsetup->{'syntax_check'} = ifyes(<{files}; + my $chain_mode = $rsetup->{chain_mode}; + my $do_syntax_check = $rsetup->{syntax_check}; + my $delete_good_output = $rsetup->{delete_good_output}; + print <{chain_mode} = $chain_mode; + } + elsif ( $ans eq 'D' ) { + $delete_good_output = ifyes("Delete needless good output files? [Y/N]"); + $rsetup->{delete_good_output} = $delete_good_output; + } + elsif ( $ans eq 'S' ) { + $do_syntax_check = ifyes("Do syntax checking? [Y/N]"); + $rsetup->{syntax_check} = $do_syntax_check; + } + elsif ( $ans eq 'Q' ) { + last if ( ifyes("Quit without saving? [Y/N]") ); + } + elsif ( $ans eq 'W' || $ans eq 'X' ) { + write_config($config_file); + $rfiles = filter_files($rfiles); + $rprofiles = filter_profiles($rprofiles); + write_list( $FILES_file, $rfiles ); + write_list( $PROFILES_file, $rprofiles ); + last; + } +} + +write_GO(); + +sub filter_files { + my ($rlist) = @_; + + # keep only a unique set + $rlist = uniq($rlist); + + # only work on regular files with non-zero length + @{$rlist} = grep { -f $_ && !-z $_ } @{$rlist}; + + # Ignore .tdy {$rlist} + @{$rlist} = grep { $_ !~ /\.tdy$/ } @{$rlist}; + + # exclude pro{$rlist} + @{$rlist} = grep { $_ !~ /profile\.[0-9]*/ } @{$rlist}; + + # Sort by size + @{$rlist} = + map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, -e $_ ? -s $_ : 0 ] } @{$rlist}; + + return $rlist; +} + +sub filter_profiles { + my ($rlist) = @_; + + # keep only a unique set + $rlist = uniq($rlist); + + # only work on regular files with non-zero length + @{$rlist} = grep { -f $_ && !-z $_ } @{$rlist}; + + # Sort on numerical extension + @{$rlist} = + map { $_->[0] . "." . $_->[1] } # basename.extension + sort { $a->[1] <=> $b->[1] } # sort on extension + map { [ ( split /\./, $_ ) ] } @{$rlist}; # split into [base,ext] + + return $rlist; +} + +sub uniq { + my ($rlist) = @_; + my %seen = (); + my @uniqu = grep { !$seen{$_}++ } @{$rlist}; + return \@uniqu; +} + +sub define_files { + + $file_info = get_file_info(); + + # TODO: add option to generate random files now + # TODO: add option to shorten a list + print <='$glob'"); + $glob = $ans if ($ans); + return unless ($glob); + my @files = glob($glob); + @files = grep { -f $_ && !-z $_ } @files; + @files = grep { $_ !~ /\.tdy$/ } @files; + @files = grep { $_ !~ /profile\.[0-9]*/ } @files; + my $nfiles_new = @files; + print "Found $nfiles_new files\n"; + return unless @files; + + if ( $nfiles_old > 0 ) { + print "There are already $nfiles_old existing files"; + while (1) { + my $ans = queryu(<[0]; + $profileN = $rprofiles->[-1]; + } + my $profile_info = <[0]; + $fileN = $rfiles->[-1]; + } + my $file_info = < 1, + delete_good_output => 1, + syntax_check => 0, + profiles => $PROFILES_file, + files => $FILES_file, + }; + return; +} + +sub write_GO { + + my $runme = "GO.sh"; + my $fh; + open( $fh, '>', $runme ) || die "cannot open $runme: $!\n"; + $fh->print(<<'EOM'); +#!/bin/sh + +# This script can run perltidy with random parameters +# usage: perltidy_random.sh file1 file2 ... N +# where N is the number of random cases +echo "Perltidy random run ..." +echo "NOTE: Create a file named 'stop.now' to force an early exit" +sleep 2 +rm nohup.my +unlink $0; +nohup nice -n19 perltidy_random_run.pl >>nohup.my 2>>nohup.my +EOM + system("chmod +x $runme"); + print STDOUT "now enter ./$runme\n"; +} + +sub write_config { + my ($ofile) = @_; + my $hash = Data::Dumper->Dump( [$rsetup], ["rsetup"] ); + my $fh; + if ( !open( $fh, '>', $ofile, ) ) { + print "cannot open $ofile :$!\n"; + return; + } + $fh->print("$hash\n"); + $fh->close(); + return; +} + +sub read_config { + + my ($ifile) = @_; + $rsetup = undef; + do $ifile; + + # be sure the file has correct perl syntax + my $syntax_check = qx/perl -cw $ifile 2>&1/; + if ( $syntax_check !~ /syntax OK/ ) { + print STDERR < ) { + $line =~ s/^\s+//; + $line =~ s/\s+$//; + next if $line =~ /^#/; + push @{$rlist}, $line; + } + $fh->close(); + return $rlist; +} + +sub write_list { + my ( $fname, $rlist ) = @_; + + my $fh; + if ( !open( $fh, ">", $fname ) ) { + query("Cannot open $fname: $!\n"); + return; + } + foreach my $line ( @{$rlist} ) { + chomp $line; + $line .= "\n"; + $fh->print($line); + } + $fh->close(); + return; +} + +sub query { + my ($msg) = @_; + print $msg; + my $ans = ; + chomp $ans; + return $ans; +} + +sub queryu { + return uc query(@_); +} + +sub ifyes { + + # Updated to have default, which should be "Y" or "N" + my ( $msg, $default ) = @_; + my $count = 0; + ASK: + my $ans = query($msg); + if ( defined($default) ) { + $ans = $default unless ($ans); + } + if ( $ans =~ /^Y/i ) { return 1 } + elsif ( $ans =~ /^N/i ) { return 0 } + else { + $count++; + if ( $count > 6 ) { die "error count exceeded in ifyes\n" } + print STDERR "Please answer 'Y' or 'N'\n"; + goto ASK; + } +} + +sub get_output_filename { + my ( $msg, $default ) = @_; + $msg = "Enter filename to write" unless $msg; + RETRY: + my $filename; + if ($default) { + $filename = query("$msg, ='$default': "); + $filename = $default if ( !$filename || $filename =~ /^\s*$/ ); + } + else { + $filename = query("$msg:"); + } + if ( -e $filename ) { + goto RETRY + unless ( ifyes("file '$filename' exists; Overwrite? [Y/N]") ); + } + return $filename; +} + +sub get_input_filename { + my ( $msg, $ext, $default ) = @_; + $msg = "Enter filename to read" unless $msg; + RETRY: + my $filename; + if ($default) { + $filename = query("$msg, ='$default': "); + $filename = $default if ( !$filename || $filename =~ /^\s*$/ ); + } + else { + $filename = query("$msg:"); + } + unless ( -e $filename ) { + return undef if ( $filename eq '.' || $filename eq "" ); + if ( $filename !~ /\..*/ ) { $filename .= "$ext"; } + unless ( -e $filename ) { + print STDERR "$filename does not exist\n"; + goto RETRY if ( ifyes("Try again? [Y/N]") ); + return undef; + } + } + return $filename; +} + +sub get_num { + my ( $msg, $default ) = @_; + if ( defined($default) ) { + $msg =~ s/:$//; + $msg .= " (=$default):"; + } + my $ans = query($msg); + $ans = $default if ( defined($default) && $ans eq "" ); + my $val = eval($ans); + if ($@) { warn $@; $val = $ans; } + return $val; +} + +{ # make_profiles + + # This will generate N random profiles for perltidy + + # usage: + # make_profiles(20) + # - to make 20 random profiles + + my @parameters; + + sub get_parameters { + + # get latest parameters from perltidy + use File::Temp qw(tempfile); + my ( $fout, $tmpnam ) = File::Temp::tempfile(); + if ( !$fout ) { die "cannot get tempfile\n" } + my @parameters; + system "perltidy --dump-long-names >$tmpnam"; + open( IN, "<", $tmpnam ) || die "cannot open $tmpnam: $!\n"; + while ( my $line = ) { + next if $line =~ /#/; + chomp $line, push @parameters, $line; + } + close IN; + unlink $tmpnam if ( -e $tmpnam ); + return \@parameters; + } + + BEGIN { + + # Here is a static list of all parameters current as of v.20200907 + # Created with perltidy --dump-long-names + # Command line long names (passed to GetOptions) + #--------------------------------------------------------------- + # here is a summary of the Getopt codes: + # does not take an argument + # =s takes a mandatory string + # :s takes an optional string + # =i takes a mandatory integer + # :i takes an optional integer + # ! does not take an argument and may be negated + # i.e., -foo and -nofoo are allowed + # a double dash signals the end of the options list + # + #--------------------------------------------------------------- + @parameters = qw( + DEBUG! + add-newlines! + add-semicolons! + add-whitespace! + assert-tidy! + assert-untidy! + backlink=s + backup-and-modify-in-place! + backup-file-extension=s + blank-lines-after-opening-block-list=s + blank-lines-after-opening-block=i + blank-lines-before-closing-block-list=s + blank-lines-before-closing-block=i + blank-lines-before-packages=i + blank-lines-before-subs=i + blanks-before-blocks! + blanks-before-comments! + block-brace-tightness=i + block-brace-vertical-tightness-list=s + block-brace-vertical-tightness=i + brace-left-and-indent! + brace-left-and-indent-list=s + brace-tightness=i + brace-vertical-tightness-closing=i + brace-vertical-tightness=i + break-after-all-operators! + break-at-old-attribute-breakpoints! + break-at-old-comma-breakpoints! + break-at-old-keyword-breakpoints! + break-at-old-logical-breakpoints! + break-at-old-method-breakpoints! + break-at-old-semicolon-breakpoints! + break-at-old-ternary-breakpoints! + break-before-all-operators! + cachedir=s + character-encoding=s + check-syntax! + closing-brace-indentation=i + closing-paren-indentation=i + closing-side-comment-else-flag=i + closing-side-comment-interval=i + closing-side-comment-list=s + closing-side-comment-maximum-text=i + closing-side-comment-prefix=s + closing-side-comment-warnings! + closing-side-comments! + closing-side-comments-balanced! + closing-square-bracket-indentation=i + closing-token-indentation=i + comma-arrow-breakpoints=i + continuation-indentation=i + cuddled-block-list-exclusive! + cuddled-block-list=s + cuddled-break-option=i + cuddled-else! + default-tabsize=i + delete-block-comments! + delete-closing-side-comments! + delete-old-newlines! + delete-old-whitespace! + delete-pod! + delete-semicolons! + delete-side-comments! + dump-cuddled-block-list! + dump-defaults! + dump-long-names! + dump-options! + dump-profile! + dump-short-names! + dump-token-types! + dump-want-left-space! + dump-want-right-space! + entab-leading-whitespace=i + extended-syntax! + file-size-order! + fixed-position-side-comment=i + force-read-binary! + format-skipping! + format-skipping-begin=s + format-skipping-end=s + format=s + frames! + fuzzy-line-length! + hanging-side-comments! + help + html! + html-bold-bareword! + html-bold-colon! + html-bold-comma! + html-bold-comment! + html-bold-here-doc-target! + html-bold-here-doc-text! + html-bold-identifier! + html-bold-keyword! + html-bold-label! + html-bold-numeric! + html-bold-paren! + html-bold-pod-text! + html-bold-punctuation! + html-bold-quote! + html-bold-semicolon! + html-bold-structure! + html-bold-subroutine! + html-bold-v-string! + html-color-background=s + html-color-bareword=s + html-color-colon=s + html-color-comma=s + html-color-comment=s + html-color-here-doc-target=s + html-color-here-doc-text=s + html-color-identifier=s + html-color-keyword=s + html-color-label=s + html-color-numeric=s + html-color-paren=s + html-color-pod-text=s + html-color-punctuation=s + html-color-quote=s + html-color-semicolon=s + html-color-structure=s + html-color-subroutine=s + html-color-v-string=s + html-entities! + html-italic-bareword! + html-italic-colon! + html-italic-comma! + html-italic-comment! + html-italic-here-doc-target! + html-italic-here-doc-text! + html-italic-identifier! + html-italic-keyword! + html-italic-label! + html-italic-numeric! + html-italic-paren! + html-italic-pod-text! + html-italic-punctuation! + html-italic-quote! + html-italic-semicolon! + html-italic-structure! + html-italic-subroutine! + html-italic-v-string! + html-line-numbers + html-linked-style-sheet=s + html-pre-only + html-src-extension=s + html-table-of-contents! + html-toc-extension=s + htmlroot=s + ignore-old-breakpoints! + ignore-side-comment-lengths! + indent-block-comments! + indent-closing-brace! + indent-columns=i + indent-spaced-block-comments! + iterations=i + keep-interior-semicolons! + keep-old-blank-lines=i + keyword-group-blanks-after=i + keyword-group-blanks-before=i + keyword-group-blanks-delete! + keyword-group-blanks-inside! + keyword-group-blanks-list=s + keyword-group-blanks-repeat-count=i + keyword-group-blanks-size=s + keyword-paren-inner-tightness-list=s + keyword-paren-inner-tightness=i + libpods=s + line-up-parentheses! + logfile! + logfile-gap:i + logical-padding! + long-block-line-count=i + look-for-autoloader! + look-for-hash-bang! + look-for-selfloader! + maximum-consecutive-blank-lines=i + maximum-fields-per-table=i + maximum-line-length=i + memoize! + minimum-space-to-comment=i + no-profile + nohtml-style-sheets + non-indenting-brace-prefix=s + non-indenting-braces! + noprofile + nospace-after-keyword=s + notidy + nowant-left-space=s + nowant-right-space=s + npro + one-line-block-nesting=i + one-line-block-semicolons=i + opening-anonymous-sub-brace-on-new-line! + opening-brace-always-on-right! + opening-brace-on-new-line! + opening-hash-brace-right! + opening-paren-right! + opening-square-bracket-right! + opening-sub-brace-on-new-line! + outdent-keyword-list=s + outdent-keywords! + outdent-labels! + outdent-long-comments! + outdent-long-quotes! + outdent-static-block-comments! + outfile=s + output-file-extension=s + output-line-ending=s + output-path=s + paren-tightness=i + paren-vertical-tightness-closing=i + paren-vertical-tightness=i + pass-version-line! + perl-syntax-check-flags=s + pod2html! + podflush + podheader! + podindex! + podpath=s + podquiet! + podrecurse! + podroot=s + podverbose! + preserve-line-endings! + profile=s + quiet! + recombine! + short-concatenation-item-length=i + show-options! + space-after-keyword=s + space-backslash-quote=i + space-for-semicolon! + space-function-paren! + space-keyword-paren! + space-prototype-paren=i + space-terminal-semicolon! + square-bracket-tightness=i + square-bracket-vertical-tightness-closing=i + square-bracket-vertical-tightness=i + stack-closing-block-brace! + stack-closing-hash-brace! + stack-closing-paren! + stack-closing-square-bracket! + stack-opening-block-brace! + stack-opening-hash-brace! + stack-opening-paren! + stack-opening-square-bracket! + standard-error-output! + standard-output! + starting-indentation-level=i + static-block-comment-prefix=s + static-block-comments! + static-side-comment-prefix=s + static-side-comments! + stylesheet + sub-alias-list=s + tabs! + tee-block-comments! + tee-pod! + tee-side-comments! + tight-secret-operators! + timestamp! + title=s + trim-pod! + trim-qw! + use-unicode-gcstring! + valign! + variable-maximum-line-length! + version + vertical-tightness-closing=i + vertical-tightness=i + want-break-after=s + want-break-before=s + want-left-space=s + want-right-space=s + warning-output! + weld-nested-containers! + whitespace-cycle=i + ); + + # We can use the above list, but + # normally we want to update to the latest parameters + my $UPDATE_PARAMETERS = 1; + + if ($UPDATE_PARAMETERS) { + my $rparameters_current = get_parameters(); + @parameters = @{$rparameters_current}; + print STDERR "Updating perltidy parameters....\n"; + } + + } + + sub make_profiles { + my $nfiles_old = @{$rprofiles}; + my $case = 0; + if ( $nfiles_old > 0 ) { + my $profile_info = get_profile_info(); + print $profile_info; + print "There are already $nfiles_old existing files"; + while (1) { + my $ans = queryu(< $case) { $case= $1 } + } + } + last; + } + elsif ( $ans eq 'D' ) { + my $num=get_num("Number to keep:",$nfiles_old); + if ($num > $nfiles_old || $num <=0 ) { + query("Sorry, must keep 0 to $nfiles_old, hit "); + } + else { + @{$rprofiles} = @{$rprofiles}[ 0 .. $num - 1 ]; + return; + } + } + elsif ( $ans eq 'R' ) { @{$rprofiles} = []; last } + } + } + my $max_cases = + get_num( "Number of new random profiles to generate", 50); + for ( 1 .. $max_cases ) { + $case += 1; + my $profile = "profile.$case"; + + # Make the profile + + # use default parameters on first case. That way we can check + # if a file produces an error output + my $rrandom_parameters; + if ( $case == 1 ) { + $rrandom_parameters = [""]; + } + + # Case 2 creates the smallest possible output file size + if ( $case == 2 ) { + $rrandom_parameters = ["--mangle -dsc -dac -i=0 -ci=0 -it=2"]; + } + + # Case 3 checks extrude from mangle (case 2) + if ( $case == 3 ) { + $rrandom_parameters = ["--extrude"]; + } + + # Case 4 checks mangle again from extrude ( + if ( $case == 4 ) { + $rrandom_parameters = ["--mangle"]; + } + + # From then on random parameters are generated + if ( $case > 5 ) { + $rrandom_parameters = get_random_parameters(); + } + my $fh; + open( $fh, ">", $profile ) || die "cannot open $profile: $!\n"; + foreach ( @{$rrandom_parameters} ) { + $fh->print("$_\n"); + } + $fh->close(); + push @{$rprofiles}, $profile; + } + } + + sub get_random_parameters { + + # return a set of random parameters for perltidy + my @random_parameters; + + my %flag_types = ( + '!' => 'BINARY FLAG', + '=s' => 'STRING', + '=i' => 'INTEGER', + ':i' => 'OPTIONAL INTEGER', + ':s' => 'OPTIONAL STRING', + ); + + my @random_words = qw(bannanas sub subaru train 1x =+ !); + + my @operators = + qw(% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=); + my @keywords = qw(my our local do while if garbage1 34 ); + my @colors = qw( + ForestGreen + SaddleBrown + magenta4 + IndianRed3 + DeepSkyBlue4 + MediumOrchid3 + black + white + red + + bubba + ); + + my %option_range = ( + 'format' => [ 'tidy', 'html' ], #, 'user' ], + 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], + + 'space-backslash-quote' => [ 0, 2 ], + 'block-brace-tightness' => [ 0, 2 ], + 'keyword-paren-inner-tightness' => [ 0, 2 ], + 'brace-tightness' => [ 0, 2 ], + 'paren-tightness' => [ 0, 2 ], + 'square-bracket-tightness' => [ 0, 2 ], + + 'block-brace-vertical-tightness' => [ 0, 2 ], + 'brace-vertical-tightness' => [ 0, 2 ], + 'brace-vertical-tightness-closing' => [ 0, 2 ], + 'paren-vertical-tightness' => [ 0, 2 ], + 'paren-vertical-tightness-closing' => [ 0, 2 ], + 'square-bracket-vertical-tightness' => [ 0, 2 ], + 'square-bracket-vertical-tightness-closing' => [ 0, 2 ], + 'vertical-tightness' => [ 0, 2 ], + 'vertical-tightness-closing' => [ 0, 2 ], + + 'break-before-hash-brace' => [ 0, 3 ], + 'break-before-square-bracket' => [ 0, 3 ], + 'break-before-paren' => [ 0, 3 ], + 'break-before-hash-brace-and-indent' => [ 0, 2 ], + 'break-before-square-bracket-and-indent' => [ 0, 2 ], + 'break-before-paren-and-indent' => [ 0, 2 ], + + 'closing-brace-indentation' => [ 0, 3 ], + 'closing-paren-indentation' => [ 0, 3 ], + 'closing-square-bracket-indentation' => [ 0, 3 ], + 'closing-token-indentation' => [ 0, 3 ], + + 'closing-side-comment-else-flag' => [ 0, 2 ], + 'comma-arrow-breakpoints' => [ 0, 5 ], + + 'keyword-group-blanks-before' => [ 0, 2 ], + 'keyword-group-blanks-after' => [ 0, 2 ], + + 'space-prototype-paren' => [ 0, 2 ], + + # Arbitrary limits to keep things readable + 'blank-lines-after-opening-block' => [ 0, 4 ], + 'blank-lines-before-closing-block' => [ 0, 3 ], + 'blank-lines-before-packages' => [ 0, 3 ], + 'blank-lines-before-subs' => [ 0, 3 ], + + 'maximum-consecutive-blank-lines' => [ 0, 4 ], + 'minimum-space-to-comment' => [ 0, 10 ], + + 'indent-columns' => [ 0, 10 ], + 'continuation-indentation' => [ 0, 10 ], + 'default-tabsize' => [ 0, 8 ], + 'entab-leading-whitespace' => [ 0, 8 ], + + 'want-break-after' => \@operators, + 'want-break-before' => \@operators, + 'want-left-space' => \@operators, + 'want-right-space' => \@operators, + 'nowant-left-space' => \@operators, + 'nowant-right-space' => \@operators, + + #'keyword-group-blanks-list=s + 'keyword-group-blanks-size' => [ 0, 2, 4, 7, 10, 2.8, 1.8 ], + + # TODO: FILL thESE with multiple random keywords + 'space-after-keyword' => \@keywords, + 'nospace-after-keyword' => \@keywords, + + 'html-color-background' => \@colors, + 'html-color-bareword' => \@colors, + 'html-color-colon' => \@colors, + 'html-color-comma' => \@colors, + 'html-color-comment' => \@colors, + 'html-color-here-doc-target' => \@colors, + 'html-color-here-doc-text' => \@colors, + 'html-color-identifier' => \@colors, + 'html-color-keyword' => \@colors, + 'html-color-label' => \@colors, + 'html-color-numeric' => \@colors, + 'html-color-paren' => \@colors, + 'html-color-pod-text' => \@colors, + 'html-color-punctuation' => \@colors, + 'html-color-quote' => \@colors, + 'html-color-semicolon' => \@colors, + 'html-color-structure' => \@colors, + 'html-color-subroutine' => \@colors, + 'html-color-v-string' => \@colors, + ); + + my %is_multiword_list = ( + 'want-break-after' => 1, + 'want-break-before' => 1, + 'want-left-space' => 1, + 'want-right-space' => 1, + 'nowant-left-space' => 1, + 'nowant-right-space' => 1, + 'space-after-keyword' => 1, + 'nospace-after-keyword' => 1, + ); + + ################################################################### + # Most of these have been tested and are best skipped because + # they produce unwanted output or perhaps cause the program to + # just quit early. Parameters can be added and removed from the + # list to customize testing. 'format' was added because html is + # not so interesting, but can be removed for html testing. + ################################################################### + my @q = qw( + DEBUG + assert-tidy + assert-untidy + backup-and-modify-in-place + backup-file-extension + character-encoding + dump-cuddled-block-list + dump-defaults + dump-long-names + dump-options + dump-profile + dump-short-names + dump-token-types + dump-want-left-space + dump-want-right-space + format + format-skipping-begin + format-skipping-end + help + html + logfile + logfile-gap + look-for-hash-bang + notidy + outfile + output-file-extension + output-file-extension + output-line-ending + output-path + quiet + standard-error-output + standard-output + starting-indentation-level + tee-block-comments + tee-pod + tee-side-comments + version + ); + + my %skip; + @skip{@q} = (1) x scalar(@q); + + foreach my $parameter (@parameters) { + my ( $name, $flag, $type ) = ( "", "", "" ); + $parameter =~ s/\s+$//; + if ( $parameter =~ /^([\w\-]+)([^\s]*)/ ) { + $name = $1; + $flag = $2; + $flag = "" unless $flag; + $type = $flag_types{$flag} if ($flag); + + next if $skip{$name}; + + # Skip all pattern lists + if ( $flag =~ /s$/ ) { + if ( $name =~ /-(list|prefix)/ + || $name =~ /character-encoding/ ) + { + next; + } + } + + my $rrange = $option_range{$name}; + ##print "$parameter => $name $flag $type\n"; + my $line = ""; + if ( $flag eq '!' ) { + my $xx = int( rand(1) + 0.5 ); + my $prefix = $xx == 0 ? 'no' : ""; + $line = "--$prefix$name"; + } + elsif ( $flag eq '=s' ) { + my $string; + if ( !$rrange ) { $rrange = \@random_words } + my $imax = @{$rrange} - 1; + my $count = 1; + if ( $is_multiword_list{$name} ) { + $count = $imax / 2 + 1; + } + foreach my $i ( 1 .. $count ) { + my $index = int( rand($imax) + 0.5 ); + if ( $i > 1 ) { $string .= ' ' } + $string .= $rrange->[$index]; + } + $string = "'$string'"; + $line = "--$name=$string"; + } + elsif ( $flag eq '=i' ) { + my $int; + if ( !$rrange ) { + $rrange = [ 0, 100 ]; + } + + # Two items are assumed to be a range + if ( @{$rrange} == 2 ) { + my ( $imin, $imax ) = @{$rrange}; + my $frac = rand(1); + $int = $imin + $frac * ( $imax - $imin ); + $int = int( $int + 0.5 ); + } + + # Otherwise, assume a list + else { + my $ix = @{$rrange} - 1; + my $index = int( rand($ix) + 0.5 ); + $int = $rrange->[$index]; + } + $line = "--$name=$int"; + } + else { + my $xx = int( rand(1) + 0.5 ); + next unless $xx; + $line = "--$name"; + } + + # Now randomly pick and omit flags + push @random_parameters, $line; + } + } + return \@random_parameters; + } +} -- 2.39.5