--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+
+# This is one of a set of programs for doing random testing of perltidy. The
+# goal is to try to crash perltidy. The programs are:
+
+# random_file_generator.pl [optional initial step]
+# perltidy_random_setup.pl [setup step]
+# perltidy_random_run.pl [this program]
+
+# This program does the actual run based on the setup info made in the
+# previous step.
+
+my $usage = <<EOM;
+
+Use 'perltidy_random_setup.pl' to setup a run in an empty temporary direct
+(lots of temporary files may be created).
+
+Follow the directions it gives.
+
+Output is accumulated in file 'nohup.my'
+
+You can stop the run any time by creating a file "stop.now"
+
+You can restart by running './GO.sh' which is written
+when this run stops.
+
+A RUNME.sh file will be generated to help find problems in nohup.my
+
+EOM
+
+# NOTE: A restart is controlled by a single arg to this routine.
+# The restart format is
+#
+# $0 [m.n]
+#
+# where m.n is an optional restart point:
+#
+# m = integer file number to begin (start counting with 1)
+# n = integer first parameter case (start counting with 1)
+#
+# A restart from '1.1' is the same as a start.
+
+use Getopt::Std;
+our %opts;
+getopts( 'h', \%opts ) or die "$usage";
+if ( $opts{h} ) { die "$usage" }
+
+our $rsetup; # the config info
+my $hash='#';
+
+my $config_file = "config.txt";
+if ( !-e $config_file ) {
+ die <<EOM;
+Did not see '$config_file'
+Please run 'perltidy_random_setup.pl' first
+EOM
+}
+
+my $nf_beg = 1;
+my $np_beg = 1;
+if ( @ARGV > 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};
+my $perltidy = $rsetup->{perltidy};
+
+my $binfile = "perltidy";
+if ($perltidy) {
+ $binfile = "perl $perltidy";
+}
+
+$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 <<EOM;
+Exiting, nothing to do:
+Requested range of files is $nf_beg to $nf_end
+Requested range of profiles is $np_beg to $np_end
+EOM
+}
+
+# Outer loop over files
+my $file_count = 0;
+my $case = 0;
+MAIN_LOOP:
+for ( my $nf = $nf_beg ; $nf <= $nf_end ; $nf++ ) {
+ my $file = $files[ $nf - 1 ];
+
+ # remove any previously saved files
+ if (@saved_for_deletion) {
+ foreach (@saved_for_deletion) {
+ unlink $_ if ( -e $_ );
+ }
+ @saved_for_deletion = ();
+ }
+
+ next unless -e $file;
+ $file_count = $nf;
+ my $ifile = $file;
+ my $ifile_original = $ifile;
+ my $ifile_size = -s $ifile;
+ my $error_count_this_file = 0;
+
+ my $error_count = 0;
+ my $missing_ofile_count = 0;
+ my $missing_chkfile_count = 0;
+ my ( $ofile_size_min, $ofile_size_max );
+ my ( $ofile_case_min, $ofile_case_max );
+ my ( $efile_size_min, $efile_size_max ) = ( 0, 0 );
+ my ( $efile_case_min, $efile_case_max ) = ( "", "" );
+ my ( $chkfile_size_min, $chkfile_size_max );
+ my ( $chkfile_case_min, $chkfile_case_max );
+ my $ofile_size_min_expected = 0;
+
+ my $error_flag = 0;
+ my $restart_count = 0;
+ my $efile_count = 0;
+ my $has_starting_error;
+ my $starting_syntax_ok = 1;
+
+ # Inner loop over profiles for a given file
+ for ( my $np = $np_beg ; $np <= $np_end ; $np++ ) {
+ my $profile = $profiles[ $np - 1 ];
+
+ $case = $np;
+ my $error_count_this_case = 0;
+
+ my $ext = $case;
+ if ( @files > 1 ) { $ext = "$file_count.$case" }
+
+ my $ofile = "ofile.$ext";
+ my $chkfile = "chkfile.$ext";
+
+ print STDERR "\n" . $hash . '>' x 60 . "\n";
+ print STDERR
+ "$hash>Run '$nf.$np' : profile='$profile', ifile='$ifile'\n";
+
+ my $cmd = "$binfile <$ifile >$ofile -pro=$profile";
+ system_echo($cmd,$hash);
+ 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 an unexpectedly very small file size...
+ # NOTE: file sizes can often be unexpectly small when operating on
+ # random text. For example, if a random line begins with an '='
+ # then when a --delete-pod parameter is set, everything from there
+ # on gets deleted.
+ # But we still want to catch zero size files, since they might
+ # indicate a code crash. So I have lowered the fraction in this
+ # test to a small value.
+ elsif ( $case > 3 && $ofile_size < 0.1 * $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_echo($cmd,$hash);
+ 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 "$hash 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_echo($cmd2,$hash);
+ #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 && $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 $_ );
+ }
+ foreach (@saved_for_deletion) {
+ unlink $_ if ( -e $_ );
+ }
+ @saved_for_deletion = ();
+ print STDERR "$hash 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
+
+if (@saved_for_deletion) {
+ foreach (@saved_for_deletion) {
+ unlink $_ if ( -e $_ );
+ }
+ @saved_for_deletion = ();
+}
+
+# Summarize results..
+if (@problems) {
+ print STDERR <<EOM;
+
+=============================
+SUMMARY OF POSSIBLE PROBLEMS:
+=============================
+EOM
+
+ foreach my $nf (@problems) {
+ report_results( $rsummary->[$nf] );
+ }
+ if (@chkfile_errors) {
+ local $" = ')(';
+ my $num = @chkfile_errors;
+ $num = 20 if ( $num > 20 );
+ print STDERR <<EOM;
+Some check files with errors (search above for '**ERROR'):
+(@chkfile_errors[1..$num-1])
+EOM
+ }
+ if (@size_errors) {
+ local $" = ')(';
+ my $num = @size_errors;
+ $num = 20 if ( $num > 20 );
+ print STDERR <<EOM;
+Some files with definite size errors (search above for '**ERROR'):
+(@size_errors[1..$num-1])
+EOM
+ }
+ if (@syntax_errors) {
+ local $" = ')(';
+ my $num = @syntax_errors;
+ $num = 20 if ( $num > 20 );
+ print STDERR <<EOM;
+Some files with definite size errors (search above for '**ERROR'):
+(@syntax_errors[1..$num-1])
+EOM
+ }
+}
+else {
+ print STDERR <<EOM;
+
+========================
+No obvious problems seen
+========================
+EOM
+
+}
+
+# Write a script to automate search for errors
+write_runme();
+
+# Write a restart file
+my ( $nf, $np );
+if ( $case < $np_end ) {
+ $nf = $file_count;
+ $np = $case + 1;
+ write_GO( $nf, $np );
+}
+elsif ( $file_count < $nf_end ) {
+ $nf = $file_count + 1;
+ $np = 1;
+ write_GO( $nf, $np );
+}
+
+print STDERR <<EOM;
+Next: run 'RUNME.pl' or do this by hand:
+Look for lines longer than 80 characters
+grep 'Thank you' and 'bug in perltidy' in all .ERR files
+Search STDERR for 'uninitialized' and other warnings
+EOM
+
+sub report_results {
+
+ my ($rh) = @_;
+
+ my $ifile_original = $rh->{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 <<EOM;
+$hash ------------------------------------------------
+$hash Original input file: $ifile_original
+$hash ifile size : $ifile_size
+$hash $error_count files had errors when reformatted
+$hash $missing_ofile_count output files were missing
+$hash $missing_chkfile_count check output files were missing
+EOM
+
+ print STDERR <<EOM if ( defined($ofile_size_min) );
+
+$hash Minimum output size: $ofile_size_min for case $ofile_case_min
+$hash Maximum output size: $ofile_size_max for case $ofile_case_max
+EOM
+
+ print STDERR <<EOM if ( defined($chkfile_size_min) );
+
+$hash Minimum rerun size: $chkfile_size_min for case $chkfile_case_min
+$hash Maximum rerun size: $chkfile_size_max for case $chkfile_case_max
+EOM
+
+ print STDERR <<EOM if ( defined($efile_size_min) );
+
+$hash Number of error files: $efile_count
+$hash Minimum error file size: $efile_size_min for case $efile_case_min
+$hash Maximum error file size: $efile_size_max for case $efile_case_max
+EOM
+ return;
+}
+
+sub write_GO {
+
+ my ( $nf, $np ) = @_;
+ my $runme = "GO.sh";
+ unlink $runme if ( -e $runme );
+ 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
+nohup nice -n19 perltidy_random_run.pl $nf.$np >>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=<IN>;
+my $nlines=@lines;
+foreach my $line (@lines) {
+ $lno++;
+ next if ($line =~ /^#/);
+ 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 <<EOM;
+-----------------------------------
+$syntax_check
+-----------------------------------
+The above syntax errors are in File '$ifile'
+EOM
+ die;
+ }
+
+ print STDOUT "$ifile:\n";
+
+ # read the config file
+ do $ifile;
+
+ return;
+}
+
+sub read_list {
+ my ($fname) = @_;
+ my $rlist;
+
+ # read a single column list of files
+ # remove blank lines and comments
+ my $fh;
+ if ( !open( $fh, "<", $fname ) ) {
+ query("Cannot open $fname: $!\n");
+ return $rlist;
+ }
+ while ( my $line = <$fh> ) {
+ $line =~ s/^\s+//;
+ $line =~ s/\s+$//;
+ next if $line =~ /^#/;
+ push @{$rlist}, $line;
+ }
+ $fh->close();
+ return $rlist;
+}
+
+sub system_echo {
+ my ( $cmd, $prefix ) = @_;
+ my $str = $prefix ? $prefix . " " . $cmd : $cmd;
+ print STDERR "$str\n";
+ system($cmd);
+}
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use Data::Dumper;
+
+# This is one of a set of programs for doing random testing of perltidy. The
+# goal is to try to crash perltidy. These programs have been very helpful in
+# finding subtle bugs but they are a work in progress and continually evolving.
+# The programs are:
+
+# random_file_generator.pl [optional first step]
+# perltidy_random_setup.pl [this file]
+# perltidy_random_run.pl [next step]
+
+# This program is interactive and helps setup the files. It writes a config
+# file and a run script for the next program which actually does the runs.
+
+# You should create a temporary directory for this work.
+
+our $rsetup; # the setup hash
+my $config_file = "config.txt";
+my $FILES_file = "FILES.txt";
+my $PROFILES_file = "PROFILES.txt";
+my $perltidy = "";
+my $rfiles = [];
+my $rprofiles = [];
+
+query(<<EOM);
+
+IMPORTANT: You should start this program in an empty directory that you create
+specifically for this test. After testing you will probably want to delete the
+entire directory. It is useful to create this empty directory just below a
+directory full of actual perl scripts which can be read as test input.
+
+You may want to put a special copy of perltidy in this directory for testing,
+probably setting all constants DEVEL_MODE => 1. (You can make this with
+the pm2pl script).
+
+If you want to test on random files, you should generate them first in this
+directory with 'random_file_generator.pl'. That is currently a separate
+program but will eventually be incorporated into this program.
+
+Hit <cr> to continue, or hit control-C to quit.
+
+EOM
+
+# Defaults
+default_config();
+
+if ( -e $config_file ) {
+ if ( ifyes( "Read the existing config.txt file? [Y/N]", "Y" ) ) {
+ read_config($config_file);
+ }
+}
+
+if ( -e $FILES_file ) {
+ if ( ifyes( "Found $FILES_file, read it ? [Y/N]", "Y" ) ) {
+ $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]", "Y" ) ) {
+ $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( <<EOM, "N" );
+Do you want to check syntax with perl -c ?
+This will cause any BEGIN blocks in them to execute, which
+can introduce a security concern.
+Enter 'N' unless you very familiar with the test scripts.
+Y/N:
+EOM
+
+my $file_info = get_file_info();
+my $profile_info = get_profile_info();
+my $nprofiles = @{$rprofiles};
+while (1) {
+ my $files = $rsetup->{files};
+ my $chain_mode = $rsetup->{chain_mode};
+ my $do_syntax_check = $rsetup->{syntax_check};
+ my $delete_good_output = $rsetup->{delete_good_output};
+ my $perltidy_version = $rsetup->{perltidy};
+ $perltidy_version = "[default]" unless ($perltidy_version);
+ print <<EOM;
+===Main Menu===
+R - Read a config file
+F - Files: $files
+$file_info
+P - Profiles:
+$profile_info
+C - Chain mode : $chain_mode
+D - Delete good output? : $delete_good_output
+S - Syntax check? : $do_syntax_check
+V - perltidy Version : $perltidy_version
+Q - Quit without saving config file
+W - Write config, FILES.txt, PROFILES.txt, GO.sh and eXit
+EOM
+
+ my ($ans) = queryu(':');
+ if ( $ans eq 'R' ) {
+ my $infile = get_input_filename( '', '.txt', $config_file );
+ read_config($infile);
+ }
+ elsif ( $ans eq 'E' ) {
+ edit_config();
+ }
+ elsif ( $ans eq 'F' ) {
+ define_files();
+ $rfiles = filter_files($rfiles);
+ $file_info = get_file_info();
+ }
+ elsif ( $ans eq 'P' ) {
+ make_profiles();
+ $rprofiles = filter_profiles($rprofiles);
+ $profile_info = get_profile_info();
+ }
+ elsif ( $ans eq 'C' ) {
+ $chain_mode = get_num("Chaining: 0=no, 1=always,2=random");
+ $rsetup->{chain_mode} = $chain_mode;
+ }
+ elsif ( $ans eq 'D' ) {
+ $delete_good_output =
+ ifyes( "Delete needless good output files? [Y/N]", "Y" );
+ $rsetup->{delete_good_output} = $delete_good_output;
+ }
+ elsif ( $ans eq 'S' ) {
+ $do_syntax_check = ifyes( "Do syntax checking? [Y/N]", "N" );
+ $rsetup->{syntax_check} = $do_syntax_check;
+ }
+ elsif ( $ans eq 'V' ) {
+ my $test =
+ query(
+ "Enter the full path to the perltidy binary, or <cr> for default");
+ if ( $test && !-e $test ) {
+ next
+ unless (
+ ifyes("I cannot find that, do you want to use it anyway?") );
+ }
+ $rsetup->{perltidy} = $test;
+ }
+ 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 <<EOM;
+====== Define some files to process =================================
+$file_info
+
+Note that you can generate random files with 'random_file_generator.pl'
+If you want to do that, you should exit now, generate them, then come
+back.
+EOM
+ my $nfiles_old = @{$rfiles};
+ if ($nfiles_old) {
+ if ( ifyes("Use these files as is? [Y/N]") ) {
+ return;
+ }
+ }
+
+ my $glob = '../*';
+ my $ans = query("File glob of files to process, <cr>='$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(<<EOM);
+A Add new files to existing files
+R Replace existing files with new files
+X eXit, keeping existing files as is
+EOM
+ if ( $ans eq 'X' ) { return }
+ elsif ( $ans eq 'A' ) { last }
+ elsif ( $ans eq 'R' ) { @{$rfiles} = []; last }
+
+ }
+ }
+ push @{$rfiles}, @files;
+ $rfiles = uniq($rfiles);
+ $rfiles = [ sort @{$rfiles} ];
+ return;
+}
+
+sub get_profile_info {
+
+ my $nprofiles = @{$rprofiles};
+ my $profile0 = "(none)";
+ my $profileN = "(none)";
+ if ($nprofiles) {
+ $profile0 = $rprofiles->[0];
+ $profileN = $rprofiles->[-1];
+ }
+ my $profile_info = <<EOM;
+ Number of Files: $nprofiles
+ First profile : $profile0
+ Last profile : $profileN
+EOM
+ return $profile_info;
+}
+
+sub get_file_info {
+
+ my $nfiles = @{$rfiles};
+ my $file0 = "(none)";
+ my $fileN = "(none)";
+ if ($nfiles) {
+ $file0 = $rfiles->[0];
+ $fileN = $rfiles->[-1];
+ }
+ my $file_info = <<EOM;
+ Number of Files: $nfiles
+ First file : $file0
+ Last file : $fileN
+EOM
+ return $file_info;
+}
+
+sub default_config {
+ $rsetup = {
+ chain_mode => 2,
+ delete_good_output => 1,
+ syntax_check => 0,
+ profiles => $PROFILES_file,
+ files => $FILES_file,
+ perltidy => $perltidy,
+ };
+ 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 "Edit $config_file if you want to make any changes\n";
+ print STDOUT "then 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 <<EOM;
+-----------------------------------
+$syntax_check
+-----------------------------------
+The above syntax errors are in File '$ifile'
+EOM
+ die;
+ }
+
+ # read the config file
+ do $ifile;
+
+ return;
+}
+
+sub read_list {
+ my ($fname) = @_;
+ my $rlist;
+
+ # read a single column list of files
+ # remove blank lines and comments
+ my $fh;
+ if ( !open( $fh, "<", $fname ) ) {
+ query("Cannot open $fname: $!\n");
+ return $rlist;
+ }
+ while ( my $line = <$fh> ) {
+ $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 = <STDIN>;
+ 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, <cr>='$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, <cr>='$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 .= " (<cr>=$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 = <IN> ) {
+ 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:
+ # <none> 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(<<EOM);
+A Add new files to existing profiles
+D Delete some files ...
+R Replace all existing files with new files
+X eXit, keeping existing profiles as is
+EOM
+ if ( $ans eq 'X' ) { return }
+ elsif ( $ans eq 'A' ) {
+ foreach my $fname ( @{$rprofiles} ) {
+ if ( $fname =~ /\.([\d]+$)/ ) {
+ if ( $1 > $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 <cr>");
+ }
+ 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 = ["-dsm -dac -i=0 -ci=0 -it=2 -mbl=0"];
+ }
+
+ # 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
+ delete-pod
+ );
+
+ 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;
+ }
+}
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+
+# This is one of a set of programs for doing random testing of perltidy. The
+# goal is to try to crash perltidy. The programs are:
+
+# random_file_generator.pl [this file]
+# perltidy_random_setup.pl [next step]
+# perltidy_random_run.pl [final step]
+
+# This program creates some random files for testing perltidy. You must supply
+# as input args the names of a number of actual source files for it to read and
+# manipulate into random files.
+
+# Do not use too many source files
+my $MAX_SOURCES = 10;
+
+my $usage = <<EOM;
+Create a set of random files for testing perltidy
+
+ random_file_generator file1 [file2 [ ... Num
+
+ file1 file2 ... are perl scripts (or other text files)
+ Num is the number of random files to generate [default 100]
+
+Example: generate 100 random files from the scripts in the upper directory:
+
+ random_file_generator.pl ../*.pl 100
+
+EOM
+
+my @source_files = @ARGV;
+
+my $max_cases = pop @source_files;
+if ( $max_cases !~ /^\d+$/ ) {
+ push @source_files, $max_cases;
+ $max_cases = 100;
+}
+
+# only work on regular source_files with non-zero length
+@source_files=grep {-f $_ && !-z $_} @source_files;
+
+if ( !@source_files ) { die "$usage" }
+
+my $rsource_files = [];
+my $i = -1;
+foreach my $file (@source_files) {
+ $i++;
+ last if ( $i >= $MAX_SOURCES );
+ open( IN, '<', $file ) || die "cannot open $file: $!\n";
+ $rsource_files->[$i] = [];
+ foreach my $line (<IN>) {
+ push @{ $rsource_files->[$i] }, $line;
+ }
+ close(IN);
+}
+
+my $basename = "ranfile";
+my $nsources = @{$rsource_files};
+
+for ( my $nf = 1 ; $nf <= $max_cases ; $nf++ ) {
+ my $fname = "$basename.$nf";
+ my $frac = rand(1);
+ my $ix = int( rand($nsources) );
+ $ix = random_index( $nsources - 1 );
+ my $NMETH = 4;
+ my $method = random_index(3);
+ my $rfile;
+ if ( $method == 3 ) {
+ my $nchars=1+random_index(1000);
+ $rfile = random_characters($nchars);
+print STDERR "Method $method, nchars=$nchars\n";
+ }
+ elsif ( $method == 2 ) {
+ $rfile = skip_random_lines( $rsource_files->[$ix], $frac );
+print STDERR "Method $method, frac=$frac, file=$ix\n";
+ }
+ elsif ( $method == 1 ) {
+ $rfile = select_random_lines( $rsource_files->[$ix], $frac );
+print STDERR "Method $method, frac=$frac, file=$ix\n";
+ }
+ elsif ( $method == 0 ) {
+ $rfile = reverse_random_lines( $rsource_files->[$ix], $frac );
+print STDERR "Method $method, frac=$frac, file=$ix\n";
+ }
+
+ # Shouldn't happen
+ else {
+ my $nchars=1+random_index(1000);
+ $rfile = random_characters($nchars);
+print STDERR "FIXME: method=$method but NMETH=$NMETH; Method $method, nchars=$nchars\n";
+ }
+ open( OUT, ">", $fname ) || die "cannot open $fname: $!\n";
+ foreach my $line ( @{$rfile} ) {
+ print OUT $line;
+ }
+ close OUT;
+}
+
+sub random_index {
+ my ($ix_max) = @_;
+ $ix_max = 0 if ( $ix_max < 0 );
+ my $ix_min = 0;
+ my $ix = int( rand($ix_max) + 0.5 );
+ $ix = $ix_max if ( $ix > $ix_max );
+ $ix = $ix_min if ( $ix < $ix_min );
+ return $ix;
+}
+
+sub random_characters {
+
+ my ($nchars) = @_;
+ my @qset1 = qw# { [ ( } ] ) , ; #;
+ my @qset2 = (
+ qw{a b c f g m q r s t w x y z V W X 0 1 8 9},
+ ';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<',
+ '>', '.', '!', '~', '^', '*', '$', '@', '&', ':', '%', ',',
+ '\\', '/', '_', ' ', "\n", "\t", '-',
+ "'", '"', '`', '#',
+ );
+ my @qset3 = (
+ '!%:', '!%:',
+ '!%:', '!%:',
+ '!*:', '!@:',
+ '%:', '%:,',
+ '%:;', '*:',
+ '*:,', '*::',
+ '*:;', '+%:',
+ '+*:', '+@:',
+ '-%:', '-*:',
+ '-@:', ';%:',
+ ';*:', ';@:',
+ '@:', '@:,',
+ '@::', '@:;',
+ '\%:', '\&:',
+ '\*:', '\@:',
+ '~%:', '~*:',
+ '~@:', '(<',
+ '(<', '=<',
+ 'm(', 'm(',
+ 'm<', 'm[',
+ 'm{', 'q(',
+ 'q<', 'q[',
+ 'q{', 's(',
+ 's<', 's[',
+ 's{', 'y(',
+ 'y<', 'y[',
+ 'y{', '$\'0',
+ '009', '0bB',
+ '0xX', '009;',
+ '0bB;', '0xX;',
+ "<<'", '<<"',
+ '<<`', '&::',
+ '<<a', '<<V',
+ '<<s', '<<y',
+ '<<_', 'm;;_',
+ 'm[]_', 'm]]_',
+ 'm{}_', 'm}}_',
+ 'm--_', 's[]a',
+ 's[]b', 's[]0',
+ 's[];', 's[]]',
+ 's[]=', 's[].',
+ 's[]_', 's{}]',
+ 's{}?', 's<>s',
+ 's<>-', '*::0',
+ '*::1', '*:::',
+ '*::\'', '$::0',
+ '$:::', '$::\'',
+ '@::0', '@::1',
+ '@:::', '&::0',
+ '&::\'', '%:::',
+ '%::\'', '$:::z',
+ '*:::z', "\\\@::'9:!",
+ "} mz}~<<ts", "<\@<<q-r8\n/",
+ "W<<s`[\n(", "X<<f+X;g(<~\" \n1\n*",
+ "c<<t* 9\ns\n~^{s ", "<<V=-<<Wt",
+ "[<<g/.<<r>\nV", "( {8",
+ );
+ my @lines;
+ my $ncpl = 0;
+ my $line = "";
+ for ( my $ich = 0 ; $ich < $nchars ; $ich++ ) {
+ my $nset = random_index(2);
+ my $ch;
+ if ($nset==0) {
+ my $ix = random_index( @qset1 - 1 );
+ $ch = $qset1[$ix];
+ }
+ elsif ($nset==1) {
+ my $ix = random_index( @qset2 - 1 );
+ $ch = $qset2[$ix];
+ }
+ elsif ($nset==2) {
+ my $ix = random_index( @qset3 - 1 );
+ $ch = $qset3[$ix];
+ }
+ $line .= " $ch ";
+ $ncpl++;
+ if ( $ncpl > 20 ) {
+ $line .= "\n";
+ push @lines, $line;
+ $ncpl = 0;
+ }
+ }
+ $line .= "\n";
+ push @lines, $line;
+ return \@lines;
+}
+
+sub select_random_lines {
+
+ # select some fraction of the lines in a source file
+ # in any order
+ my ($rsource, $fkeep) = @_;
+
+ my $nlines = @{$rsource};
+ my $num_keep = $nlines*$fkeep;
+ my $count=0;
+ my @selected;
+ while ($count < $num_keep) {
+ my $ii = random_index($nlines-1);
+ push @selected, $rsource->[$ii];
+ $count++;
+ }
+ return \@selected;
+}
+
+sub reverse_random_lines {
+
+ # skip some fraction of the lines in a source file
+ # and reverse the characters on a line
+ my ($rsource, $frand) = @_;
+
+ my %select;
+ my $nlines = @{$rsource};
+ my $num_delete = $nlines*$frand;
+ my $count=0;
+ while ($count < $num_delete) {
+ my $ii = rand($nlines);
+ $ii = int($ii);
+ $select{$ii} = 1;
+ $count++;
+ }
+
+ my @lines;
+ my $jj = -1;
+ foreach my $line (@{$rsource}) {
+ $jj++;
+ if ($select{$jj} ) {
+ chomp $line;
+ $line = reverse($line);
+ $line .= "\n";
+ };
+ push @lines, $line;
+ }
+ return \@lines;
+}
+
+sub skip_random_lines {
+
+ # skip some fraction of the lines in a source file
+ # but keep lines in the original order
+ my ($rsource, $fskip) = @_;
+
+ my %skip;
+ my $nlines = @{$rsource};
+ my $num_delete = $nlines*$fskip;
+ my $count=0;
+ while ($count < $num_delete) {
+ my $ii = rand($nlines);
+ $ii = int($ii);
+ $skip{$ii} = 1;
+ $count++;
+ }
+
+ my @selected;
+ my $jj = -1;
+ foreach my $line (@{$rsource}) {
+ $jj++;
+ next if $skip{$jj};
+ push @selected, $line;
+ }
+ return \@selected;
+}
+
+__END__
+
+my $ii = rand(@lines);
+$ii = int($ii);
+my %skip;
+$skip{$ii} = 1;
+print STDERR "Skipping line $ii\n";
+
+my @select;
+my $jj = -1;
+foreach my $line (@lines) {
+ $jj++;
+ next if $skip{$jj};
+ push @selected, $line;
+}
+foreach my $line (@selected) {
+ print STDOUT $line;
+}
+++ /dev/null
-#!/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 = <<EOM;
-
-Use 'perltidy_random_setup.pl' to setup a run in an empty temporary direct
-(lots of temporary files may be created).
-
-Follow the directions it gives.
-
-Output is accumulated in file 'nohup.my'
-
-You can stop the run any time by creating a file "stop.now"
-
-You can restart by running './GO.sh' which is written
-when this run stops.
-
-EOM
-
-# NOTE: A restart is controlled by a single arg to this routine.
-# The restart format is
-#
-# $0 [m.n]
-#
-# where m.n is an optional restart point:
-#
-# m = integer file number to begin (start counting with 1)
-# n = integer first parameter case (start counting with 1)
-#
-# A restart from '1.1' is the same as a start.
-
-use Getopt::Std;
-our %opts;
-getopts( 'h', \%opts ) or die "$usage";
-if ( $opts{h} ) { die "$usage" }
-
-our $rsetup; # the config info
-
-my $config_file = "config.txt";
-if ( !-e $config_file ) {
- die <<EOM;
-Did not see '$config_file'
-Please run 'perltidy_random_setup.pl' first
-EOM
-}
-
-my $nf_beg = 1;
-my $np_beg = 1;
-if ( @ARGV > 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};
-my $perltidy = $rsetup->{perltidy};
-
-my $binfile = "perltidy";
-if ($perltidy) {
- $binfile = "perl $perltidy";
-}
-
-$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 <<EOM;
-Exiting, nothing to do:
-Requested range of files is $nf_beg to $nf_end
-Requested range of profiles is $np_beg to $np_end
-EOM
-}
-
-# Outer loop over files
-my $file_count = 0;
-my $case = 0;
-MAIN_LOOP:
-for ( my $nf = $nf_beg ; $nf <= $nf_end ; $nf++ ) {
- my $file = $files[ $nf - 1 ];
-
- # remove any previously saved files
- if (@saved_for_deletion) {
- foreach (@saved_for_deletion) {
- unlink $_ if ( -e $_ );
- }
- @saved_for_deletion = ();
- }
-
- next unless -e $file;
- $file_count = $nf;
- my $ifile = $file;
- my $ifile_original = $ifile;
- my $ifile_size = -s $ifile;
- my $error_count_this_file = 0;
-
- my $error_count = 0;
- my $missing_ofile_count = 0;
- my $missing_chkfile_count = 0;
- my ( $ofile_size_min, $ofile_size_max );
- my ( $ofile_case_min, $ofile_case_max );
- my ( $efile_size_min, $efile_size_max ) = ( 0, 0 );
- my ( $efile_case_min, $efile_case_max ) = ( "", "" );
- my ( $chkfile_size_min, $chkfile_size_max );
- my ( $chkfile_case_min, $chkfile_case_max );
- my $ofile_size_min_expected = 0;
-
- my $error_flag = 0;
- my $restart_count = 0;
- my $efile_count = 0;
- my $has_starting_error;
- my $starting_syntax_ok = 1;
-
- # Inner loop over profiles for a given file
- for ( my $np = $np_beg ; $np <= $np_end ; $np++ ) {
- my $profile = $profiles[ $np - 1 ];
-
- $case = $np;
- my $error_count_this_case = 0;
-
- my $ext = $case;
- if ( @files > 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 = "$binfile <$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 an unexpectedly very small file size...
- # NOTE: file sizes can often be unexpectly small when operating on
- # random text. For example, if a random line begins with an '='
- # then when a --delete-pod parameter is set, everything from there
- # on gets deleted.
- # But we still want to catch zero size files, since they might
- # indicate a code crash. So I have lowered the fraction in this
- # test to a small value.
- elsif ( $case > 3 && $ofile_size < 0.1 * $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 && $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
-
-if (@saved_for_deletion) {
- foreach (@saved_for_deletion) {
- unlink $_ if ( -e $_ );
- }
- @saved_for_deletion = ();
-}
-
-# Summarize results..
-if (@problems) {
- print STDERR <<EOM;
-
-=============================
-SUMMARY OF POSSIBLE PROBLEMS:
-=============================
-EOM
-
- foreach my $nf (@problems) {
- report_results( $rsummary->[$nf] );
- }
- if (@chkfile_errors) {
- local $" = ')(';
- my $num = @chkfile_errors;
- $num = 20 if ( $num > 20 );
- print STDERR <<EOM;
-Some check files with errors (search above for '**ERROR'):
-(@chkfile_errors[1..$num-1])
-EOM
- }
- if (@size_errors) {
- local $" = ')(';
- my $num = @size_errors;
- $num = 20 if ( $num > 20 );
- print STDERR <<EOM;
-Some files with definite size errors (search above for '**ERROR'):
-(@size_errors[1..$num-1])
-EOM
- }
- if (@syntax_errors) {
- local $" = ')(';
- my $num = @syntax_errors;
- $num = 20 if ( $num > 20 );
- print STDERR <<EOM;
-Some files with definite size errors (search above for '**ERROR'):
-(@syntax_errors[1..$num-1])
-EOM
- }
-}
-else {
- print STDERR <<EOM;
-
-========================
-No obvious problems seen
-========================
-EOM
-
-}
-
-# Write a script to automate search for errors
-write_runme();
-
-# Write a restart file
-my ( $nf, $np );
-if ( $case < $np_end ) {
- $nf = $file_count;
- $np = $case + 1;
- write_GO( $nf, $np );
-}
-elsif ( $file_count < $nf_end ) {
- $nf = $file_count + 1;
- $np = 1;
- write_GO( $nf, $np );
-}
-
-print STDERR <<EOM;
-Next: run 'RUNME.pl' or do this by hand:
-Look for lines longer than 80 characters
-grep 'Thank you' and 'bug in perltidy' in all .ERR files
-Search STDERR for 'uninitialized' and other warnings
-EOM
-
-sub report_results {
-
- my ($rh) = @_;
-
- my $ifile_original = $rh->{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 <<EOM;
-------------------------------------------------
-Original input file: $ifile_original
-ifile size : $ifile_size
-$error_count files had errors when reformatted
-$missing_ofile_count output files were missing
-$missing_chkfile_count check output files were missing
-EOM
-
- print STDERR <<EOM if ( defined($ofile_size_min) );
-
-Minimum output size: $ofile_size_min for case $ofile_case_min
-Maximum output size: $ofile_size_max for case $ofile_case_max
-EOM
-
- print STDERR <<EOM if ( defined($chkfile_size_min) );
-
-Minimum rerun size: $chkfile_size_min for case $chkfile_case_min
-Maximum rerun size: $chkfile_size_max for case $chkfile_case_max
-EOM
-
- print STDERR <<EOM if ( defined($efile_size_min) );
-
-Number of error files: $efile_count
-Minimum error file size: $efile_size_min for case $efile_case_min
-Maximum error file size: $efile_size_max for case $efile_case_max
-EOM
- return;
-}
-
-sub write_GO {
-
- my ( $nf, $np ) = @_;
- my $runme = "GO.sh";
- unlink $runme if ( -e $runme );
- 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
-nohup nice -n19 perltidy_random_run.pl $nf.$np >>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=<IN>;
-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 <<EOM;
------------------------------------
-$syntax_check
------------------------------------
-The above syntax errors are in File '$ifile'
-EOM
- die;
- }
-
- print STDOUT "$ifile:\n";
-
- # read the config file
- do $ifile;
-
- return;
-}
-
-sub read_list {
- my ($fname) = @_;
- my $rlist;
-
- # read a single column list of files
- # remove blank lines and comments
- my $fh;
- if ( !open( $fh, "<", $fname ) ) {
- query("Cannot open $fname: $!\n");
- return $rlist;
- }
- while ( my $line = <$fh> ) {
- $line =~ s/^\s+//;
- $line =~ s/\s+$//;
- next if $line =~ /^#/;
- push @{$rlist}, $line;
- }
- $fh->close();
- return $rlist;
-}
+++ /dev/null
-#!/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 $perltidy = "";
-my $rfiles = [];
-my $rprofiles = [];
-
-# Run this in a temporary directory to setup the actual run
-query(<<EOM);
-
-Be sure you should be in a temporary directory which can be deleted when
-this is finished. Hit <cr>.
-
-EOM
-
-# Defaults
-default_config();
-
-if ( -e $config_file ) {
- if ( ifyes("Read the existing config.txt file? [Y/N]", "Y") ) {
- read_config($config_file);
- }
-}
-
-if ( -e $FILES_file ) {
- if (ifyes("Found $FILES_file, read it ? [Y/N]", "Y") ) {
- $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]", "Y") ) {
- $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(<<EOM,"N");
-Do you want to check syntax with perl -c ?
-This will cause any BEGIN blocks in them to execute, which
-can introduce a security concern.
-Enter 'N' unless you very familiar with the test scripts.
-Y/N:
-EOM
-
-my $file_info=get_file_info();
-my $profile_info = get_profile_info();
-my $nprofiles = @{$rprofiles};
-while (1) {
- my $files = $rsetup->{files};
- my $chain_mode = $rsetup->{chain_mode};
- my $do_syntax_check = $rsetup->{syntax_check};
- my $delete_good_output = $rsetup->{delete_good_output};
- my $perltidy_version = $rsetup->{perltidy};
- $perltidy_version = "[default]" unless ($perltidy_version);
- print <<EOM;
-===Main Menu===
-R - Read a config file
-F - Files: $files
-$file_info
-P - Profiles:
-$profile_info
-C - Chain mode : $chain_mode
-D - Delete good output? : $delete_good_output
-S - Syntax check? : $do_syntax_check
-V - perltidy Version : $perltidy_version
-Q - Quit without saving config file
-W - Write config, FILES.txt, PROFILES.txt, GO.sh and eXit
-EOM
-
- my ($ans) = queryu(':');
- if ( $ans eq 'R' ) {
- my $infile = get_input_filename( '', '.txt', $config_file );
- read_config($infile);
- }
- elsif ( $ans eq 'E' ) {
- edit_config();
- }
- elsif ( $ans eq 'F' ) {
- define_files();
- $rfiles = filter_files($rfiles);
- $file_info=get_file_info()
- }
- elsif ( $ans eq 'P' ) {
- make_profiles();
- $rprofiles = filter_profiles($rprofiles);
- $profile_info = get_profile_info();
- }
- elsif ( $ans eq 'C' ) {
- $chain_mode = get_num("Chaining: 0=no, 1=always,2=random");
- $rsetup->{chain_mode} = $chain_mode;
- }
- elsif ( $ans eq 'D' ) {
- $delete_good_output = ifyes("Delete needless good output files? [Y/N]","Y");
- $rsetup->{delete_good_output} = $delete_good_output;
- }
- elsif ( $ans eq 'S' ) {
- $do_syntax_check = ifyes("Do syntax checking? [Y/N]","N");
- $rsetup->{syntax_check} = $do_syntax_check;
- }
- elsif ( $ans eq 'V' ) {
- my $test =
- query("Enter the full path to the perltidy binary, or <cr> for default");
- if ( $test && !-e $test ) {
- next
- unless (
- ifyes("I cannot find that, do you want to use it anyway?") );
- }
- $rsetup->{perltidy} = $test;
- }
- 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 <<EOM;
-====== Define some files to process =================================
-$file_info
-
-Note that you can generate random files with 'random_file_generator.pl'
-If you want to do that, you should exit now, generate them, then come
-back.
-EOM
- my $nfiles_old = @{$rfiles};
- if ($nfiles_old) {
- if ( ifyes("Use these files as is? [Y/N]") ) {
- return;
- }
- }
-
- my $glob = '../*';
- my $ans = query("File glob of files to process, <cr>='$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(<<EOM);
-A Add new files to existing files
-R Replace existing files with new files
-X eXit, keeping existing files as is
-EOM
- if ( $ans eq 'X' ) { return }
- elsif ( $ans eq 'A' ) { last }
- elsif ( $ans eq 'R' ) { @{$rfiles} = []; last }
-
- }
- }
- push @{$rfiles}, @files;
- $rfiles = uniq($rfiles);
- $rfiles = [ sort @{$rfiles} ];
- return;
-}
-
-sub get_profile_info {
-
- my $nprofiles = @{$rprofiles};
- my $profile0 = "(none)";
- my $profileN = "(none)";
- if ($nprofiles) {
- $profile0 = $rprofiles->[0];
- $profileN = $rprofiles->[-1];
- }
- my $profile_info = <<EOM;
- Number of Files: $nprofiles
- First profile : $profile0
- Last profile : $profileN
-EOM
- return $profile_info;
-}
-
-sub get_file_info {
-
- my $nfiles = @{$rfiles};
- my $file0 = "(none)";
- my $fileN = "(none)";
- if ($nfiles) {
- $file0 = $rfiles->[0];
- $fileN = $rfiles->[-1];
- }
- my $file_info = <<EOM;
- Number of Files: $nfiles
- First file : $file0
- Last file : $fileN
-EOM
- return $file_info;
-}
-
-sub default_config {
- $rsetup = {
- chain_mode => 2,
- delete_good_output => 1,
- syntax_check => 0,
- profiles => $PROFILES_file,
- files => $FILES_file,
- perltidy => $perltidy,
- };
- 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 "Edit $config_file if you want to make any changes\n";
- print STDOUT "then 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 <<EOM;
------------------------------------
-$syntax_check
------------------------------------
-The above syntax errors are in File '$ifile'
-EOM
- die;
- }
-
- # read the config file
- do $ifile;
-
- return;
-}
-
-sub read_list {
- my ($fname) = @_;
- my $rlist;
-
- # read a single column list of files
- # remove blank lines and comments
- my $fh;
- if ( !open( $fh, "<", $fname ) ) {
- query("Cannot open $fname: $!\n");
- return $rlist;
- }
- while ( my $line = <$fh> ) {
- $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 = <STDIN>;
- 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, <cr>='$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, <cr>='$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 .= " (<cr>=$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 = <IN> ) {
- 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:
- # <none> 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(<<EOM);
-A Add new files to existing profiles
-D Delete some files ...
-R Replace all existing files with new files
-X eXit, keeping existing profiles as is
-EOM
- if ( $ans eq 'X' ) { return }
- elsif ( $ans eq 'A' ) {
- foreach my $fname ( @{$rprofiles} ) {
- if ( $fname =~ /\.([\d]+$)/ ) {
- if ( $1 > $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 <cr>");
- }
- 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 = ["-dsm -dac -i=0 -ci=0 -it=2 -mbl=0"];
- }
-
- # 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
- delete-pod
- );
-
- 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;
- }
-}
+++ /dev/null
-#!/usr/bin/perl -w
-use strict;
-use warnings;
-
-# Do not use too source files
-my $MAX_SOURCES = 10;
-
-my $usage = <<EOM;
-Run perltidy repeatedly on a selected file with randomly generated parameters:
-
- perltidy_random_parameters file1 [file2 [ ... Num
-
-file1 ... are the names of a text to be formatted
-Num is the number of times, default 1000;
-
-You can stop the run any time by creating a file "stop.now"
-EOM
-
-# Random testing of Perl::Tidy
-# Given:
-# - a list of files
-# - a list of options
-
-# Write out a logfile of results:
-# name, exit flag, isize, osize
-# gzip name.in, name.in.tdy, name.par, name.ERR
-
-# Also save nohup.out, and echo each file as you go
-# Looking for perl complaints
-
-# Structure:
-# logfile.txt
-# files/ - has text input files for random selection
-# tmp/ - has zipped output
-
-# Continually generate files with random parameters and some randomly removed
-# lines and run perltidy.
-
-my @source_files = @ARGV;
-
-my $max_cases = pop @source_files;
-if ( $max_cases !~ /^\d+$/ ) {
- push @source_files, $max_cases;
- $max_cases = 100;
-}
-
-# only work on regular source_files with non-zero length
-@source_files=grep {-f $_ && !-z $_} @source_files;
-
-if ( !@source_files ) { die "$usage" }
-
-my $rsource_files = [];
-my $i = -1;
-foreach my $file (@source_files) {
- $i++;
- last if ( $i >= $MAX_SOURCES );
- open( IN, '<', $file ) || die "cannot open $file: $!\n";
- $rsource_files->[$i] = [];
- foreach my $line (<IN>) {
- push @{ $rsource_files->[$i] }, $line;
- }
- close(IN);
-}
-
-my $basename = "ranfile";
-my $nsources = @{$rsource_files};
-
-for ( my $nf = 1 ; $nf <= $max_cases ; $nf++ ) {
- my $fname = "$basename.$nf";
- my $frac = rand(1);
- my $ix = int( rand($nsources) );
- $ix = random_index( $nsources - 1 );
- my $NMETH = 4;
- my $method = random_index(3);
- my $rfile;
- if ( $method == 3 ) {
- my $nchars=1+random_index(1000);
- $rfile = random_characters($nchars);
-print STDERR "Method $method, nchars=$nchars\n";
- }
- elsif ( $method == 2 ) {
- $rfile = skip_random_lines( $rsource_files->[$ix], $frac );
-print STDERR "Method $method, frac=$frac, file=$ix\n";
- }
- elsif ( $method == 1 ) {
- $rfile = select_random_lines( $rsource_files->[$ix], $frac );
-print STDERR "Method $method, frac=$frac, file=$ix\n";
- }
- elsif ( $method == 0 ) {
- $rfile = reverse_random_lines( $rsource_files->[$ix], $frac );
-print STDERR "Method $method, frac=$frac, file=$ix\n";
- }
-
- # Shouldn't happen
- else {
- my $nchars=1+random_index(1000);
- $rfile = random_characters($nchars);
-print STDERR "FIXME: method=$method but NMETH=$NMETH; Method $method, nchars=$nchars\n";
- }
- open( OUT, ">", $fname ) || die "cannot open $fname: $!\n";
- foreach my $line ( @{$rfile} ) {
- print OUT $line;
- }
- close OUT;
-}
-
-sub random_index {
- my ($ix_max) = @_;
- $ix_max = 0 if ( $ix_max < 0 );
- my $ix_min = 0;
- my $ix = int( rand($ix_max) + 0.5 );
- $ix = $ix_max if ( $ix > $ix_max );
- $ix = $ix_min if ( $ix < $ix_min );
- return $ix;
-}
-
-sub random_characters {
-
- my ($nchars) = @_;
- my @qset1 = qw# { [ ( } ] ) , ; #;
- my @qset2 = (
- qw{a b c f g m q r s t w x y z V W X 0 1 8 9},
- ';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<',
- '>', '.', '!', '~', '^', '*', '$', '@', '&', ':', '%', ',',
- '\\', '/', '_', ' ', "\n", "\t", '-',
- "'", '"', '`', '#',
- );
- my @qset3 = (
- '!%:', '!%:',
- '!%:', '!%:',
- '!*:', '!@:',
- '%:', '%:,',
- '%:;', '*:',
- '*:,', '*::',
- '*:;', '+%:',
- '+*:', '+@:',
- '-%:', '-*:',
- '-@:', ';%:',
- ';*:', ';@:',
- '@:', '@:,',
- '@::', '@:;',
- '\%:', '\&:',
- '\*:', '\@:',
- '~%:', '~*:',
- '~@:', '(<',
- '(<', '=<',
- 'm(', 'm(',
- 'm<', 'm[',
- 'm{', 'q(',
- 'q<', 'q[',
- 'q{', 's(',
- 's<', 's[',
- 's{', 'y(',
- 'y<', 'y[',
- 'y{', '$\'0',
- '009', '0bB',
- '0xX', '009;',
- '0bB;', '0xX;',
- "<<'", '<<"',
- '<<`', '&::',
- '<<a', '<<V',
- '<<s', '<<y',
- '<<_', 'm;;_',
- 'm[]_', 'm]]_',
- 'm{}_', 'm}}_',
- 'm--_', 's[]a',
- 's[]b', 's[]0',
- 's[];', 's[]]',
- 's[]=', 's[].',
- 's[]_', 's{}]',
- 's{}?', 's<>s',
- 's<>-', '*::0',
- '*::1', '*:::',
- '*::\'', '$::0',
- '$:::', '$::\'',
- '@::0', '@::1',
- '@:::', '&::0',
- '&::\'', '%:::',
- '%::\'', '$:::z',
- '*:::z', "\\\@::'9:!",
- "} mz}~<<ts", "<\@<<q-r8\n/",
- "W<<s`[\n(", "X<<f+X;g(<~\" \n1\n*",
- "c<<t* 9\ns\n~^{s ", "<<V=-<<Wt",
- "[<<g/.<<r>\nV", "( {8",
- );
- my @lines;
- my $ncpl = 0;
- my $line = "";
- for ( my $ich = 0 ; $ich < $nchars ; $ich++ ) {
- my $nset = random_index(2);
- my $ch;
- if ($nset==0) {
- my $ix = random_index( @qset1 - 1 );
- $ch = $qset1[$ix];
- }
- elsif ($nset==1) {
- my $ix = random_index( @qset2 - 1 );
- $ch = $qset2[$ix];
- }
- elsif ($nset==2) {
- my $ix = random_index( @qset3 - 1 );
- $ch = $qset3[$ix];
- }
- $line .= " $ch ";
- $ncpl++;
- if ( $ncpl > 20 ) {
- $line .= "\n";
- push @lines, $line;
- $ncpl = 0;
- }
- }
- $line .= "\n";
- push @lines, $line;
- return \@lines;
-}
-
-sub select_random_lines {
-
- # select some fraction of the lines in a source file
- # in any order
- my ($rsource, $fkeep) = @_;
-
- my $nlines = @{$rsource};
- my $num_keep = $nlines*$fkeep;
- my $count=0;
- my @selected;
- while ($count < $num_keep) {
- my $ii = random_index($nlines-1);
- push @selected, $rsource->[$ii];
- $count++;
- }
- return \@selected;
-}
-
-sub reverse_random_lines {
-
- # skip some fraction of the lines in a source file
- # and reverse the characters on a line
- my ($rsource, $frand) = @_;
-
- my %select;
- my $nlines = @{$rsource};
- my $num_delete = $nlines*$frand;
- my $count=0;
- while ($count < $num_delete) {
- my $ii = rand($nlines);
- $ii = int($ii);
- $select{$ii} = 1;
- $count++;
- }
-
- my @lines;
- my $jj = -1;
- foreach my $line (@{$rsource}) {
- $jj++;
- if ($select{$jj} ) {
- chomp $line;
- $line = reverse($line);
- $line .= "\n";
- };
- push @lines, $line;
- }
- return \@lines;
-}
-
-sub skip_random_lines {
-
- # skip some fraction of the lines in a source file
- # but keep lines in the original order
- my ($rsource, $fskip) = @_;
-
- my %skip;
- my $nlines = @{$rsource};
- my $num_delete = $nlines*$fskip;
- my $count=0;
- while ($count < $num_delete) {
- my $ii = rand($nlines);
- $ii = int($ii);
- $skip{$ii} = 1;
- $count++;
- }
-
- my @selected;
- my $jj = -1;
- foreach my $line (@{$rsource}) {
- $jj++;
- next if $skip{$jj};
- push @selected, $line;
- }
- return \@selected;
-}
-
-__END__
-
-my $ii = rand(@lines);
-$ii = int($ii);
-my %skip;
-$skip{$ii} = 1;
-print STDERR "Skipping line $ii\n";
-
-my @select;
-my $jj = -1;
-foreach my $line (@lines) {
- $jj++;
- next if $skip{$jj};
- push @selected, $line;
-}
-foreach my $line (@selected) {
- print STDOUT $line;
-}
projects / perltidy.git / commitdiff