From c69992d508ed96c2f96ba478e7ac845805388892 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Mon, 11 Dec 2023 16:58:56 -0800 Subject: [PATCH] fix some minor issues found with -dv --- dev-bin/blinkers.pl | 23 ++- dev-bin/build.pl | 3 +- dev-bin/perltidy_minimal_flags.pl | 7 +- dev-bin/perltidy_random_setup.pl | 298 +++++++++++++++--------------- 4 files changed, 166 insertions(+), 165 deletions(-) diff --git a/dev-bin/blinkers.pl b/dev-bin/blinkers.pl index b491f923..94449b98 100755 --- a/dev-bin/blinkers.pl +++ b/dev-bin/blinkers.pl @@ -102,6 +102,8 @@ sub set_perltidy { sub get_version { my ($my_perltidy) = @_; + + # get the perltidy version my ( $fh, $tmpname ) = File::Temp::tempfile(); my $cmd = "$my_perltidy -v >$tmpname"; system($cmd); @@ -131,9 +133,9 @@ sub set_dirs { } if ( !@{$rdirs} ) { push @{$rdirs}, '.'; } $dir_string = join " ", @{$rdirs}; - if (length($dir_string . 40)) { - my $numd=@{$rdirs}; - $dir_string = substr($dir_string, 0, 40); + if ( length( $dir_string . 40 ) ) { + my $numd = @{$rdirs}; + $dir_string = substr( $dir_string, 0, 40 ); $dir_string .= "...[$numd dirs]"; } return; @@ -150,7 +152,6 @@ sub find_git_home { } sub ask_git_home { - my ( $fh, $err_file ) = File::Temp::tempfile(); # Only allow user to change git_home if it is not known automatically if ( !$know_git_home ) { @@ -322,8 +323,8 @@ sub blinker_test { my $imax = 4; my @ofiles; my %digest_seen; - my $digest = digest_file($ifile); - $digest_seen{$digest} = 0; + my $digest_in = digest_file($ifile); + $digest_seen{$digest_in} = 0; # Option changes: # -it=1 (just do 1 iteration) @@ -649,13 +650,17 @@ sub rename_blinkers { sub find_last_name { my ($data) = @_; + + # Find the last blinker case number in the file $data + # We ignore cases not beginning with 'b' + if ( !-e $data ) { print STDERR "Cannot find $data\n"; return; } my $string = slurp_file($data); my @lines = split /^/, $string; - my ( $max_case, $prefix ); + my $max_case; #==> b001.in <== foreach my $line (@lines) { @@ -663,7 +668,9 @@ sub find_last_name { if ( !defined($max_case) || $max_case < $1 ) { $max_case = $1 } } } - return 'b' . $max_case; + + if ( defined($max_case) ) { $max_case = 'b' . $max_case } + return $max_case; } ######################################################### diff --git a/dev-bin/build.pl b/dev-bin/build.pl index e5c87285..3e866843 100755 --- a/dev-bin/build.pl +++ b/dev-bin/build.pl @@ -350,7 +350,8 @@ sub make_dist { ) { my $fout = "tmp/cpants_lint.out"; - my $cmd = "cpants_lint.pl $tar_gz_file >$fout 2>$fout"; + if ( -e $fout ) { unlink $fout } + my $cmd = "cpants_lint.pl $tar_gz_file >$fout 2>$fout"; post_result($fout); } return; diff --git a/dev-bin/perltidy_minimal_flags.pl b/dev-bin/perltidy_minimal_flags.pl index e4785dc0..aa51555e 100755 --- a/dev-bin/perltidy_minimal_flags.pl +++ b/dev-bin/perltidy_minimal_flags.pl @@ -89,10 +89,9 @@ sub get_defaults { # get latest parameters from perltidy use File::Temp qw(tempfile); - my $ris_default = {}; + my %is_default; my ( $fout, $tmpnam ) = File::Temp::tempfile(); if ( !$fout ) { die "cannot get tempfile\n" } - my @parameters; system "perltidy --dump-defaults >$tmpnam"; open( IN, "<", $tmpnam ) || die "cannot open $tmpnam: $!\n"; @@ -100,9 +99,9 @@ sub get_defaults { next if $line =~ /#/; $line =~ s/^\s+//; $line =~ s/\s+$//; - $ris_default->{$line} = 1; + $is_default{$line} = 1; } close IN; unlink $tmpnam if ( -e $tmpnam ); - return $ris_default; + return \%is_default; } diff --git a/dev-bin/perltidy_random_setup.pl b/dev-bin/perltidy_random_setup.pl index 0ac938fb..a74f22e2 100755 --- a/dev-bin/perltidy_random_setup.pl +++ b/dev-bin/perltidy_random_setup.pl @@ -17,35 +17,41 @@ use Data::Dumper; # You should create a temporary directory for this work. +# Global variables our $rsetup; # the setup hash my $config_file = "config.txt"; my $FILES_file = "FILES.txt"; my $PROFILES_file = "PROFILES.txt"; my $perltidy = "./perltidy.pl"; -my $rfiles = []; my $rprofiles = []; -# if file 'perltidy.pl' is found here then make that the default -if ( -e './perltidy.pl' ) { $perltidy = './perltidy.pl' } - -# always require a separate version of perltidy -# go get a copy if there is none: -# On my system I have a utility 'get_perltidy.pl' which gets the latest -# perltidy.pl with DEVEL_MODE => 1 everywhere -else { - print STDERR "Attempting to get perltidy.pl in DEVEL_MODE...\n"; - my $fail = system("get_perltidy.pl"); - if ($fail) { - die "..Failed. Please move a copy of perltidy.pl here first\n"; +main(); + +sub main { + + my $rfiles = []; + + # if file 'perltidy.pl' is found here then make that the default + if ( -e './perltidy.pl' ) { $perltidy = './perltidy.pl' } + + # always require a separate version of perltidy + # go get a copy if there is none: + # On my system I have a utility 'get_perltidy.pl' which gets the latest + # perltidy.pl with DEVEL_MODE => 1 everywhere + else { + print STDERR "Attempting to get perltidy.pl in DEVEL_MODE...\n"; + my $fail = system("get_perltidy.pl"); + if ($fail) { + die "..Failed. Please move a copy of perltidy.pl here first\n"; + } } -} -# see if DEVEL_MODE is set, turn it on if not -if ( $perltidy eq "./perltidy.pl" ) { - check_DEVEL_MODE($perltidy); -} + # see if DEVEL_MODE is set, turn it on if not + if ( $perltidy eq "./perltidy.pl" ) { + check_DEVEL_MODE($perltidy); + } -query(< to continue, or hit control-C to quit. EOM -# Defaults -default_config(); + # Defaults + default_config(); -if ( -e $config_file ) { - if ( ifyes( "Read the existing config.txt file? [Y/N]", "Y" ) ) { - read_config($config_file); + 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 ( -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} ) { - $rfiles = define_new_files(); -} + if ( !@{$rfiles} ) { + $rfiles = define_new_files(); + } -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 ( -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); -} + if ( !@{$rprofiles} ) { + make_profiles(); + $rprofiles = filter_profiles($rprofiles); + } -# this is permanently deactivated -$rsetup->{'syntax_check'} = 0; + # this is permanently deactivated + $rsetup->{'syntax_check'} = 0; =pod $rsetup->{'syntax_check'} = ifyes( <{files}; - my $chain_mode = $rsetup->{chain_mode}; - my $append_flags = $rsetup->{append_flags}; - 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 <{files}; + my $chain_mode = $rsetup->{chain_mode}; + my $append_flags = $rsetup->{append_flags}; + 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 <{chain_mode} = $chain_mode; - } - elsif ( $ans eq 'A' ) { - my $str = query("Enter any flags to append"); - $rsetup->{append_flags} = $str; - } - 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 for default"); - if ( $test && !-e $test ) { - next - unless ( - ifyes("I cannot find that, do you want to use it anyway?") ); + 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 'FR' ) { + $rfiles = define_new_files(); + $rfiles = filter_files($rfiles); + $file_info = get_file_info($rfiles); + } + elsif ( $ans eq 'FA' ) { + $rfiles = add_files($rfiles); + $file_info = get_file_info($rfiles); + } + 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 'A' ) { + my $str = query("Enter any flags to append"); + $rsetup->{append_flags} = $str; + } + 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 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; } - $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(); + write_GO(); +} sub filter_files { my ($rlist) = @_; @@ -228,8 +236,8 @@ sub filter_files { # NOTE: this could also be an option @{$rlist} = grep { !-e "$_.ERR" } - # exclude pro{$rlist} - @{$rlist} = grep { $_ !~ /profile\.[0-9]*/ } @{$rlist}; + # exclude pro{$rlist} + @{$rlist} = grep { $_ !~ /profile\.[0-9]*/ } @{$rlist}; # Sort by size @{$rlist} = @@ -276,9 +284,10 @@ EOM my $rnew_files = []; my $glob = '../*'; + my $ans; REDO: - my $ans = query("File glob to get some NEW files to process, ='$glob'"); + $ans = query("File glob to get some NEW files to process, ='$glob'"); $glob = $ans if ($ans); return $rnew_files unless ($glob); my @files = glob($glob); @@ -289,10 +298,8 @@ EOM $rnew_files = filter_files($rnew_files); while (1) { - my $nfiles_new = @{$rnew_files}; - my $total_size_mb = file_size_sum_mb($rnew_files); - my $file_info = get_file_info($rnew_files); - my $ans = queryu(<='$glob'"); $glob = $ans if ($ans); next unless ($glob); @@ -385,8 +392,8 @@ sub reduce_total_file_size { my $want = $sum * $fraction; my @new_files; foreach (@partial_sum) { - my ( $fname, $sum ) = @{$_}; - last if ( $sum > $want ); + my ( $fname, $psum ) = @{$_}; + last if ( $psum > $want ); push @new_files, $fname; } return \@new_files; @@ -671,17 +678,17 @@ sub get_num { use File::Temp qw(tempfile); my ( $fout, $tmpnam ) = File::Temp::tempfile(); if ( !$fout ) { die "cannot get tempfile\n" } - my @parameters; + my $rparameters = []; system "perltidy --dump-long-names >$tmpnam"; open( IN, "<", $tmpnam ) || die "cannot open $tmpnam: $!\n"; while ( my $line = ) { next if $line =~ /#/; chomp $line; - push @parameters, $line; + push @{$rparameters}, $line; } close IN; unlink $tmpnam if ( -e $tmpnam ); - return \@parameters; + return $rparameters; } sub get_integer_option_range { @@ -708,20 +715,6 @@ sub get_num { return \%integer_option_range; } - sub dump_integer_option_range { - my ($rinteger_option_range) = @_; - print {*STDOUT} "Option, min, max, default\n"; - foreach my $key ( sort keys %{$rinteger_option_range} ) { - my ( $min, $max, $default ) = @{ $rinteger_option_range->{$key} }; - foreach ( $min, $max, $default ) { - $_ = 'undef' unless defined($_); - } - print {*STDOUT} "$key, $min, $max, $default\n"; - } - return; - } ## end sub dump_integer_option-range - - BEGIN { # Here is a static list of all parameters current as of v.20200907 @@ -1031,9 +1024,10 @@ sub get_num { print STDERR "Updating perltidy parameters....\n"; } - $rinteger_option_range = get_integer_option_range(); + $rinteger_option_range = get_integer_option_range(); } + sub make_profiles { my $nfiles_old = @{$rprofiles}; my $case = 0; @@ -1165,11 +1159,11 @@ EOM ); my %option_range = ( - 'format' => [ 'tidy', 'html' ], #, 'user' ], - 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], - 'extended-block-tightness-list' => [ 'k', 't', 'kt' ], + 'format' => [ 'tidy', 'html' ], #, 'user' ], + 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], + 'extended-block-tightness-list' => [ 'k', 't', 'kt' ], - 'warn-variables' => ['0', '1'], + 'warn-variables' => [ '0', '1' ], 'space-backslash-quote' => [ 0, 2 ], 'block-brace-tightness' => [ 0, 2 ], @@ -1377,7 +1371,7 @@ EOM next if $skip{$name}; # skip all dump options; they dump to stdout and exit - next if ($name=~/^dump-/); + next if ( $name =~ /^dump-/ ); # Skip all pattern lists if ( $flag =~ /s$/ ) { -- 2.39.5