From c3023c07aa07f73b5e7672c871b62dd60405e0c2 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Thu, 8 Feb 2024 08:22:28 -0800 Subject: [PATCH] add interbracket arrow control options --- bin/perltidy | 153 +++++++++- dev-bin/perltidy_random_setup.pl | 2 + lib/Perl/Tidy.pm | 8 + lib/Perl/Tidy/Formatter.pm | 487 +++++++++++++++++++++++++++++-- t/snippets/dia.in | 12 + t/snippets/dia1.out | 9 + t/snippets/dia1.par | 1 + t/snippets/dia2.par | 1 + t/snippets/dia3.out | 8 + t/snippets/dia3.par | 2 + t/snippets/expect/dia.def | 12 + t/snippets/expect/dia.dia1 | 12 + t/snippets/expect/dia.dia2 | 12 + t/snippets/expect/dia.dia3 | 12 + t/snippets/packing_list.txt | 4 + t/snippets29.t | 103 ++++++- 16 files changed, 816 insertions(+), 22 deletions(-) create mode 100644 t/snippets/dia.in create mode 100644 t/snippets/dia1.out create mode 100644 t/snippets/dia1.par create mode 100644 t/snippets/dia2.par create mode 100644 t/snippets/dia3.out create mode 100644 t/snippets/dia3.par create mode 100644 t/snippets/expect/dia.def create mode 100644 t/snippets/expect/dia.dia1 create mode 100644 t/snippets/expect/dia.dia2 create mode 100644 t/snippets/expect/dia.dia3 diff --git a/bin/perltidy b/bin/perltidy index 9cc4b9dd..278b3f0e 100755 --- a/bin/perltidy +++ b/bin/perltidy @@ -3901,6 +3901,155 @@ commas are removed. =back +=head2 Adding and Deleting Interbracket Arrows + +In the following expression, the arrow operator '->' between the closing and +opening brackets of hash keys and array indexes are optional: + + return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; + +These will be called B here, for lack of a better term. +Perltidy will not change them by default, but they can be added or removed with +the following parameters. + +=over 4 + +=item B<-dia>, B<--delete-interbracket-arrows> + +This parameter deletes interbracket arrows. Applied to the above example we have + + # perltidy -dia + return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; + +By default this applies to all interbracket arrows, but selective deletion is possible +with controls described below. + +=item B<-aia>, B<--add-interbracket-arrows> + +This parameter adds interbracket arrows. Applied to the line of code above, we +get back the original line. + + # perltidy -aia + return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; + +Selective changes can be made with controls described below. + +=item B<-ias=s>, B<--interbracket-arrow-style=s> + +By default the B<-add-> and B<-delete-> parameters apply to all interbracket +arrows. + +An optional style can be specified with this parameter string B. In that +case the parameters B<--add-interbracket-arrows> and +B<--delete-interbracket-arrows> only apply where they would bring the +formatting into agreement with the specified style. They may both be used in a +single run if a mixed style is specified since there is no conflict. + +The style string B gives a graphical description of the desired style. It +lists up to four possible pairs of bracket types with an optional "cuddled" +arrow. For example: + + -ias='][ }->{' + +This means no arrows are wanted between '][' but arrows should be between '}{'. +And it means that the unlisted pairs ']{' and '}[' should remain unchanged, +either with or without arrows. + +In this particular example, if the parameter B<--delete-interbracket-arrows> is +used, then only arrows like ']->[' will be deleted, since they +are the only ones which disagree with the style. + +And likewise, if B<--add-interbracket-arrows> is used, then arrows will +only be inserted between brackets like '}{' to bring the formatting into +conformity with the style in this example. + +Spaces in the string B are optional. They are ignored when the +expression is parsed. + +The style corresponding to all possible arrows is + + -ias=']->[ ]->{ }->[ }->{' + +For convenience, this may also be requested with B<-ias=1> or B<-ias='*'>. + +The style corresponding to no interbracket arrows is + + -ias='] [ ] { } [ } {' + +which may also be requested with B<-ias=0>. + +=item B<-wia>, B<--warn-interbracket-arrows> + +If this parameter is set, then a message is written to the error file in the +following cases: + +=over 4 + +=item * + +If an arrow is added or deleted by an add or delete command. + +=item * + +If a style is defined and an arrow would have been added or deleted if requested. +So for example, the command + + perltidy -wia -ias='][' + +will show where a file has arrows like ]->[' since they do not match the style, +but no changes will be made because the delete command B<-dia> has not been +given. And + + perltidy -wia -ias=0 + +will warn if any arrows exist, since the flag -ias=0 means that no arrows +are wanted. + +=back + +=item B<-iac=n>, B<--interbracket-arrow-complexity=n> + +This parameter makes it possible to skip adding or deleting arrows following a +container which is complex in some sense. Three levels of complexity can be +specified with the integer B, as follows: + + n=0 the contents of the left container must be a single thing (token) + n=1 the left container must not contain other containers [DEFAULT] + n=2 the left container may contain anything + +Some examples: + + # Container complexity + {'commandline'} 0 single token OK by default + { $type . $name } 1 multiple tokens OK by default + [ $plot{'x-axis'} - 1 ] 2 contains a container SKIPPED by default + +So, with the default complexity level of 1, an arrow could be added or deleted +following the first two of these containers but not the third. + +=back + +B when working with these parameters are: + +=over 4 + +=item * + +There are no known bugs, but this is a relatively new feature. So please +carefully check file differences and run tests when interbracket arrows are +added or removed. + +=item * + +For some unusual spacing parameters, it could take an extra iteration for +the spaces between brackets to reach their final state after arrows are +added or deleted. + +=item * + +Any comments between brackets will prevent the adding and deleting of arrows. + +=back =head2 Missing Else Blocks @@ -4301,10 +4450,10 @@ for the previous item B<-blbs=n>. =item B<-bbs>, B<--blanks-before-subs> For compatibility with previous versions, B<-bbs> or B<--blanks-before-subs> -is equivalent to F<-blbp=1> and F<-blbs=1>. +is equivalent to B<-blbp=1> and B<-blbs=1>. Likewise, B<-nbbs> or B<--noblanks-before-subs> -is equivalent to F<-blbp=0> and F<-blbs=0>. +is equivalent to B<-blbp=0> and B<-blbs=0>. =item B<-bbb>, B<--blanks-before-blocks> diff --git a/dev-bin/perltidy_random_setup.pl b/dev-bin/perltidy_random_setup.pl index 8afb7902..556cbb23 100755 --- a/dev-bin/perltidy_random_setup.pl +++ b/dev-bin/perltidy_random_setup.pl @@ -860,6 +860,8 @@ EOM 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], 'extended-block-tightness-list' => [ 'k', 't', 'kt' ], + 'interbracket-arrow-style' => [ ']{', ']->{', '][', ']->[', '}[', '}->[', '}{', '}->{'], + 'warn-variable-types' => [ '0', '1' ], 'space-backslash-quote' => [ 0, 2 ], diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index 6ec7010b..9a8f2cde 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -3714,6 +3714,12 @@ sub generate_options { $add_option->( 'want-call-parens', 'wcp', '=s' ); $add_option->( 'nowant-call-parens', 'nwcp', '=s' ); + $add_option->( 'add-interbracket-arrows', 'aia', '!' ); + $add_option->( 'delete-interbracket-arrows', 'dia', '!' ); + $add_option->( 'warn-interbracket-arrows', 'wia', '!' ); + $add_option->( 'interbracket-arrow-style', 'ias', '=s' ); + $add_option->( 'interbracket-arrow-complexity', 'iac', '=i' ); + ######################################## $category = 13; # Debugging ######################################## @@ -3838,6 +3844,7 @@ sub generate_options { indent-block-comments indent-columns=4 integer-range-check=2 + interbracket-arrow-complexity=1 iterations=1 keep-old-blank-lines=1 keyword-paren-inner-tightness=1 @@ -3994,6 +4001,7 @@ sub generate_options { 'entab-leading-whitespace' => [ 0, undef ], 'fixed-position-side-comment' => [ 0, undef ], 'indent-columns' => [ 0, undef ], + 'interbracket-arrow-complexity' => [ 0, 2 ], 'integer-range-check' => [ 0, 3 ], 'iterations' => [ 0, undef ], 'keep-old-blank-lines' => [ 0, 2 ], diff --git a/lib/Perl/Tidy/Formatter.pm b/lib/Perl/Tidy/Formatter.pm index 8bd41e7e..f9031d5d 100644 --- a/lib/Perl/Tidy/Formatter.pm +++ b/lib/Perl/Tidy/Formatter.pm @@ -377,6 +377,9 @@ my ( # INITIALIZER: sub initialize_trailing_comma_rules %trailing_comma_rules, + # INITIALIZER: sub initialize_interbracket_arrow_style + %interbracket_arrow_style, + # INITIALIZER: sub initialize_call_paren_style %call_paren_style, @@ -620,6 +623,7 @@ BEGIN { _no_vertical_tightness_flags_ => $i++, _last_vt_type_ => $i++, + _rwant_arrow_before_seqno_ => $i++, _LAST_SELF_INDEX_ => $i - 1, }; @@ -1095,6 +1099,7 @@ sub new { $self->[_no_vertical_tightness_flags_] = 0; $self->[_last_vt_type_] = 0; + $self->[_rwant_arrow_before_seqno_] = {}; $self->[_save_logfile_] = defined($logger_object) && $logger_object->get_save_logfile(); @@ -1525,6 +1530,8 @@ EOM initialize_trailing_comma_rules(); # after 'initialize_line_length_vars' + initialize_interbracket_arrow_style(); + initialize_weld_nested_exclusion_rules(); initialize_weld_fat_comma_rules(); @@ -2840,6 +2847,119 @@ EOM return; } ## end sub initialize_trailing_comma_rules +sub initialize_interbracket_arrow_style { + + # Setup hash for desired arrow style + %interbracket_arrow_style = (); + + # and check other parameters for conflicts + my $name_add = 'add-interbracket-arrows'; + my $name_delete = 'delete-interbracket-arrows'; + my $name_warn = 'warn-interbracket-arrows'; + my $name_style = 'interbracket-arrow-style'; + + my $opt_add = $rOpts->{$name_add}; + my $opt_delete = $rOpts->{$name_delete}; + my $opt_warn = $rOpts->{$name_warn}; + my $opt_style = $rOpts->{$name_style}; + + if ( $opt_add && $opt_delete && !$opt_style ) { + Die(<{ or }->[ or }{ + # The two bracket characters are the hash key and the hash value + # is 1 for an arrow and -1 for no arrow. + + # $ch1 will hold most recent closing bracket + # $ch2 will hold a '->' if seen + my %rule_hash; + my ( $ch1, $ch2 ); + my $err_msg; + while (1) { + if ( + $opt_style =~ m{ + \G + (\s+) # 1. whitespace + | ([\}\]]) # 2. closing bracket + | (->) # 3. arrow + | ([\[\{]) # 4. opening bracket + | (.*) # 5. something else, error + + }gcx + ) + { + if ($1) { next } + if ($2) { + if ( !$ch1 ) { $ch1 = $2 } + else { $err_msg = "unexpected '$2'"; last } + next; + } + if ($3) { + if ($ch1) { $ch2 = $3 } + else { $err_msg = "unexpected '$3'"; last } + next; + } + if ($4) { + if ( $ch1 || $ch2 ) { + my $key = $ch1 . $4; + if ( !defined( $rule_hash{$key} ) ) { + $rule_hash{$key} = $ch2 ? 1 : -1; + } + else { $err_msg = "multiple copies for '$key'"; last; } + $ch1 = $ch2 = undef; + } + else { $err_msg = "unexpected '$4'"; last } + next; + } + if ($5) { + my $bad = $5; + if ( length($bad) > 10 ) { + $bad = substr( $bad, 0, 10 ) . '...'; + } + $err_msg = "confused at: '$bad'\n"; + last; + } + } + + # that's all.. + else { + last; + } + } + + if ($err_msg) { + my $pos = pos($opt_style); # could display location + Die("Error parsing --$name_style: $err_msg\n"); + } + + # Copy the rule hash, converting braces to token types + foreach my $key ( keys %rule_hash ) { + my $key_fix = $key; + $key_fix =~ tr/{}/LR/; + $interbracket_arrow_style{$key_fix} = $rule_hash{$key}; + } + + return; +} ## end sub initialize_interbracket_arrow_style + sub initialize_whitespace_hashes { # This is called once before formatting begins to initialize these global @@ -6409,6 +6529,8 @@ EOM # Verify that the line hash does not have any unknown keys. $self->check_line_hashes() if (DEVEL_MODE); + $self->interbracket_arrow_check(); + { # Make a pass through all tokens, adding or deleting any whitespace as # required. Also make any other changes, such as adding semicolons. @@ -10094,6 +10216,245 @@ sub find_non_indenting_braces { return; } ## end sub find_non_indenting_braces +sub interbracket_arrow_check { + + my ($self) = @_; + + # Implement the options to add or delete optional arrows between brackets + my $rOpts_add = $rOpts->{'add-interbracket-arrows'}; + my $rOpts_del = $rOpts->{'delete-interbracket-arrows'}; + my $rOpts_warn = $rOpts->{'warn-interbracket-arrows'}; + my $rOpts_warn_and_style = $rOpts_warn && %interbracket_arrow_style; + + return + unless ( $rOpts_add || $rOpts_del || $rOpts_warn_and_style ); + + # Method: + # Loop over all opening brackets and look back for a possible arrow + # and closing bracket. If the location between brackets allows an + # optional arrow, then see if one should be added or deleted. + # Set a flag for sub respace_tokens which will make the change. + + # Deleting examples: + # $variables->{'a'}->{'b'} $variables->{'a'}{'b'} + # $variables{'a'}->{'b'} $variables{'a'}->{'b'} + # $items[1]->[4]->{red} $items[1][4]{red} + # $items{blue}->[4]->{red} $items{blue}[4]{red} + + # Adding examples: + # $variables->{'a'}{'b'} $variables->{'a'}->{'b'} + # $variables{'a'}->{'b'} $variables{'a'}->{'b'} + # $items[1][4]{red} $items[1]->[4]->{red} + # $items{blue}[4]{red} $items{blue}->[4]->{red} + + # bracket chain ] { } [ ] [ + # | | | + # arrow ok? ? ? ? + + # The following chain rule is used to locate optional arrow locations: + # Scanning left to right: + # -arrows can begin once we see an opening token preceded by: + # - an ->, or + # - a simple scalar identifier like '$href{' or '$aryref[' + # - Once arrows begin they may continue to the end of the bracket chain. + + # To illustrate why we just can't add and remove arrows between + # ']' and '[', for example, consider + # my $v1 = [ 1, 2, [ 3, 4 ] ]->[2]->[0]; # ok + # my $v2 = [ 1, 2, [ 3, 4 ] ]->[2][0]; # ok, keep required arrow + # my $v3 = [ 1, 2, [ 3, 4 ] ][2][0]; # Error + + # We will maintain the flag for this check in the following hash: + my %trailing_arrow_ok_by_seqno; + + my $rLL = $self->[_rLL_]; + return unless ( defined($rLL) && @{$rLL} ); + my $K_opening_container = $self->[_K_opening_container_]; + my $K_closing_container = $self->[_K_closing_container_]; + + my @lno_del; + my @lno_add; + + my $warn = sub { + + # write a warning on changes made or needed if -wia is set + my ( $rlno_list, $first_word ) = @_; + my $str; + my $num_changes = @{$rlno_list}; + my @unique_lno = do { + my %seen; + grep { !$seen{$_}++ } @{$rlno_list}; + }; + my $num_lno = @unique_lno; + my $num_lim = 10; + if ( $num_lno <= $num_lim ) { + $str = join( SPACE, @unique_lno ); + } + else { + $str = join( SPACE, @unique_lno[ 0 .. $num_lim - 1 ] ) . " ..."; + } + my $ess1 = $num_changes == 1 ? EMPTY_STRING : 's'; + my $ess2 = $num_lno == 1 ? EMPTY_STRING : 's'; + my $msg = "$first_word $num_changes '->'$ess1 at line$ess2 $str\n"; + warning($msg); + return; + }; + + # Complexity control flag: + # =0 left container must just contain a single token + # =1 left container must not contain other containers [DEFAULT] + # =2 no complexity constraints + my $complexity = $rOpts->{'interbracket-arrow-complexity'}; + if ( !defined($complexity) ) { $complexity = 1 } + + #-------------------------------------------- + # Main loop over all opening container tokens + #-------------------------------------------- + foreach my $seqno ( sort { $a <=> $b } keys %{$K_opening_container} ) { + + # We just want opening token types 'L" or '[' + # Note: the tokenizer marks hash braces '{' and '}' as 'L' and 'R' + # but we have to be careful because small block braces can also + # get marked 'L' and 'R' for formatting purposes. + my $Ko = $K_opening_container->{$seqno}; + my $type = $rLL->[$Ko]->[_TYPE_]; + next if ( $type ne 'L' && $type ne '[' ); + + # Now find the previous nonblank token + my $K_m = $Ko - 1; + next if ( $K_m < 0 ); + my $type_m = $rLL->[$K_m]->[_TYPE_]; + if ( $type_m eq 'b' && $K_m > 0 ) { + $K_m -= 1; + $type_m = $rLL->[$K_m]->[_TYPE_]; + } + + # These vars will hold the previous closing bracket, if any; + # initialized to this token but will be moved if it is an arrow + my $K_mm = $K_m; + my $type_mm = $type_m; + + # Decide if an inter-bracket arrow could follow the closing token + # of this container.. + + # preceded by scalar identifier (such as '$array[' or '$hash{') ? + if ( $type_m eq 'i' || $type_m eq 'Z' ) { + + my $token_m = $rLL->[$K_m]->[_TOKEN_]; + if ( substr( $token_m, 0, 1 ) eq '$' ) { + + # arrows can follow the CLOSING bracket of this container + $trailing_arrow_ok_by_seqno{$seqno} = 1; + } + } + + # or a closing bracket or hash brace + elsif ( $type_m eq ']' || $type_m eq 'R' ) { + my $seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_]; + + # propagate the arrow status flag + $trailing_arrow_ok_by_seqno{$seqno} = + $trailing_arrow_ok_by_seqno{$seqno_m}; + } + + # check a pointer and if found, back up one more token + elsif ( $type_m eq '->' ) { + + # arrows can follow the CLOSING bracket of this container + $trailing_arrow_ok_by_seqno{$seqno} = 1; + + # back up one token before the arrow + $K_mm = $K_m - 1; + next if ( $K_mm <= 0 ); + $type_mm = $rLL->[$K_mm]->[_TYPE_]; + if ( $type_mm eq 'b' && $K_mm > 0 ) { + $K_mm -= 1; + $type_mm = $rLL->[$K_mm]->[_TYPE_]; + } + } + else { + # something else + } + + # now check for a preceding closing bracket or hash brace + next if ( $type_mm ne ']' && $type_mm ne 'R' ); + my $seqno_mm = $rLL->[$K_mm]->[_TYPE_SEQUENCE_]; + next if ( !$seqno_mm ); + + $trailing_arrow_ok_by_seqno{$seqno} = 1; + + # We are between brackets with these two or three sequential tokens, + # indexes _mm and _m are identical if there is no arrow. + # $type_mm $type_m $type + # R or ] ->? [ or L + + # Can an inter-bracket arrow be here? + next unless ( $trailing_arrow_ok_by_seqno{$seqno_mm} ); + + # If the user defined a style, only continue if this requires + # adding or deleting an '->' to match the style + if (%interbracket_arrow_style) { + my $style = $interbracket_arrow_style{ $type_mm . $type }; + next if ( !$style ); + next + if ( $style == -1 && $type_m ne '->' + || $style == 1 && $type_m eq '->' ); + } + + next if ( $type_m eq '->' && !$rOpts_del && !$rOpts_warn ); + next if ( $type_m ne '->' && !$rOpts_add && !$rOpts_warn ); + + # Do not continue if the left container is too complex.. + # complexity flag = 0: only one nonblank token in the brackets + if ( !$complexity ) { + my $count = 0; + my $Ko_mm = $K_opening_container->{$seqno_mm}; + next unless defined($Ko_mm); + foreach my $KK ( $Ko_mm + 1 .. $K_mm - 2 ) { + next if ( $rLL->[$KK]->[_TYPE_] eq 'b' ); + $count++; + last if ( $count > 1 ); + } + next if ( $count > 1 ); + } + + # complexity flag = 1: no interior container tokens + elsif ( $complexity == 1 ) { + + if ( $seqno_mm ne $seqno - 1 ) { + next; + } + } + else { + # complexity flag >1 => no restriction + } + + # set a flag telling sub respace_tokens to actually make the change + my $lno = 1 + $rLL->[$Ko]->[_LINE_INDEX_]; + if ( $type_m eq '->' ) { + if ($rOpts_del) { + $self->[_rwant_arrow_before_seqno_]->{$seqno} = -1; + } + if ( $rOpts_del || $rOpts_warn_and_style ) { push @lno_del, $lno } + } + else { + if ($rOpts_add) { + $self->[_rwant_arrow_before_seqno_]->{$seqno} = 1; + } + if ( $rOpts_add || $rOpts_warn_and_style ) { push @lno_add, $lno } + } + } + + if ($rOpts_warn) { + my $wia = '--warn-interbracket-arrows report:'; + $warn->( \@lno_add, $rOpts_add ? "$wia added" : "$wia: missing" ) + if (@lno_add); + $warn->( \@lno_del, $rOpts_del ? "$wia deleted " : "$wia: unwanted " ) + if (@lno_del); + } + return; +} ## end sub interbracket_arrow_check + sub delete_side_comments { my ( $self, $rix_side_comments ) = @_; @@ -10296,6 +10657,7 @@ my $roverride_cab3; my $rparent_of_seqno; my $rtype_count_by_seqno; my $rblock_type_of_seqno; +my $rwant_arrow_before_seqno; my $K_opening_container; my $K_closing_container; @@ -10353,6 +10715,7 @@ sub initialize_respace_tokens_closure { $rparent_of_seqno = $self->[_rparent_of_seqno_]; $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_]; $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_]; + $rwant_arrow_before_seqno = $self->[_rwant_arrow_before_seqno_]; %K_first_here_doc_by_seqno = (); @@ -10729,6 +11092,21 @@ sub respace_tokens_inner_loop { } } } + + # Opening container + else { + my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_]; + if ( $rwant_arrow_before_seqno->{$type_sequence} ) { + + # +1 means add -1 means delete previous arrow + if ( $rwant_arrow_before_seqno->{$type_sequence} > 0 ) { + $self->add_interbracket_arrow(); + } + else { + $self->delete_interbracket_arrow(); + } + } + } } # Modify certain tokens here for whitespace @@ -11888,13 +12266,55 @@ sub delete_weld_interfering_comma { } ## end sub delete_weld_interfering_comma +sub add_interbracket_arrow { + my ($self) = @_; + + # Add a new '->' after the last token on the stack + my $Kp = $self->K_previous_nonblank( undef, $rLL_new ); + return unless ( defined($Kp) ); + + # verify that we are adding after a } or ] + my $type_p = $rLL_new->[$Kp]->[_TYPE_]; + if ( $type_p ne 'R' && $type_p ne ']' ) { + DEVEL_MODE && Fault("trying to store new arrow after type $type_p"); + return; + } + + $self->store_new_token( '->', '->', $Kp ); + + return; +} ## end sub add_interbracket_arrow + +sub delete_interbracket_arrow { + my ($self) = @_; + + # Delete the last nonblank token on the stack which is an '->' + my $Kp = $self->K_previous_nonblank( undef, $rLL_new ); + return unless ( defined($Kp) ); + + # verify that we are deleting an '->' + my $type_p = $rLL_new->[$Kp]->[_TYPE_]; + if ( $type_p ne '->' ) { + DEVEL_MODE && Fault("trying to delete arrow but type $type_p"); + return; + } + + $self->unstore_last_nonblank_token( '->', -1 ); + + return; +} ## end sub delete_interbracket_arrow + sub unstore_last_nonblank_token { - my ( $self, $type ) = @_; + my ( $self, $type, $want_space ) = @_; # remove the most recent nonblank token from the new token list # Input parameter: # $type = type to be removed (for safety check) + # $want_space = telling if a space should remain + # 1 => always + # 0 or undef => only if there was one (used for ',') + # -1 => never (used for '->') # Returns true if success # false if error @@ -11910,8 +12330,12 @@ sub unstore_last_nonblank_token { return; } + if ( !defined($want_space) ) { $want_space = 0 } + my ( $rcomma, $rblank ); + # Note: orignally just for ',' but now also for '->' + # case 1: pop comma from top of stack if ( $rLL_new->[-1]->[_TYPE_] eq $type ) { $rcomma = pop @{$rLL_new}; @@ -11939,15 +12363,34 @@ sub unstore_last_nonblank_token { # $last_nonblank_code_type alone. Then sub store_token will produce # the correct result. This is simpler and is done here. - # Now add a blank space after the comma if appropriate. - # Some unusual spacing controls might need another iteration to - # reach a final state. - if ( $rLL_new->[-1]->[_TYPE_] ne 'b' ) { - if ( defined($rblank) ) { - $rblank->[_CUMULATIVE_LENGTH_] -= 1; # fix for deleted comma - push @{$rLL_new}, $rblank; + # remove a remaining blank if requested + if ( $rLL_new->[-1]->[_TYPE_] eq 'b' ) { + + # current method for deleted '->' + if ( $want_space == -1 ) { + pop @{$rLL_new}; + } + } + + # add a blank if requested + else { + if ( $want_space == 1 ) { + $self->store_token(); + } + elsif ( !$want_space ) { + + # add one if there was one (current method for commas) + if ( defined($rblank) ) { + my $len = length($type); + $rblank->[_CUMULATIVE_LENGTH_] -= $len; # fix for deleted comma + push @{$rLL_new}, $rblank; + } + } + else { + # want_space=-1 so do not add a blank } } + return 1; } ## end sub unstore_last_nonblank_token @@ -12210,15 +12653,11 @@ sub store_new_token { # $token = the token text # $Kp = index of the previous token in the new list, $rLL_new - # Returns: - # $Knew = index in $rLL_new of the new token - # This operation is a little tricky because we are creating a new token and # we have to take care to follow the requested whitespace rules. my $Ktop = @{$rLL_new} - 1; my $top_is_space = $Ktop >= 0 && $rLL_new->[$Ktop]->[_TYPE_] eq 'b'; - my $Knew; if ( $top_is_space && $want_left_space{$type} == WS_NO ) { #---------------------------------------------------- @@ -12230,10 +12669,9 @@ sub store_new_token { my $rcopy = copy_token_as_type( $rLL_new->[$Ktop], 'b', SPACE ); - $Knew = $Ktop; - $rLL_new->[$Knew]->[_TOKEN_] = $token; - $rLL_new->[$Knew]->[_TOKEN_LENGTH_] = length($token); - $rLL_new->[$Knew]->[_TYPE_] = $type; + $rLL_new->[$Ktop]->[_TOKEN_] = $token; + $rLL_new->[$Ktop]->[_TOKEN_LENGTH_] = length($token); + $rLL_new->[$Ktop]->[_TYPE_] = $type; # NOTE: we are changing the output stack without updating variables # $last_nonblank_code_type, etc. Future needs might require that @@ -12248,7 +12686,9 @@ sub store_new_token { } # Then store a new blank - $self->store_token($rcopy); + if ( $want_right_space{$type} == WS_YES ) { + $self->store_token($rcopy); + } } else { @@ -12273,12 +12713,21 @@ sub store_new_token { $rLL_new->[$Ktop]->[_LINE_INDEX_] = $new_top_ix; } } + else { + if ( $want_left_space{$type} == WS_YES ) { + $self->store_token(); + } + } my $rcopy = copy_token_as_type( $rLL_new->[$Kp], $type, $token ); $self->store_token($rcopy); - $Knew = @{$rLL_new} - 1; + + if ( $want_right_space{$type} == WS_YES ) { + $self->store_token(); + } } - return $Knew; + + return; } ## end sub store_new_token sub check_Q { diff --git a/t/snippets/dia.in b/t/snippets/dia.in new file mode 100644 index 00000000..899e0869 --- /dev/null +++ b/t/snippets/dia.in @@ -0,0 +1,12 @@ +return $this->{'content'}[$row][$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; diff --git a/t/snippets/dia1.out b/t/snippets/dia1.out new file mode 100644 index 00000000..4f8ce08c --- /dev/null +++ b/t/snippets/dia1.out @@ -0,0 +1,9 @@ +return $this->{'content'}[$row][$col]; +return $this->{'content'}[$row][$col]; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ]->[1][0]{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; + diff --git a/t/snippets/dia1.par b/t/snippets/dia1.par new file mode 100644 index 00000000..dbe6754f --- /dev/null +++ b/t/snippets/dia1.par @@ -0,0 +1 @@ +-dia diff --git a/t/snippets/dia2.par b/t/snippets/dia2.par new file mode 100644 index 00000000..b6e67349 --- /dev/null +++ b/t/snippets/dia2.par @@ -0,0 +1 @@ +-aia diff --git a/t/snippets/dia3.out b/t/snippets/dia3.out new file mode 100644 index 00000000..f204987a --- /dev/null +++ b/t/snippets/dia3.out @@ -0,0 +1,8 @@ +return $this->{'content'}->[$row][$col]; +return $this->{'content'}->[$row][$col]; +return $self->{'commandline'}{'arg_list'}->[0][0]->{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}->[0][0]->{'hostgroups'}; +$names->{'strings'}->[ $featureEntry->{'settings'}{$setting} ][1][0]->{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}{$setting} ][1][0]->{0}; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; diff --git a/t/snippets/dia3.par b/t/snippets/dia3.par new file mode 100644 index 00000000..a1607392 --- /dev/null +++ b/t/snippets/dia3.par @@ -0,0 +1,2 @@ +-dia -aia -iac=2 +-ias='][ }->{ ]->{ }->[' diff --git a/t/snippets/expect/dia.def b/t/snippets/expect/dia.def new file mode 100644 index 00000000..899e0869 --- /dev/null +++ b/t/snippets/expect/dia.def @@ -0,0 +1,12 @@ +return $this->{'content'}[$row][$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; diff --git a/t/snippets/expect/dia.dia1 b/t/snippets/expect/dia.dia1 new file mode 100644 index 00000000..e734c252 --- /dev/null +++ b/t/snippets/expect/dia.dia1 @@ -0,0 +1,12 @@ +return $this->{'content'}[$row][$col]; +return $this->{'content'}[$row][$col]; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ]->[1][0]{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; diff --git a/t/snippets/expect/dia.dia2 b/t/snippets/expect/dia.dia2 new file mode 100644 index 00000000..8bdb594d --- /dev/null +++ b/t/snippets/expect/dia.dia2 @@ -0,0 +1,12 @@ +return $this->{'content'}->[$row]->[$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1]->[0]->{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}->{$subname}->{$pack}->{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i]->[0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}->{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; diff --git a/t/snippets/expect/dia.dia3 b/t/snippets/expect/dia.dia3 new file mode 100644 index 00000000..8096fd18 --- /dev/null +++ b/t/snippets/expect/dia.dia3 @@ -0,0 +1,12 @@ +return $this->{'content'}->[$row][$col]; +return $this->{'content'}->[$row][$col]; +return $self->{'commandline'}->{'arg_list'}->[0][0]->{'hostgroups'}; +return $self->{'commandline'}->{'arg_list'}->[0][0]->{'hostgroups'}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1][0]->{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1][0]->{0}; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; +@{ $table{$file}->{$subname}->{$pack}->{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }->{ $subf[$i][0] }->{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}->{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; diff --git a/t/snippets/packing_list.txt b/t/snippets/packing_list.txt index 4c76eba0..0d43932a 100644 --- a/t/snippets/packing_list.txt +++ b/t/snippets/packing_list.txt @@ -407,6 +407,10 @@ ../snippets29.t vsn.def ../snippets29.t vsn.vsn1 ../snippets29.t vsn.vsn2 +../snippets29.t dia.def +../snippets29.t dia.dia1 +../snippets29.t dia.dia2 +../snippets29.t dia.dia3 ../snippets3.t ce_wn1.ce_wn ../snippets3.t ce_wn1.def ../snippets3.t colin.colin diff --git a/t/snippets29.t b/t/snippets29.t index 0f1c96f1..e0676336 100644 --- a/t/snippets29.t +++ b/t/snippets29.t @@ -5,6 +5,10 @@ #2 vsn.def #3 vsn.vsn1 #4 vsn.vsn2 +#5 dia.def +#6 dia.dia1 +#7 dia.dia2 +#8 dia.dia3 # To locate test #13 you can search for its name or the string '#13' @@ -22,7 +26,13 @@ BEGIN { # BEGIN SECTION 1: Parameter combinations # ########################################### $rparams = { - 'def' => "", + 'def' => "", + 'dia1' => "-dia", + 'dia2' => "-aia", + 'dia3' => <<'----------', +-dia -aia -iac=2 +-ias='][ }->{ ]->{ }->[' +---------- 'git125' => "-ssp=0", 'vsn1' => <<'----------', -vsn @@ -40,6 +50,21 @@ BEGIN { ############################ $rsources = { + 'dia' => <<'----------', +return $this->{'content'}[$row][$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; +---------- + 'git125' => <<'----------', sub Add ( $x, $y ); sub Sub( $x, $y ); @@ -131,6 +156,82 @@ $s->drawLine( -35, 0 ); $s->drawLine( 0, -10 ); #4........... }, + + 'dia.def' => { + source => "dia", + params => "def", + expect => <<'#5...........', +return $this->{'content'}[$row][$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; +#5........... + }, + + 'dia.dia1' => { + source => "dia", + params => "dia1", + expect => <<'#6...........', +return $this->{'content'}[$row][$col]; +return $this->{'content'}[$row][$col]; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ][1][0]{0}; +$names->{'strings'}[ $featureEntry->{'settings'}{$setting} ]->[1][0]{0}; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}[ $last_drawn_row + 1 ][$col]; +@{ $table{$file}{$subname}{$pack}{ $type . $name }{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i][0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; +#6........... + }, + + 'dia.dia2' => { + source => "dia", + params => "dia2", + expect => <<'#7...........', +return $this->{'content'}->[$row]->[$col]; +return $this->{'content'}->[$row]->[$col]; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1]->[0]->{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ]->[1]->[0]->{0}; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ]->[$col]; +@{ $table{$file}->{$subname}->{$pack}->{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }{ $subf[$i]->[0] }{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}->{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; +#7........... + }, + + 'dia.dia3' => { + source => "dia", + params => "dia3", + expect => <<'#8...........', +return $this->{'content'}->[$row][$col]; +return $this->{'content'}->[$row][$col]; +return $self->{'commandline'}->{'arg_list'}->[0][0]->{'hostgroups'}; +return $self->{'commandline'}->{'arg_list'}->[0][0]->{'hostgroups'}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1][0]->{0}; +$names->{'strings'}->[ $featureEntry->{'settings'}->{$setting} ][1][0]->{0}; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; +$this->{'hline_color'}->[ $last_drawn_row + 1 ][$col]; +@{ $table{$file}->{$subname}->{$pack}->{ $type . $name }->{$event} }; +$tagslib->{ $fields[$x_i]->tag() }->{ $subf[$i][0] }->{tab}; +$m2_results{ $modlog->{uid} }->{m2_count}->{ $_->{uid} }++; +$self->_get_meta_data_hash_ref()->{ $p_object->get_key() }->[$p_offset]; +#8........... + }, }; my $ntests = 0 + keys %{$rtests}; -- 2.39.5