lib/Perl/Tidy/VerticalAligner.pm

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