+ if ( $last_item_length > 0 ) {
+
+ # add 2 to length because other lengths include a comma and a blank
+ $last_item_length += 2;
+ push @item_lengths, $last_item_length;
+ push @i_term_begin, $i_b + 1;
+ push @i_term_end, $i_e;
+ push @i_term_comma, undef;
+
+ my $i_odd = $item_count % 2;
+
+ if ( $last_item_length > $max_length[$i_odd] ) {
+ $max_length[$i_odd] = $last_item_length;
+ }
+
+ $item_count++;
+ $i_effective_last_comma = $i_e + 1;
+
+ if ( $types_to_go[ $i_b + 1 ] =~ /^[iR\]]$/ ) {
+ $identifier_count++;
+ }
+ }
+
+ #---------------------------------------------------------------
+ # End of length calculations
+ #---------------------------------------------------------------
+
+ #---------------------------------------------------------------
+ # Compound List Rule 1:
+ # Break at (almost) every comma for a list containing a broken
+ # sublist. This has higher priority than the Interrupted List
+ # Rule.
+ #---------------------------------------------------------------
+ if ($has_broken_sublist) {
+
+ # Break at every comma except for a comma between two
+ # simple, small terms. This prevents long vertical
+ # columns of, say, just 0's.
+ my $small_length = 10; # 2 + actual maximum length wanted
+
+ # We'll insert a break in long runs of small terms to
+ # allow alignment in uniform tables.
+ my $skipped_count = 0;
+ my $columns = table_columns_available($i_first_comma);
+ my $fields = int( $columns / $small_length );
+ if ( $rOpts_maximum_fields_per_table
+ && $fields > $rOpts_maximum_fields_per_table )
+ {
+ $fields = $rOpts_maximum_fields_per_table;
+ }
+ my $max_skipped_count = $fields - 1;
+
+ my $is_simple_last_term = 0;
+ my $is_simple_next_term = 0;
+ foreach my $j ( 0 .. $item_count ) {
+ $is_simple_last_term = $is_simple_next_term;
+ $is_simple_next_term = 0;
+ if ( $j < $item_count
+ && $i_term_end[$j] == $i_term_begin[$j]
+ && $item_lengths[$j] <= $small_length )
+ {
+ $is_simple_next_term = 1;
+ }
+ next if $j == 0;
+ if ( $is_simple_last_term
+ && $is_simple_next_term
+ && $skipped_count < $max_skipped_count )
+ {
+ $skipped_count++;
+ }
+ else {
+ $skipped_count = 0;
+ my $i = $i_term_comma[ $j - 1 ];
+ last unless defined $i;
+ $self->set_forced_breakpoint($i);
+ }
+ }
+
+ # always break at the last comma if this list is
+ # interrupted; we wouldn't want to leave a terminal '{', for
+ # example.
+ if ($interrupted) {
+ $self->set_forced_breakpoint($i_true_last_comma);
+ }
+ return;
+ }
+
+#my ( $a, $b, $c ) = caller();
+#print "LISTX: in set_list $a $c interrupt=$interrupted count=$item_count
+#i_first = $i_first_comma i_last=$i_last_comma max=$max_index_to_go\n";
+#print "depth=$depth has_broken=$has_broken_sublist[$depth] is_multi=$is_multiline opening_paren=($i_opening_paren) \n";
+
+ #---------------------------------------------------------------
+ # Interrupted List Rule:
+ # A list is forced to use old breakpoints if it was interrupted
+ # by side comments or blank lines, or requested by user.
+ #---------------------------------------------------------------
+ if ( $rOpts_break_at_old_comma_breakpoints
+ || $interrupted
+ || $i_opening_paren < 0 )
+ {
+ $self->copy_old_breakpoints( $i_first_comma, $i_true_last_comma );
+ return;
+ }
+
+ #---------------------------------------------------------------
+ # Looks like a list of items. We have to look at it and size it up.
+ #---------------------------------------------------------------
+
+ my $opening_token = $tokens_to_go[$i_opening_paren];
+ my $opening_is_in_block = $self->is_in_block_by_i($i_opening_paren);
+
+ #-------------------------------------------------------------------
+ # Return if this will fit on one line
+ #-------------------------------------------------------------------
+
+ my $i_opening_minus = $self->find_token_starting_list($i_opening_paren);
+ return
+ unless $self->excess_line_length( $i_opening_minus, $i_closing_paren )
+ > 0;
+
+ #-------------------------------------------------------------------
+ # Now we know that this block spans multiple lines; we have to set
+ # at least one breakpoint -- real or fake -- as a signal to break
+ # open any outer containers.
+ #-------------------------------------------------------------------
+ set_fake_breakpoint();
+
+ # be sure we do not extend beyond the current list length
+ if ( $i_effective_last_comma >= $max_index_to_go ) {
+ $i_effective_last_comma = $max_index_to_go - 1;
+ }
+
+ # Set a flag indicating if we need to break open to keep -lp
+ # items aligned. This is necessary if any of the list terms
+ # exceeds the available space after the '('.
+ my $need_lp_break_open = $must_break_open;
+ if ( $rOpts_line_up_parentheses && !$must_break_open ) {
+ my $columns_if_unbroken =
+ $maximum_line_length_at_level[ $levels_to_go[$i_opening_minus] ]
+ - total_line_length( $i_opening_minus, $i_opening_paren );
+ $need_lp_break_open =
+ ( $max_length[0] > $columns_if_unbroken )
+ || ( $max_length[1] > $columns_if_unbroken )
+ || ( $first_term_length > $columns_if_unbroken );
+ }
+
+ # Specify if the list must have an even number of fields or not.
+ # It is generally safest to assume an even number, because the
+ # list items might be a hash list. But if we can be sure that
+ # it is not a hash, then we can allow an odd number for more
+ # flexibility.
+ my $odd_or_even = 2; # 1 = odd field count ok, 2 = want even count
+
+ if ( $identifier_count >= $item_count - 1
+ || $is_assignment{$next_nonblank_type}
+ || ( $list_type && $list_type ne '=>' && $list_type !~ /^[\:\?]$/ )
+ )
+ {
+ $odd_or_even = 1;
+ }
+
+ # do we have a long first term which should be
+ # left on a line by itself?
+ my $use_separate_first_term = (
+ $odd_or_even == 1 # only if we can use 1 field/line
+ && $item_count > 3 # need several items
+ && $first_term_length >
+ 2 * $max_length[0] - 2 # need long first term
+ && $first_term_length >
+ 2 * $max_length[1] - 2 # need long first term
+ );
+
+ # or do we know from the type of list that the first term should
+ # be placed alone?
+ if ( !$use_separate_first_term ) {
+ if ( $is_keyword_with_special_leading_term{$list_type} ) {
+ $use_separate_first_term = 1;
+
+ # should the container be broken open?
+ if ( $item_count < 3 ) {
+ if ( $i_first_comma - $i_opening_paren < 4 ) {
+ ${$rdo_not_break_apart} = 1;
+ }
+ }
+ elsif ($first_term_length < 20
+ && $i_first_comma - $i_opening_paren < 4 )
+ {
+ my $columns = table_columns_available($i_first_comma);
+ if ( $first_term_length < $columns ) {
+ ${$rdo_not_break_apart} = 1;
+ }
+ }
+ }
+ }
+
+ # if so,
+ if ($use_separate_first_term) {
+
+ # ..set a break and update starting values
+ $use_separate_first_term = 1;
+ $self->set_forced_breakpoint($i_first_comma);
+ $i_opening_paren = $i_first_comma;
+ $i_first_comma = $rcomma_index->[1];
+ $item_count--;
+ return if $comma_count == 1;
+ shift @item_lengths;
+ shift @i_term_begin;
+ shift @i_term_end;
+ shift @i_term_comma;
+ }
+
+ # if not, update the metrics to include the first term
+ else {
+ if ( $first_term_length > $max_length[0] ) {
+ $max_length[0] = $first_term_length;
+ }
+ }
+
+ # Field width parameters
+ my $pair_width = ( $max_length[0] + $max_length[1] );
+ my $max_width =
+ ( $max_length[0] > $max_length[1] ) ? $max_length[0] : $max_length[1];
+
+ # Number of free columns across the page width for laying out tables
+ my $columns = table_columns_available($i_first_comma);
+
+ # Estimated maximum number of fields which fit this space
+ # This will be our first guess
+ my $number_of_fields_max =
+ maximum_number_of_fields( $columns, $odd_or_even, $max_width,
+ $pair_width );
+ my $number_of_fields = $number_of_fields_max;
+
+ # Find the best-looking number of fields
+ # and make this our second guess if possible
+ my ( $number_of_fields_best, $ri_ragged_break_list,
+ $new_identifier_count )
+ = $self->study_list_complexity( \@i_term_begin, \@i_term_end,
+ \@item_lengths, $max_width );
+
+ if ( $number_of_fields_best != 0
+ && $number_of_fields_best < $number_of_fields_max )
+ {
+ $number_of_fields = $number_of_fields_best;
+ }
+
+ # ----------------------------------------------------------------------
+ # If we are crowded and the -lp option is being used, try to
+ # undo some indentation
+ # ----------------------------------------------------------------------
+ if (
+ $rOpts_line_up_parentheses
+ && (
+ $number_of_fields == 0
+ || ( $number_of_fields == 1
+ && $number_of_fields != $number_of_fields_best )
+ )
+ )
+ {
+ my $available_spaces =
+ $self->get_available_spaces_to_go($i_first_comma);
+ if ( $available_spaces > 0 ) {
+
+ my $spaces_wanted = $max_width - $columns; # for 1 field
+
+ if ( $number_of_fields_best == 0 ) {
+ $number_of_fields_best =
+ get_maximum_fields_wanted( \@item_lengths );
+ }
+
+ if ( $number_of_fields_best != 1 ) {
+ my $spaces_wanted_2 =
+ 1 + $pair_width - $columns; # for 2 fields
+ if ( $available_spaces > $spaces_wanted_2 ) {
+ $spaces_wanted = $spaces_wanted_2;
+ }
+ }
+
+ if ( $spaces_wanted > 0 ) {
+ my $deleted_spaces =
+ $self->reduce_lp_indentation( $i_first_comma,
+ $spaces_wanted );
+
+ # redo the math
+ if ( $deleted_spaces > 0 ) {
+ $columns = table_columns_available($i_first_comma);
+ $number_of_fields_max =
+ maximum_number_of_fields( $columns, $odd_or_even,
+ $max_width, $pair_width );
+ $number_of_fields = $number_of_fields_max;
+
+ if ( $number_of_fields_best == 1
+ && $number_of_fields >= 1 )
+ {
+ $number_of_fields = $number_of_fields_best;
+ }
+ }
+ }
+ }
+ }
+
+ # try for one column if two won't work
+ if ( $number_of_fields <= 0 ) {
+ $number_of_fields = int( $columns / $max_width );
+ }
+
+ # The user can place an upper bound on the number of fields,
+ # which can be useful for doing maintenance on tables
+ if ( $rOpts_maximum_fields_per_table
+ && $number_of_fields > $rOpts_maximum_fields_per_table )
+ {
+ $number_of_fields = $rOpts_maximum_fields_per_table;
+ }
+
+ # How many columns (characters) and lines would this container take
+ # if no additional whitespace were added?
+ my $packed_columns = token_sequence_length( $i_opening_paren + 1,
+ $i_effective_last_comma + 1 );
+ if ( $columns <= 0 ) { $columns = 1 } # avoid divide by zero
+ my $packed_lines = 1 + int( $packed_columns / $columns );
+
+ # are we an item contained in an outer list?
+ my $in_hierarchical_list = $next_nonblank_type =~ /^[\}\,]$/;
+
+ if ( $number_of_fields <= 0 ) {
+
+# #---------------------------------------------------------------
+# # We're in trouble. We can't find a single field width that works.
+# # There is no simple answer here; we may have a single long list
+# # item, or many.
+# #---------------------------------------------------------------
+#
+# In many cases, it may be best to not force a break if there is just one
+# comma, because the standard continuation break logic will do a better
+# job without it.
+#
+# In the common case that all but one of the terms can fit
+# on a single line, it may look better not to break open the
+# containing parens. Consider, for example
+#
+# $color =
+# join ( '/',
+# sort { $color_value{$::a} <=> $color_value{$::b}; }
+# keys %colors );
+#
+# which will look like this with the container broken:
+#
+# $color = join (
+# '/',
+# sort { $color_value{$::a} <=> $color_value{$::b}; } keys %colors
+# );
+#
+# Here is an example of this rule for a long last term:
+#
+# log_message( 0, 256, 128,
+# "Number of routes in adj-RIB-in to be considered: $peercount" );
+#
+# And here is an example with a long first term:
+#
+# $s = sprintf(
+# "%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
+# $r, $pu, $ps, $cu, $cs, $tt
+# )
+# if $style eq 'all';
+
+ my $i_last_comma = $rcomma_index->[ $comma_count - 1 ];
+ my $long_last_term =
+ $self->excess_line_length( 0, $i_last_comma ) <= 0;
+ my $long_first_term =
+ $self->excess_line_length( $i_first_comma + 1, $max_index_to_go )
+ <= 0;
+
+ # break at every comma ...
+ if (
+
+ # if requested by user or is best looking
+ $number_of_fields_best == 1
+
+ # or if this is a sublist of a larger list
+ || $in_hierarchical_list
+
+ # or if multiple commas and we don't have a long first or last
+ # term
+ || ( $comma_count > 1
+ && !( $long_last_term || $long_first_term ) )
+ )
+ {
+ foreach ( 0 .. $comma_count - 1 ) {
+ $self->set_forced_breakpoint( $rcomma_index->[$_] );
+ }
+ }
+ elsif ($long_last_term) {
+
+ $self->set_forced_breakpoint($i_last_comma);
+ ${$rdo_not_break_apart} = 1 unless $must_break_open;
+ }
+ elsif ($long_first_term) {
+
+ $self->set_forced_breakpoint($i_first_comma);
+ }
+ else {
+
+ # let breaks be defined by default bond strength logic
+ }
+ return;
+ }
+
+ # --------------------------------------------------------
+ # We have a tentative field count that seems to work.
+ # How many lines will this require?
+ # --------------------------------------------------------
+ my $formatted_lines = $item_count / ($number_of_fields);
+ if ( $formatted_lines != int $formatted_lines ) {
+ $formatted_lines = 1 + int $formatted_lines;
+ }
+
+ # So far we've been trying to fill out to the right margin. But
+ # compact tables are easier to read, so let's see if we can use fewer
+ # fields without increasing the number of lines.
+ $number_of_fields =
+ compactify_table( $item_count, $number_of_fields, $formatted_lines,
+ $odd_or_even );
+
+ # How many spaces across the page will we fill?
+ my $columns_per_line =
+ ( int $number_of_fields / 2 ) * $pair_width +
+ ( $number_of_fields % 2 ) * $max_width;
+
+ my $formatted_columns;
+
+ if ( $number_of_fields > 1 ) {
+ $formatted_columns =
+ ( $pair_width * ( int( $item_count / 2 ) ) +
+ ( $item_count % 2 ) * $max_width );
+ }
+ else {
+ $formatted_columns = $max_width * $item_count;
+ }
+ if ( $formatted_columns < $packed_columns ) {
+ $formatted_columns = $packed_columns;
+ }
+
+ my $unused_columns = $formatted_columns - $packed_columns;
+
+ # set some empirical parameters to help decide if we should try to
+ # align; high sparsity does not look good, especially with few lines
+ my $sparsity = ($unused_columns) / ($formatted_columns);
+ my $max_allowed_sparsity =
+ ( $item_count < 3 ) ? 0.1
+ : ( $packed_lines == 1 ) ? 0.15
+ : ( $packed_lines == 2 ) ? 0.4
+ : 0.7;
+
+ # Begin check for shortcut methods, which avoid treating a list
+ # as a table for relatively small parenthesized lists. These
+ # are usually easier to read if not formatted as tables.
+ if (
+ $packed_lines <= 2 # probably can fit in 2 lines
+ && $item_count < 9 # doesn't have too many items
+ && $opening_is_in_block # not a sub-container
+ && $opening_token eq '(' # is paren list
+ )
+ {
+
+ # Shortcut method 1: for -lp and just one comma:
+ # This is a no-brainer, just break at the comma.
+ if (
+ $rOpts_line_up_parentheses # -lp
+ && $item_count == 2 # two items, one comma
+ && !$must_break_open
+ )
+ {
+ my $i_break = $rcomma_index->[0];
+ $self->set_forced_breakpoint($i_break);
+ ${$rdo_not_break_apart} = 1;
+ return;
+
+ }
+
+ # method 2 is for most small ragged lists which might look
+ # best if not displayed as a table.
+ if (
+ ( $number_of_fields == 2 && $item_count == 3 )
+ || (
+ $new_identifier_count > 0 # isn't all quotes
+ && $sparsity > 0.15
+ ) # would be fairly spaced gaps if aligned
+ )
+ {
+
+ my $break_count = $self->set_ragged_breakpoints( \@i_term_comma,
+ $ri_ragged_break_list );
+ ++$break_count if ($use_separate_first_term);
+
+ # NOTE: we should really use the true break count here,
+ # which can be greater if there are large terms and
+ # little space, but usually this will work well enough.
+ unless ($must_break_open) {
+
+ if ( $break_count <= 1 ) {
+ ${$rdo_not_break_apart} = 1;
+ }
+ elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
+ {
+ ${$rdo_not_break_apart} = 1;
+ }
+ }
+ return;
+ }
+
+ } # end shortcut methods
+
+ # debug stuff
+ DEBUG_SPARSE && do {
+ print STDOUT
+"SPARSE:cols=$columns commas=$comma_count items:$item_count ids=$identifier_count pairwidth=$pair_width fields=$number_of_fields lines packed: $packed_lines packed_cols=$packed_columns fmtd:$formatted_lines cols /line:$columns_per_line unused:$unused_columns fmtd:$formatted_columns sparsity=$sparsity allow=$max_allowed_sparsity\n";
+
+ };
+
+ #---------------------------------------------------------------
+ # Compound List Rule 2:
+ # If this list is too long for one line, and it is an item of a
+ # larger list, then we must format it, regardless of sparsity
+ # (ian.t). One reason that we have to do this is to trigger
+ # Compound List Rule 1, above, which causes breaks at all commas of
+ # all outer lists. In this way, the structure will be properly
+ # displayed.
+ #---------------------------------------------------------------
+
+ # Decide if this list is too long for one line unless broken
+ my $total_columns = table_columns_available($i_opening_paren);
+ my $too_long = $packed_columns > $total_columns;
+
+ # For a paren list, include the length of the token just before the
+ # '(' because this is likely a sub call, and we would have to
+ # include the sub name on the same line as the list. This is still
+ # imprecise, but not too bad. (steve.t)
+ if ( !$too_long && $i_opening_paren > 0 && $opening_token eq '(' ) {
+
+ $too_long = $self->excess_line_length( $i_opening_minus,
+ $i_effective_last_comma + 1 ) > 0;
+ }
+
+ # FIXME: For an item after a '=>', try to include the length of the
+ # thing before the '=>'. This is crude and should be improved by
+ # actually looking back token by token.
+ if ( !$too_long && $i_opening_paren > 0 && $list_type eq '=>' ) {
+ my $i_opening_minus = $i_opening_paren - 4;
+ if ( $i_opening_minus >= 0 ) {
+ $too_long = $self->excess_line_length( $i_opening_minus,
+ $i_effective_last_comma + 1 ) > 0;
+ }
+ }
+
+ # Always break lists contained in '[' and '{' if too long for 1 line,
+ # and always break lists which are too long and part of a more complex
+ # structure.
+ my $must_break_open_container = $must_break_open
+ || ( $too_long
+ && ( $in_hierarchical_list || $opening_token ne '(' ) );
+
+#print "LISTX: next=$next_nonblank_type avail cols=$columns packed=$packed_columns must format = $must_break_open_container too-long=$too_long opening=$opening_token list_type=$list_type formatted_lines=$formatted_lines packed=$packed_lines max_sparsity= $max_allowed_sparsity sparsity=$sparsity \n";
+
+ #---------------------------------------------------------------
+ # The main decision:
+ # Now decide if we will align the data into aligned columns. Do not
+ # attempt to align columns if this is a tiny table or it would be
+ # too spaced. It seems that the more packed lines we have, the
+ # sparser the list that can be allowed and still look ok.
+ #---------------------------------------------------------------
+
+ if ( ( $formatted_lines < 3 && $packed_lines < $formatted_lines )
+ || ( $formatted_lines < 2 )
+ || ( $unused_columns > $max_allowed_sparsity * $formatted_columns )
+ )
+ {
+
+ #---------------------------------------------------------------
+ # too sparse: would look ugly if aligned in a table;
+ #---------------------------------------------------------------
+
+ # use old breakpoints if this is a 'big' list
+ if ( $packed_lines > 2 && $item_count > 10 ) {
+ write_logfile_entry("List sparse: using old breakpoints\n");
+ $self->copy_old_breakpoints( $i_first_comma, $i_last_comma );
+ }
+
+ # let the continuation logic handle it if 2 lines
+ else {
+
+ my $break_count = $self->set_ragged_breakpoints( \@i_term_comma,
+ $ri_ragged_break_list );
+ ++$break_count if ($use_separate_first_term);
+
+ unless ($must_break_open_container) {
+ if ( $break_count <= 1 ) {
+ ${$rdo_not_break_apart} = 1;
+ }
+ elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
+ {
+ ${$rdo_not_break_apart} = 1;
+ }
+ }
+ }
+ return;
+ }
+
+ #---------------------------------------------------------------
+ # go ahead and format as a table
+ #---------------------------------------------------------------
+ write_logfile_entry(
+ "List: auto formatting with $number_of_fields fields/row\n");
+
+ my $j_first_break =
+ $use_separate_first_term ? $number_of_fields : $number_of_fields - 1;
+
+ for (
+ my $j = $j_first_break ;
+ $j < $comma_count ;
+ $j += $number_of_fields
+ )
+ {
+ my $i = $rcomma_index->[$j];
+ $self->set_forced_breakpoint($i);
+ }
+ return;
+ }
+} ## end closure set_comma_breakpoints_do
+
+sub study_list_complexity {
+
+ # Look for complex tables which should be formatted with one term per line.
+ # Returns the following:
+ #
+ # \@i_ragged_break_list = list of good breakpoints to avoid lines
+ # which are hard to read
+ # $number_of_fields_best = suggested number of fields based on
+ # complexity; = 0 if any number may be used.
+ #
+ my ( $self, $ri_term_begin, $ri_term_end, $ritem_lengths, $max_width ) = @_;
+ my $item_count = @{$ri_term_begin};
+ my $complex_item_count = 0;
+ my $number_of_fields_best = $rOpts_maximum_fields_per_table;
+ my $i_max = @{$ritem_lengths} - 1;
+ ##my @item_complexity;
+
+ my $i_last_last_break = -3;
+ my $i_last_break = -2;
+ my @i_ragged_break_list;
+
+ my $definitely_complex = 30;
+ my $definitely_simple = 12;
+ my $quote_count = 0;
+
+ for my $i ( 0 .. $i_max ) {
+ my $ib = $ri_term_begin->[$i];
+ my $ie = $ri_term_end->[$i];
+
+ # define complexity: start with the actual term length
+ my $weighted_length = ( $ritem_lengths->[$i] - 2 );
+
+ ##TBD: join types here and check for variations
+ ##my $str=join "", @tokens_to_go[$ib..$ie];
+
+ my $is_quote = 0;
+ if ( $types_to_go[$ib] =~ /^[qQ]$/ ) {
+ $is_quote = 1;
+ $quote_count++;
+ }
+ elsif ( $types_to_go[$ib] =~ /^[w\-]$/ ) {
+ $quote_count++;
+ }
+
+ if ( $ib eq $ie ) {
+ if ( $is_quote && $tokens_to_go[$ib] =~ /\s/ ) {
+ $complex_item_count++;
+ $weighted_length *= 2;
+ }
+ else {
+ }
+ }
+ else {
+ if ( grep { $_ eq 'b' } @types_to_go[ $ib .. $ie ] ) {
+ $complex_item_count++;
+ $weighted_length *= 2;
+ }
+ if ( grep { $_ eq '..' } @types_to_go[ $ib .. $ie ] ) {
+ $weighted_length += 4;
+ }
+ }
+
+ # add weight for extra tokens.
+ $weighted_length += 2 * ( $ie - $ib );
+
+## my $BUB = join '', @tokens_to_go[$ib..$ie];
+## print "# COMPLEXITY:$weighted_length $BUB\n";
+
+##push @item_complexity, $weighted_length;
+
+ # now mark a ragged break after this item it if it is 'long and
+ # complex':
+ if ( $weighted_length >= $definitely_complex ) {
+
+ # if we broke after the previous term
+ # then break before it too
+ if ( $i_last_break == $i - 1
+ && $i > 1
+ && $i_last_last_break != $i - 2 )
+ {
+
+ ## FIXME: don't strand a small term
+ pop @i_ragged_break_list;
+ push @i_ragged_break_list, $i - 2;
+ push @i_ragged_break_list, $i - 1;
+ }
+
+ push @i_ragged_break_list, $i;
+ $i_last_last_break = $i_last_break;
+ $i_last_break = $i;
+ }
+
+ # don't break before a small last term -- it will
+ # not look good on a line by itself.
+ elsif ($i == $i_max
+ && $i_last_break == $i - 1
+ && $weighted_length <= $definitely_simple )
+ {
+ pop @i_ragged_break_list;
+ }
+ }
+
+ my $identifier_count = $i_max + 1 - $quote_count;
+
+ # Need more tuning here..
+ if ( $max_width > 12
+ && $complex_item_count > $item_count / 2
+ && $number_of_fields_best != 2 )
+ {
+ $number_of_fields_best = 1;
+ }
+
+ return ( $number_of_fields_best, \@i_ragged_break_list, $identifier_count );
+}
+
+sub get_maximum_fields_wanted {
+
+ # Not all tables look good with more than one field of items.
+ # This routine looks at a table and decides if it should be
+ # formatted with just one field or not.
+ # This coding is still under development.
+ my ($ritem_lengths) = @_;
+
+ my $number_of_fields_best = 0;
+
+ # For just a few items, we tentatively assume just 1 field.
+ my $item_count = @{$ritem_lengths};
+ if ( $item_count <= 5 ) {
+ $number_of_fields_best = 1;
+ }
+
+ # For larger tables, look at it both ways and see what looks best
+ else {
+
+ my $is_odd = 1;
+ my @max_length = ( 0, 0 );
+ my @last_length_2 = ( undef, undef );
+ my @first_length_2 = ( undef, undef );
+ my $last_length = undef;
+ my $total_variation_1 = 0;
+ my $total_variation_2 = 0;
+ my @total_variation_2 = ( 0, 0 );
+
+ foreach my $j ( 0 .. $item_count - 1 ) {
+
+ $is_odd = 1 - $is_odd;
+ my $length = $ritem_lengths->[$j];
+ if ( $length > $max_length[$is_odd] ) {
+ $max_length[$is_odd] = $length;
+ }
+
+ if ( defined($last_length) ) {
+ my $dl = abs( $length - $last_length );
+ $total_variation_1 += $dl;
+ }
+ $last_length = $length;
+
+ my $ll = $last_length_2[$is_odd];
+ if ( defined($ll) ) {
+ my $dl = abs( $length - $ll );
+ $total_variation_2[$is_odd] += $dl;
+ }
+ else {
+ $first_length_2[$is_odd] = $length;
+ }
+ $last_length_2[$is_odd] = $length;
+ }
+ $total_variation_2 = $total_variation_2[0] + $total_variation_2[1];
+
+ my $factor = ( $item_count > 10 ) ? 1 : ( $item_count > 5 ) ? 0.75 : 0;
+ unless ( $total_variation_2 < $factor * $total_variation_1 ) {
+ $number_of_fields_best = 1;
+ }
+ }
+ return ($number_of_fields_best);
+}
+
+sub table_columns_available {
+ my $i_first_comma = shift;
+ my $columns =
+ $maximum_line_length_at_level[ $levels_to_go[$i_first_comma] ] -
+ leading_spaces_to_go($i_first_comma);
+
+ # Patch: the vertical formatter does not line up lines whose lengths
+ # exactly equal the available line length because of allowances
+ # that must be made for side comments. Therefore, the number of
+ # available columns is reduced by 1 character.
+ $columns -= 1;
+ return $columns;
+}
+
+sub maximum_number_of_fields {
+
+ # how many fields will fit in the available space?
+ my ( $columns, $odd_or_even, $max_width, $pair_width ) = @_;
+ my $max_pairs = int( $columns / $pair_width );
+ my $number_of_fields = $max_pairs * 2;
+ if ( $odd_or_even == 1
+ && $max_pairs * $pair_width + $max_width <= $columns )
+ {
+ $number_of_fields++;
+ }
+ return $number_of_fields;
+}
+
+sub compactify_table {
+
+ # given a table with a certain number of fields and a certain number
+ # of lines, see if reducing the number of fields will make it look
+ # better.
+ my ( $item_count, $number_of_fields, $formatted_lines, $odd_or_even ) = @_;
+ if ( $number_of_fields >= $odd_or_even * 2 && $formatted_lines > 0 ) {
+ my $min_fields;
+
+ for (
+ $min_fields = $number_of_fields ;
+ $min_fields >= $odd_or_even
+ && $min_fields * $formatted_lines >= $item_count ;
+ $min_fields -= $odd_or_even
+ )
+ {
+ $number_of_fields = $min_fields;
+ }
+ }
+ return $number_of_fields;
+}
+
+sub set_ragged_breakpoints {
+
+ # Set breakpoints in a list that cannot be formatted nicely as a
+ # table.
+ my ( $self, $ri_term_comma, $ri_ragged_break_list ) = @_;
+
+ my $break_count = 0;
+ foreach ( @{$ri_ragged_break_list} ) {
+ my $j = $ri_term_comma->[$_];
+ if ($j) {
+ $self->set_forced_breakpoint($j);
+ $break_count++;
+ }
+ }
+ return $break_count;
+}
+
+sub copy_old_breakpoints {
+ my ( $self, $i_first_comma, $i_last_comma ) = @_;
+ for my $i ( $i_first_comma .. $i_last_comma ) {
+ if ( $old_breakpoint_to_go[$i] ) {
+ $self->set_forced_breakpoint($i);
+ }
+ }
+ return;
+}
+
+sub set_nobreaks {
+ my ( $self, $i, $j ) = @_;
+ if ( $i >= 0 && $i <= $j && $j <= $max_index_to_go ) {
+
+ 0 && do {
+ my ( $a, $b, $c ) = caller();
+ my $forced_breakpoint_count = get_forced_breakpoint_count();
+ print STDOUT
+"NOBREAK: forced_breakpoint $forced_breakpoint_count from $a $c with i=$i max=$max_index_to_go type=$types_to_go[$i]\n";
+ };
+
+ @nobreak_to_go[ $i .. $j ] = (1) x ( $j - $i + 1 );
+ }
+
+ # shouldn't happen; non-critical error
+ else {
+ 0 && do {
+ my ( $a, $b, $c ) = caller();
+ print STDOUT
+ "NOBREAK ERROR: from $a $c with i=$i j=$j max=$max_index_to_go\n";
+ };
+ }
+ return;
+}
+
+###############################################
+# CODE SECTION 12: Code for setting indentation
+###############################################
+
+sub token_sequence_length {
+
+ # return length of tokens ($ibeg .. $iend) including $ibeg & $iend
+ # returns 0 if $ibeg > $iend (shouldn't happen)
+ my ( $ibeg, $iend ) = @_;
+ return 0 if ( !defined($iend) || $iend < 0 || $ibeg > $iend );
+ return $summed_lengths_to_go[ $iend + 1 ] if ( $ibeg < 0 );
+ return $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
+}
+
+sub total_line_length {
+
+ # return length of a line of tokens ($ibeg .. $iend)
+ my ( $ibeg, $iend ) = @_;
+
+ # original coding:
+ #return leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
+
+ # this is basically sub 'leading_spaces_to_go':
+ my $indentation = $leading_spaces_to_go[$ibeg];
+ if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
+
+ return $indentation + $summed_lengths_to_go[ $iend + 1 ] -
+ $summed_lengths_to_go[$ibeg];
+}
+
+sub excess_line_length {
+
+ # return number of characters by which a line of tokens ($ibeg..$iend)
+ # exceeds the allowable line length.
+
+ # NOTE: Profiling shows that this is a critical routine for efficiency.
+ # Therefore I have eliminated additional calls to subs from it.
+ my ( $self, $ibeg, $iend, $ignore_right_weld ) = @_;
+
+ # Original expression for line length
+ ##$length = leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
+
+ # This is basically sub 'leading_spaces_to_go':
+ my $indentation = $leading_spaces_to_go[$ibeg];
+ if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
+
+ my $length =
+ $indentation +
+ $summed_lengths_to_go[ $iend + 1 ] -
+ $summed_lengths_to_go[$ibeg];
+
+ # Include right weld lengths unless requested not to.
+ if ( $total_weld_count
+ && !$ignore_right_weld
+ && $type_sequence_to_go[$iend] )
+ {
+ my $wr = $self->[_rweld_len_right_at_K_]->{ $K_to_go[$iend] };
+ $length += $wr if defined($wr);
+ }
+
+ # return the excess
+ return $length - $maximum_line_length_at_level[ $levels_to_go[$ibeg] ];
+}
+
+sub get_spaces {
+
+ # return the number of leading spaces associated with an indentation
+ # variable $indentation is either a constant number of spaces or an object
+ # with a get_spaces method.
+ my $indentation = shift;
+ return ref($indentation) ? $indentation->get_spaces() : $indentation;
+}
+
+sub get_recoverable_spaces {
+
+ # return the number of spaces (+ means shift right, - means shift left)
+ # that we would like to shift a group of lines with the same indentation
+ # to get them to line up with their opening parens
+ my $indentation = shift;
+ return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
+}
+
+sub get_available_spaces_to_go {
+
+ my ( $self, $ii ) = @_;
+ my $item = $leading_spaces_to_go[$ii];
+
+ # return the number of available leading spaces associated with an
+ # indentation variable. $indentation is either a constant number of
+ # spaces or an object with a get_available_spaces method.
+ return ref($item) ? $item->get_available_spaces() : 0;
+}
+
+{ ## begin closure set_leading_whitespace (for -lp indentation)
+
+ # These routines are called batch-by-batch to handle the -lp indentation
+ # option. The coding is rather complex, but is only for -lp.
+
+ my $gnu_position_predictor;
+ my $gnu_sequence_number;
+ my $line_start_index_to_go;
+ my $max_gnu_item_index;
+ my $max_gnu_stack_index;
+ my %gnu_arrow_count;
+ my %gnu_comma_count;
+ my %last_gnu_equals;
+ my @gnu_item_list;
+ my @gnu_stack;
+
+ sub initialize_gnu_vars {
+
+ # initialize gnu variables for a new file;
+ # must be called once at the start of a new file.
+
+ # initialize the leading whitespace stack to negative levels
+ # so that we can never run off the end of the stack
+ $gnu_position_predictor =
+ 0; # where the current token is predicted to be
+ $max_gnu_stack_index = 0;
+ $max_gnu_item_index = -1;
+ $gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
+ @gnu_item_list = ();
+ return;
+ }
+
+ sub initialize_gnu_batch_vars {
+
+ # initialize gnu variables for a new batch;
+ # must be called before each new batch
+ $gnu_sequence_number++; # increment output batch counter
+ %last_gnu_equals = ();
+ %gnu_comma_count = ();
+ %gnu_arrow_count = ();
+ $line_start_index_to_go = 0;
+ $max_gnu_item_index = UNDEFINED_INDEX;
+ return;
+ }
+
+ sub new_lp_indentation_item {
+
+ # this is an interface to the IndentationItem class
+ my ( $spaces, $level, $ci_level, $available_spaces, $align_paren ) = @_;
+
+ # A negative level implies not to store the item in the item_list
+ my $index = 0;
+ if ( $level >= 0 ) { $index = ++$max_gnu_item_index; }
+
+ my $starting_index_K = 0;
+ if ( defined($line_start_index_to_go)
+ && $line_start_index_to_go >= 0
+ && $line_start_index_to_go <= $max_index_to_go )
+ {
+ $starting_index_K = $K_to_go[$line_start_index_to_go];
+ }
+
+ my $item = Perl::Tidy::IndentationItem->new(
+ spaces => $spaces,
+ level => $level,
+ ci_level => $ci_level,
+ available_spaces => $available_spaces,
+ index => $index,
+ gnu_sequence_number => $gnu_sequence_number,
+ align_paren => $align_paren,
+ stack_depth => $max_gnu_stack_index,
+ starting_index_K => $starting_index_K,
+ );
+
+ if ( $level >= 0 ) {
+ $gnu_item_list[$max_gnu_item_index] = $item;
+ }
+
+ return $item;
+ }
+
+ sub set_leading_whitespace {
+
+ # This routine defines leading whitespace for the case of -lp formatting
+ # given: the level and continuation_level of a token,
+ # define: space count of leading string which would apply if it
+ # were the first token of a new line.
+
+ my ( $self, $Kj, $K_last_nonblank, $K_last_last_nonblank,
+ $level_abs, $ci_level, $in_continued_quote )
+ = @_;
+
+ return unless ($rOpts_line_up_parentheses);
+ return unless ( defined($max_index_to_go) && $max_index_to_go >= 0 );
+
+ my $rbreak_container = $self->[_rbreak_container_];
+ my $rshort_nested = $self->[_rshort_nested_];
+ my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
+ my $rLL = $self->[_rLL_];
+ my $rbreak_before_container_by_seqno =
+ $self->[_rbreak_before_container_by_seqno_];
+
+ # find needed previous nonblank tokens
+ my $last_nonblank_token = '';
+ my $last_nonblank_type = '';
+ my $last_nonblank_block_type = '';
+
+ # and previous nonblank tokens, just in this batch:
+ my $last_nonblank_token_in_batch = '';
+ my $last_nonblank_type_in_batch = '';
+ my $last_last_nonblank_type_in_batch = '';
+
+ if ( defined($K_last_nonblank) ) {
+ $last_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
+ $last_nonblank_type = $rLL->[$K_last_nonblank]->[_TYPE_];
+ $last_nonblank_block_type =
+ $rLL->[$K_last_nonblank]->[_BLOCK_TYPE_];
+
+ if ( $K_last_nonblank >= $K_to_go[0] ) {
+ $last_nonblank_token_in_batch = $last_nonblank_token;
+ $last_nonblank_type_in_batch = $last_nonblank_type;
+ if ( defined($K_last_last_nonblank)
+ && $K_last_last_nonblank > $K_to_go[0] )
+ {
+ $last_last_nonblank_type_in_batch =
+ $rLL->[$K_last_last_nonblank]->[_TYPE_];
+ }
+ }
+ }
+
+ ################################################################
+
+ # Adjust levels if necessary to recycle whitespace:
+ my $level = $level_abs;
+ my $radjusted_levels = $self->[_radjusted_levels_];
+ my $nK = @{$rLL};
+ my $nws = @{$radjusted_levels};
+ if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
+ $level = $radjusted_levels->[$Kj];
+ if ( $level < 0 ) { $level = 0 } # note: this should not happen
+ }
+
+ # The continued_quote flag means that this is the first token of a
+ # line, and it is the continuation of some kind of multi-line quote
+ # or pattern. It requires special treatment because it must have no
+ # added leading whitespace. So we create a special indentation item
+ # which is not in the stack.
+ if ($in_continued_quote) {
+ my $space_count = 0;
+ my $available_space = 0;
+ $level = -1; # flag to prevent storing in item_list
+ $leading_spaces_to_go[$max_index_to_go] =
+ $reduced_spaces_to_go[$max_index_to_go] =
+ new_lp_indentation_item( $space_count, $level, $ci_level,
+ $available_space, 0 );
+ return;
+ }
+
+ # get the top state from the stack
+ my $space_count = $gnu_stack[$max_gnu_stack_index]->get_spaces();
+ my $current_level = $gnu_stack[$max_gnu_stack_index]->get_level();
+ my $current_ci_level = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
+
+ my $type = $types_to_go[$max_index_to_go];
+ my $token = $tokens_to_go[$max_index_to_go];
+ my $total_depth = $nesting_depth_to_go[$max_index_to_go];
+
+ if ( $type eq '{' || $type eq '(' ) {
+
+ $gnu_comma_count{ $total_depth + 1 } = 0;
+ $gnu_arrow_count{ $total_depth + 1 } = 0;
+
+ # If we come to an opening token after an '=' token of some type,
+ # see if it would be helpful to 'break' after the '=' to save space
+ my $last_equals = $last_gnu_equals{$total_depth};
+ if ( $last_equals && $last_equals > $line_start_index_to_go ) {
+
+ my $seqno = $type_sequence_to_go[$max_index_to_go];
+
+ # find the position if we break at the '='
+ my $i_test = $last_equals;
+ if ( $types_to_go[ $i_test + 1 ] eq 'b' ) { $i_test++ }
+
+ # TESTING
+ ##my $too_close = ($i_test==$max_index_to_go-1);
+
+ my $test_position =
+ total_line_length( $i_test, $max_index_to_go );
+ my $mll =
+ $maximum_line_length_at_level[ $levels_to_go[$i_test] ];
+
+ my $bbc_flag = $break_before_container_types{$token};
+
+ if (
+
+ # the equals is not just before an open paren (testing)
+ ##!$too_close &&
+
+ # if we are beyond the midpoint
+ $gnu_position_predictor >
+ $mll - $rOpts_maximum_line_length / 2
+
+ # if a -bbx flag WANTS a break before this opening token
+ || ( $seqno && $rbreak_before_container_by_seqno->{$seqno} )
+
+ # or if we MIGHT want a break (fixes case b826 b909 b989)
+ || ( $bbc_flag && $bbc_flag >= 2 )
+
+ # or we are beyond the 1/4 point and there was an old
+ # break at an assignment (not '=>') [fix for b1035]
+ || (
+ $gnu_position_predictor >
+ $mll - $rOpts_maximum_line_length * 3 / 4
+ && $types_to_go[$last_equals] ne '=>'
+ && (
+ $old_breakpoint_to_go[$last_equals]
+ || ( $last_equals > 0
+ && $old_breakpoint_to_go[ $last_equals - 1 ] )
+ || ( $last_equals > 1
+ && $types_to_go[ $last_equals - 1 ] eq 'b'
+ && $old_breakpoint_to_go[ $last_equals - 2 ] )
+ )
+ )
+ )
+ {
+
+ # then make the switch -- note that we do not set a real
+ # breakpoint here because we may not really need one; sub
+ # scan_list will do that if necessary
+ $line_start_index_to_go = $i_test + 1;
+ $gnu_position_predictor = $test_position;
+ }
+ }
+ }
+
+ my $halfway =
+ $maximum_line_length_at_level[$level] -
+ $rOpts_maximum_line_length / 2;
+
+ # Check for decreasing depth ..
+ # Note that one token may have both decreasing and then increasing
+ # depth. For example, (level, ci) can go from (1,1) to (2,0). So,
+ # in this example we would first go back to (1,0) then up to (2,0)
+ # in a single call.
+ if ( $level < $current_level || $ci_level < $current_ci_level ) {
+
+ # loop to find the first entry at or completely below this level
+ my ( $lev, $ci_lev );
+ while (1) {
+ if ($max_gnu_stack_index) {
+
+ # save index of token which closes this level
+ $gnu_stack[$max_gnu_stack_index]
+ ->set_closed($max_index_to_go);
+
+ # Undo any extra indentation if we saw no commas
+ my $available_spaces =
+ $gnu_stack[$max_gnu_stack_index]->get_available_spaces();
+
+ my $comma_count = 0;
+ my $arrow_count = 0;
+ if ( $type eq '}' || $type eq ')' ) {
+ $comma_count = $gnu_comma_count{$total_depth};
+ $arrow_count = $gnu_arrow_count{$total_depth};
+ $comma_count = 0 unless $comma_count;
+ $arrow_count = 0 unless $arrow_count;
+ }
+ $gnu_stack[$max_gnu_stack_index]
+ ->set_comma_count($comma_count);
+ $gnu_stack[$max_gnu_stack_index]
+ ->set_arrow_count($arrow_count);
+
+ if ( $available_spaces > 0 ) {
+
+ if ( $comma_count <= 0 || $arrow_count > 0 ) {
+
+ my $i =
+ $gnu_stack[$max_gnu_stack_index]->get_index();
+ my $seqno =
+ $gnu_stack[$max_gnu_stack_index]
+ ->get_sequence_number();
+
+ # Be sure this item was created in this batch. This
+ # should be true because we delete any available
+ # space from open items at the end of each batch.
+ if ( $gnu_sequence_number != $seqno
+ || $i > $max_gnu_item_index )
+ {
+ warning(
+"Program bug with -lp. seqno=$seqno should be $gnu_sequence_number and i=$i should be less than max=$max_gnu_item_index\n"
+ );
+ report_definite_bug();
+ }
+
+ else {
+ if ( $arrow_count == 0 ) {
+ $gnu_item_list[$i]
+ ->permanently_decrease_available_spaces(
+ $available_spaces);
+ }
+ else {
+ $gnu_item_list[$i]
+ ->tentatively_decrease_available_spaces(
+ $available_spaces);
+ }
+ foreach my $j ( $i + 1 .. $max_gnu_item_index )
+ {
+ $gnu_item_list[$j]
+ ->decrease_SPACES($available_spaces);
+ }
+ }
+ }
+ }
+
+ # go down one level
+ --$max_gnu_stack_index;
+ $lev = $gnu_stack[$max_gnu_stack_index]->get_level();
+ $ci_lev = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
+
+ # stop when we reach a level at or below the current level
+ if ( $lev <= $level && $ci_lev <= $ci_level ) {
+ $space_count =
+ $gnu_stack[$max_gnu_stack_index]->get_spaces();
+ $current_level = $lev;
+ $current_ci_level = $ci_lev;
+ last;
+ }
+ }
+
+ # reached bottom of stack .. should never happen because
+ # only negative levels can get here, and $level was forced
+ # to be positive above.
+ else {
+ warning(
+"program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp\n"
+ );
+ report_definite_bug();
+ last;
+ }
+ }
+ }
+
+ # handle increasing depth
+ if ( $level > $current_level || $ci_level > $current_ci_level ) {
+
+ # Compute the standard incremental whitespace. This will be
+ # the minimum incremental whitespace that will be used. This
+ # choice results in a smooth transition between the gnu-style
+ # and the standard style.
+ my $standard_increment =
+ ( $level - $current_level ) *
+ $rOpts_indent_columns +
+ ( $ci_level - $current_ci_level ) *
+ $rOpts_continuation_indentation;
+
+ # Now we have to define how much extra incremental space
+ # ("$available_space") we want. This extra space will be
+ # reduced as necessary when long lines are encountered or when
+ # it becomes clear that we do not have a good list.
+ my $available_space = 0;
+ my $align_paren = 0;
+ my $excess = 0;
+
+ my $last_nonblank_seqno;
+ if ( defined($K_last_nonblank) ) {
+ $last_nonblank_seqno =
+ $rLL->[$K_last_nonblank]->[_TYPE_SEQUENCE_];
+ }
+
+ # initialization on empty stack..
+ if ( $max_gnu_stack_index == 0 ) {
+ $space_count = $level * $rOpts_indent_columns;
+ }
+
+ # if this is a BLOCK, add the standard increment
+ elsif ($last_nonblank_block_type) {
+ $space_count += $standard_increment;
+ }
+
+ # add the standard increment for containers excluded by user rules
+ # or which contain here-docs or multiline qw text
+ elsif ( defined($last_nonblank_seqno)
+ && $ris_excluded_lp_container->{$last_nonblank_seqno} )
+ {
+ $space_count += $standard_increment;
+ }
+
+ # if last nonblank token was not structural indentation,
+ # just use standard increment
+ elsif ( $last_nonblank_type ne '{' ) {
+ $space_count += $standard_increment;
+ }
+
+ # otherwise use the space to the first non-blank level change token
+ else {
+
+ $space_count = $gnu_position_predictor;
+
+ my $min_gnu_indentation =
+ $gnu_stack[$max_gnu_stack_index]->get_spaces();
+
+ $available_space = $space_count - $min_gnu_indentation;
+ if ( $available_space >= $standard_increment ) {
+ $min_gnu_indentation += $standard_increment;
+ }
+ elsif ( $available_space > 1 ) {
+ $min_gnu_indentation += $available_space + 1;
+ }
+ elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
+ if ( ( $tightness{$last_nonblank_token} < 2 ) ) {
+ $min_gnu_indentation += 2;
+ }
+ else {
+ $min_gnu_indentation += 1;
+ }
+ }
+ else {
+ $min_gnu_indentation += $standard_increment;
+ }
+ $available_space = $space_count - $min_gnu_indentation;
+
+ if ( $available_space < 0 ) {
+ $space_count = $min_gnu_indentation;
+ $available_space = 0;
+ }
+ $align_paren = 1;
+ }
+
+ # update state, but not on a blank token
+ if ( $types_to_go[$max_index_to_go] ne 'b' ) {
+
+ $gnu_stack[$max_gnu_stack_index]->set_have_child(1);
+
+ ++$max_gnu_stack_index;
+ $gnu_stack[$max_gnu_stack_index] =
+ new_lp_indentation_item( $space_count, $level, $ci_level,
+ $available_space, $align_paren );
+
+ # If the opening paren is beyond the half-line length, then
+ # we will use the minimum (standard) indentation. This will
+ # help avoid problems associated with running out of space
+ # near the end of a line. As a result, in deeply nested
+ # lists, there will be some indentations which are limited
+ # to this minimum standard indentation. But the most deeply
+ # nested container will still probably be able to shift its
+ # parameters to the right for proper alignment, so in most
+ # cases this will not be noticeable.
+ if ( $available_space > 0 && $space_count > $halfway ) {
+ $gnu_stack[$max_gnu_stack_index]
+ ->tentatively_decrease_available_spaces($available_space);
+ }
+ }
+ }
+
+ # Count commas and look for non-list characters. Once we see a
+ # non-list character, we give up and don't look for any more commas.
+ if ( $type eq '=>' ) {
+ $gnu_arrow_count{$total_depth}++;
+
+ # remember '=>' like '=' for estimating breaks (but see above note
+ # for b1035)
+ $last_gnu_equals{$total_depth} = $max_index_to_go;
+ }
+
+ elsif ( $type eq ',' ) {
+ $gnu_comma_count{$total_depth}++;
+ }
+
+ elsif ( $is_assignment{$type} ) {
+ $last_gnu_equals{$total_depth} = $max_index_to_go;
+ }
+
+ # this token might start a new line
+ # if this is a non-blank..
+ if ( $type ne 'b' ) {
+
+ # and if ..
+ if (
+
+ # this is the first nonblank token of the line
+ $max_index_to_go == 1 && $types_to_go[0] eq 'b'
+
+ # or previous character was one of these:
+ || $last_nonblank_type_in_batch =~ /^([\:\?\,f])$/
+
+ # or previous character was opening and this does not close it
+ || ( $last_nonblank_type_in_batch eq '{' && $type ne '}' )
+ || ( $last_nonblank_type_in_batch eq '(' and $type ne ')' )
+
+ # or this token is one of these:
+ || $type =~ /^([\.]|\|\||\&\&)$/
+
+ # or this is a closing structure
+ || ( $last_nonblank_type_in_batch eq '}'
+ && $last_nonblank_token_in_batch eq
+ $last_nonblank_type_in_batch )
+
+ # or previous token was keyword 'return'
+ || (
+ $last_nonblank_type_in_batch eq 'k'
+ && ( $last_nonblank_token_in_batch eq 'return'
+ && $type ne '{' )
+ )
+
+ # or starting a new line at certain keywords is fine
+ || ( $type eq 'k'
+ && $is_if_unless_and_or_last_next_redo_return{$token} )
+
+ # or this is after an assignment after a closing structure
+ || (
+ $is_assignment{$last_nonblank_type_in_batch}
+ && (
+ $last_last_nonblank_type_in_batch =~ /^[\}\)\]]$/
+
+ # and it is significantly to the right
+ || $gnu_position_predictor > $halfway
+ )
+ )
+ )
+ {
+ check_for_long_gnu_style_lines($max_index_to_go);
+ $line_start_index_to_go = $max_index_to_go;
+
+ # back up 1 token if we want to break before that type
+ # otherwise, we may strand tokens like '?' or ':' on a line
+ if ( $line_start_index_to_go > 0 ) {
+ if ( $last_nonblank_type_in_batch eq 'k' ) {
+
+ if ( $want_break_before{$last_nonblank_token_in_batch} )
+ {
+ $line_start_index_to_go--;
+ }
+ }
+ elsif ( $want_break_before{$last_nonblank_type_in_batch} ) {
+ $line_start_index_to_go--;
+ }
+ }
+ }
+ }
+
+ # remember the predicted position of this token on the output line
+ if ( $max_index_to_go > $line_start_index_to_go ) {
+ $gnu_position_predictor =
+ total_line_length( $line_start_index_to_go, $max_index_to_go );
+ }
+ else {
+ $gnu_position_predictor =
+ $space_count + $token_lengths_to_go[$max_index_to_go];
+ }
+
+ # store the indentation object for this token
+ # this allows us to manipulate the leading whitespace
+ # (in case we have to reduce indentation to fit a line) without
+ # having to change any token values
+ $leading_spaces_to_go[$max_index_to_go] =
+ $gnu_stack[$max_gnu_stack_index];
+ $reduced_spaces_to_go[$max_index_to_go] =
+ ( $max_gnu_stack_index > 0 && $ci_level )
+ ? $gnu_stack[ $max_gnu_stack_index - 1 ]
+ : $gnu_stack[$max_gnu_stack_index];
+ return;
+ }
+
+ sub check_for_long_gnu_style_lines {
+
+ # look at the current estimated maximum line length, and
+ # remove some whitespace if it exceeds the desired maximum
+ my ($mx_index_to_go) = @_;
+
+ # this is only for the '-lp' style
+ return unless ($rOpts_line_up_parentheses);
+
+ # nothing can be done if no stack items defined for this line
+ return if ( $max_gnu_item_index == UNDEFINED_INDEX );
+
+ # see if we have exceeded the maximum desired line length
+ # keep 2 extra free because they are needed in some cases
+ # (result of trial-and-error testing)
+ my $spaces_needed =
+ $gnu_position_predictor -
+ $maximum_line_length_at_level[ $levels_to_go[$mx_index_to_go] ] + 2;
+
+ return if ( $spaces_needed <= 0 );
+
+ # We are over the limit, so try to remove a requested number of
+ # spaces from leading whitespace. We are only allowed to remove
+ # from whitespace items created on this batch, since others have
+ # already been used and cannot be undone.
+ my @candidates = ();
+ my $i;
+
+ # loop over all whitespace items created for the current batch
+ for ( $i = 0 ; $i <= $max_gnu_item_index ; $i++ ) {
+ my $item = $gnu_item_list[$i];
+
+ # item must still be open to be a candidate (otherwise it
+ # cannot influence the current token)
+ next if ( $item->get_closed() >= 0 );
+
+ my $available_spaces = $item->get_available_spaces();
+
+ if ( $available_spaces > 0 ) {
+ push( @candidates, [ $i, $available_spaces ] );
+ }
+ }
+
+ return unless (@candidates);
+
+ # sort by available whitespace so that we can remove whitespace
+ # from the maximum available first
+ @candidates = sort { $b->[1] <=> $a->[1] } @candidates;
+
+ # keep removing whitespace until we are done or have no more
+ foreach my $candidate (@candidates) {
+ my ( $i, $available_spaces ) = @{$candidate};
+ my $deleted_spaces =
+ ( $available_spaces > $spaces_needed )
+ ? $spaces_needed
+ : $available_spaces;
+
+ # remove the incremental space from this item
+ $gnu_item_list[$i]->decrease_available_spaces($deleted_spaces);
+
+ my $i_debug = $i;
+
+ # update the leading whitespace of this item and all items
+ # that came after it
+ for ( ; $i <= $max_gnu_item_index ; $i++ ) {
+
+ my $old_spaces = $gnu_item_list[$i]->get_spaces();
+ if ( $old_spaces >= $deleted_spaces ) {
+ $gnu_item_list[$i]->decrease_SPACES($deleted_spaces);
+ }
+
+ # shouldn't happen except for code bug:
+ else {
+ my $level = $gnu_item_list[$i_debug]->get_level();
+ my $ci_level = $gnu_item_list[$i_debug]->get_ci_level();
+ my $old_level = $gnu_item_list[$i]->get_level();
+ my $old_ci_level = $gnu_item_list[$i]->get_ci_level();
+ warning(
+"program bug with -lp: want to delete $deleted_spaces from item $i, but old=$old_spaces deleted: lev=$level ci=$ci_level deleted: level=$old_level ci=$ci_level\n"
+ );
+ report_definite_bug();
+ }
+ }
+ $gnu_position_predictor -= $deleted_spaces;
+ $spaces_needed -= $deleted_spaces;
+ last unless ( $spaces_needed > 0 );
+ }
+ return;
+ }
+
+ sub finish_lp_batch {
+
+ # This routine is called once after each output stream batch is
+ # finished to undo indentation for all incomplete -lp
+ # indentation levels. It is too risky to leave a level open,
+ # because then we can't backtrack in case of a long line to follow.
+ # This means that comments and blank lines will disrupt this
+ # indentation style. But the vertical aligner may be able to
+ # get the space back if there are side comments.
+
+ # this is only for the 'lp' style
+ return unless ($rOpts_line_up_parentheses);
+
+ # nothing can be done if no stack items defined for this line
+ return if ( $max_gnu_item_index == UNDEFINED_INDEX );
+
+ # loop over all whitespace items created for the current batch
+ foreach my $i ( 0 .. $max_gnu_item_index ) {
+ my $item = $gnu_item_list[$i];
+
+ # only look for open items
+ next if ( $item->get_closed() >= 0 );
+
+ # Tentatively remove all of the available space
+ # (The vertical aligner will try to get it back later)
+ my $available_spaces = $item->get_available_spaces();
+ if ( $available_spaces > 0 ) {
+
+ # delete incremental space for this item
+ $gnu_item_list[$i]
+ ->tentatively_decrease_available_spaces($available_spaces);
+
+ # Reduce the total indentation space of any nodes that follow
+ # Note that any such nodes must necessarily be dependents
+ # of this node.
+ foreach ( $i + 1 .. $max_gnu_item_index ) {
+ $gnu_item_list[$_]->decrease_SPACES($available_spaces);
+ }
+ }
+ }
+ return;
+ }
+} ## end closure set_leading_whitespace
+
+sub reduce_lp_indentation {
+
+ # reduce the leading whitespace at token $i if possible by $spaces_needed
+ # (a large value of $spaces_needed will remove all excess space)
+ # NOTE: to be called from scan_list only for a sequence of tokens
+ # contained between opening and closing parens/braces/brackets
+
+ my ( $self, $i, $spaces_wanted ) = @_;
+ my $deleted_spaces = 0;
+
+ my $item = $leading_spaces_to_go[$i];
+ my $available_spaces = $item->get_available_spaces();
+
+ if (
+ $available_spaces > 0
+ && ( ( $spaces_wanted <= $available_spaces )
+ || !$item->get_have_child() )
+ )
+ {
+
+ # we'll remove these spaces, but mark them as recoverable
+ $deleted_spaces =
+ $item->tentatively_decrease_available_spaces($spaces_wanted);
+ }
+
+ return $deleted_spaces;
+}
+
+###########################################################
+# CODE SECTION 13: Preparing batches for vertical alignment
+###########################################################
+
+sub send_lines_to_vertical_aligner {
+
+ my ($self) = @_;
+
+ # This routine receives a batch of code for which the final line breaks
+ # have been defined. Here we prepare the lines for passing to the vertical
+ # aligner. We do the following tasks:
+ # - mark certain vertical alignment tokens, such as '=', in each line
+ # - make minor indentation adjustments
+ # - do logical padding: insert extra blank spaces to help display certain
+ # logical constructions
+
+ my $this_batch = $self->[_this_batch_];
+ my $rlines_K = $this_batch->[_rlines_K_];
+ if ( !@{$rlines_K} ) {
+
+ # This can't happen because sub grind_batch_of_CODE always receives
+ # tokens which it turns into one or more lines. If we get here it means
+ # that a programming error has caused those lines to be lost.
+ Fault("Unexpected call with no lines");
+ return;
+ }
+ my $n_last_line = @{$rlines_K} - 1;
+
+ my $do_not_pad = $this_batch->[_do_not_pad_];
+ my $peak_batch_size = $this_batch->[_peak_batch_size_];
+ my $starting_in_quote = $this_batch->[_starting_in_quote_];
+ my $ending_in_quote = $this_batch->[_ending_in_quote_];
+ my $is_static_block_comment = $this_batch->[_is_static_block_comment_];
+ my $ibeg0 = $this_batch->[_ibeg0_];
+ my $rK_to_go = $this_batch->[_rK_to_go_];
+ my $batch_count = $this_batch->[_batch_count_];
+ my $rix_seqno_controlling_ci = $this_batch->[_rix_seqno_controlling_ci_];
+
+ my $rLL = $self->[_rLL_];
+ my $Klimit = $self->[_Klimit_];
+
+ my ( $Kbeg_next, $Kend_next ) = @{ $rlines_K->[0] };
+ my $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
+ my $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
+ my $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
+
+ # Construct indexes to the global_to_go arrays so that called routines can
+ # still access those arrays. This might eventually be removed
+ # when all called routines have been converted to access token values
+ # in the rLL array instead.
+ my $Kbeg0 = $Kbeg_next;
+ my ( $ri_first, $ri_last );
+ foreach my $rline ( @{$rlines_K} ) {
+ my ( $Kbeg, $Kend ) = @{$rline};
+ my $ibeg = $ibeg0 + $Kbeg - $Kbeg0;
+ my $iend = $ibeg0 + $Kend - $Kbeg0;
+ push @{$ri_first}, $ibeg;
+ push @{$ri_last}, $iend;
+ }
+
+ my ( $cscw_block_comment, $closing_side_comment );
+ if ( $rOpts->{'closing-side-comments'} ) {
+ ( $closing_side_comment, $cscw_block_comment ) =
+ $self->add_closing_side_comment();
+ }
+
+ my $rindentation_list = [0]; # ref to indentations for each line
+
+ # define the array @{$ralignment_type_to_go} for the output tokens
+ # which will be non-blank for each special token (such as =>)
+ # for which alignment is required.
+ my $ralignment_type_to_go =
+ $self->set_vertical_alignment_markers( $ri_first, $ri_last );
+
+ # flush before a long if statement to avoid unwanted alignment
+ if ( $n_last_line > 0
+ && $type_beg_next eq 'k'
+ && $token_beg_next =~ /^(if|unless)$/ )
+ {
+ $self->flush_vertical_aligner();
+ }
+
+ $self->undo_ci( $ri_first, $ri_last, $rix_seqno_controlling_ci );
+
+ $self->set_logical_padding( $ri_first, $ri_last, $peak_batch_size,
+ $starting_in_quote )
+ if ( $rOpts->{'logical-padding'} );
+
+ # Resum lengths. We need accurate lengths for making alignment patterns,
+ # and we may have unmasked a semicolon which was not included at the start.
+ for ( 0 .. $max_index_to_go ) {
+ $summed_lengths_to_go[ $_ + 1 ] =
+ $summed_lengths_to_go[$_] + $token_lengths_to_go[$_];
+ }
+
+ # loop to prepare each line for shipment
+ my ( $Kbeg, $type_beg, $token_beg );
+ my ( $Kend, $type_end );
+ for my $n ( 0 .. $n_last_line ) {
+
+ my $ibeg = $ri_first->[$n];
+ my $iend = $ri_last->[$n];
+ my $rline = $rlines_K->[$n];
+ my $forced_breakpoint = $rline->[2];
+
+ # we may need to look at variables on three consecutive lines ...
+
+ # Some vars on line [n-1], if any:
+ my $Kbeg_last = $Kbeg;
+ my $type_beg_last = $type_beg;
+ my $token_beg_last = $token_beg;
+ my $Kend_last = $Kend;
+ my $type_end_last = $type_end;
+
+ # Some vars on line [n]:
+ $Kbeg = $Kbeg_next;
+ $type_beg = $type_beg_next;
+ $token_beg = $token_beg_next;
+ $Kend = $Kend_next;
+ $type_end = $type_end_next;
+
+ # Only forward ending K values of non-comments down the pipeline.
+ # This is equivalent to checking that the last CODE_type is blank or
+ # equal to 'VER'. See also sub resync_lines_and_tokens for related
+ # coding. Note that '$batch_CODE_type' is the code type of the line
+ # to which the ending token belongs.
+ my $batch_CODE_type = $this_batch->[_batch_CODE_type_];
+ my $Kend_code =
+ $batch_CODE_type && $batch_CODE_type ne 'VER' ? undef : $Kend;
+
+ # We use two slightly different definitions of level jump at the end
+ # of line:
+ # $ljump is the level jump needed by 'sub set_adjusted_indentation'
+ # $level_jump is the level jump needed by the vertical aligner.
+ my $ljump = 0; # level jump at end of line
+
+ # Get some vars on line [n+1], if any:
+ if ( $n < $n_last_line ) {
+ ( $Kbeg_next, $Kend_next ) =
+ @{ $rlines_K->[ $n + 1 ] };
+ $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
+ $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
+ $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
+ $ljump = $rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
+ }
+ else {
+
+ # Patch for git #51, a bare closing qw paren was not outdented
+ # if the flag '-nodelete-old-newlines is set
+ my $Kbeg_next = $self->K_next_code($Kend);
+ if ( defined($Kbeg_next) ) {
+ $ljump =
+ $rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
+ }
+ }
+
+ # level jump at end of line for the vertical aligner:
+ my $level_jump =
+ $Kend >= $Klimit
+ ? 0
+ : $rLL->[ $Kend + 1 ]->[_SLEVEL_] - $rLL->[$Kbeg]->[_SLEVEL_];
+
+ $self->delete_needless_alignments( $ibeg, $iend,
+ $ralignment_type_to_go );
+
+ my ( $rtokens, $rfields, $rpatterns, $rfield_lengths ) =
+ $self->make_alignment_patterns( $ibeg, $iend,
+ $ralignment_type_to_go );
+
+ my ( $indentation, $lev, $level_end, $terminal_type,
+ $terminal_block_type, $is_semicolon_terminated, $is_outdented_line )
+ = $self->set_adjusted_indentation( $ibeg, $iend, $rfields,
+ $rpatterns, $ri_first, $ri_last,
+ $rindentation_list, $ljump, $starting_in_quote,
+ $is_static_block_comment, );
+
+ # we will allow outdenting of long lines..
+ my $outdent_long_lines = (
+
+ # which are long quotes, if allowed
+ ( $type_beg eq 'Q' && $rOpts->{'outdent-long-quotes'} )
+
+ # which are long block comments, if allowed
+ || (
+ $type_beg eq '#'
+ && $rOpts->{'outdent-long-comments'}
+
+ # but not if this is a static block comment
+ && !$is_static_block_comment
+ )
+ );
+
+ my $break_alignment_before = $is_outdented_line || $do_not_pad;
+ my $break_alignment_after = $is_outdented_line;
+
+ # flush at an 'if' which follows a line with (1) terminal semicolon
+ # or (2) terminal block_type which is not an 'if'. This prevents
+ # unwanted alignment between the lines.
+ if ( $type_beg eq 'k' && $token_beg eq 'if' ) {
+ my $Km = $self->K_previous_code($Kbeg);
+ my $type_m = 'b';
+ my $block_type_m = 'b';
+ if ( defined($Km) ) {
+ $type_m = $rLL->[$Km]->[_TYPE_];
+ $block_type_m = $rLL->[$Km]->[_BLOCK_TYPE_];
+ }
+
+ # break after anything that is not if-like
+ $break_alignment_before ||= $type_m eq ';'
+ || ( $type_m eq '}'
+ && $block_type_m ne 'if'
+ && $block_type_m ne 'unless'
+ && $block_type_m ne 'elsif'
+ && $block_type_m ne 'else' );
+ }
+
+ my $rvertical_tightness_flags =
+ $self->set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
+ $ri_first, $ri_last, $ending_in_quote, $closing_side_comment );
+
+ # Set a flag at the final ':' of a ternary chain to request
+ # vertical alignment of the final term. Here is a
+ # slightly complex example:
+ #
+ # $self->{_text} = (
+ # !$section ? ''
+ # : $type eq 'item' ? "the $section entry"
+ # : "the section on $section"
+ # )
+ # . (
+ # $page
+ # ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
+ # : ' elsewhere in this document'
+ # );
+ #
+ my $is_terminal_ternary = 0;
+
+ if ( $type_beg eq ':' || $n > 0 && $type_end_last eq ':' ) {
+ my $last_leading_type = $n > 0 ? $type_beg_last : ':';
+ if ( $terminal_type ne ';'
+ && $n_last_line > $n
+ && $level_end == $lev )
+ {
+ $level_end = $rLL->[$Kbeg_next]->[_LEVEL_];
+ $terminal_type = $rLL->[$Kbeg_next]->[_TYPE_];
+ }
+ if (
+ $last_leading_type eq ':'
+ && ( ( $terminal_type eq ';' && $level_end <= $lev )
+ || ( $terminal_type ne ':' && $level_end < $lev ) )
+ )
+ {
+
+ # the terminal term must not contain any ternary terms, as in
+ # my $ECHO = (
+ # $Is_MSWin32 ? ".\\echo$$"
+ # : $Is_MacOS ? ":echo$$"
+ # : ( $Is_NetWare ? "echo$$" : "./echo$$" )
+ # );
+ $is_terminal_ternary = 1;
+
+ my $KP = $rLL->[$Kbeg]->[_KNEXT_SEQ_ITEM_];
+ while ( defined($KP) && $KP <= $Kend ) {
+ my $type_KP = $rLL->[$KP]->[_TYPE_];
+ if ( $type_KP eq '?' || $type_KP eq ':' ) {
+ $is_terminal_ternary = 0;
+ last;
+ }
+ $KP = $rLL->[$KP]->[_KNEXT_SEQ_ITEM_];
+ }
+ }
+ }
+
+ my $level_adj = $lev;
+ my $radjusted_levels = $self->[_radjusted_levels_];
+ if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
+ $level_adj = $radjusted_levels->[$Kbeg];
+ if ( $level_adj < 0 ) { $level_adj = 0 }
+ }
+
+ # add any new closing side comment to the last line
+ if ( $closing_side_comment && $n == $n_last_line && @{$rfields} ) {
+ $rfields->[-1] .= " $closing_side_comment";
+
+ # NOTE: Patch for csc. We can just use 1 for the length of the csc
+ # because its length should not be a limiting factor from here on.
+ $rfield_lengths->[-1] += 2;
+ }
+
+ # Programming check: (shouldn't happen)
+ # The number of tokens which separate the fields must always be
+ # one less than the number of fields. If this is not true then
+ # an error has been introduced in sub make_alignment_patterns.
+ if ( @{$rfields} && ( @{$rtokens} != ( @{$rfields} - 1 ) ) ) {
+ my $nt = @{$rtokens};
+ my $nf = @{$rfields};
+ my $msg = <<EOM;
+Program bug in Perl::Tidy::Formatter, probably in sub 'make_alignment_patterns':
+The number of tokens = $nt should be one less than number of fields: $nf
+EOM
+ Fault($msg);
+ }
+
+ # Set flag which tells if this line is contained in a multi-line list
+ my $list_seqno = $self->is_list_by_K($Kbeg);
+
+ # send this new line down the pipe
+ my $rvalign_hash = {};
+ $rvalign_hash->{level} = $lev;
+ $rvalign_hash->{level_end} = $level_end;
+ $rvalign_hash->{level_adj} = $level_adj;
+ $rvalign_hash->{indentation} = $indentation;
+ $rvalign_hash->{list_seqno} = $list_seqno;
+ $rvalign_hash->{outdent_long_lines} = $outdent_long_lines;
+ $rvalign_hash->{is_terminal_ternary} = $is_terminal_ternary;
+ $rvalign_hash->{rvertical_tightness_flags} = $rvertical_tightness_flags;
+ $rvalign_hash->{level_jump} = $level_jump;
+ $rvalign_hash->{rfields} = $rfields;
+ $rvalign_hash->{rpatterns} = $rpatterns;
+ $rvalign_hash->{rtokens} = $rtokens;
+ $rvalign_hash->{rfield_lengths} = $rfield_lengths;
+ $rvalign_hash->{terminal_block_type} = $terminal_block_type;
+ $rvalign_hash->{batch_count} = $batch_count;
+ $rvalign_hash->{break_alignment_before} = $break_alignment_before;
+ $rvalign_hash->{break_alignment_after} = $break_alignment_after;
+ $rvalign_hash->{Kend} = $Kend_code;
+ $rvalign_hash->{ci_level} = $ci_levels_to_go[$ibeg];
+
+ my $vao = $self->[_vertical_aligner_object_];
+ $vao->valign_input($rvalign_hash);
+
+ $do_not_pad = 0;
+
+ # Set flag indicating if this line ends in an opening
+ # token and is very short, so that a blank line is not
+ # needed if the subsequent line is a comment.
+ # Examples of what we are looking for:
+ # {
+ # && (
+ # BEGIN {
+ # default {
+ # sub {
+ $self->[_last_output_short_opening_token_]
+
+ # line ends in opening token
+ # /^[\{\(\[L]$/
+ = $is_opening_type{$type_end}
+
+ # and either
+ && (
+ # line has either single opening token
+ $Kend == $Kbeg
+
+ # or is a single token followed by opening token.
+ # Note that sub identifiers have blanks like 'sub doit'
+ # $token_beg !~ /\s+/
+ || ( $Kend - $Kbeg <= 2 && index( $token_beg, ' ' ) < 0 )
+ )
+
+ # and limit total to 10 character widths
+ && token_sequence_length( $ibeg, $iend ) <= 10;
+
+ } # end of loop to output each line
+
+ # remember indentation of lines containing opening containers for
+ # later use by sub set_adjusted_indentation
+ $self->save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
+
+ # output any new -cscw block comment
+ if ($cscw_block_comment) {
+ $self->flush_vertical_aligner();
+ my $file_writer_object = $self->[_file_writer_object_];
+ $file_writer_object->write_code_line( $cscw_block_comment . "\n" );
+ }
+ return;
+}
+
+{ ## begin closure set_vertical_alignment_markers
+ my %is_vertical_alignment_type;
+ my %is_not_vertical_alignment_token;
+ my %is_vertical_alignment_keyword;
+ my %is_terminal_alignment_type;
+ my %is_low_level_alignment_token;
+
+ BEGIN {
+
+ my @q;
+
+ # Replaced =~ and // in the list. // had been removed in RT 119588
+ @q = qw#
+ = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
+ { ? : => && || ~~ !~~ =~ !~ // <=> ->
+ #;
+ @is_vertical_alignment_type{@q} = (1) x scalar(@q);
+
+ # These 'tokens' are not aligned. We need this to remove [
+ # from the above list because it has type ='{'
+ @q = qw([);
+ @is_not_vertical_alignment_token{@q} = (1) x scalar(@q);
+
+ # these are the only types aligned at a line end
+ @q = qw(&& || =>);
+ @is_terminal_alignment_type{@q} = (1) x scalar(@q);
+
+ # these tokens only align at line level
+ @q = ( '{', '(' );
+ @is_low_level_alignment_token{@q} = (1) x scalar(@q);
+
+ # eq and ne were removed from this list to improve alignment chances
+ @q = qw(if unless and or err for foreach while until);
+ @is_vertical_alignment_keyword{@q} = (1) x scalar(@q);
+ }
+
+ sub set_vertical_alignment_markers {
+
+ # This routine takes the first step toward vertical alignment of the
+ # lines of output text. It looks for certain tokens which can serve as
+ # vertical alignment markers (such as an '=').
+ #
+ # Method: We look at each token $i in this output batch and set
+ # $ralignment_type_to_go->[$i] equal to those tokens at which we would
+ # accept vertical alignment.
+
+ my ( $self, $ri_first, $ri_last ) = @_;
+ my $rspecial_side_comment_type = $self->[_rspecial_side_comment_type_];
+
+ my $ralignment_type_to_go;
+
+ # Initialize the alignment array. Note that closing side comments can
+ # insert up to 2 additional tokens beyond the original
+ # $max_index_to_go, so we need to check ri_last for the last index.
+ my $max_line = @{$ri_first} - 1;
+ my $iend = $ri_last->[$max_line];
+ if ( $iend < $max_index_to_go ) { $iend = $max_index_to_go }
+
+ # nothing to do if we aren't allowed to change whitespace
+ # or there is only 1 token
+ if ( $iend == 0 || !$rOpts_add_whitespace ) {
+ for my $i ( 0 .. $iend ) {
+ $ralignment_type_to_go->[$i] = '';
+ }
+ return $ralignment_type_to_go;
+ }
+
+ # remember the index of last nonblank token before any sidecomment
+ my $i_terminal = $max_index_to_go;
+ if ( $types_to_go[$i_terminal] eq '#' ) {
+ if ( $i_terminal > 0 && $types_to_go[ --$i_terminal ] eq 'b' ) {
+ if ( $i_terminal > 0 ) { --$i_terminal }
+ }
+ }
+
+ # look at each line of this batch..
+ my $last_vertical_alignment_before_index;
+ my $vert_last_nonblank_type;
+ my $vert_last_nonblank_token;
+ my $vert_last_nonblank_block_type;
+
+ foreach my $line ( 0 .. $max_line ) {
+ my $ibeg = $ri_first->[$line];
+ my $iend = $ri_last->[$line];
+ $last_vertical_alignment_before_index = -1;
+ $vert_last_nonblank_type = '';
+ $vert_last_nonblank_token = '';
+ $vert_last_nonblank_block_type = '';
+
+ # look at each token in this output line..
+ my $level_beg = $levels_to_go[$ibeg];
+ foreach my $i ( $ibeg .. $iend ) {
+ my $alignment_type = '';
+ my $type = $types_to_go[$i];
+ my $block_type = $block_type_to_go[$i];
+ my $token = $tokens_to_go[$i];
+
+ # do not align tokens at lower level then start of line
+ # except for side comments
+ if ( $levels_to_go[$i] < $levels_to_go[$ibeg]
+ && $type ne '#' )
+ {
+ $ralignment_type_to_go->[$i] = '';
+ next;
+ }
+
+ #--------------------------------------------------------
+ # First see if we want to align BEFORE this token
+ #--------------------------------------------------------
+
+ # The first possible token that we can align before
+ # is index 2 because: 1) it doesn't normally make sense to
+ # align before the first token and 2) the second
+ # token must be a blank if we are to align before
+ # the third
+ if ( $i < $ibeg + 2 ) { }
+
+ # must follow a blank token
+ elsif ( $types_to_go[ $i - 1 ] ne 'b' ) { }
+
+ # align a side comment --
+ elsif ( $type eq '#' ) {
+
+ my $KK = $K_to_go[$i];
+ my $sc_type = $rspecial_side_comment_type->{$KK};
+
+ unless (
+
+ # it is any specially marked side comment
+ $sc_type
+
+ # or it is a static side comment
+ || ( $rOpts->{'static-side-comments'}
+ && $token =~ /$static_side_comment_pattern/ )
+
+ # or a closing side comment
+ || ( $vert_last_nonblank_block_type
+ && $token =~
+ /$closing_side_comment_prefix_pattern/ )
+ )
+ {
+ $alignment_type = $type;
+ } ## Example of a static side comment
+ }
+
+ # otherwise, do not align two in a row to create a
+ # blank field
+ elsif ( $last_vertical_alignment_before_index == $i - 2 ) { }
+
+ # align before one of these keywords
+ # (within a line, since $i>1)
+ elsif ( $type eq 'k' ) {
+
+ # /^(if|unless|and|or|eq|ne)$/
+ if ( $is_vertical_alignment_keyword{$token} ) {
+ $alignment_type = $token;
+ }
+ }
+
+ # align before one of these types..
+ # Note: add '.' after new vertical aligner is operational
+ elsif ( $is_vertical_alignment_type{$type}
+ && !$is_not_vertical_alignment_token{$token} )
+ {
+ $alignment_type = $token;
+
+ # Do not align a terminal token. Although it might
+ # occasionally look ok to do this, this has been found to be
+ # a good general rule. The main problems are:
+ # (1) that the terminal token (such as an = or :) might get
+ # moved far to the right where it is hard to see because
+ # nothing follows it, and
+ # (2) doing so may prevent other good alignments.
+ # Current exceptions are && and || and =>
+ if ( $i == $iend || $i >= $i_terminal ) {
+ $alignment_type = ""
+ unless ( $is_terminal_alignment_type{$type} );
+ }
+
+ # Do not align leading ': (' or '. ('. This would prevent
+ # alignment in something like the following:
+ # $extra_space .=
+ # ( $input_line_number < 10 ) ? " "
+ # : ( $input_line_number < 100 ) ? " "
+ # : "";
+ # or
+ # $code =
+ # ( $case_matters ? $accessor : " lc($accessor) " )
+ # . ( $yesno ? " eq " : " ne " )
+
+ # Also, do not align a ( following a leading ? so we can
+ # align something like this:
+ # $converter{$_}->{ushortok} =
+ # $PDL::IO::Pic::biggrays
+ # ? ( m/GIF/ ? 0 : 1 )
+ # : ( m/GIF|RAST|IFF/ ? 0 : 1 );
+ if (
+ $i == $ibeg + 2
+ && $types_to_go[ $i - 1 ] eq 'b'
+ && ( $types_to_go[$ibeg] eq '.'
+ || $types_to_go[$ibeg] eq ':'
+ || $types_to_go[$ibeg] eq '?' )
+ )
+ {
+ $alignment_type = "";
+ }
+
+ # Certain tokens only align at the same level as the
+ # initial line level
+ if ( $is_low_level_alignment_token{$token}
+ && $levels_to_go[$i] != $level_beg )
+ {
+ $alignment_type = "";
+ }
+
+ # For a paren after keyword, only align something like this:
+ # if ( $a ) { &a }
+ # elsif ( $b ) { &b }
+ if ( $token eq '(' ) {
+
+ if ( $vert_last_nonblank_type eq 'k' ) {
+ $alignment_type = ""
+ unless $vert_last_nonblank_token =~
+ /^(if|unless|elsif)$/;
+ }
+
+ # Do not align a spaced-function-paren if requested.
+ # Issue git #53. Note that $i-1 is a blank token if we
+ # get here.
+ if ( !$rOpts_function_paren_vertical_alignment
+ && $i > $ibeg + 1 )
+ {
+ my $type_m = $types_to_go[ $i - 2 ];
+ my $token_m = $tokens_to_go[ $i - 2 ];
+
+ # this is the same test as 'space-function-paren'
+ if ( $type_m =~ /^[wUG]$/
+ || $type_m eq '->'
+ || $type_m =~ /^[wi]$/
+ && $token_m =~ /^(\&|->)/ )
+ {
+ $alignment_type = "";
+ }
+ }
+ }
+
+ # be sure the alignment tokens are unique
+ # This didn't work well: reason not determined
+ # if ($token ne $type) {$alignment_type .= $type}
+ }
+
+ # NOTE: This is deactivated because it causes the previous
+ # if/elsif alignment to fail
+ #elsif ( $type eq '}' && $token eq '}' && $block_type_to_go[$i])
+ #{ $alignment_type = $type; }
+
+ if ($alignment_type) {
+ $last_vertical_alignment_before_index = $i;
+ }
+
+ #--------------------------------------------------------
+ # Next see if we want to align AFTER the previous nonblank
+ #--------------------------------------------------------
+
+ # We want to line up ',' and interior ';' tokens, with the added
+ # space AFTER these tokens. (Note: interior ';' is included
+ # because it may occur in short blocks).
+ if (
+
+ # we haven't already set it
+ !$alignment_type
+
+ # and its not the first token of the line
+ && ( $i > $ibeg )
+
+ # and it follows a blank
+ && $types_to_go[ $i - 1 ] eq 'b'
+
+ # and previous token IS one of these:
+ && ( $vert_last_nonblank_type eq ','
+ || $vert_last_nonblank_type eq ';' )
+
+ # and it's NOT one of these
+ && ( $type ne 'b'
+ && $type ne '#'
+ && !$is_closing_token{$type} )
+
+ # then go ahead and align
+ )
+
+ {
+ $alignment_type = $vert_last_nonblank_type;
+ }
+
+ #--------------------------------------------------------
+ # Undo alignment in special cases
+ #--------------------------------------------------------
+ if ($alignment_type) {
+
+ # do not align the opening brace of an anonymous sub
+ if ( $token eq '{' && $block_type =~ /$ASUB_PATTERN/ ) {
+ $alignment_type = "";
+ }
+ }
+
+ #--------------------------------------------------------
+ # then store the value
+ #--------------------------------------------------------
+ $ralignment_type_to_go->[$i] = $alignment_type;
+ if ( $type ne 'b' ) {
+ $vert_last_nonblank_type = $type;
+ $vert_last_nonblank_token = $token;
+ $vert_last_nonblank_block_type = $block_type;
+ }
+ }
+ }
+ return $ralignment_type_to_go;
+ }
+} ## end closure set_vertical_alignment_markers
+
+sub get_seqno {
+
+ # get opening and closing sequence numbers of a token for the vertical
+ # aligner. Assign qw quotes a value to allow qw opening and closing tokens
+ # to be treated somewhat like opening and closing tokens for stacking
+ # tokens by the vertical aligner.
+ my ( $self, $ii, $ending_in_quote ) = @_;
+
+ my $rLL = $self->[_rLL_];
+ my $this_batch = $self->[_this_batch_];
+ my $rK_to_go = $this_batch->[_rK_to_go_];
+
+ my $KK = $rK_to_go->[$ii];
+ my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
+
+ if ( $rLL->[$KK]->[_TYPE_] eq 'q' ) {
+ my $SEQ_QW = -1;
+ my $token = $rLL->[$KK]->[_TOKEN_];
+ if ( $ii > 0 ) {
+ $seqno = $SEQ_QW if ( $token =~ /^qw\s*[\(\{\[]/ );
+ }
+ else {
+ if ( !$ending_in_quote ) {
+ $seqno = $SEQ_QW if ( $token =~ /[\)\}\]]$/ );
+ }
+ }
+ }
+ return ($seqno);
+}
+
+{
+ my %undo_extended_ci;
+
+ sub initialize_undo_ci {
+ %undo_extended_ci = ();
+ return;
+ }
+
+ sub undo_ci {
+
+ # Undo continuation indentation in certain sequences
+ my ( $self, $ri_first, $ri_last, $rix_seqno_controlling_ci ) = @_;
+ my ( $line_1, $line_2, $lev_last );
+ my $this_line_is_semicolon_terminated;
+ my $max_line = @{$ri_first} - 1;
+
+ my $rseqno_controlling_my_ci = $self->[_rseqno_controlling_my_ci_];
+
+ # Prepare a list of controlling indexes for each line if required.
+ # This is used for efficient processing below. Note: this is
+ # critical for speed. In the initial implementation I just looped
+ # through the @$rix_seqno_controlling_ci list below. Using NYT_prof, I
+ # found that this routine was causing a huge run time in large lists.
+ # On a very large list test case, this new coding dropped the run time
+ # of this routine from 30 seconds to 169 milliseconds.
+ my @i_controlling_ci;
+ if ( @{$rix_seqno_controlling_ci} ) {
+ my @tmp = reverse @{$rix_seqno_controlling_ci};
+ my $ix_next = pop @tmp;
+ foreach my $line ( 0 .. $max_line ) {
+ my $iend = $ri_last->[$line];
+ while ( defined($ix_next) && $ix_next <= $iend ) {
+ push @{ $i_controlling_ci[$line] }, $ix_next;
+ $ix_next = pop @tmp;
+ }
+ }
+ }
+
+ # Loop over all lines of the batch ...
+
+ # Workaround for problem c007, in which the combination -lp -xci
+ # can produce a "Program bug" message in unusual circumstances.
+ my $skip_SECTION_1 = $rOpts_line_up_parentheses
+ && $rOpts->{'extended-continuation-indentation'};
+
+ foreach my $line ( 0 .. $max_line ) {
+
+ my $ibeg = $ri_first->[$line];
+ my $iend = $ri_last->[$line];
+ my $lev = $levels_to_go[$ibeg];
+
+ ####################################
+ # SECTION 1: Undo needless common CI
+ ####################################
+
+ # We are looking at leading tokens and looking for a sequence all
+ # at the same level and all at a higher level than enclosing lines.
+
+ # For example, we can undo continuation indentation in sort/map/grep
+ # chains
+
+ # my $dat1 = pack( "n*",
+ # map { $_, $lookup->{$_} }
+ # sort { $a <=> $b }
+ # grep { $lookup->{$_} ne $default } keys %$lookup );
+
+ # to become
+
+ # my $dat1 = pack( "n*",
+ # map { $_, $lookup->{$_} }
+ # sort { $a <=> $b }
+ # grep { $lookup->{$_} ne $default } keys %$lookup );
+
+ if ( $line > 0 && !$skip_SECTION_1 ) {
+
+ # if we have started a chain..
+ if ($line_1) {
+
+ # see if it continues..
+ if ( $lev == $lev_last ) {
+ if ( $types_to_go[$ibeg] eq 'k'
+ && $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
+ {
+
+ # chain continues...
+ # check for chain ending at end of a statement
+ if ( $line == $max_line ) {
+
+ # see of this line ends a statement
+ $this_line_is_semicolon_terminated =
+ $types_to_go[$iend] eq ';'
+
+ # with possible side comment
+ || ( $types_to_go[$iend] eq '#'
+ && $iend - $ibeg >= 2
+ && $types_to_go[ $iend - 2 ] eq ';'
+ && $types_to_go[ $iend - 1 ] eq 'b' );
+ }
+ $line_2 = $line
+ if ($this_line_is_semicolon_terminated);
+ }
+ else {
+
+ # kill chain
+ $line_1 = undef;
+ }
+ }
+ elsif ( $lev < $lev_last ) {
+
+ # chain ends with previous line
+ $line_2 = $line - 1;
+ }
+ elsif ( $lev > $lev_last ) {
+
+ # kill chain
+ $line_1 = undef;
+ }
+
+ # undo the continuation indentation if a chain ends
+ if ( defined($line_2) && defined($line_1) ) {
+ my $continuation_line_count = $line_2 - $line_1 + 1;
+ @ci_levels_to_go[ @{$ri_first}[ $line_1 .. $line_2 ] ]
+ = (0) x ($continuation_line_count)
+ if ( $continuation_line_count >= 0 );
+ @leading_spaces_to_go[ @{$ri_first}
+ [ $line_1 .. $line_2 ] ] =
+ @reduced_spaces_to_go[ @{$ri_first}
+ [ $line_1 .. $line_2 ] ];
+ $line_1 = undef;
+ }
+ }
+
+ # not in a chain yet..
+ else {
+
+ # look for start of a new sort/map/grep chain
+ if ( $lev > $lev_last ) {
+ if ( $types_to_go[$ibeg] eq 'k'
+ && $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
+ {
+ $line_1 = $line;
+ }
+ }
+ }
+ }
+
+ ######################################
+ # SECTION 2: Undo ci at cuddled blocks
+ ######################################
+
+ # Note that sub set_adjusted_indentation will be called later to
+ # actually do this, but for now we will tentatively mark cuddled
+ # lines with ci=0 so that the the -xci loop which follows will be
+ # correct at cuddles.
+ if (
+ $types_to_go[$ibeg] eq '}'
+ && ( $nesting_depth_to_go[$iend] + 1 ==
+ $nesting_depth_to_go[$ibeg] )
+ )
+ {
+ my $terminal_type = $types_to_go[$iend];
+ if ( $terminal_type eq '#' && $iend > $ibeg ) {
+ $terminal_type = $types_to_go[ $iend - 1 ];
+ if ( $terminal_type eq '#' && $iend - 1 > $ibeg ) {
+ $terminal_type = $types_to_go[ $iend - 2 ];
+ }
+ }
+ if ( $terminal_type eq '{' ) {
+ my $Kbeg = $K_to_go[$ibeg];
+ $ci_levels_to_go[$ibeg] = 0;
+ }
+ }
+
+ #########################################################
+ # SECTION 3: Undo ci set by sub extended_ci if not needed
+ #########################################################
+
+ # Undo the ci of the leading token if its controlling token
+ # went out on a previous line without ci
+ if ( $ci_levels_to_go[$ibeg] ) {
+ my $Kbeg = $K_to_go[$ibeg];
+ my $seqno = $rseqno_controlling_my_ci->{$Kbeg};
+ if ( $seqno && $undo_extended_ci{$seqno} ) {
+
+ # but do not undo ci set by the -lp flag
+ if ( !ref( $reduced_spaces_to_go[$ibeg] ) ) {
+ $ci_levels_to_go[$ibeg] = 0;
+ $leading_spaces_to_go[$ibeg] =
+ $reduced_spaces_to_go[$ibeg];
+ }
+ }
+ }
+
+ # Flag any controlling opening tokens in lines without ci. This
+ # will be used later in the above if statement to undo the ci which
+ # they added. The array i_controlling_ci[$line] was prepared at
+ # the top of this routine.
+ if ( !$ci_levels_to_go[$ibeg]
+ && defined( $i_controlling_ci[$line] ) )
+ {
+ foreach my $i ( @{ $i_controlling_ci[$line] } ) {
+ my $seqno = $type_sequence_to_go[$i];
+ $undo_extended_ci{$seqno} = 1;
+ }
+ }
+
+ $lev_last = $lev;
+ }
+
+ return;
+ }
+}
+
+{ ## begin closure set_logical_padding
+ my %is_math_op;
+
+ BEGIN {
+
+ my @q = qw( + - * / );
+ @is_math_op{@q} = (1) x scalar(@q);
+ }
+
+ sub set_logical_padding {
+
+ # Look at a batch of lines and see if extra padding can improve the
+ # alignment when there are certain leading operators. Here is an
+ # example, in which some extra space is introduced before
+ # '( $year' to make it line up with the subsequent lines:
+ #
+ # if ( ( $Year < 1601 )
+ # || ( $Year > 2899 )
+ # || ( $EndYear < 1601 )
+ # || ( $EndYear > 2899 ) )
+ # {
+ # &Error_OutOfRange;
+ # }
+ #
+ my ( $self, $ri_first, $ri_last, $peak_batch_size, $starting_in_quote )
+ = @_;
+ my $max_line = @{$ri_first} - 1;
+
+ my ( $ibeg, $ibeg_next, $ibegm, $iend, $iendm, $ipad, $pad_spaces,
+ $tok_next, $type_next, $has_leading_op_next, $has_leading_op );
+
+ # Patch to produce padding in the first line of short code blocks.
+ # This is part of an update to fix cases b562 .. b983.
+ # This is needed to compensate for a change which was made in 'sub
+ # starting_one_line_block' to prevent blinkers. Previously, that sub
+ # would not look at the total block size and rely on sub
+ # set_continuation_breaks to break up long blocks. Consequently, the
+ # first line of those batches would end in the opening block brace of a
+ # sort/map/grep/eval block. When this was changed to immediately check
+ # for blocks which were too long, the opening block brace would go out
+ # in a single batch, and the block contents would go out as the next
+ # batch. This caused the logic in this routine which decides if the
+ # first line should be padded to be incorrect. To fix this, we set a
+ # flag if the previous batch ended in an opening sort/map/grep/eval
+ # block brace, and use it to adjust the logic to compensate.
+
+ # For example, the following would have previously been a single batch
+ # but now is two batches. We want to pad the line starting in '$dir':
+ # my (@indices) = # batch n-1 (prev batch n)
+ # sort { # batch n-1 (prev batch n)
+ # $dir eq 'left' # batch n
+ # ? $cells[$a] <=> $cells[$b] # batch n
+ # : $cells[$b] <=> $cells[$a]; # batch n
+ # } ( 0 .. $#cells ); # batch n
+
+ my $rLL = $self->[_rLL_];
+ my $K0 = $K_to_go[0];
+ my $Kprev = $self->K_previous_code($K0);
+ my $is_short_block;
+ if ( defined($Kprev)
+ && $rLL->[$Kprev]->[_BLOCK_TYPE_] )
+ {
+ my $block_type = $rLL->[$Kprev]->[_BLOCK_TYPE_];
+ $is_short_block = $is_sort_map_grep_eval{$block_type};
+ $is_short_block ||= $want_one_line_block{$block_type};
+ }
+
+ # looking at each line of this batch..
+ foreach my $line ( 0 .. $max_line - 1 ) {
+
+ # see if the next line begins with a logical operator
+ $ibeg = $ri_first->[$line];
+ $iend = $ri_last->[$line];
+ $ibeg_next = $ri_first->[ $line + 1 ];
+ $tok_next = $tokens_to_go[$ibeg_next];
+ $type_next = $types_to_go[$ibeg_next];
+
+ $has_leading_op_next = ( $tok_next =~ /^\w/ )
+ ? $is_chain_operator{$tok_next} # + - * / : ? && ||
+ : $is_chain_operator{$type_next}; # and, or
+
+ next unless ($has_leading_op_next);
+
+ # next line must not be at lesser depth
+ next
+ if ( $nesting_depth_to_go[$ibeg] >
+ $nesting_depth_to_go[$ibeg_next] );
+
+ # identify the token in this line to be padded on the left
+ $ipad = undef;
+
+ # handle lines at same depth...
+ if ( $nesting_depth_to_go[$ibeg] ==
+ $nesting_depth_to_go[$ibeg_next] )
+ {
+
+ # if this is not first line of the batch ...
+ if ( $line > 0 ) {
+
+ # and we have leading operator..
+ next if $has_leading_op;
+
+ # Introduce padding if..
+ # 1. the previous line is at lesser depth, or
+ # 2. the previous line ends in an assignment
+ # 3. the previous line ends in a 'return'
+ # 4. the previous line ends in a comma
+ # Example 1: previous line at lesser depth
+ # if ( ( $Year < 1601 ) # <- we are here but
+ # || ( $Year > 2899 ) # list has not yet
+ # || ( $EndYear < 1601 ) # collapsed vertically
+ # || ( $EndYear > 2899 ) )
+ # {
+ #
+ # Example 2: previous line ending in assignment:
+ # $leapyear =
+ # $year % 4 ? 0 # <- We are here
+ # : $year % 100 ? 1
+ # : $year % 400 ? 0
+ # : 1;
+ #
+ # Example 3: previous line ending in comma:
+ # push @expr,
+ # /test/ ? undef
+ # : eval($_) ? 1
+ # : eval($_) ? 1
+ # : 0;
+
+ # be sure levels agree (do not indent after an indented 'if')
+ next
+ if ( $levels_to_go[$ibeg] ne $levels_to_go[$ibeg_next] );
+
+ # allow padding on first line after a comma but only if:
+ # (1) this is line 2 and
+ # (2) there are at more than three lines and
+ # (3) lines 3 and 4 have the same leading operator
+ # These rules try to prevent padding within a long
+ # comma-separated list.
+ my $ok_comma;
+ if ( $types_to_go[$iendm] eq ','
+ && $line == 1
+ && $max_line > 2 )
+ {
+ my $ibeg_next_next = $ri_first->[ $line + 2 ];
+ my $tok_next_next = $tokens_to_go[$ibeg_next_next];
+ $ok_comma = $tok_next_next eq $tok_next;
+ }
+
+ next
+ unless (
+ $is_assignment{ $types_to_go[$iendm] }
+ || $ok_comma
+ || ( $nesting_depth_to_go[$ibegm] <
+ $nesting_depth_to_go[$ibeg] )
+ || ( $types_to_go[$iendm] eq 'k'
+ && $tokens_to_go[$iendm] eq 'return' )
+ );
+
+ # we will add padding before the first token
+ $ipad = $ibeg;
+ }
+
+ # for first line of the batch..
+ else {
+
+ # WARNING: Never indent if first line is starting in a
+ # continued quote, which would change the quote.
+ next if $starting_in_quote;
+
+ # if this is text after closing '}'
+ # then look for an interior token to pad
+ if ( $types_to_go[$ibeg] eq '}' ) {
+
+ }
+
+ # otherwise, we might pad if it looks really good
+ elsif ($is_short_block) {
+ $ipad = $ibeg;
+ }
+ else {
+
+ # we might pad token $ibeg, so be sure that it
+ # is at the same depth as the next line.
+ next
+ if ( $nesting_depth_to_go[$ibeg] !=
+ $nesting_depth_to_go[$ibeg_next] );
+
+ # We can pad on line 1 of a statement if at least 3
+ # lines will be aligned. Otherwise, it
+ # can look very confusing.
+
+ # We have to be careful not to pad if there are too few
+ # lines. The current rule is:
+ # (1) in general we require at least 3 consecutive lines
+ # with the same leading chain operator token,
+ # (2) but an exception is that we only require two lines
+ # with leading colons if there are no more lines. For example,
+ # the first $i in the following snippet would get padding
+ # by the second rule:
+ #
+ # $i == 1 ? ( "First", "Color" )
+ # : $i == 2 ? ( "Then", "Rarity" )
+ # : ( "Then", "Name" );
+
+ if ( $max_line > 1 ) {
+ my $leading_token = $tokens_to_go[$ibeg_next];
+ my $tokens_differ;
+
+ # never indent line 1 of a '.' series because
+ # previous line is most likely at same level.
+ # TODO: we should also look at the leading_spaces
+ # of the last output line and skip if it is same
+ # as this line.
+ next if ( $leading_token eq '.' );
+
+ my $count = 1;
+ foreach my $l ( 2 .. 3 ) {
+ last if ( $line + $l > $max_line );
+ my $ibeg_next_next = $ri_first->[ $line + $l ];
+ if ( $tokens_to_go[$ibeg_next_next] ne
+ $leading_token )
+ {
+ $tokens_differ = 1;
+ last;
+ }
+ $count++;
+ }
+ next if ($tokens_differ);
+ next if ( $count < 3 && $leading_token ne ':' );
+ $ipad = $ibeg;
+ }
+ else {
+ next;
+ }
+ }
+ }
+ }
+
+ # find interior token to pad if necessary
+ if ( !defined($ipad) ) {
+
+ for ( my $i = $ibeg ; ( $i < $iend ) && !$ipad ; $i++ ) {
+
+ # find any unclosed container
+ next
+ unless ( $type_sequence_to_go[$i]
+ && $mate_index_to_go[$i] > $iend );
+
+ # find next nonblank token to pad
+ $ipad = $inext_to_go[$i];
+ last if ( $ipad > $iend );
+ }
+ last unless $ipad;
+ }
+
+ # We cannot pad the first leading token of a file because
+ # it could cause a bug in which the starting indentation
+ # level is guessed incorrectly each time the code is run
+ # though perltidy, thus causing the code to march off to
+ # the right. For example, the following snippet would have
+ # this problem:
+
+## ov_method mycan( $package, '(""' ), $package
+## or ov_method mycan( $package, '(0+' ), $package
+## or ov_method mycan( $package, '(bool' ), $package
+## or ov_method mycan( $package, '(nomethod' ), $package;
+
+ # If this snippet is within a block this won't happen
+ # unless the user just processes the snippet alone within
+ # an editor. In that case either the user will see and
+ # fix the problem or it will be corrected next time the
+ # entire file is processed with perltidy.
+ next if ( $ipad == 0 && $peak_batch_size <= 1 );
+
+## THIS PATCH REMOVES THE FOLLOWING POOR PADDING (math.t) with -pbp, BUT
+## IT DID MORE HARM THAN GOOD
+## ceil(
+## $font->{'loca'}->{'glyphs'}[$x]->read->{'xMin'} * 1000
+## / $upem
+## ),
+##? # do not put leading padding for just 2 lines of math
+##? if ( $ipad == $ibeg
+##? && $line > 0
+##? && $levels_to_go[$ipad] > $levels_to_go[ $ipad - 1 ]
+##? && $is_math_op{$type_next}
+##? && $line + 2 <= $max_line )
+##? {
+##? my $ibeg_next_next = $ri_first->[ $line + 2 ];
+##? my $type_next_next = $types_to_go[$ibeg_next_next];
+##? next if !$is_math_op{$type_next_next};
+##? }
+
+ # next line must not be at greater depth
+ my $iend_next = $ri_last->[ $line + 1 ];
+ next
+ if ( $nesting_depth_to_go[ $iend_next + 1 ] >
+ $nesting_depth_to_go[$ipad] );
+
+ # lines must be somewhat similar to be padded..
+ my $inext_next = $inext_to_go[$ibeg_next];
+ my $type = $types_to_go[$ipad];
+ my $type_next = $types_to_go[ $ipad + 1 ];
+
+ # see if there are multiple continuation lines
+ my $logical_continuation_lines = 1;
+ if ( $line + 2 <= $max_line ) {
+ my $leading_token = $tokens_to_go[$ibeg_next];
+ my $ibeg_next_next = $ri_first->[ $line + 2 ];
+ if ( $tokens_to_go[$ibeg_next_next] eq $leading_token
+ && $nesting_depth_to_go[$ibeg_next] eq
+ $nesting_depth_to_go[$ibeg_next_next] )
+ {
+ $logical_continuation_lines++;
+ }
+ }
+
+ # see if leading types match
+ my $types_match = $types_to_go[$inext_next] eq $type;
+ my $matches_without_bang;
+
+ # if first line has leading ! then compare the following token
+ if ( !$types_match && $type eq '!' ) {
+ $types_match = $matches_without_bang =
+ $types_to_go[$inext_next] eq $types_to_go[ $ipad + 1 ];
+ }
+ if (
+
+ # either we have multiple continuation lines to follow
+ # and we are not padding the first token
+ (
+ $logical_continuation_lines > 1
+ && ( $ipad > 0 || $is_short_block )
+ )
+
+ # or..
+ || (
+
+ # types must match
+ $types_match
+
+ # and keywords must match if keyword
+ && !(
+ $type eq 'k'
+ && $tokens_to_go[$ipad] ne $tokens_to_go[$inext_next]
+ )
+ )
+ )
+ {
+
+ #----------------------begin special checks--------------
+ #
+ # SPECIAL CHECK 1:
+ # A check is needed before we can make the pad.
+ # If we are in a list with some long items, we want each
+ # item to stand out. So in the following example, the
+ # first line beginning with '$casefold->' would look good
+ # padded to align with the next line, but then it
+ # would be indented more than the last line, so we
+ # won't do it.
+ #
+ # ok(
+ # $casefold->{code} eq '0041'
+ # && $casefold->{status} eq 'C'
+ # && $casefold->{mapping} eq '0061',
+ # 'casefold 0x41'
+ # );
+ #
+ # Note:
+ # It would be faster, and almost as good, to use a comma
+ # count, and not pad if comma_count > 1 and the previous
+ # line did not end with a comma.
+ #
+ my $ok_to_pad = 1;
+
+ my $ibg = $ri_first->[ $line + 1 ];
+ my $depth = $nesting_depth_to_go[ $ibg + 1 ];
+
+ # just use simplified formula for leading spaces to avoid
+ # needless sub calls
+ my $lsp = $levels_to_go[$ibg] + $ci_levels_to_go[$ibg];
+
+ # look at each line beyond the next ..
+ my $l = $line + 1;
+ foreach my $ltest ( $line + 2 .. $max_line ) {
+ $l = $ltest;
+ my $ibg = $ri_first->[$l];
+
+ # quit looking at the end of this container
+ last
+ if ( $nesting_depth_to_go[ $ibg + 1 ] < $depth )
+ || ( $nesting_depth_to_go[$ibg] < $depth );
+
+ # cannot do the pad if a later line would be
+ # outdented more
+ if ( $levels_to_go[$ibg] + $ci_levels_to_go[$ibg] < $lsp ) {
+ $ok_to_pad = 0;
+ last;
+ }
+ }
+
+ # don't pad if we end in a broken list
+ if ( $l == $max_line ) {
+ my $i2 = $ri_last->[$l];
+ if ( $types_to_go[$i2] eq '#' ) {
+ my $i1 = $ri_first->[$l];
+ next if terminal_type_i( $i1, $i2 ) eq ',';
+ }
+ }
+
+ # SPECIAL CHECK 2:
+ # a minus may introduce a quoted variable, and we will
+ # add the pad only if this line begins with a bare word,
+ # such as for the word 'Button' here:
+ # [
+ # Button => "Print letter \"~$_\"",
+ # -command => [ sub { print "$_[0]\n" }, $_ ],
+ # -accelerator => "Meta+$_"
+ # ];
+ #
+ # On the other hand, if 'Button' is quoted, it looks best
+ # not to pad:
+ # [
+ # 'Button' => "Print letter \"~$_\"",
+ # -command => [ sub { print "$_[0]\n" }, $_ ],
+ # -accelerator => "Meta+$_"
+ # ];
+ if ( $types_to_go[$ibeg_next] eq 'm' ) {
+ $ok_to_pad = 0 if $types_to_go[$ibeg] eq 'Q';
+ }
+
+ next unless $ok_to_pad;
+
+ #----------------------end special check---------------
+
+ my $length_1 = total_line_length( $ibeg, $ipad - 1 );
+ my $length_2 = total_line_length( $ibeg_next, $inext_next - 1 );
+ $pad_spaces = $length_2 - $length_1;
+
+ # If the first line has a leading ! and the second does
+ # not, then remove one space to try to align the next
+ # leading characters, which are often the same. For example:
+ # if ( !$ts
+ # || $ts == $self->Holder
+ # || $self->Holder->Type eq "Arena" )
+ #
+ # This usually helps readability, but if there are subsequent
+ # ! operators things will still get messed up. For example:
+ #
+ # if ( !exists $Net::DNS::typesbyname{$qtype}
+ # && exists $Net::DNS::classesbyname{$qtype}
+ # && !exists $Net::DNS::classesbyname{$qclass}
+ # && exists $Net::DNS::typesbyname{$qclass} )
+ # We can't fix that.
+ if ($matches_without_bang) { $pad_spaces-- }
+
+ # make sure this won't change if -lp is used
+ my $indentation_1 = $leading_spaces_to_go[$ibeg];
+ if ( ref($indentation_1) ) {
+ if ( $indentation_1->get_recoverable_spaces() == 0 ) {
+ my $indentation_2 = $leading_spaces_to_go[$ibeg_next];
+ unless ( $indentation_2->get_recoverable_spaces() == 0 )
+ {
+ $pad_spaces = 0;
+ }
+ }
+ }
+
+ # we might be able to handle a pad of -1 by removing a blank
+ # token
+ if ( $pad_spaces < 0 ) {
+
+ # Deactivated for -kpit due to conflict. This block deletes
+ # a space in an attempt to improve alignment in some cases,
+ # but it may conflict with user spacing requests. For now
+ # it is just deactivated if the -kpit option is used.
+ if ( $pad_spaces == -1 ) {
+ if ( $ipad > $ibeg
+ && $types_to_go[ $ipad - 1 ] eq 'b'
+ && !%keyword_paren_inner_tightness )
+ {
+ $self->pad_token( $ipad - 1, $pad_spaces );
+ }
+ }
+ $pad_spaces = 0;
+ }
+
+ # now apply any padding for alignment
+ if ( $ipad >= 0 && $pad_spaces ) {
+
+ my $length_t = total_line_length( $ibeg, $iend );
+ if ( $pad_spaces + $length_t <=
+ $maximum_line_length_at_level[ $levels_to_go[$ibeg] ] )
+ {
+ $self->pad_token( $ipad, $pad_spaces );
+ }
+ }
+ }
+ }
+ continue {
+ $iendm = $iend;
+ $ibegm = $ibeg;
+ $has_leading_op = $has_leading_op_next;
+ } # end of loop over lines
+ return;
+ }
+} ## end closure set_logical_padding
+
+sub pad_token {
+
+ # insert $pad_spaces before token number $ipad
+ my ( $self, $ipad, $pad_spaces ) = @_;
+ my $rLL = $self->[_rLL_];
+ my $KK = $K_to_go[$ipad];
+ my $tok = $rLL->[$KK]->[_TOKEN_];
+ my $tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_];
+
+ if ( $pad_spaces > 0 ) {
+ $tok = ' ' x $pad_spaces . $tok;
+ $tok_len += $pad_spaces;
+ }
+ elsif ( $pad_spaces == -1 && $tokens_to_go[$ipad] eq ' ' ) {
+ $tok = "";
+ $tok_len = 0;
+ }
+ else {
+
+ # shouldn't happen
+ return;
+ }
+
+ $tok = $rLL->[$KK]->[_TOKEN_] = $tok;
+ $tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_] = $tok_len;
+
+ $token_lengths_to_go[$ipad] += $pad_spaces;
+ $tokens_to_go[$ipad] = $tok;
+
+ foreach my $i ( $ipad .. $max_index_to_go ) {
+ $summed_lengths_to_go[ $i + 1 ] += $pad_spaces;
+ }
+ return;
+}
+
+{ ## begin closure make_alignment_patterns
+
+ my %block_type_map;
+ my %keyword_map;
+ my %operator_map;
+ my %is_w_n_C;
+
+ BEGIN {
+
+ # map related block names into a common name to
+ # allow alignment
+ %block_type_map = (
+ 'unless' => 'if',
+ 'else' => 'if',
+ 'elsif' => 'if',
+ 'when' => 'if',
+ 'default' => 'if',
+ 'case' => 'if',
+ 'sort' => 'map',
+ 'grep' => 'map',
+ );
+
+ # map certain keywords to the same 'if' class to align
+ # long if/elsif sequences. [elsif.pl]
+ %keyword_map = (
+ 'unless' => 'if',
+ 'else' => 'if',
+ 'elsif' => 'if',
+ 'when' => 'given',
+ 'default' => 'given',
+ 'case' => 'switch',
+
+ # treat an 'undef' similar to numbers and quotes
+ 'undef' => 'Q',
+ );
+
+ # map certain operators to the same class for pattern matching
+ %operator_map = (
+ '!~' => '=~',
+ '+=' => '+=',
+ '-=' => '+=',
+ '*=' => '+=',
+ '/=' => '+=',
+ );
+
+ %is_w_n_C = (
+ 'w' => 1,
+ 'n' => 1,
+ 'C' => 1,
+ );
+ }
+
+ sub delete_needless_alignments {
+ my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
+
+ # Remove unwanted alignments. This routine is a place to remove
+ # alignments which might cause problems at later stages. There are
+ # currently two types of fixes:
+
+ # 1. Remove excess parens
+ # 2. Remove alignments within 'elsif' conditions
+
+ # Patch #1: Excess alignment of parens can prevent other good
+ # alignments. For example, note the parens in the first two rows of
+ # the following snippet. They would normally get marked for alignment
+ # and aligned as follows:
+
+ # my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
+ # my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
+ # my $img = new Gimp::Image( $w, $h, RGB );
+
+ # This causes unnecessary paren alignment and prevents the third equals
+ # from aligning. If we remove the unwanted alignments we get:
+
+ # my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
+ # my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
+ # my $img = new Gimp::Image( $w, $h, RGB );
+
+ # A rule for doing this which works well is to remove alignment of
+ # parens whose containers do not contain other aligning tokens, with
+ # the exception that we always keep alignment of the first opening
+ # paren on a line (for things like 'if' and 'elsif' statements).
+
+ # Setup needed constants
+ my $i_good_paren = -1;
+ my $imin_match = $iend + 1;
+ my $i_elsif_close = $ibeg - 1;
+ my $i_elsif_open = $iend + 1;
+ if ( $iend > $ibeg ) {
+ if ( $types_to_go[$ibeg] eq 'k' ) {
+
+ # Paren patch: mark a location of a paren we should keep, such
+ # as one following something like a leading 'if', 'elsif',..
+ $i_good_paren = $ibeg + 1;
+ if ( $types_to_go[$i_good_paren] eq 'b' ) {
+ $i_good_paren++;
+ }
+
+ # 'elsif' patch: remember the range of the parens of an elsif,
+ # and do not make alignments within them because this can cause
+ # loss of padding and overall brace alignment in the vertical
+ # aligner.
+ if ( $tokens_to_go[$ibeg] eq 'elsif'
+ && $i_good_paren < $iend
+ && $tokens_to_go[$i_good_paren] eq '(' )
+ {
+ $i_elsif_open = $i_good_paren;
+ $i_elsif_close = $mate_index_to_go[$i_good_paren];
+ }
+ }
+ }
+
+ # Loop to make the fixes on this line
+ my @imatch_list;
+ for my $i ( $ibeg .. $iend ) {
+
+ if ( $ralignment_type_to_go->[$i] ) {
+
+ # Patch #2: undo alignment within elsif parens
+ if ( $i > $i_elsif_open && $i < $i_elsif_close ) {
+ $ralignment_type_to_go->[$i] = '';
+ next;
+ }
+ push @imatch_list, $i;
+
+ }
+ if ( $tokens_to_go[$i] eq ')' ) {
+
+ # Patch #1: undo the corresponding opening paren if:
+ # - it is at the top of the stack
+ # - and not the first overall opening paren
+ # - does not follow a leading keyword on this line
+ my $imate = $mate_index_to_go[$i];
+ if ( @imatch_list
+ && $imatch_list[-1] eq $imate
+ && ( $ibeg > 1 || @imatch_list > 1 )
+ && $imate > $i_good_paren )
+ {
+ $ralignment_type_to_go->[$imate] = '';
+ pop @imatch_list;
+ }
+ }
+ }
+ return;
+ }
+
+ sub make_alignment_patterns {
+
+ # Here we do some important preliminary work for the
+ # vertical aligner. We create three arrays for one
+ # output line. These arrays contain strings that can
+ # be tested by the vertical aligner to see if
+ # consecutive lines can be aligned vertically.
+ #
+ # The three arrays are indexed on the vertical
+ # alignment fields and are:
+ # @tokens - a list of any vertical alignment tokens for this line.
+ # These are tokens, such as '=' '&&' '#' etc which
+ # we want to might align vertically. These are
+ # decorated with various information such as
+ # nesting depth to prevent unwanted vertical
+ # alignment matches.
+ # @fields - the actual text of the line between the vertical alignment
+ # tokens.
+ # @patterns - a modified list of token types, one for each alignment
+ # field. These should normally each match before alignment is
+ # allowed, even when the alignment tokens match.
+ my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
+ my @tokens = ();
+ my @fields = ();
+ my @patterns = ();
+ my @field_lengths = ();
+ my $i_start = $ibeg;
+
+ # For a 'use' statement, use the module name as container name.
+ # Fixes issue rt136416.
+ my $cname = "";
+ if ( $types_to_go[$ibeg] eq 'k' && $tokens_to_go[$ibeg] eq 'use' ) {
+ my $inext = $inext_to_go[$ibeg];
+ if ( $inext <= $iend ) { $cname = $tokens_to_go[$inext] }
+ }
+
+ my $depth = 0;
+ my %container_name = ( 0 => "$cname" );
+
+ my $j = 0; # field index
+
+ $patterns[0] = "";
+ my %token_count;
+ for my $i ( $ibeg .. $iend ) {
+
+ # Keep track of containers balanced on this line only.
+ # These are used below to prevent unwanted cross-line alignments.
+ # Unbalanced containers already avoid aligning across
+ # container boundaries.
+
+ my $type = $types_to_go[$i];
+ my $token = $tokens_to_go[$i];
+ my $depth_last = $depth;
+ if ( $type_sequence_to_go[$i] ) {
+ if ( $is_opening_type{$token} ) {
+
+ # if container is balanced on this line...
+ my $i_mate = $mate_index_to_go[$i];
+ if ( $i_mate > $i && $i_mate <= $iend ) {
+ $depth++;
+
+ # Append the previous token name to make the container name
+ # more unique. This name will also be given to any commas
+ # within this container, and it helps avoid undesirable
+ # alignments of different types of containers.
+
+ # Containers beginning with { and [ are given those names
+ # for uniqueness. That way commas in different containers
+ # will not match. Here is an example of what this prevents:
+ # a => [ 1, 2, 3 ],
+ # b => { b1 => 4, b2 => 5 },
+ # Here is another example of what we avoid by labeling the
+ # commas properly:
+
+ # is_d( [ $a, $a ], [ $b, $c ] );
+ # is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
+ # is_d( [ \$a, \$a ], [ \$b, \$c ] );
+
+ my $name = $token;
+ if ( $token eq '(' ) {
+ $name = $self->make_paren_name($i);
+ }
+ $container_name{$depth} = "+" . $name;
+
+ # Make the container name even more unique if necessary.
+ # If we are not vertically aligning this opening paren,
+ # append a character count to avoid bad alignment because
+ # it usually looks bad to align commas within containers
+ # for which the opening parens do not align. Here
+ # is an example very BAD alignment of commas (because
+ # the atan2 functions are not all aligned):
+ # $XY =
+ # $X * $RTYSQP1 * atan2( $X, $RTYSQP1 ) +
+ # $Y * $RTXSQP1 * atan2( $Y, $RTXSQP1 ) -
+ # $X * atan2( $X, 1 ) -
+ # $Y * atan2( $Y, 1 );
+ #
+ # On the other hand, it is usually okay to align commas
+ # if opening parens align, such as:
+ # glVertex3d( $cx + $s * $xs, $cy, $z );
+ # glVertex3d( $cx, $cy + $s * $ys, $z );
+ # glVertex3d( $cx - $s * $xs, $cy, $z );
+ # glVertex3d( $cx, $cy - $s * $ys, $z );
+ #
+ # To distinguish between these situations, we will append
+ # the length of the line from the previous matching
+ # token, or beginning of line, to the function name.
+ # This will allow the vertical aligner to reject
+ # undesirable matches.
+
+ # if we are not aligning on this paren...
+ if ( !$ralignment_type_to_go->[$i] ) {
+
+ # Sum length from previous alignment
+ my $len = token_sequence_length( $i_start, $i - 1 );
+
+ # Minor patch: do not include the length of any '!'.
+ # Otherwise, commas in the following line will not
+ # match
+ # ok( 20, tapprox( ( pdl 2, 3 ), ( pdl 2, 3 ) ) );
+ # ok( 21, !tapprox( ( pdl 2, 3 ), ( pdl 2, 4 ) ) );
+ if ( grep { $_ eq '!' }
+ @types_to_go[ $i_start .. $i - 1 ] )
+ {
+ $len -= 1;
+ }
+
+ if ( $i_start == $ibeg ) {
+
+ # For first token, use distance from start of line
+ # but subtract off the indentation due to level.
+ # Otherwise, results could vary with indentation.
+ $len +=
+ leading_spaces_to_go($ibeg) -
+ $levels_to_go[$i_start] *
+ $rOpts_indent_columns;
+ if ( $len < 0 ) { $len = 0 }
+ }
+
+ # tack this length onto the container name to try
+ # to make a unique token name
+ $container_name{$depth} .= "-" . $len;
+ }
+ }
+ }
+ elsif ( $is_closing_type{$token} ) {
+ $depth-- if $depth > 0;
+ }
+ }
+
+ # if we find a new synchronization token, we are done with
+ # a field
+ if ( $i > $i_start && $ralignment_type_to_go->[$i] ) {
+
+ my $tok = my $raw_tok = $ralignment_type_to_go->[$i];
+
+ # map similar items
+ my $tok_map = $operator_map{$tok};
+ $tok = $tok_map if ($tok_map);
+
+ # make separators in different nesting depths unique
+ # by appending the nesting depth digit.
+ if ( $raw_tok ne '#' ) {
+ $tok .= "$nesting_depth_to_go[$i]";
+ }
+
+ # also decorate commas with any container name to avoid
+ # unwanted cross-line alignments.
+ if ( $raw_tok eq ',' || $raw_tok eq '=>' ) {
+
+ # If we are at an opening token which increased depth, we have
+ # to use the name from the previous depth.
+ my $depth_p =
+ ( $depth_last < $depth ? $depth_last : $depth );
+ if ( $container_name{$depth_p} ) {
+ $tok .= $container_name{$depth_p};
+ }
+ }
+
+ # Patch to avoid aligning leading and trailing if, unless.
+ # Mark trailing if, unless statements with container names.
+ # This makes them different from leading if, unless which
+ # are not so marked at present. If we ever need to name
+ # them too, we could use ci to distinguish them.
+ # Example problem to avoid:
+ # return ( 2, "DBERROR" )
+ # if ( $retval == 2 );
+ # if ( scalar @_ ) {
+ # my ( $a, $b, $c, $d, $e, $f ) = @_;
+ # }
+ if ( $raw_tok eq '(' ) {
+ if ( $ci_levels_to_go[$ibeg]
+ && $container_name{$depth} =~ /^\+(if|unless)/ )
+ {
+ $tok .= $container_name{$depth};
+ }
+ }
+
+ # Decorate block braces with block types to avoid
+ # unwanted alignments such as the following:
+ # foreach ( @{$routput_array} ) { $fh->print($_) }
+ # eval { $fh->close() };
+ if ( $raw_tok eq '{' && $block_type_to_go[$i] ) {
+ my $block_type = $block_type_to_go[$i];
+
+ # map certain related block types to allow
+ # else blocks to align
+ $block_type = $block_type_map{$block_type}
+ if ( defined( $block_type_map{$block_type} ) );
+
+ # remove sub names to allow one-line sub braces to align
+ # regardless of name
+ if ( $block_type =~ /$SUB_PATTERN/ ) { $block_type = 'sub' }
+
+ # allow all control-type blocks to align
+ if ( $block_type =~ /^[A-Z]+$/ ) { $block_type = 'BEGIN' }
+
+ $tok .= $block_type;
+ }
+
+ # Mark multiple copies of certain tokens with the copy number
+ # This will allow the aligner to decide if they are matched.
+ # For now, only do this for equals. For example, the two
+ # equals on the next line will be labeled '=0' and '=0.2'.
+ # Later, the '=0.2' will be ignored in alignment because it
+ # has no match.
+
+ # $| = $debug = 1 if $opt_d;
+ # $full_index = 1 if $opt_i;
+
+ if ( $raw_tok eq '=' || $raw_tok eq '=>' ) {
+ $token_count{$tok}++;
+ if ( $token_count{$tok} > 1 ) {
+ $tok .= '.' . $token_count{$tok};
+ }
+ }
+
+ # concatenate the text of the consecutive tokens to form
+ # the field
+ push( @fields,
+ join( '', @tokens_to_go[ $i_start .. $i - 1 ] ) );
+
+ push @field_lengths,
+ $summed_lengths_to_go[$i] - $summed_lengths_to_go[$i_start];
+
+ # store the alignment token for this field
+ push( @tokens, $tok );
+
+ # get ready for the next batch
+ $i_start = $i;
+ $j++;
+ $patterns[$j] = "";
+ }
+
+ # continue accumulating tokens
+
+ # for keywords we have to use the actual text
+ if ( $type eq 'k' ) {
+
+ my $tok_fix = $tokens_to_go[$i];
+
+ # but map certain keywords to a common string to allow
+ # alignment.
+ $tok_fix = $keyword_map{$tok_fix}
+ if ( defined( $keyword_map{$tok_fix} ) );
+ $patterns[$j] .= $tok_fix;
+ }
+
+ elsif ( $type eq 'b' ) {
+ $patterns[$j] .= $type;
+ }
+
+ # handle non-keywords..
+ else {
+
+ my $type_fix = $type;
+
+ # Mark most things before arrows as a quote to
+ # get them to line up. Testfile: mixed.pl.
+ # $type =~ /^[wnC]$/
+ if ( $i < $iend - 1 && $is_w_n_C{$type} ) {
+ my $next_type = $types_to_go[ $i + 1 ];
+ my $i_next_nonblank =
+ ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
+
+ if ( $types_to_go[$i_next_nonblank] eq '=>' ) {
+ $type_fix = 'Q';
+
+ # Patch to ignore leading minus before words,
+ # by changing pattern 'mQ' into just 'Q',
+ # so that we can align things like this:
+ # Button => "Print letter \"~$_\"",
+ # -command => [ sub { print "$_[0]\n" }, $_ ],
+ if ( $patterns[$j] eq 'm' ) { $patterns[$j] = "" }
+ }
+ }
+
+ # Convert a bareword within braces into a quote for matching.
+ # This will allow alignment of expressions like this:
+ # local ( $SIG{'INT'} ) = IGNORE;
+ # local ( $SIG{ALRM} ) = 'POSTMAN';
+ if ( $type eq 'w'
+ && $i > $ibeg
+ && $i < $iend
+ && $types_to_go[ $i - 1 ] eq 'L'
+ && $types_to_go[ $i + 1 ] eq 'R' )
+ {
+ $type_fix = 'Q';
+ }
+
+ # patch to make numbers and quotes align
+ if ( $type eq 'n' ) { $type_fix = 'Q' }
+
+ # patch to ignore any ! in patterns
+ if ( $type eq '!' ) { $type_fix = '' }
+
+ $patterns[$j] .= $type_fix;
+
+ # remove any zero-level name at first fat comma
+ if ( $depth == 0 && $type eq '=>' ) {
+ $container_name{$depth} = "";
+ }
+
+ }
+ }
+
+ # done with this line .. join text of tokens to make the last field
+ push( @fields, join( '', @tokens_to_go[ $i_start .. $iend ] ) );
+ push @field_lengths,
+ $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$i_start];
+
+ return ( \@tokens, \@fields, \@patterns, \@field_lengths );
+ }
+
+} ## end closure make_alignment_patterns
+
+sub make_paren_name {
+ my ( $self, $i ) = @_;
+
+ # The token at index $i is a '('.
+ # Create an alignment name for it to avoid incorrect alignments.
+
+ # Start with the name of the previous nonblank token...
+ my $name = "";
+ my $im = $i - 1;
+ return "" if ( $im < 0 );
+ if ( $types_to_go[$im] eq 'b' ) { $im--; }
+ return "" if ( $im < 0 );
+ $name = $tokens_to_go[$im];
+
+ # Prepend any sub name to an isolated -> to avoid unwanted alignments
+ # [test case is test8/penco.pl]
+ if ( $name eq '->' ) {
+ $im--;
+ if ( $im >= 0 && $types_to_go[$im] ne 'b' ) {
+ $name = $tokens_to_go[$im] . $name;
+ }
+ }
+
+ # Finally, remove any leading arrows
+ if ( substr( $name, 0, 2 ) eq '->' ) {
+ $name = substr( $name, 2 );
+ }
+ return $name;
+}
+
+{ ## begin closure set_adjusted_indentation
+
+ my ( $last_indentation_written, $last_unadjusted_indentation,
+ $last_leading_token );
+
+ sub initialize_adjusted_indentation {
+ $last_indentation_written = 0;
+ $last_unadjusted_indentation = 0;
+ $last_leading_token = "";
+ return;
+ }
+
+ sub set_adjusted_indentation {
+
+ # This routine has the final say regarding the actual indentation of
+ # a line. It starts with the basic indentation which has been
+ # defined for the leading token, and then takes into account any
+ # options that the user has set regarding special indenting and
+ # outdenting.
+
+ # This routine has to resolve a number of complex interacting issues,
+ # including:
+ # 1. The various -cti=n type flags, which contain the desired change in
+ # indentation for lines ending in commas and semicolons, should be
+ # followed,
+ # 2. qw quotes require special processing and do not fit perfectly
+ # with normal containers,
+ # 3. formatting with -wn can complicate things, especially with qw
+ # quotes,
+ # 4. formatting with the -lp option is complicated, and does not
+ # work well with qw quotes and with -wn formatting.
+ # 5. a number of special situations, such as 'cuddled' formatting.
+ # 6. This routine is mainly concerned with outdenting closing tokens
+ # but note that there is some overlap with the functions of sub
+ # undo_ci, which was processed earlier, so care has to be taken to
+ # keep them coordinated.
+
+ my (
+ $self, $ibeg,
+ $iend, $rfields,
+ $rpatterns, $ri_first,
+ $ri_last, $rindentation_list,
+ $level_jump, $starting_in_quote,
+ $is_static_block_comment,
+ ) = @_;
+
+ my $rLL = $self->[_rLL_];
+ my $ris_bli_container = $self->[_ris_bli_container_];
+ my $rseqno_controlling_my_ci = $self->[_rseqno_controlling_my_ci_];
+ my $rwant_reduced_ci = $self->[_rwant_reduced_ci_];
+ my $rK_weld_left = $self->[_rK_weld_left_];
+
+ # we need to know the last token of this line
+ my ( $terminal_type, $i_terminal ) = terminal_type_i( $ibeg, $iend );
+
+ my $terminal_block_type = $block_type_to_go[$i_terminal];
+ my $is_outdented_line = 0;
+
+ my $terminal_is_in_list = $self->is_in_list_by_i($i_terminal);
+
+ my $type_beg = $types_to_go[$ibeg];
+ my $token_beg = $tokens_to_go[$ibeg];
+ my $K_beg = $K_to_go[$ibeg];
+ my $ibeg_weld_fix = $ibeg;
+ my $seqno_beg = $type_sequence_to_go[$ibeg];
+ my $is_bli_beg = $seqno_beg ? $ris_bli_container->{$seqno_beg} : 0;
+
+ # QW INDENTATION PATCH 3:
+ my $seqno_qw_closing;
+ if ( $type_beg eq 'q' && $ibeg == 0 ) {
+ my $KK = $K_to_go[$ibeg];
+ $seqno_qw_closing =
+ $self->[_rending_multiline_qw_seqno_by_K_]->{$KK};
+ }
+
+ my $is_semicolon_terminated = $terminal_type eq ';'
+ && ( $nesting_depth_to_go[$iend] < $nesting_depth_to_go[$ibeg]
+ || $seqno_qw_closing );
+
+ # NOTE: A future improvement would be to make it semicolon terminated
+ # even if it does not have a semicolon but is followed by a closing
+ # block brace. This would undo ci even for something like the
+ # following, in which the final paren does not have a semicolon because
+ # it is a possible weld location:
+
+ # if ($BOLD_MATH) {
+ # (
+ # $labels, $comment,
+ # join( '', '<B>', &make_math( $mode, '', '', $_ ), '</B>' )
+ # )
+ # }
+ #
+
+ # MOJO: Set a flag if this lines begins with ')->'
+ my $leading_paren_arrow = (
+ $types_to_go[$ibeg] eq '}'
+ && $tokens_to_go[$ibeg] eq ')'
+ && (
+ ( $ibeg < $i_terminal && $types_to_go[ $ibeg + 1 ] eq '->' )
+ || ( $ibeg < $i_terminal - 1
+ && $types_to_go[ $ibeg + 1 ] eq 'b'
+ && $types_to_go[ $ibeg + 2 ] eq '->' )
+ )
+ );
+
+ ##########################################################
+ # Section 1: set a flag and a default indentation
+ #
+ # Most lines are indented according to the initial token.
+ # But it is common to outdent to the level just after the
+ # terminal token in certain cases...
+ # adjust_indentation flag:
+ # 0 - do not adjust
+ # 1 - outdent
+ # 2 - vertically align with opening token
+ # 3 - indent
+ ##########################################################
+ my $adjust_indentation = 0;
+ my $default_adjust_indentation = $adjust_indentation;
+
+ my (
+ $opening_indentation, $opening_offset,
+ $is_leading, $opening_exists
+ );
+
+ # Honor any flag to reduce -ci set by the -bbxi=n option
+ if ( $seqno_beg && $rwant_reduced_ci->{$seqno_beg} ) {
+
+ # if this is an opening, it must be alone on the line ...
+ if ( $is_closing_type{$type_beg} || $ibeg == $i_terminal ) {
+ $adjust_indentation = 1;
+ }
+
+ # ... or a single welded unit (fix for b1173)
+ elsif ($total_weld_count) {
+ my $Kterm = $K_to_go[$i_terminal];
+ my $Kterm_test = $rK_weld_left->{$Kterm};
+ if ( defined($Kterm_test) && $Kterm_test >= $K_beg ) {
+ $Kterm = $Kterm_test;
+ }
+ if ( $Kterm == $K_beg ) { $adjust_indentation = 1 }
+ }
+ }
+
+ # Update the $is_bli flag as we go. It is initially 1.
+ # We note seeing a leading opening brace by setting it to 2.
+ # If we get to the closing brace without seeing the opening then we
+ # turn it off. This occurs if the opening brace did not get output
+ # at the start of a line, so we will then indent the closing brace
+ # in the default way.
+ if ( $is_bli_beg && $is_bli_beg == 1 ) {
+ my $K_opening_container = $self->[_K_opening_container_];
+ my $K_opening = $K_opening_container->{$seqno_beg};
+ if ( $K_beg eq $K_opening ) {
+ $ris_bli_container->{$seqno_beg} = $is_bli_beg = 2;
+ }
+ else { $is_bli_beg = 0 }
+ }
+
+ # QW PATCH for the combination -lp -wn
+ # For -lp formatting use $ibeg_weld_fix to get around the problem
+ # that with -lp type formatting the opening and closing tokens to not
+ # have sequence numbers.
+ if ( $seqno_qw_closing && $total_weld_count ) {
+ my $K_next_nonblank = $self->K_next_code($K_beg);
+ if ( defined($K_next_nonblank)
+ && defined( $rK_weld_left->{$K_next_nonblank} ) )
+ {
+ my $itest = $ibeg + ( $K_next_nonblank - $K_beg );
+ if ( $itest <= $max_index_to_go ) {
+ $ibeg_weld_fix = $itest;
+ }
+ }
+ }
+
+ # if we are at a closing token of some type..
+ if ( $is_closing_type{$type_beg} || $seqno_qw_closing ) {
+
+ # get the indentation of the line containing the corresponding
+ # opening token
+ (
+ $opening_indentation, $opening_offset,
+ $is_leading, $opening_exists
+ )
+ = $self->get_opening_indentation( $ibeg_weld_fix, $ri_first,
+ $ri_last, $rindentation_list, $seqno_qw_closing );
+
+ # First set the default behavior:
+ if (
+
+ # default behavior is to outdent closing lines
+ # of the form: "); }; ]; )->xxx;"
+ $is_semicolon_terminated
+
+ # and 'cuddled parens' of the form: ")->pack("
+ # Bug fix for RT #123749]: the types here were
+ # incorrectly '(' and ')'. Corrected to be '{' and '}'
+ || (
+ $terminal_type eq '{'
+ && $type_beg eq '}'
+ && ( $nesting_depth_to_go[$iend] + 1 ==
+ $nesting_depth_to_go[$ibeg] )
+ )
+
+ # remove continuation indentation for any line like
+ # } ... {
+ # or without ending '{' and unbalanced, such as
+ # such as '}->{$operator}'
+ || (
+ $type_beg eq '}'
+
+ && ( $types_to_go[$iend] eq '{'
+ || $levels_to_go[$iend] < $levels_to_go[$ibeg] )
+ )
+
+ # and when the next line is at a lower indentation level...
+
+ # PATCH #1: and only if the style allows undoing continuation
+ # for all closing token types. We should really wait until
+ # the indentation of the next line is known and then make
+ # a decision, but that would require another pass.
+
+ # PATCH #2: and not if this token is under -xci control
+ || ( $level_jump < 0
+ && !$some_closing_token_indentation
+ && !$rseqno_controlling_my_ci->{$K_beg} )
+
+ # Patch for -wn=2, multiple welded closing tokens
+ || ( $i_terminal > $ibeg
+ && $is_closing_type{ $types_to_go[$iend] } )
+
+ # Alternate Patch for git #51, isolated closing qw token not
+ # outdented if no-delete-old-newlines is set. This works, but
+ # a more general patch elsewhere fixes the real problem: ljump.
+ # || ( $seqno_qw_closing && $ibeg == $i_terminal )
+
+ )
+ {
+ $adjust_indentation = 1;
+ }
+
+ # outdent something like '),'
+ if (
+ $terminal_type eq ','
+
+ # Removed this constraint for -wn
+ # OLD: allow just one character before the comma
+ # && $i_terminal == $ibeg + 1
+
+ # require LIST environment; otherwise, we may outdent too much -
+ # this can happen in calls without parentheses (overload.t);
+ && $terminal_is_in_list
+ )
+ {
+ $adjust_indentation = 1;
+ }
+
+ # undo continuation indentation of a terminal closing token if
+ # it is the last token before a level decrease. This will allow
+ # a closing token to line up with its opening counterpart, and
+ # avoids an indentation jump larger than 1 level.
+ if ( $types_to_go[$i_terminal] =~ /^[\}\]\)R]$/
+ && $i_terminal == $ibeg
+ && defined($K_beg) )
+ {
+ my $K_next_nonblank = $self->K_next_code($K_beg);
+
+ if ( !$is_bli_beg && defined($K_next_nonblank) ) {
+ my $lev = $rLL->[$K_beg]->[_LEVEL_];
+ my $level_next = $rLL->[$K_next_nonblank]->[_LEVEL_];
+
+ # and do not undo ci if it was set by the -xci option
+ $adjust_indentation = 1
+ if ( $level_next < $lev
+ && !$rseqno_controlling_my_ci->{$K_beg} );
+ }
+
+ # Patch for RT #96101, in which closing brace of anonymous subs
+ # was not outdented. We should look ahead and see if there is
+ # a level decrease at the next token (i.e., a closing token),
+ # but right now we do not have that information. For now
+ # we see if we are in a list, and this works well.
+ # See test files 'sub*.t' for good test cases.
+ if ( $block_type_to_go[$ibeg] =~ /$ASUB_PATTERN/
+ && $terminal_is_in_list
+ && !$rOpts->{'indent-closing-brace'} )
+ {
+ (
+ $opening_indentation, $opening_offset,
+ $is_leading, $opening_exists
+ )
+ = $self->get_opening_indentation( $ibeg, $ri_first,
+ $ri_last, $rindentation_list );
+ my $indentation = $leading_spaces_to_go[$ibeg];
+ if ( defined($opening_indentation)
+ && get_spaces($indentation) >
+ get_spaces($opening_indentation) )
+ {
+ $adjust_indentation = 1;
+ }
+ }
+ }
+
+ # YVES patch 1 of 2:
+ # Undo ci of line with leading closing eval brace,
+ # but not beyond the indention of the line with
+ # the opening brace.
+ if ( $block_type_to_go[$ibeg] eq 'eval'
+ && !$rOpts->{'line-up-parentheses'}
+ && !$rOpts->{'indent-closing-brace'} )
+ {
+ (
+ $opening_indentation, $opening_offset,
+ $is_leading, $opening_exists
+ )
+ = $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
+ $rindentation_list );
+ my $indentation = $leading_spaces_to_go[$ibeg];
+ if ( defined($opening_indentation)
+ && get_spaces($indentation) >
+ get_spaces($opening_indentation) )
+ {
+ $adjust_indentation = 1;
+ }
+ }
+
+ # patch for issue git #40: -bli setting has priority
+ $adjust_indentation = 0 if ($is_bli_beg);
+
+ $default_adjust_indentation = $adjust_indentation;
+
+ # Now modify default behavior according to user request:
+ # handle option to indent non-blocks of the form ); }; ];
+ # But don't do special indentation to something like ')->pack('
+ if ( !$block_type_to_go[$ibeg] ) {
+
+ # Note that logical padding has already been applied, so we may
+ # need to remove some spaces to get a valid hash key.
+ my $tok = $tokens_to_go[$ibeg];
+ my $cti = $closing_token_indentation{$tok};
+
+ # Fix the value of 'cti' for an isloated non-welded closing qw
+ # delimiter.
+ if ( $seqno_qw_closing && $ibeg_weld_fix == $ibeg ) {
+
+ # A quote delimiter which is not a container will not have
+ # a cti value defined. In this case use the style of a
+ # paren. For example
+ # my @fars = (
+ # qw<
+ # far
+ # farfar
+ # farfars-far
+ # >,
+ # );
+ if ( !defined($cti) && length($tok) == 1 ) {
+
+ # something other than ')', '}', ']' ; use flag for ')'
+ $cti = $closing_token_indentation{')'};
+
+ # But for now, do not outdent non-container qw
+ # delimiters because it would would change existing
+ # formatting.
+ if ( $tok ne '>' ) { $cti = 3 }
+ }
+
+ # A non-welded closing qw cannot currently use -cti=1
+ # because that option requires a sequence number to find
+ # the opening indentation, and qw quote delimiters are not
+ # sequenced items.
+ if ( defined($cti) && $cti == 1 ) { $cti = 0 }
+ }
+
+ if ( !defined($cti) ) {
+
+ # $cti may not be defined for several reasons.
+ # -padding may have been applied so the character
+ # has a length > 1
+ # - we may have welded to a closing quote token.
+ # Here is an example (perltidy -wn):
+ # __PACKAGE__->load_components( qw(
+ # > Core
+ # >
+ # > ) );
+ $adjust_indentation = 0;
+
+ }
+ elsif ( $cti == 1 ) {
+ if ( $i_terminal <= $ibeg + 1
+ || $is_semicolon_terminated )
+ {
+ $adjust_indentation = 2;
+ }
+ else {
+ $adjust_indentation = 0;
+ }
+ }
+ elsif ( $cti == 2 ) {
+ if ($is_semicolon_terminated) {
+ $adjust_indentation = 3;
+ }
+ else {
+ $adjust_indentation = 0;
+ }
+ }
+ elsif ( $cti == 3 ) {
+ $adjust_indentation = 3;
+ }
+ }
+
+ # handle option to indent blocks
+ else {
+ if (
+ $rOpts->{'indent-closing-brace'}
+ && (
+ $i_terminal == $ibeg # isolated terminal '}'
+ || $is_semicolon_terminated
+ )
+ ) # } xxxx ;
+ {
+ $adjust_indentation = 3;
+ }
+ }
+ }
+
+ # if at ');', '};', '>;', and '];' of a terminal qw quote
+ elsif ($rpatterns->[0] =~ /^qb*;$/
+ && $rfields->[0] =~ /^([\)\}\]\>]);$/ )
+ {
+ if ( $closing_token_indentation{$1} == 0 ) {
+ $adjust_indentation = 1;
+ }
+ else {
+ $adjust_indentation = 3;
+ }
+ }
+
+ # if line begins with a ':', align it with any
+ # previous line leading with corresponding ?
+ elsif ( $types_to_go[$ibeg] eq ':' ) {
+ (
+ $opening_indentation, $opening_offset,
+ $is_leading, $opening_exists
+ )
+ = $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
+ $rindentation_list );
+ if ($is_leading) { $adjust_indentation = 2; }
+ }
+
+ ##########################################################
+ # Section 2: set indentation according to flag set above
+ #
+ # Select the indentation object to define leading
+ # whitespace. If we are outdenting something like '} } );'
+ # then we want to use one level below the last token
+ # ($i_terminal) in order to get it to fully outdent through
+ # all levels.
+ ##########################################################
+ my $indentation;
+ my $lev;
+ my $level_end = $levels_to_go[$iend];
+
+ if ( $adjust_indentation == 0 ) {
+ $indentation = $leading_spaces_to_go[$ibeg];
+ $lev = $levels_to_go[$ibeg];
+ }
+ elsif ( $adjust_indentation == 1 ) {
+
+ # Change the indentation to be that of a different token on the line
+ # Previously, the indentation of the terminal token was used:
+ # OLD CODING:
+ # $indentation = $reduced_spaces_to_go[$i_terminal];
+ # $lev = $levels_to_go[$i_terminal];
+
+ # Generalization for MOJO:
+ # Use the lowest level indentation of the tokens on the line.
+ # For example, here we can use the indentation of the ending ';':
+ # } until ($selection > 0 and $selection < 10); # ok to use ';'
+ # But this will not outdent if we use the terminal indentation:
+ # )->then( sub { # use indentation of the ->, not the {
+ # Warning: reduced_spaces_to_go[] may be a reference, do not
+ # do numerical checks with it
+
+ my $i_ind = $ibeg;
+ $indentation = $reduced_spaces_to_go[$i_ind];
+ $lev = $levels_to_go[$i_ind];
+ while ( $i_ind < $i_terminal ) {
+ $i_ind++;
+ if ( $levels_to_go[$i_ind] < $lev ) {
+ $indentation = $reduced_spaces_to_go[$i_ind];
+ $lev = $levels_to_go[$i_ind];
+ }
+ }
+ }
+
+ # handle indented closing token which aligns with opening token
+ elsif ( $adjust_indentation == 2 ) {
+
+ # handle option to align closing token with opening token
+ $lev = $levels_to_go[$ibeg];
+
+ # calculate spaces needed to align with opening token
+ my $space_count =
+ get_spaces($opening_indentation) + $opening_offset;
+
+ # Indent less than the previous line.
+ #
+ # Problem: For -lp we don't exactly know what it was if there
+ # were recoverable spaces sent to the aligner. A good solution
+ # would be to force a flush of the vertical alignment buffer, so
+ # that we would know. For now, this rule is used for -lp:
+ #
+ # When the last line did not start with a closing token we will
+ # be optimistic that the aligner will recover everything wanted.
+ #
+ # This rule will prevent us from breaking a hierarchy of closing
+ # tokens, and in a worst case will leave a closing paren too far
+ # indented, but this is better than frequently leaving it not
+ # indented enough.
+ my $last_spaces = get_spaces($last_indentation_written);
+ if ( !$is_closing_token{$last_leading_token} ) {
+ $last_spaces +=
+ get_recoverable_spaces($last_indentation_written);
+ }
+
+ # reset the indentation to the new space count if it works
+ # only options are all or none: nothing in-between looks good
+ $lev = $levels_to_go[$ibeg];
+ if ( $space_count < $last_spaces ) {
+ if ($rOpts_line_up_parentheses) {
+ my $lev = $levels_to_go[$ibeg];
+ $indentation =
+ new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
+ }
+ else {
+ $indentation = $space_count;
+ }
+ }
+
+ # revert to default if it doesn't work
+ else {
+ $space_count = leading_spaces_to_go($ibeg);
+ if ( $default_adjust_indentation == 0 ) {
+ $indentation = $leading_spaces_to_go[$ibeg];
+ }
+ elsif ( $default_adjust_indentation == 1 ) {
+ $indentation = $reduced_spaces_to_go[$i_terminal];
+ $lev = $levels_to_go[$i_terminal];
+ }
+ }
+ }
+
+ # Full indentaion of closing tokens (-icb and -icp or -cti=2)
+ else {
+
+ # handle -icb (indented closing code block braces)
+ # Updated method for indented block braces: indent one full level if
+ # there is no continuation indentation. This will occur for major
+ # structures such as sub, if, else, but not for things like map
+ # blocks.
+ #
+ # Note: only code blocks without continuation indentation are
+ # handled here (if, else, unless, ..). In the following snippet,
+ # the terminal brace of the sort block will have continuation
+ # indentation as shown so it will not be handled by the coding
+ # here. We would have to undo the continuation indentation to do
+ # this, but it probably looks ok as is. This is a possible future
+ # update for semicolon terminated lines.
+ #
+ # if ($sortby eq 'date' or $sortby eq 'size') {
+ # @files = sort {
+ # $file_data{$a}{$sortby} <=> $file_data{$b}{$sortby}
+ # or $a cmp $b
+ # } @files;
+ # }
+ #
+ if ( $block_type_to_go[$ibeg]
+ && $ci_levels_to_go[$i_terminal] == 0 )
+ {
+ my $spaces = get_spaces( $leading_spaces_to_go[$i_terminal] );
+ $indentation = $spaces + $rOpts_indent_columns;