+ # STEP 1: Our starting guess is to use measure from the first token of the
+ # current line. This is usually a good guess.
+ my $Kref = $Kfirst;
+
+ # STEP 2: See if we should go back a little farther
+ my $Kprev = $self->K_previous_nonblank($Kfirst);
+ if ( defined($Kprev) ) {
+
+ # Avoid measuring from between an opening paren and a previous token
+ # which should stay close to it ... fixes b1185
+ my $token_oo = $rLL->[$Kouter_opening]->[_TOKEN_];
+ my $type_prev = $rLL->[$Kprev]->[_TYPE_];
+ if ( $Kouter_opening == $Kfirst
+ && $token_oo eq '('
+ && $has_tight_paren{$type_prev} )
+ {
+ $Kref = $Kprev;
+ }
+
+ # Back up and count length from a token like '=' or '=>' if -lp
+ # is used (this fixes b520)
+ # ...or if a break is wanted before there
+ elsif ($rOpts_line_up_parentheses
+ || $want_break_before{$type_prev} )
+ {
+
+ # If there are other sequence items between the start of this line
+ # and the opening token in question, then do not include tokens on
+ # the previous line in length calculations. This check added to
+ # fix case b1174 which had a '?' on the line
+ my $no_previous_seq_item = $Kref == $Kouter_opening
+ || $rLL->[$Kref]->[_KNEXT_SEQ_ITEM_] == $Kouter_opening;
+
+ if ( $no_previous_seq_item
+ && substr( $type_prev, 0, 1 ) eq '=' )
+ {
+ $Kref = $Kprev;
+
+ # Fix for b1144 and b1112: backup to the first nonblank
+ # character before the =>, or to the start of its line.
+ if ( $type_prev eq '=>' ) {
+ my $iline_prev = $rLL->[$Kprev]->[_LINE_INDEX_];
+ my $rK_range_prev = $rlines->[$iline_prev]->{_rK_range};
+ my ( $Kfirst_prev, $Klast_prev ) = @{$rK_range_prev};
+ foreach my $KK ( reverse( $Kfirst_prev .. $Kref - 1 ) ) {
+ next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
+ $Kref = $KK;
+ last;
+ }
+ }
+ }
+ }
+ }
+
+ # STEP 3: Now look ahead for a ternary and, if found, use it.
+ # This fixes case b1182.
+ # Also look for a ')' at the same level and, if found, use it.
+ # This fixes case b1224.
+ if ( $Kref < $Kouter_opening ) {
+ my $Knext = $rLL->[$Kref]->[_KNEXT_SEQ_ITEM_];
+ my $level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
+ while ( $Knext < $Kouter_opening ) {
+ if ( $rLL->[$Knext]->[_LEVEL_] == $level_oo ) {
+ if ( $is_ternary{ $rLL->[$Knext]->[_TYPE_] }
+ || $rLL->[$Knext]->[_TOKEN_] eq ')' )
+ {
+ $Kref = $Knext;
+ last;
+ }
+ }
+ $Knext = $rLL->[$Knext]->[_KNEXT_SEQ_ITEM_];
+ }
+ }
+
+ # Define the starting measurements we will need
+ $starting_lentot =
+ $Kref <= 0 ? 0 : $rLL->[ $Kref - 1 ]->[_CUMULATIVE_LENGTH_];
+ $starting_level = $rLL->[$Kref]->[_LEVEL_];
+ $starting_ci = $rLL->[$Kref]->[_CI_LEVEL_];
+
+ $maximum_text_length = $maximum_text_length_at_level[$starting_level] -
+ $starting_ci * $rOpts_continuation_indentation;
+
+ # STEP 4: Switch to using the outer opening token as the reference
+ # point if a line break before it would make a longer line.
+ # Fixes case b1055 and is also an alternate fix for b1065.
+ my $starting_level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
+ if ( $Kref < $Kouter_opening ) {
+ my $starting_ci_oo = $rLL->[$Kouter_opening]->[_CI_LEVEL_];
+ my $lentot_oo = $rLL->[ $Kouter_opening - 1 ]->[_CUMULATIVE_LENGTH_];
+ my $maximum_text_length_oo =
+ $maximum_text_length_at_level[$starting_level_oo] -
+ $starting_ci_oo * $rOpts_continuation_indentation;
+
+ # The excess length to any cumulative length K = lenK is either
+ # $excess = $lenk - ($lentot + $maximum_text_length), or
+ # $excess = $lenk - ($lentot_oo + $maximum_text_length_oo),
+ # so the worst case (maximum excess) corresponds to the configuration
+ # with minimum value of the sum: $lentot + $maximum_text_length
+ if ( $lentot_oo + $maximum_text_length_oo <
+ $starting_lentot + $maximum_text_length )
+ {
+ $Kref = $Kouter_opening;
+ $starting_level = $starting_level_oo;
+ $starting_ci = $starting_ci_oo;
+ $starting_lentot = $lentot_oo;
+ $maximum_text_length = $maximum_text_length_oo;
+ }
+ }
+
+ my $new_weld_ok = 1;
+
+ # STEP 5, fix b1020: Avoid problem areas with the -wn -lp combination. The
+ # combination -wn -lp -dws -naws does not work well and can cause blinkers.
+ # It will probably only occur in stress testing. For this situation we
+ # will only start a new weld if we start at a 'good' location.
+ # - Added 'if' to fix case b1032.
+ # - Require blank before certain previous characters to fix b1111.
+ # - Add ';' to fix case b1139
+ # - Convert from '$ok_to_weld' to '$new_weld_ok' to fix b1162.
+ # - relaxed constraints for b1227
+ # - added skip if type is 'q' for b1349 and b1350 b1351 b1352 b1353
+ # - added skip if type is 'Q' for b1447
+ if ( $starting_ci
+ && $rOpts_line_up_parentheses
+ && $rOpts_delete_old_whitespace
+ && !$rOpts_add_whitespace
+ && $rLL->[$Kinner_opening]->[_TYPE_] ne 'q'
+ && $rLL->[$Kinner_opening]->[_TYPE_] ne 'Q'
+ && defined($Kprev) )
+ {
+ my $type_first = $rLL->[$Kfirst]->[_TYPE_];
+ my $token_first = $rLL->[$Kfirst]->[_TOKEN_];
+ my $type_prev = $rLL->[$Kprev]->[_TYPE_];
+ my $type_pp = 'b';
+ if ( $Kprev >= 0 ) { $type_pp = $rLL->[ $Kprev - 1 ]->[_TYPE_] }
+ unless (
+ $type_prev =~ /^[\,\.\;]/
+ || $type_prev =~ /^[=\{\[\(\L]/
+ && ( $type_pp eq 'b' || $type_pp eq '}' || $type_first eq 'k' )
+ || $type_first =~ /^[=\,\.\;\{\[\(\L]/
+ || $type_first eq '||'
+ || (
+ $type_first eq 'k'
+ && ( $token_first eq 'if'
+ || $token_first eq 'or' )
+ )
+ )
+ {
+ $msg =
+"Skipping weld: poor break with -lp and ci at type_first='$type_first' type_prev='$type_prev' type_pp=$type_pp\n";
+ $new_weld_ok = 0;
+ }
+ }
+ return ( $new_weld_ok, $maximum_text_length, $starting_lentot, $msg );
+} ## end sub setup_new_weld_measurements
+
+sub excess_line_length_for_Krange {
+ my ( $self, $Kfirst, $Klast ) = @_;
+
+ # returns $excess_length =
+ # by how many characters a line composed of tokens $Kfirst .. $Klast will
+ # exceed the allowed line length
+
+ my $rLL = $self->[_rLL_];
+ my $length_before_Kfirst =
+ $Kfirst <= 0
+ ? 0
+ : $rLL->[ $Kfirst - 1 ]->[_CUMULATIVE_LENGTH_];
+
+ # backup before a side comment if necessary
+ my $Kend = $Klast;
+ if ( $rOpts_ignore_side_comment_lengths
+ && $rLL->[$Klast]->[_TYPE_] eq '#' )
+ {
+ my $Kprev = $self->K_previous_nonblank($Klast);
+ if ( defined($Kprev) && $Kprev >= $Kfirst ) { $Kend = $Kprev }
+ }
+
+ # get the length of the text
+ my $length = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] - $length_before_Kfirst;
+
+ # get the size of the text window
+ my $level = $rLL->[$Kfirst]->[_LEVEL_];
+ my $ci_level = $rLL->[$Kfirst]->[_CI_LEVEL_];
+ my $max_text_length = $maximum_text_length_at_level[$level] -
+ $ci_level * $rOpts_continuation_indentation;
+
+ my $excess_length = $length - $max_text_length;
+
+ DEBUG_WELD
+ && print
+"Kfirst=$Kfirst, Klast=$Klast, Kend=$Kend, level=$level, ci=$ci_level, max_text_length=$max_text_length, length=$length\n";
+ return ($excess_length);
+} ## end sub excess_line_length_for_Krange
+
+sub weld_nested_containers {
+ my ($self) = @_;
+
+ # Called once per file for option '--weld-nested-containers'
+
+ my $rK_weld_left = $self->[_rK_weld_left_];
+ my $rK_weld_right = $self->[_rK_weld_right_];
+
+ # This routine implements the -wn flag by "welding together"
+ # the nested closing and opening tokens which were previously
+ # identified by sub 'find_nested_pairs'. "welding" simply
+ # involves setting certain hash values which will be checked
+ # later during formatting.
+
+ my $rLL = $self->[_rLL_];
+ my $rlines = $self->[_rlines_];
+ my $K_opening_container = $self->[_K_opening_container_];
+ my $K_closing_container = $self->[_K_closing_container_];
+ my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
+ my $ris_asub_block = $self->[_ris_asub_block_];
+ my $rmax_vertical_tightness = $self->[_rmax_vertical_tightness_];
+
+ my $rOpts_asbl = $rOpts->{'opening-anonymous-sub-brace-on-new-line'};
+
+ # Find nested pairs of container tokens for any welding.
+ my $rnested_pairs = $self->find_nested_pairs();
+
+ # Return unless there are nested pairs to weld
+ return unless defined($rnested_pairs) && @{$rnested_pairs};
+
+ # NOTE: It would be nice to apply RULE 5 right here by deleting unwanted
+ # pairs. But it isn't clear if this is possible because we don't know
+ # which sequences might actually start a weld.
+
+ my $rOpts_break_at_old_method_breakpoints =
+ $rOpts->{'break-at-old-method-breakpoints'};
+
+ # This array will hold the sequence numbers of the tokens to be welded.
+ my @welds;
+
+ # Variables needed for estimating line lengths
+ my $maximum_text_length; # maximum spaces available for text
+ my $starting_lentot; # cumulative text to start of current line
+
+ my $iline_outer_opening = -1;
+ my $weld_count_this_start = 0;
+
+ # OLD: $single_line_tol added to fix cases b1180 b1181
+ # = $rOpts_continuation_indentation > $rOpts_indent_columns ? 1 : 0;
+ # NEW: $single_line_tol=0; fixes b1212 and b1180-1181 work now
+ my $single_line_tol = 0;
+
+ my $multiline_tol = $single_line_tol + 1 +
+ max( $rOpts_indent_columns, $rOpts_continuation_indentation );
+
+ # Define a welding cutoff level: do not start a weld if the inside
+ # container level equals or exceeds this level.
+
+ # We use the minimum of two criteria, either of which may be more
+ # restrictive. The 'alpha' value is more restrictive in (b1206, b1252) and
+ # the 'beta' value is more restrictive in other cases (b1243).
+ # Reduced beta term from beta+3 to beta+2 to fix b1401. Previously:
+ # my $weld_cutoff_level = min($stress_level_alpha, $stress_level_beta + 2);
+ # This is now '$high_stress_level'.
+
+ # The vertical tightness flags can throw off line length calculations.
+ # This patch was added to fix instability issue b1284.
+ # It works to always use a tol of 1 for 1 line block length tests, but
+ # this restricted value keeps test case wn6.wn working as before.
+ # It may be necessary to include '[' and '{' here in the future.
+ my $one_line_tol = $opening_vertical_tightness{'('} ? 1 : 0;
+
+ # Abbreviations:
+ # _oo=outer opening, i.e. first of { {
+ # _io=inner opening, i.e. second of { {
+ # _oc=outer closing, i.e. second of } {
+ # _ic=inner closing, i.e. first of } }
+
+ my $previous_pair;
+
+ # Main loop over nested pairs...
+ # We are working from outermost to innermost pairs so that
+ # level changes will be complete when we arrive at the inner pairs.
+ while ( my $item = pop( @{$rnested_pairs} ) ) {
+ my ( $inner_seqno, $outer_seqno ) = @{$item};
+
+ my $Kouter_opening = $K_opening_container->{$outer_seqno};
+ my $Kinner_opening = $K_opening_container->{$inner_seqno};
+ my $Kouter_closing = $K_closing_container->{$outer_seqno};
+ my $Kinner_closing = $K_closing_container->{$inner_seqno};
+
+ # RULE: do not weld if inner container has <= 3 tokens unless the next
+ # token is a heredoc (so we know there will be multiple lines)
+ if ( $Kinner_closing - $Kinner_opening <= 4 ) {
+ my $Knext_nonblank = $self->K_next_nonblank($Kinner_opening);
+ next unless defined($Knext_nonblank);
+ my $type = $rLL->[$Knext_nonblank]->[_TYPE_];
+ next unless ( $type eq 'h' );
+ }
+
+ my $outer_opening = $rLL->[$Kouter_opening];
+ my $inner_opening = $rLL->[$Kinner_opening];
+ my $outer_closing = $rLL->[$Kouter_closing];
+ my $inner_closing = $rLL->[$Kinner_closing];
+
+ # RULE: do not weld to a hash brace. The reason is that it has a very
+ # strong bond strength to the next token, so a line break after it
+ # may not work. Previously we allowed welding to something like @{
+ # but that caused blinking states (cases b751, b779).
+ if ( $inner_opening->[_TYPE_] eq 'L' ) {
+ next;
+ }
+
+ # RULE: do not weld to a square bracket which does not contain commas
+ if ( $inner_opening->[_TYPE_] eq '[' ) {
+ my $rtype_count = $self->[_rtype_count_by_seqno_]->{$inner_seqno};
+ next unless ( $rtype_count && $rtype_count->{','} );
+
+ # Do not weld if there is text before a '[' such as here:
+ # curr_opt ( @beg [2,5] )
+ # It will not break into the desired sandwich structure.
+ # This fixes case b109, 110.
+ my $Kdiff = $Kinner_opening - $Kouter_opening;
+ next if ( $Kdiff > 2 );
+ next
+ if ( $Kdiff == 2
+ && $rLL->[ $Kouter_opening + 1 ]->[_TYPE_] ne 'b' );
+
+ }
+
+ # RULE: Avoid welding under stress. The idea is that we need to have a
+ # little space* within a welded container to avoid instability. Note
+ # that after each weld the level values are reduced, so long multiple
+ # welds can still be made. This rule will seldom be a limiting factor
+ # in actual working code. Fixes b1206, b1243.
+ my $inner_level = $inner_opening->[_LEVEL_];
+ if ( $inner_level >= $high_stress_level ) { next }
+
+ # Set flag saying if this pair starts a new weld
+ my $starting_new_weld = !( @welds && $outer_seqno == $welds[-1]->[0] );
+
+ # Set flag saying if this pair is adjacent to the previous nesting pair
+ # (even if previous pair was rejected as a weld)
+ my $touch_previous_pair =
+ defined($previous_pair) && $outer_seqno == $previous_pair->[0];
+ $previous_pair = $item;
+
+ my $do_not_weld_rule = 0;
+ my $Msg = EMPTY_STRING;
+ my $is_one_line_weld;
+
+ my $iline_oo = $outer_opening->[_LINE_INDEX_];
+ my $iline_io = $inner_opening->[_LINE_INDEX_];
+ my $iline_ic = $inner_closing->[_LINE_INDEX_];
+ my $iline_oc = $outer_closing->[_LINE_INDEX_];
+ my $token_oo = $outer_opening->[_TOKEN_];
+ my $token_io = $inner_opening->[_TOKEN_];
+
+ # DO-NOT-WELD RULE 7: Do not weld if this conflicts with -bom
+ # Added for case b973. Moved here from below to fix b1423.
+ if ( !$do_not_weld_rule
+ && $rOpts_break_at_old_method_breakpoints
+ && $iline_io > $iline_oo )
+ {
+
+ foreach my $iline ( $iline_oo + 1 .. $iline_io ) {
+ my $rK_range = $rlines->[$iline]->{_rK_range};
+ next unless defined($rK_range);
+ my ( $Kfirst, $Klast ) = @{$rK_range};
+ next unless defined($Kfirst);
+ if ( $rLL->[$Kfirst]->[_TYPE_] eq '->' ) {
+ $do_not_weld_rule = 7;
+ last;
+ }
+ }
+ }
+ next if ($do_not_weld_rule);
+
+ # Turn off vertical tightness at possible one-line welds. Fixes b1402,
+ # b1419, b1421, b1424, b1425. This also fixes issues b1338, b1339,
+ # b1340, b1341, b1342, b1343, which previously used a separate fix.
+ # Issue c161 is the latest and simplest check, using
+ # $iline_ic==$iline_io as the test.
+ if ( %opening_vertical_tightness
+ && $iline_ic == $iline_io
+ && $opening_vertical_tightness{$token_oo} )
+ {
+ $rmax_vertical_tightness->{$outer_seqno} = 0;
+ }
+
+ my $is_multiline_weld =
+ $iline_oo == $iline_io
+ && $iline_ic == $iline_oc
+ && $iline_io != $iline_ic;
+
+ if (DEBUG_WELD) {
+ my $len_oo = $rLL->[$Kouter_opening]->[_CUMULATIVE_LENGTH_];
+ my $len_io = $rLL->[$Kinner_opening]->[_CUMULATIVE_LENGTH_];
+ $Msg .= <<EOM;
+Pair seqo=$outer_seqno seqi=$inner_seqno lines: loo=$iline_oo lio=$iline_io lic=$iline_ic loc=$iline_oc
+Koo=$Kouter_opening Kio=$Kinner_opening Kic=$Kinner_closing Koc=$Kouter_closing lenoo=$len_oo lenio=$len_io
+tokens '$token_oo' .. '$token_io'
+EOM
+ }
+
+ # DO-NOT-WELD RULE 0:
+ # Avoid a new paren-paren weld if inner parens are 'sheared' (separated
+ # by one line). This can produce instabilities (fixes b1250 b1251
+ # 1256).
+ if ( !$is_multiline_weld
+ && $iline_ic == $iline_io + 1
+ && $token_oo eq '('
+ && $token_io eq '(' )
+ {
+ if (DEBUG_WELD) {
+ $Msg .= "RULE 0: Not welding due to sheared inner parens\n";
+ print $Msg;
+ }
+ next;
+ }
+
+ # If this pair is not adjacent to the previous pair (skipped or not),
+ # then measure lengths from the start of line of oo.
+ if (
+ !$touch_previous_pair
+
+ # Also do this if restarting at a new line; fixes case b965, s001
+ || ( !$weld_count_this_start && $iline_oo > $iline_outer_opening )
+ )
+ {
+
+ # Remember the line we are using as a reference
+ $iline_outer_opening = $iline_oo;
+ $weld_count_this_start = 0;
+
+ ( my $new_weld_ok, $maximum_text_length, $starting_lentot, my $msg )
+ = $self->setup_new_weld_measurements( $Kouter_opening,
+ $Kinner_opening );
+
+ if (
+ !$new_weld_ok
+ && ( $iline_oo != $iline_io
+ || $iline_ic != $iline_oc )
+ )
+ {
+ if (DEBUG_WELD) { print $msg}
+ next;
+ }
+
+ my $rK_range = $rlines->[$iline_oo]->{_rK_range};
+ my ( $Kfirst, $Klast ) = @{$rK_range};
+
+ # An existing one-line weld is a line in which
+ # (1) the containers are all on one line, and
+ # (2) the line does not exceed the allowable length
+ if ( $iline_oo == $iline_oc ) {
+
+ # All the tokens are on one line, now check their length.
+ # Start with the full line index range. We will reduce this
+ # in the coding below in some cases.
+ my $Kstart = $Kfirst;
+ my $Kstop = $Klast;
+
+ # Note that the following minimal choice for measuring will
+ # work and will not cause any instabilities because it is
+ # invariant:
+
+ ## my $Kstart = $Kouter_opening;
+ ## my $Kstop = $Kouter_closing;
+
+ # But that can lead to some undesirable welds. So a little
+ # more complicated method has been developed.
+
+ # We are trying to avoid creating bad two-line welds when we are
+ # working on long, previously un-welded input text, such as
+
+ # INPUT (example of a long input line weld candidate):
+ ## $mutation->transpos( $self->RNA->position($mutation->label, $atg_label));
+
+ # GOOD two-line break: (not welded; result marked too long):
+ ## $mutation->transpos(
+ ## $self->RNA->position($mutation->label, $atg_label));
+
+ # BAD two-line break: (welded; result if we weld):
+ ## $mutation->transpos($self->RNA->position(
+ ## $mutation->label, $atg_label));
+
+ # We can only get an approximate estimate of the final length,
+ # since the line breaks may change, and for -lp mode because
+ # even the indentation is not yet known.
+
+ my $level_first = $rLL->[$Kfirst]->[_LEVEL_];
+ my $level_last = $rLL->[$Klast]->[_LEVEL_];
+ my $level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
+ my $level_oc = $rLL->[$Kouter_closing]->[_LEVEL_];
+
+ # - measure to the end of the original line if balanced
+ # - measure to the closing container if unbalanced (fixes b1230)
+ #if ( $level_first != $level_last ) { $Kstop = $Kouter_closing }
+ if ( $level_oc > $level_last ) { $Kstop = $Kouter_closing }
+
+ # - measure from the start of the original line if balanced
+ # - measure from the most previous token with same level
+ # if unbalanced (b1232)
+ if ( $Kouter_opening > $Kfirst && $level_oo > $level_first ) {
+ $Kstart = $Kouter_opening;
+
+ foreach
+ my $KK ( reverse( $Kfirst + 1 .. $Kouter_opening - 1 ) )
+ {
+ next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
+ last if ( $rLL->[$KK]->[_LEVEL_] < $level_oo );
+ $Kstart = $KK;
+ }
+ }
+
+ my $excess =
+ $self->excess_line_length_for_Krange( $Kstart, $Kstop );
+
+ # Coding simplified here for case b1219.
+ # Increased tol from 0 to 1 when pvt>0 to fix b1284.
+ $is_one_line_weld = $excess <= $one_line_tol;
+ }
+
+ # DO-NOT-WELD RULE 1:
+ # Do not weld something that looks like the start of a two-line
+ # function call, like this: <<snippets/wn6.in>>
+ # $trans->add_transformation(
+ # PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
+ # We will look for a semicolon after the closing paren.
+
+ # We want to weld something complex, like this though
+ # my $compass = uc( opposite_direction( line_to_canvas_direction(
+ # @{ $coords[0] }, @{ $coords[1] } ) ) );
+ # Otherwise we will get a 'blinker'. For example, the following
+ # would become a blinker without this rule:
+ # $Self->_Add( $SortOrderDisplay{ $Field
+ # ->GenerateFieldForSelectSQL() } );
+ # But it is okay to weld a two-line statement if it looks like
+ # it was already welded, meaning that the two opening containers are
+ # on a different line that the two closing containers. This is
+ # necessary to prevent blinking of something like this with
+ # perltidy -wn -pbp (starting indentation two levels deep):
+
+ # $top_label->set_text( gettext(
+ # "Unable to create personal directory - check permissions.") );
+ if ( $iline_oc == $iline_oo + 1
+ && $iline_io == $iline_ic
+ && $token_oo eq '(' )
+ {
+
+ # Look for following semicolon...
+ my $Knext_nonblank = $self->K_next_nonblank($Kouter_closing);
+ my $next_nonblank_type =
+ defined($Knext_nonblank)
+ ? $rLL->[$Knext_nonblank]->[_TYPE_]
+ : 'b';
+ if ( $next_nonblank_type eq ';' ) {
+
+ # Then do not weld if no other containers between inner
+ # opening and closing.
+ my $Knext_seq_item = $inner_opening->[_KNEXT_SEQ_ITEM_];
+ if ( $Knext_seq_item == $Kinner_closing ) {
+ $do_not_weld_rule = 1;
+ }
+ }
+ }
+ } ## end starting new weld sequence
+
+ else {
+
+ # set the 1-line flag if continuing a weld sequence; fixes b1239
+ $is_one_line_weld = ( $iline_oo == $iline_oc );
+ }
+
+ # DO-NOT-WELD RULE 2:
+ # Do not weld an opening paren to an inner one line brace block
+ # We will just use old line numbers for this test and require
+ # iterations if necessary for convergence
+
+ # For example, otherwise we could cause the opening paren
+ # in the following example to separate from the caller name
+ # as here:
+
+ # $_[0]->code_handler
+ # ( sub { $more .= $_[1] . ":" . $_[0] . "\n" } );
+
+ # Here is another example where we do not want to weld:
+ # $wrapped->add_around_modifier(
+ # sub { push @tracelog => 'around 1'; $_[0]->(); } );
+
+ # If the one line sub block gets broken due to length or by the
+ # user, then we can weld. The result will then be:
+ # $wrapped->add_around_modifier( sub {
+ # push @tracelog => 'around 1';
+ # $_[0]->();
+ # } );
+
+ # Updated to fix cases b1082 b1102 b1106 b1115:
+ # Also, do not weld to an intact inner block if the outer opening token
+ # is on a different line. For example, this prevents oscillation
+ # between these two states in case b1106:
+
+ # return map{
+ # ($_,[$self->$_(@_[1..$#_])])
+ # }@every;
+
+ # return map { (
+ # $_, [ $self->$_( @_[ 1 .. $#_ ] ) ]
+ # ) } @every;
+
+ # The effect of this change on typical code is very minimal. Sometimes
+ # it may take a second iteration to converge, but this gives protection
+ # against blinking.
+ if ( !$do_not_weld_rule
+ && !$is_one_line_weld
+ && $iline_ic == $iline_io )
+ {
+ $do_not_weld_rule = 2
+ if ( $token_oo eq '(' || $iline_oo != $iline_io );
+ }
+
+ # DO-NOT-WELD RULE 2A:
+ # Do not weld an opening asub brace in -lp mode if -asbl is set. This
+ # helps avoid instabilities in one-line block formation, and fixes
+ # b1241. Previously, the '$is_one_line_weld' flag was tested here
+ # instead of -asbl, and this fixed most cases. But it turns out that
+ # the real problem was the -asbl flag, and switching to this was
+ # necessary to fixe b1268. This also fixes b1269, b1277, b1278.
+ if ( !$do_not_weld_rule
+ && $rOpts_line_up_parentheses
+ && $rOpts_asbl
+ && $ris_asub_block->{$outer_seqno} )
+ {
+ $do_not_weld_rule = '2A';
+ }
+
+ # DO-NOT-WELD RULE 3:
+ # Do not weld if this makes our line too long.
+ # Use a tolerance which depends on if the old tokens were welded
+ # (fixes cases b746 b748 b749 b750 b752 b753 b754 b755 b756 b758 b759)
+ if ( !$do_not_weld_rule ) {
+
+ # Measure to a little beyond the inner opening token if it is
+ # followed by a bare word, which may have unusual line break rules.
+
+ # NOTE: Originally this was OLD RULE 6: do not weld to a container
+ # which is followed on the same line by an unknown bareword token.
+ # This can cause blinkers (cases b626, b611). But OK to weld one
+ # line welds to fix cases b1057 b1064. For generality, OLD RULE 6
+ # has been merged into RULE 3 here to also fix cases b1078 b1091.
+
+ my $K_for_length = $Kinner_opening;
+ my $Knext_io = $self->K_next_nonblank($Kinner_opening);
+ next unless ( defined($Knext_io) ); # shouldn't happen
+ my $type_io_next = $rLL->[$Knext_io]->[_TYPE_];
+
+ # Note: may need to eventually also include other types here,
+ # such as 'Z' and 'Y': if ($type_io_next =~ /^[ZYw]$/) {
+ if ( $type_io_next eq 'w' ) {
+ my $Knext_io2 = $self->K_next_nonblank($Knext_io);
+ next unless ( defined($Knext_io2) );
+ my $type_io_next2 = $rLL->[$Knext_io2]->[_TYPE_];
+ if ( !$type_ok_after_bareword{$type_io_next2} ) {
+ $K_for_length = $Knext_io2;
+ }
+ }
+
+ # Use a tolerance for welds over multiple lines to avoid blinkers.
+ # We can use zero tolerance if it looks like we are working on an
+ # existing weld.
+ my $tol =
+ $is_one_line_weld || $is_multiline_weld
+ ? $single_line_tol
+ : $multiline_tol;
+
+ # By how many characters does this exceed the text window?
+ my $excess =
+ $self->cumulative_length_before_K($K_for_length) -
+ $starting_lentot + 1 + $tol -
+ $maximum_text_length;
+
+ # Old patch: Use '>=0' instead of '> 0' here to fix cases b995 b998
+ # b1000 b1001 b1007 b1008 b1009 b1010 b1011 b1012 b1016 b1017 b1018
+ # Revised patch: New tolerance definition allows going back to '> 0'
+ # here. This fixes case b1124. See also cases b1087 and b1087a.
+ if ( $excess > 0 ) { $do_not_weld_rule = 3 }
+
+ if (DEBUG_WELD) {
+ $Msg .=
+"RULE 3 test: excess length to K=$Kinner_opening is $excess > 0 with tol= $tol ?) \n";
+ }
+ }
+
+ # DO-NOT-WELD RULE 4; implemented for git#10:
+ # Do not weld an opening -ce brace if the next container is on a single
+ # line, different from the opening brace. (This is very rare). For
+ # example, given the following with -ce, we will avoid joining the {
+ # and [
+
+ # } else {
+ # [ $_, length($_) ]
+ # }
+
+ # because this would produce a terminal one-line block:
+
+ # } else { [ $_, length($_) ] }
+
+ # which may not be what is desired. But given this input:
+
+ # } else { [ $_, length($_) ] }
+
+ # then we will do the weld and retain the one-line block
+ if ( !$do_not_weld_rule && $rOpts->{'cuddled-else'} ) {
+ my $block_type = $rblock_type_of_seqno->{$outer_seqno};
+ if ( $block_type && $rcuddled_block_types->{'*'}->{$block_type} ) {
+ my $io_line = $inner_opening->[_LINE_INDEX_];
+ my $ic_line = $inner_closing->[_LINE_INDEX_];
+ my $oo_line = $outer_opening->[_LINE_INDEX_];
+ if ( $oo_line < $io_line && $ic_line == $io_line ) {
+ $do_not_weld_rule = 4;
+ }
+ }
+ }
+
+ # DO-NOT-WELD RULE 5: do not include welds excluded by user
+ if (
+ !$do_not_weld_rule
+ && %weld_nested_exclusion_rules
+ && ( $self->is_excluded_weld( $Kouter_opening, $starting_new_weld )
+ || $self->is_excluded_weld( $Kinner_opening, 0 ) )
+ )
+ {
+ $do_not_weld_rule = 5;
+ }
+
+ # DO-NOT-WELD RULE 6: This has been merged into RULE 3 above.
+
+ if ($do_not_weld_rule) {
+
+ # After neglecting a pair, we start measuring from start of point
+ # io ... but not if previous type does not like to be separated
+ # from its container (fixes case b1184)
+ my $Kprev = $self->K_previous_nonblank($Kinner_opening);
+ my $type_prev = defined($Kprev) ? $rLL->[$Kprev]->[_TYPE_] : 'w';
+ if ( !$has_tight_paren{$type_prev} ) {
+ my $starting_level = $inner_opening->[_LEVEL_];
+ my $starting_ci_level = $inner_opening->[_CI_LEVEL_];
+ $starting_lentot =
+ $self->cumulative_length_before_K($Kinner_opening);
+ $maximum_text_length =
+ $maximum_text_length_at_level[$starting_level] -
+ $starting_ci_level * $rOpts_continuation_indentation;
+ }
+
+ if (DEBUG_WELD) {
+ $Msg .= "Not welding due to RULE $do_not_weld_rule\n";
+ print $Msg;
+ }
+
+ # Normally, a broken pair should not decrease indentation of
+ # intermediate tokens:
+ ## if ( $last_pair_broken ) { next }
+ # However, for long strings of welded tokens, such as '{{{{{{...'
+ # we will allow broken pairs to also remove indentation.
+ # This will keep very long strings of opening and closing
+ # braces from marching off to the right. We will do this if the
+ # number of tokens in a weld before the broken weld is 4 or more.
+ # This rule will mainly be needed for test scripts, since typical
+ # welds have fewer than about 4 welded tokens.
+ if ( !@welds || @{ $welds[-1] } < 4 ) { next }
+ }
+
+ # otherwise start new weld ...
+ elsif ($starting_new_weld) {
+ $weld_count_this_start++;
+ if (DEBUG_WELD) {
+ $Msg .= "Starting new weld\n";
+ print $Msg;
+ }
+ push @welds, $item;
+
+ $rK_weld_right->{$Kouter_opening} = $Kinner_opening;
+ $rK_weld_left->{$Kinner_opening} = $Kouter_opening;
+
+ $rK_weld_right->{$Kinner_closing} = $Kouter_closing;
+ $rK_weld_left->{$Kouter_closing} = $Kinner_closing;
+ }
+
+ # ... or extend current weld
+ else {
+ $weld_count_this_start++;
+ if (DEBUG_WELD) {
+ $Msg .= "Extending current weld\n";
+ print $Msg;
+ }
+ unshift @{ $welds[-1] }, $inner_seqno;
+ $rK_weld_right->{$Kouter_opening} = $Kinner_opening;
+ $rK_weld_left->{$Kinner_opening} = $Kouter_opening;
+
+ $rK_weld_right->{$Kinner_closing} = $Kouter_closing;
+ $rK_weld_left->{$Kouter_closing} = $Kinner_closing;
+
+ # Keep a broken container broken at multiple welds. This might
+ # also be useful for simple welds, but for now it is restricted
+ # to multiple welds to minimize changes to existing coding. This
+ # fixes b1429, b1430. Updated for issue c198: but allow a
+ # line differences of 1 (simple shear) so that a simple shear
+ # can remain or become a single line.
+ if ( $iline_ic - $iline_io > 1 ) {
+
+ # Only set this break if it is the last possible weld in this
+ # chain. This will keep some extreme test cases unchanged.
+ my $is_chain_end = !@{$rnested_pairs}
+ || $rnested_pairs->[-1]->[1] != $inner_seqno;
+ if ($is_chain_end) {
+ $self->[_rbreak_container_]->{$inner_seqno} = 1;
+ }
+ }
+ }
+
+ # After welding, reduce the indentation level if all intermediate tokens
+ my $dlevel = $outer_opening->[_LEVEL_] - $inner_opening->[_LEVEL_];
+ if ( $dlevel != 0 ) {
+ my $Kstart = $Kinner_opening;
+ my $Kstop = $Kinner_closing;
+ foreach my $KK ( $Kstart .. $Kstop ) {
+ $rLL->[$KK]->[_LEVEL_] += $dlevel;
+ }
+
+ # Copy opening ci level to help break at = for -lp mode (case b1124)
+ $rLL->[$Kinner_opening]->[_CI_LEVEL_] =
+ $rLL->[$Kouter_opening]->[_CI_LEVEL_];
+
+ # But do not copy the closing ci level ... it can give poor results
+ ## $rLL->[$Kinner_closing]->[_CI_LEVEL_] =
+ ## $rLL->[$Kouter_closing]->[_CI_LEVEL_];
+ }
+ }
+
+ return;
+} ## end sub weld_nested_containers
+
+sub weld_nested_quotes {
+
+ # Called once per file for option '--weld-nested-containers'. This
+ # does welding on qw quotes.
+
+ my $self = shift;
+
+ # See if quotes are excluded from welding
+ my $rflags = $weld_nested_exclusion_rules{'q'};
+ return if ( defined($rflags) && defined( $rflags->[1] ) );
+
+ my $rK_weld_left = $self->[_rK_weld_left_];
+ my $rK_weld_right = $self->[_rK_weld_right_];
+
+ my $rLL = $self->[_rLL_];
+ return unless ( defined($rLL) && @{$rLL} );
+ my $Num = @{$rLL};
+
+ my $K_opening_container = $self->[_K_opening_container_];
+ my $K_closing_container = $self->[_K_closing_container_];
+ my $rlines = $self->[_rlines_];
+
+ my $starting_lentot;
+ my $maximum_text_length;
+
+ my $is_single_quote = sub {
+ my ( $Kbeg, $Kend, $quote_type ) = @_;
+ foreach my $K ( $Kbeg .. $Kend ) {
+ my $test_type = $rLL->[$K]->[_TYPE_];
+ next if ( $test_type eq 'b' );
+ return if ( $test_type ne $quote_type );
+ }
+ return 1;
+ };
+
+ # Length tolerance - same as previously used for sub weld_nested
+ my $multiline_tol =
+ 1 + max( $rOpts_indent_columns, $rOpts_continuation_indentation );
+
+ # look for single qw quotes nested in containers
+ my $KNEXT = $self->[_K_first_seq_item_];
+ while ( defined($KNEXT) ) {
+ my $KK = $KNEXT;
+ $KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
+ my $rtoken_vars = $rLL->[$KK];
+ my $outer_seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
+ if ( !$outer_seqno ) {
+ next if ( $KK == 0 ); # first token in file may not be container
+
+ # A fault here implies that an error was made in the little loop at
+ # the bottom of sub 'respace_tokens' which set the values of
+ # _KNEXT_SEQ_ITEM_. Or an error has been introduced in the
+ # loop control lines above.
+ Fault("sequence = $outer_seqno not defined at K=$KK")
+ if (DEVEL_MODE);
+ next;
+ }
+
+ my $token = $rtoken_vars->[_TOKEN_];
+ if ( $is_opening_token{$token} ) {
+
+ # see if the next token is a quote of some type
+ my $Kn = $KK + 1;
+ $Kn += 1
+ if ( $Kn < $Num && $rLL->[$Kn]->[_TYPE_] eq 'b' );
+ next unless ( $Kn < $Num );
+
+ my $next_token = $rLL->[$Kn]->[_TOKEN_];
+ my $next_type = $rLL->[$Kn]->[_TYPE_];
+ next
+ unless ( ( $next_type eq 'q' || $next_type eq 'Q' )
+ && substr( $next_token, 0, 1 ) eq 'q' );
+
+ # The token before the closing container must also be a quote
+ my $Kouter_closing = $K_closing_container->{$outer_seqno};
+ my $Kinner_closing = $self->K_previous_nonblank($Kouter_closing);
+ next unless $rLL->[$Kinner_closing]->[_TYPE_] eq $next_type;
+
+ # This is an inner opening container
+ my $Kinner_opening = $Kn;
+
+ # Do not weld to single-line quotes. Nothing is gained, and it may
+ # look bad.
+ next if ( $Kinner_closing == $Kinner_opening );
+
+ # Only weld to quotes delimited with container tokens. This is
+ # because welding to arbitrary quote delimiters can produce code
+ # which is less readable than without welding.
+ my $closing_delimiter =
+ substr( $rLL->[$Kinner_closing]->[_TOKEN_], -1, 1 );
+ next
+ unless ( $is_closing_token{$closing_delimiter}
+ || $closing_delimiter eq '>' );
+
+ # Now make sure that there is just a single quote in the container
+ next
+ unless (
+ $is_single_quote->(