From 6bc240eaecb295dba7ae0811bc294b459f62aee8 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Fri, 27 Jan 2023 17:27:13 -0800 Subject: [PATCH] Added parameter --one-line-block-exclusion-list=s --- CHANGES.md | 8 ++ MANIFEST | 1 + bin/perltidy | 50 ++++++----- dev-bin/perltidy_random_setup.pl | 2 + lib/Perl/Tidy.pm | 1 + lib/Perl/Tidy/Formatter.pm | 42 ++++++--- t/snippets/expect/olbxl.def | 11 +++ t/snippets/expect/olbxl.olbxl1 | 13 +++ t/snippets/expect/olbxl.olbxl2 | 18 ++++ t/snippets/olbxl.in | 17 ++++ t/snippets/olbxl1.par | 1 + t/snippets/olbxl2.par | 1 + t/snippets/packing_list.txt | 3 + t/snippets27.t | 61 +++++++++++++ t/snippets28.t | 142 +++++++++++++++++++++++++++++++ 15 files changed, 341 insertions(+), 30 deletions(-) create mode 100644 t/snippets/expect/olbxl.def create mode 100644 t/snippets/expect/olbxl.olbxl1 create mode 100644 t/snippets/expect/olbxl.olbxl2 create mode 100644 t/snippets/olbxl.in create mode 100644 t/snippets/olbxl1.par create mode 100644 t/snippets/olbxl2.par create mode 100644 t/snippets28.t diff --git a/CHANGES.md b/CHANGES.md index ad0f5390..1a9f84b7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,14 @@ ## 2022 11 12.04 + - Added parameter --one-line-block-exclusion-list=s, or -olbxl=s, where + s is a list of block types which should not automatically be turned + into one-line blocks. This implements the issue raised in PR #111. + The list s may include any of the words 'sort map grep eval', or + it may be '*' to indicate all of these. So for example to prevent + multi-line 'eval' blocks from becomming one-line blocks, the command + would be -olbxl='eval'. + - For the -b (--backup-and-modify-in-place) option, the file timestamps are changing (issue rt#145999). First, if there are no formatting changes to an input file, it will keep its original modification time. diff --git a/MANIFEST b/MANIFEST index 8921af76..a31cb2ac 100644 --- a/MANIFEST +++ b/MANIFEST @@ -79,6 +79,7 @@ t/snippets24.t t/snippets25.t t/snippets26.t t/snippets27.t +t/snippets28.t t/snippets3.t t/snippets4.t t/snippets5.t diff --git a/bin/perltidy b/bin/perltidy index 6c70f8db..4e239008 100755 --- a/bin/perltidy +++ b/bin/perltidy @@ -4451,9 +4451,9 @@ checks for and adds any optional terminating semicolon (unless the B<-nasc> option is used) if the block is a code block. The main exception is that perltidy will attempt to form new one-line -blocks following the keywords C, C, and C, because +blocks following the keywords C, C, and C, C, because these code blocks are often small and most clearly displayed in a single -line. +line. This behavior can be controlled with the flag B<--one-line-block-exclusion-list> described below. One-line block rules can conflict with the cuddled-else option. When the cuddled-else option is used, perltidy retains existing one-line @@ -4491,6 +4491,18 @@ the result is This shows that blocks with a single statement become one-line blocks. +=item B<-olbxl=s>, B<--one-line-block-exclusion-list=s> + +As noted above, perltidy will, by default, attempt to create new one-line +blocks for certain block types. This flag allows the user to prevent this +behavior for the block types listed in the string B. The list B may +include any of the words C, C, C, C, or it may be C<*> +to indicate all of these. + +So for example to prevent multi-line 'eval' blocks from becomming one-line +blocks, the command would be B<-olbxl='eval'>. In this case, existing one-line B blocks will remain on one-line if possible, and existing multi-line +B blocks will remain multi-line blocks. + =item B<-olbs=n>, B<--one-line-block-semicolons=n> This flag controls the placement of semicolons at the end of one-line blocks. @@ -4533,10 +4545,8 @@ If the parameter B<-olbn=1> is given, then the line will be left intact if it is a single line in the source, or it will be broken into multiple lines if it is broken in multiple lines in the source. - =back - =head2 Controlling Vertical Alignment Vertical alignment refers to lining up certain symbols in a list of consecutive @@ -5403,22 +5413,22 @@ The following list shows all short parameter names which allow a prefix D anl asbl asc ast asu atc atnl aws b baa baao bar bbao bbb bbc bbs bl bli boa - boc bok bol bom bos bot cblx ce conv cs - csc cscb cscw dac dbc dbs dcbl dcsc ddf dln - dnl dop dp dpro drc dsc dsm dsn dtc dtt - dwic dwls dwrs dws eos f fll fpva frm fs - fso gcs hbc hbcm hbco hbh hbhh hbi hbj hbk - hbm hbn hbp hbpd hbpu hbq hbs hbsc hbv hbw - hent hic hicm hico hih hihh hii hij hik him - hin hip hipd hipu hiq his hisc hiv hiw hsc - html ibc icb icp iob isbc iscl kgb kgbd kgbi - kis lal log lop lp lsl mem nib ohbr okw - ola olc oll olq opr opt osbc osbr otr ple - pod pvl q sac sbc sbl scbb schb scp scsb - sct se sfp sfs skp sob sobb sohb sop sosb - sot ssc st sts t tac tbc toc tp tqw - trp ts tsc tso vbc vc vmll vsc w wfc - wn x xci xlp xs + boc bok bol bom bos bot cblx ce conv cpb + cs csc cscb cscw dac dbc dbs dcbl dcsc ddf + dln dnl dop dp dpro drc dsc dsm dsn dtc + dtt dwic dwls dwrs dws eos f fll fpva frm + fs fso gcs hbc hbcm hbco hbh hbhh hbi hbj + hbk hbm hbn hbp hbpd hbpu hbq hbs hbsc hbv + hbw hent hic hicm hico hih hihh hii hij hik + him hin hip hipd hipu hiq his hisc hiv hiw + hsc html ibc icb icp iob isbc iscl kgb kgbd + kgbi kis lal log lop lp lsl mem nib ohbr + okw ola olc oll olq opr opt osbc osbr otr + ple pod pvl q sac sbc sbl scbb schb scp + scsb sct se sfp sfs skp sob sobb sohb sop + sosb sot ssc st sts t tac tbc toc tp + tqw trp ts tsc tso vbc vc vmll vsc w + wfc wn x xci xlp xs Equivalently, the prefix 'no' or 'no-' on the corresponding long names may be used. diff --git a/dev-bin/perltidy_random_setup.pl b/dev-bin/perltidy_random_setup.pl index 3f1517b2..4cd36a19 100755 --- a/dev-bin/perltidy_random_setup.pl +++ b/dev-bin/perltidy_random_setup.pl @@ -1162,6 +1162,8 @@ EOM 'break-after-labels' => [ 0, 2 ], 'want-trailing-commas' => [ '0', '*', 'm', 'b', 'h', 'i', ' ' ], + 'one-line-block-exclusion-list' => + [ 'sort', 'map', 'grep', 'eval', '*', 'zzyzx' ], 'use-feature' => [ 'class', ' ', 'xyzzy' ], diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index cb0064ef..8fe08edc 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -3325,6 +3325,7 @@ sub generate_options { $add_option->( 'keep-interior-semicolons', 'kis', '!' ); $add_option->( 'one-line-block-semicolons', 'olbs', '=i' ); $add_option->( 'one-line-block-nesting', 'olbn', '=i' ); + $add_option->( 'one-line-block-exclusion-list', 'olbxl', '=s' ); $add_option->( 'break-before-hash-brace', 'bbhb', '=i' ); $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' ); $add_option->( 'break-before-square-bracket', 'bbsb', '=i' ); diff --git a/lib/Perl/Tidy/Formatter.pm b/lib/Perl/Tidy/Formatter.pm index cb00573a..5dcc1ef4 100644 --- a/lib/Perl/Tidy/Formatter.pm +++ b/lib/Perl/Tidy/Formatter.pm @@ -1285,7 +1285,7 @@ sub check_options { initialize_bond_strength_hashes(); # This function must be called early to get hashes with grep initialized - initialize_grep_and_friends( $rOpts->{'grep-alias-list'} ); + initialize_grep_and_friends(); # Make needed regex patterns for matching text. # NOTE: sub_matching_patterns must be made first because later patterns use @@ -1335,12 +1335,6 @@ sub check_options { make_blank_line_pattern(); make_keyword_group_list_pattern(); - # Make initial list of desired one line block types - # They will be modified by 'prepare_cuddled_block_types' - # NOTE: this line must come after is_sort_map_grep_eval is - # initialized in sub 'initialize_grep_and_friends' - %want_one_line_block = %is_sort_map_grep_eval; - prepare_cuddled_block_types(); if ( $rOpts->{'dump-cuddled-block-list'} ) { dump_cuddled_block_list(*STDOUT); @@ -2106,22 +2100,50 @@ EOM use constant ALIGN_GREP_ALIASES => 0; sub initialize_grep_and_friends { - my ($str) = @_; # Initialize or re-initialize hashes with 'grep' and grep aliases. This # must be done after each set of options because new grep aliases may be # used. - # re-initialize the hash ... this is critical! + # re-initialize the hashes ... this is critical! %is_sort_map_grep = (); my @q = qw(sort map grep); @is_sort_map_grep{@q} = (1) x scalar(@q); + my $olbxl = $rOpts->{'one-line-block-exclusion-list'}; + my %is_olb_exclusion_word; + if ( defined($olbxl) ) { + my @list = split_words($olbxl); + if (@list) { + @is_olb_exclusion_word{@list} = (1) x scalar(@list); + } + } + + # Make the list of block types which may be re-formed into one line. + # They will be modified with the grep-alias-list below and + # by sub 'prepare_cuddled_block_types'. + # Note that it is essential to always re-initialize the hash here: + %want_one_line_block = (); + if ( !$is_olb_exclusion_word{'*'} ) { + foreach (qw(sort map grep eval)) { + if ( !$is_olb_exclusion_word{$_} ) { $want_one_line_block{$_} = 1 } + } + } + # Note that any 'grep-alias-list' string has been preprocessed to be a # trimmed, space-separated list. + my $str = $rOpts->{'grep-alias-list'}; my @grep_aliases = split /\s+/, $str; - @{is_sort_map_grep}{@grep_aliases} = (1) x scalar(@grep_aliases); + + if (@grep_aliases) { + + @{is_sort_map_grep}{@grep_aliases} = (1) x scalar(@grep_aliases); + + if ( $want_one_line_block{'grep'} ) { + @{want_one_line_block}{@grep_aliases} = (1) x scalar(@grep_aliases); + } + } ##@q = qw(sort map grep eval); %is_sort_map_grep_eval = %is_sort_map_grep; diff --git a/t/snippets/expect/olbxl.def b/t/snippets/expect/olbxl.def new file mode 100644 index 00000000..c0ba39be --- /dev/null +++ b/t/snippets/expect/olbxl.def @@ -0,0 +1,11 @@ + eval { require Ace }; + + @list = + map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list; + + $color = join( '/', + sort { $color_value{$::a} <=> $color_value{$::b}; } + keys %colors ); + + @sorted = + sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} }; diff --git a/t/snippets/expect/olbxl.olbxl1 b/t/snippets/expect/olbxl.olbxl1 new file mode 100644 index 00000000..05a9b522 --- /dev/null +++ b/t/snippets/expect/olbxl.olbxl1 @@ -0,0 +1,13 @@ + eval { + require Ace; + }; + + @list = + map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list; + + $color = join( '/', + sort { $color_value{$::a} <=> $color_value{$::b}; } + keys %colors ); + + @sorted = + sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} }; diff --git a/t/snippets/expect/olbxl.olbxl2 b/t/snippets/expect/olbxl.olbxl2 new file mode 100644 index 00000000..c2c221f6 --- /dev/null +++ b/t/snippets/expect/olbxl.olbxl2 @@ -0,0 +1,18 @@ + eval { + require Ace; + }; + + @list = map { + $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); + } @list; + + $color = join( + '/', + sort { + $color_value{$::a} <=> $color_value{$::b}; + } keys %colors + ); + + @sorted = sort { + $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} + }; diff --git a/t/snippets/olbxl.in b/t/snippets/olbxl.in new file mode 100644 index 00000000..6a0aa499 --- /dev/null +++ b/t/snippets/olbxl.in @@ -0,0 +1,17 @@ + eval { + require Ace }; + + @list = map { + $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); + } @list; + + $color = join( + '/', + sort { + $color_value{$::a} <=> $color_value{$::b}; + } keys %colors + ); + + @sorted = sort { + $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} + }; diff --git a/t/snippets/olbxl1.par b/t/snippets/olbxl1.par new file mode 100644 index 00000000..5c5bba64 --- /dev/null +++ b/t/snippets/olbxl1.par @@ -0,0 +1 @@ +-olbxl=eval diff --git a/t/snippets/olbxl2.par b/t/snippets/olbxl2.par new file mode 100644 index 00000000..b86843a3 --- /dev/null +++ b/t/snippets/olbxl2.par @@ -0,0 +1 @@ +-olbxl='*' diff --git a/t/snippets/packing_list.txt b/t/snippets/packing_list.txt index 21aead70..f170789b 100644 --- a/t/snippets/packing_list.txt +++ b/t/snippets/packing_list.txt @@ -522,3 +522,6 @@ ../snippets9.t rt98902.def ../snippets9.t rt98902.rt98902 ../snippets9.t rt99961.def +../snippets27.t olbxl.def +../snippets27.t olbxl.olbxl1 +../snippets28.t olbxl.olbxl2 diff --git a/t/snippets27.t b/t/snippets27.t index 0ba723b1..d23e4465 100644 --- a/t/snippets27.t +++ b/t/snippets27.t @@ -18,6 +18,8 @@ #15 cpb.cpb #16 cpb.def #17 rt145706.def +#18 olbxl.def +#19 olbxl.olbxl1 # To locate test #13 you can search for its name or the string '#13' @@ -40,6 +42,7 @@ BEGIN { 'cpb' => "-cpb", 'def' => "", 'dwic' => "-wn -dwic", + 'olbxl1' => "-olbxl=eval", 'rt144979' => "-xci -ce -lp", 'wtc1' => "-wtc=0 -dtc", 'wtc2' => "-wtc=1 -atc", @@ -115,6 +118,26 @@ foreach my $dir ( ); ---------- + 'olbxl' => <<'----------', + eval { + require Ace }; + + @list = map { + $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); + } @list; + + $color = join( + '/', + sort { + $color_value{$::a} <=> $color_value{$::b}; + } keys %colors + ); + + @sorted = sort { + $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} + }; +---------- + 'rt144979' => <<'----------', # part 1 GetOptions( @@ -940,6 +963,44 @@ class +Night with +Bad { my $x = field(50); #17........... }, + + 'olbxl.def' => { + source => "olbxl", + params => "def", + expect => <<'#18...........', + eval { require Ace }; + + @list = + map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list; + + $color = join( '/', + sort { $color_value{$::a} <=> $color_value{$::b}; } + keys %colors ); + + @sorted = + sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} }; +#18........... + }, + + 'olbxl.olbxl1' => { + source => "olbxl", + params => "olbxl1", + expect => <<'#19...........', + eval { + require Ace; + }; + + @list = + map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list; + + $color = join( '/', + sort { $color_value{$::a} <=> $color_value{$::b}; } + keys %colors ); + + @sorted = + sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} }; +#19........... + }, }; my $ntests = 0 + keys %{$rtests}; diff --git a/t/snippets28.t b/t/snippets28.t new file mode 100644 index 00000000..18bbaaf8 --- /dev/null +++ b/t/snippets28.t @@ -0,0 +1,142 @@ +# Created with: ./make_t.pl + +# Contents: +#1 olbxl.olbxl2 + +# To locate test #13 you can search for its name or the string '#13' + +use strict; +use Test::More; +use Carp; +use Perl::Tidy; +my $rparams; +my $rsources; +my $rtests; + +BEGIN { + + ########################################### + # BEGIN SECTION 1: Parameter combinations # + ########################################### + $rparams = { + 'olbxl2' => <<'----------', +-olbxl='*' +---------- + }; + + ############################ + # BEGIN SECTION 2: Sources # + ############################ + $rsources = { + + 'olbxl' => <<'----------', + eval { + require Ace }; + + @list = map { + $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); + } @list; + + $color = join( + '/', + sort { + $color_value{$::a} <=> $color_value{$::b}; + } keys %colors + ); + + @sorted = sort { + $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} + }; +---------- + }; + + #################################### + # BEGIN SECTION 3: Expected output # + #################################### + $rtests = { + + 'olbxl.olbxl2' => { + source => "olbxl", + params => "olbxl2", + expect => <<'#1...........', + eval { + require Ace; + }; + + @list = map { + $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); + } @list; + + $color = join( + '/', + sort { + $color_value{$::a} <=> $color_value{$::b}; + } keys %colors + ); + + @sorted = sort { + $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} + }; +#1........... + }, + }; + + my $ntests = 0 + keys %{$rtests}; + plan tests => $ntests; +} + +############### +# EXECUTE TESTS +############### + +foreach my $key ( sort keys %{$rtests} ) { + my $output; + my $sname = $rtests->{$key}->{source}; + my $expect = $rtests->{$key}->{expect}; + my $pname = $rtests->{$key}->{params}; + my $source = $rsources->{$sname}; + my $params = defined($pname) ? $rparams->{$pname} : ""; + my $stderr_string; + my $errorfile_string; + my $err = Perl::Tidy::perltidy( + source => \$source, + destination => \$output, + perltidyrc => \$params, + argv => '', # for safety; hide any ARGV from perltidy + stderr => \$stderr_string, + errorfile => \$errorfile_string, # not used when -se flag is set + ); + if ( $err || $stderr_string || $errorfile_string ) { + print STDERR "Error output received for test '$key'\n"; + if ($err) { + print STDERR "An error flag '$err' was returned\n"; + ok( !$err ); + } + if ($stderr_string) { + print STDERR "---------------------\n"; + print STDERR "<>\n$stderr_string\n"; + print STDERR "---------------------\n"; + ok( !$stderr_string ); + } + if ($errorfile_string) { + print STDERR "---------------------\n"; + print STDERR "<<.ERR file>>\n$errorfile_string\n"; + print STDERR "---------------------\n"; + ok( !$errorfile_string ); + } + } + else { + if ( !is( $output, $expect, $key ) ) { + my $leno = length($output); + my $lene = length($expect); + if ( $leno == $lene ) { + print STDERR +"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n"; + } + else { + print STDERR +"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n"; + } + } + } +} -- 2.39.5