my %is_closing_token;
my %is_digit_char;
my %is_plus_or_minus;
+my %is_if_or;
+my %is_assignment;
+my %is_comma_token;
+my %is_good_marginal_alignment;
BEGIN {
@q = qw( + - );
@is_plus_or_minus{@q} = (1) x scalar(@q);
+
+ @q = qw( if unless or || );
+ @is_if_or{@q} = (1) x scalar(@q);
+
+ @q = qw( = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x= );
+ @is_assignment{@q} = (1) x scalar(@q);
+
+ @q = qw( => );
+ push @q, ',';
+ @is_comma_token{@q} = (1) x scalar(@q);
+
+ # We can be less restrictive in marginal cases at certain "good" alignments
+ @q = qw( { ? => = );
+ push @q, (',');
+ @is_good_marginal_alignment{@q} = (1) x scalar(@q);
+
}
#--------------------------------------------
return 1;
} ## end sub join_hanging_comment
-{ ## closure for sub decide_if_list
+sub decide_if_list {
- my %is_comma_token;
+ my $line = shift;
- BEGIN {
-
- my @q = qw( => );
- push @q, ',';
- @is_comma_token{@q} = (1) x scalar(@q);
- } ## end BEGIN
-
- sub decide_if_list {
-
- my $line = shift;
-
- # Given:
- # $line = ref to hash of values for a line
- # Task:
- # Set 'list_type' property
-
- # A list will be taken to be a line with a forced break in which all
- # of the field separators are commas or comma-arrows (except for the
- # trailing #)
-
- my $rtokens = $line->{'rtokens'};
- my $test_token = $rtokens->[0];
- my ( $raw_tok, $lev, $tag, $tok_count ) =
- decode_alignment_token($test_token);
- if ( $is_comma_token{$raw_tok} ) {
- my $list_type = $test_token;
- my $jmax = $line->{'jmax'};
-
- foreach ( 1 .. $jmax - 2 ) {
- ( $raw_tok, $lev, $tag, $tok_count ) =
- decode_alignment_token( $rtokens->[$_] );
- if ( !$is_comma_token{$raw_tok} ) {
- $list_type = EMPTY_STRING;
- last;
- }
+ # Given:
+ # $line = ref to hash of values for a line
+ # Task:
+ # Set 'list_type' property
+
+ # A list will be taken to be a line with a forced break in which all
+ # of the field separators are commas or comma-arrows (except for the
+ # trailing #)
+
+ my $rtokens = $line->{'rtokens'};
+ my $test_token = $rtokens->[0];
+ my ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token($test_token);
+ if ( $is_comma_token{$raw_tok} ) {
+ my $list_type = $test_token;
+ my $jmax = $line->{'jmax'};
+
+ foreach ( 1 .. $jmax - 2 ) {
+ ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token( $rtokens->[$_] );
+ if ( !$is_comma_token{$raw_tok} ) {
+ $list_type = EMPTY_STRING;
+ last;
}
- $line->{'list_type'} = $list_type;
}
- return;
- } ## end sub decide_if_list
-}
+ $line->{'list_type'} = $list_type;
+ }
+ return;
+} ## end sub decide_if_list
sub fix_terminal_ternary {
} ## end sub decode_alignment_token
}
-{ ## closure for sub delete_unmatched_tokens
+sub delete_unmatched_tokens {
+ my ( $rlines, $group_level ) = @_;
- my %is_assignment;
- my %keep_after_deleted_assignment;
+ # Remove as many obviously un-needed alignment tokens as possible.
+ # This will prevent them from interfering with the final alignment.
- BEGIN {
- my @q;
+ # Given:
+ # $rlines = ref to hash of all lines in this alignment group
+ # $group_level = their comment indentation level
- @q = qw( = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x= );
- @is_assignment{@q} = (1) x scalar(@q);
+ # Return:
+ my $max_lev_diff = 0; # used to avoid a call to prune_tree
+ my $saw_side_comment = 0; # used to avoid a call for side comments
+ my $saw_signed_number = 0; # used to avoid a call for -vsn
- # These tokens may be kept following an = deletion
- @q = qw( if unless or || );
- @keep_after_deleted_assignment{@q} = (1) x scalar(@q);
+ # Handle no lines -- shouldn't happen
+ return unless @{$rlines};
- } ## end BEGIN
+ # Handle a single line
+ if ( @{$rlines} == 1 ) {
+ my $line = $rlines->[0];
+ my $jmax = $line->{'jmax'};
+ my $length = $line->{'rfield_lengths'}->[$jmax];
+ $saw_side_comment = $length > 0;
+ return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
+ }
- sub delete_unmatched_tokens {
- my ( $rlines, $group_level ) = @_;
+ # ignore hanging side comments in these operations
+ my @filtered = grep { !$_->{'is_hanging_side_comment'} } @{$rlines};
+ my $rnew_lines = \@filtered;
- # Remove as many obviously un-needed alignment tokens as possible.
- # This will prevent them from interfering with the final alignment.
+ $saw_side_comment = @filtered != @{$rlines};
+ $max_lev_diff = 0;
- # Given:
- # $rlines = ref to hash of all lines in this alignment group
- # $group_level = their comment indentation level
+ # nothing to do if all lines were hanging side comments
+ my $jmax = @{$rnew_lines} - 1;
+ return ( $max_lev_diff, $saw_side_comment, $saw_signed_number )
+ if ( $jmax < 0 );
- # Return:
- my $max_lev_diff = 0; # used to avoid a call to prune_tree
- my $saw_side_comment = 0; # used to avoid a call for side comments
- my $saw_signed_number = 0; # used to avoid a call for -vsn
-
- # Handle no lines -- shouldn't happen
- return unless @{$rlines};
+ #----------------------------------------------------
+ # Create a hash of alignment token info for each line
+ #----------------------------------------------------
+ ( my $rline_hashes, my $requals_info, $saw_side_comment, $max_lev_diff ) =
+ make_alignment_info( $group_level, $rnew_lines, $saw_side_comment );
- # Handle a single line
- if ( @{$rlines} == 1 ) {
- my $line = $rlines->[0];
- my $jmax = $line->{'jmax'};
- my $length = $line->{'rfield_lengths'}->[$jmax];
- $saw_side_comment = $length > 0;
- return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
+ #------------------------------------------------------------
+ # Find independent subgroups of lines. Neighboring subgroups
+ # do not have a common alignment token.
+ #------------------------------------------------------------
+ my @subgroups;
+ push @subgroups, [ 0, $jmax ];
+ foreach my $jl ( 0 .. $jmax - 1 ) {
+ if ( $rnew_lines->[$jl]->{'end_group'} ) {
+ $subgroups[-1]->[1] = $jl;
+ push @subgroups, [ $jl + 1, $jmax ];
}
+ }
- # ignore hanging side comments in these operations
- my @filtered = grep { !$_->{'is_hanging_side_comment'} } @{$rlines};
- my $rnew_lines = \@filtered;
-
- $saw_side_comment = @filtered != @{$rlines};
- $max_lev_diff = 0;
-
- # nothing to do if all lines were hanging side comments
- my $jmax = @{$rnew_lines} - 1;
- return ( $max_lev_diff, $saw_side_comment, $saw_signed_number )
- if ( $jmax < 0 );
-
- #----------------------------------------------------
- # Create a hash of alignment token info for each line
- #----------------------------------------------------
- ( my $rline_hashes, my $requals_info, $saw_side_comment, $max_lev_diff )
- = make_alignment_info( $group_level, $rnew_lines, $saw_side_comment );
-
- #------------------------------------------------------------
- # Find independent subgroups of lines. Neighboring subgroups
- # do not have a common alignment token.
- #------------------------------------------------------------
- my @subgroups;
- push @subgroups, [ 0, $jmax ];
- foreach my $jl ( 0 .. $jmax - 1 ) {
- if ( $rnew_lines->[$jl]->{'end_group'} ) {
- $subgroups[-1]->[1] = $jl;
- push @subgroups, [ $jl + 1, $jmax ];
- }
- }
+ #-----------------------------------------------------------
+ # PASS 1 over subgroups to remove unmatched alignment tokens
+ #-----------------------------------------------------------
+ delete_unmatched_tokens_main_loop(
+ $group_level, $rnew_lines, \@subgroups,
+ $rline_hashes, $requals_info
+ );
- #-----------------------------------------------------------
- # PASS 1 over subgroups to remove unmatched alignment tokens
- #-----------------------------------------------------------
- delete_unmatched_tokens_main_loop(
- $group_level, $rnew_lines, \@subgroups,
- $rline_hashes, $requals_info
- );
+ #----------------------------------------------------------------
+ # PASS 2: Construct a tree of matched lines and delete some small
+ # deeper levels of tokens. They also block good alignments.
+ #----------------------------------------------------------------
+ prune_alignment_tree($rnew_lines) if ($max_lev_diff);
- #----------------------------------------------------------------
- # PASS 2: Construct a tree of matched lines and delete some small
- # deeper levels of tokens. They also block good alignments.
- #----------------------------------------------------------------
- prune_alignment_tree($rnew_lines) if ($max_lev_diff);
+ #--------------------------------------------
+ # PASS 3: compare all lines for common tokens
+ #--------------------------------------------
+ $saw_signed_number =
+ match_line_pairs( $rlines, $rnew_lines, \@subgroups, $group_level );
- #--------------------------------------------
- # PASS 3: compare all lines for common tokens
- #--------------------------------------------
- $saw_signed_number =
- match_line_pairs( $rlines, $rnew_lines, \@subgroups, $group_level );
+ return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
+} ## end sub delete_unmatched_tokens
- return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
- } ## end sub delete_unmatched_tokens
+sub make_alignment_info {
- sub make_alignment_info {
+ my ( $group_level, $rnew_lines, $saw_side_comment ) = @_;
- my ( $group_level, $rnew_lines, $saw_side_comment ) = @_;
+ # Create a hash of alignment token info for each line
+ # This info will be used to find common alignments
- # Create a hash of alignment token info for each line
- # This info will be used to find common alignments
+ # Given:
+ # $group_level = common indentation level
+ # $rnew_lines = ref to hash of line info
+ # $saw_side_comment = true if there is a side comment
+ # Return:
+ # $rline_hashes = ref to hash with new line vars
+ # \@equals_info = ref to array with info on any '=' tokens
+ # $saw_side_comment = updated side comment flag
+ # $max_lev_diff = maximum level change seen
- # Given:
- # $group_level = common indentation level
- # $rnew_lines = ref to hash of line info
- # $saw_side_comment = true if there is a side comment
- # Return:
- # $rline_hashes = ref to hash with new line vars
- # \@equals_info = ref to array with info on any '=' tokens
- # $saw_side_comment = updated side comment flag
- # $max_lev_diff = maximum level change seen
-
- #----------------
- # Loop over lines
- #----------------
- my $rline_hashes = [];
- my @equals_info;
- my @line_info; # no longer used
- my $jmax = @{$rnew_lines} - 1;
- my $max_lev_diff = 0;
- foreach my $line ( @{$rnew_lines} ) {
- my $rhash = {};
- my $rtokens = $line->{'rtokens'};
- my $rpatterns = $line->{'rpatterns'};
- my $i = 0;
- my ( $i_eq, $tok_eq, $pat_eq );
- my ( $lev_min, $lev_max );
- foreach my $tok ( @{$rtokens} ) {
- my ( $raw_tok, $lev, $tag, $tok_count ) =
- decode_alignment_token($tok);
+ #----------------
+ # Loop over lines
+ #----------------
+ my $rline_hashes = [];
+ my @equals_info;
+ my @line_info; # no longer used
+ my $jmax = @{$rnew_lines} - 1;
+ my $max_lev_diff = 0;
+ foreach my $line ( @{$rnew_lines} ) {
+ my $rhash = {};
+ my $rtokens = $line->{'rtokens'};
+ my $rpatterns = $line->{'rpatterns'};
+ my $i = 0;
+ my ( $i_eq, $tok_eq, $pat_eq );
+ my ( $lev_min, $lev_max );
+ foreach my $tok ( @{$rtokens} ) {
+ my ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token($tok);
- if ( $tok ne '#' ) {
- if ( !defined($lev_min) ) {
- $lev_min = $lev;
- $lev_max = $lev;
- }
- else {
- if ( $lev < $lev_min ) { $lev_min = $lev }
- if ( $lev > $lev_max ) { $lev_max = $lev }
- }
+ if ( $tok ne '#' ) {
+ if ( !defined($lev_min) ) {
+ $lev_min = $lev;
+ $lev_max = $lev;
}
else {
- if ( !$saw_side_comment ) {
- my $length = $line->{'rfield_lengths'}->[ $i + 1 ];
- $saw_side_comment ||= $length;
- }
+ if ( $lev < $lev_min ) { $lev_min = $lev }
+ if ( $lev > $lev_max ) { $lev_max = $lev }
}
+ }
+ else {
+ if ( !$saw_side_comment ) {
+ my $length = $line->{'rfield_lengths'}->[ $i + 1 ];
+ $saw_side_comment ||= $length;
+ }
+ }
- # Possible future upgrade: for multiple matches,
- # record [$i1, $i2, ..] instead of $i
- $rhash->{$tok} =
- [ $i, undef, undef, $raw_tok, $lev, $tag, $tok_count ];
+ # Possible future upgrade: for multiple matches,
+ # record [$i1, $i2, ..] instead of $i
+ $rhash->{$tok} =
+ [ $i, undef, undef, $raw_tok, $lev, $tag, $tok_count ];
- # remember the first equals at line level
- if ( !defined($i_eq) && $raw_tok eq '=' ) {
+ # remember the first equals at line level
+ if ( !defined($i_eq) && $raw_tok eq '=' ) {
- if ( $lev eq $group_level ) {
- $i_eq = $i;
- $tok_eq = $tok;
- $pat_eq = $rpatterns->[$i];
- }
+ if ( $lev eq $group_level ) {
+ $i_eq = $i;
+ $tok_eq = $tok;
+ $pat_eq = $rpatterns->[$i];
}
- $i++;
- }
- push @{$rline_hashes}, $rhash;
- push @equals_info, [ $i_eq, $tok_eq, $pat_eq ];
- push @line_info, [ $lev_min, $lev_max ];
- if ( defined($lev_min) ) {
- my $lev_diff = $lev_max - $lev_min;
- if ( $lev_diff > $max_lev_diff ) { $max_lev_diff = $lev_diff }
}
+ $i++;
+ }
+ push @{$rline_hashes}, $rhash;
+ push @equals_info, [ $i_eq, $tok_eq, $pat_eq ];
+ push @line_info, [ $lev_min, $lev_max ];
+ if ( defined($lev_min) ) {
+ my $lev_diff = $lev_max - $lev_min;
+ if ( $lev_diff > $max_lev_diff ) { $max_lev_diff = $lev_diff }
}
+ }
- #----------------------------------------------------
- # Loop to compare each line pair and remember matches
- #----------------------------------------------------
- my $rtok_hash = {};
- my $nr = 0;
- foreach my $jl ( 0 .. $jmax - 1 ) {
- my $nl = $nr;
- $nr = 0;
- my $jr = $jl + 1;
- my $rhash_l = $rline_hashes->[$jl];
- my $rhash_r = $rline_hashes->[$jr];
- foreach my $tok ( keys %{$rhash_l} ) {
- if ( defined( $rhash_r->{$tok} ) ) {
- my $il = $rhash_l->{$tok}->[0];
- my $ir = $rhash_r->{$tok}->[0];
- $rhash_l->{$tok}->[2] = $ir;
- $rhash_r->{$tok}->[1] = $il;
- if ( $tok ne '#' ) {
- push @{ $rtok_hash->{$tok} }, ( $jl, $jr );
- $nr++;
- }
+ #----------------------------------------------------
+ # Loop to compare each line pair and remember matches
+ #----------------------------------------------------
+ my $rtok_hash = {};
+ my $nr = 0;
+ foreach my $jl ( 0 .. $jmax - 1 ) {
+ my $nl = $nr;
+ $nr = 0;
+ my $jr = $jl + 1;
+ my $rhash_l = $rline_hashes->[$jl];
+ my $rhash_r = $rline_hashes->[$jr];
+ foreach my $tok ( keys %{$rhash_l} ) {
+ if ( defined( $rhash_r->{$tok} ) ) {
+ my $il = $rhash_l->{$tok}->[0];
+ my $ir = $rhash_r->{$tok}->[0];
+ $rhash_l->{$tok}->[2] = $ir;
+ $rhash_r->{$tok}->[1] = $il;
+ if ( $tok ne '#' ) {
+ push @{ $rtok_hash->{$tok} }, ( $jl, $jr );
+ $nr++;
}
}
+ }
- # Set a line break if no matching tokens between these lines
- # (this is not strictly necessary now but does not hurt)
- if ( $nr == 0 && $nl > 0 ) {
+ # Set a line break if no matching tokens between these lines
+ # (this is not strictly necessary now but does not hurt)
+ if ( $nr == 0 && $nl > 0 ) {
+ $rnew_lines->[$jl]->{'end_group'} = 1;
+ }
+
+ # Also set a line break if both lines have simple equals but with
+ # different leading characters in patterns. This check is similar
+ # to one in sub check_match, and will prevent sub
+ # prune_alignment_tree from removing alignments which otherwise
+ # should be kept. This fix is rarely needed, but it can
+ # occasionally improve formatting.
+ # For example:
+ # my $name = $this->{Name};
+ # $type = $this->ctype($genlooptype) if defined $genlooptype;
+ # my $declini = ( $asgnonly ? "" : "\t$type *" );
+ # my $cast = ( $type ? "($type *)" : "" );
+ # The last two lines start with 'my' and will not match the
+ # previous line starting with $type, so we do not want
+ # prune_alignment tree to delete their ? : alignments at a deeper
+ # level.
+ my ( $i_eq_l, $tok_eq_l, $pat_eq_l ) = @{ $equals_info[$jl] };
+ my ( $i_eq_r, $tok_eq_r, $pat_eq_r ) = @{ $equals_info[$jr] };
+ if ( defined($i_eq_l) && defined($i_eq_r) ) {
+
+ # Also, do not align equals across a change in ci level
+ my $ci_jump = $rnew_lines->[$jl]->{'ci_level'} !=
+ $rnew_lines->[$jr]->{'ci_level'};
+
+ if (
+ $tok_eq_l eq $tok_eq_r
+ && $i_eq_l == 0
+ && $i_eq_r == 0
+ && ( substr( $pat_eq_l, 0, 1 ) ne substr( $pat_eq_r, 0, 1 )
+ || $ci_jump )
+ )
+ {
$rnew_lines->[$jl]->{'end_group'} = 1;
}
+ }
+ }
+ return ( $rline_hashes, \@equals_info, $saw_side_comment, $max_lev_diff );
+} ## end sub make_alignment_info
- # Also set a line break if both lines have simple equals but with
- # different leading characters in patterns. This check is similar
- # to one in sub check_match, and will prevent sub
- # prune_alignment_tree from removing alignments which otherwise
- # should be kept. This fix is rarely needed, but it can
- # occasionally improve formatting.
- # For example:
- # my $name = $this->{Name};
- # $type = $this->ctype($genlooptype) if defined $genlooptype;
- # my $declini = ( $asgnonly ? "" : "\t$type *" );
- # my $cast = ( $type ? "($type *)" : "" );
- # The last two lines start with 'my' and will not match the
- # previous line starting with $type, so we do not want
- # prune_alignment tree to delete their ? : alignments at a deeper
- # level.
- my ( $i_eq_l, $tok_eq_l, $pat_eq_l ) = @{ $equals_info[$jl] };
- my ( $i_eq_r, $tok_eq_r, $pat_eq_r ) = @{ $equals_info[$jr] };
- if ( defined($i_eq_l) && defined($i_eq_r) ) {
-
- # Also, do not align equals across a change in ci level
- my $ci_jump = $rnew_lines->[$jl]->{'ci_level'} !=
- $rnew_lines->[$jr]->{'ci_level'};
+sub delete_unmatched_tokens_main_loop {
- if (
- $tok_eq_l eq $tok_eq_r
- && $i_eq_l == 0
- && $i_eq_r == 0
- && ( substr( $pat_eq_l, 0, 1 ) ne substr( $pat_eq_r, 0, 1 )
- || $ci_jump )
- )
- {
- $rnew_lines->[$jl]->{'end_group'} = 1;
- }
- }
- }
- return ( $rline_hashes, \@equals_info, $saw_side_comment,
- $max_lev_diff );
- } ## end sub make_alignment_info
+ my ( $group_level, $rnew_lines, $rsubgroups, $rline_hashes, $requals_info )
+ = @_;
- sub delete_unmatched_tokens_main_loop {
+ #--------------------------------------------------------------
+ # Main loop over subgroups to remove unmatched alignment tokens
+ #--------------------------------------------------------------
- my (
- $group_level, $rnew_lines, $rsubgroups,
- $rline_hashes, $requals_info
- ) = @_;
+ # flag to allow skipping pass 2 - not currently used
+ my $saw_large_group;
- #--------------------------------------------------------------
- # Main loop over subgroups to remove unmatched alignment tokens
- #--------------------------------------------------------------
-
- # flag to allow skipping pass 2 - not currently used
- my $saw_large_group;
-
- my $has_terminal_match = $rnew_lines->[-1]->{'j_terminal_match'};
-
- foreach my $item ( @{$rsubgroups} ) {
- my ( $jbeg, $jend ) = @{$item};
-
- my $nlines = $jend - $jbeg + 1;
-
- #---------------------------------------------------
- # Look for complete if/elsif/else and ternary blocks
- #---------------------------------------------------
-
- # We are looking for a common '$dividing_token' like these:
-
- # if ( $b and $s ) { $p->{'type'} = 'a'; }
- # elsif ($b) { $p->{'type'} = 'b'; }
- # elsif ($s) { $p->{'type'} = 's'; }
- # else { $p->{'type'} = ''; }
- # ^----------- dividing_token
-
- # my $severity =
- # !$routine ? '[PFX]'
- # : $routine =~ /warn.*_d\z/ ? '[DS]'
- # : $routine =~ /ck_warn/ ? 'W'
- # : $routine =~ /ckWARN\d*reg_d/ ? 'S'
- # : $routine =~ /ckWARN\d*reg/ ? 'W'
- # : $routine =~ /vWARN\d/ ? '[WDS]'
- # : '[PFX]';
- # ^----------- dividing_token
-
- # Only look for groups which are more than 2 lines long. Two lines
- # can get messed up doing this, probably due to the various
- # two-line rules.
-
- my $dividing_token;
- my %token_line_count;
- if ( $nlines > 2 ) {
-
- foreach my $jj ( $jbeg .. $jend ) {
- my %seen;
- my $line = $rnew_lines->[$jj];
- my $rtokens = $line->{'rtokens'};
- foreach my $tok ( @{$rtokens} ) {
- if ( !$seen{$tok} ) {
- $seen{$tok}++;
- $token_line_count{$tok}++;
- }
+ my $has_terminal_match = $rnew_lines->[-1]->{'j_terminal_match'};
+
+ foreach my $item ( @{$rsubgroups} ) {
+ my ( $jbeg, $jend ) = @{$item};
+
+ my $nlines = $jend - $jbeg + 1;
+
+ #---------------------------------------------------
+ # Look for complete if/elsif/else and ternary blocks
+ #---------------------------------------------------
+
+ # We are looking for a common '$dividing_token' like these:
+
+ # if ( $b and $s ) { $p->{'type'} = 'a'; }
+ # elsif ($b) { $p->{'type'} = 'b'; }
+ # elsif ($s) { $p->{'type'} = 's'; }
+ # else { $p->{'type'} = ''; }
+ # ^----------- dividing_token
+
+ # my $severity =
+ # !$routine ? '[PFX]'
+ # : $routine =~ /warn.*_d\z/ ? '[DS]'
+ # : $routine =~ /ck_warn/ ? 'W'
+ # : $routine =~ /ckWARN\d*reg_d/ ? 'S'
+ # : $routine =~ /ckWARN\d*reg/ ? 'W'
+ # : $routine =~ /vWARN\d/ ? '[WDS]'
+ # : '[PFX]';
+ # ^----------- dividing_token
+
+ # Only look for groups which are more than 2 lines long. Two lines
+ # can get messed up doing this, probably due to the various
+ # two-line rules.
+
+ my $dividing_token;
+ my %token_line_count;
+ if ( $nlines > 2 ) {
+
+ foreach my $jj ( $jbeg .. $jend ) {
+ my %seen;
+ my $line = $rnew_lines->[$jj];
+ my $rtokens = $line->{'rtokens'};
+ foreach my $tok ( @{$rtokens} ) {
+ if ( !$seen{$tok} ) {
+ $seen{$tok}++;
+ $token_line_count{$tok}++;
}
}
+ }
- foreach my $tok ( keys %token_line_count ) {
- if ( $token_line_count{$tok} == $nlines ) {
- if ( substr( $tok, 0, 1 ) eq '?'
- || substr( $tok, 0, 1 ) eq '{'
- && $tok =~ /^\{\d+if/ )
- {
- $dividing_token = $tok;
- last;
- }
+ foreach my $tok ( keys %token_line_count ) {
+ if ( $token_line_count{$tok} == $nlines ) {
+ if ( substr( $tok, 0, 1 ) eq '?'
+ || substr( $tok, 0, 1 ) eq '{' && $tok =~ /^\{\d+if/ )
+ {
+ $dividing_token = $tok;
+ last;
}
}
}
+ }
- #-------------------------------------------------------------
- # Loop over subgroup lines to remove unwanted alignment tokens
- #-------------------------------------------------------------
- foreach my $jj ( $jbeg .. $jend ) {
- my $line = $rnew_lines->[$jj];
- my $rtokens = $line->{'rtokens'};
- my $rhash = $rline_hashes->[$jj];
- my $i_eq = $requals_info->[$jj]->[0];
- my @idel;
- my $imax = @{$rtokens} - 2;
- my $delete_above_level;
- my $deleted_assignment_token;
-
- my $saw_dividing_token = EMPTY_STRING;
- $saw_large_group ||= $nlines > 2 && $imax > 1;
-
- # Loop over all alignment tokens
- foreach my $i ( 0 .. $imax ) {
- my $tok = $rtokens->[$i];
- next if ( $tok eq '#' ); # shouldn't happen
- my ( $iii_uu, $il, $ir, $raw_tok, $lev, $tag_uu,
- $tok_count )
- = @{ $rhash->{$tok} };
-
- #------------------------------------------------------
- # Here is the basic RULE: remove an unmatched alignment
- # which does not occur in the surrounding lines.
- #------------------------------------------------------
- my $delete_me = !defined($il) && !defined($ir);
-
- # Apply any user controls. Note that not all lines pass
- # this way so they have to be applied elsewhere too.
- my $align_ok = 1;
- if (%valign_control_hash) {
- $align_ok = $valign_control_hash{$raw_tok};
- $align_ok = $valign_control_default
- unless defined($align_ok);
- $delete_me ||= !$align_ok;
- }
+ #-------------------------------------------------------------
+ # Loop over subgroup lines to remove unwanted alignment tokens
+ #-------------------------------------------------------------
+ foreach my $jj ( $jbeg .. $jend ) {
+ my $line = $rnew_lines->[$jj];
+ my $rtokens = $line->{'rtokens'};
+ my $rhash = $rline_hashes->[$jj];
+ my $i_eq = $requals_info->[$jj]->[0];
+ my @idel;
+ my $imax = @{$rtokens} - 2;
+ my $delete_above_level;
+ my $deleted_assignment_token;
- # But now we modify this with exceptions...
+ my $saw_dividing_token = EMPTY_STRING;
+ $saw_large_group ||= $nlines > 2 && $imax > 1;
- # EXCEPTION 1: If we are in a complete ternary or
- # if/elsif/else group, and this token is not on every line
- # of the group, should we delete it to preserve overall
- # alignment?
- if ($dividing_token) {
- if ( $token_line_count{$tok} >= $nlines ) {
- $saw_dividing_token ||= $tok eq $dividing_token;
- }
- else {
+ # Loop over all alignment tokens
+ foreach my $i ( 0 .. $imax ) {
+ my $tok = $rtokens->[$i];
+ next if ( $tok eq '#' ); # shouldn't happen
+ my ( $iii_uu, $il, $ir, $raw_tok, $lev, $tag_uu, $tok_count ) =
+ @{ $rhash->{$tok} };
+
+ #------------------------------------------------------
+ # Here is the basic RULE: remove an unmatched alignment
+ # which does not occur in the surrounding lines.
+ #------------------------------------------------------
+ my $delete_me = !defined($il) && !defined($ir);
+
+ # Apply any user controls. Note that not all lines pass
+ # this way so they have to be applied elsewhere too.
+ my $align_ok = 1;
+ if (%valign_control_hash) {
+ $align_ok = $valign_control_hash{$raw_tok};
+ $align_ok = $valign_control_default
+ unless defined($align_ok);
+ $delete_me ||= !$align_ok;
+ }
- # For shorter runs, delete toks to save alignment.
- # For longer runs, keep toks after the '{' or '?'
- # to allow sub-alignments within braces. The
- # number 5 lines is arbitrary but seems to work ok.
- $delete_me ||=
- ( $nlines < 5 || !$saw_dividing_token );
- }
+ # But now we modify this with exceptions...
+
+ # EXCEPTION 1: If we are in a complete ternary or
+ # if/elsif/else group, and this token is not on every line
+ # of the group, should we delete it to preserve overall
+ # alignment?
+ if ($dividing_token) {
+ if ( $token_line_count{$tok} >= $nlines ) {
+ $saw_dividing_token ||= $tok eq $dividing_token;
}
+ else {
- # EXCEPTION 2: Remove all tokens above a certain level
- # following a previous deletion. For example, we have to
- # remove tagged higher level alignment tokens following a
- # '=>' deletion because the tags of higher level tokens
- # will now be incorrect. For example, this will prevent
- # aligning commas as follows after deleting the second '=>'
- # $w->insert(
- # ListBox => origin => [ 270, 160 ],
- # size => [ 200, 55 ],
- # );
- if ( defined($delete_above_level) ) {
- if ( $lev > $delete_above_level ) {
- $delete_me ||= 1;
- }
- else { $delete_above_level = undef }
+ # For shorter runs, delete toks to save alignment.
+ # For longer runs, keep toks after the '{' or '?'
+ # to allow sub-alignments within braces. The
+ # number 5 lines is arbitrary but seems to work ok.
+ $delete_me ||= ( $nlines < 5 || !$saw_dividing_token );
}
+ }
- # EXCEPTION 3: Remove all but certain tokens after an
- # assignment deletion.
- if (
- $deleted_assignment_token
- && ( $lev > $group_level
- || !$keep_after_deleted_assignment{$raw_tok} )
- )
- {
+ # EXCEPTION 2: Remove all tokens above a certain level
+ # following a previous deletion. For example, we have to
+ # remove tagged higher level alignment tokens following a
+ # '=>' deletion because the tags of higher level tokens
+ # will now be incorrect. For example, this will prevent
+ # aligning commas as follows after deleting the second '=>'
+ # $w->insert(
+ # ListBox => origin => [ 270, 160 ],
+ # size => [ 200, 55 ],
+ # );
+ if ( defined($delete_above_level) ) {
+ if ( $lev > $delete_above_level ) {
$delete_me ||= 1;
}
+ else { $delete_above_level = undef }
+ }
- # EXCEPTION 4: Do not touch the first line of a 2 line
- # terminal match, such as below, because j_terminal has
- # already been set.
- # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
- # else { $tago = $tagc = ''; }
- # But see snippets 'else1.t' and 'else2.t'
- $delete_me = 0
- if ( $jj == $jbeg
- && $has_terminal_match
- && $nlines == 2 );
+ # EXCEPTION 3: Remove all but certain tokens after an
+ # assignment deletion.
+ if (
+ $deleted_assignment_token
+ && ( $lev > $group_level
+ || !$is_if_or{$raw_tok} )
+ )
+ {
+ $delete_me ||= 1;
+ }
- # EXCEPTION 5: misc additional rules for commas and equals
- if ( $delete_me && $tok_count == 1 ) {
+ # EXCEPTION 4: Do not touch the first line of a 2 line
+ # terminal match, such as below, because j_terminal has
+ # already been set.
+ # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
+ # else { $tago = $tagc = ''; }
+ # But see snippets 'else1.t' and 'else2.t'
+ $delete_me = 0
+ if ( $jj == $jbeg
+ && $has_terminal_match
+ && $nlines == 2 );
- # okay to delete second and higher copies of a token
+ # EXCEPTION 5: misc additional rules for commas and equals
+ if ( $delete_me && $tok_count == 1 ) {
- # for a comma...
- if ( $raw_tok eq ',' ) {
+ # okay to delete second and higher copies of a token
- # Do not delete commas before an equals
- $delete_me = 0
- if ( defined($i_eq) && $i < $i_eq );
+ # for a comma...
+ if ( $raw_tok eq ',' ) {
- # Do not delete line-level commas
- $delete_me = 0 if ( $lev <= $group_level );
- }
+ # Do not delete commas before an equals
+ $delete_me = 0
+ if ( defined($i_eq) && $i < $i_eq );
- # For an assignment at group level..
- if ( $is_assignment{$raw_tok}
- && $lev == $group_level )
- {
+ # Do not delete line-level commas
+ $delete_me = 0 if ( $lev <= $group_level );
+ }
- # Do not delete if it is the last alignment of
- # multiple tokens; this will prevent some
- # undesirable alignments
- if ( $imax > 0 && $i == $imax ) {
- $delete_me = 0;
- }
+ # For an assignment at group level..
+ if ( $is_assignment{$raw_tok}
+ && $lev == $group_level )
+ {
- # Otherwise, set a flag to delete most
- # remaining tokens
- else { $deleted_assignment_token = $raw_tok }
+ # Do not delete if it is the last alignment of
+ # multiple tokens; this will prevent some
+ # undesirable alignments
+ if ( $imax > 0 && $i == $imax ) {
+ $delete_me = 0;
}
+
+ # Otherwise, set a flag to delete most
+ # remaining tokens
+ else { $deleted_assignment_token = $raw_tok }
}
+ }
- # Do not let a user exclusion be reactivated by above rules
- $delete_me ||= !$align_ok;
+ # Do not let a user exclusion be reactivated by above rules
+ $delete_me ||= !$align_ok;
- #------------------------------------
- # Add this token to the deletion list
- #------------------------------------
- if ($delete_me) {
- push @idel, $i;
+ #------------------------------------
+ # Add this token to the deletion list
+ #------------------------------------
+ if ($delete_me) {
+ push @idel, $i;
- # update deletion propagation flags
- if ( !defined($delete_above_level)
- || $lev < $delete_above_level )
- {
+ # update deletion propagation flags
+ if ( !defined($delete_above_level)
+ || $lev < $delete_above_level )
+ {
- # delete all following higher level alignments
- $delete_above_level = $lev;
+ # delete all following higher level alignments
+ $delete_above_level = $lev;
- # but keep deleting after => to next lower level
- # to avoid some bizarre alignments
- if ( $raw_tok eq '=>' ) {
- $delete_above_level = $lev - 1;
- }
+ # but keep deleting after => to next lower level
+ # to avoid some bizarre alignments
+ if ( $raw_tok eq '=>' ) {
+ $delete_above_level = $lev - 1;
}
}
- } # End loop over alignment tokens
-
- # Process all deletion requests for this line
- if (@idel) {
- delete_selected_tokens( $line, \@idel );
}
- } # End loop over lines
- } ## end main loop over subgroups
+ } # End loop over alignment tokens
- return;
- } ## end sub delete_unmatched_tokens_main_loop
-}
+ # Process all deletion requests for this line
+ if (@idel) {
+ delete_selected_tokens( $line, \@idel );
+ }
+ } # End loop over lines
+ } ## end main loop over subgroups
+
+ return;
+} ## end sub delete_unmatched_tokens_main_loop
sub match_line_pairs {
my ( $rlines, $rnew_lines, $rsubgroups, $group_level ) = @_;
return;
} ## end sub Dump_tree_groups
-{ ## closure for sub is_marginal_match
-
- my %is_if_or;
- my %is_assignment;
- my %is_good_alignment;
-
- # This test did not give sufficiently better results to use as an update,
- # but the flag is worth keeping as a starting point for future testing.
- use constant TEST_MARGINAL_EQ_ALIGNMENT => 0;
+# This test did not give sufficiently better results to use as an update,
+# but the flag is kept as a starting point for future testing.
+use constant TEST_MARGINAL_EQ_ALIGNMENT => 0;
- BEGIN {
-
- my @q = qw( if unless or || );
- @is_if_or{@q} = (1) x scalar(@q);
-
- @q = qw( = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x= );
- @is_assignment{@q} = (1) x scalar(@q);
-
- # Vertically aligning on certain "good" tokens is usually okay
- # so we can be less restrictive in marginal cases.
- @q = qw( { ? => = );
- push @q, (',');
- @is_good_alignment{@q} = (1) x scalar(@q);
- } ## end BEGIN
+sub is_marginal_match {
- sub is_marginal_match {
+ my ( $line_0, $line_1, $group_level, $imax_align, $imax_prev ) = @_;
- my ( $line_0, $line_1, $group_level, $imax_align, $imax_prev ) = @_;
+ # Decide if we should undo some or all of the common alignments of a
+ # group of just two lines.
- # Decide if we should undo some or all of the common alignments of a
- # group of just two lines.
+ # Given:
+ # $line_0 and $line_1 - the two lines
+ # $group_level = the indentation level of the group being processed
+ # $imax_align = the maximum index of the common alignment tokens
+ # of the two lines
+ # $imax_prev = the maximum index of the common alignment tokens
+ # with the line before $line_0 (=-1 of does not exist)
- # Given:
- # $line_0 and $line_1 - the two lines
- # $group_level = the indentation level of the group being processed
- # $imax_align = the maximum index of the common alignment tokens
- # of the two lines
- # $imax_prev = the maximum index of the common alignment tokens
- # with the line before $line_0 (=-1 of does not exist)
+ # Return:
+ # $is_marginal = true if the two lines should NOT be fully aligned
+ # = false if the two lines can remain fully aligned
+ # $imax_align = the index of the highest alignment token shared by
+ # these two lines to keep if the match is marginal.
- # Return:
- # $is_marginal = true if the two lines should NOT be fully aligned
- # = false if the two lines can remain fully aligned
- # $imax_align = the index of the highest alignment token shared by
- # these two lines to keep if the match is marginal.
+ # When we have an alignment group of just two lines like this, we are
+ # working in the twilight zone of what looks good and what looks bad.
+ # This routine is a collection of rules which work have been found to
+ # work fairly well, but it will need to be updated from time to time.
- # When we have an alignment group of just two lines like this, we are
- # working in the twilight zone of what looks good and what looks bad.
- # This routine is a collection of rules which work have been found to
- # work fairly well, but it will need to be updated from time to time.
+ my $is_marginal = 0;
- my $is_marginal = 0;
+ #---------------------------------------
+ # Always align certain special cases ...
+ #---------------------------------------
+ if (
- #---------------------------------------
- # Always align certain special cases ...
- #---------------------------------------
- if (
+ # always keep alignments of a terminal else or ternary
+ defined( $line_1->{'j_terminal_match'} )
- # always keep alignments of a terminal else or ternary
- defined( $line_1->{'j_terminal_match'} )
+ # always align lists
+ || $line_0->{'list_type'}
- # always align lists
- || $line_0->{'list_type'}
+ # always align hanging side comments
+ || $line_1->{'is_hanging_side_comment'}
- # always align hanging side comments
- || $line_1->{'is_hanging_side_comment'}
+ )
+ {
+ return ( $is_marginal, $imax_align );
+ }
- )
- {
- return ( $is_marginal, $imax_align );
- }
-
- my $jmax_0 = $line_0->{'jmax'};
- my $jmax_1 = $line_1->{'jmax'};
- my $rtokens_1 = $line_1->{'rtokens'};
-## my $rtokens_0 = $line_0->{'rtokens'};
- my $rfield_lengths_0 = $line_0->{'rfield_lengths'};
- my $rfield_lengths_1 = $line_1->{'rfield_lengths'};
- my $rpatterns_0 = $line_0->{'rpatterns'};
- my $rpatterns_1 = $line_1->{'rpatterns'};
- my $imax_next = $line_1->{'imax_pair'};
-
- # We will scan the alignment tokens and set a flag '$is_marginal' if
- # it seems that the an alignment would look bad.
- my $max_pad = 0;
- my $saw_good_alignment = 0;
- my $saw_if_or; # if we saw an 'if' or 'or' at group level
- my $raw_tokb = EMPTY_STRING; # first token seen at group level
- my $jfirst_bad;
- my $line_ending_fat_comma; # is last token just a '=>' ?
- my $j0_eq_pad;
- my $j0_max_pad = 0;
-
- foreach my $j ( 0 .. $jmax_1 - 2 ) {
- my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
- decode_alignment_token( $rtokens_1->[$j] );
- if ( $raw_tok && $lev == $group_level ) {
- if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
- $saw_if_or ||= $is_if_or{$raw_tok};
- }
+ my $jmax_0 = $line_0->{'jmax'};
+ my $jmax_1 = $line_1->{'jmax'};
+ my $rtokens_1 = $line_1->{'rtokens'};
+## my $rtokens_0 = $line_0->{'rtokens'};
+ my $rfield_lengths_0 = $line_0->{'rfield_lengths'};
+ my $rfield_lengths_1 = $line_1->{'rfield_lengths'};
+ my $rpatterns_0 = $line_0->{'rpatterns'};
+ my $rpatterns_1 = $line_1->{'rpatterns'};
+ my $imax_next = $line_1->{'imax_pair'};
+
+ # We will scan the alignment tokens and set a flag '$is_marginal' if
+ # it seems that the an alignment would look bad.
+ my $max_pad = 0;
+ my $saw_good_alignment = 0;
+ my $saw_if_or; # if we saw an 'if' or 'or' at group level
+ my $raw_tokb = EMPTY_STRING; # first token seen at group level
+ my $jfirst_bad;
+ my $line_ending_fat_comma; # is last token just a '=>' ?
+ my $j0_eq_pad;
+ my $j0_max_pad = 0;
+
+ foreach my $j ( 0 .. $jmax_1 - 2 ) {
+ my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
+ decode_alignment_token( $rtokens_1->[$j] );
+ if ( $raw_tok && $lev == $group_level ) {
+ if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
+ $saw_if_or ||= $is_if_or{$raw_tok};
+ }
- # When the first of the two lines ends in a bare '=>' this will
- # probably be marginal match. (For a bare =>, the next field length
- # will be 2 or 3, depending on side comment)
- $line_ending_fat_comma =
- $j == $jmax_1 - 2
- && $raw_tok eq '=>'
- && $rfield_lengths_0->[ $j + 1 ] <= 3;
-
- my $pad = $rfield_lengths_1->[$j] - $rfield_lengths_0->[$j];
- if ( $j == 0 ) {
- $pad += $line_1->{'leading_space_count'} -
- $line_0->{'leading_space_count'};
-
- # Remember the pad at a leading equals
- if ( $raw_tok eq '=' && $lev == $group_level ) {
- $j0_eq_pad = $pad;
- $j0_max_pad =
- 0.5 * ( $rfield_lengths_1->[0] + $rfield_lengths_0->[0] );
- $j0_max_pad = 4 if ( $j0_max_pad < 4 );
- }
- }
+ # When the first of the two lines ends in a bare '=>' this will
+ # probably be marginal match. (For a bare =>, the next field length
+ # will be 2 or 3, depending on side comment)
+ $line_ending_fat_comma =
+ $j == $jmax_1 - 2
+ && $raw_tok eq '=>'
+ && $rfield_lengths_0->[ $j + 1 ] <= 3;
- if ( $pad < 0 ) { $pad = -$pad }
- if ( $pad > $max_pad ) { $max_pad = $pad }
- if ( $is_good_alignment{$raw_tok} && !$line_ending_fat_comma ) {
- $saw_good_alignment = 1;
- }
- else {
- $jfirst_bad = $j unless defined($jfirst_bad);
- }
- my $pat_0 = $rpatterns_0->[$j];
- my $pat_1 = $rpatterns_1->[$j];
- if ( $pat_0 ne $pat_1 && length($pat_0) eq length($pat_1) ) {
- $pat_0 =~ tr/n/Q/;
- $pat_1 =~ tr/n/Q/;
- }
- if ( $pat_0 ne $pat_1 ) {
-
- # Flag this as a marginal match since patterns differ.
- # Normally, we will not allow just two lines to match if
- # marginal. But we can allow matching in some specific cases.
-
- $jfirst_bad = $j if ( !defined($jfirst_bad) );
- $is_marginal = 1 if ( $is_marginal == 0 );
- if ( $raw_tok eq '=' ) {
-
- # Here is an example of a marginal match:
- # $done{$$op} = 1;
- # $op = compile_bblock($op);
- # The left tokens are both identifiers, but
- # one accesses a hash and the other doesn't.
- # We'll let this be a tentative match and undo
- # it later if we don't find more than 2 lines
- # in the group.
- $is_marginal = 2;
- }
+ my $pad = $rfield_lengths_1->[$j] - $rfield_lengths_0->[$j];
+ if ( $j == 0 ) {
+ $pad += $line_1->{'leading_space_count'} -
+ $line_0->{'leading_space_count'};
+
+ # Remember the pad at a leading equals
+ if ( $raw_tok eq '=' && $lev == $group_level ) {
+ $j0_eq_pad = $pad;
+ $j0_max_pad =
+ 0.5 * ( $rfield_lengths_1->[0] + $rfield_lengths_0->[0] );
+ $j0_max_pad = 4 if ( $j0_max_pad < 4 );
}
}
- $is_marginal = 1 if ( $is_marginal == 0 && $line_ending_fat_comma );
-
- # Turn off the "marginal match" flag in some cases...
- # A "marginal match" occurs when the alignment tokens agree
- # but there are differences in the other tokens (patterns).
- # If we leave the marginal match flag set, then the rule is that we
- # will align only if there are more than two lines in the group.
- # We will turn of the flag if we almost have a match
- # and either we have seen a good alignment token or we
- # just need a small pad (2 spaces) to fit. These rules are
- # the result of experimentation. Tokens which misaligned by just
- # one or two characters are annoying. On the other hand,
- # large gaps to less important alignment tokens are also annoying.
- if ( $is_marginal == 1
- && ( $saw_good_alignment || $max_pad < 3 ) )
+ if ( $pad < 0 ) { $pad = -$pad }
+ if ( $pad > $max_pad ) { $max_pad = $pad }
+ if ( $is_good_marginal_alignment{$raw_tok}
+ && !$line_ending_fat_comma )
{
- $is_marginal = 0;
- }
-
- # We will use the line endings to help decide on alignments...
- # See if the lines end with semicolons...
- my $sc_term0;
- my $sc_term1;
- if ( $jmax_0 < 1 || $jmax_1 < 1 ) {
-
- # shouldn't happen
+ $saw_good_alignment = 1;
}
else {
- my $pat0 = $rpatterns_0->[ $jmax_0 - 1 ];
- my $pat1 = $rpatterns_1->[ $jmax_1 - 1 ];
- $sc_term0 = $pat0 =~ /;b?$/;
- $sc_term1 = $pat1 =~ /;b?$/;
+ $jfirst_bad = $j unless defined($jfirst_bad);
+ }
+ my $pat_0 = $rpatterns_0->[$j];
+ my $pat_1 = $rpatterns_1->[$j];
+ if ( $pat_0 ne $pat_1 && length($pat_0) eq length($pat_1) ) {
+ $pat_0 =~ tr/n/Q/;
+ $pat_1 =~ tr/n/Q/;
+ }
+ if ( $pat_0 ne $pat_1 ) {
+
+ # Flag this as a marginal match since patterns differ.
+ # Normally, we will not allow just two lines to match if
+ # marginal. But we can allow matching in some specific cases.
+
+ $jfirst_bad = $j if ( !defined($jfirst_bad) );
+ $is_marginal = 1 if ( $is_marginal == 0 );
+ if ( $raw_tok eq '=' ) {
+
+ # Here is an example of a marginal match:
+ # $done{$$op} = 1;
+ # $op = compile_bblock($op);
+ # The left tokens are both identifiers, but
+ # one accesses a hash and the other doesn't.
+ # We'll let this be a tentative match and undo
+ # it later if we don't find more than 2 lines
+ # in the group.
+ $is_marginal = 2;
+ }
}
+ }
- if ( !$is_marginal && !$sc_term0 ) {
+ $is_marginal = 1 if ( $is_marginal == 0 && $line_ending_fat_comma );
+
+ # Turn off the "marginal match" flag in some cases...
+ # A "marginal match" occurs when the alignment tokens agree
+ # but there are differences in the other tokens (patterns).
+ # If we leave the marginal match flag set, then the rule is that we
+ # will align only if there are more than two lines in the group.
+ # We will turn of the flag if we almost have a match
+ # and either we have seen a good alignment token or we
+ # just need a small pad (2 spaces) to fit. These rules are
+ # the result of experimentation. Tokens which misaligned by just
+ # one or two characters are annoying. On the other hand,
+ # large gaps to less important alignment tokens are also annoying.
+ if ( $is_marginal == 1
+ && ( $saw_good_alignment || $max_pad < 3 ) )
+ {
+ $is_marginal = 0;
+ }
- # First line of assignment should be semicolon terminated.
- # For example, do not align here:
- # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
- # $$href{-NUM_DIRS} = 0;
- if ( $is_assignment{$raw_tokb} ) {
- $is_marginal = 1;
- }
- }
+ # We will use the line endings to help decide on alignments...
+ # See if the lines end with semicolons...
+ my $sc_term0;
+ my $sc_term1;
+ if ( $jmax_0 < 1 || $jmax_1 < 1 ) {
- # Try to avoid some undesirable alignments of opening tokens
- # for example, the space between grep and { here:
- # return map { ( $_ => $_ ) }
- # grep { /$handles/ } $self->_get_delegate_method_list;
- $is_marginal ||=
- ( $raw_tokb eq '(' || $raw_tokb eq '{' )
- && $jmax_1 == 2
- && $sc_term0 ne $sc_term1;
-
- #---------------------------------------
- # return if this is not a marginal match
- #---------------------------------------
- if ( !$is_marginal ) {
- return ( $is_marginal, $imax_align );
- }
-
- # Undo the marginal match flag in certain cases,
-
- # Two lines with a leading equals-like operator are allowed to
- # align if the patterns to the left of the equals are the same.
- # For example the following two lines are a marginal match but have
- # the same left side patterns, so we will align the equals.
- # my $orig = my $format = "^<<<<< ~~\n";
- # my $abc = "abc";
- # But these have a different left pattern so they will not be
- # aligned
- # $xmldoc .= $`;
- # $self->{'leftovers'} .= "<bx-seq:seq" . $';
-
- # First line semicolon terminated but second not, usually ok:
- # my $want = "'ab', 'a', 'b'";
- # my $got = join( ", ",
- # map { defined($_) ? "'$_'" : "undef" }
- # @got );
- # First line not semicolon terminated, Not OK to match:
- # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
- # $$href{-NUM_DIRS} = 0;
- my $pat0 = $rpatterns_0->[0];
- my $pat1 = $rpatterns_1->[0];
+ # shouldn't happen
+ }
+ else {
+ my $pat0 = $rpatterns_0->[ $jmax_0 - 1 ];
+ my $pat1 = $rpatterns_1->[ $jmax_1 - 1 ];
+ $sc_term0 = $pat0 =~ /;b?$/;
+ $sc_term1 = $pat1 =~ /;b?$/;
+ }
- #---------------------------------------------------------
- # Turn off the marginal flag for some types of assignments
- #---------------------------------------------------------
- if ( $is_assignment{$raw_tokb} ) {
+ if ( !$is_marginal && !$sc_term0 ) {
- # undo marginal flag if first line is semicolon terminated
- # and leading patters match
- if ($sc_term0) { # && $sc_term1) {
- $is_marginal = $pat0 ne $pat1;
- }
+ # First line of assignment should be semicolon terminated.
+ # For example, do not align here:
+ # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
+ # $$href{-NUM_DIRS} = 0;
+ if ( $is_assignment{$raw_tokb} ) {
+ $is_marginal = 1;
}
- elsif ( $raw_tokb eq '=>' ) {
+ }
- # undo marginal flag if patterns match
- $is_marginal = $pat0 ne $pat1 || $line_ending_fat_comma;
- }
- elsif ( $raw_tokb eq '=~' ) {
+ # Try to avoid some undesirable alignments of opening tokens
+ # for example, the space between grep and { here:
+ # return map { ( $_ => $_ ) }
+ # grep { /$handles/ } $self->_get_delegate_method_list;
+ $is_marginal ||=
+ ( $raw_tokb eq '(' || $raw_tokb eq '{' )
+ && $jmax_1 == 2
+ && $sc_term0 ne $sc_term1;
+
+ #---------------------------------------
+ # return if this is not a marginal match
+ #---------------------------------------
+ if ( !$is_marginal ) {
+ return ( $is_marginal, $imax_align );
+ }
- # undo marginal flag if both lines are semicolon terminated
- # and leading patters match
- if ( $sc_term1 && $sc_term0 ) {
- $is_marginal = $pat0 ne $pat1;
- }
+ # Undo the marginal match flag in certain cases,
+
+ # Two lines with a leading equals-like operator are allowed to
+ # align if the patterns to the left of the equals are the same.
+ # For example the following two lines are a marginal match but have
+ # the same left side patterns, so we will align the equals.
+ # my $orig = my $format = "^<<<<< ~~\n";
+ # my $abc = "abc";
+ # But these have a different left pattern so they will not be
+ # aligned
+ # $xmldoc .= $`;
+ # $self->{'leftovers'} .= "<bx-seq:seq" . $';
+
+ # First line semicolon terminated but second not, usually ok:
+ # my $want = "'ab', 'a', 'b'";
+ # my $got = join( ", ",
+ # map { defined($_) ? "'$_'" : "undef" }
+ # @got );
+ # First line not semicolon terminated, Not OK to match:
+ # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
+ # $$href{-NUM_DIRS} = 0;
+ my $pat0 = $rpatterns_0->[0];
+ my $pat1 = $rpatterns_1->[0];
+
+ #---------------------------------------------------------
+ # Turn off the marginal flag for some types of assignments
+ #---------------------------------------------------------
+ if ( $is_assignment{$raw_tokb} ) {
+
+ # undo marginal flag if first line is semicolon terminated
+ # and leading patters match
+ if ($sc_term0) { # && $sc_term1) {
+ $is_marginal = $pat0 ne $pat1;
}
- else {
- ##ok: (none of the above)
+ }
+ elsif ( $raw_tokb eq '=>' ) {
+
+ # undo marginal flag if patterns match
+ $is_marginal = $pat0 ne $pat1 || $line_ending_fat_comma;
+ }
+ elsif ( $raw_tokb eq '=~' ) {
+
+ # undo marginal flag if both lines are semicolon terminated
+ # and leading patters match
+ if ( $sc_term1 && $sc_term0 ) {
+ $is_marginal = $pat0 ne $pat1;
}
+ }
+ else {
+ ##ok: (none of the above)
+ }
- #-----------------------------------------------------
- # Turn off the marginal flag if we saw an 'if' or 'or'
- #-----------------------------------------------------
+ #-----------------------------------------------------
+ # Turn off the marginal flag if we saw an 'if' or 'or'
+ #-----------------------------------------------------
- # A trailing 'if' and 'or' often gives a good alignment
- # For example, we can align these:
- # return -1 if $_[0] =~ m/^CHAPT|APPENDIX/;
- # return $1 + 0 if $_[0] =~ m/^SECT(\d*)$/;
+ # A trailing 'if' and 'or' often gives a good alignment
+ # For example, we can align these:
+ # return -1 if $_[0] =~ m/^CHAPT|APPENDIX/;
+ # return $1 + 0 if $_[0] =~ m/^SECT(\d*)$/;
- # or
- # $d_in_m[2] = 29 if ( &Date_LeapYear($y) );
- # $d = $d_in_m[$m] if ( $d > $d_in_m[$m] );
+ # or
+ # $d_in_m[2] = 29 if ( &Date_LeapYear($y) );
+ # $d = $d_in_m[$m] if ( $d > $d_in_m[$m] );
- if ($saw_if_or) {
+ if ($saw_if_or) {
- # undo marginal flag if both lines are semicolon terminated
- if ( $sc_term0 && $sc_term1 ) {
- $is_marginal = 0;
- }
+ # undo marginal flag if both lines are semicolon terminated
+ if ( $sc_term0 && $sc_term1 ) {
+ $is_marginal = 0;
}
+ }
- # For a marginal match, only keep matches before the first 'bad' match
- if ( $is_marginal
- && defined($jfirst_bad)
- && $imax_align > $jfirst_bad - 1 )
- {
- $imax_align = $jfirst_bad - 1;
- }
+ # For a marginal match, only keep matches before the first 'bad' match
+ if ( $is_marginal
+ && defined($jfirst_bad)
+ && $imax_align > $jfirst_bad - 1 )
+ {
+ $imax_align = $jfirst_bad - 1;
+ }
+
+ #----------------------------------------------------------
+ # Allow sweep to match lines with leading '=' in some cases
+ #----------------------------------------------------------
+ if ( $imax_align < 0 && defined($j0_eq_pad) ) {
- #----------------------------------------------------------
- # Allow sweep to match lines with leading '=' in some cases
- #----------------------------------------------------------
- if ( $imax_align < 0 && defined($j0_eq_pad) ) {
+ if (
- if (
+ # If there is a following line with leading equals, or
+ # preceding line with leading equals, then let the sweep align
+ # them without restriction. For example, the first two lines
+ # here are a marginal match, but they are followed by a line
+ # with leading equals, so the sweep-lr logic can align all of
+ # the lines:
- # If there is a following line with leading equals, or
- # preceding line with leading equals, then let the sweep align
- # them without restriction. For example, the first two lines
- # here are a marginal match, but they are followed by a line
- # with leading equals, so the sweep-lr logic can align all of
- # the lines:
-
- # $date[1] = $month_to_num{ $date[1] }; # <--line_0
- # @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
- # $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
- # $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
-
- # Likewise, if we reverse the two pairs we want the same result
-
- # $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
- # $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
- # $date[1] = $month_to_num{ $date[1] }; # <--line_0
- # @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
-
- (
- $imax_next >= 0
- || $imax_prev >= 0
- || TEST_MARGINAL_EQ_ALIGNMENT
- )
- && $j0_eq_pad >= -$j0_max_pad
- && $j0_eq_pad <= $j0_max_pad
- )
- {
+ # $date[1] = $month_to_num{ $date[1] }; # <--line_0
+ # @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
+ # $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
+ # $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
- # But do not do this if there is a comma before the '='.
- # For example, the first two lines below have commas and
- # therefore are not allowed to align with lines 3 & 4:
+ # Likewise, if we reverse the two pairs we want the same result
- # my ( $x, $y ) = $self->Size(); #<--line_0
- # my ( $left, $top, $right, $bottom ) = $self->Window(); #<--l_1
- # my $vx = $right - $left;
- # my $vy = $bottom - $top;
+ # $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
+ # $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
+ # $date[1] = $month_to_num{ $date[1] }; # <--line_0
+ # @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
- if ( $rpatterns_0->[0] !~ /,/ && $rpatterns_1->[0] !~ /,/ ) {
- $imax_align = 0;
- }
+ (
+ $imax_next >= 0
+ || $imax_prev >= 0
+ || TEST_MARGINAL_EQ_ALIGNMENT
+ )
+ && $j0_eq_pad >= -$j0_max_pad
+ && $j0_eq_pad <= $j0_max_pad
+ )
+ {
+
+ # But do not do this if there is a comma before the '='.
+ # For example, the first two lines below have commas and
+ # therefore are not allowed to align with lines 3 & 4:
+
+ # my ( $x, $y ) = $self->Size(); #<--line_0
+ # my ( $left, $top, $right, $bottom ) = $self->Window(); #<--l_1
+ # my $vx = $right - $left;
+ # my $vy = $bottom - $top;
+
+ if ( $rpatterns_0->[0] !~ /,/ && $rpatterns_1->[0] !~ /,/ ) {
+ $imax_align = 0;
}
}
+ }
- return ( $is_marginal, $imax_align );
- } ## end sub is_marginal_match
-} ## end closure for sub is_marginal_match
+ return ( $is_marginal, $imax_align );
+} ## end sub is_marginal_match
sub get_extra_leading_spaces {
projects / perltidy.git / commitdiff