"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/lib/Perl/Tidy/VerticalAligner.pm" (7 Jan 2020, 127511 Bytes) of package /linux/misc/Perl-Tidy-20200110.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "VerticalAligner.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20191203_vs_20200110.

    1 package Perl::Tidy::VerticalAligner;
    2 use strict;
    3 use warnings;
    4 our $VERSION = '20200110';
    5 
    6 use Perl::Tidy::VerticalAligner::Alignment;
    7 use Perl::Tidy::VerticalAligner::Line;
    8 
    9 # The Perl::Tidy::VerticalAligner package collects output lines and
   10 # attempts to line up certain common tokens, such as => and #, which are
   11 # identified by the calling routine.
   12 #
   13 # There are two main routines: valign_input and flush.  Append acts as a
   14 # storage buffer, collecting lines into a group which can be vertically
   15 # aligned.  When alignment is no longer possible or desirable, it dumps
   16 # the group to flush.
   17 #
   18 #     valign_input -----> flush
   19 #
   20 #     collects          writes
   21 #     vertical          one
   22 #     groups            group
   23 
   24 BEGIN {
   25 
   26     # Caution: these debug flags produce a lot of output
   27     # They should all be 0 except when debugging small scripts
   28 
   29     use constant VALIGN_DEBUG_FLAG_APPEND  => 0;
   30     use constant VALIGN_DEBUG_FLAG_APPEND0 => 0;
   31     use constant VALIGN_DEBUG_FLAG_TERNARY => 0;
   32     use constant VALIGN_DEBUG_FLAG_TABS    => 0;
   33 
   34     my $debug_warning = sub {
   35         print STDOUT "VALIGN_DEBUGGING with key $_[0]\n";
   36         return;
   37     };
   38 
   39     VALIGN_DEBUG_FLAG_APPEND  && $debug_warning->('APPEND');
   40     VALIGN_DEBUG_FLAG_APPEND0 && $debug_warning->('APPEND0');
   41     VALIGN_DEBUG_FLAG_TERNARY && $debug_warning->('TERNARY');
   42     VALIGN_DEBUG_FLAG_TABS    && $debug_warning->('TABS');
   43 
   44 }
   45 
   46 use vars qw(
   47   $vertical_aligner_self
   48   $maximum_alignment_index
   49   $ralignment_list
   50   $maximum_jmax_seen
   51   $minimum_jmax_seen
   52   $previous_minimum_jmax_seen
   53   $previous_maximum_jmax_seen
   54   @group_lines
   55   $group_level
   56   $group_type
   57   $group_maximum_gap
   58   $marginal_match
   59   $last_level_written
   60   $last_leading_space_count
   61   $extra_indent_ok
   62   $zero_count
   63   $last_comment_column
   64   $last_side_comment_line_number
   65   $last_side_comment_length
   66   $last_side_comment_level
   67   $outdented_line_count
   68   $first_outdented_line_at
   69   $last_outdented_line_at
   70   $diagnostics_object
   71   $logger_object
   72   $file_writer_object
   73   @side_comment_history
   74   $comment_leading_space_count
   75   $is_matching_terminal_line
   76   $consecutive_block_comments
   77 
   78   $cached_line_text
   79   $cached_line_type
   80   $cached_line_flag
   81   $cached_seqno
   82   $cached_line_valid
   83   $cached_line_leading_space_count
   84   $cached_seqno_string
   85 
   86   $valign_buffer_filling
   87   @valign_buffer
   88 
   89   $seqno_string
   90   $last_nonblank_seqno_string
   91 
   92   $rOpts
   93 
   94   $rOpts_maximum_line_length
   95   $rOpts_variable_maximum_line_length
   96   $rOpts_continuation_indentation
   97   $rOpts_indent_columns
   98   $rOpts_tabs
   99   $rOpts_entab_leading_whitespace
  100   $rOpts_valign
  101 
  102   $rOpts_fixed_position_side_comment
  103   $rOpts_minimum_space_to_comment
  104 
  105 );
  106 
  107 sub initialize {
  108 
  109     (
  110         my $class, $rOpts, $file_writer_object, $logger_object,
  111         $diagnostics_object
  112     ) = @_;
  113 
  114     # variables describing the entire space group:
  115     $ralignment_list            = [];
  116     $group_level                = 0;
  117     $last_level_written         = -1;
  118     $extra_indent_ok            = 0;    # can we move all lines to the right?
  119     $last_side_comment_length   = 0;
  120     $maximum_jmax_seen          = 0;
  121     $minimum_jmax_seen          = 0;
  122     $previous_minimum_jmax_seen = 0;
  123     $previous_maximum_jmax_seen = 0;
  124 
  125     # variables describing each line of the group
  126     @group_lines = ();                  # list of all lines in group
  127 
  128     $outdented_line_count          = 0;
  129     $first_outdented_line_at       = 0;
  130     $last_outdented_line_at        = 0;
  131     $last_side_comment_line_number = 0;
  132     $last_side_comment_level       = -1;
  133     $is_matching_terminal_line     = 0;
  134 
  135     # most recent 3 side comments; [ line number, column ]
  136     $side_comment_history[0] = [ -300, 0 ];
  137     $side_comment_history[1] = [ -200, 0 ];
  138     $side_comment_history[2] = [ -100, 0 ];
  139 
  140     # valign_output_step_B cache:
  141     $cached_line_text                = "";
  142     $cached_line_type                = 0;
  143     $cached_line_flag                = 0;
  144     $cached_seqno                    = 0;
  145     $cached_line_valid               = 0;
  146     $cached_line_leading_space_count = 0;
  147     $cached_seqno_string             = "";
  148 
  149     # string of sequence numbers joined together
  150     $seqno_string               = "";
  151     $last_nonblank_seqno_string = "";
  152 
  153     # frequently used parameters
  154     $rOpts_indent_columns           = $rOpts->{'indent-columns'};
  155     $rOpts_tabs                     = $rOpts->{'tabs'};
  156     $rOpts_entab_leading_whitespace = $rOpts->{'entab-leading-whitespace'};
  157     $rOpts_fixed_position_side_comment =
  158       $rOpts->{'fixed-position-side-comment'};
  159     $rOpts_minimum_space_to_comment = $rOpts->{'minimum-space-to-comment'};
  160     $rOpts_maximum_line_length      = $rOpts->{'maximum-line-length'};
  161     $rOpts_variable_maximum_line_length =
  162       $rOpts->{'variable-maximum-line-length'};
  163     $rOpts_valign = $rOpts->{'valign'};
  164 
  165     $consecutive_block_comments = 0;
  166     forget_side_comment();
  167 
  168     initialize_for_new_group();
  169 
  170     $vertical_aligner_self = {};
  171     bless $vertical_aligner_self, $class;
  172     return $vertical_aligner_self;
  173 }
  174 
  175 sub initialize_for_new_group {
  176     @group_lines                 = ();
  177     $maximum_alignment_index     = -1;  # alignments in current group
  178     $zero_count                  = 0;   # count consecutive lines without tokens
  179     $group_maximum_gap           = 0;   # largest gap introduced
  180     $group_type                  = "";
  181     $marginal_match              = 0;
  182     $comment_leading_space_count = 0;
  183     $last_leading_space_count    = 0;
  184     return;
  185 }
  186 
  187 # interface to Perl::Tidy::Diagnostics routines
  188 sub write_diagnostics {
  189     my $msg = shift;
  190     if ($diagnostics_object) {
  191         $diagnostics_object->write_diagnostics($msg);
  192     }
  193     return;
  194 }
  195 
  196 # interface to Perl::Tidy::Logger routines
  197 sub warning {
  198     my ($msg) = @_;
  199     if ($logger_object) {
  200         $logger_object->warning($msg);
  201     }
  202     return;
  203 }
  204 
  205 sub write_logfile_entry {
  206     my ($msg) = @_;
  207     if ($logger_object) {
  208         $logger_object->write_logfile_entry($msg);
  209     }
  210     return;
  211 }
  212 
  213 sub report_definite_bug {
  214     if ($logger_object) {
  215         $logger_object->report_definite_bug();
  216     }
  217     return;
  218 }
  219 
  220 sub get_cached_line_count {
  221     my $self = shift;
  222     return @group_lines + ( $cached_line_type ? 1 : 0 );
  223 }
  224 
  225 sub get_spaces {
  226 
  227     # return the number of leading spaces associated with an indentation
  228     # variable $indentation is either a constant number of spaces or an
  229     # object with a get_spaces method.
  230     my $indentation = shift;
  231     return ref($indentation) ? $indentation->get_spaces() : $indentation;
  232 }
  233 
  234 sub get_recoverable_spaces {
  235 
  236     # return the number of spaces (+ means shift right, - means shift left)
  237     # that we would like to shift a group of lines with the same indentation
  238     # to get them to line up with their opening parens
  239     my $indentation = shift;
  240     return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
  241 }
  242 
  243 sub get_stack_depth {
  244 
  245     my $indentation = shift;
  246     return ref($indentation) ? $indentation->get_stack_depth() : 0;
  247 }
  248 
  249 sub make_alignment {
  250     my ( $col, $token ) = @_;
  251 
  252     # make one new alignment at column $col which aligns token $token
  253     ++$maximum_alignment_index;
  254 
  255     #my $alignment = new Perl::Tidy::VerticalAligner::Alignment(
  256     my $nlines    = @group_lines;
  257     my $alignment = Perl::Tidy::VerticalAligner::Alignment->new(
  258         column          => $col,
  259         starting_column => $col,
  260         matching_token  => $token,
  261         starting_line   => $nlines - 1,
  262         ending_line     => $nlines - 1,
  263         serial_number   => $maximum_alignment_index,
  264     );
  265     $ralignment_list->[$maximum_alignment_index] = $alignment;
  266     return $alignment;
  267 }
  268 
  269 sub dump_alignments {
  270     print STDOUT
  271 "Current Alignments:\ni\ttoken\tstarting_column\tcolumn\tstarting_line\tending_line\n";
  272     for my $i ( 0 .. $maximum_alignment_index ) {
  273         my $column          = $ralignment_list->[$i]->get_column();
  274         my $starting_column = $ralignment_list->[$i]->get_starting_column();
  275         my $matching_token  = $ralignment_list->[$i]->get_matching_token();
  276         my $starting_line   = $ralignment_list->[$i]->get_starting_line();
  277         my $ending_line     = $ralignment_list->[$i]->get_ending_line();
  278         print STDOUT
  279 "$i\t$matching_token\t$starting_column\t$column\t$starting_line\t$ending_line\n";
  280     }
  281     return;
  282 }
  283 
  284 sub save_alignment_columns {
  285     for my $i ( 0 .. $maximum_alignment_index ) {
  286         $ralignment_list->[$i]->save_column();
  287     }
  288     return;
  289 }
  290 
  291 sub restore_alignment_columns {
  292     for my $i ( 0 .. $maximum_alignment_index ) {
  293         $ralignment_list->[$i]->restore_column();
  294     }
  295     return;
  296 }
  297 
  298 sub forget_side_comment {
  299     $last_comment_column = 0;
  300     return;
  301 }
  302 
  303 sub maximum_line_length_for_level {
  304 
  305     # return maximum line length for line starting with a given level
  306     my $maximum_line_length = $rOpts_maximum_line_length;
  307     if ($rOpts_variable_maximum_line_length) {
  308         my $level = shift;
  309         if ( $level < 0 ) { $level = 0 }
  310         $maximum_line_length += $level * $rOpts_indent_columns;
  311     }
  312     return $maximum_line_length;
  313 }
  314 
  315 sub push_group_line {
  316 
  317     my ($new_line) = @_;
  318     push @group_lines, $new_line;
  319     return;
  320 }
  321 
  322 sub valign_input {
  323 
  324     # Place one line in the current vertical group.
  325     #
  326     # The input parameters are:
  327     #     $level = indentation level of this line
  328     #     $rfields = reference to array of fields
  329     #     $rpatterns = reference to array of patterns, one per field
  330     #     $rtokens   = reference to array of tokens starting fields 1,2,..
  331     #
  332     # Here is an example of what this package does.  In this example,
  333     # we are trying to line up both the '=>' and the '#'.
  334     #
  335     #         '18' => 'grave',    #   \`
  336     #         '19' => 'acute',    #   `'
  337     #         '20' => 'caron',    #   \v
  338     # <-tabs-><f1-><--field 2 ---><-f3->
  339     # |            |              |    |
  340     # |            |              |    |
  341     # col1        col2         col3 col4
  342     #
  343     # The calling routine has already broken the entire line into 3 fields as
  344     # indicated.  (So the work of identifying promising common tokens has
  345     # already been done).
  346     #
  347     # In this example, there will be 2 tokens being matched: '=>' and '#'.
  348     # They are the leading parts of fields 2 and 3, but we do need to know
  349     # what they are so that we can dump a group of lines when these tokens
  350     # change.
  351     #
  352     # The fields contain the actual characters of each field.  The patterns
  353     # are like the fields, but they contain mainly token types instead
  354     # of tokens, so they have fewer characters.  They are used to be
  355     # sure we are matching fields of similar type.
  356     #
  357     # In this example, there will be 4 column indexes being adjusted.  The
  358     # first one is always at zero.  The interior columns are at the start of
  359     # the matching tokens, and the last one tracks the maximum line length.
  360     #
  361     # Each time a new line comes in, it joins the current vertical
  362     # group if possible.  Otherwise it causes the current group to be dumped
  363     # and a new group is started.
  364     #
  365     # For each new group member, the column locations are increased, as
  366     # necessary, to make room for the new fields.  When the group is finally
  367     # output, these column numbers are used to compute the amount of spaces of
  368     # padding needed for each field.
  369     #
  370     # Programming note: the fields are assumed not to have any tab characters.
  371     # Tabs have been previously removed except for tabs in quoted strings and
  372     # side comments.  Tabs in these fields can mess up the column counting.
  373     # The log file warns the user if there are any such tabs.
  374 
  375     my ( $rline_hash, $rfields, $rtokens, $rpatterns ) = @_;
  376     my $level                     = $rline_hash->{level};
  377     my $level_end                 = $rline_hash->{level_end};
  378     my $indentation               = $rline_hash->{indentation};
  379     my $is_forced_break           = $rline_hash->{is_forced_break};
  380     my $outdent_long_lines        = $rline_hash->{outdent_long_lines};
  381     my $is_terminal_ternary       = $rline_hash->{is_terminal_ternary};
  382     my $is_terminal_statement     = $rline_hash->{is_terminal_statement};
  383     my $do_not_pad                = $rline_hash->{do_not_pad};
  384     my $rvertical_tightness_flags = $rline_hash->{rvertical_tightness_flags};
  385     my $level_jump                = $rline_hash->{level_jump};
  386 
  387     # number of fields is $jmax
  388     # number of tokens between fields is $jmax-1
  389     my $jmax = @{$rfields} - 1;
  390 
  391     my $leading_space_count = get_spaces($indentation);
  392 
  393     # set outdented flag to be sure we either align within statements or
  394     # across statement boundaries, but not both.
  395     my $is_outdented = $last_leading_space_count > $leading_space_count;
  396     $last_leading_space_count = $leading_space_count;
  397 
  398     # Patch: undo for hanging side comment
  399     my $is_hanging_side_comment =
  400       ( $jmax == 1 && $rtokens->[0] eq '#' && $rfields->[0] =~ /^\s*$/ );
  401     $is_outdented = 0 if $is_hanging_side_comment;
  402 
  403     # Forget side comment alignment after seeing 2 or more block comments
  404     my $is_block_comment = ( $jmax == 0 && $rfields->[0] =~ /^#/ );
  405     if ($is_block_comment) {
  406         $consecutive_block_comments++;
  407     }
  408     else {
  409         if ( $consecutive_block_comments > 1 ) { forget_side_comment() }
  410         $consecutive_block_comments = 0;
  411     }
  412 
  413     VALIGN_DEBUG_FLAG_APPEND0 && do {
  414         my $nlines = @group_lines;
  415         print STDOUT
  416 "APPEND0: entering lines=$nlines new #fields= $jmax, leading_count=$leading_space_count last_cmt=$last_comment_column force=$is_forced_break, level_jump=$level_jump, level=$level, group_level=$group_level, level_jump=$level_jump\n";
  417     };
  418 
  419     # Validate cached line if necessary: If we can produce a container
  420     # with just 2 lines total by combining an existing cached opening
  421     # token with the closing token to follow, then we will mark both
  422     # cached flags as valid.
  423     if ($rvertical_tightness_flags) {
  424         if (   @group_lines <= 1
  425             && $cached_line_type
  426             && $cached_seqno
  427             && $rvertical_tightness_flags->[2]
  428             && $rvertical_tightness_flags->[2] == $cached_seqno )
  429         {
  430             $rvertical_tightness_flags->[3] ||= 1;
  431             $cached_line_valid ||= 1;
  432         }
  433     }
  434 
  435     # do not join an opening block brace with an unbalanced line
  436     # unless requested with a flag value of 2
  437     if (   $cached_line_type == 3
  438         && !@group_lines
  439         && $cached_line_flag < 2
  440         && $level_jump != 0 )
  441     {
  442         $cached_line_valid = 0;
  443     }
  444 
  445     # patch until new aligner is finished
  446     if ($do_not_pad) { my_flush() }
  447 
  448     # shouldn't happen:
  449     if ( $level < 0 ) { $level = 0 }
  450 
  451     # do not align code across indentation level changes
  452     # or if vertical alignment is turned off for debugging
  453     if ( $level != $group_level || $is_outdented || !$rOpts_valign ) {
  454 
  455         # we are allowed to shift a group of lines to the right if its
  456         # level is greater than the previous and next group
  457         $extra_indent_ok =
  458           ( $level < $group_level && $last_level_written < $group_level );
  459 
  460         my_flush();
  461 
  462         # If we know that this line will get flushed out by itself because
  463         # of level changes, we can leave the extra_indent_ok flag set.
  464         # That way, if we get an external flush call, we will still be
  465         # able to do some -lp alignment if necessary.
  466         $extra_indent_ok = ( $is_terminal_statement && $level > $group_level );
  467 
  468         $group_level = $level;
  469 
  470         # wait until after the above flush to get the leading space
  471         # count because it may have been changed if the -icp flag is in
  472         # effect
  473         $leading_space_count = get_spaces($indentation);
  474 
  475     }
  476 
  477     # --------------------------------------------------------------------
  478     # Collect outdentable block COMMENTS
  479     # --------------------------------------------------------------------
  480     my $is_blank_line = "";
  481     if ( $group_type eq 'COMMENT' ) {
  482         if (
  483             (
  484                    $is_block_comment
  485                 && $outdent_long_lines
  486                 && $leading_space_count == $comment_leading_space_count
  487             )
  488             || $is_blank_line
  489           )
  490         {
  491             push_group_line( $rfields->[0] );
  492             return;
  493         }
  494         else {
  495             my_flush();
  496         }
  497     }
  498 
  499     # --------------------------------------------------------------------
  500     # add dummy fields for terminal ternary
  501     # --------------------------------------------------------------------
  502     my $j_terminal_match;
  503 
  504     if ( $is_terminal_ternary && @group_lines ) {
  505         $j_terminal_match =
  506           fix_terminal_ternary( $group_lines[-1], $rfields, $rtokens,
  507             $rpatterns );
  508         $jmax = @{$rfields} - 1;
  509     }
  510 
  511     # --------------------------------------------------------------------
  512     # add dummy fields for else statement
  513     # --------------------------------------------------------------------
  514 
  515     if (   $rfields->[0] =~ /^else\s*$/
  516         && @group_lines
  517         && $level_jump == 0 )
  518     {
  519 
  520         $j_terminal_match =
  521           fix_terminal_else( $group_lines[-1], $rfields, $rtokens, $rpatterns );
  522         $jmax = @{$rfields} - 1;
  523     }
  524 
  525     # --------------------------------------------------------------------
  526     # Handle simple line of code with no fields to match.
  527     # --------------------------------------------------------------------
  528     if ( $jmax <= 0 ) {
  529         $zero_count++;
  530 
  531         if ( @group_lines
  532             && !get_recoverable_spaces( $group_lines[0]->get_indentation() ) )
  533         {
  534 
  535             # flush the current group if it has some aligned columns..
  536             if ( $group_lines[0]->get_jmax() > 1 ) { my_flush() }
  537 
  538             # flush current group if we are just collecting side comments..
  539             elsif (
  540 
  541                 # ...and we haven't seen a comment lately
  542                 ( $zero_count > 3 )
  543 
  544                 # ..or if this new line doesn't fit to the left of the comments
  545                 || ( ( $leading_space_count + length( $rfields->[0] ) ) >
  546                     $group_lines[0]->get_column(0) )
  547               )
  548             {
  549                 my_flush();
  550             }
  551         }
  552 
  553         # start new COMMENT group if this comment may be outdented
  554         if (   $is_block_comment
  555             && $outdent_long_lines
  556             && !@group_lines )
  557         {
  558             $group_type                  = 'COMMENT';
  559             $comment_leading_space_count = $leading_space_count;
  560             push_group_line( $rfields->[0] );
  561             return;
  562         }
  563 
  564         # just write this line directly if no current group, no side comment,
  565         # and no space recovery is needed.
  566         if ( !@group_lines && !get_recoverable_spaces($indentation) ) {
  567             valign_output_step_B( $leading_space_count, $rfields->[0], 0,
  568                 $outdent_long_lines, $rvertical_tightness_flags, $level );
  569             return;
  570         }
  571     }
  572     else {
  573         $zero_count = 0;
  574     }
  575 
  576     # programming check: (shouldn't happen)
  577     # an error here implies an incorrect call was made
  578     if ( @{$rfields} && ( @{$rtokens} != ( @{$rfields} - 1 ) ) ) {
  579         my $nt = @{$rtokens};
  580         my $nf = @{$rfields};
  581         warning(
  582 "Program bug in Perl::Tidy::VerticalAligner - number of tokens = $nt should be one less than number of fields: $nf)\n"
  583         );
  584         report_definite_bug();
  585     }
  586     my $maximum_line_length_for_level = maximum_line_length_for_level($level);
  587 
  588     # --------------------------------------------------------------------
  589     # create an object to hold this line
  590     # --------------------------------------------------------------------
  591     my $new_line = Perl::Tidy::VerticalAligner::Line->new(
  592         jmax                      => $jmax,
  593         jmax_original_line        => $jmax,
  594         rtokens                   => $rtokens,
  595         rfields                   => $rfields,
  596         rpatterns                 => $rpatterns,
  597         indentation               => $indentation,
  598         leading_space_count       => $leading_space_count,
  599         outdent_long_lines        => $outdent_long_lines,
  600         list_type                 => "",
  601         is_hanging_side_comment   => $is_hanging_side_comment,
  602         maximum_line_length       => $maximum_line_length_for_level,
  603         rvertical_tightness_flags => $rvertical_tightness_flags,
  604         is_terminal_ternary       => $is_terminal_ternary,
  605         j_terminal_match          => $j_terminal_match,
  606     );
  607 
  608     # --------------------------------------------------------------------
  609     # It simplifies things to create a zero length side comment
  610     # if none exists.
  611     # --------------------------------------------------------------------
  612     make_side_comment( $new_line, $level_end );
  613 
  614     # --------------------------------------------------------------------
  615     # Decide if this is a simple list of items.
  616     # There are 3 list types: none, comma, comma-arrow.
  617     # We use this below to be less restrictive in deciding what to align.
  618     # --------------------------------------------------------------------
  619     if ($is_forced_break) {
  620         decide_if_list($new_line);
  621     }
  622 
  623     # --------------------------------------------------------------------
  624     # Append this line to the current group (or start new group)
  625     # --------------------------------------------------------------------
  626     if ( !@group_lines ) {
  627         add_to_group($new_line);
  628     }
  629     else {
  630         push_group_line($new_line);
  631     }
  632 
  633     # output this group if it ends in a terminal else or ternary line
  634     if ( defined($j_terminal_match) ) {
  635         my_flush();
  636     }
  637 
  638     # Force break after jump to lower level
  639     if ( $level_jump < 0 ) {
  640         my_flush();
  641     }
  642 
  643     # --------------------------------------------------------------------
  644     # Some old debugging stuff
  645     # --------------------------------------------------------------------
  646     VALIGN_DEBUG_FLAG_APPEND && do {
  647         print STDOUT "APPEND fields:";
  648         dump_array( @{$rfields} );
  649         print STDOUT "APPEND tokens:";
  650         dump_array( @{$rtokens} );
  651         print STDOUT "APPEND patterns:";
  652         dump_array( @{$rpatterns} );
  653         dump_alignments();
  654     };
  655 
  656     return;
  657 }
  658 
  659 sub join_hanging_comment {
  660 
  661     my $line = shift;
  662     my $jmax = $line->get_jmax();
  663     return 0 unless $jmax == 1;    # must be 2 fields
  664     my $rtokens = $line->get_rtokens();
  665     return 0 unless $rtokens->[0] eq '#';    # the second field is a comment..
  666     my $rfields = $line->get_rfields();
  667     return 0 unless $rfields->[0] =~ /^\s*$/;    # the first field is empty...
  668     my $old_line            = shift;
  669     my $maximum_field_index = $old_line->get_jmax();
  670     return 0
  671       unless $maximum_field_index > $jmax;    # the current line has more fields
  672     my $rpatterns = $line->get_rpatterns();
  673 
  674     $line->set_is_hanging_side_comment(1);
  675     $jmax = $maximum_field_index;
  676     $line->set_jmax($jmax);
  677     $rfields->[$jmax]         = $rfields->[1];
  678     $rtokens->[ $jmax - 1 ]   = $rtokens->[0];
  679     $rpatterns->[ $jmax - 1 ] = $rpatterns->[0];
  680     foreach my $j ( 1 .. $jmax - 1 ) {
  681         $rfields->[$j]         = " "; # NOTE: caused glitch unless 1 blank, why?
  682         $rtokens->[ $j - 1 ]   = "";
  683         $rpatterns->[ $j - 1 ] = "";
  684     }
  685     return 1;
  686 }
  687 
  688 sub eliminate_old_fields {
  689 
  690     my $new_line = shift;
  691     my $jmax     = $new_line->get_jmax();
  692     if ( $jmax > $maximum_jmax_seen ) { $maximum_jmax_seen = $jmax }
  693     if ( $jmax < $minimum_jmax_seen ) { $minimum_jmax_seen = $jmax }
  694 
  695     # there must be one previous line
  696     return unless ( @group_lines == 1 );
  697 
  698     my $old_line            = shift;
  699     my $maximum_field_index = $old_line->get_jmax();
  700 
  701     ###############################################
  702     # Moved below to allow new coding for => matches
  703     # return unless $maximum_field_index > $jmax;
  704     ###############################################
  705 
  706     # Identify specific cases where field elimination is allowed:
  707     # case=1: both lines have comma-separated lists, and the first
  708     #         line has an equals
  709     # case=2: both lines have leading equals
  710 
  711     # case 1 is the default
  712     my $case = 1;
  713 
  714     # See if case 2: both lines have leading '='
  715     # We'll require similar leading patterns in this case
  716     my $old_rtokens   = $old_line->get_rtokens();
  717     my $rtokens       = $new_line->get_rtokens();
  718     my $rpatterns     = $new_line->get_rpatterns();
  719     my $old_rpatterns = $old_line->get_rpatterns();
  720     if (   $rtokens->[0] =~ /^=>?\d*$/
  721         && $old_rtokens->[0] eq $rtokens->[0]
  722         && $old_rpatterns->[0] eq $rpatterns->[0] )
  723     {
  724         $case = 2;
  725     }
  726 
  727     # not too many fewer fields in new line for case 1
  728     return unless ( $case != 1 || $maximum_field_index - 2 <= $jmax );
  729 
  730     # case 1 must have side comment
  731     my $old_rfields = $old_line->get_rfields();
  732     return
  733       if ( $case == 1
  734         && length( $old_rfields->[$maximum_field_index] ) == 0 );
  735 
  736     my $rfields = $new_line->get_rfields();
  737 
  738     my $hid_equals = 0;
  739 
  740     my @new_alignments        = ();
  741     my @new_fields            = ();
  742     my @new_matching_patterns = ();
  743     my @new_matching_tokens   = ();
  744 
  745     my $j               = 0;
  746     my $current_field   = '';
  747     my $current_pattern = '';
  748 
  749     # loop over all old tokens
  750     my $in_match = 0;
  751     foreach my $k ( 0 .. $maximum_field_index - 1 ) {
  752         $current_field   .= $old_rfields->[$k];
  753         $current_pattern .= $old_rpatterns->[$k];
  754         last if ( $j > $jmax - 1 );
  755 
  756         if ( $old_rtokens->[$k] eq $rtokens->[$j] ) {
  757             $in_match                  = 1;
  758             $new_fields[$j]            = $current_field;
  759             $new_matching_patterns[$j] = $current_pattern;
  760             $current_field             = '';
  761             $current_pattern           = '';
  762             $new_matching_tokens[$j]   = $old_rtokens->[$k];
  763             $new_alignments[$j]        = $old_line->get_alignment($k);
  764             $j++;
  765         }
  766         else {
  767 
  768             if ( $old_rtokens->[$k] =~ /^\=\d*$/ ) {
  769                 last if ( $case == 2 );    # avoid problems with stuff
  770                                            # like:   $a=$b=$c=$d;
  771                 $hid_equals = 1;
  772             }
  773             last
  774               if ( $in_match && $case == 1 )
  775               ;    # disallow gaps in matching field types in case 1
  776         }
  777     }
  778 
  779     # Modify the current state if we are successful.
  780     # We must exactly reach the ends of the new list for success, and the old
  781     # pattern must have more fields. Here is an example where the first and
  782     # second lines have the same number, and we should not align:
  783     #  my @a = map chr, 0 .. 255;
  784     #  my @b = grep /\W/,    @a;
  785     #  my @c = grep /[^\w]/, @a;
  786 
  787     # Otherwise, we would get all of the commas aligned, which doesn't work as
  788     # well:
  789     #  my @a = map chr,      0 .. 255;
  790     #  my @b = grep /\W/,    @a;
  791     #  my @c = grep /[^\w]/, @a;
  792 
  793     if (   ( $j == $jmax )
  794         && ( $current_field eq '' )
  795         && ( $case != 1 || $hid_equals )
  796         && ( $maximum_field_index > $jmax ) )
  797     {
  798         my $k = $maximum_field_index;
  799         $current_field   .= $old_rfields->[$k];
  800         $current_pattern .= $old_rpatterns->[$k];
  801         $new_fields[$j]            = $current_field;
  802         $new_matching_patterns[$j] = $current_pattern;
  803 
  804         $new_alignments[$j] = $old_line->get_alignment($k);
  805         $maximum_field_index = $j;
  806 
  807         $old_line->set_alignments(@new_alignments);
  808         $old_line->set_jmax($jmax);
  809         $old_line->set_rtokens( \@new_matching_tokens );
  810         $old_line->set_rfields( \@new_fields );
  811         $old_line->set_rpatterns( \@{$rpatterns} );
  812     }
  813 
  814     # Dumb Down starting match if necessary:
  815     #
  816     # Consider the following two lines:
  817     #
  818     #  {
  819     #   $a => 20 > 3 ? 1 : 0,
  820     #   $xyz => 5,
  821     #  }
  822 
  823     # We would like to get alignment regardless of the order of the two lines.
  824     # If the lines come in in this order, then we will simplify the patterns of
  825     # the first line in sub eliminate_new_fields.  If the lines come in reverse
  826     # order, then we achieve this with eliminate_new_fields.
  827 
  828     # This update is currently restricted to leading '=>' matches. Although we
  829     # could do this for both '=' and '=>', overall the results for '=' come out
  830     # better without this step because this step can eliminate some other good
  831     # matches.  For example, with the '=' we get:
  832 
  833 #  my @disilva = ( "di Silva", "diSilva", "di Si\x{301}lva", "diSi\x{301}lva" );
  834 #  my @dsf     = map "$_\x{FFFE}Fred", @disilva;
  835 #  my @dsj     = map "$_\x{FFFE}John", @disilva;
  836 #  my @dsJ     = map "$_ John", @disilva;
  837 
  838     # without including '=' we get:
  839 
  840 #  my @disilva = ( "di Silva", "diSilva", "di Si\x{301}lva", "diSi\x{301}lva" );
  841 #  my @dsf = map "$_\x{FFFE}Fred", @disilva;
  842 #  my @dsj = map "$_\x{FFFE}John", @disilva;
  843 #  my @dsJ = map "$_ John",        @disilva;
  844     elsif (
  845         $case == 2
  846 
  847         && @new_matching_tokens == 1
  848         ##&& $new_matching_tokens[0] =~ /^=/   # see note above
  849         && $new_matching_tokens[0] =~ /^=>/
  850         && $maximum_field_index > 2
  851       )
  852     {
  853         my $jmaxm             = $jmax - 1;
  854         my $kmaxm             = $maximum_field_index - 1;
  855         my $have_side_comment = $old_rtokens->[$kmaxm] eq '#';
  856 
  857         # We need to reduce the group pattern to be just two tokens,
  858         # the leading equality or => and the final side comment
  859 
  860         my $mid_field = join "",
  861           @{$old_rfields}[ 1 .. $maximum_field_index - 1 ];
  862         my $mid_patterns = join "",
  863           @{$old_rpatterns}[ 1 .. $maximum_field_index - 1 ];
  864         my @new_alignments = (
  865             $old_line->get_alignment(0),
  866             $old_line->get_alignment( $maximum_field_index - 1 )
  867         );
  868         my @new_tokens =
  869           ( $old_rtokens->[0], $old_rtokens->[ $maximum_field_index - 1 ] );
  870         my @new_fields = (
  871             $old_rfields->[0], $mid_field, $old_rfields->[$maximum_field_index]
  872         );
  873         my @new_patterns = (
  874             $old_rpatterns->[0], $mid_patterns,
  875             $old_rpatterns->[$maximum_field_index]
  876         );
  877 
  878         $maximum_field_index = 2;
  879         $old_line->set_jmax($maximum_field_index);
  880         $old_line->set_rtokens( \@new_tokens );
  881         $old_line->set_rfields( \@new_fields );
  882         $old_line->set_rpatterns( \@new_patterns );
  883 
  884         initialize_for_new_group();
  885         add_to_group($old_line);
  886     }
  887     return;
  888 }
  889 
  890 # create an empty side comment if none exists
  891 sub make_side_comment {
  892     my ( $new_line, $level_end ) = @_;
  893     my $jmax    = $new_line->get_jmax();
  894     my $rtokens = $new_line->get_rtokens();
  895 
  896     # if line does not have a side comment...
  897     if ( ( $jmax == 0 ) || ( $rtokens->[ $jmax - 1 ] ne '#' ) ) {
  898         my $rfields   = $new_line->get_rfields();
  899         my $rpatterns = $new_line->get_rpatterns();
  900         $rtokens->[$jmax]     = '#';
  901         $rfields->[ ++$jmax ] = '';
  902         $rpatterns->[$jmax]   = '#';
  903         $new_line->set_jmax($jmax);
  904         $new_line->set_jmax_original_line($jmax);
  905     }
  906 
  907     # line has a side comment..
  908     else {
  909 
  910         # don't remember old side comment location for very long
  911         my $line_number = $vertical_aligner_self->get_output_line_number();
  912         my $rfields     = $new_line->get_rfields();
  913         if (
  914             $line_number - $last_side_comment_line_number > 12
  915 
  916             # and don't remember comment location across block level changes
  917             || (   $level_end < $last_side_comment_level
  918                 && $rfields->[0] =~ /^}/ )
  919           )
  920         {
  921             forget_side_comment();
  922         }
  923         $last_side_comment_line_number = $line_number;
  924         $last_side_comment_level       = $level_end;
  925     }
  926     return;
  927 }
  928 
  929 sub decide_if_list {
  930 
  931     my $line = shift;
  932 
  933     # A list will be taken to be a line with a forced break in which all
  934     # of the field separators are commas or comma-arrows (except for the
  935     # trailing #)
  936 
  937     # List separator tokens are things like ',3'   or '=>2',
  938     # where the trailing digit is the nesting depth.  Allow braces
  939     # to allow nested list items.
  940     my $rtokens    = $line->get_rtokens();
  941     my $test_token = $rtokens->[0];
  942     if ( $test_token =~ /^(\,|=>)/ ) {
  943         my $list_type = $test_token;
  944         my $jmax      = $line->get_jmax();
  945 
  946         foreach ( 1 .. $jmax - 2 ) {
  947             if ( $rtokens->[$_] !~ /^(\,|=>|\{)/ ) {
  948                 $list_type = "";
  949                 last;
  950             }
  951         }
  952         $line->set_list_type($list_type);
  953     }
  954     return;
  955 }
  956 
  957 sub eliminate_new_fields {
  958 
  959     my ( $new_line, $old_line ) = @_;
  960     return unless (@group_lines);
  961     my $jmax = $new_line->get_jmax();
  962 
  963     my $old_rtokens = $old_line->get_rtokens();
  964     my $rtokens     = $new_line->get_rtokens();
  965     my $is_assignment =
  966       ( $rtokens->[0] =~ /^=>?\d*$/ && ( $old_rtokens->[0] eq $rtokens->[0] ) );
  967 
  968     # must be monotonic variation
  969     return unless ( $is_assignment || $previous_maximum_jmax_seen <= $jmax );
  970 
  971     # must be more fields in the new line
  972     my $maximum_field_index = $old_line->get_jmax();
  973     return unless ( $maximum_field_index < $jmax );
  974 
  975     unless ($is_assignment) {
  976         return
  977           unless ( $old_line->get_jmax_original_line() == $minimum_jmax_seen )
  978           ;    # only if monotonic
  979 
  980         # never combine fields of a comma list
  981         return
  982           unless ( $maximum_field_index > 1 )
  983           && ( $new_line->get_list_type() !~ /^,/ );
  984     }
  985 
  986     my $rfields       = $new_line->get_rfields();
  987     my $rpatterns     = $new_line->get_rpatterns();
  988     my $old_rpatterns = $old_line->get_rpatterns();
  989 
  990     # loop over all OLD tokens except comment and check match
  991     my $match = 1;
  992     foreach my $k ( 0 .. $maximum_field_index - 2 ) {
  993         if (   ( $old_rtokens->[$k] ne $rtokens->[$k] )
  994             || ( $old_rpatterns->[$k] ne $rpatterns->[$k] ) )
  995         {
  996             $match = 0;
  997             last;
  998         }
  999     }
 1000 
 1001     # first tokens agree, so combine extra new tokens
 1002     if ($match) {
 1003         foreach my $k ( $maximum_field_index .. $jmax - 1 ) {
 1004 
 1005             $rfields->[ $maximum_field_index - 1 ] .= $rfields->[$k];
 1006             $rfields->[$k] = "";
 1007             $rpatterns->[ $maximum_field_index - 1 ] .= $rpatterns->[$k];
 1008             $rpatterns->[$k] = "";
 1009         }
 1010 
 1011         $rtokens->[ $maximum_field_index - 1 ] = '#';
 1012         $rfields->[$maximum_field_index]       = $rfields->[$jmax];
 1013         $rpatterns->[$maximum_field_index]     = $rpatterns->[$jmax];
 1014         $jmax                                  = $maximum_field_index;
 1015     }
 1016     $new_line->set_jmax($jmax);
 1017     return;
 1018 }
 1019 
 1020 sub fix_terminal_ternary {
 1021 
 1022     # Add empty fields as necessary to align a ternary term
 1023     # like this:
 1024     #
 1025     #  my $leapyear =
 1026     #      $year % 4   ? 0
 1027     #    : $year % 100 ? 1
 1028     #    : $year % 400 ? 0
 1029     #    :               1;
 1030     #
 1031     # returns 1 if the terminal item should be indented
 1032 
 1033     my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
 1034     return unless ($old_line);
 1035 
 1036 ## FUTURE CODING
 1037 ##     my ( $old_line, $end_line ) = @_;
 1038 ##     return unless ( $old_line && $end_line );
 1039 ##
 1040 ##     my $rfields   = $end_line->get_rfields();
 1041 ##     my $rpatterns = $end_line->get_rpatterns();
 1042 ##     my $rtokens   = $end_line->get_rtokens();
 1043 
 1044     my $jmax        = @{$rfields} - 1;
 1045     my $rfields_old = $old_line->get_rfields();
 1046 
 1047     my $rpatterns_old       = $old_line->get_rpatterns();
 1048     my $rtokens_old         = $old_line->get_rtokens();
 1049     my $maximum_field_index = $old_line->get_jmax();
 1050 
 1051     # look for the question mark after the :
 1052     my ($jquestion);
 1053     my $depth_question;
 1054     my $pad = "";
 1055     foreach my $j ( 0 .. $maximum_field_index - 1 ) {
 1056         my $tok = $rtokens_old->[$j];
 1057         if ( $tok =~ /^\?(\d+)$/ ) {
 1058             $depth_question = $1;
 1059 
 1060             # depth must be correct
 1061             next unless ( $depth_question eq $group_level );
 1062 
 1063             $jquestion = $j;
 1064             if ( $rfields_old->[ $j + 1 ] =~ /^(\?\s*)/ ) {
 1065                 $pad = " " x length($1);
 1066             }
 1067             else {
 1068                 return;    # shouldn't happen
 1069             }
 1070             last;
 1071         }
 1072     }
 1073     return unless ( defined($jquestion) );    # shouldn't happen
 1074 
 1075     # Now splice the tokens and patterns of the previous line
 1076     # into the else line to insure a match.  Add empty fields
 1077     # as necessary.
 1078     my $jadd = $jquestion;
 1079 
 1080     # Work on copies of the actual arrays in case we have
 1081     # to return due to an error
 1082     my @fields   = @{$rfields};
 1083     my @patterns = @{$rpatterns};
 1084     my @tokens   = @{$rtokens};
 1085 
 1086     VALIGN_DEBUG_FLAG_TERNARY && do {
 1087         local $" = '><';
 1088         print STDOUT "CURRENT FIELDS=<@{$rfields_old}>\n";
 1089         print STDOUT "CURRENT TOKENS=<@{$rtokens_old}>\n";
 1090         print STDOUT "CURRENT PATTERNS=<@{$rpatterns_old}>\n";
 1091         print STDOUT "UNMODIFIED FIELDS=<@{$rfields}>\n";
 1092         print STDOUT "UNMODIFIED TOKENS=<@{$rtokens}>\n";
 1093         print STDOUT "UNMODIFIED PATTERNS=<@{$rpatterns}>\n";
 1094     };
 1095 
 1096     # handle cases of leading colon on this line
 1097     if ( $fields[0] =~ /^(:\s*)(.*)$/ ) {
 1098 
 1099         my ( $colon, $therest ) = ( $1, $2 );
 1100 
 1101         # Handle sub-case of first field with leading colon plus additional code
 1102         # This is the usual situation as at the '1' below:
 1103         #  ...
 1104         #  : $year % 400 ? 0
 1105         #  :               1;
 1106         if ($therest) {
 1107 
 1108             # Split the first field after the leading colon and insert padding.
 1109             # Note that this padding will remain even if the terminal value goes
 1110             # out on a separate line.  This does not seem to look to bad, so no
 1111             # mechanism has been included to undo it.
 1112             my $field1 = shift @fields;
 1113             unshift @fields, ( $colon, $pad . $therest );
 1114 
 1115             # change the leading pattern from : to ?
 1116             return unless ( $patterns[0] =~ s/^\:/?/ );
 1117 
 1118             # install leading tokens and patterns of existing line
 1119             unshift( @tokens,   @{$rtokens_old}[ 0 .. $jquestion ] );
 1120             unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
 1121 
 1122             # insert appropriate number of empty fields
 1123             splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
 1124         }
 1125 
 1126         # handle sub-case of first field just equal to leading colon.
 1127         # This can happen for example in the example below where
 1128         # the leading '(' would create a new alignment token
 1129         # : ( $name =~ /[]}]$/ ) ? ( $mname = $name )
 1130         # :                        ( $mname = $name . '->' );
 1131         else {
 1132 
 1133             return unless ( $jmax > 0 && $tokens[0] ne '#' ); # shouldn't happen
 1134 
 1135             # prepend a leading ? onto the second pattern
 1136             $patterns[1] = "?b" . $patterns[1];
 1137 
 1138             # pad the second field
 1139             $fields[1] = $pad . $fields[1];
 1140 
 1141             # install leading tokens and patterns of existing line, replacing
 1142             # leading token and inserting appropriate number of empty fields
 1143             splice( @tokens,   0, 1, @{$rtokens_old}[ 0 .. $jquestion ] );
 1144             splice( @patterns, 1, 0, @{$rpatterns_old}[ 1 .. $jquestion ] );
 1145             splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
 1146         }
 1147     }
 1148 
 1149     # Handle case of no leading colon on this line.  This will
 1150     # be the case when -wba=':' is used.  For example,
 1151     #  $year % 400 ? 0 :
 1152     #                1;
 1153     else {
 1154 
 1155         # install leading tokens and patterns of existing line
 1156         $patterns[0] = '?' . 'b' . $patterns[0];
 1157         unshift( @tokens,   @{$rtokens_old}[ 0 .. $jquestion ] );
 1158         unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
 1159 
 1160         # insert appropriate number of empty fields
 1161         $jadd = $jquestion + 1;
 1162         $fields[0] = $pad . $fields[0];
 1163         splice( @fields, 0, 0, ('') x $jadd ) if $jadd;
 1164     }
 1165 
 1166     VALIGN_DEBUG_FLAG_TERNARY && do {
 1167         local $" = '><';
 1168         print STDOUT "MODIFIED TOKENS=<@tokens>\n";
 1169         print STDOUT "MODIFIED PATTERNS=<@patterns>\n";
 1170         print STDOUT "MODIFIED FIELDS=<@fields>\n";
 1171     };
 1172 
 1173     # all ok .. update the arrays
 1174     @{$rfields}   = @fields;
 1175     @{$rtokens}   = @tokens;
 1176     @{$rpatterns} = @patterns;
 1177 ## FUTURE CODING
 1178 ##     $end_line->set_rfields( \@fields );
 1179 ##     $end_line->set_rtokens( \@tokens );
 1180 ##     $end_line->set_rpatterns( \@patterns );
 1181 
 1182     # force a flush after this line
 1183     return $jquestion;
 1184 }
 1185 
 1186 sub fix_terminal_else {
 1187 
 1188     # Add empty fields as necessary to align a balanced terminal
 1189     # else block to a previous if/elsif/unless block,
 1190     # like this:
 1191     #
 1192     #  if   ( 1 || $x ) { print "ok 13\n"; }
 1193     #  else             { print "not ok 13\n"; }
 1194     #
 1195     # returns a positive value if the else block should be indented
 1196     #
 1197     my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
 1198     return unless ($old_line);
 1199     my $jmax = @{$rfields} - 1;
 1200     return unless ( $jmax > 0 );
 1201 
 1202     # check for balanced else block following if/elsif/unless
 1203     my $rfields_old = $old_line->get_rfields();
 1204 
 1205     # TBD: add handling for 'case'
 1206     return unless ( $rfields_old->[0] =~ /^(if|elsif|unless)\s*$/ );
 1207 
 1208     # look for the opening brace after the else, and extract the depth
 1209     my $tok_brace = $rtokens->[0];
 1210     my $depth_brace;
 1211     if ( $tok_brace =~ /^\{(\d+)/ ) { $depth_brace = $1; }
 1212 
 1213     # probably:  "else # side_comment"
 1214     else { return }
 1215 
 1216     my $rpatterns_old       = $old_line->get_rpatterns();
 1217     my $rtokens_old         = $old_line->get_rtokens();
 1218     my $maximum_field_index = $old_line->get_jmax();
 1219 
 1220     # be sure the previous if/elsif is followed by an opening paren
 1221     my $jparen    = 0;
 1222     my $tok_paren = '(' . $depth_brace;
 1223     my $tok_test  = $rtokens_old->[$jparen];
 1224     return unless ( $tok_test eq $tok_paren );    # shouldn't happen
 1225 
 1226     # Now find the opening block brace
 1227     my ($jbrace);
 1228     foreach my $j ( 1 .. $maximum_field_index - 1 ) {
 1229         my $tok = $rtokens_old->[$j];
 1230         if ( $tok eq $tok_brace ) {
 1231             $jbrace = $j;
 1232             last;
 1233         }
 1234     }
 1235     return unless ( defined($jbrace) );           # shouldn't happen
 1236 
 1237     # Now splice the tokens and patterns of the previous line
 1238     # into the else line to insure a match.  Add empty fields
 1239     # as necessary.
 1240     my $jadd = $jbrace - $jparen;
 1241     splice( @{$rtokens},   0, 0, @{$rtokens_old}[ $jparen .. $jbrace - 1 ] );
 1242     splice( @{$rpatterns}, 1, 0, @{$rpatterns_old}[ $jparen + 1 .. $jbrace ] );
 1243     splice( @{$rfields}, 1, 0, ('') x $jadd );
 1244 
 1245     # force a flush after this line if it does not follow a case
 1246     if   ( $rfields_old->[0] =~ /^case\s*$/ ) { return }
 1247     else                                      { return $jbrace }
 1248 }
 1249 
 1250 {    # sub check_match
 1251     my %is_good_alignment;
 1252 
 1253     BEGIN {
 1254 
 1255         # Vertically aligning on certain "good" tokens is usually okay
 1256         # so we can be less restrictive in marginal cases.
 1257         my @q = qw( { ? => = );
 1258         push @q, (',');
 1259         @is_good_alignment{@q} = (1) x scalar(@q);
 1260     }
 1261 
 1262     sub check_match {
 1263 
 1264         # See if the current line matches the current vertical alignment group.
 1265         # If not, flush the current group.
 1266         my ( $new_line, $old_line ) = @_;
 1267 
 1268         # uses global variables:
 1269         #  $previous_minimum_jmax_seen
 1270         #  $maximum_jmax_seen
 1271         #  $marginal_match
 1272         my $jmax                = $new_line->get_jmax();
 1273         my $maximum_field_index = $old_line->get_jmax();
 1274 
 1275         # flush if this line has too many fields
 1276         # variable $GoToLoc indicates goto branch point, for debugging
 1277         my $GoToLoc = 1;
 1278         if ( $jmax > $maximum_field_index ) { goto NO_MATCH }
 1279 
 1280         # flush if adding this line would make a non-monotonic field count
 1281         if (
 1282             ( $maximum_field_index > $jmax )    # this has too few fields
 1283             && (
 1284                 ( $previous_minimum_jmax_seen <
 1285                     $jmax )                     # and wouldn't be monotonic
 1286                 || ( $old_line->get_jmax_original_line() != $maximum_jmax_seen )
 1287             )
 1288           )
 1289         {
 1290             $GoToLoc = 2;
 1291             goto NO_MATCH;
 1292         }
 1293 
 1294         # otherwise see if this line matches the current group
 1295         my $jmax_original_line      = $new_line->get_jmax_original_line();
 1296         my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
 1297         my $rtokens                 = $new_line->get_rtokens();
 1298         my $rfields                 = $new_line->get_rfields();
 1299         my $rpatterns               = $new_line->get_rpatterns();
 1300         my $list_type               = $new_line->get_list_type();
 1301 
 1302         my $group_list_type = $old_line->get_list_type();
 1303         my $old_rpatterns   = $old_line->get_rpatterns();
 1304         my $old_rtokens     = $old_line->get_rtokens();
 1305 
 1306         my $jlimit = $jmax - 1;
 1307         if ( $maximum_field_index > $jmax ) {
 1308             $jlimit = $jmax_original_line;
 1309             --$jlimit unless ( length( $new_line->get_rfields()->[$jmax] ) );
 1310         }
 1311 
 1312         # handle comma-separated lists ..
 1313         if ( $group_list_type && ( $list_type eq $group_list_type ) ) {
 1314             for my $j ( 0 .. $jlimit ) {
 1315                 my $old_tok = $old_rtokens->[$j];
 1316                 next unless $old_tok;
 1317                 my $new_tok = $rtokens->[$j];
 1318                 next unless $new_tok;
 1319 
 1320                 # lists always match ...
 1321                 # unless they would align any '=>'s with ','s
 1322                 $GoToLoc = 3;
 1323                 goto NO_MATCH
 1324                   if ( $old_tok =~ /^=>/ && $new_tok =~ /^,/
 1325                     || $new_tok =~ /^=>/ && $old_tok =~ /^,/ );
 1326             }
 1327         }
 1328 
 1329         # do detailed check for everything else except hanging side comments
 1330         elsif ( !$is_hanging_side_comment ) {
 1331 
 1332             my $leading_space_count = $new_line->get_leading_space_count();
 1333 
 1334             my $max_pad = 0;
 1335             my $min_pad = 0;
 1336             my $saw_good_alignment;
 1337 
 1338             for my $j ( 0 .. $jlimit ) {
 1339 
 1340                 my $old_tok = $old_rtokens->[$j];
 1341                 my $new_tok = $rtokens->[$j];
 1342 
 1343                 # Note on encoding used for alignment tokens:
 1344                 # -------------------------------------------
 1345                 # Tokens are "decorated" with information which can help
 1346                 # prevent unwanted alignments.  Consider for example the
 1347                 # following two lines:
 1348                 #   local ( $xn, $xd ) = split( '/', &'rnorm(@_) );
 1349                 #   local ( $i, $f ) = &'bdiv( $xn, $xd );
 1350                 # There are three alignment tokens in each line, a comma,
 1351                 # an =, and a comma.  In the first line these three tokens
 1352                 # are encoded as:
 1353                 #    ,4+local-18     =3      ,4+split-7
 1354                 # and in the second line they are encoded as
 1355                 #    ,4+local-18     =3      ,4+&'bdiv-8
 1356                 # Tokens always at least have token name and nesting
 1357                 # depth.  So in this example the ='s are at depth 3 and
 1358                 # the ,'s are at depth 4.  This prevents aligning tokens
 1359                 # of different depths.  Commas contain additional
 1360                 # information, as follows:
 1361                 # ,  {depth} + {container name} - {spaces to opening paren}
 1362                 # This allows us to reject matching the rightmost commas
 1363                 # in the above two lines, since they are for different
 1364                 # function calls.  This encoding is done in
 1365                 # 'sub send_lines_to_vertical_aligner'.
 1366 
 1367                 # Pick off actual token.
 1368                 # Everything up to the first digit is the actual token.
 1369                 my $alignment_token = $new_tok;
 1370                 if ( $alignment_token =~ /^([^\d]+)/ ) { $alignment_token = $1 }
 1371 
 1372                 # see if the decorated tokens match
 1373                 my $tokens_match = $new_tok eq $old_tok
 1374 
 1375                   # Exception for matching terminal : of ternary statement..
 1376                   # consider containers prefixed by ? and : a match
 1377                   || ( $new_tok =~ /^,\d*\+\:/ && $old_tok =~ /^,\d*\+\?/ );
 1378 
 1379                 # No match if the alignment tokens differ...
 1380                 if ( !$tokens_match ) {
 1381 
 1382                     # ...Unless this is a side comment
 1383                     if (
 1384                         $j == $jlimit
 1385 
 1386                         # and there is either at least one alignment token
 1387                         # or this is a single item following a list.  This
 1388                         # latter rule is required for 'December' to join
 1389                         # the following list:
 1390                         # my (@months) = (
 1391                         #     '',       'January',   'February', 'March',
 1392                         #     'April',  'May',       'June',     'July',
 1393                         #     'August', 'September', 'October',  'November',
 1394                         #     'December'
 1395                         # );
 1396                         # If it doesn't then the -lp formatting will fail.
 1397                         && ( $j > 0 || $old_tok =~ /^,/ )
 1398                       )
 1399                     {
 1400                         $marginal_match = 1
 1401                           if ( $marginal_match == 0
 1402                             && @group_lines == 1 );
 1403                         last;
 1404                     }
 1405 
 1406                     $GoToLoc = 4;
 1407                     goto NO_MATCH;
 1408                 }
 1409 
 1410                 # Calculate amount of padding required to fit this in.
 1411                 # $pad is the number of spaces by which we must increase
 1412                 # the current field to squeeze in this field.
 1413                 my $pad =
 1414                   length( $rfields->[$j] ) - $old_line->current_field_width($j);
 1415                 if ( $j == 0 ) { $pad += $leading_space_count; }
 1416 
 1417                 # remember max pads to limit marginal cases
 1418                 if ( $alignment_token ne '#' ) {
 1419                     if ( $pad > $max_pad ) { $max_pad = $pad }
 1420                     if ( $pad < $min_pad ) { $min_pad = $pad }
 1421                 }
 1422                 if ( $is_good_alignment{$alignment_token} ) {
 1423                     $saw_good_alignment = 1;
 1424                 }
 1425 
 1426                 # If patterns don't match, we have to be careful...
 1427                 if ( $old_rpatterns->[$j] ne $rpatterns->[$j] ) {
 1428 
 1429                     # flag this as a marginal match since patterns differ
 1430                     $marginal_match = 1
 1431                       if ( $marginal_match == 0 && @group_lines == 1 );
 1432 
 1433                     # We have to be very careful about aligning commas
 1434                     # when the pattern's don't match, because it can be
 1435                     # worse to create an alignment where none is needed
 1436                     # than to omit one.  Here's an example where the ','s
 1437                     # are not in named containers.  The first line below
 1438                     # should not match the next two:
 1439                     #   ( $a, $b ) = ( $b, $r );
 1440                     #   ( $x1, $x2 ) = ( $x2 - $q * $x1, $x1 );
 1441                     #   ( $y1, $y2 ) = ( $y2 - $q * $y1, $y1 );
 1442                     if ( $alignment_token eq ',' ) {
 1443 
 1444                        # do not align commas unless they are in named containers
 1445                         $GoToLoc = 5;
 1446                         goto NO_MATCH unless ( $new_tok =~ /[A-Za-z]/ );
 1447                     }
 1448 
 1449                     # do not align parens unless patterns match;
 1450                     # large ugly spaces can occur in math expressions.
 1451                     elsif ( $alignment_token eq '(' ) {
 1452 
 1453                         # But we can allow a match if the parens don't
 1454                         # require any padding.
 1455                         $GoToLoc = 6;
 1456                         if ( $pad != 0 ) { goto NO_MATCH }
 1457                     }
 1458 
 1459                     # Handle an '=' alignment with different patterns to
 1460                     # the left.
 1461                     elsif ( $alignment_token eq '=' ) {
 1462 
 1463                         # It is best to be a little restrictive when
 1464                         # aligning '=' tokens.  Here is an example of
 1465                         # two lines that we will not align:
 1466                         #       my $variable=6;
 1467                         #       $bb=4;
 1468                         # The problem is that one is a 'my' declaration,
 1469                         # and the other isn't, so they're not very similar.
 1470                         # We will filter these out by comparing the first
 1471                         # letter of the pattern.  This is crude, but works
 1472                         # well enough.
 1473                         if (
 1474                             substr( $old_rpatterns->[$j], 0, 1 ) ne
 1475                             substr( $rpatterns->[$j],     0, 1 ) )
 1476                         {
 1477                             $GoToLoc = 7;
 1478                             goto NO_MATCH;
 1479                         }
 1480 
 1481                         # If we pass that test, we'll call it a marginal match.
 1482                         # Here is an example of a marginal match:
 1483                         #       $done{$$op} = 1;
 1484                         #       $op         = compile_bblock($op);
 1485                         # The left tokens are both identifiers, but
 1486                         # one accesses a hash and the other doesn't.
 1487                         # We'll let this be a tentative match and undo
 1488                         # it later if we don't find more than 2 lines
 1489                         # in the group.
 1490                         elsif ( @group_lines == 1 ) {
 1491                             $marginal_match =
 1492                               2;    # =2 prevents being undone below
 1493                         }
 1494                     }
 1495                 }
 1496 
 1497                 # Don't let line with fewer fields increase column widths
 1498                 # ( align3.t )
 1499                 if ( $maximum_field_index > $jmax ) {
 1500 
 1501                     # Exception: suspend this rule to allow last lines to join
 1502                     $GoToLoc = 8;
 1503                     if ( $pad > 0 ) { goto NO_MATCH; }
 1504                 }
 1505             } ## end for my $j ( 0 .. $jlimit)
 1506 
 1507             # Turn off the "marginal match" flag in some cases...
 1508             # A "marginal match" occurs when the alignment tokens agree
 1509             # but there are differences in the other tokens (patterns).
 1510             # If we leave the marginal match flag set, then the rule is that we
 1511             # will align only if there are more than two lines in the group.
 1512             # We will turn of the flag if we almost have a match
 1513             # and either we have seen a good alignment token or we
 1514             # just need a small pad (2 spaces) to fit.  These rules are
 1515             # the result of experimentation.  Tokens which misaligned by just
 1516             # one or two characters are annoying.  On the other hand,
 1517             # large gaps to less important alignment tokens are also annoying.
 1518             if (   $marginal_match == 1
 1519                 && $jmax == $maximum_field_index
 1520                 && ( $saw_good_alignment || ( $max_pad < 3 && $min_pad > -3 ) )
 1521               )
 1522             {
 1523                 $marginal_match = 0;
 1524             }
 1525             ##print "marginal=$marginal_match saw=$saw_good_alignment jmax=$jmax max=$maximum_field_index maxpad=$max_pad minpad=$min_pad\n";
 1526         }
 1527 
 1528         # We have a match (even if marginal).
 1529         # If the current line has fewer fields than the current group
 1530         # but otherwise matches, copy the remaining group fields to
 1531         # make it a perfect match.
 1532         if ( $maximum_field_index > $jmax ) {
 1533 
 1534             ##########################################################
 1535             # FIXME: The previous version had a bug which made side comments
 1536             # become regular fields, so for now the program does not allow a
 1537             # line with side comment to match.  This should eventually be done.
 1538             # The best test file for experimenting is 'lista.t'
 1539             ##########################################################
 1540 
 1541             my $comment = $rfields->[$jmax];
 1542             $GoToLoc = 9;
 1543             goto NO_MATCH if ($comment);
 1544 
 1545             # Corrected loop
 1546             for my $jj ( $jlimit .. $maximum_field_index ) {
 1547                 $rtokens->[$jj]         = $old_rtokens->[$jj];
 1548                 $rfields->[ $jj + 1 ]   = '';
 1549                 $rpatterns->[ $jj + 1 ] = $old_rpatterns->[ $jj + 1 ];
 1550             }
 1551 
 1552 ##          THESE DO NOT GIVE CORRECT RESULTS
 1553 ##          $rfields->[$jmax] = $comment;
 1554 ##          $new_line->set_jmax($jmax);
 1555 
 1556         }
 1557         return;
 1558 
 1559       NO_MATCH:
 1560 
 1561         # variable $GoToLoc is for debugging
 1562         #print "no match from $GoToLoc\n";
 1563 
 1564         # Make one last effort to retain a match of certain statements
 1565         my $match = salvage_equality_matches( $new_line, $old_line );
 1566         my_flush_code() unless ($match);
 1567         return;
 1568     }
 1569 }
 1570 
 1571 sub salvage_equality_matches {
 1572     my ( $new_line, $old_line ) = @_;
 1573 
 1574     # Reduce the complexity of the two lines if it will allow us to retain
 1575     # alignment of some common alignments, including '=' and '=>'.  We will
 1576     # convert both lines to have just two matching tokens, the equality and the
 1577     # side comment.
 1578 
 1579     # return 0 or undef if unsuccessful
 1580     # return 1 if successful
 1581 
 1582     # Here is a very simple example of two lines where we could at least
 1583     # align the equals:
 1584     #  $x = $class->_sub( $x, $delta );
 1585     #  $xpownm1 = $class->_pow( $class->_copy($x), $nm1 );    # x(i)^(n-1)
 1586 
 1587     # We will only do this if there is one old line (and one new line)
 1588     return unless ( @group_lines == 1 );
 1589     return if ($is_matching_terminal_line);
 1590 
 1591     # We are only looking for equality type statements
 1592     my $old_rtokens = $old_line->get_rtokens();
 1593     my $rtokens     = $new_line->get_rtokens();
 1594     my $is_equals =
 1595       ( $rtokens->[0] =~ /=/ && ( $old_rtokens->[0] eq $rtokens->[0] ) );
 1596     return unless ($is_equals);
 1597 
 1598     # The leading patterns must match
 1599     my $old_rpatterns = $old_line->get_rpatterns();
 1600     my $rpatterns     = $new_line->get_rpatterns();
 1601     return if ( $old_rpatterns->[0] ne $rpatterns->[0] );
 1602 
 1603     # Both should have side comment fields (should always be true)
 1604     my $jmax_old    = $old_line->get_jmax();
 1605     my $jmax_new    = $new_line->get_jmax();
 1606     my $end_tok_old = $old_rtokens->[ $jmax_old - 1 ];
 1607     my $end_tok_new = $rtokens->[ $jmax_new - 1 ];
 1608     my $have_side_comments =
 1609          defined($end_tok_old)
 1610       && $end_tok_old eq '#'
 1611       && defined($end_tok_new)
 1612       && $end_tok_new eq '#';
 1613     if ( !$have_side_comments ) { return; }
 1614 
 1615     # Do not match if any remaining tokens in new line include '?', 'if',
 1616     # 'unless','||', '&&'. The reason is that (1) this isn't a great match, and
 1617     # (2) we will prevent possibly better matchs to follow.  Here is an
 1618     # example.  The match of the first two lines is rejected, and this allows
 1619     # the second and third lines to match.
 1620     #   my $type = shift || "o";
 1621     #   my $fname  = ( $type eq 'oo'               ? 'orte_city' : 'orte' );
 1622     #   my $suffix = ( $coord_system eq 'standard' ? ''          : '-orig' );
 1623     # This logic can cause some unwanted losses of alignments, but it can retain
 1624     # long runs of multiple-token alignments, so overall it is worthwhile.
 1625     # If we had a peek at the subsequent line we could make a much better
 1626     # decision here, but for now this is not available.
 1627     for ( my $j = 1 ; $j < $jmax_new - 1 ; $j++ ) {
 1628         my $new_tok = $rtokens->[$j];
 1629 
 1630         # git#16: do not consider fat commas as good aligmnents here
 1631         my $is_good_alignment =
 1632           ( $new_tok =~ /^(=|\?|if|unless|\|\||\&\&)/ && $new_tok !~ /^=>/ );
 1633         return if ($is_good_alignment);
 1634     }
 1635 
 1636     my $squeeze_line = sub {
 1637         my ($line_obj) = @_;
 1638 
 1639         # reduce a line down to the three fields surrounding
 1640         # the two tokens, an '=' of some sort and a '#' at the end
 1641 
 1642         my $jmax     = $line_obj->get_jmax();
 1643         my $jmax_new = 2;
 1644         return unless $jmax > $jmax_new;
 1645         my $rfields     = $line_obj->get_rfields();
 1646         my $rpatterns   = $line_obj->get_rpatterns();
 1647         my $rtokens     = $line_obj->get_rtokens();
 1648         my $rfields_new = [
 1649             $rfields->[0], join( '', @{$rfields}[ 1 .. $jmax - 1 ] ),
 1650             $rfields->[$jmax]
 1651         ];
 1652         my $rpatterns_new = [
 1653             $rpatterns->[0], join( '', @{$rpatterns}[ 1 .. $jmax - 1 ] ),
 1654             $rpatterns->[$jmax]
 1655         ];
 1656         my $rtokens_new = [ $rtokens->[0], $rtokens->[ $jmax - 1 ] ];
 1657         $line_obj->{_rfields}   = $rfields_new;
 1658         $line_obj->{_rpatterns} = $rpatterns_new;
 1659         $line_obj->{_rtokens}   = $rtokens_new;
 1660         $line_obj->set_jmax($jmax_new);
 1661     };
 1662 
 1663     # Okay, we will force a match at the equals-like token.  We will fix both
 1664     # lines to have just 2 tokens and 3 fields:
 1665     $squeeze_line->($new_line);
 1666     $squeeze_line->($old_line);
 1667 
 1668     # start over with a new group
 1669     initialize_for_new_group();
 1670     add_to_group($old_line);
 1671     return 1;
 1672 }
 1673 
 1674 sub check_fit {
 1675 
 1676     my ( $new_line, $old_line ) = @_;
 1677     return unless (@group_lines);
 1678 
 1679     my $jmax                    = $new_line->get_jmax();
 1680     my $leading_space_count     = $new_line->get_leading_space_count();
 1681     my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
 1682     my $rtokens                 = $new_line->get_rtokens();
 1683     my $rfields                 = $new_line->get_rfields();
 1684     my $rpatterns               = $new_line->get_rpatterns();
 1685 
 1686     my $group_list_type = $group_lines[0]->get_list_type();
 1687 
 1688     my $padding_so_far    = 0;
 1689     my $padding_available = $old_line->get_available_space_on_right();
 1690 
 1691     # save current columns in case this doesn't work
 1692     save_alignment_columns();
 1693 
 1694     my $maximum_field_index = $old_line->get_jmax();
 1695     for my $j ( 0 .. $jmax ) {
 1696 
 1697         my $pad = length( $rfields->[$j] ) - $old_line->current_field_width($j);
 1698 
 1699         if ( $j == 0 ) {
 1700             $pad += $leading_space_count;
 1701         }
 1702 
 1703         # remember largest gap of the group, excluding gap to side comment
 1704         if (   $pad < 0
 1705             && $group_maximum_gap < -$pad
 1706             && $j > 0
 1707             && $j < $jmax - 1 )
 1708         {
 1709             $group_maximum_gap = -$pad;
 1710         }
 1711 
 1712         next if $pad < 0;
 1713 
 1714         ## OLD NOTES:
 1715         ## This patch helps sometimes, but it doesn't check to see if
 1716         ## the line is too long even without the side comment.  It needs
 1717         ## to be reworked.
 1718         ##don't let a long token with no trailing side comment push
 1719         ##side comments out, or end a group.  (sidecmt1.t)
 1720         ##next if ($j==$jmax-1 && length($rfields->[$jmax])==0);
 1721 
 1722         # BEGIN PATCH for keith1.txt.
 1723         # If the group began matching multiple tokens but later this got
 1724         # reduced to a fewer number of matching tokens, then the fields
 1725         # of the later lines will still have to fit into their corresponding
 1726         # fields.  So a large later field will "push" the other fields to
 1727         # the right, including previous side comments, and if there is no room
 1728         # then there is no match.
 1729         # For example, look at the last line in the following snippet:
 1730 
 1731  # my $b_prod_db = ( $ENV{ORACLE_SID} =~ m/p$/ && !$testing ) ? true    : false;
 1732  # my $env       = ($b_prod_db)                               ? "prd"   : "val";
 1733  # my $plant     = ( $OPT{p} )                                ? $OPT{p} : "STL";
 1734  # my $task      = $OPT{t};
 1735  # my $fnam      = "longggggggggggggggg.$record_created.$env.$plant.idash";
 1736 
 1737         # The long term will push the '?' to the right to fit in, and in this
 1738         # case there is not enough room so it will not match the equals unless
 1739         # we do something special.
 1740 
 1741         # Usually it looks good to keep an initial alignment of '=' going, and
 1742         # we can do this if the long term can fit in the space taken up by the
 1743         # remaining fields (the ? : fields here).
 1744 
 1745         # Allowing any matching token for now, but it could be restricted
 1746         # to an '='-like token if necessary.
 1747 
 1748         if (
 1749                $pad > $padding_available
 1750             && $jmax == 2                        # matching one thing (plus #)
 1751             && $j == $jmax - 1                   # at last field
 1752             && @group_lines > 1                  # more than 1 line in group now
 1753             && $jmax < $maximum_field_index      # other lines have more fields
 1754             && length( $rfields->[$jmax] ) == 0  # no side comment
 1755 
 1756             # Uncomment to match only equals (but this does not seem necessary)
 1757             # && $rtokens->[0] =~ /^=\d/           # matching an equals
 1758           )
 1759         {
 1760             my $extra_padding = 0;
 1761             foreach my $jj ( $j + 1 .. $maximum_field_index - 1 ) {
 1762                 $extra_padding += $old_line->current_field_width($jj);
 1763             }
 1764 
 1765             next if ( $pad <= $padding_available + $extra_padding );
 1766         }
 1767 
 1768         # END PATCH for keith1.pl
 1769 
 1770         # This line will need space; lets see if we want to accept it..
 1771         if (
 1772 
 1773             # not if this won't fit
 1774             ( $pad > $padding_available )
 1775 
 1776             # previously, there were upper bounds placed on padding here
 1777             # (maximum_whitespace_columns), but they were not really helpful
 1778 
 1779           )
 1780         {
 1781 
 1782             # revert to starting state then flush; things didn't work out
 1783             restore_alignment_columns();
 1784             my_flush_code();
 1785             last;
 1786         }
 1787 
 1788         # patch to avoid excessive gaps in previous lines,
 1789         # due to a line of fewer fields.
 1790         #   return join( ".",
 1791         #       $self->{"dfi"},  $self->{"aa"}, $self->rsvd,     $self->{"rd"},
 1792         #       $self->{"area"}, $self->{"id"}, $self->{"sel"} );
 1793         next if ( $jmax < $maximum_field_index && $j == $jmax - 1 );
 1794 
 1795         # looks ok, squeeze this field in
 1796         $old_line->increase_field_width( $j, $pad );
 1797         $padding_available -= $pad;
 1798 
 1799         # remember largest gap of the group, excluding gap to side comment
 1800         if ( $pad > $group_maximum_gap && $j > 0 && $j < $jmax - 1 ) {
 1801             $group_maximum_gap = $pad;
 1802         }
 1803     }
 1804     return;
 1805 }
 1806 
 1807 sub add_to_group {
 1808 
 1809     # The current line either starts a new alignment group or is
 1810     # accepted into the current alignment group.
 1811     my ($new_line) = @_;
 1812     push_group_line($new_line);
 1813 
 1814     # initialize field lengths if starting new group
 1815     if ( @group_lines == 1 ) {
 1816 
 1817         my $jmax    = $new_line->get_jmax();
 1818         my $rfields = $new_line->get_rfields();
 1819         my $rtokens = $new_line->get_rtokens();
 1820         my $col     = $new_line->get_leading_space_count();
 1821 
 1822         for my $j ( 0 .. $jmax ) {
 1823             $col += length( $rfields->[$j] );
 1824 
 1825             # create initial alignments for the new group
 1826             my $token = "";
 1827             if ( $j < $jmax ) { $token = $rtokens->[$j] }
 1828             my $alignment = make_alignment( $col, $token );
 1829             $new_line->set_alignment( $j, $alignment );
 1830         }
 1831 
 1832         $maximum_jmax_seen = $jmax;
 1833         $minimum_jmax_seen = $jmax;
 1834     }
 1835 
 1836     # use previous alignments otherwise
 1837     else {
 1838         my @new_alignments = $group_lines[-2]->get_alignments();
 1839         $new_line->set_alignments(@new_alignments);
 1840     }
 1841 
 1842     # remember group jmax extremes for next call to valign_input
 1843     $previous_minimum_jmax_seen = $minimum_jmax_seen;
 1844     $previous_maximum_jmax_seen = $maximum_jmax_seen;
 1845     return;
 1846 }
 1847 
 1848 sub dump_array {
 1849 
 1850     # debug routine to dump array contents
 1851     local $" = ')(';
 1852     print STDOUT "(@_)\n";
 1853     return;
 1854 }
 1855 
 1856 # flush() sends the current Perl::Tidy::VerticalAligner group down the
 1857 # pipeline to Perl::Tidy::FileWriter.
 1858 
 1859 # This is the external flush, which also empties the buffer and cache
 1860 sub flush {
 1861 
 1862     # the buffer must be emptied first, then any cached text
 1863     dump_valign_buffer();
 1864 
 1865     if (@group_lines) {
 1866         my_flush();
 1867     }
 1868     else {
 1869         if ($cached_line_type) {
 1870             $seqno_string = $cached_seqno_string;
 1871             valign_output_step_C( $cached_line_text,
 1872                 $cached_line_leading_space_count,
 1873                 $last_level_written );
 1874             $cached_line_type    = 0;
 1875             $cached_line_text    = "";
 1876             $cached_seqno_string = "";
 1877         }
 1878     }
 1879     return;
 1880 }
 1881 
 1882 sub reduce_valign_buffer_indentation {
 1883 
 1884     my ($diff) = @_;
 1885     if ( $valign_buffer_filling && $diff ) {
 1886         my $max_valign_buffer = @valign_buffer;
 1887         foreach my $i ( 0 .. $max_valign_buffer - 1 ) {
 1888             my ( $line, $leading_space_count, $level ) =
 1889               @{ $valign_buffer[$i] };
 1890             my $ws = substr( $line, 0, $diff );
 1891             if ( ( length($ws) == $diff ) && $ws =~ /^\s+$/ ) {
 1892                 $line = substr( $line, $diff );
 1893             }
 1894             if ( $leading_space_count >= $diff ) {
 1895                 $leading_space_count -= $diff;
 1896                 $level = level_change( $leading_space_count, $diff, $level );
 1897             }
 1898             $valign_buffer[$i] = [ $line, $leading_space_count, $level ];
 1899         }
 1900     }
 1901     return;
 1902 }
 1903 
 1904 sub level_change {
 1905 
 1906     # compute decrease in level when we remove $diff spaces from the
 1907     # leading spaces
 1908     my ( $leading_space_count, $diff, $level ) = @_;
 1909     if ($rOpts_indent_columns) {
 1910         my $olev =
 1911           int( ( $leading_space_count + $diff ) / $rOpts_indent_columns );
 1912         my $nlev = int( $leading_space_count / $rOpts_indent_columns );
 1913         $level -= ( $olev - $nlev );
 1914         if ( $level < 0 ) { $level = 0 }
 1915     }
 1916     return $level;
 1917 }
 1918 
 1919 sub dump_valign_buffer {
 1920     if (@valign_buffer) {
 1921         foreach (@valign_buffer) {
 1922             valign_output_step_D( @{$_} );
 1923         }
 1924         @valign_buffer = ();
 1925     }
 1926     $valign_buffer_filling = "";
 1927     return;
 1928 }
 1929 
 1930 sub my_flush_comment {
 1931 
 1932     # Output a group of COMMENT lines
 1933 
 1934     return unless (@group_lines);
 1935     my $leading_space_count = $comment_leading_space_count;
 1936     my $leading_string      = get_leading_string($leading_space_count);
 1937 
 1938     # look for excessively long lines
 1939     my $max_excess = 0;
 1940     foreach my $str (@group_lines) {
 1941         my $excess =
 1942           length($str) +
 1943           $leading_space_count -
 1944           maximum_line_length_for_level($group_level);
 1945         if ( $excess > $max_excess ) {
 1946             $max_excess = $excess;
 1947         }
 1948     }
 1949 
 1950     # zero leading space count if any lines are too long
 1951     if ( $max_excess > 0 ) {
 1952         $leading_space_count -= $max_excess;
 1953         if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
 1954         $last_outdented_line_at = $file_writer_object->get_output_line_number();
 1955         unless ($outdented_line_count) {
 1956             $first_outdented_line_at = $last_outdented_line_at;
 1957         }
 1958         my $nlines = @group_lines;
 1959         $outdented_line_count += $nlines;
 1960     }
 1961 
 1962     # write the lines
 1963     my $outdent_long_lines = 0;
 1964     foreach my $line (@group_lines) {
 1965         valign_output_step_B( $leading_space_count, $line, 0,
 1966             $outdent_long_lines, "", $group_level );
 1967     }
 1968 
 1969     initialize_for_new_group();
 1970     return;
 1971 }
 1972 
 1973 sub my_flush_code {
 1974 
 1975     # Output a group of CODE lines
 1976 
 1977     return unless (@group_lines);
 1978 
 1979     VALIGN_DEBUG_FLAG_APPEND0
 1980       && do {
 1981         my $group_list_type = $group_lines[0]->get_list_type();
 1982         my ( $a, $b, $c ) = caller();
 1983         my $nlines              = @group_lines;
 1984         my $maximum_field_index = $group_lines[0]->get_jmax();
 1985         my $rfields_old         = $group_lines[0]->get_rfields();
 1986         my $tok                 = $rfields_old->[0];
 1987         print STDOUT
 1988 "APPEND0: my_flush_code called from $a $b $c fields=$maximum_field_index list=$group_list_type lines=$nlines extra=$extra_indent_ok first tok=$tok;\n";
 1989 
 1990       };
 1991 
 1992     # some small groups are best left unaligned
 1993     my $do_not_align = decide_if_aligned_pair();
 1994 
 1995     # optimize side comment location
 1996     $do_not_align = adjust_side_comment($do_not_align);
 1997 
 1998     # recover spaces for -lp option if possible
 1999     my $extra_leading_spaces = get_extra_leading_spaces();
 2000 
 2001     # all lines of this group have the same basic leading spacing
 2002     my $group_leader_length = $group_lines[0]->get_leading_space_count();
 2003 
 2004     # add extra leading spaces if helpful
 2005     # NOTE: Use zero; this did not work well
 2006     my $min_ci_gap = 0;
 2007 
 2008     # output the lines
 2009     foreach my $line (@group_lines) {
 2010         valign_output_step_A( $line, $min_ci_gap, $do_not_align,
 2011             $group_leader_length, $extra_leading_spaces );
 2012     }
 2013 
 2014     initialize_for_new_group();
 2015     return;
 2016 }
 2017 
 2018 sub my_flush {
 2019 
 2020     # This is the vertical aligner internal flush, which leaves the cache
 2021     # intact
 2022     return unless (@group_lines);
 2023 
 2024     VALIGN_DEBUG_FLAG_APPEND0 && do {
 2025         my ( $a, $b, $c ) = caller();
 2026         my $nlines = @group_lines;
 2027         print STDOUT
 2028 "APPEND0: my_flush called from $a $b $c lines=$nlines, type=$group_type \n";
 2029     };
 2030 
 2031     # handle a group of COMMENT lines
 2032     if ( $group_type eq 'COMMENT' ) { my_flush_comment() }
 2033 
 2034     # handle a single line of CODE
 2035     elsif ( @group_lines == 1 ) { my_flush_code() }
 2036 
 2037     # handle group(s) of CODE lines
 2038     else {
 2039 
 2040         # LP FIX PART 1
 2041         # If we are trying to add extra indentation for -lp formatting,
 2042         # then we need to try to keep the group intact.  But we have
 2043         # to set the $extra_indent_ok flag to zero in case some lines
 2044         # are output separately.  We fix things up at the bottom.
 2045         # NOTE: this is a workaround but is tentative; we should really look to
 2046         # see if if extra indentation is possible.
 2047         my $rOpt_lp              = $rOpts->{'line-up-parentheses'};
 2048         my $keep_group_intact    = $rOpt_lp && $extra_indent_ok;
 2049         my $extra_indent_ok_save = $extra_indent_ok;
 2050         $extra_indent_ok = 0;
 2051 
 2052         # we will rebuild alignment line group(s);
 2053         my @new_lines = @group_lines;
 2054         initialize_for_new_group();
 2055 
 2056         # remove unmatched tokens in all lines
 2057         delete_unmatched_tokens( \@new_lines );
 2058 
 2059         foreach my $new_line (@new_lines) {
 2060 
 2061             # Start a new group if necessary
 2062             if ( !@group_lines ) {
 2063                 add_to_group($new_line);
 2064 
 2065                 next;
 2066             }
 2067 
 2068             my $j_terminal_match = $new_line->get_j_terminal_match();
 2069             my $base_line        = $group_lines[0];
 2070 
 2071             # Initialize a global flag saying if the last line of the group
 2072             # should match end of group and also terminate the group.  There
 2073             # should be no returns between here and where the flag is handled
 2074             # at the bottom.
 2075             my $col_matching_terminal = 0;
 2076             if ( defined($j_terminal_match) ) {
 2077 
 2078                 # remember the column of the terminal ? or { to match with
 2079                 $col_matching_terminal =
 2080                   $base_line->get_column($j_terminal_match);
 2081 
 2082                 # set global flag for sub decide_if_aligned_pair
 2083                 $is_matching_terminal_line = 1;
 2084             }
 2085 
 2086             # -------------------------------------------------------------
 2087             # Allow hanging side comment to join current group, if any. This
 2088             # will help keep side comments aligned, because otherwise we
 2089             # will have to start a new group, making alignment less likely.
 2090             # -------------------------------------------------------------
 2091 
 2092             if ( $new_line->get_is_hanging_side_comment() ) {
 2093                 join_hanging_comment( $new_line, $base_line );
 2094             }
 2095 
 2096             # If this line has no matching tokens, then flush out the lines
 2097             # BEFORE this line unless both it and the previous line have side
 2098             # comments.  This prevents this line from pushing side coments out
 2099             # to the right.
 2100             elsif ( $new_line->get_jmax() == 1 && !$keep_group_intact ) {
 2101 
 2102                 # There are no matching tokens, so now check side comments.
 2103                 # Programming note: accessing arrays with index -1 is
 2104                 # risky in Perl, but we have verified there is at least one
 2105                 # line in the group and that there is at least one field.
 2106                 my $prev_comment = $group_lines[-1]->get_rfields()->[-1];
 2107                 my $side_comment = $new_line->get_rfields()->[-1];
 2108                 my_flush_code() unless ( $side_comment && $prev_comment );
 2109 
 2110             }
 2111 
 2112             # -------------------------------------------------------------
 2113             # If there is just one previous line, and it has more fields
 2114             # than the new line, try to join fields together to get a match
 2115             # with the new line.  At the present time, only a single
 2116             # leading '=' is allowed to be compressed out.  This is useful
 2117             # in rare cases where a table is forced to use old breakpoints
 2118             # because of side comments,
 2119             # and the table starts out something like this:
 2120             #   my %MonthChars = ('0', 'Jan',   # side comment
 2121             #                     '1', 'Feb',
 2122             #                     '2', 'Mar',
 2123             # Eliminating the '=' field will allow the remaining fields to
 2124             # line up.  This situation does not occur if there are no side
 2125             # comments because scan_list would put a break after the
 2126             # opening '('.
 2127             # -------------------------------------------------------------
 2128 
 2129             eliminate_old_fields( $new_line, $base_line );
 2130 
 2131             # -------------------------------------------------------------
 2132             # If the new line has more fields than the current group,
 2133             # see if we can match the first fields and combine the remaining
 2134             # fields of the new line.
 2135             # -------------------------------------------------------------
 2136 
 2137             eliminate_new_fields( $new_line, $base_line );
 2138 
 2139             # -------------------------------------------------------------
 2140             # Flush previous group unless all common tokens and patterns
 2141             # match..
 2142 
 2143             check_match( $new_line, $base_line );
 2144 
 2145             # -------------------------------------------------------------
 2146             # See if there is space for this line in the current group (if
 2147             # any)
 2148             # -------------------------------------------------------------
 2149             if (@group_lines) {
 2150                 check_fit( $new_line, $base_line );
 2151             }
 2152 
 2153             add_to_group($new_line);
 2154 
 2155             if ( defined($j_terminal_match) ) {
 2156 
 2157                 # if there is only one line in the group (maybe due to failure
 2158                 # to match perfectly with previous lines), then align the ? or
 2159                 # { of this terminal line with the previous one unless that
 2160                 # would make the line too long
 2161                 if ( @group_lines == 1 ) {
 2162                     $base_line = $group_lines[0];
 2163                     my $col_now = $base_line->get_column($j_terminal_match);
 2164                     my $pad     = $col_matching_terminal - $col_now;
 2165                     my $padding_available =
 2166                       $base_line->get_available_space_on_right();
 2167                     if ( $pad > 0 && $pad <= $padding_available ) {
 2168                         $base_line->increase_field_width( $j_terminal_match,
 2169                             $pad );
 2170                     }
 2171                 }
 2172                 my_flush_code();
 2173                 $is_matching_terminal_line = 0;
 2174             }
 2175 
 2176             # Optional optimization; end the group if we know we cannot match
 2177             # next line.
 2178             elsif ( $new_line->{_end_group} ) {
 2179                 my_flush_code();
 2180             }
 2181         }
 2182 
 2183         # LP FIX PART 2
 2184         # if we managed to keep the group intact for -lp formatting,
 2185         # restore the flag which allows extra indentation
 2186         if ( $keep_group_intact && @group_lines == @new_lines ) {
 2187             $extra_indent_ok = $extra_indent_ok_save;
 2188         }
 2189         my_flush_code();
 2190     }
 2191     return;
 2192 }
 2193 
 2194 sub delete_selected_tokens {
 2195 
 2196     my ( $line_obj, $ridel ) = @_;
 2197 
 2198     # remove an unused alignment token(s) to improve alignment chances
 2199     return unless ( defined($line_obj) && defined($ridel) && @{$ridel} );
 2200 
 2201     my $jmax_old      = $line_obj->get_jmax();
 2202     my $rfields_old   = $line_obj->get_rfields();
 2203     my $rpatterns_old = $line_obj->get_rpatterns();
 2204     my $rtokens_old   = $line_obj->get_rtokens();
 2205 
 2206     local $" = '> <';
 2207     0 && print <<EOM;
 2208 delete indexes: <@{$ridel}>
 2209 old jmax: $jmax_old
 2210 old tokens: <@{$rtokens_old}>
 2211 old patterns: <@{$rpatterns_old}>
 2212 old fields: <@{$rfields_old}>
 2213 EOM
 2214 
 2215     my $rfields_new   = [];
 2216     my $rpatterns_new = [];
 2217     my $rtokens_new   = [];
 2218 
 2219     my $kmax      = @{$ridel} - 1;
 2220     my $k         = 0;
 2221     my $jdel_next = $ridel->[$k];
 2222 
 2223     # FIXME:
 2224     if ( $jdel_next < 0 ) { print STDERR "bad jdel_next=$jdel_next\n"; return }
 2225     my $pattern = $rpatterns_old->[0];
 2226     my $field   = $rfields_old->[0];
 2227     push @{$rfields_new},   $field;
 2228     push @{$rpatterns_new}, $pattern;
 2229     for ( my $j = 0 ; $j < $jmax_old ; $j++ ) {
 2230         my $token   = $rtokens_old->[$j];
 2231         my $field   = $rfields_old->[ $j + 1 ];
 2232         my $pattern = $rpatterns_old->[ $j + 1 ];
 2233         if ( $k > $kmax || $j < $jdel_next ) {
 2234             push @{$rtokens_new},   $token;
 2235             push @{$rfields_new},   $field;
 2236             push @{$rpatterns_new}, $pattern;
 2237         }
 2238         elsif ( $j == $jdel_next ) {
 2239             $rfields_new->[-1]   .= $field;
 2240             $rpatterns_new->[-1] .= $pattern;
 2241             if ( ++$k <= $kmax ) {
 2242                 my $jdel_last = $jdel_next;
 2243                 $jdel_next = $ridel->[$k];
 2244                 if ( $jdel_next < $jdel_last ) {
 2245 
 2246                     # FIXME:
 2247                     print STDERR "bad jdel_next=$jdel_next\n";
 2248                     return;
 2249                 }
 2250             }
 2251         }
 2252     }
 2253 
 2254     # ----- x ------ x ------ x ------
 2255     #t      0        1        2        <- token indexing
 2256     #f   0      1        2        3    <- field and pattern
 2257 
 2258     my $jmax_new = @{$rfields_new} - 1;
 2259     $line_obj->set_rtokens($rtokens_new);
 2260     $line_obj->set_rpatterns($rpatterns_new);
 2261     $line_obj->set_rfields($rfields_new);
 2262     $line_obj->set_jmax($jmax_new);
 2263 
 2264     0 && print <<EOM;
 2265 
 2266 new jmax: $jmax_new
 2267 new tokens: <@{$rtokens_new}>
 2268 new patterns: <@{$rpatterns_new}>
 2269 new fields: <@{$rfields_new}>
 2270 EOM
 2271     return;
 2272 }
 2273 
 2274 sub decode_alignment_token {
 2275 
 2276     # Unpack the values packed in an alignment token
 2277     #
 2278     # Usage:
 2279     #        my ( $raw_tok, $lev, $tag, $tok_count ) =
 2280     #          decode_alignment_token($token);
 2281 
 2282     # Alignment tokens have a trailing decimal level and optional tag (for
 2283     # commas):
 2284     # For example, the first comma in the following line
 2285     #     sub banner  { crlf; report( shift, '/', shift ); crlf }
 2286     # is decorated as follows:
 2287     #    ,2+report-6  => (tok,lev,tag) =qw( ,   2   +report-6)
 2288 
 2289     # An optional token count may be appended with a leading dot.
 2290     # Currently this is only done for '=' tokens but this could change.
 2291     # For example, consider the following line:
 2292     #   $nport   = $port = shift || $name;
 2293     # The first '=' may either be '=0' or '=0.1' [level 0, first equals]
 2294     # The second '=' will be '=0.2' [level 0, second equals]
 2295     my ($tok) = @_;
 2296     my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, "", 1 );
 2297     if ( $tok =~ /^(\D+)(\d+)([^\.]*)(\.(\d+))?$/ ) {
 2298         $raw_tok   = $1;
 2299         $lev       = $2;
 2300         $tag       = $3 if ($3);
 2301         $tok_count = $5 if ($5);
 2302     }
 2303     return ( $raw_tok, $lev, $tag, $tok_count );
 2304 }
 2305 
 2306 {    # sub is_deletable_token
 2307 
 2308     my %is_deletable_equals;
 2309 
 2310     BEGIN {
 2311         my @q;
 2312 
 2313         # These tokens with = may be deleted for vertical aligmnemt
 2314         @q = qw(
 2315           <= >= == =~ != <=>
 2316         );
 2317         @is_deletable_equals{@q} = (1) x scalar(@q);
 2318 
 2319     }
 2320 
 2321     sub is_deletable_token {
 2322 
 2323         # Determine if a token with no match possibility can be removed to
 2324         # improve chances of making an alignment.
 2325         my ( $token, $i, $imax, $jline, $i_eq ) = @_;
 2326 
 2327         my ( $raw_tok, $lev, $tag, $tok_count ) =
 2328           decode_alignment_token($token);
 2329 
 2330         # okay to delete second and higher copies of a token
 2331         if ( $tok_count > 1 ) { return 1 }
 2332 
 2333         # only remove lower level commas
 2334         if ( $raw_tok eq ',' ) {
 2335 
 2336             return if ( defined($i_eq) && $i < $i_eq );
 2337             return if ( $lev <= $group_level );
 2338         }
 2339 
 2340         # most operators with an equals sign should be retained if at
 2341         # same level as this statement
 2342         elsif ( $raw_tok =~ /=/ ) {
 2343             return
 2344               unless ( $lev > $group_level || $is_deletable_equals{$raw_tok} );
 2345         }
 2346 
 2347         # otherwise, ok to delete the token
 2348         return 1;
 2349     }
 2350 }
 2351 
 2352 sub delete_unmatched_tokens {
 2353     my ($rlines) = @_;
 2354 
 2355     # This is a preliminary step in vertical alignment in which we remove as
 2356     # many obviously un-needed alignment tokens as possible.  This will prevent
 2357     # them from interfering with the final alignment.
 2358 
 2359     return unless @{$rlines};
 2360     my $has_terminal_match = $rlines->[-1]->get_j_terminal_match();
 2361 
 2362     # ignore hanging side comments in these operations
 2363     my @filtered   = grep { !$_->{_is_hanging_side_comment} } @{$rlines};
 2364     my $rnew_lines = \@filtered;
 2365     my @i_equals;
 2366     my @min_levels;
 2367 
 2368     my $jmax = @{$rnew_lines} - 1;
 2369 
 2370     my %is_good_tok;
 2371 
 2372     # create a hash of tokens for each line
 2373     my $rline_hashes = [];
 2374     foreach my $line ( @{$rnew_lines} ) {
 2375         my $rhash   = {};
 2376         my $rtokens = $line->get_rtokens();
 2377         my $i       = 0;
 2378         my $i_eq;
 2379         my $lev_min;
 2380         foreach my $tok ( @{$rtokens} ) {
 2381             my ( $raw_tok, $lev, $tag, $tok_count ) =
 2382               decode_alignment_token($tok);
 2383             if ( !defined($lev_min) || $lev < $lev_min ) { $lev_min = $lev }
 2384 
 2385             # Possible future upgrade: for multiple matches,
 2386             # record [$i1, $i2, ..] instead of $i
 2387             $rhash->{$tok} =
 2388               [ $i, undef, undef, $raw_tok, $lev, $tag, $tok_count ];
 2389 
 2390             # remember the first equals at line level
 2391             if ( !defined($i_eq) && $raw_tok eq '=' ) {
 2392                 if ( $lev eq $group_level ) { $i_eq = $i }
 2393             }
 2394             $i++;
 2395         }
 2396         push @{$rline_hashes}, $rhash;
 2397         push @i_equals,   $i_eq;
 2398         push @min_levels, $lev_min;
 2399     }
 2400 
 2401     # compare each line pair and record matches
 2402     my $rtok_hash = {};
 2403     my $nr        = 0;
 2404     for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
 2405         my $nl = $nr;
 2406         $nr = 0;
 2407         my $jr      = $jl + 1;
 2408         my $rhash_l = $rline_hashes->[$jl];
 2409         my $rhash_r = $rline_hashes->[$jr];
 2410         my $count   = 0;                      # UNUSED NOW?
 2411         my $ntoks   = 0;
 2412         foreach my $tok ( keys %{$rhash_l} ) {
 2413             $ntoks++;
 2414             if ( defined( $rhash_r->{$tok} ) ) {
 2415                 if ( $tok ne '#' ) { $count++; }
 2416                 my $il = $rhash_l->{$tok}->[0];
 2417                 my $ir = $rhash_r->{$tok}->[0];
 2418                 $rhash_l->{$tok}->[2] = $ir;
 2419                 $rhash_r->{$tok}->[1] = $il;
 2420                 if ( $tok ne '#' ) {
 2421                     push @{ $rtok_hash->{$tok} }, ( $jl, $jr );
 2422                     $nr++;
 2423                 }
 2424             }
 2425         }
 2426 
 2427         # Set a line break if no matching tokens between these lines
 2428         if ( $nr == 0 && $nl > 0 ) {
 2429             $rnew_lines->[$jl]->{_end_group} = 1;
 2430         }
 2431     }
 2432 
 2433     # find subgroups
 2434     my @subgroups;
 2435     push @subgroups, [ 0, $jmax ];
 2436     for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
 2437         if ( $rnew_lines->[$jl]->{_end_group} ) {
 2438             $subgroups[-1]->[1] = $jl;
 2439             push @subgroups, [ $jl + 1, $jmax ];
 2440         }
 2441     }
 2442 
 2443     # Loop to process each subgroups
 2444     foreach my $item (@subgroups) {
 2445         my ( $jbeg, $jend ) = @{$item};
 2446 
 2447         # look for complete ternary or if/elsif/else blocks
 2448         my $nlines = $jend - $jbeg + 1;
 2449         my %token_line_count;
 2450         for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
 2451             my %seen;
 2452             my $line    = $rnew_lines->[$jj];
 2453             my $rtokens = $line->get_rtokens();
 2454             foreach my $tok ( @{$rtokens} ) {
 2455                 if ( !$seen{$tok} ) {
 2456                     $seen{$tok}++;
 2457                     $token_line_count{$tok}++;
 2458                 }
 2459             }
 2460         }
 2461 
 2462         # Look for if/else/elsif and ternary blocks
 2463         my $is_full_block;
 2464         foreach my $tok ( keys %token_line_count ) {
 2465             if ( $token_line_count{$tok} == $nlines ) {
 2466                 if ( $tok =~ /^\?/ || $tok =~ /^\{\d+if/ ) {
 2467                     $is_full_block = 1;
 2468                 }
 2469             }
 2470         }
 2471 
 2472         # remove unwanted alignment tokens
 2473         for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
 2474             my $line    = $rnew_lines->[$jj];
 2475             my $rtokens = $line->get_rtokens();
 2476             my $rhash   = $rline_hashes->[$jj];
 2477             my $i       = 0;
 2478             my $i_eq    = $i_equals[$jj];
 2479             my @idel;
 2480             my $imax = @{$rtokens} - 2;
 2481             my $delete_above_level;
 2482 
 2483             for ( my $i = 0 ; $i <= $imax ; $i++ ) {
 2484                 my $tok = $rtokens->[$i];
 2485                 next if ( $tok eq '#' );    # shouldn't happen
 2486                 my ( $iii, $il, $ir, $raw_tok, $lev, $tag, $tok_count ) =
 2487                   @{ $rhash->{$tok} };
 2488 
 2489                 # always remove unmatched tokens
 2490                 my $delete_me = !defined($il) && !defined($ir);
 2491 
 2492                 # also, if this is a complete ternary or if/elsif/else block,
 2493                 # remove all alignments which are not also in every line
 2494                 $delete_me ||=
 2495                   ( $is_full_block && $token_line_count{$tok} < $nlines );
 2496 
 2497                 # Remove all tokens above a certain level following a previous
 2498                 # deletion.  For example, we have to remove tagged higher level
 2499                 # alignment tokens following a => deletion because the tags of
 2500                 # higher level tokens will now be incorrect. For example, this
 2501                 # will prevent aligning commas as follows after deleting the
 2502                 # second =>
 2503                 #    $w->insert(
 2504                 #   ListBox => origin => [ 270, 160 ],
 2505                 #   size    => [ 200,           55 ],
 2506                 #    );
 2507                 if ( defined($delete_above_level) ) {
 2508                     if ( $lev > $delete_above_level ) {
 2509                         $delete_me ||= 1;    #$tag;
 2510                     }
 2511                     else { $delete_above_level = undef }
 2512                 }
 2513 
 2514                 if (
 2515                     $delete_me
 2516                     && is_deletable_token( $tok, $i, $imax, $jj, $i_eq )
 2517 
 2518                     # Patch: do not touch the first line of a terminal match,
 2519                     # such as below, because j_terminal has already been set.
 2520                     #    if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
 2521                     #    else      { $tago = $tagc = ''; }
 2522                     # But see snippets 'else1.t' and 'else2.t'
 2523                     && !( $jj == $jbeg && $has_terminal_match && $nlines == 2 )
 2524 
 2525                   )
 2526                 {
 2527                     push @idel, $i;
 2528                     if ( !defined($delete_above_level)
 2529                         || $lev < $delete_above_level )
 2530                     {
 2531 
 2532                         # delete all following higher level alignments
 2533                         $delete_above_level = $lev;
 2534 
 2535                         # but keep deleting after => to next lower level
 2536                         # to avoid some bizarre alignments
 2537                         if ( $raw_tok eq '=>' ) {
 2538                             $delete_above_level = $lev - 1;
 2539                         }
 2540                     }
 2541                 }
 2542             }
 2543 
 2544             if (@idel) { delete_selected_tokens( $line, \@idel ) }
 2545         }
 2546     }    # End loop over subgroups
 2547 
 2548     return;
 2549 }
 2550 
 2551 {        # decide_if_aligned_pair
 2552 
 2553     my %is_if_or;
 2554     my %is_assignment;
 2555 
 2556     BEGIN {
 2557 
 2558         my @q = qw(
 2559           if or ||
 2560         );
 2561         @is_if_or{@q} = (1) x scalar(@q);
 2562 
 2563         @q = qw(
 2564           = **= += *= &= <<= &&=
 2565           -= /= |= >>= ||= //=
 2566           .= %= ^=
 2567           x=
 2568         );
 2569         @is_assignment{@q} = (1) x scalar(@q);
 2570     }
 2571 
 2572     sub decide_if_aligned_pair {
 2573 
 2574         # Do not try to align two lines which are not really similar
 2575         return unless ( @group_lines == 2 );
 2576         return if ($is_matching_terminal_line);
 2577 
 2578         # always align lists
 2579         my $group_list_type = $group_lines[0]->get_list_type();
 2580         return 0 if ($group_list_type);
 2581 
 2582         my $jmax0          = $group_lines[0]->get_jmax();
 2583         my $jmax1          = $group_lines[1]->get_jmax();
 2584         my $rtokens        = $group_lines[0]->get_rtokens();
 2585         my $leading_equals = ( $rtokens->[0] =~ /=/ );
 2586 
 2587         # scan the tokens on the second line
 2588         my $rtokens1 = $group_lines[1]->get_rtokens();
 2589         my $saw_if_or;    # if we saw an 'if' or 'or' at group level
 2590         my $raw_tokb = "";    # first token seen at group level
 2591         for ( my $j = 0 ; $j < $jmax1 - 1 ; $j++ ) {
 2592             my ( $raw_tok, $lev, $tag, $tok_count ) =
 2593               decode_alignment_token( $rtokens1->[$j] );
 2594             if ( $raw_tok && $lev == $group_level ) {
 2595                 if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
 2596                 $saw_if_or ||= $is_if_or{$raw_tok};
 2597             }
 2598         }
 2599 
 2600         # A marginal match is a match which has different patterns. Normally,
 2601         # we should not allow exactly two lines to match if marginal. But
 2602         # we can allow matching in some specific cases.
 2603         my $is_marginal = $marginal_match;
 2604 
 2605         # lines with differing number of alignment tokens are marginal
 2606         $is_marginal ||=
 2607           $previous_maximum_jmax_seen != $previous_minimum_jmax_seen
 2608           && !$is_assignment{$raw_tokb};
 2609 
 2610         # We will use the line endings to help decide on alignments...
 2611         # See if the lines end with semicolons...
 2612         my $rpatterns0 = $group_lines[0]->get_rpatterns();
 2613         my $rpatterns1 = $group_lines[1]->get_rpatterns();
 2614         my $sc_term0;
 2615         my $sc_term1;
 2616         if ( $jmax0 < 1 || $jmax1 < 1 ) {
 2617 
 2618             # shouldn't happen
 2619         }
 2620         else {
 2621             my $pat0 = $rpatterns0->[ $jmax0 - 1 ];
 2622             my $pat1 = $rpatterns1->[ $jmax1 - 1 ];
 2623             $sc_term0 = $pat0 =~ /;b?$/;
 2624             $sc_term1 = $pat1 =~ /;b?$/;
 2625         }
 2626 
 2627         if ( !$is_marginal && !$sc_term0 ) {
 2628 
 2629             # First line of assignment should be semicolon terminated.
 2630             # For example, do not align here:
 2631             #  $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
 2632             #    $$href{-NUM_DIRS} = 0;
 2633             if ( $is_assignment{$raw_tokb} ) {
 2634                 $is_marginal = 1;
 2635             }
 2636         }
 2637 
 2638         # Try to avoid some undesirable alignments of opening tokens
 2639         # for example, the space between grep and { here:
 2640         #  return map { ( $_ => $_ ) }
 2641         #    grep     { /$handles/ } $self->_get_delegate_method_list;
 2642         $is_marginal ||=
 2643              ( $raw_tokb eq '(' || $raw_tokb eq '{' )
 2644           && $jmax1 == 2
 2645           && $sc_term0 ne $sc_term1;
 2646 
 2647         # Undo the marginal match flag in certain cases,
 2648         if ($is_marginal) {
 2649 
 2650             # Two lines with a leading equals-like operator are allowed to
 2651             # align if the patterns to the left of the equals are the same.
 2652             # For example the following two lines are a marginal match but have
 2653             # the same left side patterns, so we will align the equals.
 2654             #     my $orig = my $format = "^<<<<< ~~\n";
 2655             #     my $abc  = "abc";
 2656             # But these have a different left pattern so they will not be
 2657             # aligned
 2658             #     $xmldoc .= $`;
 2659             #     $self->{'leftovers'} .= "<bx-seq:seq" . $';
 2660 
 2661             # First line semicolon terminated but second not, usually ok:
 2662             #               my $want = "'ab', 'a', 'b'";
 2663             #               my $got  = join( ", ",
 2664             #                    map { defined($_) ? "'$_'" : "undef" }
 2665             #                          @got );
 2666             #  First line not semicolon terminated, Not OK to match:
 2667             #   $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
 2668             #      $$href{-NUM_DIRS} = 0;
 2669             my $pat0 = $rpatterns0->[0];
 2670             my $pat1 = $rpatterns1->[0];
 2671 
 2672             ##########################################################
 2673             # Turn off the marginal flag for some types of assignments
 2674             ##########################################################
 2675             if ( $is_assignment{$raw_tokb} ) {
 2676 
 2677                 # undo marginal flag if first line is semicolon terminated
 2678                 # and leading patters match
 2679                 if ($sc_term0) {    # && $sc_term1) {
 2680                     $is_marginal = $pat0 ne $pat1;
 2681                 }
 2682             }
 2683             elsif ( $raw_tokb eq '=>' ) {
 2684 
 2685                 # undo marginal flag if patterns match
 2686                 $is_marginal = $pat0 ne $pat1;
 2687             }
 2688             elsif ( $raw_tokb eq '=~' ) {
 2689 
 2690                 # undo marginal flag if both lines are semicolon terminated
 2691                 # and leading patters match
 2692                 if ( $sc_term1 && $sc_term0 ) {
 2693                     $is_marginal = $pat0 ne $pat1;
 2694                 }
 2695             }
 2696 
 2697             ######################################################
 2698             # Turn off the marginal flag if we saw an 'if' or 'or'
 2699             ######################################################
 2700 
 2701             # A trailing 'if' and 'or' often gives a good alignment
 2702             # For example, we can align these:
 2703             #  return -1     if $_[0] =~ m/^CHAPT|APPENDIX/;
 2704             #  return $1 + 0 if $_[0] =~ m/^SECT(\d*)$/;
 2705 
 2706             # or
 2707             #  $d_in_m[2] = 29          if ( &Date_LeapYear($y) );
 2708             #  $d         = $d_in_m[$m] if ( $d > $d_in_m[$m] );
 2709 
 2710             if ($saw_if_or) {
 2711 
 2712                 # undo marginal flag if both lines are semicolon terminated
 2713                 if ( $sc_term0 && $sc_term1 ) {
 2714                     $is_marginal = 0;
 2715                 }
 2716             }
 2717         }
 2718 
 2719         ###############################
 2720         # Set the return flag:
 2721         # Don't align if still marginal
 2722         ###############################
 2723         my $do_not_align = $is_marginal;
 2724 
 2725         # But try to convert them into a simple comment group if the first line
 2726         # a has side comment
 2727         my $rfields             = $group_lines[0]->get_rfields();
 2728         my $maximum_field_index = $group_lines[0]->get_jmax();
 2729         if ( $do_not_align
 2730             && ( length( $rfields->[$maximum_field_index] ) > 0 ) )
 2731         {
 2732             combine_fields();
 2733             $do_not_align = 0;
 2734         }
 2735         return $do_not_align;
 2736     }
 2737 }
 2738 
 2739 sub adjust_side_comment {
 2740 
 2741     my $do_not_align = shift;
 2742 
 2743     # let's see if we can move the side comment field out a little
 2744     # to improve readability (the last field is always a side comment field)
 2745     my $have_side_comment       = 0;
 2746     my $first_side_comment_line = -1;
 2747     my $maximum_field_index     = $group_lines[0]->get_jmax();
 2748     my $i                       = 0;
 2749     foreach my $line (@group_lines) {
 2750         if ( length( $line->get_rfields()->[$maximum_field_index] ) ) {
 2751             $have_side_comment       = 1;
 2752             $first_side_comment_line = $i;
 2753             last;
 2754         }
 2755         $i++;
 2756     }
 2757 
 2758     my $kmax = $maximum_field_index + 1;
 2759 
 2760     if ($have_side_comment) {
 2761 
 2762         my $line = $group_lines[0];
 2763 
 2764         # the maximum space without exceeding the line length:
 2765         my $avail = $line->get_available_space_on_right();
 2766 
 2767         # try to use the previous comment column
 2768         my $side_comment_column = $line->get_column( $kmax - 2 );
 2769         my $move                = $last_comment_column - $side_comment_column;
 2770 
 2771 ##        my $sc_line0 = $side_comment_history[0]->[0];
 2772 ##        my $sc_col0  = $side_comment_history[0]->[1];
 2773 ##        my $sc_line1 = $side_comment_history[1]->[0];
 2774 ##        my $sc_col1  = $side_comment_history[1]->[1];
 2775 ##        my $sc_line2 = $side_comment_history[2]->[0];
 2776 ##        my $sc_col2  = $side_comment_history[2]->[1];
 2777 ##
 2778 ##        # FUTURE UPDATES:
 2779 ##        # Be sure to ignore 'do not align' and  '} # end comments'
 2780 ##        # Find first $move > 0 and $move <= $avail as follows:
 2781 ##        # 1. try sc_col1 if sc_col1 == sc_col0 && (line-sc_line0) < 12
 2782 ##        # 2. try sc_col2 if (line-sc_line2) < 12
 2783 ##        # 3. try min possible space, plus up to 8,
 2784 ##        # 4. try min possible space
 2785 
 2786         if ( $kmax > 0 && !$do_not_align ) {
 2787 
 2788             # but if this doesn't work, give up and use the minimum space
 2789             if ( $move > $avail ) {
 2790                 $move = $rOpts_minimum_space_to_comment - 1;
 2791             }
 2792 
 2793             # but we want some minimum space to the comment
 2794             my $min_move = $rOpts_minimum_space_to_comment - 1;
 2795             if (   $move >= 0
 2796                 && $last_side_comment_length > 0
 2797                 && ( $first_side_comment_line == 0 )
 2798                 && $group_level == $last_level_written )
 2799             {
 2800                 $min_move = 0;
 2801             }
 2802 
 2803             if ( $move < $min_move ) {
 2804                 $move = $min_move;
 2805             }
 2806 
 2807             # previously, an upper bound was placed on $move here,
 2808             # (maximum_space_to_comment), but it was not helpful
 2809 
 2810             # don't exceed the available space
 2811             if ( $move > $avail ) { $move = $avail }
 2812 
 2813             # we can only increase space, never decrease
 2814             if ( $move > 0 ) {
 2815                 $line->increase_field_width( $maximum_field_index - 1, $move );
 2816             }
 2817 
 2818             # remember this column for the next group
 2819             $last_comment_column = $line->get_column( $kmax - 2 );
 2820         }
 2821         else {
 2822 
 2823             # try to at least line up the existing side comment location
 2824             if ( $kmax > 0 && $move > 0 && $move < $avail ) {
 2825                 $line->increase_field_width( $maximum_field_index - 1, $move );
 2826                 $do_not_align = 0;
 2827             }
 2828 
 2829             # reset side comment column if we can't align
 2830             else {
 2831                 forget_side_comment();
 2832             }
 2833         }
 2834     }
 2835     return $do_not_align;
 2836 }
 2837 
 2838 sub valign_output_step_A {
 2839 
 2840     ###############################################################
 2841     # This is Step A in writing vertically aligned lines.
 2842     # The line is prepared according to the alignments which have
 2843     # been found. Then it is shipped to the next step.
 2844     ###############################################################
 2845 
 2846     my ( $line, $min_ci_gap, $do_not_align, $group_leader_length,
 2847         $extra_leading_spaces )
 2848       = @_;
 2849     my $rfields                   = $line->get_rfields();
 2850     my $leading_space_count       = $line->get_leading_space_count();
 2851     my $outdent_long_lines        = $line->get_outdent_long_lines();
 2852     my $maximum_field_index       = $line->get_jmax();
 2853     my $rvertical_tightness_flags = $line->get_rvertical_tightness_flags();
 2854 
 2855     # add any extra spaces
 2856     if ( $leading_space_count > $group_leader_length ) {
 2857         $leading_space_count += $min_ci_gap;
 2858     }
 2859 
 2860     my $str = $rfields->[0];
 2861 
 2862     # loop to concatenate all fields of this line and needed padding
 2863     my $total_pad_count = 0;
 2864     for my $j ( 1 .. $maximum_field_index ) {
 2865 
 2866         # skip zero-length side comments
 2867         last
 2868           if (
 2869             ( $j == $maximum_field_index )
 2870             && ( !defined( $rfields->[$j] )
 2871                 || ( length( $rfields->[$j] ) == 0 ) )
 2872           );
 2873 
 2874         # compute spaces of padding before this field
 2875         my $col = $line->get_column( $j - 1 );
 2876         my $pad = $col - ( length($str) + $leading_space_count );
 2877 
 2878         if ($do_not_align) {
 2879             $pad =
 2880               ( $j < $maximum_field_index )
 2881               ? 0
 2882               : $rOpts_minimum_space_to_comment - 1;
 2883         }
 2884 
 2885         # if the -fpsc flag is set, move the side comment to the selected
 2886         # column if and only if it is possible, ignoring constraints on
 2887         # line length and minimum space to comment
 2888         if ( $rOpts_fixed_position_side_comment && $j == $maximum_field_index )
 2889         {
 2890             my $newpad = $pad + $rOpts_fixed_position_side_comment - $col - 1;
 2891             if ( $newpad >= 0 ) { $pad = $newpad; }
 2892         }
 2893 
 2894         # accumulate the padding
 2895         if ( $pad > 0 ) { $total_pad_count += $pad; }
 2896 
 2897         # add this field
 2898         if ( !defined $rfields->[$j] ) {
 2899             write_diagnostics("UNDEFined field at j=$j\n");
 2900         }
 2901 
 2902         # only add padding when we have a finite field;
 2903         # this avoids extra terminal spaces if we have empty fields
 2904         if ( length( $rfields->[$j] ) > 0 ) {
 2905             $str .= ' ' x $total_pad_count;
 2906             $total_pad_count = 0;
 2907             $str .= $rfields->[$j];
 2908         }
 2909         else {
 2910             $total_pad_count = 0;
 2911         }
 2912 
 2913         # update side comment history buffer
 2914         if ( $j == $maximum_field_index ) {
 2915             my $lineno = $file_writer_object->get_output_line_number();
 2916             shift @side_comment_history;
 2917             push @side_comment_history, [ $lineno, $col ];
 2918         }
 2919     }
 2920 
 2921     my $side_comment_length = ( length( $rfields->[$maximum_field_index] ) );
 2922 
 2923     # ship this line off
 2924     valign_output_step_B( $leading_space_count + $extra_leading_spaces,
 2925         $str, $side_comment_length, $outdent_long_lines,
 2926         $rvertical_tightness_flags, $group_level );
 2927     return;
 2928 }
 2929 
 2930 sub get_extra_leading_spaces {
 2931 
 2932     #----------------------------------------------------------
 2933     # Define any extra indentation space (for the -lp option).
 2934     # Here is why:
 2935     # If a list has side comments, sub scan_list must dump the
 2936     # list before it sees everything.  When this happens, it sets
 2937     # the indentation to the standard scheme, but notes how
 2938     # many spaces it would have liked to use.  We may be able
 2939     # to recover that space here in the event that all of the
 2940     # lines of a list are back together again.
 2941     #----------------------------------------------------------
 2942 
 2943     my $extra_leading_spaces = 0;
 2944     if ($extra_indent_ok) {
 2945         my $object = $group_lines[0]->get_indentation();
 2946         if ( ref($object) ) {
 2947             my $extra_indentation_spaces_wanted =
 2948               get_recoverable_spaces($object);
 2949 
 2950             # all indentation objects must be the same
 2951             for my $i ( 1 .. @group_lines - 1 ) {
 2952                 if ( $object != $group_lines[$i]->get_indentation() ) {
 2953                     $extra_indentation_spaces_wanted = 0;
 2954                     last;
 2955                 }
 2956             }
 2957 
 2958             if ($extra_indentation_spaces_wanted) {
 2959 
 2960                 # the maximum space without exceeding the line length:
 2961                 my $avail = $group_lines[0]->get_available_space_on_right();
 2962                 $extra_leading_spaces =
 2963                   ( $avail > $extra_indentation_spaces_wanted )
 2964                   ? $extra_indentation_spaces_wanted
 2965                   : $avail;
 2966 
 2967                 # update the indentation object because with -icp the terminal
 2968                 # ');' will use the same adjustment.
 2969                 $object->permanently_decrease_available_spaces(
 2970                     -$extra_leading_spaces );
 2971             }
 2972         }
 2973     }
 2974     return $extra_leading_spaces;
 2975 }
 2976 
 2977 sub combine_fields {
 2978 
 2979     # combine all fields except for the comment field  ( sidecmt.t )
 2980     # Uses global variables:
 2981     #  @group_lines
 2982     my $maximum_field_index = $group_lines[0]->get_jmax();
 2983     foreach my $line (@group_lines) {
 2984         my $rfields = $line->get_rfields();
 2985         foreach ( 1 .. $maximum_field_index - 1 ) {
 2986             $rfields->[0] .= $rfields->[$_];
 2987         }
 2988         $rfields->[1] = $rfields->[$maximum_field_index];
 2989 
 2990         $line->set_jmax(1);
 2991         $line->set_column( 0, 0 );
 2992         $line->set_column( 1, 0 );
 2993 
 2994     }
 2995     $maximum_field_index = 1;
 2996 
 2997     foreach my $line (@group_lines) {
 2998         my $rfields = $line->get_rfields();
 2999         for my $k ( 0 .. $maximum_field_index ) {
 3000             my $pad = length( $rfields->[$k] ) - $line->current_field_width($k);
 3001             if ( $k == 0 ) {
 3002                 $pad += $line->get_leading_space_count();
 3003             }
 3004 
 3005             if ( $pad > 0 ) { $line->increase_field_width( $k, $pad ) }
 3006 
 3007         }
 3008     }
 3009     return;
 3010 }
 3011 
 3012 sub get_output_line_number {
 3013 
 3014     # the output line number reported to a caller is the number of items
 3015     # written plus the number of items in the buffer
 3016     my $self   = shift;
 3017     my $nlines = @group_lines;
 3018     return $nlines + $file_writer_object->get_output_line_number();
 3019 }
 3020 
 3021 sub valign_output_step_B {
 3022 
 3023     ###############################################################
 3024     # This is Step B in writing vertically aligned lines.
 3025     # Vertical tightness is applied according to preset flags.
 3026     # In particular this routine handles stacking of opening
 3027     # and closing tokens.
 3028     ###############################################################
 3029 
 3030     my ( $leading_space_count, $str, $side_comment_length, $outdent_long_lines,
 3031         $rvertical_tightness_flags, $level )
 3032       = @_;
 3033 
 3034     # handle outdenting of long lines:
 3035     if ($outdent_long_lines) {
 3036         my $excess =
 3037           length($str) -
 3038           $side_comment_length +
 3039           $leading_space_count -
 3040           maximum_line_length_for_level($level);
 3041         if ( $excess > 0 ) {
 3042             $leading_space_count = 0;
 3043             $last_outdented_line_at =
 3044               $file_writer_object->get_output_line_number();
 3045 
 3046             unless ($outdented_line_count) {
 3047                 $first_outdented_line_at = $last_outdented_line_at;
 3048             }
 3049             $outdented_line_count++;
 3050         }
 3051     }
 3052 
 3053     # Make preliminary leading whitespace.  It could get changed
 3054     # later by entabbing, so we have to keep track of any changes
 3055     # to the leading_space_count from here on.
 3056     my $leading_string =
 3057       $leading_space_count > 0 ? ( ' ' x $leading_space_count ) : "";
 3058 
 3059     # Unpack any recombination data; it was packed by
 3060     # sub send_lines_to_vertical_aligner. Contents:
 3061     #
 3062     #   [0] type: 1=opening non-block    2=closing non-block
 3063     #             3=opening block brace  4=closing block brace
 3064     #   [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
 3065     #             if closing: spaces of padding to use
 3066     #   [2] sequence number of container
 3067     #   [3] valid flag: do not append if this flag is false
 3068     #
 3069     my ( $open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
 3070         $seqno_end );
 3071     if ($rvertical_tightness_flags) {
 3072         (
 3073             $open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
 3074             $seqno_end
 3075         ) = @{$rvertical_tightness_flags};
 3076     }
 3077 
 3078     $seqno_string = $seqno_end;
 3079 
 3080     # handle any cached line ..
 3081     # either append this line to it or write it out
 3082     if ( length($cached_line_text) ) {
 3083 
 3084         # Dump an invalid cached line
 3085         if ( !$cached_line_valid ) {
 3086             valign_output_step_C( $cached_line_text,
 3087                 $cached_line_leading_space_count,
 3088                 $last_level_written );
 3089         }
 3090 
 3091         # Handle cached line ending in OPENING tokens
 3092         elsif ( $cached_line_type == 1 || $cached_line_type == 3 ) {
 3093 
 3094             my $gap = $leading_space_count - length($cached_line_text);
 3095 
 3096             # handle option of just one tight opening per line:
 3097             if ( $cached_line_flag == 1 ) {
 3098                 if ( defined($open_or_close) && $open_or_close == 1 ) {
 3099                     $gap = -1;
 3100                 }
 3101             }
 3102 
 3103             if ( $gap >= 0 && defined($seqno_beg) ) {
 3104                 $leading_string      = $cached_line_text . ' ' x $gap;
 3105                 $leading_space_count = $cached_line_leading_space_count;
 3106                 $seqno_string        = $cached_seqno_string . ':' . $seqno_beg;
 3107                 $level               = $last_level_written;
 3108             }
 3109             else {
 3110                 valign_output_step_C( $cached_line_text,
 3111                     $cached_line_leading_space_count,
 3112                     $last_level_written );
 3113             }
 3114         }
 3115 
 3116         # Handle cached line ending in CLOSING tokens
 3117         else {
 3118             my $test_line = $cached_line_text . ' ' x $cached_line_flag . $str;
 3119             if (
 3120 
 3121                 # The new line must start with container
 3122                 $seqno_beg
 3123 
 3124                 # The container combination must be okay..
 3125                 && (
 3126 
 3127                     # okay to combine like types
 3128                     ( $open_or_close == $cached_line_type )
 3129 
 3130                     # closing block brace may append to non-block
 3131                     || ( $cached_line_type == 2 && $open_or_close == 4 )
 3132 
 3133                     # something like ');'
 3134                     || ( !$open_or_close && $cached_line_type == 2 )
 3135 
 3136                 )
 3137 
 3138                 # The combined line must fit
 3139                 && (
 3140                     length($test_line) <=
 3141                     maximum_line_length_for_level($last_level_written) )
 3142               )
 3143             {
 3144 
 3145                 $seqno_string = $cached_seqno_string . ':' . $seqno_beg;
 3146 
 3147                 # Patch to outdent closing tokens ending # in ');'
 3148                 # If we are joining a line like ');' to a previous stacked
 3149                 # set of closing tokens, then decide if we may outdent the
 3150                 # combined stack to the indentation of the ');'.  Since we
 3151                 # should not normally outdent any of the other tokens more than
 3152                 # the indentation of the lines that contained them, we will
 3153                 # only do this if all of the corresponding opening
 3154                 # tokens were on the same line.  This can happen with
 3155                 # -sot and -sct.  For example, it is ok here:
 3156                 #   __PACKAGE__->load_components( qw(
 3157                 #         PK::Auto
 3158                 #         Core
 3159                 #   ));
 3160                 #
 3161                 #   But, for example, we do not outdent in this example because
 3162                 #   that would put the closing sub brace out farther than the
 3163                 #   opening sub brace:
 3164                 #
 3165                 #   perltidy -sot -sct
 3166                 #   $c->Tk::bind(
 3167                 #       '<Control-f>' => sub {
 3168                 #           my ($c) = @_;
 3169                 #           my $e = $c->XEvent;
 3170                 #           itemsUnderArea $c;
 3171                 #       } );
 3172                 #
 3173                 if ( $str =~ /^\);/ && $cached_line_text =~ /^[\)\}\]\s]*$/ ) {
 3174 
 3175                     # The way to tell this is if the stacked sequence numbers
 3176                     # of this output line are the reverse of the stacked
 3177                     # sequence numbers of the previous non-blank line of
 3178                     # sequence numbers.  So we can join if the previous
 3179                     # nonblank string of tokens is the mirror image.  For
 3180                     # example if stack )}] is 13:8:6 then we are looking for a
 3181                     # leading stack like [{( which is 6:8:13 We only need to
 3182                     # check the two ends, because the intermediate tokens must
 3183                     # fall in order.  Note on speed: having to split on colons
 3184                     # and eliminate multiple colons might appear to be slow,
 3185                     # but it's not an issue because we almost never come
 3186                     # through here.  In a typical file we don't.
 3187                     $seqno_string               =~ s/^:+//;
 3188                     $last_nonblank_seqno_string =~ s/^:+//;
 3189                     $seqno_string               =~ s/:+/:/g;
 3190                     $last_nonblank_seqno_string =~ s/:+/:/g;
 3191 
 3192                     # how many spaces can we outdent?
 3193                     my $diff =
 3194                       $cached_line_leading_space_count - $leading_space_count;
 3195                     if (   $diff > 0
 3196                         && length($seqno_string)
 3197                         && length($last_nonblank_seqno_string) ==
 3198                         length($seqno_string) )
 3199                     {
 3200                         my @seqno_last =
 3201                           ( split /:/, $last_nonblank_seqno_string );
 3202                         my @seqno_now = ( split /:/, $seqno_string );
 3203                         if (   @seqno_now
 3204                             && @seqno_last
 3205                             && $seqno_now[-1] == $seqno_last[0]
 3206                             && $seqno_now[0] == $seqno_last[-1] )
 3207                         {
 3208 
 3209                             # OK to outdent ..
 3210                             # for absolute safety, be sure we only remove
 3211                             # whitespace
 3212                             my $ws = substr( $test_line, 0, $diff );
 3213                             if ( ( length($ws) == $diff ) && $ws =~ /^\s+$/ ) {
 3214 
 3215                                 $test_line = substr( $test_line, $diff );
 3216                                 $cached_line_leading_space_count -= $diff;
 3217                                 $last_level_written =
 3218                                   level_change(
 3219                                     $cached_line_leading_space_count,
 3220                                     $diff, $last_level_written );
 3221                                 reduce_valign_buffer_indentation($diff);
 3222                             }
 3223 
 3224                             # shouldn't happen, but not critical:
 3225                             ##else {
 3226                             ## ERROR transferring indentation here
 3227                             ##}
 3228                         }
 3229                     }
 3230                 }
 3231 
 3232                 $str                 = $test_line;
 3233                 $leading_string      = "";
 3234                 $leading_space_count = $cached_line_leading_space_count;
 3235                 $level               = $last_level_written;
 3236             }
 3237             else {
 3238                 valign_output_step_C( $cached_line_text,
 3239                     $cached_line_leading_space_count,
 3240                     $last_level_written );
 3241             }
 3242         }
 3243     }
 3244     $cached_line_type = 0;
 3245     $cached_line_text = "";
 3246 
 3247     # make the line to be written
 3248     my $line = $leading_string . $str;
 3249 
 3250     # write or cache this line
 3251     if ( !$open_or_close || $side_comment_length > 0 ) {
 3252         valign_output_step_C( $line, $leading_space_count, $level );
 3253     }
 3254     else {
 3255         $cached_line_text                = $line;
 3256         $cached_line_type                = $open_or_close;
 3257         $cached_line_flag                = $tightness_flag;
 3258         $cached_seqno                    = $seqno;
 3259         $cached_line_valid               = $valid;
 3260         $cached_line_leading_space_count = $leading_space_count;
 3261         $cached_seqno_string             = $seqno_string;
 3262     }
 3263 
 3264     $last_level_written       = $level;
 3265     $last_side_comment_length = $side_comment_length;
 3266     $extra_indent_ok          = 0;
 3267     return;
 3268 }
 3269 
 3270 sub valign_output_step_C {
 3271 
 3272     ###############################################################
 3273     # This is Step C in writing vertically aligned lines.
 3274     # Lines are either stored in a buffer or passed along to the next step.
 3275     # The reason for storing lines is that we may later want to reduce their
 3276     # indentation when -sot and -sct are both used.
 3277     ###############################################################
 3278     my @args = @_;
 3279 
 3280     # Dump any saved lines if we see a line with an unbalanced opening or
 3281     # closing token.
 3282     dump_valign_buffer() if ( $seqno_string && $valign_buffer_filling );
 3283 
 3284     # Either store or write this line
 3285     if ($valign_buffer_filling) {
 3286         push @valign_buffer, [@args];
 3287     }
 3288     else {
 3289         valign_output_step_D(@args);
 3290     }
 3291 
 3292     # For lines starting or ending with opening or closing tokens..
 3293     if ($seqno_string) {
 3294         $last_nonblank_seqno_string = $seqno_string;
 3295 
 3296         # Start storing lines when we see a line with multiple stacked opening
 3297         # tokens.
 3298         # patch for RT #94354, requested by Colin Williams
 3299         if ( $seqno_string =~ /^\d+(\:+\d+)+$/ && $args[0] !~ /^[\}\)\]\:\?]/ )
 3300         {
 3301 
 3302             # This test is efficient but a little subtle: The first test says
 3303             # that we have multiple sequence numbers and hence multiple opening
 3304             # or closing tokens in this line.  The second part of the test
 3305             # rejects stacked closing and ternary tokens.  So if we get here
 3306             # then we should have stacked unbalanced opening tokens.
 3307 
 3308             # Here is a complex example:
 3309 
 3310             # Foo($Bar[0], {  # (side comment)
 3311             #   baz => 1,
 3312             # });
 3313 
 3314             # The first line has sequence 6::4.  It does not begin with
 3315             # a closing token or ternary, so it passes the test and must be
 3316             # stacked opening tokens.
 3317 
 3318             # The last line has sequence 4:6 but is a stack of closing tokens,
 3319             # so it gets rejected.
 3320 
 3321             # Note that the sequence number of an opening token for a qw quote
 3322             # is a negative number and will be rejected.
 3323             # For example, for the following line:
 3324             #    skip_symbols([qw(
 3325             # $seqno_string='10:5:-1'.  It would be okay to accept it but
 3326             # I decided not to do this after testing.
 3327 
 3328             $valign_buffer_filling = $seqno_string;
 3329 
 3330         }
 3331     }
 3332     return;
 3333 }
 3334 
 3335 sub valign_output_step_D {
 3336 
 3337     ###############################################################
 3338     # This is Step D in writing vertically aligned lines.
 3339     # Write one vertically aligned line of code to the output object.
 3340     ###############################################################
 3341 
 3342     my ( $line, $leading_space_count, $level ) = @_;
 3343 
 3344     # The line is currently correct if there is no tabbing (recommended!)
 3345     # We may have to lop off some leading spaces and replace with tabs.
 3346     if ( $leading_space_count > 0 ) {
 3347 
 3348         # Nothing to do if no tabs
 3349         if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
 3350             || $rOpts_indent_columns <= 0 )
 3351         {
 3352 
 3353             # nothing to do
 3354         }
 3355 
 3356         # Handle entab option
 3357         elsif ($rOpts_entab_leading_whitespace) {
 3358 
 3359          # Patch 12-nov-2018 based on report from Glenn. Extra padding was
 3360          # not correctly entabbed, nor were side comments:
 3361          # Increase leading space count for a padded line to get correct tabbing
 3362             if ( $line =~ /^(\s+)(.*)$/ ) {
 3363                 my $spaces = length($1);
 3364                 if ( $spaces > $leading_space_count ) {
 3365                     $leading_space_count = $spaces;
 3366                 }
 3367             }
 3368 
 3369             my $space_count =
 3370               $leading_space_count % $rOpts_entab_leading_whitespace;
 3371             my $tab_count =
 3372               int( $leading_space_count / $rOpts_entab_leading_whitespace );
 3373             my $leading_string = "\t" x $tab_count . ' ' x $space_count;
 3374             if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
 3375                 substr( $line, 0, $leading_space_count ) = $leading_string;
 3376             }
 3377             else {
 3378 
 3379                 # shouldn't happen - program error counting whitespace
 3380                 # - skip entabbing
 3381                 VALIGN_DEBUG_FLAG_TABS
 3382                   && warning(
 3383 "Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
 3384                   );
 3385             }
 3386         }
 3387 
 3388         # Handle option of one tab per level
 3389         else {
 3390             my $leading_string = ( "\t" x $level );
 3391             my $space_count =
 3392               $leading_space_count - $level * $rOpts_indent_columns;
 3393 
 3394             # shouldn't happen:
 3395             if ( $space_count < 0 ) {
 3396 
 3397                 # But it could be an outdented comment
 3398                 if ( $line !~ /^\s*#/ ) {
 3399                     VALIGN_DEBUG_FLAG_TABS
 3400                       && warning(
 3401 "Error entabbing in valign_output_step_D: for level=$group_level count=$leading_space_count\n"
 3402                       );
 3403                 }
 3404                 $leading_string = ( ' ' x $leading_space_count );
 3405             }
 3406             else {
 3407                 $leading_string .= ( ' ' x $space_count );
 3408             }
 3409             if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
 3410                 substr( $line, 0, $leading_space_count ) = $leading_string;
 3411             }
 3412             else {
 3413 
 3414                 # shouldn't happen - program error counting whitespace
 3415                 # we'll skip entabbing
 3416                 VALIGN_DEBUG_FLAG_TABS
 3417                   && warning(
 3418 "Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
 3419                   );
 3420             }
 3421         }
 3422     }
 3423     $file_writer_object->write_code_line( $line . "\n" );
 3424     return;
 3425 }
 3426 
 3427 {    # begin get_leading_string
 3428 
 3429     my @leading_string_cache;
 3430 
 3431     sub get_leading_string {
 3432 
 3433         # define the leading whitespace string for this line..
 3434         my $leading_whitespace_count = shift;
 3435 
 3436         # Handle case of zero whitespace, which includes multi-line quotes
 3437         # (which may have a finite level; this prevents tab problems)
 3438         if ( $leading_whitespace_count <= 0 ) {
 3439             return "";
 3440         }
 3441 
 3442         # look for previous result
 3443         elsif ( $leading_string_cache[$leading_whitespace_count] ) {
 3444             return $leading_string_cache[$leading_whitespace_count];
 3445         }
 3446 
 3447         # must compute a string for this number of spaces
 3448         my $leading_string;
 3449 
 3450         # Handle simple case of no tabs
 3451         if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
 3452             || $rOpts_indent_columns <= 0 )
 3453         {
 3454             $leading_string = ( ' ' x $leading_whitespace_count );
 3455         }
 3456 
 3457         # Handle entab option
 3458         elsif ($rOpts_entab_leading_whitespace) {
 3459             my $space_count =
 3460               $leading_whitespace_count % $rOpts_entab_leading_whitespace;
 3461             my $tab_count = int(
 3462                 $leading_whitespace_count / $rOpts_entab_leading_whitespace );
 3463             $leading_string = "\t" x $tab_count . ' ' x $space_count;
 3464         }
 3465 
 3466         # Handle option of one tab per level
 3467         else {
 3468             $leading_string = ( "\t" x $group_level );
 3469             my $space_count =
 3470               $leading_whitespace_count - $group_level * $rOpts_indent_columns;
 3471 
 3472             # shouldn't happen:
 3473             if ( $space_count < 0 ) {
 3474                 VALIGN_DEBUG_FLAG_TABS
 3475                   && warning(
 3476 "Error in get_leading_string: for level=$group_level count=$leading_whitespace_count\n"
 3477                   );
 3478 
 3479                 # -- skip entabbing
 3480                 $leading_string = ( ' ' x $leading_whitespace_count );
 3481             }
 3482             else {
 3483                 $leading_string .= ( ' ' x $space_count );
 3484             }
 3485         }
 3486         $leading_string_cache[$leading_whitespace_count] = $leading_string;
 3487         return $leading_string;
 3488     }
 3489 }    # end get_leading_string
 3490 
 3491 sub report_anything_unusual {
 3492     my $self = shift;
 3493     if ( $outdented_line_count > 0 ) {
 3494         write_logfile_entry(
 3495             "$outdented_line_count long lines were outdented:\n");
 3496         write_logfile_entry(
 3497             "  First at output line $first_outdented_line_at\n");
 3498 
 3499         if ( $outdented_line_count > 1 ) {
 3500             write_logfile_entry(
 3501                 "   Last at output line $last_outdented_line_at\n");
 3502         }
 3503         write_logfile_entry(
 3504             "  use -noll to prevent outdenting, -l=n to increase line length\n"
 3505         );
 3506         write_logfile_entry("\n");
 3507     }
 3508     return;
 3509 }
 3510 1;