1 package Perl::Tidy::VerticalAligner;
4 our $VERSION = '20200110';
6 use Perl::Tidy::VerticalAligner::Alignment;
7 use Perl::Tidy::VerticalAligner::Line;
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.
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
18 # valign_input -----> flush
26 # Caution: these debug flags produce a lot of output
27 # They should all be 0 except when debugging small scripts
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;
34 my $debug_warning = sub {
35 print STDOUT "VALIGN_DEBUGGING with key $_[0]\n";
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');
47 $vertical_aligner_self
48 $maximum_alignment_index
52 $previous_minimum_jmax_seen
53 $previous_maximum_jmax_seen
60 $last_leading_space_count
64 $last_side_comment_line_number
65 $last_side_comment_length
66 $last_side_comment_level
68 $first_outdented_line_at
69 $last_outdented_line_at
74 $comment_leading_space_count
75 $is_matching_terminal_line
76 $consecutive_block_comments
83 $cached_line_leading_space_count
86 $valign_buffer_filling
90 $last_nonblank_seqno_string
94 $rOpts_maximum_line_length
95 $rOpts_variable_maximum_line_length
96 $rOpts_continuation_indentation
99 $rOpts_entab_leading_whitespace
102 $rOpts_fixed_position_side_comment
103 $rOpts_minimum_space_to_comment
110 my $class, $rOpts, $file_writer_object, $logger_object,
114 # variables describing the entire space group:
115 $ralignment_list = [];
117 $last_level_written = -1;
118 $extra_indent_ok = 0; # can we move all lines to the right?
119 $last_side_comment_length = 0;
120 $maximum_jmax_seen = 0;
121 $minimum_jmax_seen = 0;
122 $previous_minimum_jmax_seen = 0;
123 $previous_maximum_jmax_seen = 0;
125 # variables describing each line of the group
126 @group_lines = (); # list of all lines in group
128 $outdented_line_count = 0;
129 $first_outdented_line_at = 0;
130 $last_outdented_line_at = 0;
131 $last_side_comment_line_number = 0;
132 $last_side_comment_level = -1;
133 $is_matching_terminal_line = 0;
135 # most recent 3 side comments; [ line number, column ]
136 $side_comment_history[0] = [ -300, 0 ];
137 $side_comment_history[1] = [ -200, 0 ];
138 $side_comment_history[2] = [ -100, 0 ];
140 # valign_output_step_B cache:
141 $cached_line_text = "";
142 $cached_line_type = 0;
143 $cached_line_flag = 0;
145 $cached_line_valid = 0;
146 $cached_line_leading_space_count = 0;
147 $cached_seqno_string = "";
149 # string of sequence numbers joined together
151 $last_nonblank_seqno_string = "";
153 # frequently used parameters
154 $rOpts_indent_columns = $rOpts->{'indent-columns'};
155 $rOpts_tabs = $rOpts->{'tabs'};
156 $rOpts_entab_leading_whitespace = $rOpts->{'entab-leading-whitespace'};
157 $rOpts_fixed_position_side_comment =
158 $rOpts->{'fixed-position-side-comment'};
159 $rOpts_minimum_space_to_comment = $rOpts->{'minimum-space-to-comment'};
160 $rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
161 $rOpts_variable_maximum_line_length =
162 $rOpts->{'variable-maximum-line-length'};
163 $rOpts_valign = $rOpts->{'valign'};
165 $consecutive_block_comments = 0;
166 forget_side_comment();
168 initialize_for_new_group();
170 $vertical_aligner_self = {};
171 bless $vertical_aligner_self, $class;
172 return $vertical_aligner_self;
175 sub initialize_for_new_group {
177 $maximum_alignment_index = -1; # alignments in current group
178 $zero_count = 0; # count consecutive lines without tokens
179 $group_maximum_gap = 0; # largest gap introduced
182 $comment_leading_space_count = 0;
183 $last_leading_space_count = 0;
187 # interface to Perl::Tidy::Diagnostics routines
188 sub write_diagnostics {
190 if ($diagnostics_object) {
191 $diagnostics_object->write_diagnostics($msg);
196 # interface to Perl::Tidy::Logger routines
199 if ($logger_object) {
200 $logger_object->warning($msg);
205 sub write_logfile_entry {
207 if ($logger_object) {
208 $logger_object->write_logfile_entry($msg);
213 sub report_definite_bug {
214 if ($logger_object) {
215 $logger_object->report_definite_bug();
220 sub get_cached_line_count {
222 return @group_lines + ( $cached_line_type ? 1 : 0 );
227 # return the number of leading spaces associated with an indentation
228 # variable $indentation is either a constant number of spaces or an
229 # object with a get_spaces method.
230 my $indentation = shift;
231 return ref($indentation) ? $indentation->get_spaces() : $indentation;
234 sub get_recoverable_spaces {
236 # return the number of spaces (+ means shift right, - means shift left)
237 # that we would like to shift a group of lines with the same indentation
238 # to get them to line up with their opening parens
239 my $indentation = shift;
240 return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
243 sub get_stack_depth {
245 my $indentation = shift;
246 return ref($indentation) ? $indentation->get_stack_depth() : 0;
250 my ( $col, $token ) = @_;
252 # make one new alignment at column $col which aligns token $token
253 ++$maximum_alignment_index;
255 #my $alignment = new Perl::Tidy::VerticalAligner::Alignment(
256 my $nlines = @group_lines;
257 my $alignment = Perl::Tidy::VerticalAligner::Alignment->new(
259 starting_column => $col,
260 matching_token => $token,
261 starting_line => $nlines - 1,
262 ending_line => $nlines - 1,
263 serial_number => $maximum_alignment_index,
265 $ralignment_list->[$maximum_alignment_index] = $alignment;
269 sub dump_alignments {
271 "Current Alignments:\ni\ttoken\tstarting_column\tcolumn\tstarting_line\tending_line\n";
272 for my $i ( 0 .. $maximum_alignment_index ) {
273 my $column = $ralignment_list->[$i]->get_column();
274 my $starting_column = $ralignment_list->[$i]->get_starting_column();
275 my $matching_token = $ralignment_list->[$i]->get_matching_token();
276 my $starting_line = $ralignment_list->[$i]->get_starting_line();
277 my $ending_line = $ralignment_list->[$i]->get_ending_line();
279 "$i\t$matching_token\t$starting_column\t$column\t$starting_line\t$ending_line\n";
284 sub save_alignment_columns {
285 for my $i ( 0 .. $maximum_alignment_index ) {
286 $ralignment_list->[$i]->save_column();
291 sub restore_alignment_columns {
292 for my $i ( 0 .. $maximum_alignment_index ) {
293 $ralignment_list->[$i]->restore_column();
298 sub forget_side_comment {
299 $last_comment_column = 0;
303 sub maximum_line_length_for_level {
305 # return maximum line length for line starting with a given level
306 my $maximum_line_length = $rOpts_maximum_line_length;
307 if ($rOpts_variable_maximum_line_length) {
309 if ( $level < 0 ) { $level = 0 }
310 $maximum_line_length += $level * $rOpts_indent_columns;
312 return $maximum_line_length;
315 sub push_group_line {
318 push @group_lines, $new_line;
324 # Place one line in the current vertical group.
326 # The input parameters are:
327 # $level = indentation level of this line
328 # $rfields = reference to array of fields
329 # $rpatterns = reference to array of patterns, one per field
330 # $rtokens = reference to array of tokens starting fields 1,2,..
332 # Here is an example of what this package does. In this example,
333 # we are trying to line up both the '=>' and the '#'.
335 # '18' => 'grave', # \`
336 # '19' => 'acute', # `'
337 # '20' => 'caron', # \v
338 # <-tabs-><f1-><--field 2 ---><-f3->
341 # col1 col2 col3 col4
343 # The calling routine has already broken the entire line into 3 fields as
344 # indicated. (So the work of identifying promising common tokens has
345 # already been done).
347 # In this example, there will be 2 tokens being matched: '=>' and '#'.
348 # They are the leading parts of fields 2 and 3, but we do need to know
349 # what they are so that we can dump a group of lines when these tokens
352 # The fields contain the actual characters of each field. The patterns
353 # are like the fields, but they contain mainly token types instead
354 # of tokens, so they have fewer characters. They are used to be
355 # sure we are matching fields of similar type.
357 # In this example, there will be 4 column indexes being adjusted. The
358 # first one is always at zero. The interior columns are at the start of
359 # the matching tokens, and the last one tracks the maximum line length.
361 # Each time a new line comes in, it joins the current vertical
362 # group if possible. Otherwise it causes the current group to be dumped
363 # and a new group is started.
365 # For each new group member, the column locations are increased, as
366 # necessary, to make room for the new fields. When the group is finally
367 # output, these column numbers are used to compute the amount of spaces of
368 # padding needed for each field.
370 # Programming note: the fields are assumed not to have any tab characters.
371 # Tabs have been previously removed except for tabs in quoted strings and
372 # side comments. Tabs in these fields can mess up the column counting.
373 # The log file warns the user if there are any such tabs.
375 my ( $rline_hash, $rfields, $rtokens, $rpatterns ) = @_;
376 my $level = $rline_hash->{level};
377 my $level_end = $rline_hash->{level_end};
378 my $indentation = $rline_hash->{indentation};
379 my $is_forced_break = $rline_hash->{is_forced_break};
380 my $outdent_long_lines = $rline_hash->{outdent_long_lines};
381 my $is_terminal_ternary = $rline_hash->{is_terminal_ternary};
382 my $is_terminal_statement = $rline_hash->{is_terminal_statement};
383 my $do_not_pad = $rline_hash->{do_not_pad};
384 my $rvertical_tightness_flags = $rline_hash->{rvertical_tightness_flags};
385 my $level_jump = $rline_hash->{level_jump};
387 # number of fields is $jmax
388 # number of tokens between fields is $jmax-1
389 my $jmax = @{$rfields} - 1;
391 my $leading_space_count = get_spaces($indentation);
393 # set outdented flag to be sure we either align within statements or
394 # across statement boundaries, but not both.
395 my $is_outdented = $last_leading_space_count > $leading_space_count;
396 $last_leading_space_count = $leading_space_count;
398 # Patch: undo for hanging side comment
399 my $is_hanging_side_comment =
400 ( $jmax == 1 && $rtokens->[0] eq '#' && $rfields->[0] =~ /^\s*$/ );
401 $is_outdented = 0 if $is_hanging_side_comment;
403 # Forget side comment alignment after seeing 2 or more block comments
404 my $is_block_comment = ( $jmax == 0 && $rfields->[0] =~ /^#/ );
405 if ($is_block_comment) {
406 $consecutive_block_comments++;
409 if ( $consecutive_block_comments > 1 ) { forget_side_comment() }
410 $consecutive_block_comments = 0;
413 VALIGN_DEBUG_FLAG_APPEND0 && do {
414 my $nlines = @group_lines;
416 "APPEND0: entering lines=$nlines new #fields= $jmax, leading_count=$leading_space_count last_cmt=$last_comment_column force=$is_forced_break, level_jump=$level_jump, level=$level, group_level=$group_level, level_jump=$level_jump\n";
419 # Validate cached line if necessary: If we can produce a container
420 # with just 2 lines total by combining an existing cached opening
421 # token with the closing token to follow, then we will mark both
422 # cached flags as valid.
423 if ($rvertical_tightness_flags) {
424 if ( @group_lines <= 1
427 && $rvertical_tightness_flags->[2]
428 && $rvertical_tightness_flags->[2] == $cached_seqno )
430 $rvertical_tightness_flags->[3] ||= 1;
431 $cached_line_valid ||= 1;
435 # do not join an opening block brace with an unbalanced line
436 # unless requested with a flag value of 2
437 if ( $cached_line_type == 3
439 && $cached_line_flag < 2
440 && $level_jump != 0 )
442 $cached_line_valid = 0;
445 # patch until new aligner is finished
446 if ($do_not_pad) { my_flush() }
449 if ( $level < 0 ) { $level = 0 }
451 # do not align code across indentation level changes
452 # or if vertical alignment is turned off for debugging
453 if ( $level != $group_level || $is_outdented || !$rOpts_valign ) {
455 # we are allowed to shift a group of lines to the right if its
456 # level is greater than the previous and next group
458 ( $level < $group_level && $last_level_written < $group_level );
462 # If we know that this line will get flushed out by itself because
463 # of level changes, we can leave the extra_indent_ok flag set.
464 # That way, if we get an external flush call, we will still be
465 # able to do some -lp alignment if necessary.
466 $extra_indent_ok = ( $is_terminal_statement && $level > $group_level );
468 $group_level = $level;
470 # wait until after the above flush to get the leading space
471 # count because it may have been changed if the -icp flag is in
473 $leading_space_count = get_spaces($indentation);
477 # --------------------------------------------------------------------
478 # Collect outdentable block COMMENTS
479 # --------------------------------------------------------------------
480 my $is_blank_line = "";
481 if ( $group_type eq 'COMMENT' ) {
485 && $outdent_long_lines
486 && $leading_space_count == $comment_leading_space_count
491 push_group_line( $rfields->[0] );
499 # --------------------------------------------------------------------
500 # add dummy fields for terminal ternary
501 # --------------------------------------------------------------------
502 my $j_terminal_match;
504 if ( $is_terminal_ternary && @group_lines ) {
506 fix_terminal_ternary( $group_lines[-1], $rfields, $rtokens,
508 $jmax = @{$rfields} - 1;
511 # --------------------------------------------------------------------
512 # add dummy fields for else statement
513 # --------------------------------------------------------------------
515 if ( $rfields->[0] =~ /^else\s*$/
517 && $level_jump == 0 )
521 fix_terminal_else( $group_lines[-1], $rfields, $rtokens, $rpatterns );
522 $jmax = @{$rfields} - 1;
525 # --------------------------------------------------------------------
526 # Handle simple line of code with no fields to match.
527 # --------------------------------------------------------------------
532 && !get_recoverable_spaces( $group_lines[0]->get_indentation() ) )
535 # flush the current group if it has some aligned columns..
536 if ( $group_lines[0]->get_jmax() > 1 ) { my_flush() }
538 # flush current group if we are just collecting side comments..
541 # ...and we haven't seen a comment lately
544 # ..or if this new line doesn't fit to the left of the comments
545 || ( ( $leading_space_count + length( $rfields->[0] ) ) >
546 $group_lines[0]->get_column(0) )
553 # start new COMMENT group if this comment may be outdented
554 if ( $is_block_comment
555 && $outdent_long_lines
558 $group_type = 'COMMENT';
559 $comment_leading_space_count = $leading_space_count;
560 push_group_line( $rfields->[0] );
564 # just write this line directly if no current group, no side comment,
565 # and no space recovery is needed.
566 if ( !@group_lines && !get_recoverable_spaces($indentation) ) {
567 valign_output_step_B( $leading_space_count, $rfields->[0], 0,
568 $outdent_long_lines, $rvertical_tightness_flags, $level );
576 # programming check: (shouldn't happen)
577 # an error here implies an incorrect call was made
578 if ( @{$rfields} && ( @{$rtokens} != ( @{$rfields} - 1 ) ) ) {
579 my $nt = @{$rtokens};
580 my $nf = @{$rfields};
582 "Program bug in Perl::Tidy::VerticalAligner - number of tokens = $nt should be one less than number of fields: $nf)\n"
584 report_definite_bug();
586 my $maximum_line_length_for_level = maximum_line_length_for_level($level);
588 # --------------------------------------------------------------------
589 # create an object to hold this line
590 # --------------------------------------------------------------------
591 my $new_line = Perl::Tidy::VerticalAligner::Line->new(
593 jmax_original_line => $jmax,
596 rpatterns => $rpatterns,
597 indentation => $indentation,
598 leading_space_count => $leading_space_count,
599 outdent_long_lines => $outdent_long_lines,
601 is_hanging_side_comment => $is_hanging_side_comment,
602 maximum_line_length => $maximum_line_length_for_level,
603 rvertical_tightness_flags => $rvertical_tightness_flags,
604 is_terminal_ternary => $is_terminal_ternary,
605 j_terminal_match => $j_terminal_match,
608 # --------------------------------------------------------------------
609 # It simplifies things to create a zero length side comment
611 # --------------------------------------------------------------------
612 make_side_comment( $new_line, $level_end );
614 # --------------------------------------------------------------------
615 # Decide if this is a simple list of items.
616 # There are 3 list types: none, comma, comma-arrow.
617 # We use this below to be less restrictive in deciding what to align.
618 # --------------------------------------------------------------------
619 if ($is_forced_break) {
620 decide_if_list($new_line);
623 # --------------------------------------------------------------------
624 # Append this line to the current group (or start new group)
625 # --------------------------------------------------------------------
626 if ( !@group_lines ) {
627 add_to_group($new_line);
630 push_group_line($new_line);
633 # output this group if it ends in a terminal else or ternary line
634 if ( defined($j_terminal_match) ) {
638 # Force break after jump to lower level
639 if ( $level_jump < 0 ) {
643 # --------------------------------------------------------------------
644 # Some old debugging stuff
645 # --------------------------------------------------------------------
646 VALIGN_DEBUG_FLAG_APPEND && do {
647 print STDOUT "APPEND fields:";
648 dump_array( @{$rfields} );
649 print STDOUT "APPEND tokens:";
650 dump_array( @{$rtokens} );
651 print STDOUT "APPEND patterns:";
652 dump_array( @{$rpatterns} );
659 sub join_hanging_comment {
662 my $jmax = $line->get_jmax();
663 return 0 unless $jmax == 1; # must be 2 fields
664 my $rtokens = $line->get_rtokens();
665 return 0 unless $rtokens->[0] eq '#'; # the second field is a comment..
666 my $rfields = $line->get_rfields();
667 return 0 unless $rfields->[0] =~ /^\s*$/; # the first field is empty...
668 my $old_line = shift;
669 my $maximum_field_index = $old_line->get_jmax();
671 unless $maximum_field_index > $jmax; # the current line has more fields
672 my $rpatterns = $line->get_rpatterns();
674 $line->set_is_hanging_side_comment(1);
675 $jmax = $maximum_field_index;
676 $line->set_jmax($jmax);
677 $rfields->[$jmax] = $rfields->[1];
678 $rtokens->[ $jmax - 1 ] = $rtokens->[0];
679 $rpatterns->[ $jmax - 1 ] = $rpatterns->[0];
680 foreach my $j ( 1 .. $jmax - 1 ) {
681 $rfields->[$j] = " "; # NOTE: caused glitch unless 1 blank, why?
682 $rtokens->[ $j - 1 ] = "";
683 $rpatterns->[ $j - 1 ] = "";
688 sub eliminate_old_fields {
690 my $new_line = shift;
691 my $jmax = $new_line->get_jmax();
692 if ( $jmax > $maximum_jmax_seen ) { $maximum_jmax_seen = $jmax }
693 if ( $jmax < $minimum_jmax_seen ) { $minimum_jmax_seen = $jmax }
695 # there must be one previous line
696 return unless ( @group_lines == 1 );
698 my $old_line = shift;
699 my $maximum_field_index = $old_line->get_jmax();
701 ###############################################
702 # Moved below to allow new coding for => matches
703 # return unless $maximum_field_index > $jmax;
704 ###############################################
706 # Identify specific cases where field elimination is allowed:
707 # case=1: both lines have comma-separated lists, and the first
709 # case=2: both lines have leading equals
711 # case 1 is the default
714 # See if case 2: both lines have leading '='
715 # We'll require similar leading patterns in this case
716 my $old_rtokens = $old_line->get_rtokens();
717 my $rtokens = $new_line->get_rtokens();
718 my $rpatterns = $new_line->get_rpatterns();
719 my $old_rpatterns = $old_line->get_rpatterns();
720 if ( $rtokens->[0] =~ /^=>?\d*$/
721 && $old_rtokens->[0] eq $rtokens->[0]
722 && $old_rpatterns->[0] eq $rpatterns->[0] )
727 # not too many fewer fields in new line for case 1
728 return unless ( $case != 1 || $maximum_field_index - 2 <= $jmax );
730 # case 1 must have side comment
731 my $old_rfields = $old_line->get_rfields();
734 && length( $old_rfields->[$maximum_field_index] ) == 0 );
736 my $rfields = $new_line->get_rfields();
740 my @new_alignments = ();
742 my @new_matching_patterns = ();
743 my @new_matching_tokens = ();
746 my $current_field = '';
747 my $current_pattern = '';
749 # loop over all old tokens
751 foreach my $k ( 0 .. $maximum_field_index - 1 ) {
752 $current_field .= $old_rfields->[$k];
753 $current_pattern .= $old_rpatterns->[$k];
754 last if ( $j > $jmax - 1 );
756 if ( $old_rtokens->[$k] eq $rtokens->[$j] ) {
758 $new_fields[$j] = $current_field;
759 $new_matching_patterns[$j] = $current_pattern;
761 $current_pattern = '';
762 $new_matching_tokens[$j] = $old_rtokens->[$k];
763 $new_alignments[$j] = $old_line->get_alignment($k);
768 if ( $old_rtokens->[$k] =~ /^\=\d*$/ ) {
769 last if ( $case == 2 ); # avoid problems with stuff
774 if ( $in_match && $case == 1 )
775 ; # disallow gaps in matching field types in case 1
779 # Modify the current state if we are successful.
780 # We must exactly reach the ends of the new list for success, and the old
781 # pattern must have more fields. Here is an example where the first and
782 # second lines have the same number, and we should not align:
783 # my @a = map chr, 0 .. 255;
784 # my @b = grep /\W/, @a;
785 # my @c = grep /[^\w]/, @a;
787 # Otherwise, we would get all of the commas aligned, which doesn't work as
789 # my @a = map chr, 0 .. 255;
790 # my @b = grep /\W/, @a;
791 # my @c = grep /[^\w]/, @a;
794 && ( $current_field eq '' )
795 && ( $case != 1 || $hid_equals )
796 && ( $maximum_field_index > $jmax ) )
798 my $k = $maximum_field_index;
799 $current_field .= $old_rfields->[$k];
800 $current_pattern .= $old_rpatterns->[$k];
801 $new_fields[$j] = $current_field;
802 $new_matching_patterns[$j] = $current_pattern;
804 $new_alignments[$j] = $old_line->get_alignment($k);
805 $maximum_field_index = $j;
807 $old_line->set_alignments(@new_alignments);
808 $old_line->set_jmax($jmax);
809 $old_line->set_rtokens( \@new_matching_tokens );
810 $old_line->set_rfields( \@new_fields );
811 $old_line->set_rpatterns( \@{$rpatterns} );
814 # Dumb Down starting match if necessary:
816 # Consider the following two lines:
819 # $a => 20 > 3 ? 1 : 0,
823 # We would like to get alignment regardless of the order of the two lines.
824 # If the lines come in in this order, then we will simplify the patterns of
825 # the first line in sub eliminate_new_fields. If the lines come in reverse
826 # order, then we achieve this with eliminate_new_fields.
828 # This update is currently restricted to leading '=>' matches. Although we
829 # could do this for both '=' and '=>', overall the results for '=' come out
830 # better without this step because this step can eliminate some other good
831 # matches. For example, with the '=' we get:
833 # my @disilva = ( "di Silva", "diSilva", "di Si\x{301}lva", "diSi\x{301}lva" );
834 # my @dsf = map "$_\x{FFFE}Fred", @disilva;
835 # my @dsj = map "$_\x{FFFE}John", @disilva;
836 # my @dsJ = map "$_ John", @disilva;
838 # without including '=' we get:
840 # my @disilva = ( "di Silva", "diSilva", "di Si\x{301}lva", "diSi\x{301}lva" );
841 # my @dsf = map "$_\x{FFFE}Fred", @disilva;
842 # my @dsj = map "$_\x{FFFE}John", @disilva;
843 # my @dsJ = map "$_ John", @disilva;
847 && @new_matching_tokens == 1
848 ##&& $new_matching_tokens[0] =~ /^=/ # see note above
849 && $new_matching_tokens[0] =~ /^=>/
850 && $maximum_field_index > 2
853 my $jmaxm = $jmax - 1;
854 my $kmaxm = $maximum_field_index - 1;
855 my $have_side_comment = $old_rtokens->[$kmaxm] eq '#';
857 # We need to reduce the group pattern to be just two tokens,
858 # the leading equality or => and the final side comment
860 my $mid_field = join "",
861 @{$old_rfields}[ 1 .. $maximum_field_index - 1 ];
862 my $mid_patterns = join "",
863 @{$old_rpatterns}[ 1 .. $maximum_field_index - 1 ];
864 my @new_alignments = (
865 $old_line->get_alignment(0),
866 $old_line->get_alignment( $maximum_field_index - 1 )
869 ( $old_rtokens->[0], $old_rtokens->[ $maximum_field_index - 1 ] );
871 $old_rfields->[0], $mid_field, $old_rfields->[$maximum_field_index]
874 $old_rpatterns->[0], $mid_patterns,
875 $old_rpatterns->[$maximum_field_index]
878 $maximum_field_index = 2;
879 $old_line->set_jmax($maximum_field_index);
880 $old_line->set_rtokens( \@new_tokens );
881 $old_line->set_rfields( \@new_fields );
882 $old_line->set_rpatterns( \@new_patterns );
884 initialize_for_new_group();
885 add_to_group($old_line);
890 # create an empty side comment if none exists
891 sub make_side_comment {
892 my ( $new_line, $level_end ) = @_;
893 my $jmax = $new_line->get_jmax();
894 my $rtokens = $new_line->get_rtokens();
896 # if line does not have a side comment...
897 if ( ( $jmax == 0 ) || ( $rtokens->[ $jmax - 1 ] ne '#' ) ) {
898 my $rfields = $new_line->get_rfields();
899 my $rpatterns = $new_line->get_rpatterns();
900 $rtokens->[$jmax] = '#';
901 $rfields->[ ++$jmax ] = '';
902 $rpatterns->[$jmax] = '#';
903 $new_line->set_jmax($jmax);
904 $new_line->set_jmax_original_line($jmax);
907 # line has a side comment..
910 # don't remember old side comment location for very long
911 my $line_number = $vertical_aligner_self->get_output_line_number();
912 my $rfields = $new_line->get_rfields();
914 $line_number - $last_side_comment_line_number > 12
916 # and don't remember comment location across block level changes
917 || ( $level_end < $last_side_comment_level
918 && $rfields->[0] =~ /^}/ )
921 forget_side_comment();
923 $last_side_comment_line_number = $line_number;
924 $last_side_comment_level = $level_end;
933 # A list will be taken to be a line with a forced break in which all
934 # of the field separators are commas or comma-arrows (except for the
937 # List separator tokens are things like ',3' or '=>2',
938 # where the trailing digit is the nesting depth. Allow braces
939 # to allow nested list items.
940 my $rtokens = $line->get_rtokens();
941 my $test_token = $rtokens->[0];
942 if ( $test_token =~ /^(\,|=>)/ ) {
943 my $list_type = $test_token;
944 my $jmax = $line->get_jmax();
946 foreach ( 1 .. $jmax - 2 ) {
947 if ( $rtokens->[$_] !~ /^(\,|=>|\{)/ ) {
952 $line->set_list_type($list_type);
957 sub eliminate_new_fields {
959 my ( $new_line, $old_line ) = @_;
960 return unless (@group_lines);
961 my $jmax = $new_line->get_jmax();
963 my $old_rtokens = $old_line->get_rtokens();
964 my $rtokens = $new_line->get_rtokens();
966 ( $rtokens->[0] =~ /^=>?\d*$/ && ( $old_rtokens->[0] eq $rtokens->[0] ) );
968 # must be monotonic variation
969 return unless ( $is_assignment || $previous_maximum_jmax_seen <= $jmax );
971 # must be more fields in the new line
972 my $maximum_field_index = $old_line->get_jmax();
973 return unless ( $maximum_field_index < $jmax );
975 unless ($is_assignment) {
977 unless ( $old_line->get_jmax_original_line() == $minimum_jmax_seen )
978 ; # only if monotonic
980 # never combine fields of a comma list
982 unless ( $maximum_field_index > 1 )
983 && ( $new_line->get_list_type() !~ /^,/ );
986 my $rfields = $new_line->get_rfields();
987 my $rpatterns = $new_line->get_rpatterns();
988 my $old_rpatterns = $old_line->get_rpatterns();
990 # loop over all OLD tokens except comment and check match
992 foreach my $k ( 0 .. $maximum_field_index - 2 ) {
993 if ( ( $old_rtokens->[$k] ne $rtokens->[$k] )
994 || ( $old_rpatterns->[$k] ne $rpatterns->[$k] ) )
1001 # first tokens agree, so combine extra new tokens
1003 foreach my $k ( $maximum_field_index .. $jmax - 1 ) {
1005 $rfields->[ $maximum_field_index - 1 ] .= $rfields->[$k];
1006 $rfields->[$k] = "";
1007 $rpatterns->[ $maximum_field_index - 1 ] .= $rpatterns->[$k];
1008 $rpatterns->[$k] = "";
1011 $rtokens->[ $maximum_field_index - 1 ] = '#';
1012 $rfields->[$maximum_field_index] = $rfields->[$jmax];
1013 $rpatterns->[$maximum_field_index] = $rpatterns->[$jmax];
1014 $jmax = $maximum_field_index;
1016 $new_line->set_jmax($jmax);
1020 sub fix_terminal_ternary {
1022 # Add empty fields as necessary to align a ternary term
1031 # returns 1 if the terminal item should be indented
1033 my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
1034 return unless ($old_line);
1037 ## my ( $old_line, $end_line ) = @_;
1038 ## return unless ( $old_line && $end_line );
1040 ## my $rfields = $end_line->get_rfields();
1041 ## my $rpatterns = $end_line->get_rpatterns();
1042 ## my $rtokens = $end_line->get_rtokens();
1044 my $jmax = @{$rfields} - 1;
1045 my $rfields_old = $old_line->get_rfields();
1047 my $rpatterns_old = $old_line->get_rpatterns();
1048 my $rtokens_old = $old_line->get_rtokens();
1049 my $maximum_field_index = $old_line->get_jmax();
1051 # look for the question mark after the :
1055 foreach my $j ( 0 .. $maximum_field_index - 1 ) {
1056 my $tok = $rtokens_old->[$j];
1057 if ( $tok =~ /^\?(\d+)$/ ) {
1058 $depth_question = $1;
1060 # depth must be correct
1061 next unless ( $depth_question eq $group_level );
1064 if ( $rfields_old->[ $j + 1 ] =~ /^(\?\s*)/ ) {
1065 $pad = " " x length($1);
1068 return; # shouldn't happen
1073 return unless ( defined($jquestion) ); # shouldn't happen
1075 # Now splice the tokens and patterns of the previous line
1076 # into the else line to insure a match. Add empty fields
1078 my $jadd = $jquestion;
1080 # Work on copies of the actual arrays in case we have
1081 # to return due to an error
1082 my @fields = @{$rfields};
1083 my @patterns = @{$rpatterns};
1084 my @tokens = @{$rtokens};
1086 VALIGN_DEBUG_FLAG_TERNARY && do {
1088 print STDOUT "CURRENT FIELDS=<@{$rfields_old}>\n";
1089 print STDOUT "CURRENT TOKENS=<@{$rtokens_old}>\n";
1090 print STDOUT "CURRENT PATTERNS=<@{$rpatterns_old}>\n";
1091 print STDOUT "UNMODIFIED FIELDS=<@{$rfields}>\n";
1092 print STDOUT "UNMODIFIED TOKENS=<@{$rtokens}>\n";
1093 print STDOUT "UNMODIFIED PATTERNS=<@{$rpatterns}>\n";
1096 # handle cases of leading colon on this line
1097 if ( $fields[0] =~ /^(:\s*)(.*)$/ ) {
1099 my ( $colon, $therest ) = ( $1, $2 );
1101 # Handle sub-case of first field with leading colon plus additional code
1102 # This is the usual situation as at the '1' below:
1108 # Split the first field after the leading colon and insert padding.
1109 # Note that this padding will remain even if the terminal value goes
1110 # out on a separate line. This does not seem to look to bad, so no
1111 # mechanism has been included to undo it.
1112 my $field1 = shift @fields;
1113 unshift @fields, ( $colon, $pad . $therest );
1115 # change the leading pattern from : to ?
1116 return unless ( $patterns[0] =~ s/^\:/?/ );
1118 # install leading tokens and patterns of existing line
1119 unshift( @tokens, @{$rtokens_old}[ 0 .. $jquestion ] );
1120 unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
1122 # insert appropriate number of empty fields
1123 splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
1126 # handle sub-case of first field just equal to leading colon.
1127 # This can happen for example in the example below where
1128 # the leading '(' would create a new alignment token
1129 # : ( $name =~ /[]}]$/ ) ? ( $mname = $name )
1130 # : ( $mname = $name . '->' );
1133 return unless ( $jmax > 0 && $tokens[0] ne '#' ); # shouldn't happen
1135 # prepend a leading ? onto the second pattern
1136 $patterns[1] = "?b" . $patterns[1];
1138 # pad the second field
1139 $fields[1] = $pad . $fields[1];
1141 # install leading tokens and patterns of existing line, replacing
1142 # leading token and inserting appropriate number of empty fields
1143 splice( @tokens, 0, 1, @{$rtokens_old}[ 0 .. $jquestion ] );
1144 splice( @patterns, 1, 0, @{$rpatterns_old}[ 1 .. $jquestion ] );
1145 splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
1149 # Handle case of no leading colon on this line. This will
1150 # be the case when -wba=':' is used. For example,
1155 # install leading tokens and patterns of existing line
1156 $patterns[0] = '?' . 'b' . $patterns[0];
1157 unshift( @tokens, @{$rtokens_old}[ 0 .. $jquestion ] );
1158 unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
1160 # insert appropriate number of empty fields
1161 $jadd = $jquestion + 1;
1162 $fields[0] = $pad . $fields[0];
1163 splice( @fields, 0, 0, ('') x $jadd ) if $jadd;
1166 VALIGN_DEBUG_FLAG_TERNARY && do {
1168 print STDOUT "MODIFIED TOKENS=<@tokens>\n";
1169 print STDOUT "MODIFIED PATTERNS=<@patterns>\n";
1170 print STDOUT "MODIFIED FIELDS=<@fields>\n";
1173 # all ok .. update the arrays
1174 @{$rfields} = @fields;
1175 @{$rtokens} = @tokens;
1176 @{$rpatterns} = @patterns;
1178 ## $end_line->set_rfields( \@fields );
1179 ## $end_line->set_rtokens( \@tokens );
1180 ## $end_line->set_rpatterns( \@patterns );
1182 # force a flush after this line
1186 sub fix_terminal_else {
1188 # Add empty fields as necessary to align a balanced terminal
1189 # else block to a previous if/elsif/unless block,
1192 # if ( 1 || $x ) { print "ok 13\n"; }
1193 # else { print "not ok 13\n"; }
1195 # returns a positive value if the else block should be indented
1197 my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
1198 return unless ($old_line);
1199 my $jmax = @{$rfields} - 1;
1200 return unless ( $jmax > 0 );
1202 # check for balanced else block following if/elsif/unless
1203 my $rfields_old = $old_line->get_rfields();
1205 # TBD: add handling for 'case'
1206 return unless ( $rfields_old->[0] =~ /^(if|elsif|unless)\s*$/ );
1208 # look for the opening brace after the else, and extract the depth
1209 my $tok_brace = $rtokens->[0];
1211 if ( $tok_brace =~ /^\{(\d+)/ ) { $depth_brace = $1; }
1213 # probably: "else # side_comment"
1216 my $rpatterns_old = $old_line->get_rpatterns();
1217 my $rtokens_old = $old_line->get_rtokens();
1218 my $maximum_field_index = $old_line->get_jmax();
1220 # be sure the previous if/elsif is followed by an opening paren
1222 my $tok_paren = '(' . $depth_brace;
1223 my $tok_test = $rtokens_old->[$jparen];
1224 return unless ( $tok_test eq $tok_paren ); # shouldn't happen
1226 # Now find the opening block brace
1228 foreach my $j ( 1 .. $maximum_field_index - 1 ) {
1229 my $tok = $rtokens_old->[$j];
1230 if ( $tok eq $tok_brace ) {
1235 return unless ( defined($jbrace) ); # shouldn't happen
1237 # Now splice the tokens and patterns of the previous line
1238 # into the else line to insure a match. Add empty fields
1240 my $jadd = $jbrace - $jparen;
1241 splice( @{$rtokens}, 0, 0, @{$rtokens_old}[ $jparen .. $jbrace - 1 ] );
1242 splice( @{$rpatterns}, 1, 0, @{$rpatterns_old}[ $jparen + 1 .. $jbrace ] );
1243 splice( @{$rfields}, 1, 0, ('') x $jadd );
1245 # force a flush after this line if it does not follow a case
1246 if ( $rfields_old->[0] =~ /^case\s*$/ ) { return }
1247 else { return $jbrace }
1251 my %is_good_alignment;
1255 # Vertically aligning on certain "good" tokens is usually okay
1256 # so we can be less restrictive in marginal cases.
1257 my @q = qw( { ? => = );
1259 @is_good_alignment{@q} = (1) x scalar(@q);
1264 # See if the current line matches the current vertical alignment group.
1265 # If not, flush the current group.
1266 my ( $new_line, $old_line ) = @_;
1268 # uses global variables:
1269 # $previous_minimum_jmax_seen
1270 # $maximum_jmax_seen
1272 my $jmax = $new_line->get_jmax();
1273 my $maximum_field_index = $old_line->get_jmax();
1275 # flush if this line has too many fields
1276 # variable $GoToLoc indicates goto branch point, for debugging
1278 if ( $jmax > $maximum_field_index ) { goto NO_MATCH }
1280 # flush if adding this line would make a non-monotonic field count
1282 ( $maximum_field_index > $jmax ) # this has too few fields
1284 ( $previous_minimum_jmax_seen <
1285 $jmax ) # and wouldn't be monotonic
1286 || ( $old_line->get_jmax_original_line() != $maximum_jmax_seen )
1294 # otherwise see if this line matches the current group
1295 my $jmax_original_line = $new_line->get_jmax_original_line();
1296 my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
1297 my $rtokens = $new_line->get_rtokens();
1298 my $rfields = $new_line->get_rfields();
1299 my $rpatterns = $new_line->get_rpatterns();
1300 my $list_type = $new_line->get_list_type();
1302 my $group_list_type = $old_line->get_list_type();
1303 my $old_rpatterns = $old_line->get_rpatterns();
1304 my $old_rtokens = $old_line->get_rtokens();
1306 my $jlimit = $jmax - 1;
1307 if ( $maximum_field_index > $jmax ) {
1308 $jlimit = $jmax_original_line;
1309 --$jlimit unless ( length( $new_line->get_rfields()->[$jmax] ) );
1312 # handle comma-separated lists ..
1313 if ( $group_list_type && ( $list_type eq $group_list_type ) ) {
1314 for my $j ( 0 .. $jlimit ) {
1315 my $old_tok = $old_rtokens->[$j];
1316 next unless $old_tok;
1317 my $new_tok = $rtokens->[$j];
1318 next unless $new_tok;
1320 # lists always match ...
1321 # unless they would align any '=>'s with ','s
1324 if ( $old_tok =~ /^=>/ && $new_tok =~ /^,/
1325 || $new_tok =~ /^=>/ && $old_tok =~ /^,/ );
1329 # do detailed check for everything else except hanging side comments
1330 elsif ( !$is_hanging_side_comment ) {
1332 my $leading_space_count = $new_line->get_leading_space_count();
1336 my $saw_good_alignment;
1338 for my $j ( 0 .. $jlimit ) {
1340 my $old_tok = $old_rtokens->[$j];
1341 my $new_tok = $rtokens->[$j];
1343 # Note on encoding used for alignment tokens:
1344 # -------------------------------------------
1345 # Tokens are "decorated" with information which can help
1346 # prevent unwanted alignments. Consider for example the
1347 # following two lines:
1348 # local ( $xn, $xd ) = split( '/', &'rnorm(@_) );
1349 # local ( $i, $f ) = &'bdiv( $xn, $xd );
1350 # There are three alignment tokens in each line, a comma,
1351 # an =, and a comma. In the first line these three tokens
1353 # ,4+local-18 =3 ,4+split-7
1354 # and in the second line they are encoded as
1355 # ,4+local-18 =3 ,4+&'bdiv-8
1356 # Tokens always at least have token name and nesting
1357 # depth. So in this example the ='s are at depth 3 and
1358 # the ,'s are at depth 4. This prevents aligning tokens
1359 # of different depths. Commas contain additional
1360 # information, as follows:
1361 # , {depth} + {container name} - {spaces to opening paren}
1362 # This allows us to reject matching the rightmost commas
1363 # in the above two lines, since they are for different
1364 # function calls. This encoding is done in
1365 # 'sub send_lines_to_vertical_aligner'.
1367 # Pick off actual token.
1368 # Everything up to the first digit is the actual token.
1369 my $alignment_token = $new_tok;
1370 if ( $alignment_token =~ /^([^\d]+)/ ) { $alignment_token = $1 }
1372 # see if the decorated tokens match
1373 my $tokens_match = $new_tok eq $old_tok
1375 # Exception for matching terminal : of ternary statement..
1376 # consider containers prefixed by ? and : a match
1377 || ( $new_tok =~ /^,\d*\+\:/ && $old_tok =~ /^,\d*\+\?/ );
1379 # No match if the alignment tokens differ...
1380 if ( !$tokens_match ) {
1382 # ...Unless this is a side comment
1386 # and there is either at least one alignment token
1387 # or this is a single item following a list. This
1388 # latter rule is required for 'December' to join
1389 # the following list:
1391 # '', 'January', 'February', 'March',
1392 # 'April', 'May', 'June', 'July',
1393 # 'August', 'September', 'October', 'November',
1396 # If it doesn't then the -lp formatting will fail.
1397 && ( $j > 0 || $old_tok =~ /^,/ )
1401 if ( $marginal_match == 0
1402 && @group_lines == 1 );
1410 # Calculate amount of padding required to fit this in.
1411 # $pad is the number of spaces by which we must increase
1412 # the current field to squeeze in this field.
1414 length( $rfields->[$j] ) - $old_line->current_field_width($j);
1415 if ( $j == 0 ) { $pad += $leading_space_count; }
1417 # remember max pads to limit marginal cases
1418 if ( $alignment_token ne '#' ) {
1419 if ( $pad > $max_pad ) { $max_pad = $pad }
1420 if ( $pad < $min_pad ) { $min_pad = $pad }
1422 if ( $is_good_alignment{$alignment_token} ) {
1423 $saw_good_alignment = 1;
1426 # If patterns don't match, we have to be careful...
1427 if ( $old_rpatterns->[$j] ne $rpatterns->[$j] ) {
1429 # flag this as a marginal match since patterns differ
1431 if ( $marginal_match == 0 && @group_lines == 1 );
1433 # We have to be very careful about aligning commas
1434 # when the pattern's don't match, because it can be
1435 # worse to create an alignment where none is needed
1436 # than to omit one. Here's an example where the ','s
1437 # are not in named containers. The first line below
1438 # should not match the next two:
1439 # ( $a, $b ) = ( $b, $r );
1440 # ( $x1, $x2 ) = ( $x2 - $q * $x1, $x1 );
1441 # ( $y1, $y2 ) = ( $y2 - $q * $y1, $y1 );
1442 if ( $alignment_token eq ',' ) {
1444 # do not align commas unless they are in named containers
1446 goto NO_MATCH unless ( $new_tok =~ /[A-Za-z]/ );
1449 # do not align parens unless patterns match;
1450 # large ugly spaces can occur in math expressions.
1451 elsif ( $alignment_token eq '(' ) {
1453 # But we can allow a match if the parens don't
1454 # require any padding.
1456 if ( $pad != 0 ) { goto NO_MATCH }
1459 # Handle an '=' alignment with different patterns to
1461 elsif ( $alignment_token eq '=' ) {
1463 # It is best to be a little restrictive when
1464 # aligning '=' tokens. Here is an example of
1465 # two lines that we will not align:
1468 # The problem is that one is a 'my' declaration,
1469 # and the other isn't, so they're not very similar.
1470 # We will filter these out by comparing the first
1471 # letter of the pattern. This is crude, but works
1474 substr( $old_rpatterns->[$j], 0, 1 ) ne
1475 substr( $rpatterns->[$j], 0, 1 ) )
1481 # If we pass that test, we'll call it a marginal match.
1482 # Here is an example of a marginal match:
1484 # $op = compile_bblock($op);
1485 # The left tokens are both identifiers, but
1486 # one accesses a hash and the other doesn't.
1487 # We'll let this be a tentative match and undo
1488 # it later if we don't find more than 2 lines
1490 elsif ( @group_lines == 1 ) {
1492 2; # =2 prevents being undone below
1497 # Don't let line with fewer fields increase column widths
1499 if ( $maximum_field_index > $jmax ) {
1501 # Exception: suspend this rule to allow last lines to join
1503 if ( $pad > 0 ) { goto NO_MATCH; }
1505 } ## end for my $j ( 0 .. $jlimit)
1507 # Turn off the "marginal match" flag in some cases...
1508 # A "marginal match" occurs when the alignment tokens agree
1509 # but there are differences in the other tokens (patterns).
1510 # If we leave the marginal match flag set, then the rule is that we
1511 # will align only if there are more than two lines in the group.
1512 # We will turn of the flag if we almost have a match
1513 # and either we have seen a good alignment token or we
1514 # just need a small pad (2 spaces) to fit. These rules are
1515 # the result of experimentation. Tokens which misaligned by just
1516 # one or two characters are annoying. On the other hand,
1517 # large gaps to less important alignment tokens are also annoying.
1518 if ( $marginal_match == 1
1519 && $jmax == $maximum_field_index
1520 && ( $saw_good_alignment || ( $max_pad < 3 && $min_pad > -3 ) )
1523 $marginal_match = 0;
1525 ##print "marginal=$marginal_match saw=$saw_good_alignment jmax=$jmax max=$maximum_field_index maxpad=$max_pad minpad=$min_pad\n";
1528 # We have a match (even if marginal).
1529 # If the current line has fewer fields than the current group
1530 # but otherwise matches, copy the remaining group fields to
1531 # make it a perfect match.
1532 if ( $maximum_field_index > $jmax ) {
1534 ##########################################################
1535 # FIXME: The previous version had a bug which made side comments
1536 # become regular fields, so for now the program does not allow a
1537 # line with side comment to match. This should eventually be done.
1538 # The best test file for experimenting is 'lista.t'
1539 ##########################################################
1541 my $comment = $rfields->[$jmax];
1543 goto NO_MATCH if ($comment);
1546 for my $jj ( $jlimit .. $maximum_field_index ) {
1547 $rtokens->[$jj] = $old_rtokens->[$jj];
1548 $rfields->[ $jj + 1 ] = '';
1549 $rpatterns->[ $jj + 1 ] = $old_rpatterns->[ $jj + 1 ];
1552 ## THESE DO NOT GIVE CORRECT RESULTS
1553 ## $rfields->[$jmax] = $comment;
1554 ## $new_line->set_jmax($jmax);
1561 # variable $GoToLoc is for debugging
1562 #print "no match from $GoToLoc\n";
1564 # Make one last effort to retain a match of certain statements
1565 my $match = salvage_equality_matches( $new_line, $old_line );
1566 my_flush_code() unless ($match);
1571 sub salvage_equality_matches {
1572 my ( $new_line, $old_line ) = @_;
1574 # Reduce the complexity of the two lines if it will allow us to retain
1575 # alignment of some common alignments, including '=' and '=>'. We will
1576 # convert both lines to have just two matching tokens, the equality and the
1579 # return 0 or undef if unsuccessful
1580 # return 1 if successful
1582 # Here is a very simple example of two lines where we could at least
1584 # $x = $class->_sub( $x, $delta );
1585 # $xpownm1 = $class->_pow( $class->_copy($x), $nm1 ); # x(i)^(n-1)
1587 # We will only do this if there is one old line (and one new line)
1588 return unless ( @group_lines == 1 );
1589 return if ($is_matching_terminal_line);
1591 # We are only looking for equality type statements
1592 my $old_rtokens = $old_line->get_rtokens();
1593 my $rtokens = $new_line->get_rtokens();
1595 ( $rtokens->[0] =~ /=/ && ( $old_rtokens->[0] eq $rtokens->[0] ) );
1596 return unless ($is_equals);
1598 # The leading patterns must match
1599 my $old_rpatterns = $old_line->get_rpatterns();
1600 my $rpatterns = $new_line->get_rpatterns();
1601 return if ( $old_rpatterns->[0] ne $rpatterns->[0] );
1603 # Both should have side comment fields (should always be true)
1604 my $jmax_old = $old_line->get_jmax();
1605 my $jmax_new = $new_line->get_jmax();
1606 my $end_tok_old = $old_rtokens->[ $jmax_old - 1 ];
1607 my $end_tok_new = $rtokens->[ $jmax_new - 1 ];
1608 my $have_side_comments =
1609 defined($end_tok_old)
1610 && $end_tok_old eq '#'
1611 && defined($end_tok_new)
1612 && $end_tok_new eq '#';
1613 if ( !$have_side_comments ) { return; }
1615 # Do not match if any remaining tokens in new line include '?', 'if',
1616 # 'unless','||', '&&'. The reason is that (1) this isn't a great match, and
1617 # (2) we will prevent possibly better matchs to follow. Here is an
1618 # example. The match of the first two lines is rejected, and this allows
1619 # the second and third lines to match.
1620 # my $type = shift || "o";
1621 # my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
1622 # my $suffix = ( $coord_system eq 'standard' ? '' : '-orig' );
1623 # This logic can cause some unwanted losses of alignments, but it can retain
1624 # long runs of multiple-token alignments, so overall it is worthwhile.
1625 # If we had a peek at the subsequent line we could make a much better
1626 # decision here, but for now this is not available.
1627 for ( my $j = 1 ; $j < $jmax_new - 1 ; $j++ ) {
1628 my $new_tok = $rtokens->[$j];
1630 # git#16: do not consider fat commas as good aligmnents here
1631 my $is_good_alignment =
1632 ( $new_tok =~ /^(=|\?|if|unless|\|\||\&\&)/ && $new_tok !~ /^=>/ );
1633 return if ($is_good_alignment);
1636 my $squeeze_line = sub {
1637 my ($line_obj) = @_;
1639 # reduce a line down to the three fields surrounding
1640 # the two tokens, an '=' of some sort and a '#' at the end
1642 my $jmax = $line_obj->get_jmax();
1644 return unless $jmax > $jmax_new;
1645 my $rfields = $line_obj->get_rfields();
1646 my $rpatterns = $line_obj->get_rpatterns();
1647 my $rtokens = $line_obj->get_rtokens();
1649 $rfields->[0], join( '', @{$rfields}[ 1 .. $jmax - 1 ] ),
1652 my $rpatterns_new = [
1653 $rpatterns->[0], join( '', @{$rpatterns}[ 1 .. $jmax - 1 ] ),
1656 my $rtokens_new = [ $rtokens->[0], $rtokens->[ $jmax - 1 ] ];
1657 $line_obj->{_rfields} = $rfields_new;
1658 $line_obj->{_rpatterns} = $rpatterns_new;
1659 $line_obj->{_rtokens} = $rtokens_new;
1660 $line_obj->set_jmax($jmax_new);
1663 # Okay, we will force a match at the equals-like token. We will fix both
1664 # lines to have just 2 tokens and 3 fields:
1665 $squeeze_line->($new_line);
1666 $squeeze_line->($old_line);
1668 # start over with a new group
1669 initialize_for_new_group();
1670 add_to_group($old_line);
1676 my ( $new_line, $old_line ) = @_;
1677 return unless (@group_lines);
1679 my $jmax = $new_line->get_jmax();
1680 my $leading_space_count = $new_line->get_leading_space_count();
1681 my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
1682 my $rtokens = $new_line->get_rtokens();
1683 my $rfields = $new_line->get_rfields();
1684 my $rpatterns = $new_line->get_rpatterns();
1686 my $group_list_type = $group_lines[0]->get_list_type();
1688 my $padding_so_far = 0;
1689 my $padding_available = $old_line->get_available_space_on_right();
1691 # save current columns in case this doesn't work
1692 save_alignment_columns();
1694 my $maximum_field_index = $old_line->get_jmax();
1695 for my $j ( 0 .. $jmax ) {
1697 my $pad = length( $rfields->[$j] ) - $old_line->current_field_width($j);
1700 $pad += $leading_space_count;
1703 # remember largest gap of the group, excluding gap to side comment
1705 && $group_maximum_gap < -$pad
1709 $group_maximum_gap = -$pad;
1715 ## This patch helps sometimes, but it doesn't check to see if
1716 ## the line is too long even without the side comment. It needs
1718 ##don't let a long token with no trailing side comment push
1719 ##side comments out, or end a group. (sidecmt1.t)
1720 ##next if ($j==$jmax-1 && length($rfields->[$jmax])==0);
1722 # BEGIN PATCH for keith1.txt.
1723 # If the group began matching multiple tokens but later this got
1724 # reduced to a fewer number of matching tokens, then the fields
1725 # of the later lines will still have to fit into their corresponding
1726 # fields. So a large later field will "push" the other fields to
1727 # the right, including previous side comments, and if there is no room
1728 # then there is no match.
1729 # For example, look at the last line in the following snippet:
1731 # my $b_prod_db = ( $ENV{ORACLE_SID} =~ m/p$/ && !$testing ) ? true : false;
1732 # my $env = ($b_prod_db) ? "prd" : "val";
1733 # my $plant = ( $OPT{p} ) ? $OPT{p} : "STL";
1734 # my $task = $OPT{t};
1735 # my $fnam = "longggggggggggggggg.$record_created.$env.$plant.idash";
1737 # The long term will push the '?' to the right to fit in, and in this
1738 # case there is not enough room so it will not match the equals unless
1739 # we do something special.
1741 # Usually it looks good to keep an initial alignment of '=' going, and
1742 # we can do this if the long term can fit in the space taken up by the
1743 # remaining fields (the ? : fields here).
1745 # Allowing any matching token for now, but it could be restricted
1746 # to an '='-like token if necessary.
1749 $pad > $padding_available
1750 && $jmax == 2 # matching one thing (plus #)
1751 && $j == $jmax - 1 # at last field
1752 && @group_lines > 1 # more than 1 line in group now
1753 && $jmax < $maximum_field_index # other lines have more fields
1754 && length( $rfields->[$jmax] ) == 0 # no side comment
1756 # Uncomment to match only equals (but this does not seem necessary)
1757 # && $rtokens->[0] =~ /^=\d/ # matching an equals
1760 my $extra_padding = 0;
1761 foreach my $jj ( $j + 1 .. $maximum_field_index - 1 ) {
1762 $extra_padding += $old_line->current_field_width($jj);
1765 next if ( $pad <= $padding_available + $extra_padding );
1768 # END PATCH for keith1.pl
1770 # This line will need space; lets see if we want to accept it..
1773 # not if this won't fit
1774 ( $pad > $padding_available )
1776 # previously, there were upper bounds placed on padding here
1777 # (maximum_whitespace_columns), but they were not really helpful
1782 # revert to starting state then flush; things didn't work out
1783 restore_alignment_columns();
1788 # patch to avoid excessive gaps in previous lines,
1789 # due to a line of fewer fields.
1791 # $self->{"dfi"}, $self->{"aa"}, $self->rsvd, $self->{"rd"},
1792 # $self->{"area"}, $self->{"id"}, $self->{"sel"} );
1793 next if ( $jmax < $maximum_field_index && $j == $jmax - 1 );
1795 # looks ok, squeeze this field in
1796 $old_line->increase_field_width( $j, $pad );
1797 $padding_available -= $pad;
1799 # remember largest gap of the group, excluding gap to side comment
1800 if ( $pad > $group_maximum_gap && $j > 0 && $j < $jmax - 1 ) {
1801 $group_maximum_gap = $pad;
1809 # The current line either starts a new alignment group or is
1810 # accepted into the current alignment group.
1811 my ($new_line) = @_;
1812 push_group_line($new_line);
1814 # initialize field lengths if starting new group
1815 if ( @group_lines == 1 ) {
1817 my $jmax = $new_line->get_jmax();
1818 my $rfields = $new_line->get_rfields();
1819 my $rtokens = $new_line->get_rtokens();
1820 my $col = $new_line->get_leading_space_count();
1822 for my $j ( 0 .. $jmax ) {
1823 $col += length( $rfields->[$j] );
1825 # create initial alignments for the new group
1827 if ( $j < $jmax ) { $token = $rtokens->[$j] }
1828 my $alignment = make_alignment( $col, $token );
1829 $new_line->set_alignment( $j, $alignment );
1832 $maximum_jmax_seen = $jmax;
1833 $minimum_jmax_seen = $jmax;
1836 # use previous alignments otherwise
1838 my @new_alignments = $group_lines[-2]->get_alignments();
1839 $new_line->set_alignments(@new_alignments);
1842 # remember group jmax extremes for next call to valign_input
1843 $previous_minimum_jmax_seen = $minimum_jmax_seen;
1844 $previous_maximum_jmax_seen = $maximum_jmax_seen;
1850 # debug routine to dump array contents
1852 print STDOUT "(@_)\n";
1856 # flush() sends the current Perl::Tidy::VerticalAligner group down the
1857 # pipeline to Perl::Tidy::FileWriter.
1859 # This is the external flush, which also empties the buffer and cache
1862 # the buffer must be emptied first, then any cached text
1863 dump_valign_buffer();
1869 if ($cached_line_type) {
1870 $seqno_string = $cached_seqno_string;
1871 valign_output_step_C( $cached_line_text,
1872 $cached_line_leading_space_count,
1873 $last_level_written );
1874 $cached_line_type = 0;
1875 $cached_line_text = "";
1876 $cached_seqno_string = "";
1882 sub reduce_valign_buffer_indentation {
1885 if ( $valign_buffer_filling && $diff ) {
1886 my $max_valign_buffer = @valign_buffer;
1887 foreach my $i ( 0 .. $max_valign_buffer - 1 ) {
1888 my ( $line, $leading_space_count, $level ) =
1889 @{ $valign_buffer[$i] };
1890 my $ws = substr( $line, 0, $diff );
1891 if ( ( length($ws) == $diff ) && $ws =~ /^\s+$/ ) {
1892 $line = substr( $line, $diff );
1894 if ( $leading_space_count >= $diff ) {
1895 $leading_space_count -= $diff;
1896 $level = level_change( $leading_space_count, $diff, $level );
1898 $valign_buffer[$i] = [ $line, $leading_space_count, $level ];
1906 # compute decrease in level when we remove $diff spaces from the
1908 my ( $leading_space_count, $diff, $level ) = @_;
1909 if ($rOpts_indent_columns) {
1911 int( ( $leading_space_count + $diff ) / $rOpts_indent_columns );
1912 my $nlev = int( $leading_space_count / $rOpts_indent_columns );
1913 $level -= ( $olev - $nlev );
1914 if ( $level < 0 ) { $level = 0 }
1919 sub dump_valign_buffer {
1920 if (@valign_buffer) {
1921 foreach (@valign_buffer) {
1922 valign_output_step_D( @{$_} );
1924 @valign_buffer = ();
1926 $valign_buffer_filling = "";
1930 sub my_flush_comment {
1932 # Output a group of COMMENT lines
1934 return unless (@group_lines);
1935 my $leading_space_count = $comment_leading_space_count;
1936 my $leading_string = get_leading_string($leading_space_count);
1938 # look for excessively long lines
1940 foreach my $str (@group_lines) {
1943 $leading_space_count -
1944 maximum_line_length_for_level($group_level);
1945 if ( $excess > $max_excess ) {
1946 $max_excess = $excess;
1950 # zero leading space count if any lines are too long
1951 if ( $max_excess > 0 ) {
1952 $leading_space_count -= $max_excess;
1953 if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
1954 $last_outdented_line_at = $file_writer_object->get_output_line_number();
1955 unless ($outdented_line_count) {
1956 $first_outdented_line_at = $last_outdented_line_at;
1958 my $nlines = @group_lines;
1959 $outdented_line_count += $nlines;
1963 my $outdent_long_lines = 0;
1964 foreach my $line (@group_lines) {
1965 valign_output_step_B( $leading_space_count, $line, 0,
1966 $outdent_long_lines, "", $group_level );
1969 initialize_for_new_group();
1975 # Output a group of CODE lines
1977 return unless (@group_lines);
1979 VALIGN_DEBUG_FLAG_APPEND0
1981 my $group_list_type = $group_lines[0]->get_list_type();
1982 my ( $a, $b, $c ) = caller();
1983 my $nlines = @group_lines;
1984 my $maximum_field_index = $group_lines[0]->get_jmax();
1985 my $rfields_old = $group_lines[0]->get_rfields();
1986 my $tok = $rfields_old->[0];
1988 "APPEND0: my_flush_code called from $a $b $c fields=$maximum_field_index list=$group_list_type lines=$nlines extra=$extra_indent_ok first tok=$tok;\n";
1992 # some small groups are best left unaligned
1993 my $do_not_align = decide_if_aligned_pair();
1995 # optimize side comment location
1996 $do_not_align = adjust_side_comment($do_not_align);
1998 # recover spaces for -lp option if possible
1999 my $extra_leading_spaces = get_extra_leading_spaces();
2001 # all lines of this group have the same basic leading spacing
2002 my $group_leader_length = $group_lines[0]->get_leading_space_count();
2004 # add extra leading spaces if helpful
2005 # NOTE: Use zero; this did not work well
2009 foreach my $line (@group_lines) {
2010 valign_output_step_A( $line, $min_ci_gap, $do_not_align,
2011 $group_leader_length, $extra_leading_spaces );
2014 initialize_for_new_group();
2020 # This is the vertical aligner internal flush, which leaves the cache
2022 return unless (@group_lines);
2024 VALIGN_DEBUG_FLAG_APPEND0 && do {
2025 my ( $a, $b, $c ) = caller();
2026 my $nlines = @group_lines;
2028 "APPEND0: my_flush called from $a $b $c lines=$nlines, type=$group_type \n";
2031 # handle a group of COMMENT lines
2032 if ( $group_type eq 'COMMENT' ) { my_flush_comment() }
2034 # handle a single line of CODE
2035 elsif ( @group_lines == 1 ) { my_flush_code() }
2037 # handle group(s) of CODE lines
2041 # If we are trying to add extra indentation for -lp formatting,
2042 # then we need to try to keep the group intact. But we have
2043 # to set the $extra_indent_ok flag to zero in case some lines
2044 # are output separately. We fix things up at the bottom.
2045 # NOTE: this is a workaround but is tentative; we should really look to
2046 # see if if extra indentation is possible.
2047 my $rOpt_lp = $rOpts->{'line-up-parentheses'};
2048 my $keep_group_intact = $rOpt_lp && $extra_indent_ok;
2049 my $extra_indent_ok_save = $extra_indent_ok;
2050 $extra_indent_ok = 0;
2052 # we will rebuild alignment line group(s);
2053 my @new_lines = @group_lines;
2054 initialize_for_new_group();
2056 # remove unmatched tokens in all lines
2057 delete_unmatched_tokens( \@new_lines );
2059 foreach my $new_line (@new_lines) {
2061 # Start a new group if necessary
2062 if ( !@group_lines ) {
2063 add_to_group($new_line);
2068 my $j_terminal_match = $new_line->get_j_terminal_match();
2069 my $base_line = $group_lines[0];
2071 # Initialize a global flag saying if the last line of the group
2072 # should match end of group and also terminate the group. There
2073 # should be no returns between here and where the flag is handled
2075 my $col_matching_terminal = 0;
2076 if ( defined($j_terminal_match) ) {
2078 # remember the column of the terminal ? or { to match with
2079 $col_matching_terminal =
2080 $base_line->get_column($j_terminal_match);
2082 # set global flag for sub decide_if_aligned_pair
2083 $is_matching_terminal_line = 1;
2086 # -------------------------------------------------------------
2087 # Allow hanging side comment to join current group, if any. This
2088 # will help keep side comments aligned, because otherwise we
2089 # will have to start a new group, making alignment less likely.
2090 # -------------------------------------------------------------
2092 if ( $new_line->get_is_hanging_side_comment() ) {
2093 join_hanging_comment( $new_line, $base_line );
2096 # If this line has no matching tokens, then flush out the lines
2097 # BEFORE this line unless both it and the previous line have side
2098 # comments. This prevents this line from pushing side coments out
2100 elsif ( $new_line->get_jmax() == 1 && !$keep_group_intact ) {
2102 # There are no matching tokens, so now check side comments.
2103 # Programming note: accessing arrays with index -1 is
2104 # risky in Perl, but we have verified there is at least one
2105 # line in the group and that there is at least one field.
2106 my $prev_comment = $group_lines[-1]->get_rfields()->[-1];
2107 my $side_comment = $new_line->get_rfields()->[-1];
2108 my_flush_code() unless ( $side_comment && $prev_comment );
2112 # -------------------------------------------------------------
2113 # If there is just one previous line, and it has more fields
2114 # than the new line, try to join fields together to get a match
2115 # with the new line. At the present time, only a single
2116 # leading '=' is allowed to be compressed out. This is useful
2117 # in rare cases where a table is forced to use old breakpoints
2118 # because of side comments,
2119 # and the table starts out something like this:
2120 # my %MonthChars = ('0', 'Jan', # side comment
2123 # Eliminating the '=' field will allow the remaining fields to
2124 # line up. This situation does not occur if there are no side
2125 # comments because scan_list would put a break after the
2127 # -------------------------------------------------------------
2129 eliminate_old_fields( $new_line, $base_line );
2131 # -------------------------------------------------------------
2132 # If the new line has more fields than the current group,
2133 # see if we can match the first fields and combine the remaining
2134 # fields of the new line.
2135 # -------------------------------------------------------------
2137 eliminate_new_fields( $new_line, $base_line );
2139 # -------------------------------------------------------------
2140 # Flush previous group unless all common tokens and patterns
2143 check_match( $new_line, $base_line );
2145 # -------------------------------------------------------------
2146 # See if there is space for this line in the current group (if
2148 # -------------------------------------------------------------
2150 check_fit( $new_line, $base_line );
2153 add_to_group($new_line);
2155 if ( defined($j_terminal_match) ) {
2157 # if there is only one line in the group (maybe due to failure
2158 # to match perfectly with previous lines), then align the ? or
2159 # { of this terminal line with the previous one unless that
2160 # would make the line too long
2161 if ( @group_lines == 1 ) {
2162 $base_line = $group_lines[0];
2163 my $col_now = $base_line->get_column($j_terminal_match);
2164 my $pad = $col_matching_terminal - $col_now;
2165 my $padding_available =
2166 $base_line->get_available_space_on_right();
2167 if ( $pad > 0 && $pad <= $padding_available ) {
2168 $base_line->increase_field_width( $j_terminal_match,
2173 $is_matching_terminal_line = 0;
2176 # Optional optimization; end the group if we know we cannot match
2178 elsif ( $new_line->{_end_group} ) {
2184 # if we managed to keep the group intact for -lp formatting,
2185 # restore the flag which allows extra indentation
2186 if ( $keep_group_intact && @group_lines == @new_lines ) {
2187 $extra_indent_ok = $extra_indent_ok_save;
2194 sub delete_selected_tokens {
2196 my ( $line_obj, $ridel ) = @_;
2198 # remove an unused alignment token(s) to improve alignment chances
2199 return unless ( defined($line_obj) && defined($ridel) && @{$ridel} );
2201 my $jmax_old = $line_obj->get_jmax();
2202 my $rfields_old = $line_obj->get_rfields();
2203 my $rpatterns_old = $line_obj->get_rpatterns();
2204 my $rtokens_old = $line_obj->get_rtokens();
2208 delete indexes: <@{$ridel}>
2210 old tokens: <@{$rtokens_old}>
2211 old patterns: <@{$rpatterns_old}>
2212 old fields: <@{$rfields_old}>
2215 my $rfields_new = [];
2216 my $rpatterns_new = [];
2217 my $rtokens_new = [];
2219 my $kmax = @{$ridel} - 1;
2221 my $jdel_next = $ridel->[$k];
2224 if ( $jdel_next < 0 ) { print STDERR "bad jdel_next=$jdel_next\n"; return }
2225 my $pattern = $rpatterns_old->[0];
2226 my $field = $rfields_old->[0];
2227 push @{$rfields_new}, $field;
2228 push @{$rpatterns_new}, $pattern;
2229 for ( my $j = 0 ; $j < $jmax_old ; $j++ ) {
2230 my $token = $rtokens_old->[$j];
2231 my $field = $rfields_old->[ $j + 1 ];
2232 my $pattern = $rpatterns_old->[ $j + 1 ];
2233 if ( $k > $kmax || $j < $jdel_next ) {
2234 push @{$rtokens_new}, $token;
2235 push @{$rfields_new}, $field;
2236 push @{$rpatterns_new}, $pattern;
2238 elsif ( $j == $jdel_next ) {
2239 $rfields_new->[-1] .= $field;
2240 $rpatterns_new->[-1] .= $pattern;
2241 if ( ++$k <= $kmax ) {
2242 my $jdel_last = $jdel_next;
2243 $jdel_next = $ridel->[$k];
2244 if ( $jdel_next < $jdel_last ) {
2247 print STDERR "bad jdel_next=$jdel_next\n";
2254 # ----- x ------ x ------ x ------
2255 #t 0 1 2 <- token indexing
2256 #f 0 1 2 3 <- field and pattern
2258 my $jmax_new = @{$rfields_new} - 1;
2259 $line_obj->set_rtokens($rtokens_new);
2260 $line_obj->set_rpatterns($rpatterns_new);
2261 $line_obj->set_rfields($rfields_new);
2262 $line_obj->set_jmax($jmax_new);
2267 new tokens: <@{$rtokens_new}>
2268 new patterns: <@{$rpatterns_new}>
2269 new fields: <@{$rfields_new}>
2274 sub decode_alignment_token {
2276 # Unpack the values packed in an alignment token
2279 # my ( $raw_tok, $lev, $tag, $tok_count ) =
2280 # decode_alignment_token($token);
2282 # Alignment tokens have a trailing decimal level and optional tag (for
2284 # For example, the first comma in the following line
2285 # sub banner { crlf; report( shift, '/', shift ); crlf }
2286 # is decorated as follows:
2287 # ,2+report-6 => (tok,lev,tag) =qw( , 2 +report-6)
2289 # An optional token count may be appended with a leading dot.
2290 # Currently this is only done for '=' tokens but this could change.
2291 # For example, consider the following line:
2292 # $nport = $port = shift || $name;
2293 # The first '=' may either be '=0' or '=0.1' [level 0, first equals]
2294 # The second '=' will be '=0.2' [level 0, second equals]
2296 my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, "", 1 );
2297 if ( $tok =~ /^(\D+)(\d+)([^\.]*)(\.(\d+))?$/ ) {
2301 $tok_count = $5 if ($5);
2303 return ( $raw_tok, $lev, $tag, $tok_count );
2306 { # sub is_deletable_token
2308 my %is_deletable_equals;
2313 # These tokens with = may be deleted for vertical aligmnemt
2317 @is_deletable_equals{@q} = (1) x scalar(@q);
2321 sub is_deletable_token {
2323 # Determine if a token with no match possibility can be removed to
2324 # improve chances of making an alignment.
2325 my ( $token, $i, $imax, $jline, $i_eq ) = @_;
2327 my ( $raw_tok, $lev, $tag, $tok_count ) =
2328 decode_alignment_token($token);
2330 # okay to delete second and higher copies of a token
2331 if ( $tok_count > 1 ) { return 1 }
2333 # only remove lower level commas
2334 if ( $raw_tok eq ',' ) {
2336 return if ( defined($i_eq) && $i < $i_eq );
2337 return if ( $lev <= $group_level );
2340 # most operators with an equals sign should be retained if at
2341 # same level as this statement
2342 elsif ( $raw_tok =~ /=/ ) {
2344 unless ( $lev > $group_level || $is_deletable_equals{$raw_tok} );
2347 # otherwise, ok to delete the token
2352 sub delete_unmatched_tokens {
2355 # This is a preliminary step in vertical alignment in which we remove as
2356 # many obviously un-needed alignment tokens as possible. This will prevent
2357 # them from interfering with the final alignment.
2359 return unless @{$rlines};
2360 my $has_terminal_match = $rlines->[-1]->get_j_terminal_match();
2362 # ignore hanging side comments in these operations
2363 my @filtered = grep { !$_->{_is_hanging_side_comment} } @{$rlines};
2364 my $rnew_lines = \@filtered;
2368 my $jmax = @{$rnew_lines} - 1;
2372 # create a hash of tokens for each line
2373 my $rline_hashes = [];
2374 foreach my $line ( @{$rnew_lines} ) {
2376 my $rtokens = $line->get_rtokens();
2380 foreach my $tok ( @{$rtokens} ) {
2381 my ( $raw_tok, $lev, $tag, $tok_count ) =
2382 decode_alignment_token($tok);
2383 if ( !defined($lev_min) || $lev < $lev_min ) { $lev_min = $lev }
2385 # Possible future upgrade: for multiple matches,
2386 # record [$i1, $i2, ..] instead of $i
2388 [ $i, undef, undef, $raw_tok, $lev, $tag, $tok_count ];
2390 # remember the first equals at line level
2391 if ( !defined($i_eq) && $raw_tok eq '=' ) {
2392 if ( $lev eq $group_level ) { $i_eq = $i }
2396 push @{$rline_hashes}, $rhash;
2397 push @i_equals, $i_eq;
2398 push @min_levels, $lev_min;
2401 # compare each line pair and record matches
2404 for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
2408 my $rhash_l = $rline_hashes->[$jl];
2409 my $rhash_r = $rline_hashes->[$jr];
2410 my $count = 0; # UNUSED NOW?
2412 foreach my $tok ( keys %{$rhash_l} ) {
2414 if ( defined( $rhash_r->{$tok} ) ) {
2415 if ( $tok ne '#' ) { $count++; }
2416 my $il = $rhash_l->{$tok}->[0];
2417 my $ir = $rhash_r->{$tok}->[0];
2418 $rhash_l->{$tok}->[2] = $ir;
2419 $rhash_r->{$tok}->[1] = $il;
2420 if ( $tok ne '#' ) {
2421 push @{ $rtok_hash->{$tok} }, ( $jl, $jr );
2427 # Set a line break if no matching tokens between these lines
2428 if ( $nr == 0 && $nl > 0 ) {
2429 $rnew_lines->[$jl]->{_end_group} = 1;
2435 push @subgroups, [ 0, $jmax ];
2436 for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
2437 if ( $rnew_lines->[$jl]->{_end_group} ) {
2438 $subgroups[-1]->[1] = $jl;
2439 push @subgroups, [ $jl + 1, $jmax ];
2443 # Loop to process each subgroups
2444 foreach my $item (@subgroups) {
2445 my ( $jbeg, $jend ) = @{$item};
2447 # look for complete ternary or if/elsif/else blocks
2448 my $nlines = $jend - $jbeg + 1;
2449 my %token_line_count;
2450 for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
2452 my $line = $rnew_lines->[$jj];
2453 my $rtokens = $line->get_rtokens();
2454 foreach my $tok ( @{$rtokens} ) {
2455 if ( !$seen{$tok} ) {
2457 $token_line_count{$tok}++;
2462 # Look for if/else/elsif and ternary blocks
2464 foreach my $tok ( keys %token_line_count ) {
2465 if ( $token_line_count{$tok} == $nlines ) {
2466 if ( $tok =~ /^\?/ || $tok =~ /^\{\d+if/ ) {
2472 # remove unwanted alignment tokens
2473 for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
2474 my $line = $rnew_lines->[$jj];
2475 my $rtokens = $line->get_rtokens();
2476 my $rhash = $rline_hashes->[$jj];
2478 my $i_eq = $i_equals[$jj];
2480 my $imax = @{$rtokens} - 2;
2481 my $delete_above_level;
2483 for ( my $i = 0 ; $i <= $imax ; $i++ ) {
2484 my $tok = $rtokens->[$i];
2485 next if ( $tok eq '#' ); # shouldn't happen
2486 my ( $iii, $il, $ir, $raw_tok, $lev, $tag, $tok_count ) =
2487 @{ $rhash->{$tok} };
2489 # always remove unmatched tokens
2490 my $delete_me = !defined($il) && !defined($ir);
2492 # also, if this is a complete ternary or if/elsif/else block,
2493 # remove all alignments which are not also in every line
2495 ( $is_full_block && $token_line_count{$tok} < $nlines );
2497 # Remove all tokens above a certain level following a previous
2498 # deletion. For example, we have to remove tagged higher level
2499 # alignment tokens following a => deletion because the tags of
2500 # higher level tokens will now be incorrect. For example, this
2501 # will prevent aligning commas as follows after deleting the
2504 # ListBox => origin => [ 270, 160 ],
2505 # size => [ 200, 55 ],
2507 if ( defined($delete_above_level) ) {
2508 if ( $lev > $delete_above_level ) {
2509 $delete_me ||= 1; #$tag;
2511 else { $delete_above_level = undef }
2516 && is_deletable_token( $tok, $i, $imax, $jj, $i_eq )
2518 # Patch: do not touch the first line of a terminal match,
2519 # such as below, because j_terminal has already been set.
2520 # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
2521 # else { $tago = $tagc = ''; }
2522 # But see snippets 'else1.t' and 'else2.t'
2523 && !( $jj == $jbeg && $has_terminal_match && $nlines == 2 )
2528 if ( !defined($delete_above_level)
2529 || $lev < $delete_above_level )
2532 # delete all following higher level alignments
2533 $delete_above_level = $lev;
2535 # but keep deleting after => to next lower level
2536 # to avoid some bizarre alignments
2537 if ( $raw_tok eq '=>' ) {
2538 $delete_above_level = $lev - 1;
2544 if (@idel) { delete_selected_tokens( $line, \@idel ) }
2546 } # End loop over subgroups
2551 { # decide_if_aligned_pair
2561 @is_if_or{@q} = (1) x scalar(@q);
2564 = **= += *= &= <<= &&=
2565 -= /= |= >>= ||= //=
2569 @is_assignment{@q} = (1) x scalar(@q);
2572 sub decide_if_aligned_pair {
2574 # Do not try to align two lines which are not really similar
2575 return unless ( @group_lines == 2 );
2576 return if ($is_matching_terminal_line);
2578 # always align lists
2579 my $group_list_type = $group_lines[0]->get_list_type();
2580 return 0 if ($group_list_type);
2582 my $jmax0 = $group_lines[0]->get_jmax();
2583 my $jmax1 = $group_lines[1]->get_jmax();
2584 my $rtokens = $group_lines[0]->get_rtokens();
2585 my $leading_equals = ( $rtokens->[0] =~ /=/ );
2587 # scan the tokens on the second line
2588 my $rtokens1 = $group_lines[1]->get_rtokens();
2589 my $saw_if_or; # if we saw an 'if' or 'or' at group level
2590 my $raw_tokb = ""; # first token seen at group level
2591 for ( my $j = 0 ; $j < $jmax1 - 1 ; $j++ ) {
2592 my ( $raw_tok, $lev, $tag, $tok_count ) =
2593 decode_alignment_token( $rtokens1->[$j] );
2594 if ( $raw_tok && $lev == $group_level ) {
2595 if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
2596 $saw_if_or ||= $is_if_or{$raw_tok};
2600 # A marginal match is a match which has different patterns. Normally,
2601 # we should not allow exactly two lines to match if marginal. But
2602 # we can allow matching in some specific cases.
2603 my $is_marginal = $marginal_match;
2605 # lines with differing number of alignment tokens are marginal
2607 $previous_maximum_jmax_seen != $previous_minimum_jmax_seen
2608 && !$is_assignment{$raw_tokb};
2610 # We will use the line endings to help decide on alignments...
2611 # See if the lines end with semicolons...
2612 my $rpatterns0 = $group_lines[0]->get_rpatterns();
2613 my $rpatterns1 = $group_lines[1]->get_rpatterns();
2616 if ( $jmax0 < 1 || $jmax1 < 1 ) {
2621 my $pat0 = $rpatterns0->[ $jmax0 - 1 ];
2622 my $pat1 = $rpatterns1->[ $jmax1 - 1 ];
2623 $sc_term0 = $pat0 =~ /;b?$/;
2624 $sc_term1 = $pat1 =~ /;b?$/;
2627 if ( !$is_marginal && !$sc_term0 ) {
2629 # First line of assignment should be semicolon terminated.
2630 # For example, do not align here:
2631 # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
2632 # $$href{-NUM_DIRS} = 0;
2633 if ( $is_assignment{$raw_tokb} ) {
2638 # Try to avoid some undesirable alignments of opening tokens
2639 # for example, the space between grep and { here:
2640 # return map { ( $_ => $_ ) }
2641 # grep { /$handles/ } $self->_get_delegate_method_list;
2643 ( $raw_tokb eq '(' || $raw_tokb eq '{' )
2645 && $sc_term0 ne $sc_term1;
2647 # Undo the marginal match flag in certain cases,
2650 # Two lines with a leading equals-like operator are allowed to
2651 # align if the patterns to the left of the equals are the same.
2652 # For example the following two lines are a marginal match but have
2653 # the same left side patterns, so we will align the equals.
2654 # my $orig = my $format = "^<<<<< ~~\n";
2656 # But these have a different left pattern so they will not be
2659 # $self->{'leftovers'} .= "<bx-seq:seq" . $';
2661 # First line semicolon terminated but second not, usually ok:
2662 # my $want = "'ab', 'a', 'b'";
2663 # my $got = join( ", ",
2664 # map { defined($_) ? "'$_'" : "undef" }
2666 # First line not semicolon terminated, Not OK to match:
2667 # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
2668 # $$href{-NUM_DIRS} = 0;
2669 my $pat0 = $rpatterns0->[0];
2670 my $pat1 = $rpatterns1->[0];
2672 ##########################################################
2673 # Turn off the marginal flag for some types of assignments
2674 ##########################################################
2675 if ( $is_assignment{$raw_tokb} ) {
2677 # undo marginal flag if first line is semicolon terminated
2678 # and leading patters match
2679 if ($sc_term0) { # && $sc_term1) {
2680 $is_marginal = $pat0 ne $pat1;
2683 elsif ( $raw_tokb eq '=>' ) {
2685 # undo marginal flag if patterns match
2686 $is_marginal = $pat0 ne $pat1;
2688 elsif ( $raw_tokb eq '=~' ) {
2690 # undo marginal flag if both lines are semicolon terminated
2691 # and leading patters match
2692 if ( $sc_term1 && $sc_term0 ) {
2693 $is_marginal = $pat0 ne $pat1;
2697 ######################################################
2698 # Turn off the marginal flag if we saw an 'if' or 'or'
2699 ######################################################
2701 # A trailing 'if' and 'or' often gives a good alignment
2702 # For example, we can align these:
2703 # return -1 if $_[0] =~ m/^CHAPT|APPENDIX/;
2704 # return $1 + 0 if $_[0] =~ m/^SECT(\d*)$/;
2707 # $d_in_m[2] = 29 if ( &Date_LeapYear($y) );
2708 # $d = $d_in_m[$m] if ( $d > $d_in_m[$m] );
2712 # undo marginal flag if both lines are semicolon terminated
2713 if ( $sc_term0 && $sc_term1 ) {
2719 ###############################
2720 # Set the return flag:
2721 # Don't align if still marginal
2722 ###############################
2723 my $do_not_align = $is_marginal;
2725 # But try to convert them into a simple comment group if the first line
2726 # a has side comment
2727 my $rfields = $group_lines[0]->get_rfields();
2728 my $maximum_field_index = $group_lines[0]->get_jmax();
2730 && ( length( $rfields->[$maximum_field_index] ) > 0 ) )
2735 return $do_not_align;
2739 sub adjust_side_comment {
2741 my $do_not_align = shift;
2743 # let's see if we can move the side comment field out a little
2744 # to improve readability (the last field is always a side comment field)
2745 my $have_side_comment = 0;
2746 my $first_side_comment_line = -1;
2747 my $maximum_field_index = $group_lines[0]->get_jmax();
2749 foreach my $line (@group_lines) {
2750 if ( length( $line->get_rfields()->[$maximum_field_index] ) ) {
2751 $have_side_comment = 1;
2752 $first_side_comment_line = $i;
2758 my $kmax = $maximum_field_index + 1;
2760 if ($have_side_comment) {
2762 my $line = $group_lines[0];
2764 # the maximum space without exceeding the line length:
2765 my $avail = $line->get_available_space_on_right();
2767 # try to use the previous comment column
2768 my $side_comment_column = $line->get_column( $kmax - 2 );
2769 my $move = $last_comment_column - $side_comment_column;
2771 ## my $sc_line0 = $side_comment_history[0]->[0];
2772 ## my $sc_col0 = $side_comment_history[0]->[1];
2773 ## my $sc_line1 = $side_comment_history[1]->[0];
2774 ## my $sc_col1 = $side_comment_history[1]->[1];
2775 ## my $sc_line2 = $side_comment_history[2]->[0];
2776 ## my $sc_col2 = $side_comment_history[2]->[1];
2778 ## # FUTURE UPDATES:
2779 ## # Be sure to ignore 'do not align' and '} # end comments'
2780 ## # Find first $move > 0 and $move <= $avail as follows:
2781 ## # 1. try sc_col1 if sc_col1 == sc_col0 && (line-sc_line0) < 12
2782 ## # 2. try sc_col2 if (line-sc_line2) < 12
2783 ## # 3. try min possible space, plus up to 8,
2784 ## # 4. try min possible space
2786 if ( $kmax > 0 && !$do_not_align ) {
2788 # but if this doesn't work, give up and use the minimum space
2789 if ( $move > $avail ) {
2790 $move = $rOpts_minimum_space_to_comment - 1;
2793 # but we want some minimum space to the comment
2794 my $min_move = $rOpts_minimum_space_to_comment - 1;
2796 && $last_side_comment_length > 0
2797 && ( $first_side_comment_line == 0 )
2798 && $group_level == $last_level_written )
2803 if ( $move < $min_move ) {
2807 # previously, an upper bound was placed on $move here,
2808 # (maximum_space_to_comment), but it was not helpful
2810 # don't exceed the available space
2811 if ( $move > $avail ) { $move = $avail }
2813 # we can only increase space, never decrease
2815 $line->increase_field_width( $maximum_field_index - 1, $move );
2818 # remember this column for the next group
2819 $last_comment_column = $line->get_column( $kmax - 2 );
2823 # try to at least line up the existing side comment location
2824 if ( $kmax > 0 && $move > 0 && $move < $avail ) {
2825 $line->increase_field_width( $maximum_field_index - 1, $move );
2829 # reset side comment column if we can't align
2831 forget_side_comment();
2835 return $do_not_align;
2838 sub valign_output_step_A {
2840 ###############################################################
2841 # This is Step A in writing vertically aligned lines.
2842 # The line is prepared according to the alignments which have
2843 # been found. Then it is shipped to the next step.
2844 ###############################################################
2846 my ( $line, $min_ci_gap, $do_not_align, $group_leader_length,
2847 $extra_leading_spaces )
2849 my $rfields = $line->get_rfields();
2850 my $leading_space_count = $line->get_leading_space_count();
2851 my $outdent_long_lines = $line->get_outdent_long_lines();
2852 my $maximum_field_index = $line->get_jmax();
2853 my $rvertical_tightness_flags = $line->get_rvertical_tightness_flags();
2855 # add any extra spaces
2856 if ( $leading_space_count > $group_leader_length ) {
2857 $leading_space_count += $min_ci_gap;
2860 my $str = $rfields->[0];
2862 # loop to concatenate all fields of this line and needed padding
2863 my $total_pad_count = 0;
2864 for my $j ( 1 .. $maximum_field_index ) {
2866 # skip zero-length side comments
2869 ( $j == $maximum_field_index )
2870 && ( !defined( $rfields->[$j] )
2871 || ( length( $rfields->[$j] ) == 0 ) )
2874 # compute spaces of padding before this field
2875 my $col = $line->get_column( $j - 1 );
2876 my $pad = $col - ( length($str) + $leading_space_count );
2878 if ($do_not_align) {
2880 ( $j < $maximum_field_index )
2882 : $rOpts_minimum_space_to_comment - 1;
2885 # if the -fpsc flag is set, move the side comment to the selected
2886 # column if and only if it is possible, ignoring constraints on
2887 # line length and minimum space to comment
2888 if ( $rOpts_fixed_position_side_comment && $j == $maximum_field_index )
2890 my $newpad = $pad + $rOpts_fixed_position_side_comment - $col - 1;
2891 if ( $newpad >= 0 ) { $pad = $newpad; }
2894 # accumulate the padding
2895 if ( $pad > 0 ) { $total_pad_count += $pad; }
2898 if ( !defined $rfields->[$j] ) {
2899 write_diagnostics("UNDEFined field at j=$j\n");
2902 # only add padding when we have a finite field;
2903 # this avoids extra terminal spaces if we have empty fields
2904 if ( length( $rfields->[$j] ) > 0 ) {
2905 $str .= ' ' x $total_pad_count;
2906 $total_pad_count = 0;
2907 $str .= $rfields->[$j];
2910 $total_pad_count = 0;
2913 # update side comment history buffer
2914 if ( $j == $maximum_field_index ) {
2915 my $lineno = $file_writer_object->get_output_line_number();
2916 shift @side_comment_history;
2917 push @side_comment_history, [ $lineno, $col ];
2921 my $side_comment_length = ( length( $rfields->[$maximum_field_index] ) );
2923 # ship this line off
2924 valign_output_step_B( $leading_space_count + $extra_leading_spaces,
2925 $str, $side_comment_length, $outdent_long_lines,
2926 $rvertical_tightness_flags, $group_level );
2930 sub get_extra_leading_spaces {
2932 #----------------------------------------------------------
2933 # Define any extra indentation space (for the -lp option).
2935 # If a list has side comments, sub scan_list must dump the
2936 # list before it sees everything. When this happens, it sets
2937 # the indentation to the standard scheme, but notes how
2938 # many spaces it would have liked to use. We may be able
2939 # to recover that space here in the event that all of the
2940 # lines of a list are back together again.
2941 #----------------------------------------------------------
2943 my $extra_leading_spaces = 0;
2944 if ($extra_indent_ok) {
2945 my $object = $group_lines[0]->get_indentation();
2946 if ( ref($object) ) {
2947 my $extra_indentation_spaces_wanted =
2948 get_recoverable_spaces($object);
2950 # all indentation objects must be the same
2951 for my $i ( 1 .. @group_lines - 1 ) {
2952 if ( $object != $group_lines[$i]->get_indentation() ) {
2953 $extra_indentation_spaces_wanted = 0;
2958 if ($extra_indentation_spaces_wanted) {
2960 # the maximum space without exceeding the line length:
2961 my $avail = $group_lines[0]->get_available_space_on_right();
2962 $extra_leading_spaces =
2963 ( $avail > $extra_indentation_spaces_wanted )
2964 ? $extra_indentation_spaces_wanted
2967 # update the indentation object because with -icp the terminal
2968 # ');' will use the same adjustment.
2969 $object->permanently_decrease_available_spaces(
2970 -$extra_leading_spaces );
2974 return $extra_leading_spaces;
2977 sub combine_fields {
2979 # combine all fields except for the comment field ( sidecmt.t )
2980 # Uses global variables:
2982 my $maximum_field_index = $group_lines[0]->get_jmax();
2983 foreach my $line (@group_lines) {
2984 my $rfields = $line->get_rfields();
2985 foreach ( 1 .. $maximum_field_index - 1 ) {
2986 $rfields->[0] .= $rfields->[$_];
2988 $rfields->[1] = $rfields->[$maximum_field_index];
2991 $line->set_column( 0, 0 );
2992 $line->set_column( 1, 0 );
2995 $maximum_field_index = 1;
2997 foreach my $line (@group_lines) {
2998 my $rfields = $line->get_rfields();
2999 for my $k ( 0 .. $maximum_field_index ) {
3000 my $pad = length( $rfields->[$k] ) - $line->current_field_width($k);
3002 $pad += $line->get_leading_space_count();
3005 if ( $pad > 0 ) { $line->increase_field_width( $k, $pad ) }
3012 sub get_output_line_number {
3014 # the output line number reported to a caller is the number of items
3015 # written plus the number of items in the buffer
3017 my $nlines = @group_lines;
3018 return $nlines + $file_writer_object->get_output_line_number();
3021 sub valign_output_step_B {
3023 ###############################################################
3024 # This is Step B in writing vertically aligned lines.
3025 # Vertical tightness is applied according to preset flags.
3026 # In particular this routine handles stacking of opening
3027 # and closing tokens.
3028 ###############################################################
3030 my ( $leading_space_count, $str, $side_comment_length, $outdent_long_lines,
3031 $rvertical_tightness_flags, $level )
3034 # handle outdenting of long lines:
3035 if ($outdent_long_lines) {
3038 $side_comment_length +
3039 $leading_space_count -
3040 maximum_line_length_for_level($level);
3041 if ( $excess > 0 ) {
3042 $leading_space_count = 0;
3043 $last_outdented_line_at =
3044 $file_writer_object->get_output_line_number();
3046 unless ($outdented_line_count) {
3047 $first_outdented_line_at = $last_outdented_line_at;
3049 $outdented_line_count++;
3053 # Make preliminary leading whitespace. It could get changed
3054 # later by entabbing, so we have to keep track of any changes
3055 # to the leading_space_count from here on.
3056 my $leading_string =
3057 $leading_space_count > 0 ? ( ' ' x $leading_space_count ) : "";
3059 # Unpack any recombination data; it was packed by
3060 # sub send_lines_to_vertical_aligner. Contents:
3062 # [0] type: 1=opening non-block 2=closing non-block
3063 # 3=opening block brace 4=closing block brace
3064 # [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
3065 # if closing: spaces of padding to use
3066 # [2] sequence number of container
3067 # [3] valid flag: do not append if this flag is false
3069 my ( $open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
3071 if ($rvertical_tightness_flags) {
3073 $open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
3075 ) = @{$rvertical_tightness_flags};
3078 $seqno_string = $seqno_end;
3080 # handle any cached line ..
3081 # either append this line to it or write it out
3082 if ( length($cached_line_text) ) {
3084 # Dump an invalid cached line
3085 if ( !$cached_line_valid ) {
3086 valign_output_step_C( $cached_line_text,
3087 $cached_line_leading_space_count,
3088 $last_level_written );
3091 # Handle cached line ending in OPENING tokens
3092 elsif ( $cached_line_type == 1 || $cached_line_type == 3 ) {
3094 my $gap = $leading_space_count - length($cached_line_text);
3096 # handle option of just one tight opening per line:
3097 if ( $cached_line_flag == 1 ) {
3098 if ( defined($open_or_close) && $open_or_close == 1 ) {
3103 if ( $gap >= 0 && defined($seqno_beg) ) {
3104 $leading_string = $cached_line_text . ' ' x $gap;
3105 $leading_space_count = $cached_line_leading_space_count;
3106 $seqno_string = $cached_seqno_string . ':' . $seqno_beg;
3107 $level = $last_level_written;
3110 valign_output_step_C( $cached_line_text,
3111 $cached_line_leading_space_count,
3112 $last_level_written );
3116 # Handle cached line ending in CLOSING tokens
3118 my $test_line = $cached_line_text . ' ' x $cached_line_flag . $str;
3121 # The new line must start with container
3124 # The container combination must be okay..
3127 # okay to combine like types
3128 ( $open_or_close == $cached_line_type )
3130 # closing block brace may append to non-block
3131 || ( $cached_line_type == 2 && $open_or_close == 4 )
3133 # something like ');'
3134 || ( !$open_or_close && $cached_line_type == 2 )
3138 # The combined line must fit
3140 length($test_line) <=
3141 maximum_line_length_for_level($last_level_written) )
3145 $seqno_string = $cached_seqno_string . ':' . $seqno_beg;
3147 # Patch to outdent closing tokens ending # in ');'
3148 # If we are joining a line like ');' to a previous stacked
3149 # set of closing tokens, then decide if we may outdent the
3150 # combined stack to the indentation of the ');'. Since we
3151 # should not normally outdent any of the other tokens more than
3152 # the indentation of the lines that contained them, we will
3153 # only do this if all of the corresponding opening
3154 # tokens were on the same line. This can happen with
3155 # -sot and -sct. For example, it is ok here:
3156 # __PACKAGE__->load_components( qw(
3161 # But, for example, we do not outdent in this example because
3162 # that would put the closing sub brace out farther than the
3163 # opening sub brace:
3165 # perltidy -sot -sct
3167 # '<Control-f>' => sub {
3169 # my $e = $c->XEvent;
3170 # itemsUnderArea $c;
3173 if ( $str =~ /^\);/ && $cached_line_text =~ /^[\)\}\]\s]*$/ ) {
3175 # The way to tell this is if the stacked sequence numbers
3176 # of this output line are the reverse of the stacked
3177 # sequence numbers of the previous non-blank line of
3178 # sequence numbers. So we can join if the previous
3179 # nonblank string of tokens is the mirror image. For
3180 # example if stack )}] is 13:8:6 then we are looking for a
3181 # leading stack like [{( which is 6:8:13 We only need to
3182 # check the two ends, because the intermediate tokens must
3183 # fall in order. Note on speed: having to split on colons
3184 # and eliminate multiple colons might appear to be slow,
3185 # but it's not an issue because we almost never come
3186 # through here. In a typical file we don't.
3187 $seqno_string =~ s/^:+//;
3188 $last_nonblank_seqno_string =~ s/^:+//;
3189 $seqno_string =~ s/:+/:/g;
3190 $last_nonblank_seqno_string =~ s/:+/:/g;
3192 # how many spaces can we outdent?
3194 $cached_line_leading_space_count - $leading_space_count;
3196 && length($seqno_string)
3197 && length($last_nonblank_seqno_string) ==
3198 length($seqno_string) )
3201 ( split /:/, $last_nonblank_seqno_string );
3202 my @seqno_now = ( split /:/, $seqno_string );
3205 && $seqno_now[-1] == $seqno_last[0]
3206 && $seqno_now[0] == $seqno_last[-1] )
3210 # for absolute safety, be sure we only remove
3212 my $ws = substr( $test_line, 0, $diff );
3213 if ( ( length($ws) == $diff ) && $ws =~ /^\s+$/ ) {
3215 $test_line = substr( $test_line, $diff );
3216 $cached_line_leading_space_count -= $diff;
3217 $last_level_written =
3219 $cached_line_leading_space_count,
3220 $diff, $last_level_written );
3221 reduce_valign_buffer_indentation($diff);
3224 # shouldn't happen, but not critical:
3226 ## ERROR transferring indentation here
3233 $leading_string = "";
3234 $leading_space_count = $cached_line_leading_space_count;
3235 $level = $last_level_written;
3238 valign_output_step_C( $cached_line_text,
3239 $cached_line_leading_space_count,
3240 $last_level_written );
3244 $cached_line_type = 0;
3245 $cached_line_text = "";
3247 # make the line to be written
3248 my $line = $leading_string . $str;
3250 # write or cache this line
3251 if ( !$open_or_close || $side_comment_length > 0 ) {
3252 valign_output_step_C( $line, $leading_space_count, $level );
3255 $cached_line_text = $line;
3256 $cached_line_type = $open_or_close;
3257 $cached_line_flag = $tightness_flag;
3258 $cached_seqno = $seqno;
3259 $cached_line_valid = $valid;
3260 $cached_line_leading_space_count = $leading_space_count;
3261 $cached_seqno_string = $seqno_string;
3264 $last_level_written = $level;
3265 $last_side_comment_length = $side_comment_length;
3266 $extra_indent_ok = 0;
3270 sub valign_output_step_C {
3272 ###############################################################
3273 # This is Step C in writing vertically aligned lines.
3274 # Lines are either stored in a buffer or passed along to the next step.
3275 # The reason for storing lines is that we may later want to reduce their
3276 # indentation when -sot and -sct are both used.
3277 ###############################################################
3280 # Dump any saved lines if we see a line with an unbalanced opening or
3282 dump_valign_buffer() if ( $seqno_string && $valign_buffer_filling );
3284 # Either store or write this line
3285 if ($valign_buffer_filling) {
3286 push @valign_buffer, [@args];
3289 valign_output_step_D(@args);
3292 # For lines starting or ending with opening or closing tokens..
3293 if ($seqno_string) {
3294 $last_nonblank_seqno_string = $seqno_string;
3296 # Start storing lines when we see a line with multiple stacked opening
3298 # patch for RT #94354, requested by Colin Williams
3299 if ( $seqno_string =~ /^\d+(\:+\d+)+$/ && $args[0] !~ /^[\}\)\]\:\?]/ )
3302 # This test is efficient but a little subtle: The first test says
3303 # that we have multiple sequence numbers and hence multiple opening
3304 # or closing tokens in this line. The second part of the test
3305 # rejects stacked closing and ternary tokens. So if we get here
3306 # then we should have stacked unbalanced opening tokens.
3308 # Here is a complex example:
3310 # Foo($Bar[0], { # (side comment)
3314 # The first line has sequence 6::4. It does not begin with
3315 # a closing token or ternary, so it passes the test and must be
3316 # stacked opening tokens.
3318 # The last line has sequence 4:6 but is a stack of closing tokens,
3319 # so it gets rejected.
3321 # Note that the sequence number of an opening token for a qw quote
3322 # is a negative number and will be rejected.
3323 # For example, for the following line:
3325 # $seqno_string='10:5:-1'. It would be okay to accept it but
3326 # I decided not to do this after testing.
3328 $valign_buffer_filling = $seqno_string;
3335 sub valign_output_step_D {
3337 ###############################################################
3338 # This is Step D in writing vertically aligned lines.
3339 # Write one vertically aligned line of code to the output object.
3340 ###############################################################
3342 my ( $line, $leading_space_count, $level ) = @_;
3344 # The line is currently correct if there is no tabbing (recommended!)
3345 # We may have to lop off some leading spaces and replace with tabs.
3346 if ( $leading_space_count > 0 ) {
3348 # Nothing to do if no tabs
3349 if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
3350 || $rOpts_indent_columns <= 0 )
3356 # Handle entab option
3357 elsif ($rOpts_entab_leading_whitespace) {
3359 # Patch 12-nov-2018 based on report from Glenn. Extra padding was
3360 # not correctly entabbed, nor were side comments:
3361 # Increase leading space count for a padded line to get correct tabbing
3362 if ( $line =~ /^(\s+)(.*)$/ ) {
3363 my $spaces = length($1);
3364 if ( $spaces > $leading_space_count ) {
3365 $leading_space_count = $spaces;
3370 $leading_space_count % $rOpts_entab_leading_whitespace;
3372 int( $leading_space_count / $rOpts_entab_leading_whitespace );
3373 my $leading_string = "\t" x $tab_count . ' ' x $space_count;
3374 if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
3375 substr( $line, 0, $leading_space_count ) = $leading_string;
3379 # shouldn't happen - program error counting whitespace
3381 VALIGN_DEBUG_FLAG_TABS
3383 "Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
3388 # Handle option of one tab per level
3390 my $leading_string = ( "\t" x $level );
3392 $leading_space_count - $level * $rOpts_indent_columns;
3395 if ( $space_count < 0 ) {
3397 # But it could be an outdented comment
3398 if ( $line !~ /^\s*#/ ) {
3399 VALIGN_DEBUG_FLAG_TABS
3401 "Error entabbing in valign_output_step_D: for level=$group_level count=$leading_space_count\n"
3404 $leading_string = ( ' ' x $leading_space_count );
3407 $leading_string .= ( ' ' x $space_count );
3409 if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
3410 substr( $line, 0, $leading_space_count ) = $leading_string;
3414 # shouldn't happen - program error counting whitespace
3415 # we'll skip entabbing
3416 VALIGN_DEBUG_FLAG_TABS
3418 "Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
3423 $file_writer_object->write_code_line( $line . "\n" );
3427 { # begin get_leading_string
3429 my @leading_string_cache;
3431 sub get_leading_string {
3433 # define the leading whitespace string for this line..
3434 my $leading_whitespace_count = shift;
3436 # Handle case of zero whitespace, which includes multi-line quotes
3437 # (which may have a finite level; this prevents tab problems)
3438 if ( $leading_whitespace_count <= 0 ) {
3442 # look for previous result
3443 elsif ( $leading_string_cache[$leading_whitespace_count] ) {
3444 return $leading_string_cache[$leading_whitespace_count];
3447 # must compute a string for this number of spaces
3450 # Handle simple case of no tabs
3451 if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
3452 || $rOpts_indent_columns <= 0 )
3454 $leading_string = ( ' ' x $leading_whitespace_count );
3457 # Handle entab option
3458 elsif ($rOpts_entab_leading_whitespace) {
3460 $leading_whitespace_count % $rOpts_entab_leading_whitespace;
3461 my $tab_count = int(
3462 $leading_whitespace_count / $rOpts_entab_leading_whitespace );
3463 $leading_string = "\t" x $tab_count . ' ' x $space_count;
3466 # Handle option of one tab per level
3468 $leading_string = ( "\t" x $group_level );
3470 $leading_whitespace_count - $group_level * $rOpts_indent_columns;
3473 if ( $space_count < 0 ) {
3474 VALIGN_DEBUG_FLAG_TABS
3476 "Error in get_leading_string: for level=$group_level count=$leading_whitespace_count\n"
3480 $leading_string = ( ' ' x $leading_whitespace_count );
3483 $leading_string .= ( ' ' x $space_count );
3486 $leading_string_cache[$leading_whitespace_count] = $leading_string;
3487 return $leading_string;
3489 } # end get_leading_string
3491 sub report_anything_unusual {
3493 if ( $outdented_line_count > 0 ) {
3494 write_logfile_entry(
3495 "$outdented_line_count long lines were outdented:\n");
3496 write_logfile_entry(
3497 " First at output line $first_outdented_line_at\n");
3499 if ( $outdented_line_count > 1 ) {
3500 write_logfile_entry(
3501 " Last at output line $last_outdented_line_at\n");
3503 write_logfile_entry(
3504 " use -noll to prevent outdenting, -l=n to increase line length\n"
3506 write_logfile_entry("\n");