File: C:/xampp/perl/vendor/lib/Perl/Tidy/Formatter.pm
#####################################################################
#
# The Perl::Tidy::Formatter package adds indentation, whitespace, and
# line breaks to the token stream
#
# WARNING: This is not a real class for speed reasons. Only one
# Formatter may be used.
#
#####################################################################
package Perl::Tidy::Formatter;
use strict;
use warnings;
use Carp;
our $VERSION = '20200619';
# The Tokenizer will be loaded with the Formatter
##use Perl::Tidy::Tokenizer; # for is_keyword()
sub Die {
my ($msg) = @_;
Perl::Tidy::Die($msg);
croak "unexpected return from Perl::Tidy::Die";
}
sub Warn {
my ($msg) = @_;
Perl::Tidy::Warn($msg);
return;
}
sub Exit {
my ($msg) = @_;
Perl::Tidy::Exit($msg);
croak "unexpected return from Perl::Tidy::Exit";
}
BEGIN {
# Codes for insertion and deletion of blanks
use constant DELETE => 0;
use constant STABLE => 1;
use constant INSERT => 2;
# Caution: these debug flags produce a lot of output
# They should all be 0 except when debugging small scripts
use constant FORMATTER_DEBUG_FLAG_RECOMBINE => 0;
use constant FORMATTER_DEBUG_FLAG_BOND_TABLES => 0;
use constant FORMATTER_DEBUG_FLAG_BOND => 0;
use constant FORMATTER_DEBUG_FLAG_BREAK => 0;
use constant FORMATTER_DEBUG_FLAG_CI => 0;
use constant FORMATTER_DEBUG_FLAG_FLUSH => 0;
use constant FORMATTER_DEBUG_FLAG_FORCE => 0;
use constant FORMATTER_DEBUG_FLAG_LIST => 0;
use constant FORMATTER_DEBUG_FLAG_NOBREAK => 0;
use constant FORMATTER_DEBUG_FLAG_OUTPUT => 0;
use constant FORMATTER_DEBUG_FLAG_SPARSE => 0;
use constant FORMATTER_DEBUG_FLAG_STORE => 0;
use constant FORMATTER_DEBUG_FLAG_UNDOBP => 0;
use constant FORMATTER_DEBUG_FLAG_WHITE => 0;
my $debug_warning = sub {
print STDOUT "FORMATTER_DEBUGGING with key $_[0]\n";
};
FORMATTER_DEBUG_FLAG_RECOMBINE && $debug_warning->('RECOMBINE');
FORMATTER_DEBUG_FLAG_BOND_TABLES && $debug_warning->('BOND_TABLES');
FORMATTER_DEBUG_FLAG_BOND && $debug_warning->('BOND');
FORMATTER_DEBUG_FLAG_BREAK && $debug_warning->('BREAK');
FORMATTER_DEBUG_FLAG_CI && $debug_warning->('CI');
FORMATTER_DEBUG_FLAG_FLUSH && $debug_warning->('FLUSH');
FORMATTER_DEBUG_FLAG_FORCE && $debug_warning->('FORCE');
FORMATTER_DEBUG_FLAG_LIST && $debug_warning->('LIST');
FORMATTER_DEBUG_FLAG_NOBREAK && $debug_warning->('NOBREAK');
FORMATTER_DEBUG_FLAG_OUTPUT && $debug_warning->('OUTPUT');
FORMATTER_DEBUG_FLAG_SPARSE && $debug_warning->('SPARSE');
FORMATTER_DEBUG_FLAG_STORE && $debug_warning->('STORE');
FORMATTER_DEBUG_FLAG_UNDOBP && $debug_warning->('UNDOBP');
FORMATTER_DEBUG_FLAG_WHITE && $debug_warning->('WHITE');
}
use vars qw{
@gnu_stack
$max_gnu_stack_index
$gnu_position_predictor
$line_start_index_to_go
$last_indentation_written
$last_unadjusted_indentation
$last_leading_token
$last_output_short_opening_token
$peak_batch_size
$saw_VERSION_in_this_file
$saw_END_or_DATA_
@gnu_item_list
$max_gnu_item_index
$gnu_sequence_number
$last_output_indentation
%last_gnu_equals
%gnu_comma_count
%gnu_arrow_count
@block_type_to_go
@type_sequence_to_go
@container_environment_to_go
@bond_strength_to_go
@forced_breakpoint_to_go
@token_lengths_to_go
@summed_lengths_to_go
@levels_to_go
@leading_spaces_to_go
@reduced_spaces_to_go
@mate_index_to_go
@ci_levels_to_go
@nesting_depth_to_go
@nobreak_to_go
@old_breakpoint_to_go
@tokens_to_go
@K_to_go
@types_to_go
@inext_to_go
@iprev_to_go
%saved_opening_indentation
$max_index_to_go
@nonblank_lines_at_depth
$starting_in_quote
$ending_in_quote
$format_skipping_pattern_begin
$format_skipping_pattern_end
$forced_breakpoint_count
$forced_breakpoint_undo_count
@forced_breakpoint_undo_stack
%postponed_breakpoint
$tabbing
$embedded_tab_count
$first_embedded_tab_at
$last_embedded_tab_at
$deleted_semicolon_count
$first_deleted_semicolon_at
$last_deleted_semicolon_at
$added_semicolon_count
$first_added_semicolon_at
$last_added_semicolon_at
$first_tabbing_disagreement
$last_tabbing_disagreement
$in_tabbing_disagreement
$tabbing_disagreement_count
$input_line_tabbing
$last_line_leading_type
$last_line_leading_level
$last_last_line_leading_level
%block_leading_text
%block_opening_line_number
$csc_new_statement_ok
$csc_last_label
%csc_block_label
$accumulating_text_for_block
$leading_block_text
$rleading_block_if_elsif_text
$leading_block_text_level
$leading_block_text_length_exceeded
$leading_block_text_line_length
$leading_block_text_line_number
$closing_side_comment_prefix_pattern
$closing_side_comment_list_pattern
$blank_lines_after_opening_block_pattern
$blank_lines_before_closing_block_pattern
$last_output_level
%is_do_follower
%is_if_brace_follower
%space_after_keyword
%is_last_next_redo_return
%is_other_brace_follower
%is_else_brace_follower
%is_anon_sub_brace_follower
%is_anon_sub_1_brace_follower
%is_sort_map_grep
%is_sort_map_grep_eval
%want_one_line_block
%is_sort_map_grep_eval_do
%is_block_without_semicolon
%is_if_unless
%is_and_or
%is_assignment
%is_chain_operator
%is_if_unless_and_or_last_next_redo_return
%ok_to_add_semicolon_for_block_type
@has_broken_sublist
@dont_align
@want_comma_break
$is_static_block_comment
$index_max_forced_break
$input_line_number
$diagnostics_object
$vertical_aligner_object
$logger_object
$file_writer_object
$formatter_self
@ci_stack
%want_break_before
%outdent_keyword
$static_block_comment_pattern
$static_side_comment_pattern
%opening_vertical_tightness
%closing_vertical_tightness
%closing_token_indentation
$some_closing_token_indentation
%keyword_paren_inner_tightness
%opening_token_right
%stack_opening_token
%stack_closing_token
$block_brace_vertical_tightness_pattern
$keyword_group_list_pattern
$keyword_group_list_comment_pattern
$rOpts_closing_side_comment_maximum_text
$rOpts_continuation_indentation
$rOpts_indent_columns
$rOpts_line_up_parentheses
$rOpts_maximum_line_length
$rOpts_variable_maximum_line_length
%is_opening_type
%is_closing_type
%is_keyword_returning_list
%tightness
%matching_token
$rOpts
%right_bond_strength
%left_bond_strength
%binary_ws_rules
%want_left_space
%want_right_space
$bli_pattern
%is_closing_type
%is_opening_type
%is_closing_token
%is_opening_token
%weld_len_left_closing
%weld_len_right_closing
%weld_len_left_opening
%weld_len_right_opening
$rcuddled_block_types
$SUB_PATTERN
$ASUB_PATTERN
$ANYSUB_PATTERN
};
BEGIN {
# Array index names for token variables
my $i = 0;
use constant {
_BLOCK_TYPE_ => $i++,
_CI_LEVEL_ => $i++,
_CONTAINER_ENVIRONMENT_ => $i++,
_CONTAINER_TYPE_ => $i++,
_CUMULATIVE_LENGTH_ => $i++,
_LINE_INDEX_ => $i++,
_KNEXT_SEQ_ITEM_ => $i++,
_LEVEL_ => $i++,
_LEVEL_TRUE_ => $i++,
_SLEVEL_ => $i++,
_TOKEN_ => $i++,
_TOKEN_LENGTH_ => $i++,
_TYPE_ => $i++,
_TYPE_SEQUENCE_ => $i++,
# Number of token variables; must be last in list:
_NVARS => $i++,
};
my @q;
@q = qw(
= **= += *= &= <<= &&=
-= /= |= >>= ||= //=
.= %= ^=
x=
);
@is_assignment{@q} = (1) x scalar(@q);
@q = qw(
grep
keys
map
reverse
sort
split
);
@is_keyword_returning_list{@q} = (1) x scalar(@q);
@q = qw(is if unless and or err last next redo return);
@is_if_unless_and_or_last_next_redo_return{@q} = (1) x scalar(@q);
@q = qw(last next redo return);
@is_last_next_redo_return{@q} = (1) x scalar(@q);
@q = qw(sort map grep);
@is_sort_map_grep{@q} = (1) x scalar(@q);
@q = qw(sort map grep eval);
@is_sort_map_grep_eval{@q} = (1) x scalar(@q);
@q = qw(sort map grep eval do);
@is_sort_map_grep_eval_do{@q} = (1) x scalar(@q);
@q = qw(if unless);
@is_if_unless{@q} = (1) x scalar(@q);
@q = qw(and or err);
@is_and_or{@q} = (1) x scalar(@q);
# Identify certain operators which often occur in chains.
# Note: the minus (-) causes a side effect of padding of the first line in
# something like this (by sub set_logical_padding):
# Checkbutton => 'Transmission checked',
# -variable => \$TRANS
# This usually improves appearance so it seems ok.
@q = qw(&& || and or : ? . + - * /);
@is_chain_operator{@q} = (1) x scalar(@q);
# We can remove semicolons after blocks preceded by these keywords
@q =
qw(BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue if elsif else
unless while until for foreach given when default);
@is_block_without_semicolon{@q} = (1) x scalar(@q);
# We will allow semicolons to be added within these block types
# as well as sub and package blocks.
# NOTES:
# 1. Note that these keywords are omitted:
# switch case given when default sort map grep
# 2. It is also ok to add for sub and package blocks and a labeled block
# 3. But not okay for other perltidy types including:
# { } ; G t
# 4. Test files: blktype.t, blktype1.t, semicolon.t
@q =
qw( BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue if elsif else
unless do while until eval for foreach );
@ok_to_add_semicolon_for_block_type{@q} = (1) x scalar(@q);
# 'L' is token for opening { at hash key
@q = qw< L { ( [ >;
@is_opening_type{@q} = (1) x scalar(@q);
# 'R' is token for closing } at hash key
@q = qw< R } ) ] >;
@is_closing_type{@q} = (1) x scalar(@q);
@q = qw< { ( [ >;
@is_opening_token{@q} = (1) x scalar(@q);
@q = qw< } ) ] >;
@is_closing_token{@q} = (1) x scalar(@q);
}
# whitespace codes
use constant WS_YES => 1;
use constant WS_OPTIONAL => 0;
use constant WS_NO => -1;
# Token bond strengths.
use constant NO_BREAK => 10000;
use constant VERY_STRONG => 100;
use constant STRONG => 2.1;
use constant NOMINAL => 1.1;
use constant WEAK => 0.8;
use constant VERY_WEAK => 0.55;
# values for testing indexes in output array
use constant UNDEFINED_INDEX => -1;
# Maximum number of little messages; probably need not be changed.
use constant MAX_NAG_MESSAGES => 6;
# increment between sequence numbers for each type
# For example, ?: pairs might have numbers 7,11,15,...
use constant TYPE_SEQUENCE_INCREMENT => 4;
{
# methods to count instances
my $_count = 0;
sub get_count { return $_count; }
sub _increment_count { return ++$_count }
sub _decrement_count { return --$_count }
}
sub trim {
# trim leading and trailing whitespace from a string
my $str = shift;
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return $str;
}
sub max {
my @vals = @_;
my $max = shift @vals;
foreach my $val (@vals) {
$max = ( $max < $val ) ? $val : $max;
}
return $max;
}
sub min {
my @vals = @_;
my $min = shift @vals;
foreach my $val (@vals) {
$min = ( $min > $val ) ? $val : $min;
}
return $min;
}
sub split_words {
# given a string containing words separated by whitespace,
# return the list of words
my ($str) = @_;
return unless $str;
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return split( /\s+/, $str );
}
sub check_keys {
my ( $rtest, $rvalid, $msg, $exact_match ) = @_;
# Check the keys of a hash:
# $rtest = ref to hash to test
# $rvalid = ref to hash with valid keys
# $msg = a message to write in case of error
# $exact_match defines the type of check:
# = false: test hash must not have unknown key
# = true: test hash must have exactly same keys as known hash
my @unknown_keys =
grep { !exists $rvalid->{$_} } keys %{$rtest};
my @missing_keys =
grep { !exists $rtest->{$_} } keys %{$rvalid};
my $error = @unknown_keys;
if ($exact_match) { $error ||= @missing_keys }
if ($error) {
local $" = ')(';
my @expected_keys = sort keys %{$rvalid};
@unknown_keys = sort @unknown_keys;
Die(<<EOM);
------------------------------------------------------------------------
Program error detected checking hash keys
Message is: '$msg'
Expected keys: (@expected_keys)
Unknown key(s): (@unknown_keys)
Missing key(s): (@missing_keys)
------------------------------------------------------------------------
EOM
}
return;
}
# interface to Perl::Tidy::Logger routines
sub warning {
my ($msg) = @_;
if ($logger_object) { $logger_object->warning($msg); }
return;
}
sub complain {
my ($msg) = @_;
if ($logger_object) {
$logger_object->complain($msg);
}
return;
}
sub write_logfile_entry {
my @msg = @_;
if ($logger_object) {
$logger_object->write_logfile_entry(@msg);
}
return;
}
sub black_box {
my @msg = @_;
if ($logger_object) { $logger_object->black_box(@msg); }
return;
}
sub report_definite_bug {
if ($logger_object) {
$logger_object->report_definite_bug();
}
return;
}
sub get_saw_brace_error {
if ($logger_object) {
return $logger_object->get_saw_brace_error();
}
return;
}
sub we_are_at_the_last_line {
if ($logger_object) {
$logger_object->we_are_at_the_last_line();
}
return;
}
# interface to Perl::Tidy::Diagnostics routine
sub write_diagnostics {
my $msg = shift;
if ($diagnostics_object) { $diagnostics_object->write_diagnostics($msg); }
return;
}
sub get_added_semicolon_count {
my $self = shift;
return $added_semicolon_count;
}
sub DESTROY {
my $self = shift;
$self->_decrement_count();
return;
}
sub get_output_line_number {
return $vertical_aligner_object->get_output_line_number();
}
sub new {
my ( $class, @args ) = @_;
# we are given an object with a write_line() method to take lines
my %defaults = (
sink_object => undef,
diagnostics_object => undef,
logger_object => undef,
length_function => sub { return length( $_[0] ) },
fh_tee => undef,
);
my %args = ( %defaults, @args );
my $length_function = $args{length_function};
my $fh_tee = $args{fh_tee};
$logger_object = $args{logger_object};
$diagnostics_object = $args{diagnostics_object};
# we create another object with a get_line() and peek_ahead() method
my $sink_object = $args{sink_object};
$file_writer_object =
Perl::Tidy::FileWriter->new( $sink_object, $rOpts, $logger_object );
# initialize the leading whitespace stack to negative levels
# so that we can never run off the end of the stack
$peak_batch_size = 0; # flag to determine if we have output code
$gnu_position_predictor = 0; # where the current token is predicted to be
$max_gnu_stack_index = 0;
$max_gnu_item_index = -1;
$gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
@gnu_item_list = ();
$last_output_indentation = 0;
$last_indentation_written = 0;
$last_unadjusted_indentation = 0;
$last_leading_token = "";
$last_output_short_opening_token = 0;
$saw_VERSION_in_this_file = !$rOpts->{'pass-version-line'};
$saw_END_or_DATA_ = 0;
@block_type_to_go = ();
@type_sequence_to_go = ();
@container_environment_to_go = ();
@bond_strength_to_go = ();
@forced_breakpoint_to_go = ();
@summed_lengths_to_go = (); # line length to start of ith token
@token_lengths_to_go = ();
@levels_to_go = ();
@mate_index_to_go = ();
@ci_levels_to_go = ();
@nesting_depth_to_go = (0);
@nobreak_to_go = ();
@old_breakpoint_to_go = ();
@tokens_to_go = ();
@K_to_go = ();
@types_to_go = ();
@leading_spaces_to_go = ();
@reduced_spaces_to_go = ();
@inext_to_go = ();
@iprev_to_go = ();
@dont_align = ();
@has_broken_sublist = ();
@want_comma_break = ();
@ci_stack = ("");
$first_tabbing_disagreement = 0;
$last_tabbing_disagreement = 0;
$tabbing_disagreement_count = 0;
$in_tabbing_disagreement = 0;
$input_line_tabbing = undef;
$last_last_line_leading_level = 0;
$last_line_leading_level = 0;
$last_line_leading_type = '#';
$last_output_level = 0;
$embedded_tab_count = 0;
$first_embedded_tab_at = 0;
$last_embedded_tab_at = 0;
$deleted_semicolon_count = 0;
$first_deleted_semicolon_at = 0;
$last_deleted_semicolon_at = 0;
$added_semicolon_count = 0;
$first_added_semicolon_at = 0;
$last_added_semicolon_at = 0;
$is_static_block_comment = 0;
%postponed_breakpoint = ();
# variables for adding side comments
%block_leading_text = ();
%block_opening_line_number = ();
$csc_new_statement_ok = 1;
%csc_block_label = ();
%saved_opening_indentation = ();
initialize_process_line_of_CODE();
reset_block_text_accumulator();
prepare_for_new_input_lines();
$vertical_aligner_object = Perl::Tidy::VerticalAligner->initialize(
rOpts => $rOpts,
file_writer_object => $file_writer_object,
logger_object => $logger_object,
diagnostics_object => $diagnostics_object,
length_function => $length_function
);
if ( $rOpts->{'entab-leading-whitespace'} ) {
write_logfile_entry(
"Leading whitespace will be entabbed with $rOpts->{'entab-leading-whitespace'} spaces per tab\n"
);
}
elsif ( $rOpts->{'tabs'} ) {
write_logfile_entry("Indentation will be with a tab character\n");
}
else {
write_logfile_entry(
"Indentation will be with $rOpts->{'indent-columns'} spaces\n");
}
# This hash holds the main data structures for formatting
# All hash keys must be defined here.
$formatter_self = {
rlines => [], # = ref to array of lines of the file
rlines_new => [], # = ref to array of output lines
# (FOR FUTURE DEVELOPMENT)
rLL => [], # = ref to array with all tokens
# in the file. LL originally meant
# 'Linked List'. Linked lists were a
# bad idea but LL is easy to type.
Klimit => undef, # = maximum K index for rLL. This is
# needed to catch any autovivification
# problems.
rnested_pairs => [], # for welding decisions
K_opening_container => {}, # for quickly traversing structure
K_closing_container => {}, # for quickly traversing structure
K_opening_ternary => {}, # for quickly traversing structure
K_closing_ternary => {}, # for quickly traversing structure
rcontainer_map => {}, # hierarchical map of containers
rK_phantom_semicolons =>
undef, # for undoing phantom semicolons if iterating
rpaired_to_inner_container => {},
rbreak_container => {}, # prevent one-line blocks
rshort_nested => {}, # blocks not forced open
rvalid_self_keys => [], # for checking
valign_batch_count => 0,
length_function => $length_function,
fh_tee => $fh_tee,
sink_object => $sink_object,
logger_object => $logger_object,
file_writer_object => $file_writer_object,
radjusted_levels => [],
};
my @valid_keys = keys %{$formatter_self};
$formatter_self->{rvalid_self_keys} = \@valid_keys;
bless $formatter_self, $class;
# Safety check..this is not a class yet
if ( _increment_count() > 1 ) {
confess
"Attempt to create more than 1 object in $class, which is not a true class yet\n";
}
return $formatter_self;
}
sub increment_valign_batch_count {
my ($self) = shift;
return ++$self->{valign_batch_count};
}
sub get_valign_batch_count {
my ($self) = shift;
return $self->{valign_batch_count};
}
sub Fault {
my ($msg) = @_;
# This routine is called for errors that really should not occur
# except if there has been a bug introduced by a recent program change
my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
my $input_stream_name = $logger_object->get_input_stream_name();
Die(<<EOM);
==============================================================================
While operating on input stream with name: '$input_stream_name'
A fault was detected at line $line0 of sub '$subroutine1'
in file '$filename1'
which was called from line $line1 of sub '$subroutine2'
Message: '$msg'
This is probably an error introduced by a recent programming change.
==============================================================================
EOM
# This is for Perl-Critic
return;
}
sub check_self_hash {
my $self = shift;
my @valid_self_keys = @{ $self->{rvalid_self_keys} };
my %valid_self_hash;
@valid_self_hash{@valid_self_keys} = (1) x scalar(@valid_self_keys);
check_keys( $self, \%valid_self_hash, "Checkpoint: self error", 1 );
return;
}
sub check_token_array {
my $self = shift;
# Check for errors in the array of tokens
$self->check_self_hash();
my $rLL = $self->{rLL};
for ( my $KK = 0 ; $KK < @{$rLL} ; $KK++ ) {
my $nvars = @{ $rLL->[$KK] };
if ( $nvars != _NVARS ) {
my $NVARS = _NVARS;
my $type = $rLL->[$KK]->[_TYPE_];
$type = '*' unless defined($type);
Fault(
"number of vars for node $KK, type '$type', is $nvars but should be $NVARS"
);
}
foreach my $var ( _TOKEN_, _TYPE_ ) {
if ( !defined( $rLL->[$KK]->[$var] ) ) {
my $iline = $rLL->[$KK]->[_LINE_INDEX_];
Fault("Undefined variable $var for K=$KK, line=$iline\n");
}
}
}
return;
}
sub set_rLL_max_index {
my $self = shift;
# Set the limit of the rLL array, assuming that it is correct.
# This should only be called by routines after they make changes
# to tokenization
my $rLL = $self->{rLL};
if ( !defined($rLL) ) {
# Shouldn't happen because rLL was initialized to be an array ref
Fault("Undefined Memory rLL");
}
my $Klimit_old = $self->{Klimit};
my $num = @{$rLL};
my $Klimit;
if ( $num > 0 ) { $Klimit = $num - 1 }
$self->{Klimit} = $Klimit;
return ($Klimit);
}
sub get_rLL_max_index {
my $self = shift;
# the memory location $rLL and number of tokens should be obtained
# from this routine so that any autovivication can be immediately caught.
my $rLL = $self->{rLL};
my $Klimit = $self->{Klimit};
if ( !defined($rLL) ) {
# Shouldn't happen because rLL was initialized to be an array ref
Fault("Undefined Memory rLL");
}
my $num = @{$rLL};
if ( $num == 0 && defined($Klimit)
|| $num > 0 && !defined($Klimit)
|| $num > 0 && $Klimit != $num - 1 )
{
# Possible autovivification problem...
if ( !defined($Klimit) ) { $Klimit = '*' }
Fault("Error getting rLL: Memory items=$num and Klimit=$Klimit");
}
return ($Klimit);
}
sub prepare_for_new_input_lines {
# Remember the largest batch size processed. This is needed
# by the pad routine to avoid padding the first nonblank token
if ( $max_index_to_go && $max_index_to_go > $peak_batch_size ) {
$peak_batch_size = $max_index_to_go;
}
$gnu_sequence_number++; # increment output batch counter
%last_gnu_equals = ();
%gnu_comma_count = ();
%gnu_arrow_count = ();
$line_start_index_to_go = 0;
$max_gnu_item_index = UNDEFINED_INDEX;
$index_max_forced_break = UNDEFINED_INDEX;
$max_index_to_go = UNDEFINED_INDEX;
$forced_breakpoint_count = 0;
$forced_breakpoint_undo_count = 0;
$summed_lengths_to_go[0] = 0;
$starting_in_quote = 0;
initialize_batch_variables();
return;
}
sub keyword_group_scan {
my $self = shift;
# Manipulate blank lines around keyword groups (kgb* flags)
# Scan all lines looking for runs of consecutive lines beginning with
# selected keywords. Example keywords are 'my', 'our', 'local', ... but
# they may be anything. We will set flags requesting that blanks be
# inserted around and within them according to input parameters. Note
# that we are scanning the lines as they came in in the input stream, so
# they are not necessarily well formatted.
# The output of this sub is a return hash ref whose keys are the indexes of
# lines after which we desire a blank line. For line index i:
# $rhash_of_desires->{$i} = 1 means we want a blank line AFTER line $i
# $rhash_of_desires->{$i} = 2 means we want blank line $i removed
my $rhash_of_desires = {};
my $Opt_blanks_before = $rOpts->{'keyword-group-blanks-before'}; # '-kgbb'
my $Opt_blanks_after = $rOpts->{'keyword-group-blanks-after'}; # '-kgba'
my $Opt_blanks_inside = $rOpts->{'keyword-group-blanks-inside'}; # '-kgbi'
my $Opt_blanks_delete = $rOpts->{'keyword-group-blanks-delete'}; # '-kgbd'
my $Opt_size = $rOpts->{'keyword-group-blanks-size'}; # '-kgbs'
# A range of sizes can be input with decimal notation like 'min.max' with
# any number of dots between the two numbers. Examples:
# string => min max matches
# 1.1 1 1 exactly 1
# 1.3 1 3 1,2, or 3
# 1..3 1 3 1,2, or 3
# 5 5 - 5 or more
# 6. 6 - 6 or more
# .2 - 2 up to 2
# 1.0 1 0 nothing
my ( $Opt_size_min, $Opt_size_max ) = split /\.+/, $Opt_size;
if ( $Opt_size_min && $Opt_size_min !~ /^\d+$/
|| $Opt_size_max && $Opt_size_max !~ /^\d+$/ )
{
Warn(<<EOM);
Unexpected value for -kgbs: '$Opt_size'; expecting 'min' or 'min.max';
ignoring all -kgb flags
EOM
return $rhash_of_desires;
}
$Opt_size_min = 1 unless ($Opt_size_min);
if ( $Opt_size_max && $Opt_size_max < $Opt_size_min ) {
return $rhash_of_desires;
}
# codes for $Opt_blanks_before and $Opt_blanks_after:
# 0 = never (delete if exist)
# 1 = stable (keep unchanged)
# 2 = always (insert if missing)
return $rhash_of_desires
unless $Opt_size_min > 0
&& ( $Opt_blanks_before != 1
|| $Opt_blanks_after != 1
|| $Opt_blanks_inside
|| $Opt_blanks_delete );
my $Opt_pattern = $keyword_group_list_pattern;
my $Opt_comment_pattern = $keyword_group_list_comment_pattern;
my $Opt_repeat_count =
$rOpts->{'keyword-group-blanks-repeat-count'}; # '-kgbr'
my $rlines = $self->{rlines};
my $rLL = $self->{rLL};
my $K_closing_container = $self->{K_closing_container};
# variables for the current group and subgroups:
my ( $ibeg, $iend, $count, $level_beg, $K_closing, @iblanks, @group,
@subgroup );
# Definitions:
# ($ibeg, $iend) = starting and ending line indexes of this entire group
# $count = total number of keywords seen in this entire group
# $level_beg = indententation level of this group
# @group = [ $i, $token, $count ] =list of all keywords & blanks
# @subgroup = $j, index of group where token changes
# @iblanks = line indexes of blank lines in input stream in this group
# where i=starting line index
# token (the keyword)
# count = number of this token in this subgroup
# j = index in group where token changes
#
# These vars will contain values for the most recently seen line:
my ( $line_type, $CODE_type, $K_first, $K_last );
my $number_of_groups_seen = 0;
####################
# helper subroutines
####################
my $insert_blank_after = sub {
my ($i) = @_;
$rhash_of_desires->{$i} = 1;
my $ip = $i + 1;
if ( defined( $rhash_of_desires->{$ip} )
&& $rhash_of_desires->{$ip} == 2 )
{
$rhash_of_desires->{$ip} = 0;
}
return;
};
my $split_into_sub_groups = sub {
# place blanks around long sub-groups of keywords
# ...if requested
return unless ($Opt_blanks_inside);
# loop over sub-groups, index k
push @subgroup, scalar @group;
my $kbeg = 1;
my $kend = @subgroup - 1;
for ( my $k = $kbeg ; $k <= $kend ; $k++ ) {
# index j runs through all keywords found
my $j_b = $subgroup[ $k - 1 ];
my $j_e = $subgroup[$k] - 1;
# index i is the actual line number of a keyword
my ( $i_b, $tok_b, $count_b ) = @{ $group[$j_b] };
my ( $i_e, $tok_e, $count_e ) = @{ $group[$j_e] };
my $num = $count_e - $count_b + 1;
# This subgroup runs from line $ib to line $ie-1, but may contain
# blank lines
if ( $num >= $Opt_size_min ) {
# if there are blank lines, we require that at least $num lines
# be non-blank up to the boundary with the next subgroup.
my $nog_b = my $nog_e = 1;
if ( @iblanks && !$Opt_blanks_delete ) {
my $j_bb = $j_b + $num - 1;
my ( $i_bb, $tok_bb, $count_bb ) = @{ $group[$j_bb] };
$nog_b = $count_bb - $count_b + 1 == $num;
my $j_ee = $j_e - ( $num - 1 );
my ( $i_ee, $tok_ee, $count_ee ) = @{ $group[$j_ee] };
$nog_e = $count_e - $count_ee + 1 == $num;
}
if ( $nog_b && $k > $kbeg ) {
$insert_blank_after->( $i_b - 1 );
}
if ( $nog_e && $k < $kend ) {
my ( $i_ep, $tok_ep, $count_ep ) = @{ $group[ $j_e + 1 ] };
$insert_blank_after->( $i_ep - 1 );
}
}
}
};
my $delete_if_blank = sub {
my ($i) = @_;
# delete line $i if it is blank
return unless ( $i >= 0 && $i < @{$rlines} );
my $line_type = $rlines->[$i]->{_line_type};
return if ( $line_type ne 'CODE' );
my $code_type = $rlines->[$i]->{_code_type};
if ( $code_type eq 'BL' ) { $rhash_of_desires->{$i} = 2; }
return;
};
my $delete_inner_blank_lines = sub {
# always remove unwanted trailing blank lines from our list
return unless (@iblanks);
while ( my $ibl = pop(@iblanks) ) {
if ( $ibl < $iend ) { push @iblanks, $ibl; last }
$iend = $ibl;
}
# now mark mark interior blank lines for deletion if requested
return unless ($Opt_blanks_delete);
while ( my $ibl = pop(@iblanks) ) { $rhash_of_desires->{$ibl} = 2 }
};
my $end_group = sub {
# end a group of keywords
my ($bad_ending) = @_;
if ( defined($ibeg) && $ibeg >= 0 ) {
# then handle sufficiently large groups
if ( $count >= $Opt_size_min ) {
$number_of_groups_seen++;
# do any blank deletions regardless of the count
$delete_inner_blank_lines->();
if ( $ibeg > 0 ) {
my $code_type = $rlines->[ $ibeg - 1 ]->{_code_type};
# patch for hash bang line which is not currently marked as
# a comment; mark it as a comment
if ( $ibeg == 1 && !$code_type ) {
my $line_text = $rlines->[ $ibeg - 1 ]->{_line_text};
$code_type = 'BC'
if ( $line_text && $line_text =~ /^#/ );
}
# Do not insert a blank after a comment
# (this could be subject to a flag in the future)
if ( $code_type !~ /(BC|SBC|SBCX)/ ) {
if ( $Opt_blanks_before == INSERT ) {
$insert_blank_after->( $ibeg - 1 );
}
elsif ( $Opt_blanks_before == DELETE ) {
$delete_if_blank->( $ibeg - 1 );
}
}
}
# We will only put blanks before code lines. We could loosen
# this rule a little, but we have to be very careful because
# for example we certainly don't want to drop a blank line
# after a line like this:
# my $var = <<EOM;
if ( $line_type eq 'CODE' && defined($K_first) ) {
# - Do not put a blank before a line of different level
# - Do not put a blank line if we ended the search badly
# - Do not put a blank at the end of the file
# - Do not put a blank line before a hanging side comment
my $level = $rLL->[$K_first]->[_LEVEL_];
my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
if ( $level == $level_beg
&& $ci_level == 0
&& !$bad_ending
&& $iend < @{$rlines}
&& $CODE_type ne 'HSC' )
{
if ( $Opt_blanks_after == INSERT ) {
$insert_blank_after->($iend);
}
elsif ( $Opt_blanks_after == DELETE ) {
$delete_if_blank->( $iend + 1 );
}
}
}
}
$split_into_sub_groups->();
}
# reset for another group
$ibeg = -1;
$iend = undef;
$level_beg = -1;
$K_closing = undef;
@group = ();
@subgroup = ();
@iblanks = ();
};
my $find_container_end = sub {
# If the keyword lines ends with an open token, find the closing token
# '$K_closing' so that we can easily skip past the contents of the
# container.
return if ( $K_last <= $K_first );
my $KK = $K_last;
my $type_last = $rLL->[$KK]->[_TYPE_];
my $tok_last = $rLL->[$KK]->[_TOKEN_];
if ( $type_last eq '#' ) {
$KK = $self->K_previous_nonblank($KK);
$tok_last = $rLL->[$KK]->[_TOKEN_];
}
if ( $KK > $K_first && $tok_last =~ /^[\(\{\[]$/ ) {
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $lev = $rLL->[$KK]->[_LEVEL_];
if ( $lev == $level_beg ) {
$K_closing = $K_closing_container->{$type_sequence};
}
}
};
my $add_to_group = sub {
my ( $i, $token, $level ) = @_;
# End the previous group if we have reached the maximum
# group size
if ( $Opt_size_max && @group >= $Opt_size_max ) {
$end_group->();
}
if ( @group == 0 ) {
$ibeg = $i;
$level_beg = $level;
$count = 0;
}
$count++;
$iend = $i;
# New sub-group?
if ( !@group || $token ne $group[-1]->[1] ) {
push @subgroup, scalar(@group);
}
push @group, [ $i, $token, $count ];
# remember if this line ends in an open container
$find_container_end->();
return;
};
###################################
# loop over all lines of the source
###################################
$end_group->();
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$i++;
last
if ( $Opt_repeat_count > 0
&& $number_of_groups_seen >= $Opt_repeat_count );
$CODE_type = "";
$K_first = undef;
$K_last = undef;
$line_type = $line_of_tokens->{_line_type};
# always end a group at non-CODE
if ( $line_type ne 'CODE' ) { $end_group->(); next }
$CODE_type = $line_of_tokens->{_code_type};
# end any group at a format skipping line
if ( $CODE_type && $CODE_type eq 'FS' ) {
$end_group->();
next;
}
# continue in a verbatim (VB) type; it may be quoted text
if ( $CODE_type eq 'VB' ) {
if ( $ibeg >= 0 ) { $iend = $i; }
next;
}
# and continue in blank (BL) types
if ( $CODE_type eq 'BL' ) {
if ( $ibeg >= 0 ) {
$iend = $i;
push @{iblanks}, $i;
# propagate current subgroup token
my $tok = $group[-1]->[1];
push @group, [ $i, $tok, $count ];
}
next;
}
# examine the first token of this line
my $rK_range = $line_of_tokens->{_rK_range};
( $K_first, $K_last ) = @{$rK_range};
if ( !defined($K_first) ) {
# Unexpected blank line..shouldn't happen
# $rK_range should be defined for line type CODE
Warn(
"Programming Error: Unexpected Blank Line in sub 'keyword_group_scan'. Ignoring"
);
return $rhash_of_desires;
}
my $level = $rLL->[$K_first]->[_LEVEL_];
my $type = $rLL->[$K_first]->[_TYPE_];
my $token = $rLL->[$K_first]->[_TOKEN_];
my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
# see if this is a code type we seek (i.e. comment)
if ( $CODE_type
&& $Opt_comment_pattern
&& $CODE_type =~ /$Opt_comment_pattern/ )
{
my $tok = $CODE_type;
# Continuing a group
if ( $ibeg >= 0 && $level == $level_beg ) {
$add_to_group->( $i, $tok, $level );
}
# Start new group
else {
# first end old group if any; we might be starting new
# keywords at different level
if ( $ibeg > 0 ) { $end_group->(); }
$add_to_group->( $i, $tok, $level );
}
next;
}
# See if it is a keyword we seek, but never start a group in a
# continuation line; the code may be badly formatted.
if ( $ci_level == 0
&& $type eq 'k'
&& $token =~ /$Opt_pattern/ )
{
# Continuing a keyword group
if ( $ibeg >= 0 && $level == $level_beg ) {
$add_to_group->( $i, $token, $level );
}
# Start new keyword group
else {
# first end old group if any; we might be starting new
# keywords at different level
if ( $ibeg > 0 ) { $end_group->(); }
$add_to_group->( $i, $token, $level );
}
next;
}
# This is not one of our keywords, but we are in a keyword group
# so see if we should continue or quit
elsif ( $ibeg >= 0 ) {
# - bail out on a large level change; we may have walked into a
# data structure or anoymous sub code.
if ( $level > $level_beg + 1 || $level < $level_beg ) {
$end_group->();
next;
}
# - keep going on a continuation line of the same level, since
# it is probably a continuation of our previous keyword,
# - and keep going past hanging side comments because we never
# want to interrupt them.
if ( ( ( $level == $level_beg ) && $ci_level > 0 )
|| $CODE_type eq 'HSC' )
{
$iend = $i;
next;
}
# - continue if if we are within in a container which started with
# the line of the previous keyword.
if ( defined($K_closing) && $K_first <= $K_closing ) {
# continue if entire line is within container
if ( $K_last <= $K_closing ) { $iend = $i; next }
# continue at ); or }; or ];
my $KK = $K_closing + 1;
if ( $rLL->[$KK]->[_TYPE_] eq ';' ) {
if ( $KK < $K_last ) {
if ( $rLL->[ ++$KK ]->[_TYPE_] eq 'b' ) { ++$KK }
if ( $KK > $K_last || $rLL->[$KK]->[_TYPE_] ne '#' ) {
$end_group->(1);
next;
}
}
$iend = $i;
next;
}
$end_group->(1);
next;
}
# - end the group if none of the above
$end_group->();
next;
}
# not in a keyword group; continue
else { next }
}
# end of loop over all lines
$end_group->();
return $rhash_of_desires;
}
sub process_all_lines {
# Loop over old lines to set new line break points
my $self = shift;
my $rlines = $self->{rlines};
my $sink_object = $self->{sink_object};
my $fh_tee = $self->{fh_tee};
my $rOpts_keep_old_blank_lines = $rOpts->{'keep-old-blank-lines'};
# Note for RT#118553, leave only one newline at the end of a file.
# Example code to do this is in comments below:
# my $Opt_trim_ending_blank_lines = 0;
# if ($Opt_trim_ending_blank_lines) {
# while ( my $line_of_tokens = pop @{$rlines} ) {
# my $line_type = $line_of_tokens->{_line_type};
# if ( $line_type eq 'CODE' ) {
# my $CODE_type = $line_of_tokens->{_code_type};
# next if ( $CODE_type eq 'BL' );
# }
# push @{$rlines}, $line_of_tokens;
# last;
# }
# }
# But while this would be a trivial update, it would have very undesirable
# side effects when perltidy is run from within an editor on a small snippet.
# So this is best done with a separate filter, such
# as 'delete_ending_blank_lines.pl' in the examples folder.
# Flag to prevent blank lines when POD occurs in a format skipping sect.
my $in_format_skipping_section;
# set locations for blanks around long runs of keywords
my $rwant_blank_line_after = $self->keyword_group_scan();
my $line_type = "";
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$i++;
# insert blank lines requested for keyword sequences
if ( $i > 0
&& defined( $rwant_blank_line_after->{ $i - 1 } )
&& $rwant_blank_line_after->{ $i - 1 } == 1 )
{
$self->want_blank_line();
}
my $last_line_type = $line_type;
$line_type = $line_of_tokens->{_line_type};
my $input_line = $line_of_tokens->{_line_text};
# _line_type codes are:
# SYSTEM - system-specific code before hash-bang line
# CODE - line of perl code (including comments)
# POD_START - line starting pod, such as '=head'
# POD - pod documentation text
# POD_END - last line of pod section, '=cut'
# HERE - text of here-document
# HERE_END - last line of here-doc (target word)
# FORMAT - format section
# FORMAT_END - last line of format section, '.'
# DATA_START - __DATA__ line
# DATA - unidentified text following __DATA__
# END_START - __END__ line
# END - unidentified text following __END__
# ERROR - we are in big trouble, probably not a perl script
# put a blank line after an =cut which comes before __END__ and __DATA__
# (required by podchecker)
if ( $last_line_type eq 'POD_END' && !$saw_END_or_DATA_ ) {
$file_writer_object->reset_consecutive_blank_lines();
if ( !$in_format_skipping_section && $input_line !~ /^\s*$/ ) {
$self->want_blank_line();
}
}
# handle line of code..
if ( $line_type eq 'CODE' ) {
my $CODE_type = $line_of_tokens->{_code_type};
$in_format_skipping_section = $CODE_type eq 'FS';
# Handle blank lines
if ( $CODE_type eq 'BL' ) {
# If keep-old-blank-lines is zero, we delete all
# old blank lines and let the blank line rules generate any
# needed blanks.
# and delete lines requested by the keyword-group logic
my $kgb_keep = !( defined( $rwant_blank_line_after->{$i} )
&& $rwant_blank_line_after->{$i} == 2 );
# But: the keep-old-blank-lines flag has priority over kgb flags
$kgb_keep = 1 if ( $rOpts_keep_old_blank_lines == 2 );
if ( $rOpts_keep_old_blank_lines && $kgb_keep ) {
$self->flush($CODE_type);
$file_writer_object->write_blank_code_line(
$rOpts_keep_old_blank_lines == 2 );
$last_line_leading_type = 'b';
}
next;
}
else {
# let logger see all non-blank lines of code
my $output_line_number = get_output_line_number();
black_box( $line_of_tokens, $output_line_number );
}
# Handle Format Skipping (FS) and Verbatim (VB) Lines
if ( $CODE_type eq 'VB' || $CODE_type eq 'FS' ) {
$self->write_unindented_line("$input_line");
$file_writer_object->reset_consecutive_blank_lines();
next;
}
# Handle all other lines of code
$self->process_line_of_CODE($line_of_tokens);
}
# handle line of non-code..
else {
# set special flags
my $skip_line = 0;
if ( $line_type =~ /^POD/ ) {
# Pod docs should have a preceding blank line. But stay
# out of __END__ and __DATA__ sections, because
# the user may be using this section for any purpose whatsoever
if ( $rOpts->{'delete-pod'} ) { $skip_line = 1; }
if ( $rOpts->{'trim-pod'} ) { $input_line =~ s/\s+$// }
if ( !$skip_line
&& !$in_format_skipping_section
&& $line_type eq 'POD_START'
&& !$saw_END_or_DATA_ )
{
$self->want_blank_line();
}
if ( $rOpts->{'tee-pod'} ) {
$fh_tee->print($input_line) if ($fh_tee);
}
}
# leave the blank counters in a predictable state
# after __END__ or __DATA__
elsif ( $line_type =~ /^(END_START|DATA_START)$/ ) {
$file_writer_object->reset_consecutive_blank_lines();
$saw_END_or_DATA_ = 1;
}
# write unindented non-code line
if ( !$skip_line ) {
$self->write_unindented_line($input_line);
}
}
}
return;
}
{ ## Beginning of routine to check line hashes
my %valid_line_hash;
BEGIN {
# These keys are defined for each line in the formatter
# Each line must have exactly these quantities
my @valid_line_keys = qw(
_curly_brace_depth
_ending_in_quote
_guessed_indentation_level
_line_number
_line_text
_line_type
_paren_depth
_quote_character
_rK_range
_square_bracket_depth
_starting_in_quote
_ended_in_blank_token
_code_type
_ci_level_0
_level_0
_nesting_blocks_0
_nesting_tokens_0
);
@valid_line_hash{@valid_line_keys} = (1) x scalar(@valid_line_keys);
}
sub check_line_hashes {
my $self = shift;
$self->check_self_hash();
my $rlines = $self->{rlines};
foreach my $rline ( @{$rlines} ) {
my $iline = $rline->{_line_number};
my $line_type = $rline->{_line_type};
check_keys( $rline, \%valid_line_hash,
"Checkpoint: line number =$iline, line_type=$line_type", 1 );
}
return;
}
} ## End check line hashes
sub write_line {
# We are caching tokenized lines as they arrive and converting them to the
# format needed for the final formatting.
my ( $self, $line_of_tokens_old ) = @_;
my $rLL = $self->{rLL};
my $Klimit = $self->{Klimit};
my $rlines_new = $self->{rlines};
my $Kfirst;
my $line_of_tokens = {};
foreach my $key (
qw(
_curly_brace_depth
_ending_in_quote
_guessed_indentation_level
_line_number
_line_text
_line_type
_paren_depth
_quote_character
_square_bracket_depth
_starting_in_quote
)
)
{
$line_of_tokens->{$key} = $line_of_tokens_old->{$key};
}
# Data needed by Logger
$line_of_tokens->{_level_0} = 0;
$line_of_tokens->{_ci_level_0} = 0;
$line_of_tokens->{_nesting_blocks_0} = "";
$line_of_tokens->{_nesting_tokens_0} = "";
# Needed to avoid trimming quotes
$line_of_tokens->{_ended_in_blank_token} = undef;
my $line_type = $line_of_tokens_old->{_line_type};
my $input_line_no = $line_of_tokens_old->{_line_number} - 1;
if ( $line_type eq 'CODE' ) {
my $rtokens = $line_of_tokens_old->{_rtokens};
my $rtoken_type = $line_of_tokens_old->{_rtoken_type};
my $rblock_type = $line_of_tokens_old->{_rblock_type};
my $rcontainer_type = $line_of_tokens_old->{_rcontainer_type};
my $rcontainer_environment =
$line_of_tokens_old->{_rcontainer_environment};
my $rtype_sequence = $line_of_tokens_old->{_rtype_sequence};
my $rlevels = $line_of_tokens_old->{_rlevels};
my $rslevels = $line_of_tokens_old->{_rslevels};
my $rci_levels = $line_of_tokens_old->{_rci_levels};
my $rnesting_blocks = $line_of_tokens_old->{_rnesting_blocks};
my $rnesting_tokens = $line_of_tokens_old->{_rnesting_tokens};
my $jmax = @{$rtokens} - 1;
if ( $jmax >= 0 ) {
$Kfirst = defined($Klimit) ? $Klimit + 1 : 0;
foreach my $j ( 0 .. $jmax ) {
# Clip negative nesting depths to zero to avoid problems.
# Negative values can occur in files with unbalanced containers
my $slevel = $rslevels->[$j];
if ( $slevel < 0 ) { $slevel = 0 }
# But do not clip the 'level' variable yet. We will do this later,
# in sub 'store_token_to_go'. The reason is that in files with
# level errors, the logic in 'weld_cuddled_else' uses a stack
# logic that will give bad welds if we clip levels here.
## if ( $rlevels->[$j] < 0 ) { $rlevels->[$j] = 0 }
my @tokary;
@tokary[
_TOKEN_, _TYPE_,
_BLOCK_TYPE_, _CONTAINER_TYPE_,
_CONTAINER_ENVIRONMENT_, _TYPE_SEQUENCE_,
_LEVEL_, _LEVEL_TRUE_,
_SLEVEL_, _CI_LEVEL_,
_LINE_INDEX_,
]
= (
$rtokens->[$j], $rtoken_type->[$j],
$rblock_type->[$j], $rcontainer_type->[$j],
$rcontainer_environment->[$j], $rtype_sequence->[$j],
$rlevels->[$j], $rlevels->[$j],
$slevel, $rci_levels->[$j],
$input_line_no,
);
push @{$rLL}, \@tokary;
}
$Klimit = @{$rLL} - 1;
# Need to remember if we can trim the input line
$line_of_tokens->{_ended_in_blank_token} =
$rtoken_type->[$jmax] eq 'b';
$line_of_tokens->{_level_0} = $rlevels->[0];
$line_of_tokens->{_ci_level_0} = $rci_levels->[0];
$line_of_tokens->{_nesting_blocks_0} = $rnesting_blocks->[0];
$line_of_tokens->{_nesting_tokens_0} = $rnesting_tokens->[0];
}
}
$line_of_tokens->{_rK_range} = [ $Kfirst, $Klimit ];
$line_of_tokens->{_code_type} = "";
$self->{Klimit} = $Klimit;
push @{$rlines_new}, $line_of_tokens;
return;
}
sub initialize_whitespace_hashes {
# initialize these global hashes, which control the use of
# whitespace around tokens:
#
# %binary_ws_rules
# %want_left_space
# %want_right_space
# %space_after_keyword
#
# Many token types are identical to the tokens themselves.
# See the tokenizer for a complete list. Here are some special types:
# k = perl keyword
# f = semicolon in for statement
# m = unary minus
# p = unary plus
# Note that :: is excluded since it should be contained in an identifier
# Note that '->' is excluded because it never gets space
# parentheses and brackets are excluded since they are handled specially
# curly braces are included but may be overridden by logic, such as
# newline logic.
# NEW_TOKENS: create a whitespace rule here. This can be as
# simple as adding your new letter to @spaces_both_sides, for
# example.
my @opening_type = qw< L { ( [ >;
@is_opening_type{@opening_type} = (1) x scalar(@opening_type);
my @closing_type = qw< R } ) ] >;
@is_closing_type{@closing_type} = (1) x scalar(@closing_type);
my @spaces_both_sides = qw#
+ - * / % ? = . : x < > | & ^ .. << >> ** && .. || // => += -=
.= %= x= &= |= ^= *= <> <= >= == =~ !~ /= != ... <<= >>= ~~ !~~
&&= ||= //= <=> A k f w F n C Y U G v
#;
my @spaces_left_side = qw<
t ! ~ m p { \ h pp mm Z j
>;
push( @spaces_left_side, '#' ); # avoids warning message
my @spaces_right_side = qw<
; } ) ] R J ++ -- **=
>;
push( @spaces_right_side, ',' ); # avoids warning message
%want_left_space = ();
%want_right_space = ();
%binary_ws_rules = ();
# Note that we setting defaults here. Later in processing
# the values of %want_left_space and %want_right_space
# may be overridden by any user settings specified by the
# -wls and -wrs parameters. However the binary_whitespace_rules
# are hardwired and have priority.
@want_left_space{@spaces_both_sides} =
(1) x scalar(@spaces_both_sides);
@want_right_space{@spaces_both_sides} =
(1) x scalar(@spaces_both_sides);
@want_left_space{@spaces_left_side} =
(1) x scalar(@spaces_left_side);
@want_right_space{@spaces_left_side} =
(-1) x scalar(@spaces_left_side);
@want_left_space{@spaces_right_side} =
(-1) x scalar(@spaces_right_side);
@want_right_space{@spaces_right_side} =
(1) x scalar(@spaces_right_side);
$want_left_space{'->'} = WS_NO;
$want_right_space{'->'} = WS_NO;
$want_left_space{'**'} = WS_NO;
$want_right_space{'**'} = WS_NO;
$want_right_space{'CORE::'} = WS_NO;
# These binary_ws_rules are hardwired and have priority over the above
# settings. It would be nice to allow adjustment by the user,
# but it would be complicated to specify.
#
# hash type information must stay tightly bound
# as in : ${xxxx}
$binary_ws_rules{'i'}{'L'} = WS_NO;
$binary_ws_rules{'i'}{'{'} = WS_YES;
$binary_ws_rules{'k'}{'{'} = WS_YES;
$binary_ws_rules{'U'}{'{'} = WS_YES;
$binary_ws_rules{'i'}{'['} = WS_NO;
$binary_ws_rules{'R'}{'L'} = WS_NO;
$binary_ws_rules{'R'}{'{'} = WS_NO;
$binary_ws_rules{'t'}{'L'} = WS_NO;
$binary_ws_rules{'t'}{'{'} = WS_NO;
$binary_ws_rules{'}'}{'L'} = WS_NO;
$binary_ws_rules{'}'}{'{'} = WS_OPTIONAL; # RT#129850; was WS_NO
$binary_ws_rules{'$'}{'L'} = WS_NO;
$binary_ws_rules{'$'}{'{'} = WS_NO;
$binary_ws_rules{'@'}{'L'} = WS_NO;
$binary_ws_rules{'@'}{'{'} = WS_NO;
$binary_ws_rules{'='}{'L'} = WS_YES;
$binary_ws_rules{'J'}{'J'} = WS_YES;
# the following includes ') {'
# as in : if ( xxx ) { yyy }
$binary_ws_rules{']'}{'L'} = WS_NO;
$binary_ws_rules{']'}{'{'} = WS_NO;
$binary_ws_rules{')'}{'{'} = WS_YES;
$binary_ws_rules{')'}{'['} = WS_NO;
$binary_ws_rules{']'}{'['} = WS_NO;
$binary_ws_rules{']'}{'{'} = WS_NO;
$binary_ws_rules{'}'}{'['} = WS_NO;
$binary_ws_rules{'R'}{'['} = WS_NO;
$binary_ws_rules{']'}{'++'} = WS_NO;
$binary_ws_rules{']'}{'--'} = WS_NO;
$binary_ws_rules{')'}{'++'} = WS_NO;
$binary_ws_rules{')'}{'--'} = WS_NO;
$binary_ws_rules{'R'}{'++'} = WS_NO;
$binary_ws_rules{'R'}{'--'} = WS_NO;
$binary_ws_rules{'i'}{'Q'} = WS_YES;
$binary_ws_rules{'n'}{'('} = WS_YES; # occurs in 'use package n ()'
# FIXME: we could to split 'i' into variables and functions
# and have no space for functions but space for variables. For now,
# I have a special patch in the special rules below
$binary_ws_rules{'i'}{'('} = WS_NO;
$binary_ws_rules{'w'}{'('} = WS_NO;
$binary_ws_rules{'w'}{'{'} = WS_YES;
return;
} ## end initialize_whitespace_hashes
sub set_whitespace_flags {
# This routine examines each pair of nonblank tokens and
# sets a flag indicating if white space is needed.
#
# $rwhitespace_flags->[$j] is a flag indicating whether a white space
# BEFORE token $j is needed, with the following values:
#
# WS_NO = -1 do not want a space before token $j
# WS_OPTIONAL= 0 optional space or $j is a whitespace
# WS_YES = 1 want a space before token $j
#
my $self = shift;
my $rLL = $self->{rLL};
my $rOpts_block_brace_tightness = $rOpts->{'block-brace-tightness'};
my $rOpts_space_keyword_paren = $rOpts->{'space-keyword-paren'};
my $rOpts_space_backslash_quote = $rOpts->{'space-backslash-quote'};
my $rOpts_space_function_paren = $rOpts->{'space-function-paren'};
my $rwhitespace_flags = [];
my %is_for_foreach = ( 'for' => 1, 'foreach' => 1 );
my ( $token, $type, $block_type, $seqno, $input_line_no );
my (
$last_token, $last_type, $last_block_type,
$last_seqno, $last_input_line_no
);
my $j_tight_closing_paren = -1;
$token = ' ';
$type = 'b';
$block_type = '';
$seqno = '';
$input_line_no = 0;
$last_token = ' ';
$last_type = 'b';
$last_block_type = '';
$last_seqno = '';
$last_input_line_no = 0;
my $jmax = @{$rLL} - 1;
my ($ws);
# This is some logic moved to a sub to avoid deep nesting of if stmts
my $ws_in_container = sub {
my ($j) = @_;
my $ws = WS_YES;
if ( $j + 1 > $jmax ) { return (WS_NO) }
# Patch to count '-foo' as single token so that
# each of $a{-foo} and $a{foo} and $a{'foo'} do
# not get spaces with default formatting.
my $j_here = $j;
++$j_here
if ( $token eq '-'
&& $last_token eq '{'
&& $rLL->[ $j + 1 ]->[_TYPE_] eq 'w' );
# $j_next is where a closing token should be if
# the container has a single token
if ( $j_here + 1 > $jmax ) { return (WS_NO) }
my $j_next =
( $rLL->[ $j_here + 1 ]->[_TYPE_] eq 'b' )
? $j_here + 2
: $j_here + 1;
if ( $j_next > $jmax ) { return WS_NO }
my $tok_next = $rLL->[$j_next]->[_TOKEN_];
my $type_next = $rLL->[$j_next]->[_TYPE_];
# for tightness = 1, if there is just one token
# within the matching pair, we will keep it tight
if (
$tok_next eq $matching_token{$last_token}
# but watch out for this: [ [ ] (misc.t)
&& $last_token ne $token
# double diamond is usually spaced
&& $token ne '<<>>'
)
{
# remember where to put the space for the closing paren
$j_tight_closing_paren = $j_next;
return (WS_NO);
}
return (WS_YES);
};
# Local hashes to set spaces around container tokens according to their
# sequence numbers. These are set as keywords are examined.
# They are controlled by the -kpit and -kpitl flags.
my %opening_container_inside_ws;
my %closing_container_inside_ws;
my $set_container_ws_by_keyword = sub {
return unless (%keyword_paren_inner_tightness);
my ( $word, $sequence_number ) = @_;
# We just saw a keyword (or other function name) followed by an opening
# paren. Now check to see if the following paren should have special
# treatment for its inside space. If so we set a hash value using the
# sequence number as key.
if ( $word && $sequence_number ) {
my $tightness = $keyword_paren_inner_tightness{$word};
if ( defined($tightness) && $tightness != 1 ) {
my $ws_flag = $tightness == 0 ? WS_YES : WS_NO;
$opening_container_inside_ws{$sequence_number} = $ws_flag;
$closing_container_inside_ws{$sequence_number} = $ws_flag;
}
}
};
my $ws_opening_container_override = sub {
my ( $ws, $sequence_number ) = @_;
return $ws unless (%opening_container_inside_ws);
if ($sequence_number) {
my $ws_override = $opening_container_inside_ws{$sequence_number};
if ($ws_override) { $ws = $ws_override }
}
return $ws;
};
my $ws_closing_container_override = sub {
my ( $ws, $sequence_number ) = @_;
return $ws unless (%closing_container_inside_ws);
if ($sequence_number) {
my $ws_override = $closing_container_inside_ws{$sequence_number};
if ($ws_override) { $ws = $ws_override }
}
return $ws;
};
# main loop over all tokens to define the whitespace flags
for ( my $j = 0 ; $j <= $jmax ; $j++ ) {
my $rtokh = $rLL->[$j];
# Set a default
$rwhitespace_flags->[$j] = WS_OPTIONAL;
if ( $rtokh->[_TYPE_] eq 'b' ) {
next;
}
# set a default value, to be changed as needed
$ws = undef;
$last_token = $token;
$last_type = $type;
$last_block_type = $block_type;
$last_seqno = $seqno;
$last_input_line_no = $input_line_no;
$token = $rtokh->[_TOKEN_];
$type = $rtokh->[_TYPE_];
$block_type = $rtokh->[_BLOCK_TYPE_];
$seqno = $rtokh->[_TYPE_SEQUENCE_];
$input_line_no = $rtokh->[_LINE_INDEX_];
#---------------------------------------------------------------
# Whitespace Rules Section 1:
# Handle space on the inside of opening braces.
#---------------------------------------------------------------
# /^[L\{\(\[]$/
if ( $is_opening_type{$last_type} ) {
$j_tight_closing_paren = -1;
# let us keep empty matched braces together: () {} []
# except for BLOCKS
if ( $token eq $matching_token{$last_token} ) {
if ($block_type) {
$ws = WS_YES;
}
else {
$ws = WS_NO;
}
}
else {
# we're considering the right of an opening brace
# tightness = 0 means always pad inside with space
# tightness = 1 means pad inside if "complex"
# tightness = 2 means never pad inside with space
my $tightness;
if ( $last_type eq '{'
&& $last_token eq '{'
&& $last_block_type )
{
$tightness = $rOpts_block_brace_tightness;
}
else { $tightness = $tightness{$last_token} }
#=============================================================
# Patch for test problem <<snippets/fabrice_bug.in>>
# We must always avoid spaces around a bare word beginning
# with ^ as in:
# my $before = ${^PREMATCH};
# Because all of the following cause an error in perl:
# my $before = ${ ^PREMATCH };
# my $before = ${ ^PREMATCH};
# my $before = ${^PREMATCH };
# So if brace tightness flag is -bt=0 we must temporarily reset
# to bt=1. Note that here we must set tightness=1 and not 2 so
# that the closing space
# is also avoided (via the $j_tight_closing_paren flag in coding)
if ( $type eq 'w' && $token =~ /^\^/ ) { $tightness = 1 }
#=============================================================
if ( $tightness <= 0 ) {
$ws = WS_YES;
}
elsif ( $tightness > 1 ) {
$ws = WS_NO;
}
else {
$ws = $ws_in_container->($j);
}
}
# check for special cases which override the above rules
$ws = $ws_opening_container_override->( $ws, $last_seqno );
} # end setting space flag inside opening tokens
my $ws_1;
$ws_1 = $ws
if FORMATTER_DEBUG_FLAG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 2:
# Handle space on inside of closing brace pairs.
#---------------------------------------------------------------
# /[\}\)\]R]/
if ( $is_closing_type{$type} ) {
if ( $j == $j_tight_closing_paren ) {
$j_tight_closing_paren = -1;
$ws = WS_NO;
}
else {
if ( !defined($ws) ) {
my $tightness;
if ( $type eq '}' && $token eq '}' && $block_type ) {
$tightness = $rOpts_block_brace_tightness;
}
else { $tightness = $tightness{$token} }
$ws = ( $tightness > 1 ) ? WS_NO : WS_YES;
}
}
# check for special cases which override the above rules
$ws = $ws_closing_container_override->( $ws, $seqno );
} # end setting space flag inside closing tokens
my $ws_2;
$ws_2 = $ws
if FORMATTER_DEBUG_FLAG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 3:
# Use the binary rule table.
#---------------------------------------------------------------
if ( !defined($ws) ) {
$ws = $binary_ws_rules{$last_type}{$type};
}
my $ws_3;
$ws_3 = $ws
if FORMATTER_DEBUG_FLAG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 4:
# Handle some special cases.
#---------------------------------------------------------------
if ( $token eq '(' ) {
# This will have to be tweaked as tokenization changes.
# We usually want a space at '} (', for example:
# <<snippets/space1.in>>
# map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
#
# But not others:
# &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
# At present, the above & block is marked as type L/R so this case
# won't go through here.
if ( $last_type eq '}' ) { $ws = WS_YES }
# NOTE: some older versions of Perl had occasional problems if
# spaces are introduced between keywords or functions and opening
# parens. So the default is not to do this except is certain
# cases. The current Perl seems to tolerate spaces.
# Space between keyword and '('
elsif ( $last_type eq 'k' ) {
$ws = WS_NO
unless ( $rOpts_space_keyword_paren
|| $space_after_keyword{$last_token} );
# Set inside space flag if requested
$set_container_ws_by_keyword->( $last_token, $seqno );
}
# Space between function and '('
# -----------------------------------------------------
# 'w' and 'i' checks for something like:
# myfun( &myfun( ->myfun(
# -----------------------------------------------------
elsif (( $last_type =~ /^[wUG]$/ )
|| ( $last_type =~ /^[wi]$/ && $last_token =~ /^(\&|->)/ ) )
{
$ws = WS_NO unless ($rOpts_space_function_paren);
$set_container_ws_by_keyword->( $last_token, $seqno );
}
# space between something like $i and ( in <<snippets/space2.in>>
# for $i ( 0 .. 20 ) {
# FIXME: eventually, type 'i' needs to be split into multiple
# token types so this can be a hardwired rule.
elsif ( $last_type eq 'i' && $last_token =~ /^[\$\%\@]/ ) {
$ws = WS_YES;
}
# allow constant function followed by '()' to retain no space
elsif ($last_type eq 'C'
&& $rLL->[ $j + 1 ]->[_TOKEN_] eq ')' )
{
$ws = WS_NO;
}
}
# patch for SWITCH/CASE: make space at ']{' optional
# since the '{' might begin a case or when block
elsif ( ( $token eq '{' && $type ne 'L' ) && $last_token eq ']' ) {
$ws = WS_OPTIONAL;
}
# keep space between 'sub' and '{' for anonymous sub definition
if ( $type eq '{' ) {
if ( $last_token eq 'sub' ) {
$ws = WS_YES;
}
# this is needed to avoid no space in '){'
if ( $last_token eq ')' && $token eq '{' ) { $ws = WS_YES }
# avoid any space before the brace or bracket in something like
# @opts{'a','b',...}
if ( $last_type eq 'i' && $last_token =~ /^\@/ ) {
$ws = WS_NO;
}
}
elsif ( $type eq 'i' ) {
# never a space before ->
if ( $token =~ /^\-\>/ ) {
$ws = WS_NO;
}
}
# retain any space between '-' and bare word
elsif ( $type eq 'w' || $type eq 'C' ) {
$ws = WS_OPTIONAL if $last_type eq '-';
# never a space before ->
if ( $token =~ /^\-\>/ ) {
$ws = WS_NO;
}
}
# retain any space between '-' and bare word; for example
# avoid space between 'USER' and '-' here: <<snippets/space2.in>>
# $myhash{USER-NAME}='steve';
elsif ( $type eq 'm' || $type eq '-' ) {
$ws = WS_OPTIONAL if ( $last_type eq 'w' );
}
# always space before side comment
elsif ( $type eq '#' ) { $ws = WS_YES if $j > 0 }
# always preserver whatever space was used after a possible
# filehandle (except _) or here doc operator
if (
$type ne '#'
&& ( ( $last_type eq 'Z' && $last_token ne '_' )
|| $last_type eq 'h' )
)
{
$ws = WS_OPTIONAL;
}
# space_backslash_quote; RT #123774 <<snippets/rt123774.in>>
# allow a space between a backslash and single or double quote
# to avoid fooling html formatters
elsif ( $last_type eq '\\' && $type eq 'Q' && $token =~ /^[\"\']/ ) {
if ($rOpts_space_backslash_quote) {
if ( $rOpts_space_backslash_quote == 1 ) {
$ws = WS_OPTIONAL;
}
elsif ( $rOpts_space_backslash_quote == 2 ) { $ws = WS_YES }
else { } # shouldnt happen
}
else {
$ws = WS_NO;
}
}
elsif ( $type eq 'k' ) {
# Keywords 'for', 'foreach' are special cases for -kpit since the
# opening paren does not always immediately follow the keyword. So
# we have to search forward for the paren in this case. I have
# limited the search to 10 tokens ahead, just in case somebody
# has a big file and no opening paren. This should be enough for
# all normal code.
if ( $is_for_foreach{$token}
&& %keyword_paren_inner_tightness
&& defined( $keyword_paren_inner_tightness{$token} )
&& $j < $jmax )
{
my $jp = $j;
for ( my $inc = 1 ; $inc < 10 ; $inc++ ) {
$jp++;
last if ( $jp > $jmax );
next unless ( $rLL->[$jp]->[_TOKEN_] eq '(' );
my $seqno = $rLL->[$jp]->[_TYPE_SEQUENCE_];
$set_container_ws_by_keyword->( $token, $seqno );
last;
}
}
}
my $ws_4;
$ws_4 = $ws
if FORMATTER_DEBUG_FLAG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 5:
# Apply default rules not covered above.
#---------------------------------------------------------------
# If we fall through to here, look at the pre-defined hash tables for
# the two tokens, and:
# if (they are equal) use the common value
# if (either is zero or undef) use the other
# if (either is -1) use it
# That is,
# left vs right
# 1 vs 1 --> 1
# 0 vs 0 --> 0
# -1 vs -1 --> -1
#
# 0 vs -1 --> -1
# 0 vs 1 --> 1
# 1 vs 0 --> 1
# -1 vs 0 --> -1
#
# -1 vs 1 --> -1
# 1 vs -1 --> -1
if ( !defined($ws) ) {
my $wl = $want_left_space{$type};
my $wr = $want_right_space{$last_type};
if ( !defined($wl) ) { $wl = 0 }
if ( !defined($wr) ) { $wr = 0 }
$ws = ( ( $wl == $wr ) || ( $wl == -1 ) || !$wr ) ? $wl : $wr;
}
if ( !defined($ws) ) {
$ws = 0;
write_diagnostics(
"WS flag is undefined for tokens $last_token $token\n");
}
# Treat newline as a whitespace. Otherwise, we might combine
# 'Send' and '-recipients' here according to the above rules:
# <<snippets/space3.in>>
# my $msg = new Fax::Send
# -recipients => $to,
# -data => $data;
if ( $ws == 0 && $input_line_no != $last_input_line_no ) { $ws = 1 }
if ( ( $ws == 0 )
&& $j > 0
&& $j < $jmax
&& ( $last_type !~ /^[Zh]$/ ) )
{
# If this happens, we have a non-fatal but undesirable
# hole in the above rules which should be patched.
write_diagnostics(
"WS flag is zero for tokens $last_token $token\n");
}
$rwhitespace_flags->[$j] = $ws;
FORMATTER_DEBUG_FLAG_WHITE && do {
my $str = substr( $last_token, 0, 15 );
$str .= ' ' x ( 16 - length($str) );
if ( !defined($ws_1) ) { $ws_1 = "*" }
if ( !defined($ws_2) ) { $ws_2 = "*" }
if ( !defined($ws_3) ) { $ws_3 = "*" }
if ( !defined($ws_4) ) { $ws_4 = "*" }
print STDOUT
"NEW WHITE: i=$j $str $last_type $type $ws_1 : $ws_2 : $ws_3 : $ws_4 : $ws \n";
};
} ## end main loop
if ( $rOpts->{'tight-secret-operators'} ) {
new_secret_operator_whitespace( $rLL, $rwhitespace_flags );
}
return $rwhitespace_flags;
} ## end sub set_whitespace_flags
sub respace_tokens {
my $self = shift;
return if $rOpts->{'indent-only'};
# This routine makes all necessary and possible changes to the tokenization
# after the initial tokenization of the file. This is a tedious routine,
# but basically it consists of inserting and deleting whitespace between
# nonblank tokens according to the selected parameters. In a few cases
# non-space characters are added, deleted or modified.
# The goal of this routine is to create a new token array which only needs
# the definition of new line breaks and padding to complete formatting. In
# a few cases we have to cheat a little to achieve this goal. In
# particular, we may not know if a semicolon will be needed, because it
# depends on how the line breaks go. To handle this, we include the
# semicolon as a 'phantom' which can be displayed as normal or as an empty
# string.
# Method: The old tokens are copied one-by-one, with changes, from the old
# linear storage array $rLL to a new array $rLL_new.
my $rLL = $self->{rLL};
my $Klimit_old = $self->{Klimit};
my $rlines = $self->{rlines};
my $rpaired_to_inner_container = $self->{rpaired_to_inner_container};
my $length_function = $self->{length_function};
my $rLL_new = []; # This is the new array
my $KK = 0;
my $rtoken_vars;
my $Kmax = @{$rLL} - 1;
my $CODE_type = "";
my $line_type = "";
my $rOpts_add_whitespace = $rOpts->{'add-whitespace'};
my $rOpts_delete_old_whitespace = $rOpts->{'delete-old-whitespace'};
my $rOpts_one_line_block_semicolons = $rOpts->{'one-line-block-semicolons'};
my $rOpts_ignore_side_comment_lengths =
$rOpts->{'ignore-side-comment-lengths'};
# Set the whitespace flags, which indicate the token spacing preference.
my $rwhitespace_flags = $self->set_whitespace_flags();
# we will be setting token lengths as we go
my $cumulative_length = 0;
# We also define these hash indexes giving container token array indexes
# as a function of the container sequence numbers. For example,
my $K_opening_container = {}; # opening [ { or (
my $K_closing_container = {}; # closing ] } or )
my $K_opening_ternary = {}; # opening ? of ternary
my $K_closing_ternary = {}; # closing : of ternary
# List of new K indexes of phantom semicolons
# This will be needed if we want to undo them for iterations
my $rK_phantom_semicolons = [];
# a sub to link preceding nodes forward to a new node type
my $link_back = sub {
my ( $Ktop, $key ) = @_;
my $Kprev = $Ktop - 1;
while ( $Kprev >= 0
&& !defined( $rLL_new->[$Kprev]->[$key] ) )
{
$rLL_new->[$Kprev]->[$key] = $Ktop;
$Kprev -= 1;
}
};
# A sub to store one token in the new array
# All new tokens must be stored by this sub so that it can update
# all data structures on the fly.
my $last_nonblank_type = ';';
my $last_nonblank_token = ';';
my $last_nonblank_block_type = '';
my $store_token = sub {
my ($item) = @_;
# This will be the index of this item in the new array
my $KK_new = @{$rLL_new};
# check for a sequenced item (i.e., container or ?/:)
my $type_sequence = $item->[_TYPE_SEQUENCE_];
if ($type_sequence) {
$link_back->( $KK_new, _KNEXT_SEQ_ITEM_ );
my $token = $item->[_TOKEN_];
if ( $is_opening_token{$token} ) {
$K_opening_container->{$type_sequence} = $KK_new;
}
elsif ( $is_closing_token{$token} ) {
$K_closing_container->{$type_sequence} = $KK_new;
}
# These are not yet used but could be useful
else {
if ( $token eq '?' ) {
$K_opening_ternary->{$type_sequence} = $KK_new;
}
elsif ( $token eq ':' ) {
$K_closing_ternary->{$type_sequence} = $KK_new;
}
else {
# shouldn't happen
Fault("Ugh: shouldn't happen");
}
}
}
my $type = $item->[_TYPE_];
# trim comments
if ( $type eq '#' ) {
$item->[_TOKEN_] =~ s/\s*$//;
}
# Find the length of this token. Later it may be adjusted if phantom
# or ignoring side comment lengths.
my $token_length = $length_function->( $item->[_TOKEN_] );
# Mark length of side comments as just 1 if their lengths are ignored
if ( $type eq '#'
&& $rOpts_ignore_side_comment_lengths
&& ( !$CODE_type || $CODE_type eq 'HSC' ) )
{
$token_length = 1;
}
$item->[_TOKEN_LENGTH_] = $token_length;
# and update the cumulative length
$cumulative_length += $token_length;
# Save the length sum to just AFTER this token
$item->[_CUMULATIVE_LENGTH_] = $cumulative_length;
if ( $type && $type ne 'b' && $type ne '#' ) {
$last_nonblank_type = $type;
$last_nonblank_token = $item->[_TOKEN_];
$last_nonblank_block_type = $item->[_BLOCK_TYPE_];
}
# and finally, add this item to the new array
push @{$rLL_new}, $item;
};
my $store_token_and_space = sub {
my ( $item, $want_space ) = @_;
# store a token with preceding space if requested and needed
# First store the space
if ( $want_space
&& @{$rLL_new}
&& $rLL_new->[-1]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace )
{
my $rcopy = copy_token_as_type( $item, 'b', ' ' );
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
$store_token->($rcopy);
}
# then the token
$store_token->($item);
};
my $K_end_q = sub {
my ($KK) = @_;
my $K_end = $KK;
my $Kn = $self->K_next_nonblank($KK);
while ( defined($Kn) && $rLL->[$Kn]->[_TYPE_] eq 'q' ) {
$K_end = $Kn;
$Kn = $self->K_next_nonblank($Kn);
}
return $K_end;
};
my $add_phantom_semicolon = sub {
my ($KK) = @_;
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
# we are only adding semicolons for certain block types
my $block_type = $rLL->[$KK]->[_BLOCK_TYPE_];
return
unless ( $ok_to_add_semicolon_for_block_type{$block_type}
|| $block_type =~ /^(sub|package)/
|| $block_type =~ /^\w+\:$/ );
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $previous_nonblank_type = $rLL_new->[$Kp]->[_TYPE_];
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
# Do not add a semicolon if...
return
if (
# it would follow a comment (and be isolated)
$previous_nonblank_type eq '#'
# it follows a code block ( because they are not always wanted
# there and may add clutter)
|| $rLL_new->[$Kp]->[_BLOCK_TYPE_]
# it would follow a label
|| $previous_nonblank_type eq 'J'
# it would be inside a 'format' statement (and cause syntax error)
|| ( $previous_nonblank_type eq 'k'
&& $previous_nonblank_token =~ /format/ )
# if it would prevent welding two containers
|| $rpaired_to_inner_container->{$type_sequence}
);
# We will insert an empty semicolon here as a placeholder. Later, if
# it becomes the last token on a line, we will bring it to life. The
# advantage of doing this is that (1) we just have to check line
# endings, and (2) the phantom semicolon has zero width and therefore
# won't cause needless breaks of one-line blocks.
my $Ktop = -1;
if ( $rLL_new->[$Ktop]->[_TYPE_] eq 'b'
&& $want_left_space{';'} == WS_NO )
{
# convert the blank into a semicolon..
# be careful: we are working on the new stack top
# on a token which has been stored.
my $rcopy = copy_token_as_type( $rLL_new->[$Ktop], 'b', ' ' );
# Convert the existing blank to:
# a phantom semicolon for one_line_block option = 0 or 1
# a real semicolon for one_line_block option = 2
my $tok = '';
my $len_tok = 0;
if ( $rOpts_one_line_block_semicolons == 2 ) {
$tok = ';';
$len_tok = 1;
}
$rLL_new->[$Ktop]->[_TOKEN_] = $tok;
$rLL_new->[$Ktop]->[_TOKEN_LENGTH_] = $len_tok;
$rLL_new->[$Ktop]->[_TYPE_] = ';';
$rLL_new->[$Ktop]->[_SLEVEL_] =
$rLL->[$KK]->[_SLEVEL_];
push @{$rK_phantom_semicolons}, @{$rLL_new} - 1;
# Then store a new blank
$store_token->($rcopy);
}
else {
# insert a new token
my $rcopy = copy_token_as_type( $rLL_new->[$Kp], ';', '' );
$rcopy->[_SLEVEL_] = $rLL->[$KK]->[_SLEVEL_];
$store_token->($rcopy);
push @{$rK_phantom_semicolons}, @{$rLL_new} - 1;
}
};
my $check_Q = sub {
# Check that a quote looks okay
# This sub works but needs to by sync'd with the log file output
# before it can be used.
my ( $KK, $Kfirst ) = @_;
my $token = $rLL->[$KK]->[_TOKEN_];
note_embedded_tab() if ( $token =~ "\t" );
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
my $previous_nonblank_type = $rLL_new->[$Kp]->[_TYPE_];
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
my $previous_nonblank_type_2 = 'b';
my $previous_nonblank_token_2 = "";
my $Kpp = $self->K_previous_nonblank( $Kp, $rLL_new );
if ( defined($Kpp) ) {
$previous_nonblank_type_2 = $rLL_new->[$Kpp]->[_TYPE_];
$previous_nonblank_token_2 = $rLL_new->[$Kpp]->[_TOKEN_];
}
my $Kn = $self->K_next_nonblank($KK);
my $next_nonblank_token = "";
if ( defined($Kn) ) {
$next_nonblank_token = $rLL->[$Kn]->[_TOKEN_];
}
my $token_0 = $rLL->[$Kfirst]->[_TOKEN_];
my $type_0 = $rLL->[$Kfirst]->[_TYPE_];
# make note of something like '$var = s/xxx/yyy/;'
# in case it should have been '$var =~ s/xxx/yyy/;'
if (
$token =~ /^(s|tr|y|m|\/)/
&& $previous_nonblank_token =~ /^(=|==|!=)$/
# preceded by simple scalar
&& $previous_nonblank_type_2 eq 'i'
&& $previous_nonblank_token_2 =~ /^\$/
# followed by some kind of termination
# (but give complaint if we can not see far enough ahead)
&& $next_nonblank_token =~ /^[; \)\}]$/
# scalar is not declared
&& !( $type_0 eq 'k' && $token_0 =~ /^(my|our|local)$/ )
)
{
my $guess = substr( $last_nonblank_token, 0, 1 ) . '~';
complain(
"Note: be sure you want '$previous_nonblank_token' instead of '$guess' here\n"
);
}
};
# Main loop over all lines of the file
my $last_K_out;
# Testing option to break qw. Do not use; it can make a mess.
my $ALLOW_BREAK_MULTILINE_QW = 0;
my $in_multiline_qw;
foreach my $line_of_tokens ( @{$rlines} ) {
$input_line_number = $line_of_tokens->{_line_number};
my $last_line_type = $line_type;
$line_type = $line_of_tokens->{_line_type};
next unless ( $line_type eq 'CODE' );
my $last_CODE_type = $CODE_type;
$CODE_type = $line_of_tokens->{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
next unless defined($Kfirst);
# Check for correct sequence of token indexes...
# An error here means that sub write_line() did not correctly
# package the tokenized lines as it received them.
if ( defined($last_K_out) ) {
if ( $Kfirst != $last_K_out + 1 ) {
Fault(
"Program Bug: last K out was $last_K_out but Kfirst=$Kfirst"
);
}
}
else {
if ( $Kfirst != 0 ) {
Fault("Program Bug: first K is $Kfirst but should be 0");
}
}
$last_K_out = $Klast;
# Handle special lines of code
if ( $CODE_type && $CODE_type ne 'NIN' && $CODE_type ne 'VER' ) {
# CODE_types are as follows.
# 'BL' = Blank Line
# 'VB' = Verbatim - line goes out verbatim
# 'FS' = Format Skipping - line goes out verbatim, no blanks
# 'IO' = Indent Only - only indentation may be changed
# 'NIN' = No Internal Newlines - line does not get broken
# 'HSC'=Hanging Side Comment - fix this hanging side comment
# 'BC'=Block Comment - an ordinary full line comment
# 'SBC'=Static Block Comment - a block comment which does not get
# indented
# 'SBCX'=Static Block Comment Without Leading Space
# 'VER'=VERSION statement
# '' or (undefined) - no restructions
# For a hanging side comment we insert an empty quote before
# the comment so that it becomes a normal side comment and
# will be aligned by the vertical aligner
if ( $CODE_type eq 'HSC' ) {
# Safety Check: This must be a line with one token (a comment)
my $rtoken_vars = $rLL->[$Kfirst];
if ( $Kfirst == $Klast && $rtoken_vars->[_TYPE_] eq '#' ) {
# Note that even if the flag 'noadd-whitespace' is set, we
# will make an exception here and allow a blank to be
# inserted to push the comment to the right. We can think
# of this as an adjustment of indentation rather than
# whitespace between tokens. This will also prevent the
# hanging side comment from getting converted to a block
# comment if whitespace gets deleted, as for example with
# the -extrude and -mangle options.
my $rcopy = copy_token_as_type( $rtoken_vars, 'q', '' );
$store_token->($rcopy);
$rcopy = copy_token_as_type( $rtoken_vars, 'b', ' ' );
$store_token->($rcopy);
$store_token->($rtoken_vars);
next;
}
else {
# This line was mis-marked by sub scan_comment
Fault(
"Program bug. A hanging side comment has been mismarked"
);
}
}
# Copy tokens unchanged
foreach my $KK ( $Kfirst .. $Klast ) {
$store_token->( $rLL->[$KK] );
}
next;
}
# Handle normal line..
# Insert any essential whitespace between lines
# if last line was normal CODE.
# Patch for rt #125012: use K_previous_code rather than '_nonblank'
# because comments may disappear.
my $type_next = $rLL->[$Kfirst]->[_TYPE_];
my $token_next = $rLL->[$Kfirst]->[_TOKEN_];
my $Kp = $self->K_previous_code( undef, $rLL_new );
if ( $last_line_type eq 'CODE'
&& $type_next ne 'b'
&& defined($Kp) )
{
my $token_p = $rLL_new->[$Kp]->[_TOKEN_];
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
my ( $token_pp, $type_pp );
my $Kpp = $self->K_previous_code( $Kp, $rLL_new );
if ( defined($Kpp) ) {
$token_pp = $rLL_new->[$Kpp]->[_TOKEN_];
$type_pp = $rLL_new->[$Kpp]->[_TYPE_];
}
else {
$token_pp = ";";
$type_pp = ';';
}
if (
is_essential_whitespace(
$token_pp, $type_pp, $token_p,
$type_p, $token_next, $type_next,
)
)
{
# Copy this first token as blank, but use previous line number
my $rcopy = copy_token_as_type( $rLL->[$Kfirst], 'b', ' ' );
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
$store_token->($rcopy);
}
}
# loop to copy all tokens on this line, with any changes
my $type_sequence;
for ( my $KK = $Kfirst ; $KK <= $Klast ; $KK++ ) {
$rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
my $last_type_sequence = $type_sequence;
$type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
# Handle a blank space ...
if ( $type eq 'b' ) {
# Delete it if not wanted by whitespace rules
# or we are deleting all whitespace
# Note that whitespace flag is a flag indicating whether a
# white space BEFORE the token is needed
next if ( $KK >= $Klast ); # skip terminal blank
my $Knext = $KK + 1;
my $ws = $rwhitespace_flags->[$Knext];
if ( $ws == -1
|| $rOpts_delete_old_whitespace )
{
# FIXME: maybe switch to using _new
my $Kp = $self->K_previous_nonblank($KK);
next unless defined($Kp);
my $token_p = $rLL->[$Kp]->[_TOKEN_];
my $type_p = $rLL->[$Kp]->[_TYPE_];
my ( $token_pp, $type_pp );
my $Kpp = $self->K_previous_nonblank($Kp);
if ( defined($Kpp) ) {
$token_pp = $rLL->[$Kpp]->[_TOKEN_];
$type_pp = $rLL->[$Kpp]->[_TYPE_];
}
else {
$token_pp = ";";
$type_pp = ';';
}
my $token_next = $rLL->[$Knext]->[_TOKEN_];
my $type_next = $rLL->[$Knext]->[_TYPE_];
my $do_not_delete = is_essential_whitespace(
$token_pp, $type_pp, $token_p,
$type_p, $token_next, $type_next,
);
next unless ($do_not_delete);
}
# make it just one character if allowed
if ($rOpts_add_whitespace) {
$rtoken_vars->[_TOKEN_] = ' ';
}
$store_token->($rtoken_vars);
next;
}
# Handle a nonblank token...
# check for a qw quote
if ( $type eq 'q' ) {
# trim blanks from right of qw quotes
# (To avoid trimming qw quotes use -ntqw; the tokenizer handles
# this)
$token =~ s/\s*$//;
$rtoken_vars->[_TOKEN_] = $token;
note_embedded_tab() if ( $token =~ "\t" );
if ($in_multiline_qw) {
# If we are at the end of a multiline qw ..
if ( $in_multiline_qw == $KK ) {
# Split off the closing delimiter character
# so that the formatter can put a line break there if necessary
my $part1 = $token;
my $part2 = substr( $part1, -1, 1, "" );
if ($part1) {
my $rcopy =
copy_token_as_type( $rtoken_vars, 'q', $part1 );
$store_token->($rcopy);
$token = $part2;
$rtoken_vars->[_TOKEN_] = $token;
}
$in_multiline_qw = undef;
# store without preceding blank
$store_token->($rtoken_vars);
next;
}
else {
# continuing a multiline qw
$store_token->($rtoken_vars);
next;
}
}
else {
# we are encountered new qw token...see if multiline
my $K_end = $K_end_q->($KK);
if ( $ALLOW_BREAK_MULTILINE_QW && $K_end != $KK ) {
# Starting multiline qw...
# set flag equal to the ending K
$in_multiline_qw = $K_end;
# Split off the leading part
# so that the formatter can put a line break there if necessary
if ( $token =~ /^(qw\s*.)(.*)$/ ) {
my $part1 = $1;
my $part2 = $2;
if ($part2) {
my $rcopy =
copy_token_as_type( $rtoken_vars, 'q',
$part1 );
$store_token_and_space->(
$rcopy, $rwhitespace_flags->[$KK] == WS_YES
);
$token = $part2;
$rtoken_vars->[_TOKEN_] = $token;
# Second part goes without intermediate blank
$store_token->($rtoken_vars);
next;
}
}
}
else {
# this is a new single token qw -
# store with possible preceding blank
$store_token_and_space->(
$rtoken_vars, $rwhitespace_flags->[$KK] == WS_YES
);
next;
}
}
} ## end if ( $type eq 'q' )
# Modify certain tokens here for whitespace
# The following is not yet done, but could be:
# sub (x x x)
elsif ( $type =~ /^[wit]$/ ) {
# Examples: <<snippets/space1.in>>
# change '$ var' to '$var' etc
# '-> new' to '->new'
if ( $token =~ /^([\$\&\%\*\@]|\-\>)\s/ ) {
$token =~ s/\s*//g;
$rtoken_vars->[_TOKEN_] = $token;
}
# Split identifiers with leading arrows, inserting blanks if
# necessary. It is easier and safer here than in the
# tokenizer. For example '->new' becomes two tokens, '->' and
# 'new' with a possible blank between.
#
# Note: there is a related patch in sub set_whitespace_flags
if ( $token =~ /^\-\>(.*)$/ && $1 ) {
my $token_save = $1;
my $type_save = $type;
# store a blank to left of arrow if necessary
my $Kprev = $self->K_previous_nonblank($KK);
if ( defined($Kprev)
&& $rLL->[$Kprev]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace
&& $want_left_space{'->'} == WS_YES )
{
my $rcopy =
copy_token_as_type( $rtoken_vars, 'b', ' ' );
$store_token->($rcopy);
}
# then store the arrow
my $rcopy = copy_token_as_type( $rtoken_vars, '->', '->' );
$store_token->($rcopy);
# then reset the current token to be the remainder,
# and reset the whitespace flag according to the arrow
$token = $rtoken_vars->[_TOKEN_] = $token_save;
$type = $rtoken_vars->[_TYPE_] = $type_save;
$store_token->($rtoken_vars);
next;
}
if ( $token =~ /$ANYSUB_PATTERN/ ) {
# -spp = 0 : no space before opening prototype paren
# -spp = 1 : stable (follow input spacing)
# -spp = 2 : always space before opening prototype paren
my $spp = $rOpts->{'space-prototype-paren'};
if ( defined($spp) ) {
if ( $spp == 0 ) { $token =~ s/\s+\(/\(/; }
elsif ( $spp == 2 ) { $token =~ s/\(/ (/; }
}
# one space max, and no tabs
$token =~ s/\s+/ /g;
$rtoken_vars->[_TOKEN_] = $token;
}
# trim identifiers of trailing blanks which can occur
# under some unusual circumstances, such as if the
# identifier 'witch' has trailing blanks on input here:
#
# sub
# witch
# () # prototype may be on new line ...
# ...
if ( $type eq 'i' ) {
$token =~ s/\s+$//g;
$rtoken_vars->[_TOKEN_] = $token;
}
}
# change 'LABEL :' to 'LABEL:'
elsif ( $type eq 'J' ) {
$token =~ s/\s+//g;
$rtoken_vars->[_TOKEN_] = $token;
}
# patch to add space to something like "x10"
# This avoids having to split this token in the pre-tokenizer
elsif ( $type eq 'n' ) {
if ( $token =~ /^x\d+/ ) {
$token =~ s/x/x /;
$rtoken_vars->[_TOKEN_] = $token;
}
}
# check a quote for problems
elsif ( $type eq 'Q' ) {
$check_Q->( $KK, $Kfirst );
}
# handle semicolons
elsif ( $type eq ';' ) {
# Remove unnecessary semicolons, but not after bare
# blocks, where it could be unsafe if the brace is
# mistokenized.
if (
$rOpts->{'delete-semicolons'}
&& (
(
$last_nonblank_type eq '}'
&& (
$is_block_without_semicolon{
$last_nonblank_block_type}
|| $last_nonblank_block_type =~ /$SUB_PATTERN/
|| $last_nonblank_block_type =~ /^\w+:$/ )
)
|| $last_nonblank_type eq ';'
)
)
{
# This looks like a deletable semicolon, but even if a
# semicolon can be deleted it is necessarily best to do so.
# We apply these additional rules for deletion:
# - Always ok to delete a ';' at the end of a line
# - Never delete a ';' before a '#' because it would
# promote it to a block comment.
# - If a semicolon is not at the end of line, then only
# delete if it is followed by another semicolon or closing
# token. This includes the comment rule. It may take
# two passes to get to a final state, but it is a little
# safer. For example, keep the first semicolon here:
# eval { sub bubba { ok(0) }; ok(0) } || ok(1);
# It is not required but adds some clarity.
my $ok_to_delete = 1;
if ( $KK < $Klast ) {
my $Kn = $self->K_next_nonblank($KK);
if ( defined($Kn) && $Kn <= $Klast ) {
my $next_nonblank_token_type =
$rLL->[$Kn]->[_TYPE_];
$ok_to_delete = $next_nonblank_token_type eq ';'
|| $next_nonblank_token_type eq '}';
}
}
if ($ok_to_delete) {
note_deleted_semicolon();
next;
}
else {
write_logfile_entry("Extra ';'\n");
}
}
}
elsif ($type_sequence) {
# if ( $is_opening_token{$token} ) {
# }
if ( $is_closing_token{$token} ) {
# Insert a tentative missing semicolon if the next token is
# a closing block brace
if (
$type eq '}'
&& $token eq '}'
# not preceded by a ';'
&& $last_nonblank_type ne ';'
# and this is not a VERSION stmt (is all one line, we are not
# inserting semicolons on one-line blocks)
&& $CODE_type ne 'VER'
# and we are allowed to add semicolons
&& $rOpts->{'add-semicolons'}
)
{
$add_phantom_semicolon->($KK);
}
}
}
# Store this token with possible previous blank
$store_token_and_space->(
$rtoken_vars, $rwhitespace_flags->[$KK] == WS_YES
);
} # End token loop
} # End line loop
# Reset memory to be the new array
$self->{rLL} = $rLL_new;
$self->set_rLL_max_index();
$self->{K_opening_container} = $K_opening_container;
$self->{K_closing_container} = $K_closing_container;
$self->{K_opening_ternary} = $K_opening_ternary;
$self->{K_closing_ternary} = $K_closing_ternary;
$self->{rK_phantom_semicolons} = $rK_phantom_semicolons;
# make sure the new array looks okay
$self->check_token_array();
# reset the token limits of each line
$self->resync_lines_and_tokens();
return;
}
{ # scan_comments
my $Last_line_had_side_comment;
my $In_format_skipping_section;
my $Saw_VERSION_in_this_file;
sub scan_comments {
my $self = shift;
my $rlines = $self->{rlines};
$Last_line_had_side_comment = undef;
$In_format_skipping_section = undef;
$Saw_VERSION_in_this_file = undef;
# Loop over all lines
foreach my $line_of_tokens ( @{$rlines} ) {
my $line_type = $line_of_tokens->{_line_type};
next unless ( $line_type eq 'CODE' );
my $CODE_type = $self->get_CODE_type($line_of_tokens);
$line_of_tokens->{_code_type} = $CODE_type;
}
return;
}
sub get_CODE_type {
my ( $self, $line_of_tokens ) = @_;
# We are looking at a line of code and setting a flag to
# describe any special processing that it requires
# Possible CODE_types are as follows.
# 'BL' = Blank Line
# 'VB' = Verbatim - line goes out verbatim
# 'IO' = Indent Only - line goes out unchanged except for indentation
# 'NIN' = No Internal Newlines - line does not get broken
# 'HSC'=Hanging Side Comment - fix this hanging side comment
# 'BC'=Block Comment - an ordinary full line comment
# 'SBC'=Static Block Comment - a block comment which does not get
# indented
# 'SBCX'=Static Block Comment Without Leading Space
# 'VER'=VERSION statement
# '' or (undefined) - no restructions
my $rLL = $self->{rLL};
my $Klimit = $self->{Klimit};
my $rOpts_add_newlines = $rOpts->{'add-newlines'};
my $rOpts_format_skipping = $rOpts->{'format-skipping'};
my $CODE_type = $rOpts->{'indent-only'} ? 'IO' : "";
my $no_internal_newlines = 1 - $rOpts_add_newlines;
if ( !$CODE_type && $no_internal_newlines ) { $CODE_type = 'NIN' }
# extract what we need for this line..
# Global value for error messages:
$input_line_number = $line_of_tokens->{_line_number};
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
my $jmax = -1;
if ( defined($Kfirst) ) { $jmax = $Klast - $Kfirst }
my $input_line = $line_of_tokens->{_line_text};
my $is_static_block_comment = 0;
# Handle a continued quote..
if ( $line_of_tokens->{_starting_in_quote} ) {
# A line which is entirely a quote or pattern must go out
# verbatim. Note: the \n is contained in $input_line.
if ( $jmax <= 0 ) {
if ( ( $input_line =~ "\t" ) ) {
note_embedded_tab();
}
$Last_line_had_side_comment = 0;
return 'VB';
}
}
my $is_block_comment =
( $jmax == 0 && $rLL->[$Kfirst]->[_TYPE_] eq '#' );
# Write line verbatim if we are in a formatting skip section
if ($In_format_skipping_section) {
$Last_line_had_side_comment = 0;
# Note: extra space appended to comment simplifies pattern matching
if ( $is_block_comment
&& ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
/$format_skipping_pattern_end/ )
{
$In_format_skipping_section = 0;
write_logfile_entry("Exiting formatting skip section\n");
}
return 'FS';
}
# See if we are entering a formatting skip section
if ( $rOpts_format_skipping
&& $is_block_comment
&& ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
/$format_skipping_pattern_begin/ )
{
$In_format_skipping_section = 1;
write_logfile_entry("Entering formatting skip section\n");
$Last_line_had_side_comment = 0;
return 'FS';
}
# ignore trailing blank tokens (they will get deleted later)
if ( $jmax > 0 && $rLL->[$Klast]->[_TYPE_] eq 'b' ) {
$jmax--;
}
# Handle a blank line..
if ( $jmax < 0 ) {
$Last_line_had_side_comment = 0;
return 'BL';
}
# see if this is a static block comment (starts with ## by default)
my $is_static_block_comment_without_leading_space = 0;
if ( $is_block_comment
&& $rOpts->{'static-block-comments'}
&& $input_line =~ /$static_block_comment_pattern/ )
{
$is_static_block_comment = 1;
$is_static_block_comment_without_leading_space =
substr( $input_line, 0, 1 ) eq '#';
}
# Check for comments which are line directives
# Treat exactly as static block comments without leading space
# reference: perlsyn, near end, section Plain Old Comments (Not!)
# example: '# line 42 "new_filename.plx"'
if (
$is_block_comment
&& $input_line =~ /^\# \s*
line \s+ (\d+) \s*
(?:\s("?)([^"]+)\2)? \s*
$/x
)
{
$is_static_block_comment = 1;
$is_static_block_comment_without_leading_space = 1;
}
# look for hanging side comment
if (
$is_block_comment
&& $Last_line_had_side_comment # last line had side comment
&& $input_line =~ /^\s/ # there is some leading space
&& !$is_static_block_comment # do not make static comment hanging
&& $rOpts->{'hanging-side-comments'} # user is allowing
# hanging side comments
# like this
)
{
$Last_line_had_side_comment = 1;
return 'HSC';
}
# remember if this line has a side comment
$Last_line_had_side_comment =
( $jmax > 0 && $rLL->[$Klast]->[_TYPE_] eq '#' );
# Handle a block (full-line) comment..
if ($is_block_comment) {
# TRIM COMMENTS -- This could be turned off as a option
$rLL->[$Kfirst]->[_TOKEN_] =~ s/\s*$//; # trim right end
if ($is_static_block_comment_without_leading_space) {
return 'SBCX';
}
elsif ($is_static_block_comment) {
return 'SBC';
}
else {
return 'BC';
}
}
# Patch needed for MakeMaker. Do not break a statement
# in which $VERSION may be calculated. See MakeMaker.pm;
# this is based on the coding in it.
# The first line of a file that matches this will be eval'd:
# /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
# Examples:
# *VERSION = \'1.01';
# ( $VERSION ) = '$Revision: 1.74 $ ' =~ /\$Revision:\s+([^\s]+)/;
# We will pass such a line straight through without breaking
# it unless -npvl is used.
# Patch for problem reported in RT #81866, where files
# had been flattened into a single line and couldn't be
# tidied without -npvl. There are two parts to this patch:
# First, it is not done for a really long line (80 tokens for now).
# Second, we will only allow up to one semicolon
# before the VERSION. We need to allow at least one semicolon
# for statements like this:
# require Exporter; our $VERSION = $Exporter::VERSION;
# where both statements must be on a single line for MakeMaker
my $is_VERSION_statement = 0;
if ( !$Saw_VERSION_in_this_file
&& $jmax < 80
&& $input_line =~
/^[^;]*;?[^;]*([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ )
{
$Saw_VERSION_in_this_file = 1;
write_logfile_entry("passing VERSION line; -npvl deactivates\n");
$CODE_type = 'VER';
}
return $CODE_type;
}
}
sub find_nested_pairs {
my $self = shift;
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
# We define an array of pairs of nested containers
my @nested_pairs;
# We also set the following hash values to identify container pairs for
# which the opening and closing tokens are adjacent in the token stream:
# $rpaired_to_inner_container->{$seqno_out}=$seqno_in where $seqno_out and
# $seqno_in are the seqence numbers of the outer and inner containers of
# the pair We need these later to decide if we can insert a missing
# semicolon
my $rpaired_to_inner_container = {};
# This local hash remembers if an outer container has a close following
# inner container;
# The key is the outer sequence number
# The value is the token_hash of the inner container
my %has_close_following_opening;
# Names of calling routines can either be marked as 'i' or 'w',
# and they may invoke a sub call with an '->'. We will consider
# any consecutive string of such types as a single unit when making
# weld decisions. We also allow a leading !
my $is_name_type = {
'i' => 1,
'w' => 1,
'U' => 1,
'->' => 1,
'!' => 1,
};
my $is_name = sub {
my $type = shift;
return $type && $is_name_type->{$type};
};
my $last_container;
my $last_last_container;
my $last_nonblank_token_vars;
my $last_count;
my $nonblank_token_count = 0;
# loop over all tokens
foreach my $rtoken_vars ( @{$rLL} ) {
my $type = $rtoken_vars->[_TYPE_];
next if ( $type eq 'b' );
# long identifier-like items are counted as a single item
$nonblank_token_count++
unless ( $is_name->($type)
&& $is_name->( $last_nonblank_token_vars->[_TYPE_] ) );
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ($type_sequence) {
my $token = $rtoken_vars->[_TOKEN_];
if ( $is_opening_token{$token} ) {
# following previous opening token ...
if ( $last_container
&& $is_opening_token{ $last_container->[_TOKEN_] } )
{
# adjacent to this one
my $tok_diff = $nonblank_token_count - $last_count;
my $last_tok = $last_nonblank_token_vars->[_TOKEN_];
if ( $tok_diff == 1
|| $tok_diff == 2 && $last_container->[_TOKEN_] eq '(' )
{
# remember this pair...
my $outer_seqno = $last_container->[_TYPE_SEQUENCE_];
my $inner_seqno = $type_sequence;
$has_close_following_opening{$outer_seqno} =
$rtoken_vars;
}
}
}
elsif ( $is_closing_token{$token} ) {
# if the corresponding opening token had an adjacent opening
if ( $has_close_following_opening{$type_sequence}
&& $is_closing_token{ $last_container->[_TOKEN_] }
&& $has_close_following_opening{$type_sequence}
->[_TYPE_SEQUENCE_] == $last_container->[_TYPE_SEQUENCE_] )
{
# The closing weld tokens must be adjacent
# NOTE: so intermediate commas and semicolons
# can currently block a weld. This is something
# that could be fixed in the future by including
# a flag to delete un-necessary commas and semicolons.
my $tok_diff = $nonblank_token_count - $last_count;
if ( $tok_diff == 1 ) {
# This is a closely nested pair ..
my $inner_seqno = $last_container->[_TYPE_SEQUENCE_];
my $outer_seqno = $type_sequence;
$rpaired_to_inner_container->{$outer_seqno} =
$inner_seqno;
push @nested_pairs, [ $inner_seqno, $outer_seqno ];
}
}
}
$last_last_container = $last_container;
$last_container = $rtoken_vars;
$last_count = $nonblank_token_count;
}
$last_nonblank_token_vars = $rtoken_vars;
}
$self->{rnested_pairs} = \@nested_pairs;
$self->{rpaired_to_inner_container} = $rpaired_to_inner_container;
return;
}
sub Debug_dump_tokens {
# a debug routine, not normally used
my ( $self, $msg ) = @_;
my $rLL = $self->{rLL};
my $nvars = @{$rLL};
print STDERR "$msg\n";
print STDERR "ntokens=$nvars\n";
print STDERR "K\t_TOKEN_\t_TYPE_\n";
my $K = 0;
foreach my $item ( @{$rLL} ) {
print STDERR "$K\t$item->[_TOKEN_]\t$item->[_TYPE_]\n";
$K++;
}
return;
}
sub get_old_line_index {
my ( $self, $K ) = @_;
my $rLL = $self->{rLL};
return 0 unless defined($K);
return $rLL->[$K]->[_LINE_INDEX_];
}
sub get_old_line_count {
my ( $self, $Kbeg, $Kend ) = @_;
my $rLL = $self->{rLL};
return 0 unless defined($Kbeg);
return 0 unless defined($Kend);
return $rLL->[$Kend]->[_LINE_INDEX_] - $rLL->[$Kbeg]->[_LINE_INDEX_] + 1;
}
sub K_next_code {
my ( $self, $KK, $rLL ) = @_;
# return the index K of the next nonblank, non-comment token
return unless ( defined($KK) && $KK >= 0 );
# use the standard array unless given otherwise
$rLL = $self->{rLL} unless ( defined($rLL) );
my $Num = @{$rLL};
my $Knnb = $KK + 1;
while ( $Knnb < $Num ) {
if ( !defined( $rLL->[$Knnb] ) ) {
Fault("Undefined entry for k=$Knnb");
}
if ( $rLL->[$Knnb]->[_TYPE_] ne 'b'
&& $rLL->[$Knnb]->[_TYPE_] ne '#' )
{
return $Knnb;
}
$Knnb++;
}
return;
}
sub K_next_nonblank {
my ( $self, $KK, $rLL ) = @_;
# return the index K of the next nonblank token
return unless ( defined($KK) && $KK >= 0 );
# use the standard array unless given otherwise
$rLL = $self->{rLL} unless ( defined($rLL) );
my $Num = @{$rLL};
my $Knnb = $KK + 1;
while ( $Knnb < $Num ) {
if ( !defined( $rLL->[$Knnb] ) ) {
Fault("Undefined entry for k=$Knnb");
}
if ( $rLL->[$Knnb]->[_TYPE_] ne 'b' ) { return $Knnb }
$Knnb++;
}
return;
}
sub K_previous_code {
# return the index K of the previous nonblank, non-comment token
# Call with $KK=undef to start search at the top of the array
my ( $self, $KK, $rLL ) = @_;
# use the standard array unless given otherwise
$rLL = $self->{rLL} unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
elsif ( $KK > $Num ) {
# The caller should make the first call with KK_new=undef to
# avoid this error
Fault(
"Program Bug: K_previous_nonblank_new called with K=$KK which exceeds $Num"
);
}
my $Kpnb = $KK - 1;
while ( $Kpnb >= 0 ) {
if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b'
&& $rLL->[$Kpnb]->[_TYPE_] ne '#' )
{
return $Kpnb;
}
$Kpnb--;
}
return;
}
sub K_previous_nonblank {
# return index of previous nonblank token before item K;
# Call with $KK=undef to start search at the top of the array
my ( $self, $KK, $rLL ) = @_;
# use the standard array unless given otherwise
$rLL = $self->{rLL} unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
elsif ( $KK > $Num ) {
# The caller should make the first call with KK_new=undef to
# avoid this error
Fault(
"Program Bug: K_previous_nonblank_new called with K=$KK which exceeds $Num"
);
}
my $Kpnb = $KK - 1;
while ( $Kpnb >= 0 ) {
if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b' ) { return $Kpnb }
$Kpnb--;
}
return;
}
sub map_containers {
# Maps the container hierarchy
my $self = shift;
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
my $K_opening_container = $self->{K_opening_container};
my $K_closing_container = $self->{K_closing_container};
my $rcontainer_map = $self->{rcontainer_map};
# loop over containers
my @stack; # stack of container sequence numbers
my $KNEXT = 0;
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
next if ( $KK == 0 ); # first token in file may not be container
Fault("sequence = $type_sequence not defined at K=$KK");
}
my $token = $rtoken_vars->[_TOKEN_];
if ( $is_opening_token{$token} ) {
if (@stack) {
$rcontainer_map->{$type_sequence} = $stack[-1];
}
push @stack, $type_sequence;
}
if ( $is_closing_token{$token} ) {
if (@stack) {
my $seqno = pop @stack;
if ( $seqno != $type_sequence ) {
# shouldn't happen unless file is garbage
}
}
}
}
# the stack should be empty for a good file
if (@stack) {
# unbalanced containers; file probably bad
}
else {
# ok
}
return;
}
sub mark_short_nested_blocks {
# This routine looks at the entire file and marks any short nested blocks
# which should not be broken. The results are stored in the hash
# $rshort_nested->{$type_sequence}
# which will be true if the container should remain intact.
#
# For example, consider the following line:
# sub cxt_two { sort { $a <=> $b } test_if_list() }
# The 'sort' block is short and nested within an outer sub block.
# Normally, the existance of the 'sort' block will force the sub block to
# break open, but this is not always desirable. Here we will set a flag for
# the sort block to prevent this. To give the user control, we will
# follow the input file formatting. If either of the blocks is broken in
# the input file then we will allow it to remain broken. Otherwise we will
# set a flag to keep it together in later formatting steps.
# The flag which is set here will be checked in two places:
# 'sub process_line_of_CODE' and 'sub starting_one_line_block'
my $self = shift;
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
return unless ( $rOpts->{'one-line-block-nesting'} );
my $K_opening_container = $self->{K_opening_container};
my $K_closing_container = $self->{K_closing_container};
my $rbreak_container = $self->{rbreak_container};
my $rshort_nested = $self->{rshort_nested};
my $rcontainer_map = $self->{rcontainer_map};
my $rlines = $self->{rlines};
# Variables needed for estimating line lengths
my $starting_indent;
my $starting_lentot;
my $length_tol = 1;
my $excess_length_to_K = sub {
my ($K) = @_;
# Estimate the length from the line start to a given token
my $length = $self->cumulative_length_before_K($K) - $starting_lentot;
my $excess_length =
$starting_indent + $length + $length_tol - $rOpts_maximum_line_length;
return ($excess_length);
};
my $is_broken_block = sub {
# a block is broken if the input line numbers of the braces differ
my ($seqno) = @_;
my $K_opening = $K_opening_container->{$seqno};
return unless ( defined($K_opening) );
my $K_closing = $K_closing_container->{$seqno};
return unless ( defined($K_closing) );
return $rbreak_container->{$seqno}
|| $rLL->[$K_closing]->[_LINE_INDEX_] !=
$rLL->[$K_opening]->[_LINE_INDEX_];
};
# loop over all containers
my @open_block_stack;
my $iline = -1;
my $KNEXT = 0;
my $rOpts_variable_maximum_line_length =
$rOpts->{'variable-maximum-line-length'};
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
next if ( $KK == 0 ); # first token in file may not be container
# an error here is most likely due to a recent programming change
Fault("sequence = $type_sequence not defined at K=$KK");
}
# We are just looking at code blocks
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
next unless ( $type eq $token );
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
next unless ($block_type);
# Keep a stack of all acceptable block braces seen.
# Only consider blocks entirely on one line so dump the stack when line
# changes.
my $iline_last = $iline;
$iline = $rLL->[$KK]->[_LINE_INDEX_];
if ( $iline != $iline_last ) { @open_block_stack = () }
if ( $token eq '}' ) {
if (@open_block_stack) { pop @open_block_stack }
}
next unless ( $token eq '{' );
# block must be balanced (bad scripts may be unbalanced)
my $K_opening = $K_opening_container->{$type_sequence};
my $K_closing = $K_closing_container->{$type_sequence};
next unless ( defined($K_opening) && defined($K_closing) );
# require that this block be entirely on one line
next if ( $is_broken_block->($type_sequence) );
# See if this block fits on one line of allowed length (which may
# be different from the input script)
$starting_lentot =
$KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
$starting_indent = 0;
if ( !$rOpts_variable_maximum_line_length ) {
my $level = $rLL->[$KK]->[_LEVEL_];
$starting_indent = $rOpts_indent_columns * $level;
}
# Dump the stack if block is too long and skip this block
if ( $excess_length_to_K->($K_closing) > 0 ) {
@open_block_stack = ();
next;
}
# OK, Block passes tests, remember it
push @open_block_stack, $type_sequence;
# We are only marking nested code blocks,
# so check for a previous block on the stack
next unless ( @open_block_stack > 1 );
# Looks OK, mark this as a short nested block
$rshort_nested->{$type_sequence} = 1;
}
return;
}
sub weld_containers {
# do any welding operations
my $self = shift;
# initialize weld length hashes needed later for checking line lengths
# TODO: These should eventually be stored in $self rather than be package vars
%weld_len_left_closing = ();
%weld_len_right_closing = ();
%weld_len_left_opening = ();
%weld_len_right_opening = ();
return if ( $rOpts->{'indent-only'} );
return unless ( $rOpts->{'add-newlines'} );
if ( $rOpts->{'weld-nested-containers'} ) {
# if called, weld_nested_containers must be called before other weld
# operations. # This is because weld_nested_containers could overwrite
# hash values written by weld_cuddled_blocks and weld_nested_quotes.
$self->weld_nested_containers();
$self->weld_nested_quotes();
}
# Note that weld_nested_containers() changes the _LEVEL_ values, so
# weld_cuddled_blocks must use the _TRUE_LEVEL_ values instead.
# Here is a good test case to Be sure that both cuddling and welding
# are working and not interfering with each other: <<snippets/ce_wn1.in>>
# perltidy -wn -ce
# if ($BOLD_MATH) { (
# $labels, $comment,
# join( '', '<B>', &make_math( $mode, '', '', $_ ), '</B>' )
# ) } else { (
# &process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ),
# $after
# ) }
$self->weld_cuddled_blocks();
return;
}
sub cumulative_length_before_K {
my ( $self, $KK ) = @_;
my $rLL = $self->{rLL};
return ( $KK <= 0 ) ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
}
sub cumulative_length_after_K {
my ( $self, $KK ) = @_;
my $rLL = $self->{rLL};
return $rLL->[$KK]->[_CUMULATIVE_LENGTH_];
}
sub weld_cuddled_blocks {
my $self = shift;
# This routine implements the -cb flag by finding the appropriate
# closing and opening block braces and welding them together.
return unless ( %{$rcuddled_block_types} );
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
my $rbreak_container = $self->{rbreak_container};
my $K_opening_container = $self->{K_opening_container};
my $K_closing_container = $self->{K_closing_container};
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
my $KK = $K_opening_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
my $KK = $K_closing_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $is_broken_block = sub {
# a block is broken if the input line numbers of the braces differ
# we can only cuddle between broken blocks
my ($seqno) = @_;
my $K_opening = $K_opening_container->{$seqno};
return unless ( defined($K_opening) );
my $K_closing = $K_closing_container->{$seqno};
return unless ( defined($K_closing) );
return $rbreak_container->{$seqno}
|| $rLL->[$K_closing]->[_LINE_INDEX_] !=
$rLL->[$K_opening]->[_LINE_INDEX_];
};
# A stack to remember open chains at all levels:
# $in_chain[$level] = [$chain_type, $type_sequence];
my @in_chain;
my $CBO = $rOpts->{'cuddled-break-option'};
# loop over structure items to find cuddled pairs
my $level = 0;
my $KNEXT = 0;
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
next if ( $KK == 0 ); # first token in file may not be container
Fault("sequence = $type_sequence not defined at K=$KK");
}
# We use the original levels because they get changed by sub
# 'weld_nested_containers'. So if this were to be called before that
# routine, the levels would be wrong and things would go bad.
my $last_level = $level;
$level = $rtoken_vars->[_LEVEL_TRUE_];
if ( $level < $last_level ) { $in_chain[$last_level] = undef }
elsif ( $level > $last_level ) { $in_chain[$level] = undef }
# We are only looking at code blocks
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
next unless ( $type eq $token );
if ( $token eq '{' ) {
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
if ( !$block_type ) {
# patch for unrecognized block types which may not be labeled
my $Kp = $self->K_previous_nonblank($KK);
while ( $Kp && $rLL->[$Kp]->[_TYPE_] eq '#' ) {
$Kp = $self->K_previous_nonblank($Kp);
}
next unless $Kp;
$block_type = $rLL->[$Kp]->[_TOKEN_];
}
if ( $in_chain[$level] ) {
# we are in a chain and are at an opening block brace.
# See if we are welding this opening brace with the previous
# block brace. Get their identification numbers:
my $closing_seqno = $in_chain[$level]->[1];
my $opening_seqno = $type_sequence;
# The preceding block must be on multiple lines so that its
# closing brace will start a new line.
if ( !$is_broken_block->($closing_seqno) ) {
next unless ( $CBO == 2 );
$rbreak_container->{$closing_seqno} = 1;
}
# we will let the trailing block be either broken or intact
## && $is_broken_block->($opening_seqno);
# We can weld the closing brace to its following word ..
my $Ko = $K_closing_container->{$closing_seqno};
my $Kon = $self->K_next_nonblank($Ko);
# ..unless it is a comment
if ( $rLL->[$Kon]->[_TYPE_] ne '#' ) {
my $dlen =
$rLL->[$Kon]->[_CUMULATIVE_LENGTH_] -
$rLL->[ $Ko - 1 ]->[_CUMULATIVE_LENGTH_];
$weld_len_right_closing{$closing_seqno} = $dlen;
# Set flag that we want to break the next container
# so that the cuddled line is balanced.
$rbreak_container->{$opening_seqno} = 1
if ($CBO);
}
}
else {
# We are not in a chain. Start a new chain if we see the
# starting block type.
if ( $rcuddled_block_types->{$block_type} ) {
$in_chain[$level] = [ $block_type, $type_sequence ];
}
else {
$block_type = '*';
$in_chain[$level] = [ $block_type, $type_sequence ];
}
}
}
elsif ( $token eq '}' ) {
if ( $in_chain[$level] ) {
# We are in a chain at a closing brace. See if this chain
# continues..
my $Knn = $self->K_next_code($KK);
next unless $Knn;
my $chain_type = $in_chain[$level]->[0];
my $next_nonblank_token = $rLL->[$Knn]->[_TOKEN_];
if (
$rcuddled_block_types->{$chain_type}->{$next_nonblank_token}
)
{
# Note that we do not weld yet because we must wait until
# we we are sure that an opening brace for this follows.
$in_chain[$level]->[1] = $type_sequence;
}
else { $in_chain[$level] = undef }
}
}
}
return;
}
sub weld_nested_containers {
my $self = shift;
# This routine implements the -wn flag by "welding together"
# the nested closing and opening tokens which were previously
# identified by sub 'find_nested_pairs'. "welding" simply
# involves setting certain hash values which will be checked
# later during formatting.
my $rLL = $self->{rLL};
my $Klimit = $self->get_rLL_max_index();
my $rnested_pairs = $self->{rnested_pairs};
my $rlines = $self->{rlines};
my $K_opening_container = $self->{K_opening_container};
my $K_closing_container = $self->{K_closing_container};
# Return unless there are nested pairs to weld
return unless defined($rnested_pairs) && @{$rnested_pairs};
# This array will hold the sequence numbers of the tokens to be welded.
my @welds;
# Variables needed for estimating line lengths
my $starting_indent;
my $starting_lentot;
# A tolerance to the length for length estimates. In some rare cases
# this can avoid problems where a final weld slightly exceeds the
# line length and gets broken in a bad spot.
my $length_tol = 1;
my $excess_length_to_K = sub {
my ($K) = @_;
# Estimate the length from the line start to a given token
my $length = $self->cumulative_length_before_K($K) - $starting_lentot;
my $excess_length =
$starting_indent + $length + $length_tol - $rOpts_maximum_line_length;
return ($excess_length);
};
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
my $KK = $K_opening_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
my $KK = $K_closing_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
# Abbreviations:
# _oo=outer opening, i.e. first of { {
# _io=inner opening, i.e. second of { {
# _oc=outer closing, i.e. second of } {
# _ic=inner closing, i.e. first of } }
my $previous_pair;
# We are working from outermost to innermost pairs so that
# level changes will be complete when we arrive at the inner pairs.
while ( my $item = pop( @{$rnested_pairs} ) ) {
my ( $inner_seqno, $outer_seqno ) = @{$item};
my $Kouter_opening = $K_opening_container->{$outer_seqno};
my $Kinner_opening = $K_opening_container->{$inner_seqno};
my $Kouter_closing = $K_closing_container->{$outer_seqno};
my $Kinner_closing = $K_closing_container->{$inner_seqno};
my $outer_opening = $rLL->[$Kouter_opening];
my $inner_opening = $rLL->[$Kinner_opening];
my $outer_closing = $rLL->[$Kouter_closing];
my $inner_closing = $rLL->[$Kinner_closing];
my $iline_oo = $outer_opening->[_LINE_INDEX_];
my $iline_io = $inner_opening->[_LINE_INDEX_];
my $iline_ic = $inner_closing->[_LINE_INDEX_];
# Set flag saying if this pair starts a new weld
my $starting_new_weld = !( @welds && $outer_seqno == $welds[-1]->[0] );
# Set flag saying if this pair is adjacent to the previous nesting pair
# (even if previous pair was rejected as a weld)
my $touch_previous_pair =
defined($previous_pair) && $outer_seqno == $previous_pair->[0];
$previous_pair = $item;
# Set a flag if we should not weld. It sometimes looks best not to weld
# when the opening and closing tokens are very close. However, there
# is a danger that we will create a "blinker", which oscillates between
# two semi-stable states, if we do not weld. So the rules for
# not welding have to be carefully defined and tested.
my $do_not_weld;
if ( !$touch_previous_pair ) {
# If this pair is not adjacent to the previous pair (skipped or
# not), then measure lengths from the start of line of oo
my $rK_range = $rlines->[$iline_oo]->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
$starting_lentot =
$Kfirst <= 0 ? 0 : $rLL->[ $Kfirst - 1 ]->[_CUMULATIVE_LENGTH_];
$starting_indent = 0;
if ( !$rOpts_variable_maximum_line_length ) {
my $level = $rLL->[$Kfirst]->[_LEVEL_];
$starting_indent = $rOpts_indent_columns * $level;
}
# DO-NOT-WELD RULE 1:
# Do not weld something that looks like the start of a two-line
# function call, like this: <<snippets/wn6.in>>
# $trans->add_transformation(
# PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
# We will look for a semicolon after the closing paren.
# We want to weld something complex, like this though
# my $compass = uc( opposite_direction( line_to_canvas_direction(
# @{ $coords[0] }, @{ $coords[1] } ) ) );
# Otherwise we will get a 'blinker'. For example, the following
# would become a blinker without this rule:
# $Self->_Add( $SortOrderDisplay{ $Field
# ->GenerateFieldForSelectSQL() } );
# But it is okay to weld a two-line statement if it looks like
# it was already welded, meaning that the two opening containers are
# on a different line that the two closing containers. This is
# necessary to prevent blinking of something like this with
# perltidy -wn -pbp (starting indentation two levels deep):
# $top_label->set_text( gettext(
# "Unable to create personal directory - check permissions.") );
my $iline_oc = $outer_closing->[_LINE_INDEX_];
my $token_oo = $outer_opening->[_TOKEN_];
if ( $iline_oc == $iline_oo + 1
&& $iline_io == $iline_ic
&& $token_oo eq '(' )
{
# Look for following semicolon...
my $Knext_nonblank = $self->K_next_nonblank($Kouter_closing);
my $next_nonblank_type =
defined($Knext_nonblank)
? $rLL->[$Knext_nonblank]->[_TYPE_]
: 'b';
if ( $next_nonblank_type eq ';' ) {
# Then do not weld if no other containers between inner
# opening and closing.
my $Knext_seq_item = $inner_opening->[_KNEXT_SEQ_ITEM_];
if ( $Knext_seq_item == $Kinner_closing ) {
$do_not_weld ||= 1;
}
}
}
}
# DO-NOT-WELD RULE 2:
# Do not weld an opening paren to an inner one line brace block
# We will just use old line numbers for this test and require
# iterations if necessary for convergence
# For example, otherwise we could cause the opening paren
# in the following example to separate from the caller name
# as here:
# $_[0]->code_handler
# ( sub { $more .= $_[1] . ":" . $_[0] . "\n" } );
# Here is another example where we do not want to weld:
# $wrapped->add_around_modifier(
# sub { push @tracelog => 'around 1'; $_[0]->(); } );
# If the one line sub block gets broken due to length or by the
# user, then we can weld. The result will then be:
# $wrapped->add_around_modifier( sub {
# push @tracelog => 'around 1';
# $_[0]->();
# } );
if ( $iline_ic == $iline_io ) {
my $token_oo = $outer_opening->[_TOKEN_];
$do_not_weld ||= $token_oo eq '(';
}
# DO-NOT-WELD RULE 3:
# Do not weld if this makes our line too long
$do_not_weld ||= $excess_length_to_K->($Kinner_opening) > 0;
# DO-NOT-WELD RULE 4; implemented for git#10:
# Do not weld an opening -ce brace if the next container is on a single
# line, different from the opening brace. (This is very rare). For
# example, given the following with -ce, we will avoid joining the {
# and [
# } else {
# [ $_, length($_) ]
# }
# because this would produce a terminal one-line block:
# } else { [ $_, length($_) ] }
# which may not be what is desired. But given this input:
# } else { [ $_, length($_) ] }
# then we will do the weld and retain the one-line block
if ( $rOpts->{'cuddled-else'} ) {
my $block_type = $rLL->[$Kouter_opening]->[_BLOCK_TYPE_];
if ( $block_type && $rcuddled_block_types->{'*'}->{$block_type} ) {
my $io_line = $inner_opening->[_LINE_INDEX_];
my $ic_line = $inner_closing->[_LINE_INDEX_];
my $oo_line = $outer_opening->[_LINE_INDEX_];
$do_not_weld ||=
( $oo_line < $io_line && $ic_line == $io_line );
}
}
if ($do_not_weld) {
# After neglecting a pair, we start measuring from start of point io
$starting_lentot =
$self->cumulative_length_before_K($Kinner_opening);
$starting_indent = 0;
if ( !$rOpts_variable_maximum_line_length ) {
my $level = $inner_opening->[_LEVEL_];
$starting_indent = $rOpts_indent_columns * $level;
}
# Normally, a broken pair should not decrease indentation of
# intermediate tokens:
## if ( $last_pair_broken ) { next }
# However, for long strings of welded tokens, such as '{{{{{{...'
# we will allow broken pairs to also remove indentation.
# This will keep very long strings of opening and closing
# braces from marching off to the right. We will do this if the
# number of tokens in a weld before the broken weld is 4 or more.
# This rule will mainly be needed for test scripts, since typical
# welds have fewer than about 4 welded tokens.
if ( !@welds || @{ $welds[-1] } < 4 ) { next }
}
# otherwise start new weld ...
elsif ($starting_new_weld) {
push @welds, $item;
}
# ... or extend current weld
else {
unshift @{ $welds[-1] }, $inner_seqno;
}
# After welding, reduce the indentation level if all intermediate tokens
my $dlevel = $outer_opening->[_LEVEL_] - $inner_opening->[_LEVEL_];
if ( $dlevel != 0 ) {
my $Kstart = $Kinner_opening;
my $Kstop = $Kinner_closing;
for ( my $KK = $Kstart ; $KK <= $Kstop ; $KK++ ) {
$rLL->[$KK]->[_LEVEL_] += $dlevel;
}
}
}
# Define weld lengths needed later to set line breaks
foreach my $item (@welds) {
# sweep from inner to outer
my $inner_seqno;
my $len_close = 0;
my $len_open = 0;
foreach my $outer_seqno ( @{$item} ) {
if ($inner_seqno) {
my $dlen_opening =
$length_to_opening_seqno->($inner_seqno) -
$length_to_opening_seqno->($outer_seqno);
my $dlen_closing =
$length_to_closing_seqno->($outer_seqno) -
$length_to_closing_seqno->($inner_seqno);
$len_open += $dlen_opening;
$len_close += $dlen_closing;
}
$weld_len_left_closing{$outer_seqno} = $len_close;
$weld_len_right_opening{$outer_seqno} = $len_open;
$inner_seqno = $outer_seqno;
}
# sweep from outer to inner
foreach my $seqno ( reverse @{$item} ) {
$weld_len_right_closing{$seqno} =
$len_close - $weld_len_left_closing{$seqno};
$weld_len_left_opening{$seqno} =
$len_open - $weld_len_right_opening{$seqno};
}
}
#####################################
# DEBUG
#####################################
if (0) {
my $count = 0;
local $" = ')(';
foreach my $weld (@welds) {
print "\nWeld number $count has seq: (@{$weld})\n";
foreach my $seq ( @{$weld} ) {
print <<EOM;
seq=$seq
left_opening=$weld_len_left_opening{$seq};
right_opening=$weld_len_right_opening{$seq};
left_closing=$weld_len_left_closing{$seq};
right_closing=$weld_len_right_closing{$seq};
EOM
}
$count++;
}
}
return;
}
sub weld_nested_quotes {
my $self = shift;
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
my $K_opening_container = $self->{K_opening_container};
my $K_closing_container = $self->{K_closing_container};
my $rlines = $self->{rlines};
my $rOpts_variable_maximum_line_length =
$rOpts->{'variable-maximum-line-length'};
my $is_single_quote = sub {
my ( $Kbeg, $Kend, $quote_type ) = @_;
foreach my $K ( $Kbeg .. $Kend ) {
my $test_type = $rLL->[$K]->[_TYPE_];
next if ( $test_type eq 'b' );
return if ( $test_type ne $quote_type );
}
return 1;
};
my $excess_line_length = sub {
my ( $KK, $Ktest ) = @_;
# what is the excess length if we add token $Ktest to the line with $KK?
my $iline = $rLL->[$KK]->[_LINE_INDEX_];
my $rK_range = $rlines->[$iline]->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
my $starting_lentot =
$Kfirst <= 0 ? 0 : $rLL->[ $Kfirst - 1 ]->[_CUMULATIVE_LENGTH_];
my $starting_indent = 0;
my $length_tol = 1;
if ( !$rOpts_variable_maximum_line_length ) {
my $level = $rLL->[$Kfirst]->[_LEVEL_];
$starting_indent = $rOpts_indent_columns * $level;
}
my $length = $rLL->[$Ktest]->[_CUMULATIVE_LENGTH_] - $starting_lentot;
my $excess_length =
$starting_indent + $length + $length_tol - $rOpts_maximum_line_length;
return $excess_length;
};
# look for single qw quotes nested in containers
my $KNEXT = 0;
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $outer_seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$outer_seqno ) {
next if ( $KK == 0 ); # first token in file may not be container
Fault("sequence = $outer_seqno not defined at K=$KK");
}
my $token = $rtoken_vars->[_TOKEN_];
if ( $is_opening_token{$token} ) {
# see if the next token is a quote of some type
my $Kn = $self->K_next_nonblank($KK);
next unless $Kn;
my $next_token = $rLL->[$Kn]->[_TOKEN_];
my $next_type = $rLL->[$Kn]->[_TYPE_];
next
unless ( ( $next_type eq 'q' || $next_type eq 'Q' )
&& $next_token =~ /^q/ );
# The token before the closing container must also be a quote
my $K_closing = $K_closing_container->{$outer_seqno};
my $Kt_end = $self->K_previous_nonblank($K_closing);
next unless $rLL->[$Kt_end]->[_TYPE_] eq $next_type;
# Do not weld to single-line quotes. Nothing is gained, and it may
# look bad.
next if ( $Kt_end == $Kn );
# Only weld to quotes delimited with container tokens. This is
# because welding to arbitrary quote delimiters can produce code
# which is less readable than without welding.
my $closing_delimiter = substr( $rLL->[$Kt_end]->[_TOKEN_], -1, 1 );
next
unless ( $is_closing_token{$closing_delimiter}
|| $closing_delimiter eq '>' );
# Now make sure that there is just a single quote in the container
next
unless ( $is_single_quote->( $Kn + 1, $Kt_end - 1, $next_type ) );
# If welded, the line must not exceed allowed line length
# Assume old line breaks for this estimate.
next if ( $excess_line_length->( $KK, $Kn ) > 0 );
# OK to weld
# FIXME: Are these always correct?
$weld_len_left_closing{$outer_seqno} = 1;
$weld_len_right_opening{$outer_seqno} = 2;
# QW PATCH 1 (Testing)
# undo CI for welded quotes
foreach my $K ( $Kn .. $Kt_end ) {
$rLL->[$K]->[_CI_LEVEL_] = 0;
}
# Change the level of a closing qw token to be that of the outer
# containing token. This will allow -lp indentation to function
# correctly in the vertical aligner.
$rLL->[$Kt_end]->[_LEVEL_] = $rLL->[$K_closing]->[_LEVEL_];
}
}
return;
}
sub weld_len_left {
my ( $seqno, $type_or_tok ) = @_;
# Given the sequence number of a token, and the token or its type,
# return the length of any weld to its left
my $weld_len;
if ($seqno) {
if ( $is_closing_type{$type_or_tok} ) {
$weld_len = $weld_len_left_closing{$seqno};
}
elsif ( $is_opening_type{$type_or_tok} ) {
$weld_len = $weld_len_left_opening{$seqno};
}
}
if ( !defined($weld_len) ) { $weld_len = 0 }
return $weld_len;
}
sub weld_len_right {
my ( $seqno, $type_or_tok ) = @_;
# Given the sequence number of a token, and the token or its type,
# return the length of any weld to its right
my $weld_len;
if ($seqno) {
if ( $is_closing_type{$type_or_tok} ) {
$weld_len = $weld_len_right_closing{$seqno};
}
elsif ( $is_opening_type{$type_or_tok} ) {
$weld_len = $weld_len_right_opening{$seqno};
}
}
if ( !defined($weld_len) ) { $weld_len = 0 }
return $weld_len;
}
sub weld_len_left_to_go {
my ($i) = @_;
# Given the index of a token in the 'to_go' array
# return the length of any weld to its left
return if ( $i < 0 );
my $weld_len =
weld_len_left( $type_sequence_to_go[$i], $types_to_go[$i] );
return $weld_len;
}
sub weld_len_right_to_go {
my ($i) = @_;
# Given the index of a token in the 'to_go' array
# return the length of any weld to its right
return if ( $i < 0 );
if ( $i > 0 && $types_to_go[$i] eq 'b' ) { $i-- }
my $weld_len =
weld_len_right( $type_sequence_to_go[$i], $types_to_go[$i] );
return $weld_len;
}
sub whitespace_cycle_adjustment {
my $self = shift;
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
my $radjusted_levels;
my $rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
if ( $rOpts_whitespace_cycle && $rOpts_whitespace_cycle > 0 ) {
my $whitespace_last_level = -1;
my @whitespace_level_stack = ();
my $last_nonblank_type = 'b';
my $last_nonblank_token = '';
my $Kmax = @{$rLL} - 1;
foreach my $KK ( 0 .. $Kmax ) {
my $level_abs = $rLL->[$KK]->[_LEVEL_];
my $level = $level_abs;
if ( $level_abs < $whitespace_last_level ) {
pop(@whitespace_level_stack);
}
if ( !@whitespace_level_stack ) {
push @whitespace_level_stack, $level_abs;
}
elsif ( $level_abs > $whitespace_last_level ) {
$level = $whitespace_level_stack[-1] +
( $level_abs - $whitespace_last_level );
if (
# 1 Try to break at a block brace
(
$level > $rOpts_whitespace_cycle
&& $last_nonblank_type eq '{'
&& $last_nonblank_token eq '{'
)
# 2 Then either a brace or bracket
|| ( $level > $rOpts_whitespace_cycle + 1
&& $last_nonblank_token =~ /^[\{\[]$/ )
# 3 Then a paren too
|| $level > $rOpts_whitespace_cycle + 2
)
{
$level = 1;
}
push @whitespace_level_stack, $level;
}
$level = $whitespace_level_stack[-1];
$radjusted_levels->[$KK] = $level;
$whitespace_last_level = $level_abs;
my $type = $rLL->[$KK]->[_TYPE_];
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $type ne 'b' ) {
$last_nonblank_type = $type;
$last_nonblank_token = $token;
}
}
}
$self->{radjusted_levels} = $radjusted_levels;
return;
}
sub bli_adjustment {
# if -bli is set, adds one continuation indentation for certain braces
my $self = shift;
return unless ( $rOpts->{'brace-left-and-indent'} );
my $rLL = $self->{rLL};
return unless ( defined($rLL) && @{$rLL} );
my $KNEXT = 0;
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $block_type = $rLL->[$KK]->[_BLOCK_TYPE_];
if ( $block_type && $block_type =~ /$bli_pattern/ ) {
$rLL->[$KK]->[_CI_LEVEL_]++;
}
}
return;
}
sub link_sequence_items {
# This has been merged into 'respace_tokens' but retained for reference
my $self = shift;
my $rlines = $self->{rlines};
my $rLL = $self->{rLL};
# We walk the token list and make links to the next sequence item.
# We also define these hashes to container tokens using sequence number as
# the key:
my $K_opening_container = {}; # opening [ { or (
my $K_closing_container = {}; # closing ] } or )
my $K_opening_ternary = {}; # opening ? of ternary
my $K_closing_ternary = {}; # closing : of ternary
# sub to link preceding nodes forward to a new node type
my $link_back = sub {
my ( $Ktop, $key ) = @_;
my $Kprev = $Ktop - 1;
while ( $Kprev >= 0
&& !defined( $rLL->[$Kprev]->[$key] ) )
{
$rLL->[$Kprev]->[$key] = $Ktop;
$Kprev -= 1;
}
};
for ( my $KK = 0 ; $KK < @{$rLL} ; $KK++ ) {
$rLL->[$KK]->[_KNEXT_SEQ_ITEM_] = undef;
my $type = $rLL->[$KK]->[_TYPE_];
next if ( $type eq 'b' );
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($type_sequence) {
$link_back->( $KK, _KNEXT_SEQ_ITEM_ );
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $is_opening_token{$token} ) {
$K_opening_container->{$type_sequence} = $KK;
}
elsif ( $is_closing_token{$token} ) {
$K_closing_container->{$type_sequence} = $KK;
}
# These are not yet used but could be useful
else {
if ( $token eq '?' ) {
$K_opening_ternary->{$type_sequence} = $KK;
}
elsif ( $token eq ':' ) {
$K_closing_ternary->{$type_sequence} = $KK;
}
else {
Fault(<<EOM);
Unknown sequenced token type '$type'. Expecting one of '{[(?:)]}'
EOM
}
}
}
}
$self->{K_opening_container} = $K_opening_container;
$self->{K_closing_container} = $K_closing_container;
$self->{K_opening_ternary} = $K_opening_ternary;
$self->{K_closing_ternary} = $K_closing_ternary;
return;
}
sub resync_lines_and_tokens {
my $self = shift;
my $rLL = $self->{rLL};
my $Klimit = $self->{Klimit};
my $rlines = $self->{rlines};
# Re-construct the arrays of tokens associated with the original input lines
# since they have probably changed due to inserting and deleting blanks
# and a few other tokens.
my $Kmax = -1;
# This is the next token and its line index:
my $Knext = 0;
my $inext;
if ( defined($rLL) && @{$rLL} ) {
$Kmax = @{$rLL} - 1;
$inext = $rLL->[$Knext]->[_LINE_INDEX_];
}
my $get_inext = sub {
if ( $Knext < 0 || $Knext > $Kmax ) { $inext = undef }
else {
$inext = $rLL->[$Knext]->[_LINE_INDEX_];
}
return $inext;
};
# Remember the most recently output token index
my $Klast_out;
my $iline = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$iline++;
my $line_type = $line_of_tokens->{_line_type};
if ( $line_type eq 'CODE' ) {
my @K_array;
my $rK_range;
$inext = $get_inext->();
while ( defined($inext) && $inext <= $iline ) {
push @{K_array}, $Knext;
$Knext += 1;
$inext = $get_inext->();
}
# Delete any terminal blank token
if (@K_array) {
if ( $rLL->[ $K_array[-1] ]->[_TYPE_] eq 'b' ) {
pop @K_array;
}
}
# Define the range of K indexes for the line:
# $Kfirst = index of first token on line
# $Klast_out = index of last token on line
my ( $Kfirst, $Klast );
if (@K_array) {
$Kfirst = $K_array[0];
$Klast = $K_array[-1];
$Klast_out = $Klast;
}
# It is only safe to trim the actual line text if the input
# line had a terminal blank token. Otherwise, we may be
# in a quote.
if ( $line_of_tokens->{_ended_in_blank_token} ) {
$line_of_tokens->{_line_text} =~ s/\s+$//;
}
$line_of_tokens->{_rK_range} = [ $Kfirst, $Klast ];
# Deleting semicolons can create new empty code lines
# which should be marked as blank
if ( !defined($Kfirst) ) {
my $code_type = $line_of_tokens->{_code_type};
if ( !$code_type ) {
$line_of_tokens->{_code_type} = 'BL';
}
}
}
}
# There shouldn't be any nodes beyond the last one unless we start
# allowing 'link_after' calls
if ( defined($inext) ) {
Fault("unexpected tokens at end of file when reconstructing lines");
}
return;
}
sub dump_verbatim {
my $self = shift;
my $rlines = $self->{rlines};
foreach my $line ( @{$rlines} ) {
my $input_line = $line->{_line_text};
$self->write_unindented_line($input_line);
}
return;
}
sub finish_formatting {
my ( $self, $severe_error ) = @_;
# The file has been tokenized and is ready to be formatted.
# All of the relevant data is stored in $self, ready to go.
# output file verbatim if severe error or no formatting requested
if ( $severe_error || $rOpts->{notidy} ) {
$self->dump_verbatim();
$self->wrapup();
return;
}
# Make a pass through the lines, looking at lines of CODE and identifying
# special processing needs, such format skipping sections marked by
# special comments
$self->scan_comments();
# Find nested pairs of container tokens for any welding. This information
# is also needed for adding semicolons, so it is split apart from the
# welding step.
$self->find_nested_pairs();
# Make sure everything looks good
$self->check_line_hashes();
# Future: Place to Begin future Iteration Loop
# foreach my $it_count(1..$maxit) {
# Future: We must reset some things after the first iteration.
# This includes:
# - resetting levels if there was any welding
# - resetting any phantom semicolons
# - dealing with any line numbering issues so we can relate final lines
# line numbers with input line numbers.
#
# If ($it_count>1) {
# Copy {level_raw} to [_LEVEL_] if ($it_count>1)
# Renumber lines
# }
# Make a pass through all tokens, adding or deleting any whitespace as
# required. Also make any other changes, such as adding semicolons.
# All token changes must be made here so that the token data structure
# remains fixed for the rest of this iteration.
$self->respace_tokens();
# Make a hierarchical map of the containers
$self->map_containers();
# Implement any welding needed for the -wn or -cb options
$self->weld_containers();
# Locate small nested blocks which should not be broken
$self->mark_short_nested_blocks();
# Set adjusted levels for the whitespace cycle option
$self->whitespace_cycle_adjustment();
# Adjust continuation indentation if -bli is set
$self->bli_adjustment();
# Finishes formatting and write the result to the line sink.
# Eventually this call should just change the 'rlines' data according to the
# new line breaks and then return so that we can do an internal iteration
# before continuing with the next stages of formatting.
$self->process_all_lines();
############################################################
# A possible future decomposition of 'process_all_lines()' follows.
# Benefits:
# - allow perltidy to do an internal iteration which eliminates
# many unnecessary steps, such as re-parsing and vertical alignment.
# This will allow iterations to be automatic.
# - consolidate all length calculations to allow utf8 alignment
############################################################
# Future: Check for convergence of beginning tokens on CODE lines
# Future: End of Iteration Loop
# Future: add_padding($rargs);
# Future: add_closing_side_comments($rargs);
# Future: vertical_alignment($rargs);
# Future: output results
# A final routine to tie up any loose ends
$self->wrapup();
return;
}
sub leading_spaces_to_go {
# return the number of indentation spaces for a token in the output stream;
# these were previously stored by 'set_leading_whitespace'.
my $ii = shift;
if ( $ii < 0 ) { $ii = 0 }
return get_spaces( $leading_spaces_to_go[$ii] );
}
sub get_spaces {
# return the number of leading spaces associated with an indentation
# variable $indentation is either a constant number of spaces or an object
# with a get_spaces method.
my $indentation = shift;
return ref($indentation) ? $indentation->get_spaces() : $indentation;
}
sub get_recoverable_spaces {
# return the number of spaces (+ means shift right, - means shift left)
# that we would like to shift a group of lines with the same indentation
# to get them to line up with their opening parens
my $indentation = shift;
return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
}
sub get_available_spaces_to_go {
my $ii = shift;
my $item = $leading_spaces_to_go[$ii];
# return the number of available leading spaces associated with an
# indentation variable. $indentation is either a constant number of
# spaces or an object with a get_available_spaces method.
return ref($item) ? $item->get_available_spaces() : 0;
}
sub new_lp_indentation_item {
# this is an interface to the IndentationItem class
my ( $spaces, $level, $ci_level, $available_spaces, $align_paren ) = @_;
# A negative level implies not to store the item in the item_list
my $index = 0;
if ( $level >= 0 ) { $index = ++$max_gnu_item_index; }
my $item = Perl::Tidy::IndentationItem->new(
spaces => $spaces,
level => $level,
ci_level => $ci_level,
available_spaces => $available_spaces,
index => $index,
gnu_sequence_number => $gnu_sequence_number,
align_paren => $align_paren,
stack_depth => $max_gnu_stack_index,
starting_index => $line_start_index_to_go,
);
if ( $level >= 0 ) {
$gnu_item_list[$max_gnu_item_index] = $item;
}
return $item;
}
sub set_leading_whitespace {
# This routine defines leading whitespace for the case of -lp formatting
# given: the level and continuation_level of a token,
# define: space count of leading string which would apply if it
# were the first token of a new line.
my ( $self, $Kj, $K_last_nonblank, $K_last_last_nonblank,
$level_abs, $ci_level, $in_continued_quote )
= @_;
return unless ($rOpts_line_up_parentheses);
return unless ( defined($max_index_to_go) && $max_index_to_go >= 0 );
# uses Global Symbols:
# "$gnu_position_predictor"
# "$gnu_sequence_number"
# "$line_start_index_to_go"
# "$max_gnu_item_index"
# "$max_gnu_stack_index"
# "$max_index_to_go"
# "$rOpts_continuation_indentation"
# "$rOpts_indent_columns"
# "$rOpts_line_up_parentheses"
# "$rOpts_maximum_line_length"
# "%gnu_arrow_count"
# "%gnu_comma_count"
# "%is_assignment"
# "%is_if_unless_and_or_last_next_redo_return"
# "%last_gnu_equals"
# "%tightness"
# "%want_break_before"
# "@K_to_go"
# "@block_type_to_go"
# "@gnu_item_list"
# "@gnu_stack"
# "@leading_spaces_to_go"
# "@nesting_depth_to_go"
# "@old_breakpoint_to_go"
# "@reduced_spaces_to_go"
# "@token_lengths_to_go"
# "@tokens_to_go"
# "@types_to_go"
my $rbreak_container = $self->{rbreak_container};
my $rshort_nested = $self->{rshort_nested};
my $rLL = $self->{rLL};
# find needed previous nonblank tokens
my $last_nonblank_token = '';
my $last_nonblank_type = '';
my $last_nonblank_block_type = '';
# and previous nonblank tokens, just in this batch:
my $last_nonblank_token_in_batch = '';
my $last_nonblank_type_in_batch = '';
my $last_last_nonblank_type_in_batch = '';
if ( defined($K_last_nonblank) ) {
$last_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
$last_nonblank_type = $rLL->[$K_last_nonblank]->[_TYPE_];
$last_nonblank_block_type = $rLL->[$K_last_nonblank]->[_BLOCK_TYPE_];
if ( $K_last_nonblank >= $K_to_go[0] ) {
$last_nonblank_token_in_batch = $last_nonblank_token;
$last_nonblank_type_in_batch = $last_nonblank_type;
if ( defined($K_last_last_nonblank)
&& $K_last_last_nonblank > $K_to_go[0] )
{
$last_last_nonblank_type_in_batch =
$rLL->[$K_last_last_nonblank]->[_TYPE_];
}
}
}
################################################################
# Adjust levels if necessary to recycle whitespace:
my $level = $level_abs;
my $radjusted_levels = $self->{radjusted_levels};
if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
$level = $radjusted_levels->[$Kj];
}
# The continued_quote flag means that this is the first token of a
# line, and it is the continuation of some kind of multi-line quote
# or pattern. It requires special treatment because it must have no
# added leading whitespace. So we create a special indentation item
# which is not in the stack.
if ($in_continued_quote) {
my $space_count = 0;
my $available_space = 0;
$level = -1; # flag to prevent storing in item_list
$leading_spaces_to_go[$max_index_to_go] =
$reduced_spaces_to_go[$max_index_to_go] =
new_lp_indentation_item( $space_count, $level, $ci_level,
$available_space, 0 );
return;
}
# get the top state from the stack
my $space_count = $gnu_stack[$max_gnu_stack_index]->get_spaces();
my $current_level = $gnu_stack[$max_gnu_stack_index]->get_level();
my $current_ci_level = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
my $type = $types_to_go[$max_index_to_go];
my $token = $tokens_to_go[$max_index_to_go];
my $total_depth = $nesting_depth_to_go[$max_index_to_go];
if ( $type eq '{' || $type eq '(' ) {
$gnu_comma_count{ $total_depth + 1 } = 0;
$gnu_arrow_count{ $total_depth + 1 } = 0;
# If we come to an opening token after an '=' token of some type,
# see if it would be helpful to 'break' after the '=' to save space
my $last_equals = $last_gnu_equals{$total_depth};
if ( $last_equals && $last_equals > $line_start_index_to_go ) {
# find the position if we break at the '='
my $i_test = $last_equals;
if ( $types_to_go[ $i_test + 1 ] eq 'b' ) { $i_test++ }
# TESTING
##my $too_close = ($i_test==$max_index_to_go-1);
my $test_position = total_line_length( $i_test, $max_index_to_go );
my $mll = maximum_line_length($i_test);
if (
# the equals is not just before an open paren (testing)
##!$too_close &&
# if we are beyond the midpoint
$gnu_position_predictor > $mll - $rOpts_maximum_line_length / 2
# or we are beyond the 1/4 point and there was an old
# break at the equals
|| (
$gnu_position_predictor >
$mll - $rOpts_maximum_line_length * 3 / 4
&& (
$old_breakpoint_to_go[$last_equals]
|| ( $last_equals > 0
&& $old_breakpoint_to_go[ $last_equals - 1 ] )
|| ( $last_equals > 1
&& $types_to_go[ $last_equals - 1 ] eq 'b'
&& $old_breakpoint_to_go[ $last_equals - 2 ] )
)
)
)
{
# then make the switch -- note that we do not set a real
# breakpoint here because we may not really need one; sub
# scan_list will do that if necessary
$line_start_index_to_go = $i_test + 1;
$gnu_position_predictor = $test_position;
}
}
}
my $halfway =
maximum_line_length_for_level($level) - $rOpts_maximum_line_length / 2;
# Check for decreasing depth ..
# Note that one token may have both decreasing and then increasing
# depth. For example, (level, ci) can go from (1,1) to (2,0). So,
# in this example we would first go back to (1,0) then up to (2,0)
# in a single call.
if ( $level < $current_level || $ci_level < $current_ci_level ) {
# loop to find the first entry at or completely below this level
my ( $lev, $ci_lev );
while (1) {
if ($max_gnu_stack_index) {
# save index of token which closes this level
$gnu_stack[$max_gnu_stack_index]->set_closed($max_index_to_go);
# Undo any extra indentation if we saw no commas
my $available_spaces =
$gnu_stack[$max_gnu_stack_index]->get_available_spaces();
my $comma_count = 0;
my $arrow_count = 0;
if ( $type eq '}' || $type eq ')' ) {
$comma_count = $gnu_comma_count{$total_depth};
$arrow_count = $gnu_arrow_count{$total_depth};
$comma_count = 0 unless $comma_count;
$arrow_count = 0 unless $arrow_count;
}
$gnu_stack[$max_gnu_stack_index]->set_comma_count($comma_count);
$gnu_stack[$max_gnu_stack_index]->set_arrow_count($arrow_count);
if ( $available_spaces > 0 ) {
if ( $comma_count <= 0 || $arrow_count > 0 ) {
my $i = $gnu_stack[$max_gnu_stack_index]->get_index();
my $seqno =
$gnu_stack[$max_gnu_stack_index]
->get_sequence_number();
# Be sure this item was created in this batch. This
# should be true because we delete any available
# space from open items at the end of each batch.
if ( $gnu_sequence_number != $seqno
|| $i > $max_gnu_item_index )
{
warning(
"Program bug with -lp. seqno=$seqno should be $gnu_sequence_number and i=$i should be less than max=$max_gnu_item_index\n"
);
report_definite_bug();
}
else {
if ( $arrow_count == 0 ) {
$gnu_item_list[$i]
->permanently_decrease_available_spaces(
$available_spaces);
}
else {
$gnu_item_list[$i]
->tentatively_decrease_available_spaces(
$available_spaces);
}
foreach my $j ( $i + 1 .. $max_gnu_item_index ) {
$gnu_item_list[$j]
->decrease_SPACES($available_spaces);
}
}
}
}
# go down one level
--$max_gnu_stack_index;
$lev = $gnu_stack[$max_gnu_stack_index]->get_level();
$ci_lev = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
# stop when we reach a level at or below the current level
if ( $lev <= $level && $ci_lev <= $ci_level ) {
$space_count =
$gnu_stack[$max_gnu_stack_index]->get_spaces();
$current_level = $lev;
$current_ci_level = $ci_lev;
last;
}
}
# reached bottom of stack .. should never happen because
# only negative levels can get here, and $level was forced
# to be positive above.
else {
warning(
"program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp\n"
);
report_definite_bug();
last;
}
}
}
# handle increasing depth
if ( $level > $current_level || $ci_level > $current_ci_level ) {
# Compute the standard incremental whitespace. This will be
# the minimum incremental whitespace that will be used. This
# choice results in a smooth transition between the gnu-style
# and the standard style.
my $standard_increment =
( $level - $current_level ) * $rOpts_indent_columns +
( $ci_level - $current_ci_level ) * $rOpts_continuation_indentation;
# Now we have to define how much extra incremental space
# ("$available_space") we want. This extra space will be
# reduced as necessary when long lines are encountered or when
# it becomes clear that we do not have a good list.
my $available_space = 0;
my $align_paren = 0;
my $excess = 0;
# initialization on empty stack..
if ( $max_gnu_stack_index == 0 ) {
$space_count = $level * $rOpts_indent_columns;
}
# if this is a BLOCK, add the standard increment
elsif ($last_nonblank_block_type) {
$space_count += $standard_increment;
}
# if last nonblank token was not structural indentation,
# just use standard increment
elsif ( $last_nonblank_type ne '{' ) {
$space_count += $standard_increment;
}
# otherwise use the space to the first non-blank level change token
else {
$space_count = $gnu_position_predictor;
my $min_gnu_indentation =
$gnu_stack[$max_gnu_stack_index]->get_spaces();
$available_space = $space_count - $min_gnu_indentation;
if ( $available_space >= $standard_increment ) {
$min_gnu_indentation += $standard_increment;
}
elsif ( $available_space > 1 ) {
$min_gnu_indentation += $available_space + 1;
}
elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
if ( ( $tightness{$last_nonblank_token} < 2 ) ) {
$min_gnu_indentation += 2;
}
else {
$min_gnu_indentation += 1;
}
}
else {
$min_gnu_indentation += $standard_increment;
}
$available_space = $space_count - $min_gnu_indentation;
if ( $available_space < 0 ) {
$space_count = $min_gnu_indentation;
$available_space = 0;
}
$align_paren = 1;
}
# update state, but not on a blank token
if ( $types_to_go[$max_index_to_go] ne 'b' ) {
$gnu_stack[$max_gnu_stack_index]->set_have_child(1);
++$max_gnu_stack_index;
$gnu_stack[$max_gnu_stack_index] =
new_lp_indentation_item( $space_count, $level, $ci_level,
$available_space, $align_paren );
# If the opening paren is beyond the half-line length, then
# we will use the minimum (standard) indentation. This will
# help avoid problems associated with running out of space
# near the end of a line. As a result, in deeply nested
# lists, there will be some indentations which are limited
# to this minimum standard indentation. But the most deeply
# nested container will still probably be able to shift its
# parameters to the right for proper alignment, so in most
# cases this will not be noticeable.
if ( $available_space > 0 && $space_count > $halfway ) {
$gnu_stack[$max_gnu_stack_index]
->tentatively_decrease_available_spaces($available_space);
}
}
}
# Count commas and look for non-list characters. Once we see a
# non-list character, we give up and don't look for any more commas.
if ( $type eq '=>' ) {
$gnu_arrow_count{$total_depth}++;
# tentatively treating '=>' like '=' for estimating breaks
# TODO: this could use some experimentation
$last_gnu_equals{$total_depth} = $max_index_to_go;
}
elsif ( $type eq ',' ) {
$gnu_comma_count{$total_depth}++;
}
elsif ( $is_assignment{$type} ) {
$last_gnu_equals{$total_depth} = $max_index_to_go;
}
# this token might start a new line
# if this is a non-blank..
if ( $type ne 'b' ) {
# and if ..
if (
# this is the first nonblank token of the line
$max_index_to_go == 1 && $types_to_go[0] eq 'b'
# or previous character was one of these:
|| $last_nonblank_type_in_batch =~ /^([\:\?\,f])$/
# or previous character was opening and this does not close it
|| ( $last_nonblank_type_in_batch eq '{' && $type ne '}' )
|| ( $last_nonblank_type_in_batch eq '(' and $type ne ')' )
# or this token is one of these:
|| $type =~ /^([\.]|\|\||\&\&)$/
# or this is a closing structure
|| ( $last_nonblank_type_in_batch eq '}'
&& $last_nonblank_token_in_batch eq
$last_nonblank_type_in_batch )
# or previous token was keyword 'return'
|| (
$last_nonblank_type_in_batch eq 'k'
&& ( $last_nonblank_token_in_batch eq 'return'
&& $type ne '{' )
)
# or starting a new line at certain keywords is fine
|| ( $type eq 'k'
&& $is_if_unless_and_or_last_next_redo_return{$token} )
# or this is after an assignment after a closing structure
|| (
$is_assignment{$last_nonblank_type_in_batch}
&& (
$last_last_nonblank_type_in_batch =~ /^[\}\)\]]$/
# and it is significantly to the right
|| $gnu_position_predictor > $halfway
)
)
)
{
check_for_long_gnu_style_lines();
$line_start_index_to_go = $max_index_to_go;
# back up 1 token if we want to break before that type
# otherwise, we may strand tokens like '?' or ':' on a line
if ( $line_start_index_to_go > 0 ) {
if ( $last_nonblank_type_in_batch eq 'k' ) {
if ( $want_break_before{$last_nonblank_token_in_batch} ) {
$line_start_index_to_go--;
}
}
elsif ( $want_break_before{$last_nonblank_type_in_batch} ) {
$line_start_index_to_go--;
}
}
}
}
# remember the predicted position of this token on the output line
if ( $max_index_to_go > $line_start_index_to_go ) {
$gnu_position_predictor =
total_line_length( $line_start_index_to_go, $max_index_to_go );
}
else {
$gnu_position_predictor =
$space_count + $token_lengths_to_go[$max_index_to_go];
}
# store the indentation object for this token
# this allows us to manipulate the leading whitespace
# (in case we have to reduce indentation to fit a line) without
# having to change any token values
$leading_spaces_to_go[$max_index_to_go] = $gnu_stack[$max_gnu_stack_index];
$reduced_spaces_to_go[$max_index_to_go] =
( $max_gnu_stack_index > 0 && $ci_level )
? $gnu_stack[ $max_gnu_stack_index - 1 ]
: $gnu_stack[$max_gnu_stack_index];
return;
}
sub check_for_long_gnu_style_lines {
# look at the current estimated maximum line length, and
# remove some whitespace if it exceeds the desired maximum
# this is only for the '-lp' style
return unless ($rOpts_line_up_parentheses);
# nothing can be done if no stack items defined for this line
return if ( $max_gnu_item_index == UNDEFINED_INDEX );
# see if we have exceeded the maximum desired line length
# keep 2 extra free because they are needed in some cases
# (result of trial-and-error testing)
my $spaces_needed =
$gnu_position_predictor - maximum_line_length($max_index_to_go) + 2;
return if ( $spaces_needed <= 0 );
# We are over the limit, so try to remove a requested number of
# spaces from leading whitespace. We are only allowed to remove
# from whitespace items created on this batch, since others have
# already been used and cannot be undone.
my @candidates = ();
my $i;
# loop over all whitespace items created for the current batch
for ( $i = 0 ; $i <= $max_gnu_item_index ; $i++ ) {
my $item = $gnu_item_list[$i];
# item must still be open to be a candidate (otherwise it
# cannot influence the current token)
next if ( $item->get_closed() >= 0 );
my $available_spaces = $item->get_available_spaces();
if ( $available_spaces > 0 ) {
push( @candidates, [ $i, $available_spaces ] );
}
}
return unless (@candidates);
# sort by available whitespace so that we can remove whitespace
# from the maximum available first
@candidates = sort { $b->[1] <=> $a->[1] } @candidates;
# keep removing whitespace until we are done or have no more
foreach my $candidate (@candidates) {
my ( $i, $available_spaces ) = @{$candidate};
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
# remove the incremental space from this item
$gnu_item_list[$i]->decrease_available_spaces($deleted_spaces);
my $i_debug = $i;
# update the leading whitespace of this item and all items
# that came after it
for ( ; $i <= $max_gnu_item_index ; $i++ ) {
my $old_spaces = $gnu_item_list[$i]->get_spaces();
if ( $old_spaces >= $deleted_spaces ) {
$gnu_item_list[$i]->decrease_SPACES($deleted_spaces);
}
# shouldn't happen except for code bug:
else {
my $level = $gnu_item_list[$i_debug]->get_level();
my $ci_level = $gnu_item_list[$i_debug]->get_ci_level();
my $old_level = $gnu_item_list[$i]->get_level();
my $old_ci_level = $gnu_item_list[$i]->get_ci_level();
warning(
"program bug with -lp: want to delete $deleted_spaces from item $i, but old=$old_spaces deleted: lev=$level ci=$ci_level deleted: level=$old_level ci=$ci_level\n"
);
report_definite_bug();
}
}
$gnu_position_predictor -= $deleted_spaces;
$spaces_needed -= $deleted_spaces;
last unless ( $spaces_needed > 0 );
}
return;
}
sub finish_lp_batch {
# This routine is called once after each output stream batch is
# finished to undo indentation for all incomplete -lp
# indentation levels. It is too risky to leave a level open,
# because then we can't backtrack in case of a long line to follow.
# This means that comments and blank lines will disrupt this
# indentation style. But the vertical aligner may be able to
# get the space back if there are side comments.
# this is only for the 'lp' style
return unless ($rOpts_line_up_parentheses);
# nothing can be done if no stack items defined for this line
return if ( $max_gnu_item_index == UNDEFINED_INDEX );
# loop over all whitespace items created for the current batch
foreach my $i ( 0 .. $max_gnu_item_index ) {
my $item = $gnu_item_list[$i];
# only look for open items
next if ( $item->get_closed() >= 0 );
# Tentatively remove all of the available space
# (The vertical aligner will try to get it back later)
my $available_spaces = $item->get_available_spaces();
if ( $available_spaces > 0 ) {
# delete incremental space for this item
$gnu_item_list[$i]
->tentatively_decrease_available_spaces($available_spaces);
# Reduce the total indentation space of any nodes that follow
# Note that any such nodes must necessarily be dependents
# of this node.
foreach ( $i + 1 .. $max_gnu_item_index ) {
$gnu_item_list[$_]->decrease_SPACES($available_spaces);
}
}
}
return;
}
sub reduce_lp_indentation {
# reduce the leading whitespace at token $i if possible by $spaces_needed
# (a large value of $spaces_needed will remove all excess space)
# NOTE: to be called from scan_list only for a sequence of tokens
# contained between opening and closing parens/braces/brackets
my ( $i, $spaces_wanted ) = @_;
my $deleted_spaces = 0;
my $item = $leading_spaces_to_go[$i];
my $available_spaces = $item->get_available_spaces();
if (
$available_spaces > 0
&& ( ( $spaces_wanted <= $available_spaces )
|| !$item->get_have_child() )
)
{
# we'll remove these spaces, but mark them as recoverable
$deleted_spaces =
$item->tentatively_decrease_available_spaces($spaces_wanted);
}
return $deleted_spaces;
}
sub token_sequence_length {
# return length of tokens ($ibeg .. $iend) including $ibeg & $iend
# returns 0 if $ibeg > $iend (shouldn't happen)
my ( $ibeg, $iend ) = @_;
return 0 if ( $iend < 0 || $ibeg > $iend );
return $summed_lengths_to_go[ $iend + 1 ] if ( $ibeg < 0 );
return $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
}
sub total_line_length {
# return length of a line of tokens ($ibeg .. $iend)
my ( $ibeg, $iend ) = @_;
return leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
}
sub maximum_line_length_for_level {
# return maximum line length for line starting with a given level
my $maximum_line_length = $rOpts_maximum_line_length;
# Modify if -vmll option is selected
if ($rOpts_variable_maximum_line_length) {
my $level = shift;
if ( $level < 0 ) { $level = 0 }
$maximum_line_length += $level * $rOpts_indent_columns;
}
return $maximum_line_length;
}
sub maximum_line_length {
# return maximum line length for line starting with the token at given index
my $ii = shift;
return maximum_line_length_for_level( $levels_to_go[$ii] );
}
sub excess_line_length {
# return number of characters by which a line of tokens ($ibeg..$iend)
# exceeds the allowable line length.
my ( $ibeg, $iend, $ignore_left_weld, $ignore_right_weld ) = @_;
# Include left and right weld lengths unless requested not to
my $wl = $ignore_left_weld ? 0 : weld_len_left_to_go($iend);
my $wr = $ignore_right_weld ? 0 : weld_len_right_to_go($iend);
return total_line_length( $ibeg, $iend ) + $wl + $wr -
maximum_line_length($ibeg);
}
sub wrapup {
# flush buffer and write any informative messages
my $self = shift;
$self->flush();
$file_writer_object->decrement_output_line_number()
; # fix up line number since it was incremented
we_are_at_the_last_line();
if ( $added_semicolon_count > 0 ) {
my $first = ( $added_semicolon_count > 1 ) ? "First" : "";
my $what =
( $added_semicolon_count > 1 ) ? "semicolons were" : "semicolon was";
write_logfile_entry("$added_semicolon_count $what added:\n");
write_logfile_entry(
" $first at input line $first_added_semicolon_at\n");
if ( $added_semicolon_count > 1 ) {
write_logfile_entry(
" Last at input line $last_added_semicolon_at\n");
}
write_logfile_entry(" (Use -nasc to prevent semicolon addition)\n");
write_logfile_entry("\n");
}
if ( $deleted_semicolon_count > 0 ) {
my $first = ( $deleted_semicolon_count > 1 ) ? "First" : "";
my $what =
( $deleted_semicolon_count > 1 )
? "semicolons were"
: "semicolon was";
write_logfile_entry(
"$deleted_semicolon_count unnecessary $what deleted:\n");
write_logfile_entry(
" $first at input line $first_deleted_semicolon_at\n");
if ( $deleted_semicolon_count > 1 ) {
write_logfile_entry(
" Last at input line $last_deleted_semicolon_at\n");
}
write_logfile_entry(" (Use -ndsm to prevent semicolon deletion)\n");
write_logfile_entry("\n");
}
if ( $embedded_tab_count > 0 ) {
my $first = ( $embedded_tab_count > 1 ) ? "First" : "";
my $what =
( $embedded_tab_count > 1 )
? "quotes or patterns"
: "quote or pattern";
write_logfile_entry("$embedded_tab_count $what had embedded tabs:\n");
write_logfile_entry(
"This means the display of this script could vary with device or software\n"
);
write_logfile_entry(" $first at input line $first_embedded_tab_at\n");
if ( $embedded_tab_count > 1 ) {
write_logfile_entry(
" Last at input line $last_embedded_tab_at\n");
}
write_logfile_entry("\n");
}
if ($first_tabbing_disagreement) {
write_logfile_entry(
"First indentation disagreement seen at input line $first_tabbing_disagreement\n"
);
}
if ($in_tabbing_disagreement) {
write_logfile_entry(
"Ending with indentation disagreement which started at input line $in_tabbing_disagreement\n"
);
}
else {
if ($last_tabbing_disagreement) {
write_logfile_entry(
"Last indentation disagreement seen at input line $last_tabbing_disagreement\n"
);
}
else {
write_logfile_entry("No indentation disagreement seen\n");
}
}
if ($first_tabbing_disagreement) {
write_logfile_entry(
"Note: Indentation disagreement detection is not accurate for outdenting and -lp.\n"
);
}
write_logfile_entry("\n");
$vertical_aligner_object->report_anything_unusual();
$file_writer_object->report_line_length_errors();
return;
}
sub check_options {
# This routine is called to check the Opts hash after it is defined
$rOpts = shift;
initialize_whitespace_hashes();
initialize_bond_strength_hashes();
make_static_block_comment_pattern();
make_static_side_comment_pattern();
make_closing_side_comment_prefix();
make_closing_side_comment_list_pattern();
$format_skipping_pattern_begin =
make_format_skipping_pattern( 'format-skipping-begin', '#<<<' );
$format_skipping_pattern_end =
make_format_skipping_pattern( 'format-skipping-end', '#>>>' );
# If closing side comments ARE selected, then we can safely
# delete old closing side comments unless closing side comment
# warnings are requested. This is a good idea because it will
# eliminate any old csc's which fall below the line count threshold.
# We cannot do this if warnings are turned on, though, because we
# might delete some text which has been added. So that must
# be handled when comments are created.
if ( $rOpts->{'closing-side-comments'} ) {
if ( !$rOpts->{'closing-side-comment-warnings'} ) {
$rOpts->{'delete-closing-side-comments'} = 1;
}
}
# If closing side comments ARE NOT selected, but warnings ARE
# selected and we ARE DELETING csc's, then we will pretend to be
# adding with a huge interval. This will force the comments to be
# generated for comparison with the old comments, but not added.
elsif ( $rOpts->{'closing-side-comment-warnings'} ) {
if ( $rOpts->{'delete-closing-side-comments'} ) {
$rOpts->{'delete-closing-side-comments'} = 0;
$rOpts->{'closing-side-comments'} = 1;
$rOpts->{'closing-side-comment-interval'} = 100000000;
}
}
make_sub_matching_pattern();
make_bli_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
make_keyword_group_list_pattern();
# Make initial list of desired one line block types
# They will be modified by 'prepare_cuddled_block_types'
%want_one_line_block = %is_sort_map_grep_eval;
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
dump_cuddled_block_list(*STDOUT);
Exit(0);
}
if ( $rOpts->{'line-up-parentheses'} ) {
if ( $rOpts->{'indent-only'}
|| !$rOpts->{'add-newlines'}
|| !$rOpts->{'delete-old-newlines'} )
{
Warn(<<EOM);
-----------------------------------------------------------------------
Conflict: -lp conflicts with -io, -fnl, -nanl, or -ndnl; ignoring -lp
The -lp indentation logic requires that perltidy be able to coordinate
arbitrarily large numbers of line breakpoints. This isn't possible
with these flags. Sometimes an acceptable workaround is to use -wocb=3
-----------------------------------------------------------------------
EOM
$rOpts->{'line-up-parentheses'} = 0;
}
}
# At present, tabs are not compatible with the line-up-parentheses style
# (it would be possible to entab the total leading whitespace
# just prior to writing the line, if desired).
if ( $rOpts->{'line-up-parentheses'} && $rOpts->{'tabs'} ) {
Warn(<<EOM);
Conflict: -t (tabs) cannot be used with the -lp option; ignoring -t; see -et.
EOM
$rOpts->{'tabs'} = 0;
}
# Likewise, tabs are not compatible with outdenting..
if ( $rOpts->{'outdent-keywords'} && $rOpts->{'tabs'} ) {
Warn(<<EOM);
Conflict: -t (tabs) cannot be used with the -okw options; ignoring -t; see -et.
EOM
$rOpts->{'tabs'} = 0;
}
if ( $rOpts->{'outdent-labels'} && $rOpts->{'tabs'} ) {
Warn(<<EOM);
Conflict: -t (tabs) cannot be used with the -ola option; ignoring -t; see -et.
EOM
$rOpts->{'tabs'} = 0;
}
if ( !$rOpts->{'space-for-semicolon'} ) {
$want_left_space{'f'} = -1;
}
if ( $rOpts->{'space-terminal-semicolon'} ) {
$want_left_space{';'} = 1;
}
# implement outdenting preferences for keywords
%outdent_keyword = ();
my @okw = split_words( $rOpts->{'outdent-keyword-list'} );
unless (@okw) {
@okw = qw(next last redo goto return); # defaults
}
# FUTURE: if not a keyword, assume that it is an identifier
foreach (@okw) {
if ( $Perl::Tidy::Tokenizer::is_keyword{$_} ) {
$outdent_keyword{$_} = 1;
}
else {
Warn("ignoring '$_' in -okwl list; not a perl keyword");
}
}
# setup hash for -kpit option
%keyword_paren_inner_tightness = ();
my $kpit_value = $rOpts->{'keyword-paren-inner-tightness'};
if ( defined($kpit_value) && $kpit_value != 1 ) {
my @kpit =
split_words( $rOpts->{'keyword-paren-inner-tightness-list'} );
unless (@kpit) {
@kpit = qw(if elsif unless while until for foreach); # defaults
}
# we will allow keywords and user-defined identifiers
foreach (@kpit) {
$keyword_paren_inner_tightness{$_} = $kpit_value;
}
}
# implement user whitespace preferences
if ( my @q = split_words( $rOpts->{'want-left-space'} ) ) {
@want_left_space{@q} = (1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'want-right-space'} ) ) {
@want_right_space{@q} = (1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'nowant-left-space'} ) ) {
@want_left_space{@q} = (-1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'nowant-right-space'} ) ) {
@want_right_space{@q} = (-1) x scalar(@q);
}
if ( $rOpts->{'dump-want-left-space'} ) {
dump_want_left_space(*STDOUT);
Exit(0);
}
if ( $rOpts->{'dump-want-right-space'} ) {
dump_want_right_space(*STDOUT);
Exit(0);
}
# default keywords for which space is introduced before an opening paren
# (at present, including them messes up vertical alignment)
my @sak = qw(my local our and or xor err eq ne if else elsif until
unless while for foreach return switch case given when catch);
%space_after_keyword = map { $_ => 1 } @sak;
# first remove any or all of these if desired
if ( my @q = split_words( $rOpts->{'nospace-after-keyword'} ) ) {
# -nsak='*' selects all the above keywords
if ( @q == 1 && $q[0] eq '*' ) { @q = keys(%space_after_keyword) }
@space_after_keyword{@q} = (0) x scalar(@q);
}
# then allow user to add to these defaults
if ( my @q = split_words( $rOpts->{'space-after-keyword'} ) ) {
@space_after_keyword{@q} = (1) x scalar(@q);
}
# implement user break preferences
my @all_operators = qw(% + - * / x != == >= <= =~ !~ < > | &
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
. : ? && || and or err xor
);
my $break_after = sub {
my @toks = @_;
foreach my $tok (@toks) {
if ( $tok eq '?' ) { $tok = ':' } # patch to coordinate ?/:
my $lbs = $left_bond_strength{$tok};
my $rbs = $right_bond_strength{$tok};
if ( defined($lbs) && defined($rbs) && $lbs < $rbs ) {
( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
( $lbs, $rbs );
}
}
};
my $break_before = sub {
my @toks = @_;
foreach my $tok (@toks) {
my $lbs = $left_bond_strength{$tok};
my $rbs = $right_bond_strength{$tok};
if ( defined($lbs) && defined($rbs) && $rbs < $lbs ) {
( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
( $lbs, $rbs );
}
}
};
$break_after->(@all_operators) if ( $rOpts->{'break-after-all-operators'} );
$break_before->(@all_operators)
if ( $rOpts->{'break-before-all-operators'} );
$break_after->( split_words( $rOpts->{'want-break-after'} ) );
$break_before->( split_words( $rOpts->{'want-break-before'} ) );
# make note if breaks are before certain key types
%want_break_before = ();
foreach my $tok ( @all_operators, ',' ) {
$want_break_before{$tok} =
$left_bond_strength{$tok} < $right_bond_strength{$tok};
}
# Coordinate ?/: breaks, which must be similar
if ( !$want_break_before{':'} ) {
$want_break_before{'?'} = $want_break_before{':'};
$right_bond_strength{'?'} = $right_bond_strength{':'} + 0.01;
$left_bond_strength{'?'} = NO_BREAK;
}
# Define here tokens which may follow the closing brace of a do statement
# on the same line, as in:
# } while ( $something);
my @dof = qw(until while unless if ; : );
push @dof, ',';
@is_do_follower{@dof} = (1) x scalar(@dof);
# What tokens may follow the closing brace of an if or elsif block?
# Not used. Previously used for cuddled else, but no longer needed.
%is_if_brace_follower = ();
# nothing can follow the closing curly of an else { } block:
%is_else_brace_follower = ();
# what can follow a multi-line anonymous sub definition closing curly:
my @asf = qw# ; : => or and && || ~~ !~~ ) #;
push @asf, ',';
@is_anon_sub_brace_follower{@asf} = (1) x scalar(@asf);
# what can follow a one-line anonymous sub closing curly:
# one-line anonymous subs also have ']' here...
# see tk3.t and PP.pm
my @asf1 = qw# ; : => or and && || ) ] ~~ !~~ #;
push @asf1, ',';
@is_anon_sub_1_brace_follower{@asf1} = (1) x scalar(@asf1);
# What can follow a closing curly of a block
# which is not an if/elsif/else/do/sort/map/grep/eval/sub
# Testfiles: 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl'
my @obf = qw# ; : => or and && || ) #;
push @obf, ',';
@is_other_brace_follower{@obf} = (1) x scalar(@obf);
$right_bond_strength{'{'} = WEAK;
$left_bond_strength{'{'} = VERY_STRONG;
# make -l=0 equal to -l=infinite
if ( !$rOpts->{'maximum-line-length'} ) {
$rOpts->{'maximum-line-length'} = 1000000;
}
# make -lbl=0 equal to -lbl=infinite
if ( !$rOpts->{'long-block-line-count'} ) {
$rOpts->{'long-block-line-count'} = 1000000;
}
my $ole = $rOpts->{'output-line-ending'};
if ($ole) {
my %endings = (
dos => "\015\012",
win => "\015\012",
mac => "\015",
unix => "\012",
);
# Patch for RT #99514, a memoization issue.
# Normally, the user enters one of 'dos', 'win', etc, and we change the
# value in the options parameter to be the corresponding line ending
# character. But, if we are using memoization, on later passes through
# here the option parameter will already have the desired ending
# character rather than the keyword 'dos', 'win', etc. So
# we must check to see if conversion has already been done and, if so,
# bypass the conversion step.
my %endings_inverted = (
"\015\012" => 'dos',
"\015\012" => 'win',
"\015" => 'mac',
"\012" => 'unix',
);
if ( defined( $endings_inverted{$ole} ) ) {
# we already have valid line ending, nothing more to do
}
else {
$ole = lc $ole;
unless ( $rOpts->{'output-line-ending'} = $endings{$ole} ) {
my $str = join " ", keys %endings;
Die(<<EOM);
Unrecognized line ending '$ole'; expecting one of: $str
EOM
}
if ( $rOpts->{'preserve-line-endings'} ) {
Warn("Ignoring -ple; conflicts with -ole\n");
$rOpts->{'preserve-line-endings'} = undef;
}
}
}
# hashes used to simplify setting whitespace
%tightness = (
'{' => $rOpts->{'brace-tightness'},
'}' => $rOpts->{'brace-tightness'},
'(' => $rOpts->{'paren-tightness'},
')' => $rOpts->{'paren-tightness'},
'[' => $rOpts->{'square-bracket-tightness'},
']' => $rOpts->{'square-bracket-tightness'},
);
%matching_token = (
'{' => '}',
'(' => ')',
'[' => ']',
'?' => ':',
);
if ( $rOpts->{'ignore-old-breakpoints'} ) {
if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -bom; -bom will be ignored\n"
);
}
if ( $rOpts->{'break-at-old-comma-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -boc; -boc will be ignored\n"
);
}
if ( $rOpts->{'break-at-old-semicolon-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -bos; -bos will be ignored\n"
);
}
# Note: there are additional parameters that can be made inactive by
# -iob, but they are on by default so we would generate excessive
# warnings if we noted them. They are:
# $rOpts->{'break-at-old-keyword-breakpoints'}
# $rOpts->{'break-at-old-logical-breakpoints'}
# $rOpts->{'break-at-old-ternary-breakpoints'}
# $rOpts->{'break-at-old-attribute-breakpoints'}
}
# very frequently used parameters made global for efficiency
$rOpts_closing_side_comment_maximum_text =
$rOpts->{'closing-side-comment-maximum-text'};
$rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
$rOpts_indent_columns = $rOpts->{'indent-columns'};
$rOpts_line_up_parentheses = $rOpts->{'line-up-parentheses'};
$rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
$rOpts_variable_maximum_line_length =
$rOpts->{'variable-maximum-line-length'};
# Note that both opening and closing tokens can access the opening
# and closing flags of their container types.
%opening_vertical_tightness = (
'(' => $rOpts->{'paren-vertical-tightness'},
'{' => $rOpts->{'brace-vertical-tightness'},
'[' => $rOpts->{'square-bracket-vertical-tightness'},
')' => $rOpts->{'paren-vertical-tightness'},
'}' => $rOpts->{'brace-vertical-tightness'},
']' => $rOpts->{'square-bracket-vertical-tightness'},
);
%closing_vertical_tightness = (
'(' => $rOpts->{'paren-vertical-tightness-closing'},
'{' => $rOpts->{'brace-vertical-tightness-closing'},
'[' => $rOpts->{'square-bracket-vertical-tightness-closing'},
')' => $rOpts->{'paren-vertical-tightness-closing'},
'}' => $rOpts->{'brace-vertical-tightness-closing'},
']' => $rOpts->{'square-bracket-vertical-tightness-closing'},
);
# assume flag for '>' same as ')' for closing qw quotes
%closing_token_indentation = (
')' => $rOpts->{'closing-paren-indentation'},
'}' => $rOpts->{'closing-brace-indentation'},
']' => $rOpts->{'closing-square-bracket-indentation'},
'>' => $rOpts->{'closing-paren-indentation'},
);
# flag indicating if any closing tokens are indented
$some_closing_token_indentation =
$rOpts->{'closing-paren-indentation'}
|| $rOpts->{'closing-brace-indentation'}
|| $rOpts->{'closing-square-bracket-indentation'}
|| $rOpts->{'indent-closing-brace'};
%opening_token_right = (
'(' => $rOpts->{'opening-paren-right'},
'{' => $rOpts->{'opening-hash-brace-right'},
'[' => $rOpts->{'opening-square-bracket-right'},
);
%stack_opening_token = (
'(' => $rOpts->{'stack-opening-paren'},
'{' => $rOpts->{'stack-opening-hash-brace'},
'[' => $rOpts->{'stack-opening-square-bracket'},
);
%stack_closing_token = (
')' => $rOpts->{'stack-closing-paren'},
'}' => $rOpts->{'stack-closing-hash-brace'},
']' => $rOpts->{'stack-closing-square-bracket'},
);
return;
}
sub bad_pattern {
# See if a pattern will compile. We have to use a string eval here,
# but it should be safe because the pattern has been constructed
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
return $@;
}
{
my %no_cuddle;
# Add keywords here which really should not be cuddled
BEGIN {
my @q = qw(if unless for foreach while);
@no_cuddle{@q} = (1) x scalar(@q);
}
sub prepare_cuddled_block_types {
# the cuddled-else style, if used, is controlled by a hash that
# we construct here
# Include keywords here which should not be cuddled
my $cuddled_string = "";
if ( $rOpts->{'cuddled-else'} ) {
# set the default
$cuddled_string = 'elsif else continue catch finally'
unless ( $rOpts->{'cuddled-block-list-exclusive'} );
# This is the old equivalent but more complex version
# $cuddled_string = 'if-elsif-else unless-elsif-else -continue ';
# Add users other blocks to be cuddled
my $cuddled_block_list = $rOpts->{'cuddled-block-list'};
if ($cuddled_block_list) {
$cuddled_string .= " " . $cuddled_block_list;
}
}
# If we have a cuddled string of the form
# 'try-catch-finally'
# we want to prepare a hash of the form
# $rcuddled_block_types = {
# 'try' => {
# 'catch' => 1,
# 'finally' => 1
# },
# };
# use -dcbl to dump this hash
# Multiple such strings are input as a space or comma separated list
# If we get two lists with the same leading type, such as
# -cbl = "-try-catch-finally -try-catch-otherwise"
# then they will get merged as follows:
# $rcuddled_block_types = {
# 'try' => {
# 'catch' => 1,
# 'finally' => 2,
# 'otherwise' => 1,
# },
# };
# This will allow either type of chain to be followed.
$cuddled_string =~ s/,/ /g; # allow space or comma separated lists
my @cuddled_strings = split /\s+/, $cuddled_string;
$rcuddled_block_types = {};
# process each dash-separated string...
my $string_count = 0;
foreach my $string (@cuddled_strings) {
next unless $string;
my @words = split /-+/, $string; # allow multiple dashes
# we could look for and report possible errors here...
next unless ( @words > 0 );
# allow either '-continue' or *-continue' for arbitrary starting type
my $start = '*';
# a single word without dashes is a secondary block type
if ( @words > 1 ) {
$start = shift @words;
}
# always make an entry for the leading word. If none follow, this
# will still prevent a wildcard from matching this word.
if ( !defined( $rcuddled_block_types->{$start} ) ) {
$rcuddled_block_types->{$start} = {};
}
# The count gives the original word order in case we ever want it.
$string_count++;
my $word_count = 0;
foreach my $word (@words) {
next unless $word;
if ( $no_cuddle{$word} ) {
Warn(
"## Ignoring keyword '$word' in -cbl; does not seem right\n"
);
next;
}
$word_count++;
$rcuddled_block_types->{$start}->{$word} =
1; #"$string_count.$word_count";
# git#9: Remove this word from the list of desired one-line
# blocks
$want_one_line_block{$word} = 0;
}
}
return;
}
}
sub dump_cuddled_block_list {
my ($fh) = @_;
# ORIGINAL METHOD: Here is the format of the cuddled block type hash
# which controls this routine
# my $rcuddled_block_types = {
# 'if' => {
# 'else' => 1,
# 'elsif' => 1
# },
# 'try' => {
# 'catch' => 1,
# 'finally' => 1
# },
# };
# SIMPLFIED METHOD: the simplified method uses a wildcard for
# the starting block type and puts all cuddled blocks together:
# my $rcuddled_block_types = {
# '*' => {
# 'else' => 1,
# 'elsif' => 1
# 'catch' => 1,
# 'finally' => 1
# },
# };
# Both methods work, but the simplified method has proven to be adequate and
# easier to manage.
my $cuddled_string = $rOpts->{'cuddled-block-list'};
$cuddled_string = '' unless $cuddled_string;
my $flags = "";
$flags .= "-ce" if ( $rOpts->{'cuddled-else'} );
$flags .= " -cbl='$cuddled_string'";
unless ( $rOpts->{'cuddled-else'} ) {
$flags .= "\nNote: You must specify -ce to generate a cuddled hash";
}
$fh->print(<<EOM);
------------------------------------------------------------------------
Hash of cuddled block types prepared for a run with these parameters:
$flags
------------------------------------------------------------------------
EOM
use Data::Dumper;
$fh->print( Dumper($rcuddled_block_types) );
$fh->print(<<EOM);
------------------------------------------------------------------------
EOM
return;
}
sub make_static_block_comment_pattern {
# create the pattern used to identify static block comments
$static_block_comment_pattern = '^\s*##';
# allow the user to change it
if ( $rOpts->{'static-block-comment-prefix'} ) {
my $prefix = $rOpts->{'static-block-comment-prefix'};
$prefix =~ s/^\s*//;
my $pattern = $prefix;
# user may give leading caret to force matching left comments only
if ( $prefix !~ /^\^#/ ) {
if ( $prefix !~ /^#/ ) {
Die(
"ERROR: the -sbcp prefix is '$prefix' but must begin with '#' or '^#'\n"
);
}
$pattern = '^\s*' . $prefix;
}
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the -sbc prefix '$prefix' causes the invalid regex '$pattern'\n"
);
}
$static_block_comment_pattern = $pattern;
}
return;
}
sub make_format_skipping_pattern {
my ( $opt_name, $default ) = @_;
my $param = $rOpts->{$opt_name};
unless ($param) { $param = $default }
$param =~ s/^\s*//;
if ( $param !~ /^#/ ) {
Die("ERROR: the $opt_name parameter '$param' must begin with '#'\n");
}
my $pattern = '^' . $param . '\s';
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the $opt_name parameter '$param' causes the invalid regex '$pattern'\n"
);
}
return $pattern;
}
sub make_closing_side_comment_list_pattern {
# turn any input list into a regex for recognizing selected block types
$closing_side_comment_list_pattern = '^\w+';
if ( defined( $rOpts->{'closing-side-comment-list'} )
&& $rOpts->{'closing-side-comment-list'} )
{
$closing_side_comment_list_pattern =
make_block_pattern( '-cscl', $rOpts->{'closing-side-comment-list'} );
}
return;
}
sub make_sub_matching_pattern {
# Patterns for standardizing matches to block types for regular subs and
# anonymous subs. Examples
# 'sub process' is a named sub
# 'sub ::m' is a named sub
# 'sub' is an anonymous sub
# 'sub:' is a label, not a sub
# 'substr' is a keyword
$SUB_PATTERN = '^sub\s+(::|\w)'; # match normal sub
$ASUB_PATTERN = '^sub$'; # match anonymous sub
$ANYSUB_PATTERN = '^sub\b'; # match either type of sub
if ( $rOpts->{'sub-alias-list'} ) {
# Note that any 'sub-alias-list' has been preprocessed to
# be a trimmed, space-separated list which includes 'sub'
# for example, it might be 'sub method fun'
my $sub_alias_list = $rOpts->{'sub-alias-list'};
$sub_alias_list =~ s/\s+/\|/g;
$SUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
$ASUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
$ANYSUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
}
return;
}
sub make_bli_pattern {
# default list of block types for which -bli would apply
my $bli_list_string = 'if else elsif unless while for foreach do : sub';
if ( defined( $rOpts->{'brace-left-and-indent-list'} )
&& $rOpts->{'brace-left-and-indent-list'} )
{
$bli_list_string = $rOpts->{'brace-left-and-indent-list'};
}
$bli_pattern = make_block_pattern( '-blil', $bli_list_string );
return;
}
sub make_keyword_group_list_pattern {
# turn any input list into a regex for recognizing selected block types.
# Here are the defaults:
$keyword_group_list_pattern = '^(our|local|my|use|require|)$';
$keyword_group_list_comment_pattern = '';
if ( defined( $rOpts->{'keyword-group-blanks-list'} )
&& $rOpts->{'keyword-group-blanks-list'} )
{
my @words = split /\s+/, $rOpts->{'keyword-group-blanks-list'};
my @keyword_list;
my @comment_list;
foreach my $word (@words) {
if ( $word =~ /^(BC|SBC)$/ ) {
push @comment_list, $word;
if ( $word eq 'SBC' ) { push @comment_list, 'SBCX' }
}
else {
push @keyword_list, $word;
}
}
$keyword_group_list_pattern =
make_block_pattern( '-kgbl', $rOpts->{'keyword-group-blanks-list'} );
$keyword_group_list_comment_pattern =
make_block_pattern( '-kgbl', join( ' ', @comment_list ) );
}
return;
}
sub make_block_brace_vertical_tightness_pattern {
# turn any input list into a regex for recognizing selected block types
$block_brace_vertical_tightness_pattern =
'^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
if ( defined( $rOpts->{'block-brace-vertical-tightness-list'} )
&& $rOpts->{'block-brace-vertical-tightness-list'} )
{
$block_brace_vertical_tightness_pattern =
make_block_pattern( '-bbvtl',
$rOpts->{'block-brace-vertical-tightness-list'} );
}
return;
}
sub make_blank_line_pattern {
$blank_lines_before_closing_block_pattern = $SUB_PATTERN;
my $key = 'blank-lines-before-closing-block-list';
if ( defined( $rOpts->{$key} ) && $rOpts->{$key} ) {
$blank_lines_before_closing_block_pattern =
make_block_pattern( '-blbcl', $rOpts->{$key} );
}
$blank_lines_after_opening_block_pattern = $SUB_PATTERN;
$key = 'blank-lines-after-opening-block-list';
if ( defined( $rOpts->{$key} ) && $rOpts->{$key} ) {
$blank_lines_after_opening_block_pattern =
make_block_pattern( '-blaol', $rOpts->{$key} );
}
return;
}
sub make_block_pattern {
# given a string of block-type keywords, return a regex to match them
# The only tricky part is that labels are indicated with a single ':'
# and the 'sub' token text may have additional text after it (name of
# sub).
#
# Example:
#
# input string: "if else elsif unless while for foreach do : sub";
# pattern: '^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
# Minor Update:
#
# To distinguish between anonymous subs and named subs, use 'sub' to
# indicate a named sub, and 'asub' to indicate an anonymous sub
my ( $abbrev, $string ) = @_;
my @list = split_words($string);
my @words = ();
my %seen;
for my $i (@list) {
if ( $i eq '*' ) { my $pattern = '^.*'; return $pattern }
next if $seen{$i};
$seen{$i} = 1;
if ( $i eq 'sub' ) {
}
elsif ( $i eq 'asub' ) {
}
elsif ( $i eq ';' ) {
push @words, ';';
}
elsif ( $i eq '{' ) {
push @words, '\{';
}
elsif ( $i eq ':' ) {
push @words, '\w+:';
}
elsif ( $i =~ /^\w/ ) {
push @words, $i;
}
else {
Warn("unrecognized block type $i after $abbrev, ignoring\n");
}
}
my $pattern = '(' . join( '|', @words ) . ')$';
my $sub_patterns = "";
if ( $seen{'sub'} ) {
$sub_patterns .= '|' . $SUB_PATTERN;
}
if ( $seen{'asub'} ) {
$sub_patterns .= '|' . $ASUB_PATTERN;
}
if ($sub_patterns) {
$pattern = '(' . $pattern . $sub_patterns . ')';
}
$pattern = '^' . $pattern;
return $pattern;
}
sub make_static_side_comment_pattern {
# create the pattern used to identify static side comments
$static_side_comment_pattern = '^##';
# allow the user to change it
if ( $rOpts->{'static-side-comment-prefix'} ) {
my $prefix = $rOpts->{'static-side-comment-prefix'};
$prefix =~ s/^\s*//;
my $pattern = '^' . $prefix;
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the -sscp prefix '$prefix' causes the invalid regex '$pattern'\n"
);
}
$static_side_comment_pattern = $pattern;
}
return;
}
sub make_closing_side_comment_prefix {
# Be sure we have a valid closing side comment prefix
my $csc_prefix = $rOpts->{'closing-side-comment-prefix'};
my $csc_prefix_pattern;
if ( !defined($csc_prefix) ) {
$csc_prefix = '## end';
$csc_prefix_pattern = '^##\s+end';
}
else {
my $test_csc_prefix = $csc_prefix;
if ( $test_csc_prefix !~ /^#/ ) {
$test_csc_prefix = '#' . $test_csc_prefix;
}
# make a regex to recognize the prefix
my $test_csc_prefix_pattern = $test_csc_prefix;
# escape any special characters
$test_csc_prefix_pattern =~ s/([^#\s\w])/\\$1/g;
$test_csc_prefix_pattern = '^' . $test_csc_prefix_pattern;
# allow exact number of intermediate spaces to vary
$test_csc_prefix_pattern =~ s/\s+/\\s\+/g;
# make sure we have a good pattern
# if we fail this we probably have an error in escaping
# characters.
if ( bad_pattern($test_csc_prefix_pattern) ) {
# shouldn't happen..must have screwed up escaping, above
report_definite_bug();
Warn(
"Program Error: the -cscp prefix '$csc_prefix' caused the invalid regex '$csc_prefix_pattern'\n"
);
# just warn and keep going with defaults
Warn("Please consider using a simpler -cscp prefix\n");
Warn("Using default -cscp instead; please check output\n");
}
else {
$csc_prefix = $test_csc_prefix;
$csc_prefix_pattern = $test_csc_prefix_pattern;
}
}
$rOpts->{'closing-side-comment-prefix'} = $csc_prefix;
$closing_side_comment_prefix_pattern = $csc_prefix_pattern;
return;
}
sub dump_want_left_space {
my $fh = shift;
local $" = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the left of a token type;
They may be altered with the -wls parameter.
For a list of token types, use perltidy --dump-token-types (-dtt)
1 means the token wants a space to its left
-1 means the token does not want a space to its left
------------------------------------------------------------------------
EOM
foreach my $key ( sort keys %want_left_space ) {
$fh->print("$key\t$want_left_space{$key}\n");
}
return;
}
sub dump_want_right_space {
my $fh = shift;
local $" = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the right of a token type;
They may be altered with the -wrs parameter.
For a list of token types, use perltidy --dump-token-types (-dtt)
1 means the token wants a space to its right
-1 means the token does not want a space to its right
------------------------------------------------------------------------
EOM
foreach my $key ( sort keys %want_right_space ) {
$fh->print("$key\t$want_right_space{$key}\n");
}
return;
}
{ # begin is_essential_whitespace
my %is_sort_grep_map;
my %is_for_foreach;
my %is_digraph;
my %is_trigraph;
BEGIN {
my @q;
@q = qw(sort grep map);
@is_sort_grep_map{@q} = (1) x scalar(@q);
@q = qw(for foreach);
@is_for_foreach{@q} = (1) x scalar(@q);
@q = qw(
.. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
<= >= == =~ !~ != ++ -- /= x= ~~ ~. |. &. ^.
);
@is_digraph{@q} = (1) x scalar(@q);
@q = qw( ... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~);
@is_trigraph{@q} = (1) x scalar(@q);
}
sub is_essential_whitespace {
# Essential whitespace means whitespace which cannot be safely deleted
# without risking the introduction of a syntax error.
# We are given three tokens and their types:
# ($tokenl, $typel) is the token to the left of the space in question
# ($tokenr, $typer) is the token to the right of the space in question
# ($tokenll, $typell) is previous nonblank token to the left of $tokenl
#
# This is a slow routine but is not needed too often except when -mangle
# is used.
#
# Note: This routine should almost never need to be changed. It is
# for avoiding syntax problems rather than for formatting.
my ( $tokenll, $typell, $tokenl, $typel, $tokenr, $typer ) = @_;
my $tokenr_is_bareword = $tokenr =~ /^\w/ && $tokenr !~ /^\d/;
my $tokenr_is_open_paren = $tokenr eq '(';
my $token_joined = $tokenl . $tokenr;
my $tokenl_is_dash = $tokenl eq '-';
my $result =
# never combine two bare words or numbers
# examples: and ::ok(1)
# return ::spw(...)
# for bla::bla:: abc
# example is "%overload:: and" in files Dumpvalue.pm or colonbug.pl
# $input eq"quit" to make $inputeq"quit"
# my $size=-s::SINK if $file; <==OK but we won't do it
# don't join something like: for bla::bla:: abc
# example is "%overload:: and" in files Dumpvalue.pm or colonbug.pl
( ( $tokenl =~ /([\'\w]|\:\:)$/ && $typel ne 'CORE::' )
&& ( $tokenr =~ /^([\'\w]|\:\:)/ ) )
# do not combine a number with a concatenation dot
# example: pom.caputo:
# $vt100_compatible ? "\e[0;0H" : ('-' x 78 . "\n");
|| $typel eq 'n' && $tokenr eq '.'
|| $typer eq 'n'
&& $tokenl eq '.'
# cases of a space before a bareword...
|| (
$tokenr_is_bareword && (
# do not join a minus with a bare word, because you might form
# a file test operator. Example from Complex.pm:
# if (CORE::abs($z - i) < $eps);
# "z-i" would be taken as a file test.
$tokenl_is_dash && length($tokenr) == 1
# and something like this could become ambiguous without space
# after the '-':
# use constant III=>1;
# $a = $b - III;
# and even this:
# $a = - III;
|| $tokenl_is_dash && $typer =~ /^[wC]$/
# keep a space between a quote and a bareword to prevent the
# bareword from becoming a quote modifier.
|| $typel eq 'Q'
# keep a space between a token ending in '$' and any word;
# this caused trouble: "die @$ if $@"
|| $typel eq 'i' && $tokenl =~ /\$$/
# do not remove space between an '&' and a bare word because
# it may turn into a function evaluation, like here
# between '&' and 'O_ACCMODE', producing a syntax error [File.pm]
# $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
|| $typel eq '&'
# don't combine $$ or $# with any alphanumeric
# (testfile mangle.t with --mangle)
|| $tokenl =~ /^\$[\$\#]$/
)
) ## end $tokenr_is_bareword
# OLD, not used
# '= -' should not become =- or you will get a warning
# about reversed -=
# || ($tokenr eq '-')
# do not join a bare word with a minus, like between 'Send' and
# '-recipients' here <<snippets/space3.in>>
# my $msg = new Fax::Send
# -recipients => $to,
# -data => $data;
# This is the safest thing to do. If we had the token to the right of
# the minus we could do a better check.
|| $tokenr eq '-' && $typel eq 'w'
# perl is very fussy about spaces before <<
|| $tokenr =~ /^\<\</
# avoid combining tokens to create new meanings. Example:
# $a+ +$b must not become $a++$b
|| ( $is_digraph{$token_joined} )
|| $is_trigraph{$token_joined}
# another example: do not combine these two &'s:
# allow_options & &OPT_EXECCGI
|| $is_digraph{ $tokenl . substr( $tokenr, 0, 1 ) }
# retain any space after possible filehandle
# (testfiles prnterr1.t with --extrude and mangle.t with --mangle)
|| $typel eq 'Z'
# Perl is sensitive to whitespace after the + here:
# $b = xvals $a + 0.1 * yvals $a;
|| $typell eq 'Z' && $typel =~ /^[\/\?\+\-\*]$/
|| (
$tokenr_is_open_paren && (
# keep paren separate in 'use Foo::Bar ()'
( $typel eq 'w' && $typell eq 'k' && $tokenll eq 'use' )
# keep any space between filehandle and paren:
# file mangle.t with --mangle:
|| $typel eq 'Y'
# must have space between grep and left paren; "grep(" will fail
|| $is_sort_grep_map{$tokenl}
# don't stick numbers next to left parens, as in:
#use Mail::Internet 1.28 (); (see Entity.pm, Head.pm, Test.pm)
|| $typel eq 'n'
)
) ## end $tokenr_is_open_paren
# retain any space after here doc operator ( hereerr.t)
|| $typel eq 'h'
# be careful with a space around ++ and --, to avoid ambiguity as to
# which token it applies
|| $typer =~ /^(pp|mm)$/ && $tokenl !~ /^[\;\{\(\[]/
|| $typel =~ /^(\+\+|\-\-)$/
&& $tokenr !~ /^[\;\}\)\]]/
# need space after foreach my; for example, this will fail in
# older versions of Perl:
# foreach my$ft(@filetypes)...
|| (
$tokenl eq 'my'
# /^(for|foreach)$/
&& $is_for_foreach{$tokenll}
&& $tokenr =~ /^\$/
)
# We must be sure that a space between a ? and a quoted string
# remains if the space before the ? remains. [Loca.pm, lockarea]
# ie,
# $b=join $comma ? ',' : ':', @_; # ok
# $b=join $comma?',' : ':', @_; # ok!
# $b=join $comma ?',' : ':', @_; # error!
# Not really required:
## || ( ( $typel eq '?' ) && ( $typer eq 'Q' ) )
# space stacked labels (TODO: check if really necessary)
|| $typel eq 'J' && $typer eq 'J'
; # the value of this long logic sequence is the result we want
##if ($typel eq 'j') {print STDERR "typel=$typel typer=$typer result='$result'\n"}
return $result;
}
}
{
my %secret_operators;
my %is_leading_secret_token;
BEGIN {
# token lists for perl secret operators as compiled by Philippe Bruhat
# at: https://metacpan.org/module/perlsecret
%secret_operators = (
'Goatse' => [qw#= ( ) =#], #=( )=
'Venus1' => [qw#0 +#], # 0+
'Venus2' => [qw#+ 0#], # +0
'Enterprise' => [qw#) x ! !#], # ()x!!
'Kite1' => [qw#~ ~ <>#], # ~~<>
'Kite2' => [qw#~~ <>#], # ~~<>
'Winking Fat Comma' => [ ( ',', '=>' ) ], # ,=>
'Bang bang ' => [qw#! !#], # !!
);
# The following operators and constants are not included because they
# are normally kept tight by perltidy:
# ~~ <~>
#
# Make a lookup table indexed by the first token of each operator:
# first token => [list, list, ...]
foreach my $value ( values(%secret_operators) ) {
my $tok = $value->[0];
push @{ $is_leading_secret_token{$tok} }, $value;
}
}
sub new_secret_operator_whitespace {
my ( $rlong_array, $rwhitespace_flags ) = @_;
# Loop over all tokens in this line
my ( $token, $type );
my $jmax = @{$rlong_array} - 1;
foreach my $j ( 0 .. $jmax ) {
$token = $rlong_array->[$j]->[_TOKEN_];
$type = $rlong_array->[$j]->[_TYPE_];
# Skip unless this token might start a secret operator
next if ( $type eq 'b' );
next unless ( $is_leading_secret_token{$token} );
# Loop over all secret operators with this leading token
foreach my $rpattern ( @{ $is_leading_secret_token{$token} } ) {
my $jend = $j - 1;
foreach my $tok ( @{$rpattern} ) {
$jend++;
$jend++
if ( $jend <= $jmax
&& $rlong_array->[$jend]->[_TYPE_] eq 'b' );
if ( $jend > $jmax
|| $tok ne $rlong_array->[$jend]->[_TOKEN_] )
{
$jend = undef;
last;
}
}
if ($jend) {
# set flags to prevent spaces within this operator
foreach my $jj ( $j + 1 .. $jend ) {
$rwhitespace_flags->[$jj] = WS_NO;
}
$j = $jend;
last;
}
} ## End Loop over all operators
} ## End loop over all tokens
return;
} # End sub
}
sub tight_paren_follows {
my ( $self, $K_to_go_0, $K_ic ) = @_;
# Input parameters:
# $K_to_go_0 = first token index K of this output batch (=K_to_go[0])
# $K_ic = index of the closing do brace (=K_to_go[$max_index_to_go])
# Return parameter:
# false if we want a break after the closing do brace
# true if we do not want a break after the closing do brace
# We are at the closing brace of a 'do' block. See if this brace is
# followed by a closing paren, and if so, set a flag which indicates
# that we do not want a line break between the '}' and ')'.
# xxxxx ( ...... do { ... } ) {
# ^-------looking at this brace, K_ic
# Subscript notation:
# _i = inner container (braces in this case)
# _o = outer container (parens in this case)
# _io = inner opening = '{'
# _ic = inner closing = '}'
# _oo = outer opening = '('
# _oc = outer closing = ')'
# |--K_oo |--K_oc = outer container
# xxxxx ( ...... do { ...... } ) {
# |--K_io |--K_ic = inner container
# In general, the safe thing to do is return a 'false' value
# if the statement appears to be complex. This will have
# the downstream side-effect of opening up outer containers
# to help make complex code readable. But for simpler
# do blocks it can be preferable to keep the code compact
# by returning a 'true' value.
# uses Global Symbols: $rOpts, $ANYSUB_PATTERN
return unless defined($K_ic);
my $rLL = $self->{rLL};
# we should only be called at a closing block
my $seqno_i = $rLL->[$K_ic]->[_TYPE_SEQUENCE_];
return unless ($seqno_i); # shouldn't happen;
# This only applies if the next nonblank is a ')'
my $K_oc = $self->K_next_nonblank($K_ic);
return unless defined($K_oc);
my $token_next = $rLL->[$K_oc]->[_TOKEN_];
return unless ( $token_next eq ')' );
my $seqno_o = $rLL->[$K_oc]->[_TYPE_SEQUENCE_];
my $K_io = $self->{K_opening_container}->{$seqno_i};
my $K_oo = $self->{K_opening_container}->{$seqno_o};
# RULE 1: Do not break before a closing signature paren
# (regardless of complexity). This is a fix for issue git#22.
# Looking for something like:
# sub xxx ( ... do { ... } ) {
# ^----- next block_type
my $K_test = $self->K_next_nonblank($K_oc);
if ( defined($K_test) ) {
my $block_type = $rLL->[$K_test]->[_BLOCK_TYPE_];
if ( $block_type
&& $rLL->[$K_test]->[_TYPE_] eq '{'
&& $block_type =~ /$ANYSUB_PATTERN/ )
{
return 1;
}
}
# RULE 2: Break if the contents within braces appears to be 'complex'. We
# base this decision on the number of tokens between braces.
# xxxxx ( ... do { ... } ) {
# ^^^^^^
# Although very simple, it has the advantages of (1) being insensitive to
# changes in lengths of identifier names, (2) easy to understand, implement
# and test. A test case for this is 't/snippets/long_line.in'.
# Example: $K_ic - $K_oo = 9 [Pass Rule 2]
# if ( do { $2 !~ /&/ } ) { ... }
# Example: $K_ic - $K_oo = 10 [Pass Rule 2]
# for ( split /\s*={70,}\s*/, do { local $/; <DATA> }) { ... }
# Example: $K_ic - $K_oo = 20 [Fail Rule 2]
# test_zero_args( "do-returned list slice", do { ( 10, 11 )[ 2, 3 ]; });
return if ( $K_ic - $K_io > 16 );
# RULE 3: break if the code between the opening '(' and the '{' is 'complex'
# As with the previous rule, we decide based on the token count
# xxxxx ( ... do { ... } ) {
# ^^^^^^^^
# Example: $K_ic - $K_oo = 9 [Pass Rule 2]
# $K_io - $K_oo = 4 [Pass Rule 3]
# if ( do { $2 !~ /&/ } ) { ... }
# Example: $K_ic - $K_oo = 10 [Pass rule 2]
# $K_io - $K_oo = 9 [Pass rule 3]
# for ( split /\s*={70,}\s*/, do { local $/; <DATA> }) { ... }
return if ( $K_io - $K_oo > 9 );
# RULE 4: Break if we have already broken this batch of output tokens
return if ( $K_oo < $K_to_go_0 );
# RULE 5: Break if input is not on one line
# For example, we will set the flag for the following expression
# written in one line:
# This has: $K_ic - $K_oo = 10 [Pass rule 2]
# $K_io - $K_oo = 8 [Pass rule 3]
# $self->debug( 'Error: ' . do { local $/; <$err> } );
# but we break after the brace if it is on multiple lines on input, since
# the user may prefer it on multiple lines:
# [Fail rule 5]
# $self->debug(
# 'Error: ' . do { local $/; <$err> }
# );
if ( !$rOpts->{'ignore-old-breakpoints'} ) {
my $iline_oo = $rLL->[$K_oo]->[_LINE_INDEX_];
my $iline_oc = $rLL->[$K_oc]->[_LINE_INDEX_];
return if ( $iline_oo != $iline_oc );
}
# OK to keep the paren tight
return 1;
}
sub copy_token_as_type {
my ( $rold_token, $type, $token ) = @_;
if ( $type eq 'b' ) {
$token = " " unless defined($token);
}
elsif ( $type eq 'q' ) {
$token = '' unless defined($token);
}
elsif ( $type eq '->' ) {
$token = '->' unless defined($token);
}
elsif ( $type eq ';' ) {
$token = ';' unless defined($token);
}
else {
Fault(
"Programming error: copy_token_as has type $type but should be 'b' or 'q'"
);
}
my $rnew_token = [ map { $_ } @{$rold_token} ];
$rnew_token->[_TYPE_] = $type;
$rnew_token->[_TOKEN_] = $token;
$rnew_token->[_BLOCK_TYPE_] = '';
$rnew_token->[_CONTAINER_TYPE_] = '';
$rnew_token->[_CONTAINER_ENVIRONMENT_] = '';
$rnew_token->[_TYPE_SEQUENCE_] = '';
return $rnew_token;
}
{ # begin process_line_of_CODE
# uses Global Symbols:
# "$ending_in_quote"
# "$file_writer_object"
# "$input_line_number"
# "$is_static_block_comment"
# "$last_line_leading_type"
# "$last_output_short_opening_token"
# "$saw_VERSION_in_this_file"
# "$starting_in_quote"
# "$rOpts"
# "$ANYSUB_PATTERN"
# "$ASUB_PATTERN"
# "$closing_side_comment_list_pattern"
# "$closing_side_comment_prefix_pattern"
# "%is_anon_sub_1_brace_follower"
# "%is_anon_sub_brace_follower"
# "%is_block_without_semicolon"
# "%is_do_follower"
# "%is_else_brace_follower"
# "%is_if_brace_follower"
# "%is_other_brace_follower"
# "%is_sort_map_grep_eval"
# "$max_index_to_go"
# "@K_to_go"
# "@block_type_to_go"
# "@bond_strength_to_go"
# "@ci_levels_to_go"
# "@container_environment_to_go"
# "@forced_breakpoint_to_go"
# "@inext_to_go"
# "@iprev_to_go"
# "@levels_to_go"
# "@mate_index_to_go"
# "@nesting_depth_to_go"
# "@nobreak_to_go"
# "@old_breakpoint_to_go"
# "@summed_lengths_to_go"
# "@token_lengths_to_go"
# "@tokens_to_go"
# "@type_sequence_to_go"
# "@types_to_go"
# flags needed by the store routine
my $line_of_tokens;
my $no_internal_newlines;
my $side_comment_follows;
# range of K of tokens for the current line
my ( $K_first, $K_last );
# past stored nonblank tokens
my (
$last_last_nonblank_token, $last_last_nonblank_type,
$last_nonblank_token, $last_nonblank_type,
$last_nonblank_block_type, $K_last_nonblank_code,
$K_last_last_nonblank_code, $looking_for_else,
);
sub initialize_process_line_of_CODE {
$last_nonblank_token = ';';
$last_nonblank_type = ';';
$last_last_nonblank_token = ';';
$last_last_nonblank_type = ';';
$last_nonblank_block_type = "";
$K_last_nonblank_code = undef;
$K_last_last_nonblank_code = undef;
$looking_for_else = 0;
return;
}
# batch variables
my ( $rbrace_follower, $index_start_one_line_block,
$semicolons_before_block_self_destruct,
$comma_count_in_batch );
# called at the start of each new batch
sub initialize_batch_variables {
$rbrace_follower = undef;
$comma_count_in_batch = 0;
destroy_one_line_block();
return;
}
sub create_one_line_block {
( $index_start_one_line_block, $semicolons_before_block_self_destruct )
= @_;
return;
}
sub destroy_one_line_block {
$index_start_one_line_block = UNDEFINED_INDEX;
$semicolons_before_block_self_destruct = 0;
return;
}
# Routine to place the current token into the output stream.
# Called once per output token.
sub store_token_to_go {
my ( $self, $Ktoken_vars, $rtoken_vars ) = @_;
my $rLL = $self->{rLL};
my $flag = $side_comment_follows ? 1 : $no_internal_newlines;
# the array of tokens can be given if they are different from the
# input arrays.
if ( !defined($rtoken_vars) ) {
$rtoken_vars = $rLL->[$Ktoken_vars];
}
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
my $container_type = $rtoken_vars->[_CONTAINER_TYPE_];
my $container_environment = $rtoken_vars->[_CONTAINER_ENVIRONMENT_];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
my $level = $rtoken_vars->[_LEVEL_];
my $slevel = $rtoken_vars->[_SLEVEL_];
my $ci_level = $rtoken_vars->[_CI_LEVEL_];
# Clip levels to zero if there are level errors in the file.
# We had to wait until now for reasons explained in sub 'write_line'.
if ( $level < 0 ) { $level = 0 }
# Programming check: The K indexes in the batch must be a continuous
# sequence of the global token array. If this relationship fails we
# are in danger of losing data. An error here implies an error in
# a recent programming change.
if ( defined($max_index_to_go) && $max_index_to_go >= 0 ) {
my $Klast = $K_to_go[$max_index_to_go];
if ( $Ktoken_vars != $Klast + 1 ) {
Fault("Unexpected break in K values: $Ktoken_vars != $Klast+1");
}
}
++$max_index_to_go;
$K_to_go[$max_index_to_go] = $Ktoken_vars;
$tokens_to_go[$max_index_to_go] = $token;
$types_to_go[$max_index_to_go] = $type;
$nobreak_to_go[$max_index_to_go] = $flag;
$old_breakpoint_to_go[$max_index_to_go] = 0;
$forced_breakpoint_to_go[$max_index_to_go] = 0;
$block_type_to_go[$max_index_to_go] = $block_type;
$type_sequence_to_go[$max_index_to_go] = $type_sequence;
$container_environment_to_go[$max_index_to_go] = $container_environment;
$ci_levels_to_go[$max_index_to_go] = $ci_level;
$mate_index_to_go[$max_index_to_go] = -1;
$bond_strength_to_go[$max_index_to_go] = 0;
$levels_to_go[$max_index_to_go] = $level;
$nesting_depth_to_go[$max_index_to_go] = $slevel;
# link the non-blank tokens
my $iprev = $max_index_to_go - 1;
$iprev-- if ( $iprev >= 0 && $types_to_go[$iprev] eq 'b' );
$iprev_to_go[$max_index_to_go] = $iprev;
$inext_to_go[$iprev] = $max_index_to_go
if ( $iprev >= 0 && $type ne 'b' );
$inext_to_go[$max_index_to_go] = $max_index_to_go + 1;
my $length = $rLL->[$Ktoken_vars]->[_TOKEN_LENGTH_];
# Safety check that length is defined. Should not be needed now.
# Former patch for indent-only, in which the entire set of tokens is
# turned into type 'q'. Lengths may have not been defined because sub
# 'respace_tokens' is bypassed. We do not need lengths in this case,
# but we will use the character count to have a defined value. In the
# future, it would be nicer to have 'respace_tokens' convert the lines
# to quotes and get correct lengths.
if ( !defined($length) ) { $length = length($token) }
$token_lengths_to_go[$max_index_to_go] = $length;
# We keep a running sum of token lengths from the start of this batch:
# summed_lengths_to_go[$i] = total length to just before token $i
# summed_lengths_to_go[$i+1] = total length to just after token $i
$summed_lengths_to_go[ $max_index_to_go + 1 ] =
$summed_lengths_to_go[$max_index_to_go] +
$token_lengths_to_go[$max_index_to_go];
my $in_continued_quote =
( $Ktoken_vars == $K_first ) && $line_of_tokens->{_starting_in_quote};
if ( $max_index_to_go == 0 ) {
$starting_in_quote = $in_continued_quote;
}
# Define the indentation that this token would have if it started
# a new line. We start by using the default formula.
# First Adjust levels if necessary to recycle whitespace:
my $level_wc = $level;
my $radjusted_levels = $self->{radjusted_levels};
if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
$level_wc = $radjusted_levels->[$Ktoken_vars];
}
my $space_count =
$ci_level * $rOpts_continuation_indentation +
$level_wc * $rOpts_indent_columns;
my $ci_spaces =
( $ci_level == 0 ) ? 0 : $rOpts_continuation_indentation;
if ($in_continued_quote) {
$space_count = 0;
$ci_spaces = 0;
}
$leading_spaces_to_go[$max_index_to_go] = $space_count;
$reduced_spaces_to_go[$max_index_to_go] = $space_count - $ci_spaces;
# Correct these values if -lp is used
if ($rOpts_line_up_parentheses) {
$self->set_leading_whitespace( $Ktoken_vars, $K_last_nonblank_code,
$K_last_last_nonblank_code, $level, $ci_level,
$in_continued_quote );
}
if ( $type eq ',' ) {
$comma_count_in_batch++;
}
FORMATTER_DEBUG_FLAG_STORE && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"STORE: from $a $c: storing token $token type $type lev=$level slev=$slevel at $max_index_to_go\n";
};
return;
}
sub package_and_process_batch_of_CODE {
# finish any batch packaging and call the process routine
# this is the only call to process_batch_of_CODE()
my ($self) = @_;
$self->process_batch_of_CODE($comma_count_in_batch);
return;
}
sub end_batch {
# end the current batch, except for a few special cases
my ($self) = @_;
# Exception 1: Do not end line in a weld
return if ( weld_len_right_to_go($max_index_to_go) );
# Exception 2: just set a tentative breakpoint if we might be in a
# one-line block
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
set_forced_breakpoint($max_index_to_go);
return;
}
$self->package_and_process_batch_of_CODE();
return;
}
# flush is called to output any tokens in the pipeline, so that
# an alternate source of lines can be written in the correct order
sub flush {
my ( $self, $CODE_type ) = @_;
# end the current batch with 1 exception
destroy_one_line_block();
# Exception: if we are flushing within the code stream only to insert
# blank line(s), then we can keep the batch intact at a weld. This
# improves formatting of -ce. See test 'ce1.ce'
if ( $CODE_type && $CODE_type eq 'BL' ) { $self->end_batch() }
# otherwise, we have to shut things down completely.
else { $self->package_and_process_batch_of_CODE() }
Perl::Tidy::VerticalAligner::flush();
return;
}
sub process_line_of_CODE {
my ( $self, $my_line_of_tokens ) = @_;
# This routine is called once per input line to process all of the
# tokens on that line. This is the first stage of beautification.
# Full-line comments and blank lines may be output immediately.
# The tokens are copied one-by-one from the global token array $rLL to
# a set of '_to_go' arrays which collect batches of tokens for a
# further processing via calls to 'sub store_token_to_go', until a well
# defined 'structural' break point* or 'forced' breakpoint* is reached.
# Then, the batch of collected '_to_go' tokens is passed along to 'sub
# process_batch_of_CODE' for further processing.
# * 'structural' break points are basically line breaks corresponding
# to code blocks. An example is a chain of if-elsif-else statements,
# which should typically be broken at the opening and closing braces.
# * 'forced' break points are breaks required by side comments or by
# special user controls.
# So this routine is just making an initial set of required line
# breaks, basically regardless of the maximum requested line length.
# Later stages of formating make additional line breaks appropriate for
# lists and logical structures, and to keep line lengths below the
# requested maximum line length.
$line_of_tokens = $my_line_of_tokens;
$input_line_number = $line_of_tokens->{_line_number};
my $input_line = $line_of_tokens->{_line_text};
my $CODE_type = $line_of_tokens->{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
( $K_first, $K_last ) = @{$rK_range};
my $rLL = $self->{rLL};
my $rbreak_container = $self->{rbreak_container};
my $rshort_nested = $self->{rshort_nested};
my $sink_object = $self->{sink_object};
my $fh_tee = $self->{fh_tee};
my $rOpts_add_newlines = $rOpts->{'add-newlines'};
my $rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
my $rOpts_ignore_old_breakpoints = $rOpts->{'ignore-old-breakpoints'};
my $rOpts_keep_interior_semicolons =
$rOpts->{'keep-interior-semicolons'};
if ( !defined($K_first) ) {
# Empty line: This can happen if tokens are deleted, for example
# with the -mangle parameter
return;
}
$no_internal_newlines = 1 - $rOpts_add_newlines;
$side_comment_follows = 0;
my $is_comment =
( $K_first == $K_last && $rLL->[$K_first]->[_TYPE_] eq '#' );
my $is_static_block_comment_without_leading_space =
$CODE_type eq 'SBCX';
$is_static_block_comment =
$CODE_type eq 'SBC' || $is_static_block_comment_without_leading_space;
my $is_hanging_side_comment = $CODE_type eq 'HSC';
my $is_VERSION_statement = $CODE_type eq 'VER';
if ($is_VERSION_statement) {
$saw_VERSION_in_this_file = 1;
$no_internal_newlines = 1;
}
# Add interline blank if any
my $last_old_nonblank_type = "b";
my $first_new_nonblank_token = "";
if ( $max_index_to_go >= 0 ) {
$last_old_nonblank_type = $types_to_go[$max_index_to_go];
$first_new_nonblank_token = $rLL->[$K_first]->[_TOKEN_];
if ( !$is_comment
&& $types_to_go[$max_index_to_go] ne 'b'
&& $K_first > 0
&& $rLL->[ $K_first - 1 ]->[_TYPE_] eq 'b' )
{
$K_first -= 1;
}
}
my $rtok_first = $rLL->[$K_first];
my $in_quote = $line_of_tokens->{_ending_in_quote};
$ending_in_quote = $in_quote;
my $guessed_indentation_level =
$line_of_tokens->{_guessed_indentation_level};
######################################
# Handle a block (full-line) comment..
######################################
if ($is_comment) {
if ( $rOpts->{'tee-block-comments'} ) {
$fh_tee->print($input_line) if ($fh_tee);
}
if ( $rOpts->{'delete-block-comments'} ) {
$self->flush();
return;
}
destroy_one_line_block();
$self->end_batch();
# output a blank line before block comments
if (
# unless we follow a blank or comment line
$last_line_leading_type !~ /^[#b]$/
# only if allowed
&& $rOpts->{'blanks-before-comments'}
# if this is NOT an empty comment line
&& $rtok_first->[_TOKEN_] ne '#'
# not after a short line ending in an opening token
# because we already have space above this comment.
# Note that the first comment in this if block, after
# the 'if (', does not get a blank line because of this.
&& !$last_output_short_opening_token
# never before static block comments
&& !$is_static_block_comment
)
{
$self->flush(); # switching to new output stream
$file_writer_object->write_blank_code_line();
$last_line_leading_type = 'b';
}
if (
$rOpts->{'indent-block-comments'}
&& ( !$rOpts->{'indent-spaced-block-comments'}
|| $input_line =~ /^\s+/ )
&& !$is_static_block_comment_without_leading_space
)
{
my $Ktoken_vars = $K_first;
$self->store_token_to_go($Ktoken_vars);
$self->end_batch();
}
else {
$self->flush(); # switching to new output stream
$file_writer_object->write_code_line(
$rtok_first->[_TOKEN_] . "\n" );
$last_line_leading_type = '#';
}
return;
}
# compare input/output indentation except for continuation lines
# (because they have an unknown amount of initial blank space)
# and lines which are quotes (because they may have been outdented)
my $structural_indentation_level = $rLL->[$K_first]->[_LEVEL_];
compare_indentation_levels( $guessed_indentation_level,
$structural_indentation_level )
unless ( $is_hanging_side_comment
|| $rtok_first->[_CI_LEVEL_] > 0
|| $guessed_indentation_level == 0
&& $rtok_first->[_TYPE_] eq 'Q' );
##########################
# Handle indentation-only
##########################
# NOTE: In previous versions we sent all qw lines out immediately here.
# No longer doing this: also write a line which is entirely a 'qw' list
# to allow stacking of opening and closing tokens. Note that interior
# qw lines will still go out at the end of this routine.
if ( $CODE_type eq 'IO' ) {
$self->flush();
my $line = $input_line;
# delete side comments if requested with -io
if ( $rLL->[$K_last]->[_TYPE_] eq '#' ) {
if ( $rOpts->{'delete-side-comments'} ) {
$line = "";
foreach my $KK ( $K_first .. $K_last - 1 ) {
$line .= $rLL->[$KK]->[_TOKEN_];
}
}
if ( $rOpts->{'tee-side-comments'} ) {
$fh_tee->print($input_line) if ($fh_tee);
}
}
# Fix for rt #125506 Unexpected string formating
# in which leading space of a terminal quote was removed
$line =~ s/\s+$//;
$line =~ s/^\s+// unless ( $line_of_tokens->{_starting_in_quote} );
my $Ktoken_vars = $K_first;
# We work with a copy of the token variables and change the
# first token to be the entire line as a quote variable
my $rtoken_vars = $rLL->[$Ktoken_vars];
$rtoken_vars = copy_token_as_type( $rtoken_vars, 'q', $line );
# Patch: length is not really important here
$rtoken_vars->[_TOKEN_LENGTH_] = length($line);
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
$self->end_batch();
return;
}
############################
# Handle all other lines ...
############################
# If we just saw the end of an elsif block, write nag message
# if we do not see another elseif or an else.
if ($looking_for_else) {
unless ( $rLL->[$K_first]->[_TOKEN_] =~ /^(elsif|else)$/ ) {
write_logfile_entry("(No else block)\n");
}
$looking_for_else = 0;
}
# This is a good place to kill incomplete one-line blocks
if (
(
( $semicolons_before_block_self_destruct == 0 )
&& ( $max_index_to_go >= 0 )
&& ( $last_old_nonblank_type eq ';' )
&& ( $first_new_nonblank_token ne '}' )
)
# Patch for RT #98902. Honor request to break at old commas.
|| ( $rOpts_break_at_old_comma_breakpoints
&& $max_index_to_go >= 0
&& $last_old_nonblank_type eq ',' )
)
{
$forced_breakpoint_to_go[$max_index_to_go] = 1
if ($rOpts_break_at_old_comma_breakpoints);
destroy_one_line_block();
$self->end_batch();
}
# loop to process the tokens one-by-one
# We do not want a leading blank if the previous batch just got output
if ( $max_index_to_go < 0 && $rLL->[$K_first]->[_TYPE_] eq 'b' ) {
$K_first++;
}
foreach my $Ktoken_vars ( $K_first .. $K_last ) {
# pull out some values for this token
my $rtoken_vars = $rLL->[$Ktoken_vars];
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
my $level = $rtoken_vars->[_LEVEL_];
my $slevel = $rtoken_vars->[_SLEVEL_];
my $ci_level = $rtoken_vars->[_CI_LEVEL_];
if ( $type eq '#' ) {
if (
$rOpts->{'delete-side-comments'}
# delete closing side comments if necessary
|| ( $rOpts->{'delete-closing-side-comments'}
&& $token =~ /$closing_side_comment_prefix_pattern/
&& $last_nonblank_block_type =~
/$closing_side_comment_list_pattern/ )
)
{
if ( $types_to_go[$max_index_to_go] eq 'b' ) {
unstore_token_to_go();
}
last;
}
}
# If we are continuing after seeing a right curly brace, flush
# buffer unless we see what we are looking for, as in
# } else ...
if ( $rbrace_follower && $type ne 'b' ) {
unless ( $rbrace_follower->{$token} ) {
$self->end_batch();
}
$rbrace_follower = undef;
}
# Get next nonblank on this line
my $next_nonblank_token = '';
my $next_nonblank_token_type = 'b';
if ( $Ktoken_vars < $K_last ) {
my $Knnb = $Ktoken_vars + 1;
if ( $rLL->[$Knnb]->[_TYPE_] eq 'b'
&& $Knnb < $K_last )
{
$Knnb++;
}
$next_nonblank_token = $rLL->[$Knnb]->[_TOKEN_];
$next_nonblank_token_type = $rLL->[$Knnb]->[_TYPE_];
}
# Do not allow breaks which would promote a side comment to a
# block comment. In order to allow a break before an opening
# or closing BLOCK, followed by a side comment, those sections
# of code will handle this flag separately.
$side_comment_follows = ( $next_nonblank_token_type eq '#' );
my $is_opening_BLOCK =
( $type eq '{'
&& $token eq '{'
&& $block_type
&& !$rshort_nested->{$type_sequence}
&& $block_type ne 't' );
my $is_closing_BLOCK =
( $type eq '}'
&& $token eq '}'
&& $block_type
&& !$rshort_nested->{$type_sequence}
&& $block_type ne 't' );
if ( $side_comment_follows
&& !$is_opening_BLOCK
&& !$is_closing_BLOCK )
{
$no_internal_newlines = 1;
}
# We're only going to handle breaking for code BLOCKS at this
# (top) level. Other indentation breaks will be handled by
# sub scan_list, which is better suited to dealing with them.
if ($is_opening_BLOCK) {
# Tentatively output this token. This is required before
# calling starting_one_line_block. We may have to unstore
# it, though, if we have to break before it.
$self->store_token_to_go($Ktoken_vars);
# Look ahead to see if we might form a one-line block..
my $too_long =
$self->starting_one_line_block( $Ktoken_vars,
$K_last_nonblank_code,
$K_last, $level, $slevel, $ci_level );
clear_breakpoint_undo_stack();
# to simplify the logic below, set a flag to indicate if
# this opening brace is far from the keyword which introduces it
my $keyword_on_same_line = 1;
if ( ( $max_index_to_go >= 0 )
&& ( $last_nonblank_type eq ')' )
&& ( ( $slevel < $nesting_depth_to_go[0] ) || $too_long ) )
{
$keyword_on_same_line = 0;
}
# decide if user requested break before '{'
my $want_break =
# use -bl flag if not a sub block of any type
$block_type !~ /$ANYSUB_PATTERN/
? $rOpts->{'opening-brace-on-new-line'}
# use -sbl flag for a named sub block
: $block_type !~ /$ASUB_PATTERN/
? $rOpts->{'opening-sub-brace-on-new-line'}
# use -asbl flag for an anonymous sub block
: $rOpts->{'opening-anonymous-sub-brace-on-new-line'};
# Do not break if this token is welded to the left
if ( weld_len_left( $type_sequence, $token ) ) {
$want_break = 0;
}
# Break before an opening '{' ...
if (
# if requested
$want_break
# and we were unable to start looking for a block,
&& $index_start_one_line_block == UNDEFINED_INDEX
# or if it will not be on same line as its keyword, so that
# it will be outdented (eval.t, overload.t), and the user
# has not insisted on keeping it on the right
|| ( !$keyword_on_same_line
&& !$rOpts->{'opening-brace-always-on-right'} )
)
{
# but only if allowed
unless ($no_internal_newlines) {
# since we already stored this token, we must unstore it
$self->unstore_token_to_go();
# then output the line
$self->end_batch();
# and now store this token at the start of a new line
$self->store_token_to_go($Ktoken_vars);
}
}
# Now update for side comment
if ($side_comment_follows) { $no_internal_newlines = 1 }
# now output this line
unless ($no_internal_newlines) {
$self->end_batch();
}
}
elsif ($is_closing_BLOCK) {
# If there is a pending one-line block ..
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
# we have to terminate it if..
if (
# it is too long (final length may be different from
# initial estimate). note: must allow 1 space for this
# token
excess_line_length( $index_start_one_line_block,
$max_index_to_go ) >= 0
# or if it has too many semicolons
|| ( $semicolons_before_block_self_destruct == 0
&& $last_nonblank_type ne ';' )
)
{
destroy_one_line_block();
}
}
# put a break before this closing curly brace if appropriate
unless ( $no_internal_newlines
|| $index_start_one_line_block != UNDEFINED_INDEX )
{
# write out everything before this closing curly brace
$self->end_batch();
}
# Now update for side comment
if ($side_comment_follows) { $no_internal_newlines = 1 }
# store the closing curly brace
$self->store_token_to_go($Ktoken_vars);
# ok, we just stored a closing curly brace. Often, but
# not always, we want to end the line immediately.
# So now we have to check for special cases.
# if this '}' successfully ends a one-line block..
my $is_one_line_block = 0;
my $keep_going = 0;
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
# Remember the type of token just before the
# opening brace. It would be more general to use
# a stack, but this will work for one-line blocks.
$is_one_line_block =
$types_to_go[$index_start_one_line_block];
# we have to actually make it by removing tentative
# breaks that were set within it
undo_forced_breakpoint_stack(0);
set_nobreaks( $index_start_one_line_block,
$max_index_to_go - 1 );
# then re-initialize for the next one-line block
destroy_one_line_block();
# then decide if we want to break after the '}' ..
# We will keep going to allow certain brace followers as in:
# do { $ifclosed = 1; last } unless $losing;
#
# But make a line break if the curly ends a
# significant block:
if (
(
$is_block_without_semicolon{$block_type}
# Follow users break point for
# one line block types U & G, such as a 'try' block
|| $is_one_line_block =~ /^[UG]$/
&& $Ktoken_vars == $K_last
)
# if needless semicolon follows we handle it later
&& $next_nonblank_token ne ';'
)
{
$self->end_batch()
unless ($no_internal_newlines);
}
}
# set string indicating what we need to look for brace follower
# tokens
if ( $block_type eq 'do' ) {
$rbrace_follower = \%is_do_follower;
if ( $self->tight_paren_follows( $K_to_go[0], $Ktoken_vars )
)
{
$rbrace_follower = { ')' => 1 };
}
}
elsif ( $block_type =~ /^(if|elsif|unless)$/ ) {
$rbrace_follower = \%is_if_brace_follower;
}
elsif ( $block_type eq 'else' ) {
$rbrace_follower = \%is_else_brace_follower;
}
# added eval for borris.t
elsif ($is_sort_map_grep_eval{$block_type}
|| $is_one_line_block eq 'G' )
{
$rbrace_follower = undef;
$keep_going = 1;
}
# anonymous sub
elsif ( $block_type =~ /$ASUB_PATTERN/ ) {
if ($is_one_line_block) {
$rbrace_follower = \%is_anon_sub_1_brace_follower;
}
else {
$rbrace_follower = \%is_anon_sub_brace_follower;
}
}
# None of the above: specify what can follow a closing
# brace of a block which is not an
# if/elsif/else/do/sort/map/grep/eval
# Testfiles:
# 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl', 'break1.t
else {
$rbrace_follower = \%is_other_brace_follower;
}
# See if an elsif block is followed by another elsif or else;
# complain if not.
if ( $block_type eq 'elsif' ) {
if ( $next_nonblank_token_type eq 'b' ) { # end of line?
$looking_for_else = 1; # ok, check on next line
}
else {
unless ( $next_nonblank_token =~ /^(elsif|else)$/ ) {
write_logfile_entry("No else block :(\n");
}
}
}
# keep going after certain block types (map,sort,grep,eval)
# added eval for borris.t
if ($keep_going) {
# keep going
}
# if no more tokens, postpone decision until re-entring
elsif ( ( $next_nonblank_token_type eq 'b' )
&& $rOpts_add_newlines )
{
unless ($rbrace_follower) {
$self->end_batch()
unless ($no_internal_newlines);
}
}
elsif ($rbrace_follower) {
unless ( $rbrace_follower->{$next_nonblank_token} ) {
$self->end_batch()
unless ($no_internal_newlines);
}
$rbrace_follower = undef;
}
else {
$self->end_batch()
unless ($no_internal_newlines);
}
} # end treatment of closing block token
# handle semicolon
elsif ( $type eq ';' ) {
# kill one-line blocks with too many semicolons
$semicolons_before_block_self_destruct--;
if (
( $semicolons_before_block_self_destruct < 0 )
|| ( $semicolons_before_block_self_destruct == 0
&& $next_nonblank_token_type !~ /^[b\}]$/ )
)
{
destroy_one_line_block();
}
$self->store_token_to_go($Ktoken_vars);
$self->end_batch()
unless (
$no_internal_newlines
|| ( $rOpts_keep_interior_semicolons
&& $Ktoken_vars < $K_last )
|| ( $next_nonblank_token eq '}' )
);
}
# handle here_doc target string
elsif ( $type eq 'h' ) {
# no newlines after seeing here-target
$no_internal_newlines = 1;
destroy_one_line_block();
$self->store_token_to_go($Ktoken_vars);
}
# handle all other token types
else {
$self->store_token_to_go($Ktoken_vars);
}
# remember two previous nonblank OUTPUT tokens
if ( $type ne '#' && $type ne 'b' ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_nonblank_token = $token;
$last_nonblank_type = $type;
$last_nonblank_block_type = $block_type;
$K_last_last_nonblank_code = $K_last_nonblank_code;
$K_last_nonblank_code = $Ktoken_vars;
}
} # end of loop over all tokens in this 'line_of_tokens'
my $type = $rLL->[$K_last]->[_TYPE_];
if ( $type eq '#' && $rOpts->{'tee-side-comments'} ) {
$fh_tee->print($input_line) if ($fh_tee);
}
# we have to flush ..
if (
# if there is a side comment...
# Even if we deleted it! Otherwise,
# i-K indexing will have a gap and be incorrect ( see RT #132059)
## ( ( $type eq '#' ) && !$rOpts->{'delete-side-comments'} )
$type eq '#'
# if this line ends in a quote
# NOTE: This is critically important for insuring that quoted lines
# do not get processed by things like -sot and -sct
|| $in_quote
# if this is a VERSION statement
|| $is_VERSION_statement
# to keep a label at the end of a line
|| $type eq 'J'
# if we are instructed to keep all old line breaks
|| !$rOpts->{'delete-old-newlines'}
)
{
destroy_one_line_block();
$self->end_batch();
}
# mark old line breakpoints in current output stream
if ( $max_index_to_go >= 0 && !$rOpts_ignore_old_breakpoints ) {
my $jobp = $max_index_to_go;
if ( $types_to_go[$max_index_to_go] eq 'b' && $max_index_to_go > 0 )
{
$jobp--;
}
$old_breakpoint_to_go[$jobp] = 1;
}
return;
} ## end sub process_line_of_CODE
} ## end block process_line_of_CODE
sub consecutive_nonblank_lines {
return $file_writer_object->get_consecutive_nonblank_lines() +
$vertical_aligner_object->get_cached_line_count();
}
# sub process_batch_of_CODE sends one logical line of tokens on down the
# pipeline to the VerticalAligner package, breaking the line into continuation
# lines as necessary. The line of tokens is ready to go in the "to_go"
# arrays.
sub process_batch_of_CODE {
my ( $self, $comma_count_in_batch ) = @_;
my $rLL = $self->{rLL};
my $rOpts_add_newlines = $rOpts->{'add-newlines'};
my $rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
my $rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
my $rOpts_one_line_block_semicolons = $rOpts->{'one-line-block-semicolons'};
# debug stuff; this routine can be called from many points
FORMATTER_DEBUG_FLAG_OUTPUT && do {
my ( $a, $b, $c ) = caller;
my $token = my $type = "";
if ( $max_index_to_go >= 0 ) {
$token = $tokens_to_go[$max_index_to_go];
$type = $types_to_go[$max_index_to_go];
}
write_diagnostics(
"OUTPUT: process_batch_of_CODE called: $a $c at type='$type' tok='$token', tokens to write=$max_index_to_go\n"
);
my $output_str = join "", @tokens_to_go[ 0 .. $max_index_to_go ];
write_diagnostics("$output_str\n");
};
my $comma_arrow_count_contained = match_opening_and_closing_tokens();
# tell the -lp option we are outputting a batch so it can close
# any unfinished items in its stack
finish_lp_batch();
# If this line ends in a code block brace, set breaks at any
# previous closing code block braces to breakup a chain of code
# blocks on one line. This is very rare but can happen for
# user-defined subs. For example we might be looking at this:
# BOOL { $server_data{uptime} > 0; } NUM { $server_data{load}; } STR {
my $saw_good_break = 0; # flag to force breaks even if short line
if (
# looking for opening or closing block brace
$block_type_to_go[$max_index_to_go]
# but not one of these which are never duplicated on a line:
# until|while|for|if|elsif|else
&& !$is_block_without_semicolon{ $block_type_to_go[$max_index_to_go] }
)
{
my $lev = $nesting_depth_to_go[$max_index_to_go];
# Walk backwards from the end and
# set break at any closing block braces at the same level.
# But quit if we are not in a chain of blocks.
for ( my $i = $max_index_to_go - 1 ; $i >= 0 ; $i-- ) {
last if ( $levels_to_go[$i] < $lev ); # stop at a lower level
next if ( $levels_to_go[$i] > $lev ); # skip past higher level
if ( $block_type_to_go[$i] ) {
if ( $tokens_to_go[$i] eq '}' ) {
set_forced_breakpoint($i);
$saw_good_break = 1;
}
}
# quit if we see anything besides words, function, blanks
# at this level
elsif ( $types_to_go[$i] !~ /^[\(\)Gwib]$/ ) { last }
}
}
my $imin = 0;
my $imax = $max_index_to_go;
# trim any blank tokens
if ( $max_index_to_go >= 0 ) {
if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
}
# anything left to write?
if ( $imin <= $imax ) {
# add a blank line before certain key types but not after a comment
if ( $last_line_leading_type !~ /^[#]/ ) {
my $want_blank = 0;
my $leading_token = $tokens_to_go[$imin];
my $leading_type = $types_to_go[$imin];
# blank lines before subs except declarations and one-liners
if ( $leading_type eq 'i' && $leading_token =~ /$SUB_PATTERN/ ) {
$want_blank = $rOpts->{'blank-lines-before-subs'}
if ( $self->terminal_type_i( $imin, $imax ) !~ /^[\;\}]$/ );
}
# break before all package declarations
elsif ($leading_token =~ /^(package\s)/
&& $leading_type eq 'i' )
{
$want_blank = $rOpts->{'blank-lines-before-packages'};
}
# break before certain key blocks except one-liners
if ( $leading_token =~ /^(BEGIN|END)$/ && $leading_type eq 'k' ) {
$want_blank = $rOpts->{'blank-lines-before-subs'}
if ( $self->terminal_type_i( $imin, $imax ) ne '}' );
}
# Break before certain block types if we haven't had a
# break at this level for a while. This is the
# difficult decision..
elsif ($leading_type eq 'k'
&& $last_line_leading_type ne 'b'
&& $leading_token =~ /^(unless|if|while|until|for|foreach)$/ )
{
my $lc = $nonblank_lines_at_depth[$last_line_leading_level];
if ( !defined($lc) ) { $lc = 0 }
# patch for RT #128216: no blank line inserted at a level change
if ( $levels_to_go[$imin] != $last_line_leading_level ) {
$lc = 0;
}
$want_blank =
$rOpts->{'blanks-before-blocks'}
&& $lc >= $rOpts->{'long-block-line-count'}
&& consecutive_nonblank_lines() >=
$rOpts->{'long-block-line-count'}
&& $self->terminal_type_i( $imin, $imax ) ne '}';
}
# Check for blank lines wanted before a closing brace
if ( $leading_token eq '}' ) {
if ( $rOpts->{'blank-lines-before-closing-block'}
&& $block_type_to_go[$imin]
&& $block_type_to_go[$imin] =~
/$blank_lines_before_closing_block_pattern/ )
{
my $nblanks = $rOpts->{'blank-lines-before-closing-block'};
if ( $nblanks > $want_blank ) {
$want_blank = $nblanks;
}
}
}
if ($want_blank) {
# future: send blank line down normal path to VerticalAligner
Perl::Tidy::VerticalAligner::flush();
$file_writer_object->require_blank_code_lines($want_blank);
}
}
# update blank line variables and count number of consecutive
# non-blank, non-comment lines at this level
$last_last_line_leading_level = $last_line_leading_level;
$last_line_leading_level = $levels_to_go[$imin];
if ( $last_line_leading_level < 0 ) { $last_line_leading_level = 0 }
$last_line_leading_type = $types_to_go[$imin];
if ( $last_line_leading_level == $last_last_line_leading_level
&& $last_line_leading_type ne 'b'
&& $last_line_leading_type ne '#'
&& defined( $nonblank_lines_at_depth[$last_line_leading_level] ) )
{
$nonblank_lines_at_depth[$last_line_leading_level]++;
}
else {
$nonblank_lines_at_depth[$last_line_leading_level] = 1;
}
FORMATTER_DEBUG_FLAG_FLUSH && do {
my ( $package, $file, $line ) = caller;
print STDOUT
"FLUSH: flushing from $package $file $line, types= $types_to_go[$imin] to $types_to_go[$imax]\n";
};
# add a couple of extra terminal blank tokens
pad_array_to_go();
# set all forced breakpoints for good list formatting
my $is_long_line = excess_line_length( $imin, $max_index_to_go ) > 0;
my $old_line_count_in_batch =
$self->get_old_line_count( $K_to_go[0], $K_to_go[$max_index_to_go] );
if (
$is_long_line
|| $old_line_count_in_batch > 1
# must always call scan_list() with unbalanced batches because it
# is maintaining some stacks
|| is_unbalanced_batch()
# call scan_list if we might want to break at commas
|| (
$comma_count_in_batch
&& ( $rOpts_maximum_fields_per_table > 0
|| $rOpts_comma_arrow_breakpoints == 0 )
)
# call scan_list if user may want to break open some one-line
# hash references
|| ( $comma_arrow_count_contained
&& $rOpts_comma_arrow_breakpoints != 3 )
)
{
## This caused problems in one version of perl for unknown reasons:
## $saw_good_break ||= scan_list();
my $sgb = scan_list();
$saw_good_break ||= $sgb;
}
# let $ri_first and $ri_last be references to lists of
# first and last tokens of line fragments to output..
my ( $ri_first, $ri_last );
# write a single line if..
if (
# we aren't allowed to add any newlines
!$rOpts_add_newlines
# or, we don't already have an interior breakpoint
# and we didn't see a good breakpoint
|| (
!$forced_breakpoint_count
&& !$saw_good_break
# and this line is 'short'
&& !$is_long_line
)
)
{
@{$ri_first} = ($imin);
@{$ri_last} = ($imax);
}
# otherwise use multiple lines
else {
( $ri_first, $ri_last, my $colon_count ) =
$self->set_continuation_breaks($saw_good_break);
$self->break_all_chain_tokens( $ri_first, $ri_last );
break_equals( $ri_first, $ri_last );
# now we do a correction step to clean this up a bit
# (The only time we would not do this is for debugging)
if ( $rOpts->{'recombine'} ) {
( $ri_first, $ri_last ) =
recombine_breakpoints( $ri_first, $ri_last );
}
$self->insert_final_breaks( $ri_first, $ri_last ) if $colon_count;
}
# do corrector step if -lp option is used
my $do_not_pad = 0;
if ($rOpts_line_up_parentheses) {
$do_not_pad = correct_lp_indentation( $ri_first, $ri_last );
}
$self->unmask_phantom_semicolons( $ri_first, $ri_last );
if ( $rOpts_one_line_block_semicolons == 0 ) {
$self->delete_one_line_semicolons( $ri_first, $ri_last );
}
# The line breaks for this batch of code have been finalized. Now we
# can to package the results for further processing. We will switch
# from the local '_to_go' buffer arrays (i-index) back to the global
# token arrays (K-index) at this point.
my $rlines_K;
my $index_error;
for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
my $ibeg = $ri_first->[$n];
my $Kbeg = $K_to_go[$ibeg];
my $iend = $ri_last->[$n];
my $Kend = $K_to_go[$iend];
if ( $iend - $ibeg != $Kend - $Kbeg ) {
$index_error = $n unless defined($index_error);
}
push @{$rlines_K},
[ $Kbeg, $Kend, $forced_breakpoint_to_go[$iend] ];
}
# Check correctness of the mapping between the i and K token indexes
if ( defined($index_error) ) {
# Temporary debug code - should never get here
for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
my $ibeg = $ri_first->[$n];
my $Kbeg = $K_to_go[$ibeg];
my $iend = $ri_last->[$n];
my $Kend = $K_to_go[$iend];
my $idiff = $iend - $ibeg;
my $Kdiff = $Kend - $Kbeg;
print STDERR <<EOM;
line $n, irange $ibeg-$iend = $idiff, Krange $Kbeg-$Kend = $Kdiff;
EOM
}
Fault("Index error at line $index_error; i and K ranges differ");
}
my $rbatch_hash = {
rlines_K => $rlines_K,
do_not_pad => $do_not_pad,
ibeg0 => $ri_first->[0],
};
$self->send_lines_to_vertical_aligner($rbatch_hash);
# Insert any requested blank lines after an opening brace. We have to
# skip back before any side comment to find the terminal token
my $iterm;
for ( $iterm = $imax ; $iterm >= $imin ; $iterm-- ) {
next if $types_to_go[$iterm] eq '#';
next if $types_to_go[$iterm] eq 'b';
last;
}
# write requested number of blank lines after an opening block brace
if ( $iterm >= $imin && $types_to_go[$iterm] eq '{' ) {
if ( $rOpts->{'blank-lines-after-opening-block'}
&& $block_type_to_go[$iterm]
&& $block_type_to_go[$iterm] =~
/$blank_lines_after_opening_block_pattern/ )
{
my $nblanks = $rOpts->{'blank-lines-after-opening-block'};
Perl::Tidy::VerticalAligner::flush();
$file_writer_object->require_blank_code_lines($nblanks);
}
}
}
prepare_for_new_input_lines();
return;
}
sub note_added_semicolon {
my ($line_number) = @_;
$last_added_semicolon_at = $line_number;
if ( $added_semicolon_count == 0 ) {
$first_added_semicolon_at = $last_added_semicolon_at;
}
$added_semicolon_count++;
write_logfile_entry("Added ';' here\n");
return;
}
sub note_deleted_semicolon {
$last_deleted_semicolon_at = $input_line_number;
if ( $deleted_semicolon_count == 0 ) {
$first_deleted_semicolon_at = $last_deleted_semicolon_at;
}
$deleted_semicolon_count++;
write_logfile_entry("Deleted unnecessary ';' at line $input_line_number\n");
return;
}
sub note_embedded_tab {
$embedded_tab_count++;
$last_embedded_tab_at = $input_line_number;
if ( !$first_embedded_tab_at ) {
$first_embedded_tab_at = $last_embedded_tab_at;
}
if ( $embedded_tab_count <= MAX_NAG_MESSAGES ) {
write_logfile_entry("Embedded tabs in quote or pattern\n");
}
return;
}
sub starting_one_line_block {
# after seeing an opening curly brace, look for the closing brace and see
# if the entire block will fit on a line. This routine is not always right
# so a check is made later (at the closing brace) to make sure we really
# have a one-line block. We have to do this preliminary check, though,
# because otherwise we would always break at a semicolon within a one-line
# block if the block contains multiple statements.
my ( $self, $Kj, $K_last_nonblank, $K_last, $level, $slevel, $ci_level ) =
@_;
# uses Global Symbols:
# "$ANYSUB_PATTERN"
# "$index_max_forced_break"
# "$max_index_to_go"
# "%is_sort_map_grep"
# "%want_one_line_block"
# "@K_to_go"
# "@levels_to_go"
# "@tokens_to_go"
# "@types_to_go"
my $rbreak_container = $self->{rbreak_container};
my $rshort_nested = $self->{rshort_nested};
my $rLL = $self->{rLL};
# kill any current block - we can only go 1 deep
destroy_one_line_block();
# return value:
# 1=distance from start of block to opening brace exceeds line length
# 0=otherwise
my $i_start = 0;
# shouldn't happen: there must have been a prior call to
# store_token_to_go to put the opening brace in the output stream
if ( !defined($max_index_to_go) || $max_index_to_go < 0 ) {
Fault("program bug: store_token_to_go called incorrectly\n");
}
# return if block should be broken
my $type_sequence = $rLL->[$Kj]->[_TYPE_SEQUENCE_];
if ( $rbreak_container->{$type_sequence} ) {
return 0;
}
my $block_type = $rLL->[$Kj]->[_BLOCK_TYPE_];
my $previous_nonblank_token = '';
my $i_last_nonblank = -1;
if ( defined($K_last_nonblank) ) {
$i_last_nonblank = $K_last_nonblank - $K_to_go[0];
if ( $i_last_nonblank >= 0 ) {
$previous_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
}
}
# find the starting keyword for this block (such as 'if', 'else', ...)
if ( $max_index_to_go == 0
|| $block_type =~ /^[\{\}\;\:]$/
|| $block_type =~ /^package/ )
{
$i_start = $max_index_to_go;
}
# the previous nonblank token should start these block types
elsif (
$i_last_nonblank >= 0
&& ( $previous_nonblank_token eq $block_type
|| $block_type =~ /$ANYSUB_PATTERN/
|| $block_type =~ /\(\)/ )
)
{
$i_start = $i_last_nonblank;
# For signatures and extended syntax ...
# If this brace follows a parenthesized list, we should look back to
# find the keyword before the opening paren because otherwise we might
# form a one line block which stays intack, and cause the parenthesized
# expression to break open. That looks bad. However, actually
# searching for the opening paren is slow and tedius.
# The actual keyword is often at the start of a line, but might not be.
# For example, we might have an anonymous sub with signature list
# following a =>. It is safe to mark the start anywhere before the
# opening paren, so we just go back to the prevoious break (or start of
# the line) if that is before the opening paren. The minor downside is
# that we may very occasionally break open a block unnecessarily.
if ( $tokens_to_go[$i_start] eq ')' ) {
$i_start = $index_max_forced_break + 1;
if ( $types_to_go[$i_start] eq 'b' ) { $i_start++; }
my $lev = $levels_to_go[$i_start];
if ( $lev > $level ) { return 0 }
}
}
elsif ( $previous_nonblank_token eq ')' ) {
# For something like "if (xxx) {", the keyword "if" will be
# just after the most recent break. This will be 0 unless
# we have just killed a one-line block and are starting another.
# (doif.t)
# Note: cannot use inext_index_to_go[] here because that array
# is still being constructed.
$i_start = $index_max_forced_break + 1;
if ( $types_to_go[$i_start] eq 'b' ) {
$i_start++;
}
# Patch to avoid breaking short blocks defined with extended_syntax:
# Strip off any trailing () which was added in the parser to mark
# the opening keyword. For example, in the following
# create( TypeFoo $e) {$bubba}
# the blocktype would be marked as create()
my $stripped_block_type = $block_type;
$stripped_block_type =~ s/\(\)$//;
unless ( $tokens_to_go[$i_start] eq $stripped_block_type ) {
return 0;
}
}
# patch for SWITCH/CASE to retain one-line case/when blocks
elsif ( $block_type eq 'case' || $block_type eq 'when' ) {
# Note: cannot use inext_index_to_go[] here because that array
# is still being constructed.
$i_start = $index_max_forced_break + 1;
if ( $types_to_go[$i_start] eq 'b' ) {
$i_start++;
}
unless ( $tokens_to_go[$i_start] eq $block_type ) {
return 0;
}
}
else {
return 1;
}
my $pos = total_line_length( $i_start, $max_index_to_go ) - 1;
# see if length is too long to even start
if ( $pos > maximum_line_length($i_start) ) {
return 1;
}
foreach my $Ki ( $Kj + 1 .. $K_last ) {
# old whitespace could be arbitrarily large, so don't use it
if ( $rLL->[$Ki]->[_TYPE_] eq 'b' ) { $pos += 1 }
else { $pos += $rLL->[$Ki]->[_TOKEN_LENGTH_] }
# ignore some small blocks
my $type_sequence = $rLL->[$Ki]->[_TYPE_SEQUENCE_];
my $nobreak = $rshort_nested->{$type_sequence};
# Return false result if we exceed the maximum line length,
if ( $pos > maximum_line_length($i_start) ) {
return 0;
}
# keep going for non-containers
elsif ( !$type_sequence ) {
}
# return if we encounter another opening brace before finding the
# closing brace.
elsif ($rLL->[$Ki]->[_TOKEN_] eq '{'
&& $rLL->[$Ki]->[_TYPE_] eq '{'
&& $rLL->[$Ki]->[_BLOCK_TYPE_]
&& !$nobreak )
{
return 0;
}
# if we find our closing brace..
elsif ($rLL->[$Ki]->[_TOKEN_] eq '}'
&& $rLL->[$Ki]->[_TYPE_] eq '}'
&& $rLL->[$Ki]->[_BLOCK_TYPE_]
&& !$nobreak )
{
# be sure any trailing comment also fits on the line
my $Ki_nonblank = $Ki;
if ( $Ki_nonblank < $K_last ) {
$Ki_nonblank++;
if ( $rLL->[$Ki_nonblank]->[_TYPE_] eq 'b'
&& $Ki_nonblank < $K_last )
{
$Ki_nonblank++;
}
}
# Patch for one-line sort/map/grep/eval blocks with side comments:
# We will ignore the side comment length for sort/map/grep/eval
# because this can lead to statements which change every time
# perltidy is run. Here is an example from Denis Moskowitz which
# oscillates between these two states without this patch:
## --------
## grep { $_->foo ne 'bar' } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
## @baz;
##
## grep {
## $_->foo ne 'bar'
## } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
## @baz;
## --------
# When the first line is input it gets broken apart by the main
# line break logic in sub process_line_of_CODE.
# When the second line is input it gets recombined by
# process_line_of_CODE and passed to the output routines. The
# output routines (set_continuation_breaks) do not break it apart
# because the bond strengths are set to the highest possible value
# for grep/map/eval/sort blocks, so the first version gets output.
# It would be possible to fix this by changing bond strengths,
# but they are high to prevent errors in older versions of perl.
if ( $Ki < $K_last
&& $rLL->[$Ki_nonblank]->[_TYPE_] eq '#'
&& !$is_sort_map_grep{$block_type} )
{
$pos += $rLL->[$Ki_nonblank]->[_TOKEN_LENGTH_];
if ( $Ki_nonblank > $Ki + 1 ) {
# source whitespace could be anything, assume
# at least one space before the hash on output
if ( $rLL->[ $Ki + 1 ]->[_TYPE_] eq 'b' ) {
$pos += 1;
}
else { $pos += $rLL->[ $Ki + 1 ]->[_TOKEN_LENGTH_] }
}
if ( $pos >= maximum_line_length($i_start) ) {
return 0;
}
}
# ok, it's a one-line block
create_one_line_block( $i_start, 20 );
return 0;
}
# just keep going for other characters
else {
}
}
# Allow certain types of new one-line blocks to form by joining
# input lines. These can be safely done, but for other block types,
# we keep old one-line blocks but do not form new ones. It is not
# always a good idea to make as many one-line blocks as possible,
# so other types are not done. The user can always use -mangle.
if ( $want_one_line_block{$block_type} ) {
create_one_line_block( $i_start, 1 );
}
return 0;
}
sub unstore_token_to_go {
# remove most recent token from output stream
my $self = shift;
if ( $max_index_to_go > 0 ) {
$max_index_to_go--;
}
else {
$max_index_to_go = UNDEFINED_INDEX;
}
return;
}
sub want_blank_line {
my $self = shift;
$self->flush();
$file_writer_object->want_blank_line();
return;
}
sub write_unindented_line {
my ( $self, $line ) = @_;
$self->flush();
$file_writer_object->write_line($line);
return;
}
sub undo_ci {
# Undo continuation indentation in certain sequences
# For example, we can undo continuation indentation in sort/map/grep chains
# my $dat1 = pack( "n*",
# map { $_, $lookup->{$_} }
# sort { $a <=> $b }
# grep { $lookup->{$_} ne $default } keys %$lookup );
# To align the map/sort/grep keywords like this:
# my $dat1 = pack( "n*",
# map { $_, $lookup->{$_} }
# sort { $a <=> $b }
# grep { $lookup->{$_} ne $default } keys %$lookup );
my ( $self, $ri_first, $ri_last ) = @_;
my ( $line_1, $line_2, $lev_last );
my $this_line_is_semicolon_terminated;
my $max_line = @{$ri_first} - 1;
# looking at each line of this batch..
# We are looking at leading tokens and looking for a sequence
# all at the same level and higher level than enclosing lines.
foreach my $line ( 0 .. $max_line ) {
my $ibeg = $ri_first->[$line];
my $lev = $levels_to_go[$ibeg];
if ( $line > 0 ) {
# if we have started a chain..
if ($line_1) {
# see if it continues..
if ( $lev == $lev_last ) {
if ( $types_to_go[$ibeg] eq 'k'
&& $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
{
# chain continues...
# check for chain ending at end of a statement
if ( $line == $max_line ) {
# see of this line ends a statement
my $iend = $ri_last->[$line];
$this_line_is_semicolon_terminated =
$types_to_go[$iend] eq ';'
# with possible side comment
|| ( $types_to_go[$iend] eq '#'
&& $iend - $ibeg >= 2
&& $types_to_go[ $iend - 2 ] eq ';'
&& $types_to_go[ $iend - 1 ] eq 'b' );
}
$line_2 = $line if ($this_line_is_semicolon_terminated);
}
else {
# kill chain
$line_1 = undef;
}
}
elsif ( $lev < $lev_last ) {
# chain ends with previous line
$line_2 = $line - 1;
}
elsif ( $lev > $lev_last ) {
# kill chain
$line_1 = undef;
}
# undo the continuation indentation if a chain ends
if ( defined($line_2) && defined($line_1) ) {
my $continuation_line_count = $line_2 - $line_1 + 1;
@ci_levels_to_go[ @{$ri_first}[ $line_1 .. $line_2 ] ] =
(0) x ($continuation_line_count)
if ( $continuation_line_count >= 0 );
@leading_spaces_to_go[ @{$ri_first}[ $line_1 .. $line_2 ] ]
= @reduced_spaces_to_go[ @{$ri_first}
[ $line_1 .. $line_2 ] ];
$line_1 = undef;
}
}
# not in a chain yet..
else {
# look for start of a new sort/map/grep chain
if ( $lev > $lev_last ) {
if ( $types_to_go[$ibeg] eq 'k'
&& $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
{
$line_1 = $line;
}
}
}
}
$lev_last = $lev;
}
return;
}
sub undo_lp_ci {
# If there is a single, long parameter within parens, like this:
#
# $self->command( "/msg "
# . $infoline->chan
# . " You said $1, but did you know that it's square was "
# . $1 * $1 . " ?" );
#
# we can remove the continuation indentation of the 2nd and higher lines
# to achieve this effect, which is more pleasing:
#
# $self->command("/msg "
# . $infoline->chan
# . " You said $1, but did you know that it's square was "
# . $1 * $1 . " ?");
my ( $line_open, $i_start, $closing_index, $ri_first, $ri_last ) = @_;
my $max_line = @{$ri_first} - 1;
# must be multiple lines
return unless $max_line > $line_open;
my $lev_start = $levels_to_go[$i_start];
my $ci_start_plus = 1 + $ci_levels_to_go[$i_start];
# see if all additional lines in this container have continuation
# indentation
my $n;
my $line_1 = 1 + $line_open;
for ( $n = $line_1 ; $n <= $max_line ; ++$n ) {
my $ibeg = $ri_first->[$n];
my $iend = $ri_last->[$n];
if ( $ibeg eq $closing_index ) { $n--; last }
return if ( $lev_start != $levels_to_go[$ibeg] );
return if ( $ci_start_plus != $ci_levels_to_go[$ibeg] );
last if ( $closing_index <= $iend );
}
# we can reduce the indentation of all continuation lines
my $continuation_line_count = $n - $line_open;
@ci_levels_to_go[ @{$ri_first}[ $line_1 .. $n ] ] =
(0) x ($continuation_line_count);
@leading_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ] =
@reduced_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ];
return;
}
sub pad_token {
# insert $pad_spaces before token number $ipad
my ( $self, $ipad, $pad_spaces ) = @_;
my $rLL = $self->{rLL};
my $KK = $K_to_go[$ipad];
my $tok = $rLL->[$KK]->[_TOKEN_];
my $tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_];
if ( $pad_spaces > 0 ) {
$tok = ' ' x $pad_spaces . $tok;
$tok_len += $pad_spaces;
}
elsif ( $pad_spaces == -1 && $tokens_to_go[$ipad] eq ' ' ) {
$tok = "";
$tok_len = 0;
}
else {
# shouldn't happen
return;
}
$tok = $rLL->[$KK]->[_TOKEN_] = $tok;
$tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_] = $tok_len;
$token_lengths_to_go[$ipad] += $pad_spaces;
$tokens_to_go[$ipad] = $tok;
foreach my $i ( $ipad .. $max_index_to_go ) {
$summed_lengths_to_go[ $i + 1 ] += $pad_spaces;
}
return;
}
{
my %is_math_op;
BEGIN {
my @q = qw( + - * / );
@is_math_op{@q} = (1) x scalar(@q);
}
sub set_logical_padding {
# Look at a batch of lines and see if extra padding can improve the
# alignment when there are certain leading operators. Here is an
# example, in which some extra space is introduced before
# '( $year' to make it line up with the subsequent lines:
#
# if ( ( $Year < 1601 )
# || ( $Year > 2899 )
# || ( $EndYear < 1601 )
# || ( $EndYear > 2899 ) )
# {
# &Error_OutOfRange;
# }
#
my ( $self, $ri_first, $ri_last ) = @_;
my $max_line = @{$ri_first} - 1;
# FIXME: move these declarations below
my ( $ibeg, $ibeg_next, $ibegm, $iend, $iendm, $ipad, $pad_spaces,
$tok_next, $type_next, $has_leading_op_next, $has_leading_op );
# looking at each line of this batch..
foreach my $line ( 0 .. $max_line - 1 ) {
# see if the next line begins with a logical operator
$ibeg = $ri_first->[$line];
$iend = $ri_last->[$line];
$ibeg_next = $ri_first->[ $line + 1 ];
$tok_next = $tokens_to_go[$ibeg_next];
$type_next = $types_to_go[$ibeg_next];
$has_leading_op_next = ( $tok_next =~ /^\w/ )
? $is_chain_operator{$tok_next} # + - * / : ? && ||
: $is_chain_operator{$type_next}; # and, or
next unless ($has_leading_op_next);
# next line must not be at lesser depth
next
if ( $nesting_depth_to_go[$ibeg] >
$nesting_depth_to_go[$ibeg_next] );
# identify the token in this line to be padded on the left
$ipad = undef;
# handle lines at same depth...
if ( $nesting_depth_to_go[$ibeg] ==
$nesting_depth_to_go[$ibeg_next] )
{
# if this is not first line of the batch ...
if ( $line > 0 ) {
# and we have leading operator..
next if $has_leading_op;
# Introduce padding if..
# 1. the previous line is at lesser depth, or
# 2. the previous line ends in an assignment
# 3. the previous line ends in a 'return'
# 4. the previous line ends in a comma
# Example 1: previous line at lesser depth
# if ( ( $Year < 1601 ) # <- we are here but
# || ( $Year > 2899 ) # list has not yet
# || ( $EndYear < 1601 ) # collapsed vertically
# || ( $EndYear > 2899 ) )
# {
#
# Example 2: previous line ending in assignment:
# $leapyear =
# $year % 4 ? 0 # <- We are here
# : $year % 100 ? 1
# : $year % 400 ? 0
# : 1;
#
# Example 3: previous line ending in comma:
# push @expr,
# /test/ ? undef
# : eval($_) ? 1
# : eval($_) ? 1
# : 0;
# be sure levels agree (do not indent after an indented 'if')
next
if ( $levels_to_go[$ibeg] ne $levels_to_go[$ibeg_next] );
# allow padding on first line after a comma but only if:
# (1) this is line 2 and
# (2) there are at more than three lines and
# (3) lines 3 and 4 have the same leading operator
# These rules try to prevent padding within a long
# comma-separated list.
my $ok_comma;
if ( $types_to_go[$iendm] eq ','
&& $line == 1
&& $max_line > 2 )
{
my $ibeg_next_next = $ri_first->[ $line + 2 ];
my $tok_next_next = $tokens_to_go[$ibeg_next_next];
$ok_comma = $tok_next_next eq $tok_next;
}
next
unless (
$is_assignment{ $types_to_go[$iendm] }
|| $ok_comma
|| ( $nesting_depth_to_go[$ibegm] <
$nesting_depth_to_go[$ibeg] )
|| ( $types_to_go[$iendm] eq 'k'
&& $tokens_to_go[$iendm] eq 'return' )
);
# we will add padding before the first token
$ipad = $ibeg;
}
# for first line of the batch..
else {
# WARNING: Never indent if first line is starting in a
# continued quote, which would change the quote.
next if $starting_in_quote;
# if this is text after closing '}'
# then look for an interior token to pad
if ( $types_to_go[$ibeg] eq '}' ) {
}
# otherwise, we might pad if it looks really good
else {
# we might pad token $ibeg, so be sure that it
# is at the same depth as the next line.
next
if ( $nesting_depth_to_go[$ibeg] !=
$nesting_depth_to_go[$ibeg_next] );
# We can pad on line 1 of a statement if at least 3
# lines will be aligned. Otherwise, it
# can look very confusing.
# We have to be careful not to pad if there are too few
# lines. The current rule is:
# (1) in general we require at least 3 consecutive lines
# with the same leading chain operator token,
# (2) but an exception is that we only require two lines
# with leading colons if there are no more lines. For example,
# the first $i in the following snippet would get padding
# by the second rule:
#
# $i == 1 ? ( "First", "Color" )
# : $i == 2 ? ( "Then", "Rarity" )
# : ( "Then", "Name" );
if ( $max_line > 1 ) {
my $leading_token = $tokens_to_go[$ibeg_next];
my $tokens_differ;
# never indent line 1 of a '.' series because
# previous line is most likely at same level.
# TODO: we should also look at the leasing_spaces
# of the last output line and skip if it is same
# as this line.
next if ( $leading_token eq '.' );
my $count = 1;
foreach my $l ( 2 .. 3 ) {
last if ( $line + $l > $max_line );
my $ibeg_next_next = $ri_first->[ $line + $l ];
if ( $tokens_to_go[$ibeg_next_next] ne
$leading_token )
{
$tokens_differ = 1;
last;
}
$count++;
}
next if ($tokens_differ);
next if ( $count < 3 && $leading_token ne ':' );
$ipad = $ibeg;
}
else {
next;
}
}
}
}
# find interior token to pad if necessary
if ( !defined($ipad) ) {
for ( my $i = $ibeg ; ( $i < $iend ) && !$ipad ; $i++ ) {
# find any unclosed container
next
unless ( $type_sequence_to_go[$i]
&& $self->mate_index_to_go($i) > $iend );
# find next nonblank token to pad
$ipad = $inext_to_go[$i];
last if ( $ipad > $iend );
}
last unless $ipad;
}
# We cannot pad the first leading token of a file because
# it could cause a bug in which the starting indentation
# level is guessed incorrectly each time the code is run
# though perltidy, thus causing the code to march off to
# the right. For example, the following snippet would have
# this problem:
## ov_method mycan( $package, '(""' ), $package
## or ov_method mycan( $package, '(0+' ), $package
## or ov_method mycan( $package, '(bool' ), $package
## or ov_method mycan( $package, '(nomethod' ), $package;
# If this snippet is within a block this won't happen
# unless the user just processes the snippet alone within
# an editor. In that case either the user will see and
# fix the problem or it will be corrected next time the
# entire file is processed with perltidy.
next if ( $ipad == 0 && $peak_batch_size <= 1 );
## THIS PATCH REMOVES THE FOLLOWING POOR PADDING (math.t) with -pbp, BUT
## IT DID MORE HARM THAN GOOD
## ceil(
## $font->{'loca'}->{'glyphs'}[$x]->read->{'xMin'} * 1000
## / $upem
## ),
##? # do not put leading padding for just 2 lines of math
##? if ( $ipad == $ibeg
##? && $line > 0
##? && $levels_to_go[$ipad] > $levels_to_go[ $ipad - 1 ]
##? && $is_math_op{$type_next}
##? && $line + 2 <= $max_line )
##? {
##? my $ibeg_next_next = $ri_first->[ $line + 2 ];
##? my $type_next_next = $types_to_go[$ibeg_next_next];
##? next if !$is_math_op{$type_next_next};
##? }
# next line must not be at greater depth
my $iend_next = $ri_last->[ $line + 1 ];
next
if ( $nesting_depth_to_go[ $iend_next + 1 ] >
$nesting_depth_to_go[$ipad] );
# lines must be somewhat similar to be padded..
my $inext_next = $inext_to_go[$ibeg_next];
my $type = $types_to_go[$ipad];
my $type_next = $types_to_go[ $ipad + 1 ];
# see if there are multiple continuation lines
my $logical_continuation_lines = 1;
if ( $line + 2 <= $max_line ) {
my $leading_token = $tokens_to_go[$ibeg_next];
my $ibeg_next_next = $ri_first->[ $line + 2 ];
if ( $tokens_to_go[$ibeg_next_next] eq $leading_token
&& $nesting_depth_to_go[$ibeg_next] eq
$nesting_depth_to_go[$ibeg_next_next] )
{
$logical_continuation_lines++;
}
}
# see if leading types match
my $types_match = $types_to_go[$inext_next] eq $type;
my $matches_without_bang;
# if first line has leading ! then compare the following token
if ( !$types_match && $type eq '!' ) {
$types_match = $matches_without_bang =
$types_to_go[$inext_next] eq $types_to_go[ $ipad + 1 ];
}
if (
# either we have multiple continuation lines to follow
# and we are not padding the first token
( $logical_continuation_lines > 1 && $ipad > 0 )
# or..
|| (
# types must match
$types_match
# and keywords must match if keyword
&& !(
$type eq 'k'
&& $tokens_to_go[$ipad] ne $tokens_to_go[$inext_next]
)
)
)
{
#----------------------begin special checks--------------
#
# SPECIAL CHECK 1:
# A check is needed before we can make the pad.
# If we are in a list with some long items, we want each
# item to stand out. So in the following example, the
# first line beginning with '$casefold->' would look good
# padded to align with the next line, but then it
# would be indented more than the last line, so we
# won't do it.
#
# ok(
# $casefold->{code} eq '0041'
# && $casefold->{status} eq 'C'
# && $casefold->{mapping} eq '0061',
# 'casefold 0x41'
# );
#
# Note:
# It would be faster, and almost as good, to use a comma
# count, and not pad if comma_count > 1 and the previous
# line did not end with a comma.
#
my $ok_to_pad = 1;
my $ibg = $ri_first->[ $line + 1 ];
my $depth = $nesting_depth_to_go[ $ibg + 1 ];
# just use simplified formula for leading spaces to avoid
# needless sub calls
my $lsp = $levels_to_go[$ibg] + $ci_levels_to_go[$ibg];
# look at each line beyond the next ..
my $l = $line + 1;
foreach my $ltest ( $line + 2 .. $max_line ) {
$l = $ltest;
my $ibg = $ri_first->[$l];
# quit looking at the end of this container
last
if ( $nesting_depth_to_go[ $ibg + 1 ] < $depth )
|| ( $nesting_depth_to_go[$ibg] < $depth );
# cannot do the pad if a later line would be
# outdented more
if ( $levels_to_go[$ibg] + $ci_levels_to_go[$ibg] < $lsp ) {
$ok_to_pad = 0;
last;
}
}
# don't pad if we end in a broken list
if ( $l == $max_line ) {
my $i2 = $ri_last->[$l];
if ( $types_to_go[$i2] eq '#' ) {
my $i1 = $ri_first->[$l];
next if $self->terminal_type_i( $i1, $i2 ) eq ',';
}
}
# SPECIAL CHECK 2:
# a minus may introduce a quoted variable, and we will
# add the pad only if this line begins with a bare word,
# such as for the word 'Button' here:
# [
# Button => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
# -accelerator => "Meta+$_"
# ];
#
# On the other hand, if 'Button' is quoted, it looks best
# not to pad:
# [
# 'Button' => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
# -accelerator => "Meta+$_"
# ];
if ( $types_to_go[$ibeg_next] eq 'm' ) {
$ok_to_pad = 0 if $types_to_go[$ibeg] eq 'Q';
}
next unless $ok_to_pad;
#----------------------end special check---------------
my $length_1 = total_line_length( $ibeg, $ipad - 1 );
my $length_2 = total_line_length( $ibeg_next, $inext_next - 1 );
$pad_spaces = $length_2 - $length_1;
# If the first line has a leading ! and the second does
# not, then remove one space to try to align the next
# leading characters, which are often the same. For example:
# if ( !$ts
# || $ts == $self->Holder
# || $self->Holder->Type eq "Arena" )
#
# This usually helps readability, but if there are subsequent
# ! operators things will still get messed up. For example:
#
# if ( !exists $Net::DNS::typesbyname{$qtype}
# && exists $Net::DNS::classesbyname{$qtype}
# && !exists $Net::DNS::classesbyname{$qclass}
# && exists $Net::DNS::typesbyname{$qclass} )
# We can't fix that.
if ($matches_without_bang) { $pad_spaces-- }
# make sure this won't change if -lp is used
my $indentation_1 = $leading_spaces_to_go[$ibeg];
if ( ref($indentation_1) ) {
if ( $indentation_1->get_recoverable_spaces() == 0 ) {
my $indentation_2 = $leading_spaces_to_go[$ibeg_next];
unless ( $indentation_2->get_recoverable_spaces() == 0 )
{
$pad_spaces = 0;
}
}
}
# we might be able to handle a pad of -1 by removing a blank
# token
if ( $pad_spaces < 0 ) {
# Deactivated for -kpit due to conflict. This block deletes
# a space in an attempt to improve alignment in some cases,
# but it may conflict with user spacing requests. For now
# it is just deactivated if the -kpit option is used.
if ( $pad_spaces == -1 ) {
if ( $ipad > $ibeg
&& $types_to_go[ $ipad - 1 ] eq 'b'
&& !%keyword_paren_inner_tightness )
{
$self->pad_token( $ipad - 1, $pad_spaces );
}
}
$pad_spaces = 0;
}
# now apply any padding for alignment
if ( $ipad >= 0 && $pad_spaces ) {
my $length_t = total_line_length( $ibeg, $iend );
if ( $pad_spaces + $length_t <= maximum_line_length($ibeg) )
{
$self->pad_token( $ipad, $pad_spaces );
}
}
}
}
continue {
$iendm = $iend;
$ibegm = $ibeg;
$has_leading_op = $has_leading_op_next;
} # end of loop over lines
return;
}
}
sub correct_lp_indentation {
# When the -lp option is used, we need to make a last pass through
# each line to correct the indentation positions in case they differ
# from the predictions. This is necessary because perltidy uses a
# predictor/corrector method for aligning with opening parens. The
# predictor is usually good, but sometimes stumbles. The corrector
# tries to patch things up once the actual opening paren locations
# are known.
my ( $ri_first, $ri_last ) = @_;
my $do_not_pad = 0;
# Note on flag '$do_not_pad':
# We want to avoid a situation like this, where the aligner inserts
# whitespace before the '=' to align it with a previous '=', because
# otherwise the parens might become mis-aligned in a situation like
# this, where the '=' has become aligned with the previous line,
# pushing the opening '(' forward beyond where we want it.
#
# $mkFloor::currentRoom = '';
# $mkFloor::c_entry = $c->Entry(
# -width => '10',
# -relief => 'sunken',
# ...
# );
#
# We leave it to the aligner to decide how to do this.
# first remove continuation indentation if appropriate
my $max_line = @{$ri_first} - 1;
# looking at each line of this batch..
my ( $ibeg, $iend );
foreach my $line ( 0 .. $max_line ) {
$ibeg = $ri_first->[$line];
$iend = $ri_last->[$line];
# looking at each token in this output line..
foreach my $i ( $ibeg .. $iend ) {
# How many space characters to place before this token
# for special alignment. Actual padding is done in the
# continue block.
# looking for next unvisited indentation item
my $indentation = $leading_spaces_to_go[$i];
if ( !$indentation->get_marked() ) {
$indentation->set_marked(1);
# looking for indentation item for which we are aligning
# with parens, braces, and brackets
next unless ( $indentation->get_align_paren() );
# skip closed container on this line
if ( $i > $ibeg ) {
my $im = max( $ibeg, $iprev_to_go[$i] );
if ( $type_sequence_to_go[$im]
&& $mate_index_to_go[$im] <= $iend )
{
next;
}
}
if ( $line == 1 && $i == $ibeg ) {
$do_not_pad = 1;
}
# Ok, let's see what the error is and try to fix it
my $actual_pos;
my $predicted_pos = $indentation->get_spaces();
if ( $i > $ibeg ) {
# token is mid-line - use length to previous token
$actual_pos = total_line_length( $ibeg, $i - 1 );
# for mid-line token, we must check to see if all
# additional lines have continuation indentation,
# and remove it if so. Otherwise, we do not get
# good alignment.
my $closing_index = $indentation->get_closed();
if ( $closing_index > $iend ) {
my $ibeg_next = $ri_first->[ $line + 1 ];
if ( $ci_levels_to_go[$ibeg_next] > 0 ) {
undo_lp_ci( $line, $i, $closing_index, $ri_first,
$ri_last );
}
}
}
elsif ( $line > 0 ) {
# handle case where token starts a new line;
# use length of previous line
my $ibegm = $ri_first->[ $line - 1 ];
my $iendm = $ri_last->[ $line - 1 ];
$actual_pos = total_line_length( $ibegm, $iendm );
# follow -pt style
++$actual_pos
if ( $types_to_go[ $iendm + 1 ] eq 'b' );
}
else {
# token is first character of first line of batch
$actual_pos = $predicted_pos;
}
my $move_right = $actual_pos - $predicted_pos;
# done if no error to correct (gnu2.t)
if ( $move_right == 0 ) {
$indentation->set_recoverable_spaces($move_right);
next;
}
# if we have not seen closure for this indentation in
# this batch, we can only pass on a request to the
# vertical aligner
my $closing_index = $indentation->get_closed();
if ( $closing_index < 0 ) {
$indentation->set_recoverable_spaces($move_right);
next;
}
# If necessary, look ahead to see if there is really any
# leading whitespace dependent on this whitespace, and
# also find the longest line using this whitespace.
# Since it is always safe to move left if there are no
# dependents, we only need to do this if we may have
# dependent nodes or need to move right.
my $right_margin = 0;
my $have_child = $indentation->get_have_child();
my %saw_indentation;
my $line_count = 1;
$saw_indentation{$indentation} = $indentation;
if ( $have_child || $move_right > 0 ) {
$have_child = 0;
my $max_length = 0;
if ( $i == $ibeg ) {
$max_length = total_line_length( $ibeg, $iend );
}
# look ahead at the rest of the lines of this batch..
foreach my $line_t ( $line + 1 .. $max_line ) {
my $ibeg_t = $ri_first->[$line_t];
my $iend_t = $ri_last->[$line_t];
last if ( $closing_index <= $ibeg_t );
# remember all different indentation objects
my $indentation_t = $leading_spaces_to_go[$ibeg_t];
$saw_indentation{$indentation_t} = $indentation_t;
$line_count++;
# remember longest line in the group
my $length_t = total_line_length( $ibeg_t, $iend_t );
if ( $length_t > $max_length ) {
$max_length = $length_t;
}
}
$right_margin = maximum_line_length($ibeg) - $max_length;
if ( $right_margin < 0 ) { $right_margin = 0 }
}
my $first_line_comma_count =
grep { $_ eq ',' } @types_to_go[ $ibeg .. $iend ];
my $comma_count = $indentation->get_comma_count();
my $arrow_count = $indentation->get_arrow_count();
# This is a simple approximate test for vertical alignment:
# if we broke just after an opening paren, brace, bracket,
# and there are 2 or more commas in the first line,
# and there are no '=>'s,
# then we are probably vertically aligned. We could set
# an exact flag in sub scan_list, but this is good
# enough.
my $indentation_count = keys %saw_indentation;
my $is_vertically_aligned =
( $i == $ibeg
&& $first_line_comma_count > 1
&& $indentation_count == 1
&& ( $arrow_count == 0 || $arrow_count == $line_count ) );
# Make the move if possible ..
if (
# we can always move left
$move_right < 0
# but we should only move right if we are sure it will
# not spoil vertical alignment
|| ( $comma_count == 0 )
|| ( $comma_count > 0 && !$is_vertically_aligned )
)
{
my $move =
( $move_right <= $right_margin )
? $move_right
: $right_margin;
foreach ( keys %saw_indentation ) {
$saw_indentation{$_}
->permanently_decrease_available_spaces( -$move );
}
}
# Otherwise, record what we want and the vertical aligner
# will try to recover it.
else {
$indentation->set_recoverable_spaces($move_right);
}
}
}
}
return $do_not_pad;
}
sub reset_block_text_accumulator {
# save text after 'if' and 'elsif' to append after 'else'
if ($accumulating_text_for_block) {
if ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
push @{$rleading_block_if_elsif_text}, $leading_block_text;
}
}
$accumulating_text_for_block = "";
$leading_block_text = "";
$leading_block_text_level = 0;
$leading_block_text_length_exceeded = 0;
$leading_block_text_line_number = 0;
$leading_block_text_line_length = 0;
return;
}
sub set_block_text_accumulator {
my $i = shift;
$accumulating_text_for_block = $tokens_to_go[$i];
if ( $accumulating_text_for_block !~ /^els/ ) {
$rleading_block_if_elsif_text = [];
}
$leading_block_text = "";
$leading_block_text_level = $levels_to_go[$i];
$leading_block_text_line_number = get_output_line_number();
$leading_block_text_length_exceeded = 0;
# this will contain the column number of the last character
# of the closing side comment
$leading_block_text_line_length =
length($csc_last_label) +
length($accumulating_text_for_block) +
length( $rOpts->{'closing-side-comment-prefix'} ) +
$leading_block_text_level * $rOpts_indent_columns + 3;
return;
}
sub accumulate_block_text {
my $i = shift;
# accumulate leading text for -csc, ignoring any side comments
if ( $accumulating_text_for_block
&& !$leading_block_text_length_exceeded
&& $types_to_go[$i] ne '#' )
{
my $added_length = $token_lengths_to_go[$i];
$added_length += 1 if $i == 0;
my $new_line_length = $leading_block_text_line_length + $added_length;
# we can add this text if we don't exceed some limits..
if (
# we must not have already exceeded the text length limit
length($leading_block_text) <
$rOpts_closing_side_comment_maximum_text
# and either:
# the new total line length must be below the line length limit
# or the new length must be below the text length limit
# (ie, we may allow one token to exceed the text length limit)
&& (
$new_line_length <
maximum_line_length_for_level($leading_block_text_level)
|| length($leading_block_text) + $added_length <
$rOpts_closing_side_comment_maximum_text
)
# UNLESS: we are adding a closing paren before the brace we seek.
# This is an attempt to avoid situations where the ... to be
# added are longer than the omitted right paren, as in:
# foreach my $item (@a_rather_long_variable_name_here) {
# &whatever;
# } ## end foreach my $item (@a_rather_long_variable_name_here...
|| (
$tokens_to_go[$i] eq ')'
&& (
(
$i + 1 <= $max_index_to_go
&& $block_type_to_go[ $i + 1 ] eq
$accumulating_text_for_block
)
|| ( $i + 2 <= $max_index_to_go
&& $block_type_to_go[ $i + 2 ] eq
$accumulating_text_for_block )
)
)
)
{
# add an extra space at each newline
if ( $i == 0 ) { $leading_block_text .= ' ' }
# add the token text
$leading_block_text .= $tokens_to_go[$i];
$leading_block_text_line_length = $new_line_length;
}
# show that text was truncated if necessary
elsif ( $types_to_go[$i] ne 'b' ) {
$leading_block_text_length_exceeded = 1;
$leading_block_text .= '...';
}
}
return;
}
{
my %is_if_elsif_else_unless_while_until_for_foreach;
BEGIN {
# These block types may have text between the keyword and opening
# curly. Note: 'else' does not, but must be included to allow trailing
# if/elsif text to be appended.
# patch for SWITCH/CASE: added 'case' and 'when'
my @q =
qw(if elsif else unless while until for foreach case when catch);
@is_if_elsif_else_unless_while_until_for_foreach{@q} =
(1) x scalar(@q);
}
sub accumulate_csc_text {
# called once per output buffer when -csc is used. Accumulates
# the text placed after certain closing block braces.
# Defines and returns the following for this buffer:
my $block_leading_text = ""; # the leading text of the last '}'
my $rblock_leading_if_elsif_text;
my $i_block_leading_text =
-1; # index of token owning block_leading_text
my $block_line_count = 100; # how many lines the block spans
my $terminal_type = 'b'; # type of last nonblank token
my $i_terminal = 0; # index of last nonblank token
my $terminal_block_type = "";
# update most recent statement label
$csc_last_label = "" unless ($csc_last_label);
if ( $types_to_go[0] eq 'J' ) { $csc_last_label = $tokens_to_go[0] }
my $block_label = $csc_last_label;
# Loop over all tokens of this batch
for my $i ( 0 .. $max_index_to_go ) {
my $type = $types_to_go[$i];
my $block_type = $block_type_to_go[$i];
my $token = $tokens_to_go[$i];
# remember last nonblank token type
if ( $type ne '#' && $type ne 'b' ) {
$terminal_type = $type;
$terminal_block_type = $block_type;
$i_terminal = $i;
}
my $type_sequence = $type_sequence_to_go[$i];
if ( $block_type && $type_sequence ) {
if ( $token eq '}' ) {
# restore any leading text saved when we entered this block
if ( defined( $block_leading_text{$type_sequence} ) ) {
( $block_leading_text, $rblock_leading_if_elsif_text )
= @{ $block_leading_text{$type_sequence} };
$i_block_leading_text = $i;
delete $block_leading_text{$type_sequence};
$rleading_block_if_elsif_text =
$rblock_leading_if_elsif_text;
}
if ( defined( $csc_block_label{$type_sequence} ) ) {
$block_label = $csc_block_label{$type_sequence};
delete $csc_block_label{$type_sequence};
}
# if we run into a '}' then we probably started accumulating
# at something like a trailing 'if' clause..no harm done.
if ( $accumulating_text_for_block
&& $levels_to_go[$i] <= $leading_block_text_level )
{
my $lev = $levels_to_go[$i];
reset_block_text_accumulator();
}
if ( defined( $block_opening_line_number{$type_sequence} ) )
{
my $output_line_number = get_output_line_number();
$block_line_count =
$output_line_number -
$block_opening_line_number{$type_sequence} + 1;
delete $block_opening_line_number{$type_sequence};
}
else {
# Error: block opening line undefined for this line..
# This shouldn't be possible, but it is not a
# significant problem.
}
}
elsif ( $token eq '{' ) {
my $line_number = get_output_line_number();
$block_opening_line_number{$type_sequence} = $line_number;
# set a label for this block, except for
# a bare block which already has the label
# A label can only be used on the next {
if ( $block_type =~ /:$/ ) { $csc_last_label = "" }
$csc_block_label{$type_sequence} = $csc_last_label;
$csc_last_label = "";
if ( $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
{
if ( $accumulating_text_for_block eq $block_type ) {
# save any leading text before we enter this block
$block_leading_text{$type_sequence} = [
$leading_block_text,
$rleading_block_if_elsif_text
];
$block_opening_line_number{$type_sequence} =
$leading_block_text_line_number;
reset_block_text_accumulator();
}
else {
# shouldn't happen, but not a serious error.
# We were accumulating -csc text for block type
# $accumulating_text_for_block and unexpectedly
# encountered a '{' for block type $block_type.
}
}
}
}
if ( $type eq 'k'
&& $csc_new_statement_ok
&& $is_if_elsif_else_unless_while_until_for_foreach{$token}
&& $token =~ /$closing_side_comment_list_pattern/ )
{
set_block_text_accumulator($i);
}
else {
# note: ignoring type 'q' because of tricks being played
# with 'q' for hanging side comments
if ( $type ne 'b' && $type ne '#' && $type ne 'q' ) {
$csc_new_statement_ok =
( $block_type || $type eq 'J' || $type eq ';' );
}
if ( $type eq ';'
&& $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
{
reset_block_text_accumulator();
}
else {
accumulate_block_text($i);
}
}
}
# Treat an 'else' block specially by adding preceding 'if' and
# 'elsif' text. Otherwise, the 'end else' is not helpful,
# especially for cuddled-else formatting.
if ( $terminal_block_type =~ /^els/ && $rblock_leading_if_elsif_text ) {
$block_leading_text =
make_else_csc_text( $i_terminal, $terminal_block_type,
$block_leading_text, $rblock_leading_if_elsif_text );
}
# if this line ends in a label then remember it for the next pass
$csc_last_label = "";
if ( $terminal_type eq 'J' ) {
$csc_last_label = $tokens_to_go[$i_terminal];
}
return ( $terminal_type, $i_terminal, $i_block_leading_text,
$block_leading_text, $block_line_count, $block_label );
}
}
sub make_else_csc_text {
# create additional -csc text for an 'else' and optionally 'elsif',
# depending on the value of switch
#
# = 0 add 'if' text to trailing else
# = 1 same as 0 plus:
# add 'if' to 'elsif's if can fit in line length
# add last 'elsif' to trailing else if can fit in one line
# = 2 same as 1 but do not check if exceed line length
#
# $rif_elsif_text = a reference to a list of all previous closing
# side comments created for this if block
#
my ( $i_terminal, $block_type, $block_leading_text, $rif_elsif_text ) = @_;
my $csc_text = $block_leading_text;
my $rOpts_closing_side_comment_else_flag =
$rOpts->{'closing-side-comment-else-flag'};
if ( $block_type eq 'elsif'
&& $rOpts_closing_side_comment_else_flag == 0 )
{
return $csc_text;
}
my $count = @{$rif_elsif_text};
return $csc_text unless ($count);
my $if_text = '[ if' . $rif_elsif_text->[0];
# always show the leading 'if' text on 'else'
if ( $block_type eq 'else' ) {
$csc_text .= $if_text;
}
# see if that's all
if ( $rOpts_closing_side_comment_else_flag == 0 ) {
return $csc_text;
}
my $last_elsif_text = "";
if ( $count > 1 ) {
$last_elsif_text = ' [elsif' . $rif_elsif_text->[ $count - 1 ];
if ( $count > 2 ) { $last_elsif_text = ' [...' . $last_elsif_text; }
}
# tentatively append one more item
my $saved_text = $csc_text;
if ( $block_type eq 'else' ) {
$csc_text .= $last_elsif_text;
}
else {
$csc_text .= ' ' . $if_text;
}
# all done if no length checks requested
if ( $rOpts_closing_side_comment_else_flag == 2 ) {
return $csc_text;
}
# undo it if line length exceeded
my $length =
length($csc_text) +
length($block_type) +
length( $rOpts->{'closing-side-comment-prefix'} ) +
$levels_to_go[$i_terminal] * $rOpts_indent_columns + 3;
if ( $length > maximum_line_length_for_level($leading_block_text_level) ) {
$csc_text = $saved_text;
}
return $csc_text;
}
{ # sub balance_csc_text
my %matching_char;
BEGIN {
%matching_char = (
'{' => '}',
'(' => ')',
'[' => ']',
'}' => '{',
')' => '(',
']' => '[',
);
}
sub balance_csc_text {
# Append characters to balance a closing side comment so that editors
# such as vim can correctly jump through code.
# Simple Example:
# input = ## end foreach my $foo ( sort { $b ...
# output = ## end foreach my $foo ( sort { $b ...})
# NOTE: This routine does not currently filter out structures within
# quoted text because the bounce algorithms in text editors do not
# necessarily do this either (a version of vim was checked and
# did not do this).
# Some complex examples which will cause trouble for some editors:
# while ( $mask_string =~ /\{[^{]*?\}/g ) {
# if ( $mask_str =~ /\}\s*els[^\{\}]+\{$/ ) {
# if ( $1 eq '{' ) {
# test file test1/braces.pl has many such examples.
my ($csc) = @_;
# loop to examine characters one-by-one, RIGHT to LEFT and
# build a balancing ending, LEFT to RIGHT.
for ( my $pos = length($csc) - 1 ; $pos >= 0 ; $pos-- ) {
my $char = substr( $csc, $pos, 1 );
# ignore everything except structural characters
next unless ( $matching_char{$char} );
# pop most recently appended character
my $top = chop($csc);
# push it back plus the mate to the newest character
# unless they balance each other.
$csc = $csc . $top . $matching_char{$char} unless $top eq $char;
}
# return the balanced string
return $csc;
}
}
sub add_closing_side_comment {
my $self = shift;
my $rLL = $self->{rLL};
# add closing side comments after closing block braces if -csc used
my ( $closing_side_comment, $cscw_block_comment );
#---------------------------------------------------------------
# Step 1: loop through all tokens of this line to accumulate
# the text needed to create the closing side comments. Also see
# how the line ends.
#---------------------------------------------------------------
my ( $terminal_type, $i_terminal, $i_block_leading_text,
$block_leading_text, $block_line_count, $block_label )
= accumulate_csc_text();
#---------------------------------------------------------------
# Step 2: make the closing side comment if this ends a block
#---------------------------------------------------------------
my $have_side_comment = $types_to_go[$max_index_to_go] eq '#';
# if this line might end in a block closure..
if (
$terminal_type eq '}'
# ..and either
&& (
# the block is long enough
( $block_line_count >= $rOpts->{'closing-side-comment-interval'} )
# or there is an existing comment to check
|| ( $have_side_comment
&& $rOpts->{'closing-side-comment-warnings'} )
)
# .. and if this is one of the types of interest
&& $block_type_to_go[$i_terminal] =~
/$closing_side_comment_list_pattern/
# .. but not an anonymous sub
# These are not normally of interest, and their closing braces are
# often followed by commas or semicolons anyway. This also avoids
# possible erratic output due to line numbering inconsistencies
# in the cases where their closing braces terminate a line.
&& $block_type_to_go[$i_terminal] ne 'sub'
# ..and the corresponding opening brace must is not in this batch
# (because we do not need to tag one-line blocks, although this
# should also be caught with a positive -csci value)
&& $self->mate_index_to_go($i_terminal) < 0
# ..and either
&& (
# this is the last token (line doesn't have a side comment)
!$have_side_comment
# or the old side comment is a closing side comment
|| $tokens_to_go[$max_index_to_go] =~
/$closing_side_comment_prefix_pattern/
)
)
{
# then make the closing side comment text
if ($block_label) { $block_label .= " " }
my $token =
"$rOpts->{'closing-side-comment-prefix'} $block_label$block_type_to_go[$i_terminal]";
# append any extra descriptive text collected above
if ( $i_block_leading_text == $i_terminal ) {
$token .= $block_leading_text;
}
$token = balance_csc_text($token)
if $rOpts->{'closing-side-comments-balanced'};
$token =~ s/\s*$//; # trim any trailing whitespace
# handle case of existing closing side comment
if ($have_side_comment) {
# warn if requested and tokens differ significantly
if ( $rOpts->{'closing-side-comment-warnings'} ) {
my $old_csc = $tokens_to_go[$max_index_to_go];
my $new_csc = $token;
$new_csc =~ s/\s+//g; # trim all whitespace
$old_csc =~ s/\s+//g; # trim all whitespace
$new_csc =~ s/[\]\)\}\s]*$//; # trim trailing structures
$old_csc =~ s/[\]\)\}\s]*$//; # trim trailing structures
$new_csc =~ s/(\.\.\.)$//; # trim trailing '...'
my $new_trailing_dots = $1;
$old_csc =~ s/(\.\.\.)\s*$//; # trim trailing '...'
# Patch to handle multiple closing side comments at
# else and elsif's. These have become too complicated
# to check, so if we see an indication of
# '[ if' or '[ # elsif', then assume they were made
# by perltidy.
if ( $block_type_to_go[$i_terminal] eq 'else' ) {
if ( $old_csc =~ /\[\s*elsif/ ) { $old_csc = $new_csc }
}
elsif ( $block_type_to_go[$i_terminal] eq 'elsif' ) {
if ( $old_csc =~ /\[\s*if/ ) { $old_csc = $new_csc }
}
# if old comment is contained in new comment,
# only compare the common part.
if ( length($new_csc) > length($old_csc) ) {
$new_csc = substr( $new_csc, 0, length($old_csc) );
}
# if the new comment is shorter and has been limited,
# only compare the common part.
if ( length($new_csc) < length($old_csc)
&& $new_trailing_dots )
{
$old_csc = substr( $old_csc, 0, length($new_csc) );
}
# any remaining difference?
if ( $new_csc ne $old_csc ) {
# just leave the old comment if we are below the threshold
# for creating side comments
if ( $block_line_count <
$rOpts->{'closing-side-comment-interval'} )
{
$token = undef;
}
# otherwise we'll make a note of it
else {
warning(
"perltidy -cscw replaced: $tokens_to_go[$max_index_to_go]\n"
);
# save the old side comment in a new trailing block
# comment
my $timestamp = "";
if ( $rOpts->{'timestamp'} ) {
my ( $day, $month, $year ) = (localtime)[ 3, 4, 5 ];
$year += 1900;
$month += 1;
$timestamp = "$year-$month-$day";
}
$cscw_block_comment =
"## perltidy -cscw $timestamp: $tokens_to_go[$max_index_to_go]";
## "## perltidy -cscw $year-$month-$day: $tokens_to_go[$max_index_to_go]";
}
}
else {
# No differences.. we can safely delete old comment if we
# are below the threshold
if ( $block_line_count <
$rOpts->{'closing-side-comment-interval'} )
{
$token = undef;
$self->unstore_token_to_go()
if ( $types_to_go[$max_index_to_go] eq '#' );
$self->unstore_token_to_go()
if ( $types_to_go[$max_index_to_go] eq 'b' );
}
}
}
# switch to the new csc (unless we deleted it!)
if ($token) {
$tokens_to_go[$max_index_to_go] = $token;
my $K = $K_to_go[$max_index_to_go];
$rLL->[$K]->[_TOKEN_] = $token;
$rLL->[$K]->[_TOKEN_LENGTH_] =
length($token); # NOTE: length no longer important
}
}
# handle case of NO existing closing side comment
else {
# To avoid inserting a new token in the token arrays, we
# will just return the new side comment so that it can be
# inserted just before it is needed in the call to the
# vertical aligner.
$closing_side_comment = $token;
}
}
return ( $closing_side_comment, $cscw_block_comment );
}
sub previous_nonblank_token {
my ($i) = @_;
my $name = "";
my $im = $i - 1;
return "" if ( $im < 0 );
if ( $types_to_go[$im] eq 'b' ) { $im--; }
return "" if ( $im < 0 );
$name = $tokens_to_go[$im];
# prepend any sub name to an isolated -> to avoid unwanted alignments
# [test case is test8/penco.pl]
if ( $name eq '->' ) {
$im--;
if ( $im >= 0 && $types_to_go[$im] ne 'b' ) {
$name = $tokens_to_go[$im] . $name;
}
}
return $name;
}
sub send_lines_to_vertical_aligner {
my ( $self, $rbatch_hash ) = @_;
# This routine receives a batch of code for which the final line breaks
# have been defined. Here we prepare the lines for passing to the vertical
# aligner. We do the following tasks:
# - mark certain vertical alignment tokens tokens, such as '=', in each line
# - make minor indentation adjustments
# - insert extra blank spaces to help display certain logical constructions
my $rlines_K = $rbatch_hash->{rlines_K};
if ( !@{$rlines_K} ) {
Fault("Unexpected call with no lines");
return;
}
my $n_last_line = @{$rlines_K} - 1;
my $do_not_pad = $rbatch_hash->{do_not_pad};
my $rLL = $self->{rLL};
my $Klimit = $self->{Klimit};
my ( $Kbeg_next, $Kend_next ) = @{ $rlines_K->[0] };
my $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
my $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
my $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
# Construct indexes to the global_to_go arrays so that called routines can
# still access those arrays. This might eventually be removed
# when all called routines have been converted to access token values
# in the rLL array instead.
my $ibeg0 = $rbatch_hash->{ibeg0};
my $Kbeg0 = $Kbeg_next;
my ( $ri_first, $ri_last );
foreach my $rline ( @{$rlines_K} ) {
my ( $Kbeg, $Kend ) = @{$rline};
my $ibeg = $ibeg0 + $Kbeg - $Kbeg0;
my $iend = $ibeg0 + $Kend - $Kbeg0;
push @{$ri_first}, $ibeg;
push @{$ri_last}, $iend;
}
my $valign_batch_number = $self->increment_valign_batch_count();
my ( $cscw_block_comment, $closing_side_comment );
if ( $rOpts->{'closing-side-comments'} ) {
( $closing_side_comment, $cscw_block_comment ) =
$self->add_closing_side_comment();
}
my $rindentation_list = [0]; # ref to indentations for each line
# define the array @{$ralignment_type_to_go} for the output tokens
# which will be non-blank for each special token (such as =>)
# for which alignment is required.
my $ralignment_type_to_go =
$self->set_vertical_alignment_markers( $ri_first, $ri_last );
# flush before a long if statement to avoid unwanted alignment
if ( $n_last_line > 0
&& $type_beg_next eq 'k'
&& $token_beg_next =~ /^(if|unless)$/ )
{
Perl::Tidy::VerticalAligner::flush();
}
$self->undo_ci( $ri_first, $ri_last );
$self->set_logical_padding( $ri_first, $ri_last )
if ( $rOpts->{'logical-padding'} );
# loop to prepare each line for shipment
my $in_comma_list;
my ( $Kbeg, $type_beg, $token_beg );
my ( $Kend, $type_end );
for my $n ( 0 .. $n_last_line ) {
my $ibeg = $ri_first->[$n];
my $iend = $ri_last->[$n];
my $rline = $rlines_K->[$n];
my $forced_breakpoint = $rline->[2];
# we may need to look at variables on three consecutive lines ...
# Some vars on line [n-1], if any:
my $Kbeg_last = $Kbeg;
my $type_beg_last = $type_beg;
my $token_beg_last = $token_beg;
my $Kend_last = $Kend;
my $type_end_last = $type_end;
# Some vars on line [n]:
$Kbeg = $Kbeg_next;
$type_beg = $type_beg_next;
$token_beg = $token_beg_next;
$Kend = $Kend_next;
$type_end = $type_end_next;
# We use two slightly different definitions of level jump at the end
# of line:
# $ljump is the level jump needed by 'sub set_adjusted_indentation'
# $level_jump is the level jump needed by the vertical aligner.
my $ljump = 0; # level jump at end of line
# Get some vars on line [n+1], if any:
if ( $n < $n_last_line ) {
( $Kbeg_next, $Kend_next ) =
@{ $rlines_K->[ $n + 1 ] };
$type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
$token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
$type_end_next = $rLL->[$Kend_next]->[_TYPE_];
$ljump = $rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
}
# level jump at end of line for the vertical aligner:
my $level_jump =
$Kend >= $Klimit
? 0
: $rLL->[ $Kend + 1 ]->[_SLEVEL_] - $rLL->[$Kbeg]->[_SLEVEL_];
$self->delete_needless_alignments( $ibeg, $iend,
$ralignment_type_to_go );
my ( $rtokens, $rfields, $rpatterns, $rfield_lengths ) =
$self->make_alignment_patterns( $ibeg, $iend,
$ralignment_type_to_go );
my ( $indentation, $lev, $level_end, $terminal_type,
$is_semicolon_terminated, $is_outdented_line )
= $self->set_adjusted_indentation( $ibeg, $iend, $rfields, $rpatterns,
$ri_first, $ri_last, $rindentation_list, $ljump );
# we will allow outdenting of long lines..
my $outdent_long_lines = (
# which are long quotes, if allowed
( $type_beg eq 'Q' && $rOpts->{'outdent-long-quotes'} )
# which are long block comments, if allowed
|| (
$type_beg eq '#'
&& $rOpts->{'outdent-long-comments'}
# but not if this is a static block comment
&& !$is_static_block_comment
)
);
my $rvertical_tightness_flags =
$self->set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
$ri_first, $ri_last );
# flush an outdented line to avoid any unwanted vertical alignment
Perl::Tidy::VerticalAligner::flush() if ($is_outdented_line);
# Set a flag at the final ':' of a ternary chain to request
# vertical alignment of the final term. Here is a
# slightly complex example:
#
# $self->{_text} = (
# !$section ? ''
# : $type eq 'item' ? "the $section entry"
# : "the section on $section"
# )
# . (
# $page
# ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
# : ' elsewhere in this document'
# );
#
my $is_terminal_ternary = 0;
if ( $type_beg eq ':' || $n > 0 && $type_end_last eq ':' ) {
my $last_leading_type = $n > 0 ? $type_beg_last : ':';
if ( $terminal_type ne ';'
&& $n_last_line > $n
&& $level_end == $lev )
{
$level_end = $rLL->[$Kbeg_next]->[_LEVEL_];
$terminal_type = $rLL->[$Kbeg_next]->[_TYPE_];
}
if (
$last_leading_type eq ':'
&& ( ( $terminal_type eq ';' && $level_end <= $lev )
|| ( $terminal_type ne ':' && $level_end < $lev ) )
)
{
# the terminal term must not contain any ternary terms, as in
# my $ECHO = (
# $Is_MSWin32 ? ".\\echo$$"
# : $Is_MacOS ? ":echo$$"
# : ( $Is_NetWare ? "echo$$" : "./echo$$" )
# );
$is_terminal_ternary = 1;
my $KP = $rLL->[$Kbeg]->[_KNEXT_SEQ_ITEM_];
while ( defined($KP) && $KP <= $Kend ) {
my $type_KP = $rLL->[$KP]->[_TYPE_];
if ( $type_KP eq '?' || $type_KP eq ':' ) {
$is_terminal_ternary = 0;
last;
}
$KP = $rLL->[$KP]->[_KNEXT_SEQ_ITEM_];
}
}
}
# add any new closing side comment to the last line
if ( $closing_side_comment && $n == $n_last_line && @{$rfields} ) {
$rfields->[-1] .= " $closing_side_comment";
# NOTE: Patch for csc. We can just use 1 for the length of the csc
# because its length should not be a limiting factor from here on.
$rfield_lengths->[-1] += 2;
}
# send this new line down the pipe
my $rvalign_hash = {};
$rvalign_hash->{level} = $lev;
$rvalign_hash->{level_end} = $level_end;
$rvalign_hash->{indentation} = $indentation;
$rvalign_hash->{is_forced_break} = $forced_breakpoint || $in_comma_list;
$rvalign_hash->{outdent_long_lines} = $outdent_long_lines;
$rvalign_hash->{is_terminal_ternary} = $is_terminal_ternary;
$rvalign_hash->{is_terminal_statement} = $is_semicolon_terminated;
$rvalign_hash->{do_not_pad} = $do_not_pad;
$rvalign_hash->{rvertical_tightness_flags} = $rvertical_tightness_flags;
$rvalign_hash->{level_jump} = $level_jump;
$rvalign_hash->{rfields} = $rfields;
$rvalign_hash->{rpatterns} = $rpatterns;
$rvalign_hash->{rtokens} = $rtokens;
$rvalign_hash->{rfield_lengths} = $rfield_lengths;
$rvalign_hash->{valign_batch_number} = $valign_batch_number;
Perl::Tidy::VerticalAligner::valign_input($rvalign_hash);
$in_comma_list = $type_end eq ',' && $forced_breakpoint;
# flush an outdented line to avoid any unwanted vertical alignment
Perl::Tidy::VerticalAligner::flush() if ($is_outdented_line);
$do_not_pad = 0;
# Set flag indicating if this line ends in an opening
# token and is very short, so that a blank line is not
# needed if the subsequent line is a comment.
# Examples of what we are looking for:
# {
# && (
# BEGIN {
# default {
# sub {
$last_output_short_opening_token
# line ends in opening token
= $type_end =~ /^[\{\(\[L]$/
# and either
&& (
# line has either single opening token
$Kend == $Kbeg
# or is a single token followed by opening token.
# Note that sub identifiers have blanks like 'sub doit'
|| ( $Kend - $Kbeg <= 2 && $token_beg !~ /\s+/ )
)
# and limit total to 10 character widths
&& token_sequence_length( $ibeg, $iend ) <= 10;
} # end of loop to output each line
# remember indentation of lines containing opening containers for
# later use by sub set_adjusted_indentation
$self->save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
# output any new -cscw block comment
if ($cscw_block_comment) {
Perl::Tidy::VerticalAligner::flush();
$file_writer_object->write_code_line( $cscw_block_comment . "\n" );
}
return;
}
{ # begin make_alignment_patterns
my %block_type_map;
my %keyword_map;
my %operator_map;
BEGIN {
# map related block names into a common name to
# allow alignment
%block_type_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'if',
'default' => 'if',
'case' => 'if',
'sort' => 'map',
'grep' => 'map',
);
# map certain keywords to the same 'if' class to align
# long if/elsif sequences. [elsif.pl]
%keyword_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'given',
'default' => 'given',
'case' => 'switch',
# treat an 'undef' similar to numbers and quotes
'undef' => 'Q',
);
# map certain operators to the same class for pattern matching
%operator_map = (
'!~' => '=~',
'+=' => '+=',
'-=' => '+=',
'*=' => '+=',
'/=' => '+=',
);
}
sub delete_needless_alignments {
my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
# Remove unwanted alignments. This routine is a place to remove
# alignments which might cause problems at later stages. There are
# currently two types of fixes:
# 1. Remove excess parens
# 2. Remove alignments within 'elsif' conditions
# Patch #1: Excess alignment of parens can prevent other good
# alignments. For example, note the parens in the first two rows of
# the following snippet. They would normally get marked for alignment
# and aligned as follows:
# my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
# my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
# my $img = new Gimp::Image( $w, $h, RGB );
# This causes unnecessary paren alignment and prevents the third equals
# from aligning. If we remove the unwanted alignments we get:
# my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
# my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
# my $img = new Gimp::Image( $w, $h, RGB );
# A rule for doing this which works well is to remove alignment of
# parens whose containers do not contain other aligning tokens, with
# the exception that we always keep alignment of the first opening
# paren on a line (for things like 'if' and 'elsif' statements).
# Setup needed constants
my $i_good_paren = -1;
my $imin_match = $iend + 1;
my $i_elsif_close = $ibeg - 1;
my $i_elsif_open = $iend + 1;
if ( $iend > $ibeg ) {
if ( $types_to_go[$ibeg] eq 'k' ) {
# Paren patch: mark a location of a paren we should keep, such
# as one following something like a leading 'if', 'elsif',..
$i_good_paren = $ibeg + 1;
if ( $types_to_go[$i_good_paren] eq 'b' ) {
$i_good_paren++;
}
# 'elsif' patch: remember the range of the parens of an elsif,
# and do not make alignments within them because this can cause
# loss of padding and overall brace alignment in the vertical
# aligner.
if ( $tokens_to_go[$ibeg] eq 'elsif'
&& $i_good_paren < $iend
&& $tokens_to_go[$i_good_paren] eq '(' )
{
$i_elsif_open = $i_good_paren;
$i_elsif_close = $self->mate_index_to_go($i_good_paren);
}
}
}
# Loop to make the fixes on this line
my @imatch_list;
for my $i ( $ibeg .. $iend ) {
if ( $ralignment_type_to_go->[$i] ne '' ) {
# Patch #2: undo alignment within elsif parens
if ( $i > $i_elsif_open && $i < $i_elsif_close ) {
$ralignment_type_to_go->[$i] = '';
next;
}
push @imatch_list, $i;
}
if ( $tokens_to_go[$i] eq ')' ) {
# Patch #1: undo the corresponding opening paren if:
# - it is at the top of the stack
# - and not the first overall opening paren
# - does not follow a leading keyword on this line
my $imate = $self->mate_index_to_go($i);
if ( @imatch_list
&& $imatch_list[-1] eq $imate
&& ( $ibeg > 1 || @imatch_list > 1 )
&& $imate > $i_good_paren )
{
$ralignment_type_to_go->[$imate] = '';
pop @imatch_list;
}
}
}
return;
}
my $field_length_sum = sub {
my ( $i1, $i2 ) = @_;
my $len_field = 0;
foreach ( $i1 .. $i2 ) {
$len_field += $token_lengths_to_go[$_];
}
return $len_field;
};
sub make_alignment_patterns {
# Here we do some important preliminary work for the
# vertical aligner. We create three arrays for one
# output line. These arrays contain strings that can
# be tested by the vertical aligner to see if
# consecutive lines can be aligned vertically.
#
# The three arrays are indexed on the vertical
# alignment fields and are:
# @tokens - a list of any vertical alignment tokens for this line.
# These are tokens, such as '=' '&&' '#' etc which
# we want to might align vertically. These are
# decorated with various information such as
# nesting depth to prevent unwanted vertical
# alignment matches.
# @fields - the actual text of the line between the vertical alignment
# tokens.
# @patterns - a modified list of token types, one for each alignment
# field. These should normally each match before alignment is
# allowed, even when the alignment tokens match.
my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
my @tokens = ();
my @fields = ();
my @patterns = ();
my @field_lengths = ();
my $i_start = $ibeg;
my $depth = 0;
my @container_name = ("");
my @multiple_comma_arrows = (undef);
my $j = 0; # field index
$patterns[0] = "";
my %token_count;
for my $i ( $ibeg .. $iend ) {
# Keep track of containers balanced on this line only.
# These are used below to prevent unwanted cross-line alignments.
# Unbalanced containers already avoid aligning across
# container boundaries.
my $tok = $tokens_to_go[$i];
if ( $tok =~ /^[\(\{\[]/ ) { #'(' ) {
# if container is balanced on this line...
my $i_mate = $self->mate_index_to_go($i);
if ( $i_mate > $i && $i_mate <= $iend ) {
$depth++;
my $seqno = $type_sequence_to_go[$i];
my $count = comma_arrow_count($seqno);
$multiple_comma_arrows[$depth] = $count && $count > 1;
# Append the previous token name to make the container name
# more unique. This name will also be given to any commas
# within this container, and it helps avoid undesirable
# alignments of different types of containers.
# Containers beginning with { and [ are given those names
# for uniqueness. That way commas in different containers
# will not match. Here is an example of what this prevents:
# a => [ 1, 2, 3 ],
# b => { b1 => 4, b2 => 5 },
# Here is another example of what we avoid by labeling the
# commas properly:
# is_d( [ $a, $a ], [ $b, $c ] );
# is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
# is_d( [ \$a, \$a ], [ \$b, \$c ] );
my $name = $tok;
if ( $tok eq '(' ) {
$name = previous_nonblank_token($i);
$name =~ s/^->//;
}
$container_name[$depth] = "+" . $name;
# Make the container name even more unique if necessary.
# If we are not vertically aligning this opening paren,
# append a character count to avoid bad alignment because
# it usually looks bad to align commas within containers
# for which the opening parens do not align. Here
# is an example very BAD alignment of commas (because
# the atan2 functions are not all aligned):
# $XY =
# $X * $RTYSQP1 * atan2( $X, $RTYSQP1 ) +
# $Y * $RTXSQP1 * atan2( $Y, $RTXSQP1 ) -
# $X * atan2( $X, 1 ) -
# $Y * atan2( $Y, 1 );
#
# On the other hand, it is usually okay to align commas if
# opening parens align, such as:
# glVertex3d( $cx + $s * $xs, $cy, $z );
# glVertex3d( $cx, $cy + $s * $ys, $z );
# glVertex3d( $cx - $s * $xs, $cy, $z );
# glVertex3d( $cx, $cy - $s * $ys, $z );
#
# To distinguish between these situations, we will
# append the length of the line from the previous matching
# token, or beginning of line, to the function name. This
# will allow the vertical aligner to reject undesirable
# matches.
# if we are not aligning on this paren...
if ( $ralignment_type_to_go->[$i] eq '' ) {
# Sum length from previous alignment
my $len = token_sequence_length( $i_start, $i - 1 );
if ( $i_start == $ibeg ) {
# For first token, use distance from start of line
# but subtract off the indentation due to level.
# Otherwise, results could vary with indentation.
$len += leading_spaces_to_go($ibeg) -
$levels_to_go[$i_start] * $rOpts_indent_columns;
if ( $len < 0 ) { $len = 0 }
}
# tack this length onto the container name to try
# to make a unique token name
$container_name[$depth] .= "-" . $len;
}
}
}
elsif ( $tokens_to_go[$i] =~ /^[\)\}\]]/ ) {
$depth-- if $depth > 0;
}
# if we find a new synchronization token, we are done with
# a field
if ( $i > $i_start && $ralignment_type_to_go->[$i] ne '' ) {
my $tok = my $raw_tok = $ralignment_type_to_go->[$i];
# map similar items
my $tok_map = $operator_map{$tok};
$tok = $tok_map if ($tok_map);
# make separators in different nesting depths unique
# by appending the nesting depth digit.
if ( $raw_tok ne '#' ) {
$tok .= "$nesting_depth_to_go[$i]";
}
# also decorate commas with any container name to avoid
# unwanted cross-line alignments.
if ( $raw_tok eq ',' || $raw_tok eq '=>' ) {
if ( $container_name[$depth] ) {
$tok .= $container_name[$depth];
}
}
# Patch to avoid aligning leading and trailing if, unless.
# Mark trailing if, unless statements with container names.
# This makes them different from leading if, unless which
# are not so marked at present. If we ever need to name
# them too, we could use ci to distinguish them.
# Example problem to avoid:
# return ( 2, "DBERROR" )
# if ( $retval == 2 );
# if ( scalar @_ ) {
# my ( $a, $b, $c, $d, $e, $f ) = @_;
# }
if ( $raw_tok eq '(' ) {
my $ci = $ci_levels_to_go[$ibeg];
if ( $container_name[$depth] =~ /^\+(if|unless)/
&& $ci )
{
$tok .= $container_name[$depth];
}
}
# Decorate block braces with block types to avoid
# unwanted alignments such as the following:
# foreach ( @{$routput_array} ) { $fh->print($_) }
# eval { $fh->close() };
if ( $raw_tok eq '{' && $block_type_to_go[$i] ) {
my $block_type = $block_type_to_go[$i];
# map certain related block types to allow
# else blocks to align
$block_type = $block_type_map{$block_type}
if ( defined( $block_type_map{$block_type} ) );
# remove sub names to allow one-line sub braces to align
# regardless of name
#if ( $block_type =~ /^sub / ) { $block_type = 'sub' }
if ( $block_type =~ /$SUB_PATTERN/ ) { $block_type = 'sub' }
# allow all control-type blocks to align
if ( $block_type =~ /^[A-Z]+$/ ) { $block_type = 'BEGIN' }
$tok .= $block_type;
}
# Mark multiple copies of certain tokens with the copy number
# This will allow the aligner to decide if they are matched.
# For now, only do this for equals. For example, the two
# equals on the next line will be labeled '=0' and '=0.2'.
# Later, the '=0.2' will be ignored in alignment because it
# has no match.
# $| = $debug = 1 if $opt_d;
# $full_index = 1 if $opt_i;
if ( $raw_tok eq '=' || $raw_tok eq '=>' ) {
$token_count{$tok}++;
if ( $token_count{$tok} > 1 ) {
$tok .= '.' . $token_count{$tok};
}
}
# concatenate the text of the consecutive tokens to form
# the field
push( @fields,
join( '', @tokens_to_go[ $i_start .. $i - 1 ] ) );
push @field_lengths, $field_length_sum->( $i_start, $i - 1 );
# store the alignment token for this field
push( @tokens, $tok );
# get ready for the next batch
$i_start = $i;
$j++;
$patterns[$j] = "";
}
# continue accumulating tokens
# handle non-keywords..
if ( $types_to_go[$i] ne 'k' ) {
my $type = $types_to_go[$i];
# Mark most things before arrows as a quote to
# get them to line up. Testfile: mixed.pl.
if ( ( $i < $iend - 1 ) && ( $type =~ /^[wnC]$/ ) ) {
my $next_type = $types_to_go[ $i + 1 ];
my $i_next_nonblank =
( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
if ( $types_to_go[$i_next_nonblank] eq '=>' ) {
$type = 'Q';
# Patch to ignore leading minus before words,
# by changing pattern 'mQ' into just 'Q',
# so that we can align things like this:
# Button => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
if ( $patterns[$j] eq 'm' ) { $patterns[$j] = "" }
}
}
# Convert a bareword within braces into a quote for matching. This will
# allow alignment of expressions like this:
# local ( $SIG{'INT'} ) = IGNORE;
# local ( $SIG{ALRM} ) = 'POSTMAN';
if ( $type eq 'w'
&& $i > $ibeg
&& $i < $iend
&& $types_to_go[ $i - 1 ] eq 'L'
&& $types_to_go[ $i + 1 ] eq 'R' )
{
$type = 'Q';
}
# patch to make numbers and quotes align
if ( $type eq 'n' ) { $type = 'Q' }
# patch to ignore any ! in patterns
if ( $type eq '!' ) { $type = '' }
$patterns[$j] .= $type;
}
# for keywords we have to use the actual text
else {
my $tok = $tokens_to_go[$i];
# but map certain keywords to a common string to allow
# alignment.
$tok = $keyword_map{$tok}
if ( defined( $keyword_map{$tok} ) );
$patterns[$j] .= $tok;
}
}
# done with this line .. join text of tokens to make the last field
push( @fields, join( '', @tokens_to_go[ $i_start .. $iend ] ) );
push @field_lengths, $field_length_sum->( $i_start, $iend );
return ( \@tokens, \@fields, \@patterns, \@field_lengths );
}
} # end make_alignment_patterns
{ # begin unmatched_indexes
# closure to keep track of unbalanced containers.
# arrays shared by the routines in this block:
my @unmatched_opening_indexes_in_this_batch;
my @unmatched_closing_indexes_in_this_batch;
my %comma_arrow_count;
sub is_unbalanced_batch {
return @unmatched_opening_indexes_in_this_batch +
@unmatched_closing_indexes_in_this_batch;
}
sub comma_arrow_count {
my $seqno = shift;
return $comma_arrow_count{$seqno};
}
sub match_opening_and_closing_tokens {
# Match up indexes of opening and closing braces, etc, in this batch.
# This has to be done after all tokens are stored because unstoring
# of tokens would otherwise cause trouble.
@unmatched_opening_indexes_in_this_batch = ();
@unmatched_closing_indexes_in_this_batch = ();
%comma_arrow_count = ();
my $comma_arrow_count_contained = 0;
foreach my $i ( 0 .. $max_index_to_go ) {
if ( $type_sequence_to_go[$i] ) {
my $token = $tokens_to_go[$i];
if ( $token =~ /^[\(\[\{\?]$/ ) {
push @unmatched_opening_indexes_in_this_batch, $i;
}
elsif ( $token =~ /^[\)\]\}\:]$/ ) {
my $i_mate = pop @unmatched_opening_indexes_in_this_batch;
if ( defined($i_mate) && $i_mate >= 0 ) {
if ( $type_sequence_to_go[$i_mate] ==
$type_sequence_to_go[$i] )
{
$mate_index_to_go[$i] = $i_mate;
$mate_index_to_go[$i_mate] = $i;
my $seqno = $type_sequence_to_go[$i];
if ( $comma_arrow_count{$seqno} ) {
$comma_arrow_count_contained +=
$comma_arrow_count{$seqno};
}
}
else {
push @unmatched_opening_indexes_in_this_batch,
$i_mate;
push @unmatched_closing_indexes_in_this_batch, $i;
}
}
else {
push @unmatched_closing_indexes_in_this_batch, $i;
}
}
}
elsif ( $tokens_to_go[$i] eq '=>' ) {
if (@unmatched_opening_indexes_in_this_batch) {
my $j = $unmatched_opening_indexes_in_this_batch[-1];
my $seqno = $type_sequence_to_go[$j];
$comma_arrow_count{$seqno}++;
}
}
}
return $comma_arrow_count_contained;
}
sub save_opening_indentation {
# This should be called after each batch of tokens is output. It
# saves indentations of lines of all unmatched opening tokens.
# These will be used by sub get_opening_indentation.
my ( $self, $ri_first, $ri_last, $rindentation_list ) = @_;
# we no longer need indentations of any saved indentations which
# are unmatched closing tokens in this batch, because we will
# never encounter them again. So we can delete them to keep
# the hash size down.
foreach (@unmatched_closing_indexes_in_this_batch) {
my $seqno = $type_sequence_to_go[$_];
delete $saved_opening_indentation{$seqno};
}
# we need to save indentations of any unmatched opening tokens
# in this batch because we may need them in a subsequent batch.
foreach (@unmatched_opening_indexes_in_this_batch) {
my $seqno = $type_sequence_to_go[$_];
$saved_opening_indentation{$seqno} = [
lookup_opening_indentation(
$_, $ri_first, $ri_last, $rindentation_list
)
];
}
return;
}
} # end unmatched_indexes
sub get_opening_indentation {
# get the indentation of the line which output the opening token
# corresponding to a given closing token in the current output batch.
#
# given:
# $i_closing - index in this line of a closing token ')' '}' or ']'
#
# $ri_first - reference to list of the first index $i for each output
# line in this batch
# $ri_last - reference to list of the last index $i for each output line
# in this batch
# $rindentation_list - reference to a list containing the indentation
# used for each line.
#
# return:
# -the indentation of the line which contained the opening token
# which matches the token at index $i_opening
# -and its offset (number of columns) from the start of the line
#
my ( $self, $i_closing, $ri_first, $ri_last, $rindentation_list ) = @_;
# first, see if the opening token is in the current batch
my $i_opening = $mate_index_to_go[$i_closing];
my ( $indent, $offset, $is_leading, $exists );
$exists = 1;
if ( $i_opening >= 0 ) {
# it is..look up the indentation
( $indent, $offset, $is_leading ) =
lookup_opening_indentation( $i_opening, $ri_first, $ri_last,
$rindentation_list );
}
# if not, it should have been stored in the hash by a previous batch
else {
my $seqno = $type_sequence_to_go[$i_closing];
if ($seqno) {
if ( $saved_opening_indentation{$seqno} ) {
( $indent, $offset, $is_leading ) =
@{ $saved_opening_indentation{$seqno} };
}
# some kind of serious error
# (example is badfile.t)
else {
$indent = 0;
$offset = 0;
$is_leading = 0;
$exists = 0;
}
}
# if no sequence number it must be an unbalanced container
else {
$indent = 0;
$offset = 0;
$is_leading = 0;
$exists = 0;
}
}
return ( $indent, $offset, $is_leading, $exists );
}
sub lookup_opening_indentation {
# get the indentation of the line in the current output batch
# which output a selected opening token
#
# given:
# $i_opening - index of an opening token in the current output batch
# whose line indentation we need
# $ri_first - reference to list of the first index $i for each output
# line in this batch
# $ri_last - reference to list of the last index $i for each output line
# in this batch
# $rindentation_list - reference to a list containing the indentation
# used for each line. (NOTE: the first slot in
# this list is the last returned line number, and this is
# followed by the list of indentations).
#
# return
# -the indentation of the line which contained token $i_opening
# -and its offset (number of columns) from the start of the line
my ( $i_opening, $ri_start, $ri_last, $rindentation_list ) = @_;
if ( !@{$ri_last} ) {
warning("Error in opening_indentation: no lines");
return;
}
my $nline = $rindentation_list->[0]; # line number of previous lookup
# reset line location if necessary
$nline = 0 if ( $i_opening < $ri_start->[$nline] );
# find the correct line
unless ( $i_opening > $ri_last->[-1] ) {
while ( $i_opening > $ri_last->[$nline] ) { $nline++; }
}
# error - token index is out of bounds - shouldn't happen
else {
warning(
"non-fatal program bug in lookup_opening_indentation - index out of range\n"
);
report_definite_bug();
$nline = $#{$ri_last};
}
$rindentation_list->[0] =
$nline; # save line number to start looking next call
my $ibeg = $ri_start->[$nline];
my $offset = token_sequence_length( $ibeg, $i_opening ) - 1;
my $is_leading = ( $ibeg == $i_opening );
return ( $rindentation_list->[ $nline + 1 ], $offset, $is_leading );
}
{
my %is_if_elsif_else_unless_while_until_for_foreach;
BEGIN {
# These block types may have text between the keyword and opening
# curly. Note: 'else' does not, but must be included to allow trailing
# if/elsif text to be appended.
# patch for SWITCH/CASE: added 'case' and 'when'
my @q = qw(if elsif else unless while until for foreach case when);
@is_if_elsif_else_unless_while_until_for_foreach{@q} =
(1) x scalar(@q);
}
sub set_adjusted_indentation {
# This routine has the final say regarding the actual indentation of
# a line. It starts with the basic indentation which has been
# defined for the leading token, and then takes into account any
# options that the user has set regarding special indenting and
# outdenting.
my (
$self, $ibeg, $iend,
$rfields, $rpatterns, $ri_first,
$ri_last, $rindentation_list, $level_jump
) = @_;
my $rLL = $self->{rLL};
# we need to know the last token of this line
my ( $terminal_type, $i_terminal ) =
$self->terminal_type_i( $ibeg, $iend );
my $is_outdented_line = 0;
my $is_semicolon_terminated = $terminal_type eq ';'
&& $nesting_depth_to_go[$iend] < $nesting_depth_to_go[$ibeg];
# NOTE: A future improvement would be to make it semicolon terminated
# even if it does not have a semicolon but is followed by a closing
# block brace. This would undo ci even for something like the
# following, in which the final paren does not have a semicolon because
# it is a possible weld location:
# if ($BOLD_MATH) {
# (
# $labels, $comment,
# join( '', '<B>', &make_math( $mode, '', '', $_ ), '</B>' )
# )
# }
#
# MOJO: Set a flag if this lines begins with ')->'
my $leading_paren_arrow = (
$types_to_go[$ibeg] eq '}'
&& $tokens_to_go[$ibeg] eq ')'
&& (
( $ibeg < $i_terminal && $types_to_go[ $ibeg + 1 ] eq '->' )
|| ( $ibeg < $i_terminal - 1
&& $types_to_go[ $ibeg + 1 ] eq 'b'
&& $types_to_go[ $ibeg + 2 ] eq '->' )
)
);
##########################################################
# Section 1: set a flag and a default indentation
#
# Most lines are indented according to the initial token.
# But it is common to outdent to the level just after the
# terminal token in certain cases...
# adjust_indentation flag:
# 0 - do not adjust
# 1 - outdent
# 2 - vertically align with opening token
# 3 - indent
##########################################################
my $adjust_indentation = 0;
my $default_adjust_indentation = $adjust_indentation;
my (
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
);
my $type_beg = $types_to_go[$ibeg];
my $token_beg = $tokens_to_go[$ibeg];
my $K_beg = $K_to_go[$ibeg];
my $ibeg_weld_fix = $ibeg;
# QW PATCH 2 (Testing)
# At an isolated closing token of a qw quote which is welded to
# a following closing token, we will locally change its type to
# be the same as its token. This will allow formatting to be the
# same as for an ordinary closing token.
# For -lp formatting se use $ibeg_weld_fix to get around the problem
# that with -lp type formatting the opening and closing tokens to not
# have sequence numbers.
if ( $type_beg eq 'q' && $token_beg =~ /^[\)\}\]\>]/ ) {
my $K_next_nonblank = $self->K_next_code($K_beg);
if ( defined($K_next_nonblank) ) {
my $type_sequence = $rLL->[$K_next_nonblank]->[_TYPE_SEQUENCE_];
my $token = $rLL->[$K_next_nonblank]->[_TOKEN_];
my $welded = weld_len_left( $type_sequence, $token );
if ($welded) {
$ibeg_weld_fix = $ibeg + ( $K_next_nonblank - $K_beg );
$type_beg = ')'; ##$token_beg;
}
}
}
# if we are at a closing token of some type..
if ( $type_beg =~ /^[\)\}\]R]$/ ) {
# get the indentation of the line containing the corresponding
# opening token
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg_weld_fix, $ri_first,
$ri_last, $rindentation_list );
# First set the default behavior:
if (
# default behavior is to outdent closing lines
# of the form: "); }; ]; )->xxx;"
$is_semicolon_terminated
# and 'cuddled parens' of the form: ")->pack("
# Bug fix for RT #123749]: the types here were
# incorrectly '(' and ')'. Corrected to be '{' and '}'
|| (
$terminal_type eq '{'
&& $type_beg eq '}'
&& ( $nesting_depth_to_go[$iend] + 1 ==
$nesting_depth_to_go[$ibeg] )
)
# remove continuation indentation for any line like
# } ... {
# or without ending '{' and unbalanced, such as
# such as '}->{$operator}'
|| (
$type_beg eq '}'
&& ( $types_to_go[$iend] eq '{'
|| $levels_to_go[$iend] < $levels_to_go[$ibeg] )
)
# and when the next line is at a lower indentation level
# PATCH: and only if the style allows undoing continuation
# for all closing token types. We should really wait until
# the indentation of the next line is known and then make
# a decision, but that would require another pass.
|| ( $level_jump < 0 && !$some_closing_token_indentation )
# Patch for -wn=2, multiple welded closing tokens
|| ( $i_terminal > $ibeg
&& $types_to_go[$iend] =~ /^[\)\}\]R]$/ )
)
{
$adjust_indentation = 1;
}
# outdent something like '),'
if (
$terminal_type eq ','
# Removed this constraint for -wn
# OLD: allow just one character before the comma
# && $i_terminal == $ibeg + 1
# require LIST environment; otherwise, we may outdent too much -
# this can happen in calls without parentheses (overload.t);
&& $container_environment_to_go[$i_terminal] eq 'LIST'
)
{
$adjust_indentation = 1;
}
# undo continuation indentation of a terminal closing token if
# it is the last token before a level decrease. This will allow
# a closing token to line up with its opening counterpart, and
# avoids an indentation jump larger than 1 level.
if ( $types_to_go[$i_terminal] =~ /^[\}\]\)R]$/
&& $i_terminal == $ibeg
&& defined($K_beg) )
{
my $K_next_nonblank = $self->K_next_code($K_beg);
# Patch for RT#131115: honor -bli flag at closing brace
my $is_bli =
$rOpts->{'brace-left-and-indent'}
&& $block_type_to_go[$i_terminal]
&& $block_type_to_go[$i_terminal] =~ /$bli_pattern/;
if ( !$is_bli && defined($K_next_nonblank) ) {
my $lev = $rLL->[$K_beg]->[_LEVEL_];
my $level_next = $rLL->[$K_next_nonblank]->[_LEVEL_];
$adjust_indentation = 1 if ( $level_next < $lev );
}
# Patch for RT #96101, in which closing brace of anonymous subs
# was not outdented. We should look ahead and see if there is
# a level decrease at the next token (i.e., a closing token),
# but right now we do not have that information. For now
# we see if we are in a list, and this works well.
# See test files 'sub*.t' for good test cases.
if ( $block_type_to_go[$ibeg] =~ /$ASUB_PATTERN/
&& $container_environment_to_go[$i_terminal] eq 'LIST'
&& !$rOpts->{'indent-closing-brace'} )
{
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first,
$ri_last, $rindentation_list );
my $indentation = $leading_spaces_to_go[$ibeg];
if ( defined($opening_indentation)
&& get_spaces($indentation) >
get_spaces($opening_indentation) )
{
$adjust_indentation = 1;
}
}
}
# YVES patch 1 of 2:
# Undo ci of line with leading closing eval brace,
# but not beyond the indention of the line with
# the opening brace.
if ( $block_type_to_go[$ibeg] eq 'eval'
&& !$rOpts->{'line-up-parentheses'}
&& !$rOpts->{'indent-closing-brace'} )
{
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
my $indentation = $leading_spaces_to_go[$ibeg];
if ( defined($opening_indentation)
&& get_spaces($indentation) >
get_spaces($opening_indentation) )
{
$adjust_indentation = 1;
}
}
$default_adjust_indentation = $adjust_indentation;
# Now modify default behavior according to user request:
# handle option to indent non-blocks of the form ); }; ];
# But don't do special indentation to something like ')->pack('
if ( !$block_type_to_go[$ibeg] ) {
my $cti = $closing_token_indentation{ $tokens_to_go[$ibeg] };
if ( $cti == 1 ) {
if ( $i_terminal <= $ibeg + 1
|| $is_semicolon_terminated )
{
$adjust_indentation = 2;
}
else {
$adjust_indentation = 0;
}
}
elsif ( $cti == 2 ) {
if ($is_semicolon_terminated) {
$adjust_indentation = 3;
}
else {
$adjust_indentation = 0;
}
}
elsif ( $cti == 3 ) {
$adjust_indentation = 3;
}
}
# handle option to indent blocks
else {
if (
$rOpts->{'indent-closing-brace'}
&& (
$i_terminal == $ibeg # isolated terminal '}'
|| $is_semicolon_terminated
)
) # } xxxx ;
{
$adjust_indentation = 3;
}
}
}
# if at ');', '};', '>;', and '];' of a terminal qw quote
elsif ($rpatterns->[0] =~ /^qb*;$/
&& $rfields->[0] =~ /^([\)\}\]\>]);$/ )
{
if ( $closing_token_indentation{$1} == 0 ) {
$adjust_indentation = 1;
}
else {
$adjust_indentation = 3;
}
}
# if line begins with a ':', align it with any
# previous line leading with corresponding ?
elsif ( $types_to_go[$ibeg] eq ':' ) {
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
if ($is_leading) { $adjust_indentation = 2; }
}
##########################################################
# Section 2: set indentation according to flag set above
#
# Select the indentation object to define leading
# whitespace. If we are outdenting something like '} } );'
# then we want to use one level below the last token
# ($i_terminal) in order to get it to fully outdent through
# all levels.
##########################################################
my $indentation;
my $lev;
my $level_end = $levels_to_go[$iend];
if ( $adjust_indentation == 0 ) {
$indentation = $leading_spaces_to_go[$ibeg];
$lev = $levels_to_go[$ibeg];
}
elsif ( $adjust_indentation == 1 ) {
# Change the indentation to be that of a different token on the line
# Previously, the indentation of the terminal token was used:
# OLD CODING:
# $indentation = $reduced_spaces_to_go[$i_terminal];
# $lev = $levels_to_go[$i_terminal];
# Generalization for MOJO:
# Use the lowest level indentation of the tokens on the line.
# For example, here we can use the indentation of the ending ';':
# } until ($selection > 0 and $selection < 10); # ok to use ';'
# But this will not outdent if we use the terminal indentation:
# )->then( sub { # use indentation of the ->, not the {
# Warning: reduced_spaces_to_go[] may be a reference, do not
# do numerical checks with it
my $i_ind = $ibeg;
$indentation = $reduced_spaces_to_go[$i_ind];
$lev = $levels_to_go[$i_ind];
while ( $i_ind < $i_terminal ) {
$i_ind++;
if ( $levels_to_go[$i_ind] < $lev ) {
$indentation = $reduced_spaces_to_go[$i_ind];
$lev = $levels_to_go[$i_ind];
}
}
}
# handle indented closing token which aligns with opening token
elsif ( $adjust_indentation == 2 ) {
# handle option to align closing token with opening token
$lev = $levels_to_go[$ibeg];
# calculate spaces needed to align with opening token
my $space_count =
get_spaces($opening_indentation) + $opening_offset;
# Indent less than the previous line.
#
# Problem: For -lp we don't exactly know what it was if there
# were recoverable spaces sent to the aligner. A good solution
# would be to force a flush of the vertical alignment buffer, so
# that we would know. For now, this rule is used for -lp:
#
# When the last line did not start with a closing token we will
# be optimistic that the aligner will recover everything wanted.
#
# This rule will prevent us from breaking a hierarchy of closing
# tokens, and in a worst case will leave a closing paren too far
# indented, but this is better than frequently leaving it not
# indented enough.
my $last_spaces = get_spaces($last_indentation_written);
if ( $last_leading_token !~ /^[\}\]\)]$/ ) {
$last_spaces +=
get_recoverable_spaces($last_indentation_written);
}
# reset the indentation to the new space count if it works
# only options are all or none: nothing in-between looks good
$lev = $levels_to_go[$ibeg];
if ( $space_count < $last_spaces ) {
if ($rOpts_line_up_parentheses) {
my $lev = $levels_to_go[$ibeg];
$indentation =
new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
}
else {
$indentation = $space_count;
}
}
# revert to default if it doesn't work
else {
$space_count = leading_spaces_to_go($ibeg);
if ( $default_adjust_indentation == 0 ) {
$indentation = $leading_spaces_to_go[$ibeg];
}
elsif ( $default_adjust_indentation == 1 ) {
$indentation = $reduced_spaces_to_go[$i_terminal];
$lev = $levels_to_go[$i_terminal];
}
}
}
# Full indentaion of closing tokens (-icb and -icp or -cti=2)
else {
# handle -icb (indented closing code block braces)
# Updated method for indented block braces: indent one full level if
# there is no continuation indentation. This will occur for major
# structures such as sub, if, else, but not for things like map
# blocks.
#
# Note: only code blocks without continuation indentation are
# handled here (if, else, unless, ..). In the following snippet,
# the terminal brace of the sort block will have continuation
# indentation as shown so it will not be handled by the coding
# here. We would have to undo the continuation indentation to do
# this, but it probably looks ok as is. This is a possible future
# update for semicolon terminated lines.
#
# if ($sortby eq 'date' or $sortby eq 'size') {
# @files = sort {
# $file_data{$a}{$sortby} <=> $file_data{$b}{$sortby}
# or $a cmp $b
# } @files;
# }
#
if ( $block_type_to_go[$ibeg]
&& $ci_levels_to_go[$i_terminal] == 0 )
{
my $spaces = get_spaces( $leading_spaces_to_go[$i_terminal] );
$indentation = $spaces + $rOpts_indent_columns;
# NOTE: for -lp we could create a new indentation object, but
# there is probably no need to do it
}
# handle -icp and any -icb block braces which fall through above
# test such as the 'sort' block mentioned above.
else {
# There are currently two ways to handle -icp...
# One way is to use the indentation of the previous line:
# $indentation = $last_indentation_written;
# The other way is to use the indentation that the previous line
# would have had if it hadn't been adjusted:
$indentation = $last_unadjusted_indentation;
# Current method: use the minimum of the two. This avoids
# inconsistent indentation.
if ( get_spaces($last_indentation_written) <
get_spaces($indentation) )
{
$indentation = $last_indentation_written;
}
}
# use previous indentation but use own level
# to cause list to be flushed properly
$lev = $levels_to_go[$ibeg];
}
# remember indentation except for multi-line quotes, which get
# no indentation
unless ( $ibeg == 0 && $starting_in_quote ) {
$last_indentation_written = $indentation;
$last_unadjusted_indentation = $leading_spaces_to_go[$ibeg];
$last_leading_token = $tokens_to_go[$ibeg];
}
# be sure lines with leading closing tokens are not outdented more
# than the line which contained the corresponding opening token.
#############################################################
# updated per bug report in alex_bug.pl: we must not
# mess with the indentation of closing logical braces so
# we must treat something like '} else {' as if it were
# an isolated brace
#############################################################
my $is_isolated_block_brace = $block_type_to_go[$ibeg]
&& ( $i_terminal == $ibeg
|| $is_if_elsif_else_unless_while_until_for_foreach{
$block_type_to_go[$ibeg] } );
# only do this for a ':; which is aligned with its leading '?'
my $is_unaligned_colon = $types_to_go[$ibeg] eq ':' && !$is_leading;
if (
defined($opening_indentation)
&& !$leading_paren_arrow # MOJO
&& !$is_isolated_block_brace
&& !$is_unaligned_colon
)
{
if ( get_spaces($opening_indentation) > get_spaces($indentation) ) {
$indentation = $opening_indentation;
}
}
# remember the indentation of each line of this batch
push @{$rindentation_list}, $indentation;
# outdent lines with certain leading tokens...
if (
# must be first word of this batch
$ibeg == 0
# and ...
&& (
# certain leading keywords if requested
(
$rOpts->{'outdent-keywords'}
&& $types_to_go[$ibeg] eq 'k'
&& $outdent_keyword{ $tokens_to_go[$ibeg] }
)
# or labels if requested
|| ( $rOpts->{'outdent-labels'} && $types_to_go[$ibeg] eq 'J' )
# or static block comments if requested
|| ( $types_to_go[$ibeg] eq '#'
&& $rOpts->{'outdent-static-block-comments'}
&& $is_static_block_comment )
)
)
{
my $space_count = leading_spaces_to_go($ibeg);
if ( $space_count > 0 ) {
$space_count -= $rOpts_continuation_indentation;
$is_outdented_line = 1;
if ( $space_count < 0 ) { $space_count = 0 }
# do not promote a spaced static block comment to non-spaced;
# this is not normally necessary but could be for some
# unusual user inputs (such as -ci = -i)
if ( $types_to_go[$ibeg] eq '#' && $space_count == 0 ) {
$space_count = 1;
}
if ($rOpts_line_up_parentheses) {
$indentation =
new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
}
else {
$indentation = $space_count;
}
}
}
return ( $indentation, $lev, $level_end, $terminal_type,
$is_semicolon_terminated, $is_outdented_line );
}
}
sub mate_index_to_go {
my ( $self, $i ) = @_;
# Return the matching index of a container or ternary pair
# This is equivalent to the array @mate_index_to_go
my $K = $K_to_go[$i];
my $K_mate = $self->K_mate_index($K);
my $i_mate = -1;
if ( defined($K_mate) ) {
$i_mate = $i + ( $K_mate - $K );
if ( $i_mate < 0 || $i_mate > $max_index_to_go ) {
$i_mate = -1;
}
}
my $i_mate_alt = $mate_index_to_go[$i];
# FIXME: Debug code to be removed eventually
if ( 0 && $i_mate_alt != $i_mate ) {
my $tok = $tokens_to_go[$i];
my $type = $types_to_go[$i];
my $tok_mate = '*';
my $type_mate = '*';
if ( $i_mate >= 0 && $i_mate <= $max_index_to_go ) {
$tok_mate = $tokens_to_go[$i_mate];
$type_mate = $types_to_go[$i_mate];
}
my $seq = $type_sequence_to_go[$i];
my $file = $logger_object->get_input_stream_name();
Warn(
"mate_index: file '$file': i=$i, imate=$i_mate, should be $i_mate_alt, K=$K, K_mate=$K_mate\ntype=$type, tok=$tok, seq=$seq, max=$max_index_to_go, tok_mate=$tok_mate, type_mate=$type_mate"
);
}
return $i_mate;
}
sub K_mate_index {
# Given the index K of an opening or closing container, or ?/: ternary pair,
# return the index K of the other member of the pair.
my ( $self, $K ) = @_;
return unless defined($K);
my $rLL = $self->{rLL};
my $seqno = $rLL->[$K]->[_TYPE_SEQUENCE_];
return unless ($seqno);
my $K_opening = $self->{K_opening_container}->{$seqno};
if ( defined($K_opening) ) {
if ( $K != $K_opening ) { return $K_opening }
return $self->{K_closing_container}->{$seqno};
}
$K_opening = $self->{K_opening_ternary}->{$seqno};
if ( defined($K_opening) ) {
if ( $K != $K_opening ) { return $K_opening }
return $self->{K_closing_ternary}->{$seqno};
}
return;
}
sub set_vertical_tightness_flags {
my ( $self, $n, $n_last_line, $ibeg, $iend, $ri_first, $ri_last ) = @_;
# Define vertical tightness controls for the nth line of a batch.
# We create an array of parameters which tell the vertical aligner
# if we should combine this line with the next line to achieve the
# desired vertical tightness. The array of parameters contains:
#
# [0] type: 1=opening non-block 2=closing non-block
# 3=opening block brace 4=closing block brace
#
# [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
# if closing: spaces of padding to use
# [2] sequence number of container
# [3] valid flag: do not append if this flag is false. Will be
# true if appropriate -vt flag is set. Otherwise, Will be
# made true only for 2 line container in parens with -lp
#
# These flags are used by sub set_leading_whitespace in
# the vertical aligner
my $rvertical_tightness_flags = [ 0, 0, 0, 0, 0, 0 ];
my $rOpts_block_brace_tightness = $rOpts->{'block-brace-tightness'};
my $rOpts_block_brace_vertical_tightness =
$rOpts->{'block-brace-vertical-tightness'};
my $rOpts_stack_closing_block_brace = $rOpts->{'stack-closing-block-brace'};
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1:
# Handle Lines 1 .. n-1 but not the last line
# For non-BLOCK tokens, we will need to examine the next line
# too, so we won't consider the last line.
#--------------------------------------------------------------
if ( $n < $n_last_line ) {
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1a:
# Look for Type 1, last token of this line is a non-block opening token
#--------------------------------------------------------------
my $ibeg_next = $ri_first->[ $n + 1 ];
my $token_end = $tokens_to_go[$iend];
my $iend_next = $ri_last->[ $n + 1 ];
if (
$type_sequence_to_go[$iend]
&& !$block_type_to_go[$iend]
&& $is_opening_token{$token_end}
&& (
$opening_vertical_tightness{$token_end} > 0
# allow 2-line method call to be closed up
|| ( $rOpts_line_up_parentheses
&& $token_end eq '('
&& $iend > $ibeg
&& $types_to_go[ $iend - 1 ] ne 'b' )
)
)
{
# avoid multiple jumps in nesting depth in one line if
# requested
my $ovt = $opening_vertical_tightness{$token_end};
my $iend_next = $ri_last->[ $n + 1 ];
unless (
$ovt < 2
&& ( $nesting_depth_to_go[ $iend_next + 1 ] !=
$nesting_depth_to_go[$ibeg_next] )
)
{
# If -vt flag has not been set, mark this as invalid
# and aligner will validate it if it sees the closing paren
# within 2 lines.
my $valid_flag = $ovt;
@{$rvertical_tightness_flags} =
( 1, $ovt, $type_sequence_to_go[$iend], $valid_flag );
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1b:
# Look for Type 2, first token of next line is a non-block closing
# token .. and be sure this line does not have a side comment
#--------------------------------------------------------------
my $token_next = $tokens_to_go[$ibeg_next];
if ( $type_sequence_to_go[$ibeg_next]
&& !$block_type_to_go[$ibeg_next]
&& $is_closing_token{$token_next}
&& $types_to_go[$iend] !~ '#' ) # for safety, shouldn't happen!
{
my $ovt = $opening_vertical_tightness{$token_next};
my $cvt = $closing_vertical_tightness{$token_next};
if (
# never append a trailing line like )->pack(
# because it will throw off later alignment
(
$nesting_depth_to_go[$ibeg_next] ==
$nesting_depth_to_go[ $iend_next + 1 ] + 1
)
&& (
$cvt == 2
|| (
$container_environment_to_go[$ibeg_next] ne 'LIST'
&& (
$cvt == 1
# allow closing up 2-line method calls
|| ( $rOpts_line_up_parentheses
&& $token_next eq ')' )
)
)
)
)
{
# decide which trailing closing tokens to append..
my $ok = 0;
if ( $cvt == 2 || $iend_next == $ibeg_next ) { $ok = 1 }
else {
my $str = join( '',
@types_to_go[ $ibeg_next + 1 .. $ibeg_next + 2 ] );
# append closing token if followed by comment or ';'
if ( $str =~ /^b?[#;]/ ) { $ok = 1 }
}
if ($ok) {
my $valid_flag = $cvt;
@{$rvertical_tightness_flags} = (
2,
$tightness{$token_next} == 2 ? 0 : 1,
$type_sequence_to_go[$ibeg_next], $valid_flag,
);
}
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1c:
# Implement the Opening Token Right flag (Type 2)..
# If requested, move an isolated trailing opening token to the end of
# the previous line which ended in a comma. We could do this
# in sub recombine_breakpoints but that would cause problems
# with -lp formatting. The problem is that indentation will
# quickly move far to the right in nested expressions. By
# doing it after indentation has been set, we avoid changes
# to the indentation. Actual movement of the token takes place
# in sub valign_output_step_B.
#--------------------------------------------------------------
if (
$opening_token_right{ $tokens_to_go[$ibeg_next] }
# previous line is not opening
# (use -sot to combine with it)
&& !$is_opening_token{$token_end}
# previous line ended in one of these
# (add other cases if necessary; '=>' and '.' are not necessary
&& !$block_type_to_go[$ibeg_next]
# this is a line with just an opening token
&& ( $iend_next == $ibeg_next
|| $iend_next == $ibeg_next + 2
&& $types_to_go[$iend_next] eq '#' )
# looks bad if we align vertically with the wrong container
&& $tokens_to_go[$ibeg] ne $tokens_to_go[$ibeg_next]
)
{
my $valid_flag = 1;
my $spaces = ( $types_to_go[ $ibeg_next - 1 ] eq 'b' ) ? 1 : 0;
@{$rvertical_tightness_flags} =
( 2, $spaces, $type_sequence_to_go[$ibeg_next], $valid_flag, );
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1d:
# Stacking of opening and closing tokens (Type 2)
#--------------------------------------------------------------
my $stackable;
my $token_beg_next = $tokens_to_go[$ibeg_next];
# patch to make something like 'qw(' behave like an opening paren
# (aran.t)
if ( $types_to_go[$ibeg_next] eq 'q' ) {
if ( $token_beg_next =~ /^qw\s*([\[\(\{])$/ ) {
$token_beg_next = $1;
}
}
if ( $is_closing_token{$token_end}
&& $is_closing_token{$token_beg_next} )
{
$stackable = $stack_closing_token{$token_beg_next}
unless ( $block_type_to_go[$ibeg_next] )
; # shouldn't happen; just checking
}
elsif ($is_opening_token{$token_end}
&& $is_opening_token{$token_beg_next} )
{
$stackable = $stack_opening_token{$token_beg_next}
unless ( $block_type_to_go[$ibeg_next] )
; # shouldn't happen; just checking
}
if ($stackable) {
my $is_semicolon_terminated;
if ( $n + 1 == $n_last_line ) {
my ( $terminal_type, $i_terminal ) =
$self->terminal_type_i( $ibeg_next, $iend_next );
$is_semicolon_terminated = $terminal_type eq ';'
&& $nesting_depth_to_go[$iend_next] <
$nesting_depth_to_go[$ibeg_next];
}
# this must be a line with just an opening token
# or end in a semicolon
if (
$is_semicolon_terminated
|| ( $iend_next == $ibeg_next
|| $iend_next == $ibeg_next + 2
&& $types_to_go[$iend_next] eq '#' )
)
{
my $valid_flag = 1;
my $spaces = ( $types_to_go[ $ibeg_next - 1 ] eq 'b' ) ? 1 : 0;
@{$rvertical_tightness_flags} =
( 2, $spaces, $type_sequence_to_go[$ibeg_next], $valid_flag,
);
}
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 2:
# Handle type 3, opening block braces on last line of the batch
# Check for a last line with isolated opening BLOCK curly
#--------------------------------------------------------------
elsif ($rOpts_block_brace_vertical_tightness
&& $ibeg eq $iend
&& $types_to_go[$iend] eq '{'
&& $block_type_to_go[$iend] =~
/$block_brace_vertical_tightness_pattern/ )
{
@{$rvertical_tightness_flags} =
( 3, $rOpts_block_brace_vertical_tightness, 0, 1 );
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 3:
# Handle type 4, a closing block brace on the last line of the batch Check
# for a last line with isolated closing BLOCK curly
#--------------------------------------------------------------
elsif ($rOpts_stack_closing_block_brace
&& $ibeg eq $iend
&& $block_type_to_go[$iend]
&& $types_to_go[$iend] eq '}' )
{
my $spaces = $rOpts_block_brace_tightness == 2 ? 0 : 1;
@{$rvertical_tightness_flags} =
( 4, $spaces, $type_sequence_to_go[$iend], 1 );
}
# pack in the sequence numbers of the ends of this line
$rvertical_tightness_flags->[4] = get_seqno($ibeg);
$rvertical_tightness_flags->[5] = get_seqno($iend);
return $rvertical_tightness_flags;
}
sub get_seqno {
# get opening and closing sequence numbers of a token for the vertical
# aligner. Assign qw quotes a value to allow qw opening and closing tokens
# to be treated somewhat like opening and closing tokens for stacking
# tokens by the vertical aligner.
my ($ii) = @_;
my $seqno = $type_sequence_to_go[$ii];
if ( $types_to_go[$ii] eq 'q' ) {
my $SEQ_QW = -1;
if ( $ii > 0 ) {
$seqno = $SEQ_QW if ( $tokens_to_go[$ii] =~ /^qw\s*[\(\{\[]/ );
}
else {
if ( !$ending_in_quote ) {
$seqno = $SEQ_QW if ( $tokens_to_go[$ii] =~ /[\)\}\]]$/ );
}
}
}
return ($seqno);
}
{
my %is_vertical_alignment_type;
my %is_not_vertical_alignment_token;
my %is_vertical_alignment_keyword;
my %is_terminal_alignment_type;
my %is_low_level_alignment_token;
BEGIN {
my @q;
# Replaced =~ and // in the list. // had been removed in RT 119588
@q = qw#
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
{ ? : => && || ~~ !~~ =~ !~ //
#;
@is_vertical_alignment_type{@q} = (1) x scalar(@q);
# These 'tokens' are not aligned. We need this to remove [
# from the above list because it has type ='{'
@q = qw([);
@is_not_vertical_alignment_token{@q} = (1) x scalar(@q);
# these are the only types aligned at a line end
@q = qw(&& ||);
@is_terminal_alignment_type{@q} = (1) x scalar(@q);
# these tokens only align at line level
@q = ( '{', '(' );
@is_low_level_alignment_token{@q} = (1) x scalar(@q);
# eq and ne were removed from this list to improve alignment chances
@q = qw(if unless and or err for foreach while until);
@is_vertical_alignment_keyword{@q} = (1) x scalar(@q);
}
sub set_vertical_alignment_markers {
# This routine takes the first step toward vertical alignment of the
# lines of output text. It looks for certain tokens which can serve as
# vertical alignment markers (such as an '=').
#
# Method: We look at each token $i in this output batch and set
# $ralignment_type_to_go->[$i] equal to those tokens at which we would
# accept vertical alignment.
my ( $self, $ri_first, $ri_last ) = @_;
my $rOpts_add_whitespace = $rOpts->{'add-whitespace'};
my $ralignment_type_to_go;
for my $i ( 0 .. $max_index_to_go ) {
$ralignment_type_to_go->[$i] = '';
}
# nothing to do if we aren't allowed to change whitespace
if ( !$rOpts_add_whitespace ) {
return $ralignment_type_to_go;
}
# remember the index of last nonblank token before any sidecomment
my $i_terminal = $max_index_to_go;
if ( $types_to_go[$i_terminal] eq '#' ) {
if ( $i_terminal > 0 && $types_to_go[ --$i_terminal ] eq 'b' ) {
if ( $i_terminal > 0 ) { --$i_terminal }
}
}
# look at each line of this batch..
my $last_vertical_alignment_before_index;
my $vert_last_nonblank_type;
my $vert_last_nonblank_token;
my $vert_last_nonblank_block_type;
my $max_line = @{$ri_first} - 1;
foreach my $line ( 0 .. $max_line ) {
my $ibeg = $ri_first->[$line];
my $iend = $ri_last->[$line];
$last_vertical_alignment_before_index = -1;
$vert_last_nonblank_type = '';
$vert_last_nonblank_token = '';
$vert_last_nonblank_block_type = '';
# look at each token in this output line..
my $level_beg = $levels_to_go[$ibeg];
foreach my $i ( $ibeg .. $iend ) {
my $alignment_type = '';
my $type = $types_to_go[$i];
my $block_type = $block_type_to_go[$i];
my $token = $tokens_to_go[$i];
# do not align tokens at lower level then start of line
# except for side comments
if ( $levels_to_go[$i] < $levels_to_go[$ibeg]
&& $types_to_go[$i] ne '#' )
{
$ralignment_type_to_go->[$i] = '';
next;
}
#--------------------------------------------------------
# First see if we want to align BEFORE this token
#--------------------------------------------------------
# The first possible token that we can align before
# is index 2 because: 1) it doesn't normally make sense to
# align before the first token and 2) the second
# token must be a blank if we are to align before
# the third
if ( $i < $ibeg + 2 ) { }
# must follow a blank token
elsif ( $types_to_go[ $i - 1 ] ne 'b' ) { }
# align a side comment --
elsif ( $type eq '#' ) {
unless (
# it is a static side comment
(
$rOpts->{'static-side-comments'}
&& $token =~ /$static_side_comment_pattern/
)
# or a closing side comment
|| ( $vert_last_nonblank_block_type
&& $token =~
/$closing_side_comment_prefix_pattern/ )
)
{
$alignment_type = $type;
} ## Example of a static side comment
}
# otherwise, do not align two in a row to create a
# blank field
elsif ( $last_vertical_alignment_before_index == $i - 2 ) { }
# align before one of these keywords
# (within a line, since $i>1)
elsif ( $type eq 'k' ) {
# /^(if|unless|and|or|eq|ne)$/
if ( $is_vertical_alignment_keyword{$token} ) {
$alignment_type = $token;
}
}
# align before one of these types..
# Note: add '.' after new vertical aligner is operational
elsif ( $is_vertical_alignment_type{$type}
&& !$is_not_vertical_alignment_token{$token} )
{
$alignment_type = $token;
# Do not align a terminal token. Although it might
# occasionally look ok to do this, this has been found to be
# a good general rule. The main problems are:
# (1) that the terminal token (such as an = or :) might get
# moved far to the right where it is hard to see because
# nothing follows it, and
# (2) doing so may prevent other good alignments.
# Current exceptions are && and ||
if ( $i == $iend || $i >= $i_terminal ) {
$alignment_type = ""
unless ( $is_terminal_alignment_type{$type} );
}
# Do not align leading ': (' or '. ('. This would prevent
# alignment in something like the following:
# $extra_space .=
# ( $input_line_number < 10 ) ? " "
# : ( $input_line_number < 100 ) ? " "
# : "";
# or
# $code =
# ( $case_matters ? $accessor : " lc($accessor) " )
# . ( $yesno ? " eq " : " ne " )
# Also, do not align a ( following a leading ? so we can
# align something like this:
# $converter{$_}->{ushortok} =
# $PDL::IO::Pic::biggrays
# ? ( m/GIF/ ? 0 : 1 )
# : ( m/GIF|RAST|IFF/ ? 0 : 1 );
if ( $i == $ibeg + 2
&& $types_to_go[$ibeg] =~ /^[\.\:\?]$/
&& $types_to_go[ $i - 1 ] eq 'b' )
{
$alignment_type = "";
}
# Certain tokens only align at the same level as the
# initial line level
if ( $is_low_level_alignment_token{$token}
&& $levels_to_go[$i] != $level_beg )
{
$alignment_type = "";
}
# For a paren after keyword, only align something like this:
# if ( $a ) { &a }
# elsif ( $b ) { &b }
if ( $token eq '(' ) {
if ( $vert_last_nonblank_type eq 'k' ) {
$alignment_type = ""
unless $vert_last_nonblank_token =~
/^(if|unless|elsif)$/;
}
}
# be sure the alignment tokens are unique
# This didn't work well: reason not determined
# if ($token ne $type) {$alignment_type .= $type}
}
# NOTE: This is deactivated because it causes the previous
# if/elsif alignment to fail
#elsif ( $type eq '}' && $token eq '}' && $block_type_to_go[$i])
#{ $alignment_type = $type; }
if ($alignment_type) {
$last_vertical_alignment_before_index = $i;
}
#--------------------------------------------------------
# Next see if we want to align AFTER the previous nonblank
#--------------------------------------------------------
# We want to line up ',' and interior ';' tokens, with the added
# space AFTER these tokens. (Note: interior ';' is included
# because it may occur in short blocks).
if (
# we haven't already set it
!$alignment_type
# and its not the first token of the line
&& ( $i > $ibeg )
# and it follows a blank
&& $types_to_go[ $i - 1 ] eq 'b'
# and previous token IS one of these:
&& ( $vert_last_nonblank_type =~ /^[\,\;]$/ )
# and it's NOT one of these
&& ( $type !~ /^[b\#\)\]\}]$/ )
# then go ahead and align
)
{
$alignment_type = $vert_last_nonblank_type;
}
#--------------------------------------------------------
# Undo alignment in special cases
#--------------------------------------------------------
if ($alignment_type) {
# do not align the opening brace of an anonymous sub
if ( $token eq '{' && $block_type =~ /$ASUB_PATTERN/ ) {
$alignment_type = "";
}
}
#--------------------------------------------------------
# then store the value
#--------------------------------------------------------
$ralignment_type_to_go->[$i] = $alignment_type;
if ( $type ne 'b' ) {
$vert_last_nonblank_type = $type;
$vert_last_nonblank_token = $token;
$vert_last_nonblank_block_type = $block_type;
}
}
}
return $ralignment_type_to_go;
}
}
sub terminal_type_i {
# returns type of last token on this line (terminal token), as follows:
# returns # for a full-line comment
# returns ' ' for a blank line
# otherwise returns final token type
my ( $self, $ibeg, $iend ) = @_;
# Start at the end and work backwards
my $i = $iend;
my $type_i = $types_to_go[$i];
# Check for side comment
if ( $type_i eq '#' ) {
$i--;
if ( $i < $ibeg ) {
return wantarray ? ( $type_i, $ibeg ) : $type_i;
}
$type_i = $types_to_go[$i];
}
# Skip past a blank
if ( $type_i eq 'b' ) {
$i--;
if ( $i < $ibeg ) {
return wantarray ? ( $type_i, $ibeg ) : $type_i;
}
$type_i = $types_to_go[$i];
}
# Found it..make sure it is a BLOCK termination,
# but hide a terminal } after sort/grep/map because it is not
# necessarily the end of the line. (terminal.t)
my $block_type = $block_type_to_go[$i];
if (
$type_i eq '}'
&& ( !$block_type
|| ( $is_sort_map_grep_eval_do{$block_type} ) )
)
{
$type_i = 'b';
}
return wantarray ? ( $type_i, $i ) : $type_i;
}
sub terminal_type_K {
# returns type of last token on this line (terminal token), as follows:
# returns # for a full-line comment
# returns ' ' for a blank line
# otherwise returns final token type
my ( $self, $Kbeg, $Kend ) = @_;
my $rLL = $self->{rLL};
if ( !defined($Kend) ) {
Fault("Error in terminal_type_K: Kbeg=$Kbeg > $Kend=Kend");
}
# Start at the end and work backwards
my $K = $Kend;
my $type_K = $rLL->[$K]->[_TYPE_];
# Check for side comment
if ( $type_K eq '#' ) {
$K--;
if ( $K < $Kbeg ) {
return wantarray ? ( $type_K, $Kbeg ) : $type_K;
}
$type_K = $rLL->[$K]->[_TYPE_];
}
# Skip past a blank
if ( $type_K eq 'b' ) {
$K--;
if ( $K < $Kbeg ) {
return wantarray ? ( $type_K, $Kbeg ) : $type_K;
}
$type_K = $rLL->[$K]->[_TYPE_];
}
# found it..make sure it is a BLOCK termination,
# but hide a terminal } after sort/grep/map because it is not
# necessarily the end of the line. (terminal.t)
my $block_type = $rLL->[$K]->[_BLOCK_TYPE_];
if (
$type_K eq '}'
&& ( !$block_type
|| ( $is_sort_map_grep_eval_do{$block_type} ) )
)
{
$type_K = 'b';
}
return wantarray ? ( $type_K, $K ) : $type_K;
}
{ # set_bond_strengths
my %is_good_keyword_breakpoint;
my %is_lt_gt_le_ge;
my %binary_bond_strength;
my %nobreak_lhs;
my %nobreak_rhs;
my @bias_tokens;
my $delta_bias;
sub bias_table_key {
my ( $type, $token ) = @_;
my $bias_table_key = $type;
if ( $type eq 'k' ) {
$bias_table_key = $token;
if ( $token eq 'err' ) { $bias_table_key = 'or' }
}
return $bias_table_key;
}
sub initialize_bond_strength_hashes {
my @q;
@q = qw(if unless while until for foreach);
@is_good_keyword_breakpoint{@q} = (1) x scalar(@q);
@q = qw(lt gt le ge);
@is_lt_gt_le_ge{@q} = (1) x scalar(@q);
#
# The decision about where to break a line depends upon a "bond
# strength" between tokens. The LOWER the bond strength, the MORE
# likely a break. A bond strength may be any value but to simplify
# things there are several pre-defined strength levels:
# NO_BREAK => 10000;
# VERY_STRONG => 100;
# STRONG => 2.1;
# NOMINAL => 1.1;
# WEAK => 0.8;
# VERY_WEAK => 0.55;
# The strength values are based on trial-and-error, and need to be
# tweaked occasionally to get desired results. Some comments:
#
# 1. Only relative strengths are important. small differences
# in strengths can make big formatting differences.
# 2. Each indentation level adds one unit of bond strength.
# 3. A value of NO_BREAK makes an unbreakable bond
# 4. A value of VERY_WEAK is the strength of a ','
# 5. Values below NOMINAL are considered ok break points.
# 6. Values above NOMINAL are considered poor break points.
#
# The bond strengths should roughly follow precedence order where
# possible. If you make changes, please check the results very
# carefully on a variety of scripts. Testing with the -extrude
# options is particularly helpful in exercising all of the rules.
# Wherever possible, bond strengths are defined in the following
# tables. There are two main stages to setting bond strengths and
# two types of tables:
#
# The first stage involves looking at each token individually and
# defining left and right bond strengths, according to if we want
# to break to the left or right side, and how good a break point it
# is. For example tokens like =, ||, && make good break points and
# will have low strengths, but one might want to break on either
# side to put them at the end of one line or beginning of the next.
#
# The second stage involves looking at certain pairs of tokens and
# defining a bond strength for that particular pair. This second
# stage has priority.
#---------------------------------------------------------------
# Bond Strength BEGIN Section 1.
# Set left and right bond strengths of individual tokens.
#---------------------------------------------------------------
# NOTE: NO_BREAK's set in this section first are HINTS which will
# probably not be honored. Essential NO_BREAKS's should be set in
# BEGIN Section 2 or hardwired in the NO_BREAK coding near the end
# of this subroutine.
# Note that we are setting defaults in this section. The user
# cannot change bond strengths but can cause the left and right
# bond strengths of any token type to be swapped through the use of
# the -wba and -wbb flags. In this way the user can determine if a
# breakpoint token should appear at the end of one line or the
# beginning of the next line.
%right_bond_strength = ();
%left_bond_strength = ();
%binary_bond_strength = ();
%nobreak_lhs = ();
%nobreak_rhs = ();
# The hash keys in this section are token types, plus the text of
# certain keywords like 'or', 'and'.
# no break around possible filehandle
$left_bond_strength{'Z'} = NO_BREAK;
$right_bond_strength{'Z'} = NO_BREAK;
# never put a bare word on a new line:
# example print (STDERR, "bla"); will fail with break after (
$left_bond_strength{'w'} = NO_BREAK;
# blanks always have infinite strength to force breaks after
# real tokens
$right_bond_strength{'b'} = NO_BREAK;
# try not to break on exponentation
@q = qw# ** .. ... <=> #;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (STRONG) x scalar(@q);
# The comma-arrow has very low precedence but not a good break point
$left_bond_strength{'=>'} = NO_BREAK;
$right_bond_strength{'=>'} = NOMINAL;
# ok to break after label
$left_bond_strength{'J'} = NO_BREAK;
$right_bond_strength{'J'} = NOMINAL;
$left_bond_strength{'j'} = STRONG;
$right_bond_strength{'j'} = STRONG;
$left_bond_strength{'A'} = STRONG;
$right_bond_strength{'A'} = STRONG;
$left_bond_strength{'->'} = STRONG;
$right_bond_strength{'->'} = VERY_STRONG;
$left_bond_strength{'CORE::'} = NOMINAL;
$right_bond_strength{'CORE::'} = NO_BREAK;
# breaking AFTER modulus operator is ok:
@q = qw< % >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.1 * NOMINAL + 0.9 * STRONG ) x scalar(@q);
# Break AFTER math operators * and /
@q = qw< * / x >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (NOMINAL) x scalar(@q);
# Break AFTER weakest math operators + and -
# Make them weaker than * but a bit stronger than '.'
@q = qw< + - >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.91 * NOMINAL + 0.09 * WEAK ) x scalar(@q);
# breaking BEFORE these is just ok:
@q = qw# >> << #;
@right_bond_strength{@q} = (STRONG) x scalar(@q);
@left_bond_strength{@q} = (NOMINAL) x scalar(@q);
# breaking before the string concatenation operator seems best
# because it can be hard to see at the end of a line
$right_bond_strength{'.'} = STRONG;
$left_bond_strength{'.'} = 0.9 * NOMINAL + 0.1 * WEAK;
@q = qw< } ] ) R >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (NOMINAL) x scalar(@q);
# make these a little weaker than nominal so that they get
# favored for end-of-line characters
@q = qw< != == =~ !~ ~~ !~~ >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.9 * NOMINAL + 0.1 * WEAK ) x scalar(@q);
# break AFTER these
@q = qw# < > | & >= <= #;
@left_bond_strength{@q} = (VERY_STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.8 * NOMINAL + 0.2 * WEAK ) x scalar(@q);
# breaking either before or after a quote is ok
# but bias for breaking before a quote
$left_bond_strength{'Q'} = NOMINAL;
$right_bond_strength{'Q'} = NOMINAL + 0.02;
$left_bond_strength{'q'} = NOMINAL;
$right_bond_strength{'q'} = NOMINAL;
# starting a line with a keyword is usually ok
$left_bond_strength{'k'} = NOMINAL;
# we usually want to bond a keyword strongly to what immediately
# follows, rather than leaving it stranded at the end of a line
$right_bond_strength{'k'} = STRONG;
$left_bond_strength{'G'} = NOMINAL;
$right_bond_strength{'G'} = STRONG;
# assignment operators
@q = qw(
= **= += *= &= <<= &&=
-= /= |= >>= ||= //=
.= %= ^=
x=
);
# Default is to break AFTER various assignment operators
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.4 * WEAK + 0.6 * VERY_WEAK ) x scalar(@q);
# Default is to break BEFORE '&&' and '||' and '//'
# set strength of '||' to same as '=' so that chains like
# $a = $b || $c || $d will break before the first '||'
$right_bond_strength{'||'} = NOMINAL;
$left_bond_strength{'||'} = $right_bond_strength{'='};
# same thing for '//'
$right_bond_strength{'//'} = NOMINAL;
$left_bond_strength{'//'} = $right_bond_strength{'='};
# set strength of && a little higher than ||
$right_bond_strength{'&&'} = NOMINAL;
$left_bond_strength{'&&'} = $left_bond_strength{'||'} + 0.1;
$left_bond_strength{';'} = VERY_STRONG;
$right_bond_strength{';'} = VERY_WEAK;
$left_bond_strength{'f'} = VERY_STRONG;
# make right strength of for ';' a little less than '='
# to make for contents break after the ';' to avoid this:
# for ( $j = $number_of_fields - 1 ; $j < $item_count ; $j +=
# $number_of_fields )
# and make it weaker than ',' and 'and' too
$right_bond_strength{'f'} = VERY_WEAK - 0.03;
# The strengths of ?/: should be somewhere between
# an '=' and a quote (NOMINAL),
# make strength of ':' slightly less than '?' to help
# break long chains of ? : after the colons
$left_bond_strength{':'} = 0.4 * WEAK + 0.6 * NOMINAL;
$right_bond_strength{':'} = NO_BREAK;
$left_bond_strength{'?'} = $left_bond_strength{':'} + 0.01;
$right_bond_strength{'?'} = NO_BREAK;
$left_bond_strength{','} = VERY_STRONG;
$right_bond_strength{','} = VERY_WEAK;
# remaining digraphs and trigraphs not defined above
@q = qw( :: <> ++ --);
@left_bond_strength{@q} = (WEAK) x scalar(@q);
@right_bond_strength{@q} = (STRONG) x scalar(@q);
# Set bond strengths of certain keywords
# make 'or', 'err', 'and' slightly weaker than a ','
$left_bond_strength{'and'} = VERY_WEAK - 0.01;
$left_bond_strength{'or'} = VERY_WEAK - 0.02;
$left_bond_strength{'err'} = VERY_WEAK - 0.02;
$left_bond_strength{'xor'} = VERY_WEAK - 0.01;
$right_bond_strength{'and'} = NOMINAL;
$right_bond_strength{'or'} = NOMINAL;
$right_bond_strength{'err'} = NOMINAL;
$right_bond_strength{'xor'} = NOMINAL;
#---------------------------------------------------------------
# Bond Strength BEGIN Section 2.
# Set binary rules for bond strengths between certain token types.
#---------------------------------------------------------------
# We have a little problem making tables which apply to the
# container tokens. Here is a list of container tokens and
# their types:
#
# type tokens // meaning
# { {, [, ( // indent
# } }, ], ) // outdent
# [ [ // left non-structural [ (enclosing an array index)
# ] ] // right non-structural square bracket
# ( ( // left non-structural paren
# ) ) // right non-structural paren
# L { // left non-structural curly brace (enclosing a key)
# R } // right non-structural curly brace
#
# Some rules apply to token types and some to just the token
# itself. We solve the problem by combining type and token into a
# new hash key for the container types.
#
# If a rule applies to a token 'type' then we need to make rules
# for each of these 'type.token' combinations:
# Type Type.Token
# { {{, {[, {(
# [ [[
# ( ((
# L L{
# } }}, }], })
# ] ]]
# ) ))
# R R}
#
# If a rule applies to a token then we need to make rules for
# these 'type.token' combinations:
# Token Type.Token
# { {{, L{
# [ {[, [[
# ( {(, ((
# } }}, R}
# ] }], ]]
# ) }), ))
# allow long lines before final { in an if statement, as in:
# if (..........
# ..........)
# {
#
# Otherwise, the line before the { tends to be too short.
$binary_bond_strength{'))'}{'{{'} = VERY_WEAK + 0.03;
$binary_bond_strength{'(('}{'{{'} = NOMINAL;
# break on something like '} (', but keep this stronger than a ','
# example is in 'howe.pl'
$binary_bond_strength{'R}'}{'(('} = 0.8 * VERY_WEAK + 0.2 * WEAK;
$binary_bond_strength{'}}'}{'(('} = 0.8 * VERY_WEAK + 0.2 * WEAK;
# keep matrix and hash indices together
# but make them a little below STRONG to allow breaking open
# something like {'some-word'}{'some-very-long-word'} at the }{
# (bracebrk.t)
$binary_bond_strength{']]'}{'[['} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{']]'}{'L{'} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{'R}'}{'[['} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{'R}'}{'L{'} = 0.9 * STRONG + 0.1 * NOMINAL;
# increase strength to the point where a break in the following
# will be after the opening paren rather than at the arrow:
# $a->$b($c);
$binary_bond_strength{'i'}{'->'} = 1.45 * STRONG;
# Note that the following alternative strength would make the break at the
# '->' rather than opening the '('. Both have advantages and disadvantages.
# $binary_bond_strength{'i'}{'->'} = 0.5*STRONG + 0.5 * NOMINAL; #
$binary_bond_strength{'))'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{']]'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'})'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'}]'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'}}'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'R}'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'))'}{'[['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'})'}{'[['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'))'}{'{['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'})'}{'{['} = 0.2 * STRONG + 0.8 * NOMINAL;
#---------------------------------------------------------------
# Binary NO_BREAK rules
#---------------------------------------------------------------
# use strict requires that bare word and => not be separated
$binary_bond_strength{'C'}{'=>'} = NO_BREAK;
$binary_bond_strength{'U'}{'=>'} = NO_BREAK;
# Never break between a bareword and a following paren because
# perl may give an error. For example, if a break is placed
# between 'to_filehandle' and its '(' the following line will
# give a syntax error [Carp.pm]: my( $no) =fileno(
# to_filehandle( $in)) ;
$binary_bond_strength{'C'}{'(('} = NO_BREAK;
$binary_bond_strength{'C'}{'{('} = NO_BREAK;
$binary_bond_strength{'U'}{'(('} = NO_BREAK;
$binary_bond_strength{'U'}{'{('} = NO_BREAK;
# use strict requires that bare word within braces not start new
# line
$binary_bond_strength{'L{'}{'w'} = NO_BREAK;
$binary_bond_strength{'w'}{'R}'} = NO_BREAK;
# use strict requires that bare word and => not be separated
$binary_bond_strength{'w'}{'=>'} = NO_BREAK;
# use strict does not allow separating type info from trailing { }
# testfile is readmail.pl
$binary_bond_strength{'t'}{'L{'} = NO_BREAK;
$binary_bond_strength{'i'}{'L{'} = NO_BREAK;
# As a defensive measure, do not break between a '(' and a
# filehandle. In some cases, this can cause an error. For
# example, the following program works:
# my $msg="hi!\n";
# print
# ( STDOUT
# $msg
# );
#
# But this program fails:
# my $msg="hi!\n";
# print
# (
# STDOUT
# $msg
# );
#
# This is normally only a problem with the 'extrude' option
$binary_bond_strength{'(('}{'Y'} = NO_BREAK;
$binary_bond_strength{'{('}{'Y'} = NO_BREAK;
# never break between sub name and opening paren
$binary_bond_strength{'w'}{'(('} = NO_BREAK;
$binary_bond_strength{'w'}{'{('} = NO_BREAK;
# keep '}' together with ';'
$binary_bond_strength{'}}'}{';'} = NO_BREAK;
# Breaking before a ++ can cause perl to guess wrong. For
# example the following line will cause a syntax error
# with -extrude if we break between '$i' and '++' [fixstyle2]
# print( ( $i++ & 1 ) ? $_ : ( $change{$_} || $_ ) );
$nobreak_lhs{'++'} = NO_BREAK;
# Do not break before a possible file handle
$nobreak_lhs{'Z'} = NO_BREAK;
# use strict hates bare words on any new line. For
# example, a break before the underscore here provokes the
# wrath of use strict:
# if ( -r $fn && ( -s _ || $AllowZeroFilesize)) {
$nobreak_rhs{'F'} = NO_BREAK;
$nobreak_rhs{'CORE::'} = NO_BREAK;
#---------------------------------------------------------------
# Bond Strength BEGIN Section 3.
# Define tables and values for applying a small bias to the above
# values.
#---------------------------------------------------------------
# Adding a small 'bias' to strengths is a simple way to make a line
# break at the first of a sequence of identical terms. For
# example, to force long string of conditional operators to break
# with each line ending in a ':', we can add a small number to the
# bond strength of each ':' (colon.t)
@bias_tokens = qw( : && || f and or . ); # tokens which get bias
$delta_bias = 0.0001; # a very small strength level
return;
} ## end sub initialize_bond_strength_hashes
sub set_bond_strengths {
# patch-its always ok to break at end of line
$nobreak_to_go[$max_index_to_go] = 0;
my $rOpts_short_concatenation_item_length =
$rOpts->{'short-concatenation-item-length'};
# we start a new set of bias values for each line
my %bias;
@bias{@bias_tokens} = (0) x scalar(@bias_tokens);
my $code_bias = -.01; # bias for closing block braces
my $type = 'b';
my $token = ' ';
my $token_length = 1;
my $last_type;
my $last_nonblank_type = $type;
my $last_nonblank_token = $token;
my $list_str = $left_bond_strength{'?'};
my ( $block_type, $i_next, $i_next_nonblank, $next_nonblank_token,
$next_nonblank_type, $next_token, $next_type, $total_nesting_depth,
);
# main loop to compute bond strengths between each pair of tokens
foreach my $i ( 0 .. $max_index_to_go ) {
$last_type = $type;
if ( $type ne 'b' ) {
$last_nonblank_type = $type;
$last_nonblank_token = $token;
}
$type = $types_to_go[$i];
# strength on both sides of a blank is the same
if ( $type eq 'b' && $last_type ne 'b' ) {
$bond_strength_to_go[$i] = $bond_strength_to_go[ $i - 1 ];
next;
}
$token = $tokens_to_go[$i];
$token_length = $token_lengths_to_go[$i];
$block_type = $block_type_to_go[$i];
$i_next = $i + 1;
$next_type = $types_to_go[$i_next];
$next_token = $tokens_to_go[$i_next];
$total_nesting_depth = $nesting_depth_to_go[$i_next];
$i_next_nonblank = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
# We are computing the strength of the bond between the current
# token and the NEXT token.
#---------------------------------------------------------------
# Bond Strength Section 1:
# First Approximation.
# Use minimum of individual left and right tabulated bond
# strengths.
#---------------------------------------------------------------
my $bsr = $right_bond_strength{$type};
my $bsl = $left_bond_strength{$next_nonblank_type};
# define right bond strengths of certain keywords
if ( $type eq 'k' && defined( $right_bond_strength{$token} ) ) {
$bsr = $right_bond_strength{$token};
}
elsif ( $token eq 'ne' or $token eq 'eq' ) {
$bsr = NOMINAL;
}
# set terminal bond strength to the nominal value
# this will cause good preceding breaks to be retained
if ( $i_next_nonblank > $max_index_to_go ) {
$bsl = NOMINAL;
}
# define right bond strengths of certain keywords
if ( $next_nonblank_type eq 'k'
&& defined( $left_bond_strength{$next_nonblank_token} ) )
{
$bsl = $left_bond_strength{$next_nonblank_token};
}
elsif ($next_nonblank_token eq 'ne'
or $next_nonblank_token eq 'eq' )
{
$bsl = NOMINAL;
}
elsif ( $is_lt_gt_le_ge{$next_nonblank_token} ) {
$bsl = 0.9 * NOMINAL + 0.1 * STRONG;
}
# Use the minimum of the left and right strengths. Note: it might
# seem that we would want to keep a NO_BREAK if either token has
# this value. This didn't work, for example because in an arrow
# list, it prevents the comma from separating from the following
# bare word (which is probably quoted by its arrow). So necessary
# NO_BREAK's have to be handled as special cases in the final
# section.
if ( !defined($bsr) ) { $bsr = VERY_STRONG }
if ( !defined($bsl) ) { $bsl = VERY_STRONG }
my $bond_str = ( $bsr < $bsl ) ? $bsr : $bsl;
my $bond_str_1 = $bond_str;
#---------------------------------------------------------------
# Bond Strength Section 2:
# Apply hardwired rules..
#---------------------------------------------------------------
# Patch to put terminal or clauses on a new line: Weaken the bond
# at an || followed by die or similar keyword to make the terminal
# or clause fall on a new line, like this:
#
# my $class = shift
# || die "Cannot add broadcast: No class identifier found";
#
# Otherwise the break will be at the previous '=' since the || and
# = have the same starting strength and the or is biased, like
# this:
#
# my $class =
# shift || die "Cannot add broadcast: No class identifier found";
#
# In any case if the user places a break at either the = or the ||
# it should remain there.
if ( $type eq '||' || $type eq 'k' && $token eq 'or' ) {
if ( $next_nonblank_token =~ /^(die|confess|croak|warn)$/ ) {
if ( $want_break_before{$token} && $i > 0 ) {
$bond_strength_to_go[ $i - 1 ] -= $delta_bias;
# keep bond strength of a token and its following blank
# the same
if ( $types_to_go[ $i - 1 ] eq 'b' && $i > 2 ) {
$bond_strength_to_go[ $i - 2 ] -= $delta_bias;
}
}
else {
$bond_str -= $delta_bias;
}
}
}
# good to break after end of code blocks
if ( $type eq '}' && $block_type && $next_nonblank_type ne ';' ) {
$bond_str = 0.5 * WEAK + 0.5 * VERY_WEAK + $code_bias;
$code_bias += $delta_bias;
}
if ( $type eq 'k' ) {
# allow certain control keywords to stand out
if ( $next_nonblank_type eq 'k'
&& $is_last_next_redo_return{$token} )
{
$bond_str = 0.45 * WEAK + 0.55 * VERY_WEAK;
}
# Don't break after keyword my. This is a quick fix for a
# rare problem with perl. An example is this line from file
# Container.pm:
# foreach my $question( Debian::DebConf::ConfigDb::gettree(
# $this->{'question'} ) )
if ( $token eq 'my' ) {
$bond_str = NO_BREAK;
}
}
# good to break before 'if', 'unless', etc
if ( $is_if_brace_follower{$next_nonblank_token} ) {
$bond_str = VERY_WEAK;
}
if ( $next_nonblank_type eq 'k' && $type ne 'CORE::' ) {
# FIXME: needs more testing
if ( $is_keyword_returning_list{$next_nonblank_token} ) {
$bond_str = $list_str if ( $bond_str > $list_str );
}
# keywords like 'unless', 'if', etc, within statements
# make good breaks
if ( $is_good_keyword_breakpoint{$next_nonblank_token} ) {
$bond_str = VERY_WEAK / 1.05;
}
}
# try not to break before a comma-arrow
elsif ( $next_nonblank_type eq '=>' ) {
if ( $bond_str < STRONG ) { $bond_str = STRONG }
}
#---------------------------------------------------------------
# Additional hardwired NOBREAK rules
#---------------------------------------------------------------
# map1.t -- correct for a quirk in perl
if ( $token eq '('
&& $next_nonblank_type eq 'i'
&& $last_nonblank_type eq 'k'
&& $is_sort_map_grep{$last_nonblank_token} )
# /^(sort|map|grep)$/ )
{
$bond_str = NO_BREAK;
}
# extrude.t: do not break before paren at:
# -l pid_filename(
if ( $last_nonblank_type eq 'F' && $next_nonblank_token eq '(' ) {
$bond_str = NO_BREAK;
}
# in older version of perl, use strict can cause problems with
# breaks before bare words following opening parens. For example,
# this will fail under older versions if a break is made between
# '(' and 'MAIL': use strict; open( MAIL, "a long filename or
# command"); close MAIL;
if ( $type eq '{' ) {
if ( $token eq '(' && $next_nonblank_type eq 'w' ) {
# but it's fine to break if the word is followed by a '=>'
# or if it is obviously a sub call
my $i_next_next_nonblank = $i_next_nonblank + 1;
my $next_next_type = $types_to_go[$i_next_next_nonblank];
if ( $next_next_type eq 'b'
&& $i_next_nonblank < $max_index_to_go )
{
$i_next_next_nonblank++;
$next_next_type = $types_to_go[$i_next_next_nonblank];
}
# We'll check for an old breakpoint and keep a leading
# bareword if it was that way in the input file.
# Presumably it was ok that way. For example, the
# following would remain unchanged:
#
# @months = (
# January, February, March, April,
# May, June, July, August,
# September, October, November, December,
# );
#
# This should be sufficient:
if (
!$old_breakpoint_to_go[$i]
&& ( $next_next_type eq ','
|| $next_next_type eq '}' )
)
{
$bond_str = NO_BREAK;
}
}
}
# Do not break between a possible filehandle and a ? or / and do
# not introduce a break after it if there is no blank
# (extrude.t)
elsif ( $type eq 'Z' ) {
# don't break..
if (
# if there is no blank and we do not want one. Examples:
# print $x++ # do not break after $x
# print HTML"HELLO" # break ok after HTML
(
$next_type ne 'b'
&& defined( $want_left_space{$next_type} )
&& $want_left_space{$next_type} == WS_NO
)
# or we might be followed by the start of a quote
|| $next_nonblank_type =~ /^[\/\?]$/
)
{
$bond_str = NO_BREAK;
}
}
# Breaking before a ? before a quote can cause trouble if
# they are not separated by a blank.
# Example: a syntax error occurs if you break before the ? here
# my$logic=join$all?' && ':' || ',@regexps;
# From: Professional_Perl_Programming_Code/multifind.pl
if ( $next_nonblank_type eq '?' ) {
$bond_str = NO_BREAK
if ( $types_to_go[ $i_next_nonblank + 1 ] eq 'Q' );
}
# Breaking before a . followed by a number
# can cause trouble if there is no intervening space
# Example: a syntax error occurs if you break before the .2 here
# $str .= pack($endian.2, ensurrogate($ord));
# From: perl58/Unicode.pm
elsif ( $next_nonblank_type eq '.' ) {
$bond_str = NO_BREAK
if ( $types_to_go[ $i_next_nonblank + 1 ] eq 'n' );
}
my $bond_str_2 = $bond_str;
#---------------------------------------------------------------
# End of hardwired rules
#---------------------------------------------------------------
#---------------------------------------------------------------
# Bond Strength Section 3:
# Apply table rules. These have priority over the above
# hardwired rules.
#---------------------------------------------------------------
my $tabulated_bond_str;
my $ltype = $type;
my $rtype = $next_nonblank_type;
if ( $token =~ /^[\(\[\{\)\]\}]/ ) { $ltype = $type . $token }
if ( $next_nonblank_token =~ /^[\(\[\{\)\]\}]/ ) {
$rtype = $next_nonblank_type . $next_nonblank_token;
}
if ( $binary_bond_strength{$ltype}{$rtype} ) {
$bond_str = $binary_bond_strength{$ltype}{$rtype};
$tabulated_bond_str = $bond_str;
}
if ( $nobreak_rhs{$ltype} || $nobreak_lhs{$rtype} ) {
$bond_str = NO_BREAK;
$tabulated_bond_str = $bond_str;
}
my $bond_str_3 = $bond_str;
# If the hardwired rules conflict with the tabulated bond
# strength then there is an inconsistency that should be fixed
FORMATTER_DEBUG_FLAG_BOND_TABLES
&& $tabulated_bond_str
&& $bond_str_1
&& $bond_str_1 != $bond_str_2
&& $bond_str_2 != $tabulated_bond_str
&& do {
print STDERR
"BOND_TABLES: ltype=$ltype rtype=$rtype $bond_str_1->$bond_str_2->$bond_str_3\n";
};
#-----------------------------------------------------------------
# Bond Strength Section 4:
# Modify strengths of certain tokens which often occur in sequence
# by adding a small bias to each one in turn so that the breaks
# occur from left to right.
#
# Note that we only changing strengths by small amounts here,
# and usually increasing, so we should not be altering any NO_BREAKs.
# Other routines which check for NO_BREAKs will use a tolerance
# of one to avoid any problem.
#-----------------------------------------------------------------
# The bias tables use special keys
my $left_key = bias_table_key( $type, $token );
my $right_key =
bias_table_key( $next_nonblank_type, $next_nonblank_token );
# add any bias set by sub scan_list at old comma break points.
if ( $type eq ',' ) { $bond_str += $bond_strength_to_go[$i] }
# bias left token
elsif ( defined( $bias{$left_key} ) ) {
if ( !$want_break_before{$left_key} ) {
$bias{$left_key} += $delta_bias;
$bond_str += $bias{$left_key};
}
}
# bias right token
if ( defined( $bias{$right_key} ) ) {
if ( $want_break_before{$right_key} ) {
# for leading '.' align all but 'short' quotes; the idea
# is to not place something like "\n" on a single line.
if ( $right_key eq '.' ) {
unless (
$last_nonblank_type eq '.'
&& ( $token_length <=
$rOpts_short_concatenation_item_length )
&& ( !$is_closing_token{$token} )
)
{
$bias{$right_key} += $delta_bias;
}
}
else {
$bias{$right_key} += $delta_bias;
}
$bond_str += $bias{$right_key};
}
}
my $bond_str_4 = $bond_str;
#---------------------------------------------------------------
# Bond Strength Section 5:
# Fifth Approximation.
# Take nesting depth into account by adding the nesting depth
# to the bond strength.
#---------------------------------------------------------------
my $strength;
if ( defined($bond_str) && !$nobreak_to_go[$i] ) {
if ( $total_nesting_depth > 0 ) {
$strength = $bond_str + $total_nesting_depth;
}
else {
$strength = $bond_str;
}
}
else {
$strength = NO_BREAK;
}
#---------------------------------------------------------------
# Bond Strength Section 6:
# Sixth Approximation. Welds.
#---------------------------------------------------------------
# Do not allow a break within welds,
if ( weld_len_right_to_go($i) ) { $strength = NO_BREAK }
# But encourage breaking after opening welded tokens
elsif ( weld_len_left_to_go($i) && $is_opening_token{$token} ) {
$strength -= 1;
}
# always break after side comment
if ( $type eq '#' ) { $strength = 0 }
$bond_strength_to_go[$i] = $strength;
FORMATTER_DEBUG_FLAG_BOND && do {
my $str = substr( $token, 0, 15 );
$str .= ' ' x ( 16 - length($str) );
print STDOUT
"BOND: i=$i $str $type $next_nonblank_type depth=$total_nesting_depth strength=$bond_str_1 -> $bond_str_2 -> $bond_str_3 -> $bond_str_4 $bond_str -> $strength \n";
};
} ## end main loop
return;
} ## end sub set_bond_strengths
}
sub pad_array_to_go {
# to simplify coding in scan_list and set_bond_strengths, it helps
# to create some extra blank tokens at the end of the arrays
$tokens_to_go[ $max_index_to_go + 1 ] = '';
$tokens_to_go[ $max_index_to_go + 2 ] = '';
$types_to_go[ $max_index_to_go + 1 ] = 'b';
$types_to_go[ $max_index_to_go + 2 ] = 'b';
$nesting_depth_to_go[ $max_index_to_go + 1 ] =
$nesting_depth_to_go[$max_index_to_go];
# /^[R\}\)\]]$/
if ( $is_closing_type{ $types_to_go[$max_index_to_go] } ) {
if ( $nesting_depth_to_go[$max_index_to_go] <= 0 ) {
# shouldn't happen:
unless ( get_saw_brace_error() ) {
warning(
"Program bug in scan_list: hit nesting error which should have been caught\n"
);
report_definite_bug();
}
}
else {
$nesting_depth_to_go[ $max_index_to_go + 1 ] -= 1;
}
}
# /^[L\{\(\[]$/
elsif ( $is_opening_type{ $types_to_go[$max_index_to_go] } ) {
$nesting_depth_to_go[ $max_index_to_go + 1 ] += 1;
}
return;
}
{ # begin scan_list
my (
$block_type, $current_depth,
$depth, $i,
$i_last_nonblank_token, $last_colon_sequence_number,
$last_nonblank_token, $last_nonblank_type,
$last_nonblank_block_type, $last_old_breakpoint_count,
$minimum_depth, $next_nonblank_block_type,
$next_nonblank_token, $next_nonblank_type,
$old_breakpoint_count, $starting_breakpoint_count,
$starting_depth, $token,
$type, $type_sequence,
);
my (
@breakpoint_stack, @breakpoint_undo_stack,
@comma_index, @container_type,
@identifier_count_stack, @index_before_arrow,
@interrupted_list, @item_count_stack,
@last_comma_index, @last_dot_index,
@last_nonblank_type, @old_breakpoint_count_stack,
@opening_structure_index_stack, @rfor_semicolon_list,
@has_old_logical_breakpoints, @rand_or_list,
@i_equals,
);
# routine to define essential variables when we go 'up' to
# a new depth
sub check_for_new_minimum_depth {
my $depth = shift;
if ( $depth < $minimum_depth ) {
$minimum_depth = $depth;
# these arrays need not retain values between calls
$breakpoint_stack[$depth] = $starting_breakpoint_count;
$container_type[$depth] = "";
$identifier_count_stack[$depth] = 0;
$index_before_arrow[$depth] = -1;
$interrupted_list[$depth] = 1;
$item_count_stack[$depth] = 0;
$last_nonblank_type[$depth] = "";
$opening_structure_index_stack[$depth] = -1;
$breakpoint_undo_stack[$depth] = undef;
$comma_index[$depth] = undef;
$last_comma_index[$depth] = undef;
$last_dot_index[$depth] = undef;
$old_breakpoint_count_stack[$depth] = undef;
$has_old_logical_breakpoints[$depth] = 0;
$rand_or_list[$depth] = [];
$rfor_semicolon_list[$depth] = [];
$i_equals[$depth] = -1;
# these arrays must retain values between calls
if ( !defined( $has_broken_sublist[$depth] ) ) {
$dont_align[$depth] = 0;
$has_broken_sublist[$depth] = 0;
$want_comma_break[$depth] = 0;
}
}
return;
}
# routine to decide which commas to break at within a container;
# returns:
# $bp_count = number of comma breakpoints set
# $do_not_break_apart = a flag indicating if container need not
# be broken open
sub set_comma_breakpoints {
my $dd = shift;
my $bp_count = 0;
my $do_not_break_apart = 0;
# anything to do?
if ( $item_count_stack[$dd] ) {
# handle commas not in containers...
if ( $dont_align[$dd] ) {
do_uncontained_comma_breaks($dd);
}
# handle commas within containers...
else {
my $fbc = $forced_breakpoint_count;
# always open comma lists not preceded by keywords,
# barewords, identifiers (that is, anything that doesn't
# look like a function call)
my $must_break_open = $last_nonblank_type[$dd] !~ /^[kwiU]$/;
set_comma_breakpoints_do(
depth => $dd,
i_opening_paren => $opening_structure_index_stack[$dd],
i_closing_paren => $i,
item_count => $item_count_stack[$dd],
identifier_count => $identifier_count_stack[$dd],
rcomma_index => $comma_index[$dd],
next_nonblank_type => $next_nonblank_type,
list_type => $container_type[$dd],
interrupted => $interrupted_list[$dd],
rdo_not_break_apart => \$do_not_break_apart,
must_break_open => $must_break_open,
);
$bp_count = $forced_breakpoint_count - $fbc;
$do_not_break_apart = 0 if $must_break_open;
}
}
return ( $bp_count, $do_not_break_apart );
}
sub do_uncontained_comma_breaks {
# Handle commas not in containers...
# This is a catch-all routine for commas that we
# don't know what to do with because the don't fall
# within containers. We will bias the bond strength
# to break at commas which ended lines in the input
# file. This usually works better than just trying
# to put as many items on a line as possible. A
# downside is that if the input file is garbage it
# won't work very well. However, the user can always
# prevent following the old breakpoints with the
# -iob flag.
my $dd = shift;
my $bias = -.01;
my $old_comma_break_count = 0;
foreach my $ii ( @{ $comma_index[$dd] } ) {
if ( $old_breakpoint_to_go[$ii] ) {
$old_comma_break_count++;
$bond_strength_to_go[$ii] = $bias;
# reduce bias magnitude to force breaks in order
$bias *= 0.99;
}
}
# Also put a break before the first comma if
# (1) there was a break there in the input, and
# (2) there was exactly one old break before the first comma break
# (3) OLD: there are multiple old comma breaks
# (3) NEW: there are one or more old comma breaks (see return example)
#
# For example, we will follow the user and break after
# 'print' in this snippet:
# print
# "conformability (Not the same dimension)\n",
# "\t", $have, " is ", text_unit($hu), "\n",
# "\t", $want, " is ", text_unit($wu), "\n",
# ;
#
# Another example, just one comma, where we will break after
# the return:
# return
# $x * cos($a) - $y * sin($a),
# $x * sin($a) + $y * cos($a);
# Breaking a print statement:
# print SAVEOUT
# ( $? & 127 ) ? " (SIG#" . ( $? & 127 ) . ")" : "",
# ( $? & 128 ) ? " -- core dumped" : "", "\n";
#
# But we will not force a break after the opening paren here
# (causes a blinker):
# $heap->{stream}->set_output_filter(
# poe::filter::reference->new('myotherfreezer') ),
# ;
#
my $i_first_comma = $comma_index[$dd]->[0];
if ( $old_breakpoint_to_go[$i_first_comma] ) {
my $level_comma = $levels_to_go[$i_first_comma];
my $ibreak = -1;
my $obp_count = 0;
for ( my $ii = $i_first_comma - 1 ; $ii >= 0 ; $ii -= 1 ) {
if ( $old_breakpoint_to_go[$ii] ) {
$obp_count++;
last if ( $obp_count > 1 );
$ibreak = $ii
if ( $levels_to_go[$ii] == $level_comma );
}
}
# Changed rule from multiple old commas to just one here:
if ( $ibreak >= 0 && $obp_count == 1 && $old_comma_break_count > 0 )
{
# Do not to break before an opening token because
# it can lead to "blinkers".
my $ibreakm = $ibreak;
$ibreakm-- if ( $types_to_go[$ibreakm] eq 'b' );
if ( $ibreakm >= 0 && $types_to_go[$ibreakm] !~ /^[\(\{\[L]$/ )
{
set_forced_breakpoint($ibreak);
}
}
}
return;
}
my %is_logical_container;
BEGIN {
my @q = qw# if elsif unless while and or err not && | || ? : ! #;
@is_logical_container{@q} = (1) x scalar(@q);
}
sub set_for_semicolon_breakpoints {
my $dd = shift;
foreach ( @{ $rfor_semicolon_list[$dd] } ) {
set_forced_breakpoint($_);
}
return;
}
sub set_logical_breakpoints {
my $dd = shift;
if (
$item_count_stack[$dd] == 0
&& $is_logical_container{ $container_type[$dd] }
|| $has_old_logical_breakpoints[$dd]
)
{
# Look for breaks in this order:
# 0 1 2 3
# or and || &&
foreach my $i ( 0 .. 3 ) {
if ( $rand_or_list[$dd][$i] ) {
foreach ( @{ $rand_or_list[$dd][$i] } ) {
set_forced_breakpoint($_);
}
# break at any 'if' and 'unless' too
foreach ( @{ $rand_or_list[$dd][4] } ) {
set_forced_breakpoint($_);
}
$rand_or_list[$dd] = [];
last;
}
}
}
return;
}
sub is_unbreakable_container {
# never break a container of one of these types
# because bad things can happen (map1.t)
my $dd = shift;
return $is_sort_map_grep{ $container_type[$dd] };
}
sub scan_list {
# This routine is responsible for setting line breaks for all lists,
# so that hierarchical structure can be displayed and so that list
# items can be vertically aligned. The output of this routine is
# stored in the array @forced_breakpoint_to_go, which is used to set
# final breakpoints.
my $rOpts_break_at_old_attribute_breakpoints =
$rOpts->{'break-at-old-attribute-breakpoints'};
my $rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
my $rOpts_break_at_old_keyword_breakpoints =
$rOpts->{'break-at-old-keyword-breakpoints'};
my $rOpts_break_at_old_logical_breakpoints =
$rOpts->{'break-at-old-logical-breakpoints'};
my $rOpts_break_at_old_method_breakpoints =
$rOpts->{'break-at-old-method-breakpoints'};
my $rOpts_break_at_old_semicolon_breakpoints =
$rOpts->{'break-at-old-semicolon-breakpoints'};
my $rOpts_break_at_old_ternary_breakpoints =
$rOpts->{'break-at-old-ternary-breakpoints'};
my $rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
$starting_depth = $nesting_depth_to_go[0];
$block_type = ' ';
$current_depth = $starting_depth;
$i = -1;
$last_colon_sequence_number = -1;
$last_nonblank_token = ';';
$last_nonblank_type = ';';
$last_nonblank_block_type = ' ';
$last_old_breakpoint_count = 0;
$minimum_depth = $current_depth + 1; # forces update in check below
$old_breakpoint_count = 0;
$starting_breakpoint_count = $forced_breakpoint_count;
$token = ';';
$type = ';';
$type_sequence = '';
my $total_depth_variation = 0;
my $i_old_assignment_break;
my $depth_last = $starting_depth;
check_for_new_minimum_depth($current_depth);
my $is_long_line = excess_line_length( 0, $max_index_to_go ) > 0;
my $want_previous_breakpoint = -1;
my $saw_good_breakpoint;
my $i_line_end = -1;
my $i_line_start = -1;
# loop over all tokens in this batch
while ( ++$i <= $max_index_to_go ) {
if ( $type ne 'b' ) {
$i_last_nonblank_token = $i - 1;
$last_nonblank_type = $type;
$last_nonblank_token = $token;
$last_nonblank_block_type = $block_type;
} ## end if ( $type ne 'b' )
$type = $types_to_go[$i];
$block_type = $block_type_to_go[$i];
$token = $tokens_to_go[$i];
$type_sequence = $type_sequence_to_go[$i];
my $next_type = $types_to_go[ $i + 1 ];
my $next_token = $tokens_to_go[ $i + 1 ];
my $i_next_nonblank = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
$next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
# set break if flag was set
if ( $want_previous_breakpoint >= 0 ) {
set_forced_breakpoint($want_previous_breakpoint);
$want_previous_breakpoint = -1;
}
$last_old_breakpoint_count = $old_breakpoint_count;
if ( $old_breakpoint_to_go[$i] ) {
$i_line_end = $i;
$i_line_start = $i_next_nonblank;
$old_breakpoint_count++;
# Break before certain keywords if user broke there and
# this is a 'safe' break point. The idea is to retain
# any preferred breaks for sequential list operations,
# like a schwartzian transform.
if ($rOpts_break_at_old_keyword_breakpoints) {
if (
$next_nonblank_type eq 'k'
&& $is_keyword_returning_list{$next_nonblank_token}
&& ( $type =~ /^[=\)\]\}Riw]$/
|| $type eq 'k'
&& $is_keyword_returning_list{$token} )
)
{
# we actually have to set this break next time through
# the loop because if we are at a closing token (such
# as '}') which forms a one-line block, this break might
# get undone.
$want_previous_breakpoint = $i;
} ## end if ( $next_nonblank_type...)
} ## end if ($rOpts_break_at_old_keyword_breakpoints)
# Break before attributes if user broke there
if ($rOpts_break_at_old_attribute_breakpoints) {
if ( $next_nonblank_type eq 'A' ) {
$want_previous_breakpoint = $i;
}
}
# remember an = break as possible good break point
if ( $is_assignment{$type} ) {
$i_old_assignment_break = $i;
}
elsif ( $is_assignment{$next_nonblank_type} ) {
$i_old_assignment_break = $i_next_nonblank;
}
} ## end if ( $old_breakpoint_to_go...)
next if ( $type eq 'b' );
$depth = $nesting_depth_to_go[ $i + 1 ];
$total_depth_variation += abs( $depth - $depth_last );
$depth_last = $depth;
# safety check - be sure we always break after a comment
# Shouldn't happen .. an error here probably means that the
# nobreak flag did not get turned off correctly during
# formatting.
if ( $type eq '#' ) {
if ( $i != $max_index_to_go ) {
warning(
"Non-fatal program bug: backup logic needed to break after a comment\n"
);
report_definite_bug();
$nobreak_to_go[$i] = 0;
set_forced_breakpoint($i);
} ## end if ( $i != $max_index_to_go)
} ## end if ( $type eq '#' )
# Force breakpoints at certain tokens in long lines.
# Note that such breakpoints will be undone later if these tokens
# are fully contained within parens on a line.
if (
# break before a keyword within a line
$type eq 'k'
&& $i > 0
# if one of these keywords:
&& $token =~ /^(if|unless|while|until|for)$/
# but do not break at something like '1 while'
&& ( $last_nonblank_type ne 'n' || $i > 2 )
# and let keywords follow a closing 'do' brace
&& $last_nonblank_block_type ne 'do'
&& (
$is_long_line
# or container is broken (by side-comment, etc)
|| ( $next_nonblank_token eq '('
&& $mate_index_to_go[$i_next_nonblank] < $i )
)
)
{
set_forced_breakpoint( $i - 1 );
} ## end if ( $type eq 'k' && $i...)
# remember locations of -> if this is a pre-broken method chain
if ( $type eq '->' ) {
if ($rOpts_break_at_old_method_breakpoints) {
# Case 1: look for lines with leading pointers
if ( $i == $i_line_start ) {
set_forced_breakpoint( $i - 1 );
}
# Case 2: look for cuddled pointer calls
else {
# look for old lines with leading ')->' or ') ->'
# and, when found, force a break before the
# opening paren and after the previous closing paren.
if (
$types_to_go[$i_line_start] eq '}'
&& ( $i == $i_line_start + 1
|| $i == $i_line_start + 2
&& $types_to_go[ $i - 1 ] eq 'b' )
)
{
set_forced_breakpoint( $i_line_start - 1 );
set_forced_breakpoint(
$mate_index_to_go[$i_line_start] );
}
}
}
} ## end if ( $type eq '->' )
elsif ( $type eq ';' ) {
if ( $i == $i_line_start
&& $rOpts_break_at_old_semicolon_breakpoints )
{
set_forced_breakpoint( $i - 1 );
}
}
# remember locations of '||' and '&&' for possible breaks if we
# decide this is a long logical expression.
elsif ( $type eq '||' ) {
push @{ $rand_or_list[$depth][2] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end elsif ( $type eq '||' )
elsif ( $type eq '&&' ) {
push @{ $rand_or_list[$depth][3] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end elsif ( $type eq '&&' )
elsif ( $type eq 'f' ) {
push @{ $rfor_semicolon_list[$depth] }, $i;
}
elsif ( $type eq 'k' ) {
if ( $token eq 'and' ) {
push @{ $rand_or_list[$depth][1] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end if ( $token eq 'and' )
# break immediately at 'or's which are probably not in a logical
# block -- but we will break in logical breaks below so that
# they do not add to the forced_breakpoint_count
elsif ( $token eq 'or' ) {
push @{ $rand_or_list[$depth][0] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
if ( $is_logical_container{ $container_type[$depth] } ) {
}
else {
if ($is_long_line) { set_forced_breakpoint($i) }
elsif ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints )
{
$saw_good_breakpoint = 1;
}
} ## end else [ if ( $is_logical_container...)]
} ## end elsif ( $token eq 'or' )
elsif ( $token eq 'if' || $token eq 'unless' ) {
push @{ $rand_or_list[$depth][4] }, $i;
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints )
{
set_forced_breakpoint($i);
}
} ## end elsif ( $token eq 'if' ||...)
} ## end elsif ( $type eq 'k' )
elsif ( $is_assignment{$type} ) {
$i_equals[$depth] = $i;
}
if ($type_sequence) {
# handle any postponed closing breakpoints
if ( $token =~ /^[\)\]\}\:]$/ ) {
if ( $type eq ':' ) {
$last_colon_sequence_number = $type_sequence;
# retain break at a ':' line break
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_ternary_breakpoints )
{
set_forced_breakpoint($i);
# break at previous '='
if ( $i_equals[$depth] > 0 ) {
set_forced_breakpoint( $i_equals[$depth] );
$i_equals[$depth] = -1;
}
} ## end if ( ( $i == $i_line_start...))
} ## end if ( $type eq ':' )
if ( defined( $postponed_breakpoint{$type_sequence} ) ) {
my $inc = ( $type eq ':' ) ? 0 : 1;
set_forced_breakpoint( $i - $inc );
delete $postponed_breakpoint{$type_sequence};
}
} ## end if ( $token =~ /^[\)\]\}\:]$/[{[(])
# set breaks at ?/: if they will get separated (and are
# not a ?/: chain), or if the '?' is at the end of the
# line
elsif ( $token eq '?' ) {
my $i_colon = $mate_index_to_go[$i];
if (
$i_colon <= 0 # the ':' is not in this batch
|| $i == 0 # this '?' is the first token of the line
|| $i ==
$max_index_to_go # or this '?' is the last token
)
{
# don't break at a '?' if preceded by ':' on
# this line of previous ?/: pair on this line.
# This is an attempt to preserve a chain of ?/:
# expressions (elsif2.t). And don't break if
# this has a side comment.
set_forced_breakpoint($i)
unless (
$type_sequence == (
$last_colon_sequence_number +
TYPE_SEQUENCE_INCREMENT
)
|| $tokens_to_go[$max_index_to_go] eq '#'
);
set_closing_breakpoint($i);
} ## end if ( $i_colon <= 0 ||...)
} ## end elsif ( $token eq '?' )
} ## end if ($type_sequence)
#print "LISTX sees: i=$i type=$type tok=$token block=$block_type depth=$depth\n";
#------------------------------------------------------------
# Handle Increasing Depth..
#
# prepare for a new list when depth increases
# token $i is a '(','{', or '['
#------------------------------------------------------------
if ( $depth > $current_depth ) {
$breakpoint_stack[$depth] = $forced_breakpoint_count;
$breakpoint_undo_stack[$depth] = $forced_breakpoint_undo_count;
$has_broken_sublist[$depth] = 0;
$identifier_count_stack[$depth] = 0;
$index_before_arrow[$depth] = -1;
$interrupted_list[$depth] = 0;
$item_count_stack[$depth] = 0;
$last_comma_index[$depth] = undef;
$last_dot_index[$depth] = undef;
$last_nonblank_type[$depth] = $last_nonblank_type;
$old_breakpoint_count_stack[$depth] = $old_breakpoint_count;
$opening_structure_index_stack[$depth] = $i;
$rand_or_list[$depth] = [];
$rfor_semicolon_list[$depth] = [];
$i_equals[$depth] = -1;
$want_comma_break[$depth] = 0;
$container_type[$depth] =
( $last_nonblank_type =~ /^(k|=>|&&|\|\||\?|\:|\.)$/ )
? $last_nonblank_token
: "";
$has_old_logical_breakpoints[$depth] = 0;
# if line ends here then signal closing token to break
if ( $next_nonblank_type eq 'b' || $next_nonblank_type eq '#' )
{
set_closing_breakpoint($i);
}
# Not all lists of values should be vertically aligned..
$dont_align[$depth] =
# code BLOCKS are handled at a higher level
( $block_type ne "" )
# certain paren lists
|| ( $type eq '(' ) && (
# it does not usually look good to align a list of
# identifiers in a parameter list, as in:
# my($var1, $var2, ...)
# (This test should probably be refined, for now I'm just
# testing for any keyword)
( $last_nonblank_type eq 'k' )
# a trailing '(' usually indicates a non-list
|| ( $next_nonblank_type eq '(' )
);
# patch to outdent opening brace of long if/for/..
# statements (like this one). See similar coding in
# set_continuation breaks. We have also catch it here for
# short line fragments which otherwise will not go through
# set_continuation_breaks.
if (
$block_type
# if we have the ')' but not its '(' in this batch..
&& ( $last_nonblank_token eq ')' )
&& $mate_index_to_go[$i_last_nonblank_token] < 0
# and user wants brace to left
&& !$rOpts->{'opening-brace-always-on-right'}
&& ( $type eq '{' ) # should be true
&& ( $token eq '{' ) # should be true
)
{
set_forced_breakpoint( $i - 1 );
} ## end if ( $block_type && ( ...))
} ## end if ( $depth > $current_depth)
#------------------------------------------------------------
# Handle Decreasing Depth..
#
# finish off any old list when depth decreases
# token $i is a ')','}', or ']'
#------------------------------------------------------------
elsif ( $depth < $current_depth ) {
check_for_new_minimum_depth($depth);
# force all outer logical containers to break after we see on
# old breakpoint
$has_old_logical_breakpoints[$depth] ||=
$has_old_logical_breakpoints[$current_depth];
# Patch to break between ') {' if the paren list is broken.
# There is similar logic in set_continuation_breaks for
# non-broken lists.
if ( $token eq ')'
&& $next_nonblank_block_type
&& $interrupted_list[$current_depth]
&& $next_nonblank_type eq '{'
&& !$rOpts->{'opening-brace-always-on-right'} )
{
set_forced_breakpoint($i);
} ## end if ( $token eq ')' && ...
#print "LISTY sees: i=$i type=$type tok=$token block=$block_type depth=$depth next=$next_nonblank_type next_block=$next_nonblank_block_type inter=$interrupted_list[$current_depth]\n";
# set breaks at commas if necessary
my ( $bp_count, $do_not_break_apart ) =
set_comma_breakpoints($current_depth);
my $i_opening = $opening_structure_index_stack[$current_depth];
my $saw_opening_structure = ( $i_opening >= 0 );
# this term is long if we had to break at interior commas..
my $is_long_term = $bp_count > 0;
# If this is a short container with one or more comma arrows,
# then we will mark it as a long term to open it if requested.
# $rOpts_comma_arrow_breakpoints =
# 0 - open only if comma precedes closing brace
# 1 - stable: except for one line blocks
# 2 - try to form 1 line blocks
# 3 - ignore =>
# 4 - always open up if vt=0
# 5 - stable: even for one line blocks if vt=0
if ( !$is_long_term
&& $tokens_to_go[$i_opening] =~ /^[\(\{\[]$/
&& $index_before_arrow[ $depth + 1 ] > 0
&& !$opening_vertical_tightness{ $tokens_to_go[$i_opening] }
)
{
$is_long_term = $rOpts_comma_arrow_breakpoints == 4
|| ( $rOpts_comma_arrow_breakpoints == 0
&& $last_nonblank_token eq ',' )
|| ( $rOpts_comma_arrow_breakpoints == 5
&& $old_breakpoint_to_go[$i_opening] );
} ## end if ( !$is_long_term &&...)
# mark term as long if the length between opening and closing
# parens exceeds allowed line length
if ( !$is_long_term && $saw_opening_structure ) {
my $i_opening_minus = find_token_starting_list($i_opening);
# Note: we have to allow for one extra space after a
# closing token so that we do not strand a comma or
# semicolon, hence the '>=' here (oneline.t)
# Note: we ignore left weld lengths here for best results
$is_long_term =
excess_line_length( $i_opening_minus, $i, 1 ) >= 0;
} ## end if ( !$is_long_term &&...)
# We've set breaks after all comma-arrows. Now we have to
# undo them if this can be a one-line block
# (the only breakpoints set will be due to comma-arrows)
if (
# user doesn't require breaking after all comma-arrows
( $rOpts_comma_arrow_breakpoints != 0 )
&& ( $rOpts_comma_arrow_breakpoints != 4 )
# and if the opening structure is in this batch
&& $saw_opening_structure
# and either on the same old line
&& (
$old_breakpoint_count_stack[$current_depth] ==
$last_old_breakpoint_count
# or user wants to form long blocks with arrows
|| $rOpts_comma_arrow_breakpoints == 2
)
# and we made some breakpoints between the opening and closing
&& ( $breakpoint_undo_stack[$current_depth] <
$forced_breakpoint_undo_count )
# and this block is short enough to fit on one line
# Note: use < because need 1 more space for possible comma
&& !$is_long_term
)
{
undo_forced_breakpoint_stack(
$breakpoint_undo_stack[$current_depth] );
} ## end if ( ( $rOpts_comma_arrow_breakpoints...))
# now see if we have any comma breakpoints left
my $has_comma_breakpoints =
( $breakpoint_stack[$current_depth] !=
$forced_breakpoint_count );
# update broken-sublist flag of the outer container
$has_broken_sublist[$depth] =
$has_broken_sublist[$depth]
|| $has_broken_sublist[$current_depth]
|| $is_long_term
|| $has_comma_breakpoints;
# Having come to the closing ')', '}', or ']', now we have to decide if we
# should 'open up' the structure by placing breaks at the opening and
# closing containers. This is a tricky decision. Here are some of the
# basic considerations:
#
# -If this is a BLOCK container, then any breakpoints will have already
# been set (and according to user preferences), so we need do nothing here.
#
# -If we have a comma-separated list for which we can align the list items,
# then we need to do so because otherwise the vertical aligner cannot
# currently do the alignment.
#
# -If this container does itself contain a container which has been broken
# open, then it should be broken open to properly show the structure.
#
# -If there is nothing to align, and no other reason to break apart,
# then do not do it.
#
# We will not break open the parens of a long but 'simple' logical expression.
# For example:
#
# This is an example of a simple logical expression and its formatting:
#
# if ( $bigwasteofspace1 && $bigwasteofspace2
# || $bigwasteofspace3 && $bigwasteofspace4 )
#
# Most people would prefer this than the 'spacey' version:
#
# if (
# $bigwasteofspace1 && $bigwasteofspace2
# || $bigwasteofspace3 && $bigwasteofspace4
# )
#
# To illustrate the rules for breaking logical expressions, consider:
#
# FULLY DENSE:
# if ( $opt_excl
# and ( exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc ))
#
# This is on the verge of being difficult to read. The current default is to
# open it up like this:
#
# DEFAULT:
# if (
# $opt_excl
# and ( exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc )
# )
#
# This is a compromise which tries to avoid being too dense and to spacey.
# A more spaced version would be:
#
# SPACEY:
# if (
# $opt_excl
# and (
# exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc
# )
# )
#
# Some people might prefer the spacey version -- an option could be added. The
# innermost expression contains a long block '( exists $ids_... ')'.
#
# Here is how the logic goes: We will force a break at the 'or' that the
# innermost expression contains, but we will not break apart its opening and
# closing containers because (1) it contains no multi-line sub-containers itself,
# and (2) there is no alignment to be gained by breaking it open like this
#
# and (
# exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc
# )
#
# (although this looks perfectly ok and might be good for long expressions). The
# outer 'if' container, though, contains a broken sub-container, so it will be
# broken open to avoid too much density. Also, since it contains no 'or's, there
# will be a forced break at its 'and'.
# set some flags telling something about this container..
my $is_simple_logical_expression = 0;
if ( $item_count_stack[$current_depth] == 0
&& $saw_opening_structure
&& $tokens_to_go[$i_opening] eq '('
&& $is_logical_container{ $container_type[$current_depth] }
)
{
# This seems to be a simple logical expression with
# no existing breakpoints. Set a flag to prevent
# opening it up.
if ( !$has_comma_breakpoints ) {
$is_simple_logical_expression = 1;
}
# This seems to be a simple logical expression with
# breakpoints (broken sublists, for example). Break
# at all 'or's and '||'s.
else {
set_logical_breakpoints($current_depth);
}
} ## end if ( $item_count_stack...)
if ( $is_long_term
&& @{ $rfor_semicolon_list[$current_depth] } )
{
set_for_semicolon_breakpoints($current_depth);
# open up a long 'for' or 'foreach' container to allow
# leading term alignment unless -lp is used.
$has_comma_breakpoints = 1
unless $rOpts_line_up_parentheses;
} ## end if ( $is_long_term && ...)
if (
# breaks for code BLOCKS are handled at a higher level
!$block_type
# we do not need to break at the top level of an 'if'
# type expression
&& !$is_simple_logical_expression
## modification to keep ': (' containers vertically tight;
## but probably better to let user set -vt=1 to avoid
## inconsistency with other paren types
## && ($container_type[$current_depth] ne ':')
# otherwise, we require one of these reasons for breaking:
&& (
# - this term has forced line breaks
$has_comma_breakpoints
# - the opening container is separated from this batch
# for some reason (comment, blank line, code block)
# - this is a non-paren container spanning multiple lines
|| !$saw_opening_structure
# - this is a long block contained in another breakable
# container
|| ( $is_long_term
&& $container_environment_to_go[$i_opening] ne
'BLOCK' )
)
)
{
# For -lp option, we must put a breakpoint before
# the token which has been identified as starting
# this indentation level. This is necessary for
# proper alignment.
if ( $rOpts_line_up_parentheses && $saw_opening_structure )
{
my $item = $leading_spaces_to_go[ $i_opening + 1 ];
if ( $i_opening + 1 < $max_index_to_go
&& $types_to_go[ $i_opening + 1 ] eq 'b' )
{
$item = $leading_spaces_to_go[ $i_opening + 2 ];
}
if ( defined($item) ) {
my $i_start_2 = $item->get_starting_index();
if (
defined($i_start_2)
# we are breaking after an opening brace, paren,
# so don't break before it too
&& $i_start_2 ne $i_opening
)
{
# Only break for breakpoints at the same
# indentation level as the opening paren
my $test1 = $nesting_depth_to_go[$i_opening];
my $test2 = $nesting_depth_to_go[$i_start_2];
if ( $test2 == $test1 ) {
set_forced_breakpoint( $i_start_2 - 1 );
}
} ## end if ( defined($i_start_2...))
} ## end if ( defined($item) )
} ## end if ( $rOpts_line_up_parentheses...)
# break after opening structure.
# note: break before closing structure will be automatic
if ( $minimum_depth <= $current_depth ) {
set_forced_breakpoint($i_opening)
unless ( $do_not_break_apart
|| is_unbreakable_container($current_depth) );
# break at ',' of lower depth level before opening token
if ( $last_comma_index[$depth] ) {
set_forced_breakpoint( $last_comma_index[$depth] );
}
# break at '.' of lower depth level before opening token
if ( $last_dot_index[$depth] ) {
set_forced_breakpoint( $last_dot_index[$depth] );
}
# break before opening structure if preceded by another
# closing structure and a comma. This is normally
# done by the previous closing brace, but not
# if it was a one-line block.
if ( $i_opening > 2 ) {
my $i_prev =
( $types_to_go[ $i_opening - 1 ] eq 'b' )
? $i_opening - 2
: $i_opening - 1;
if ( $types_to_go[$i_prev] eq ','
&& $types_to_go[ $i_prev - 1 ] =~ /^[\)\}]$/ )
{
set_forced_breakpoint($i_prev);
}
# also break before something like ':(' or '?('
# if appropriate.
elsif (
$types_to_go[$i_prev] =~ /^([k\:\?]|&&|\|\|)$/ )
{
my $token_prev = $tokens_to_go[$i_prev];
if ( $want_break_before{$token_prev} ) {
set_forced_breakpoint($i_prev);
}
} ## end elsif ( $types_to_go[$i_prev...])
} ## end if ( $i_opening > 2 )
} ## end if ( $minimum_depth <=...)
# break after comma following closing structure
if ( $next_type eq ',' ) {
set_forced_breakpoint( $i + 1 );
}
# break before an '=' following closing structure
if (
$is_assignment{$next_nonblank_type}
&& ( $breakpoint_stack[$current_depth] !=
$forced_breakpoint_count )
)
{
set_forced_breakpoint($i);
} ## end if ( $is_assignment{$next_nonblank_type...})
# break at any comma before the opening structure Added
# for -lp, but seems to be good in general. It isn't
# obvious how far back to look; the '5' below seems to
# work well and will catch the comma in something like
# push @list, myfunc( $param, $param, ..
my $icomma = $last_comma_index[$depth];
if ( defined($icomma) && ( $i_opening - $icomma ) < 5 ) {
unless ( $forced_breakpoint_to_go[$icomma] ) {
set_forced_breakpoint($icomma);
}
}
} # end logic to open up a container
# Break open a logical container open if it was already open
elsif ($is_simple_logical_expression
&& $has_old_logical_breakpoints[$current_depth] )
{
set_logical_breakpoints($current_depth);
}
# Handle long container which does not get opened up
elsif ($is_long_term) {
# must set fake breakpoint to alert outer containers that
# they are complex
set_fake_breakpoint();
} ## end elsif ($is_long_term)
} ## end elsif ( $depth < $current_depth)
#------------------------------------------------------------
# Handle this token
#------------------------------------------------------------
$current_depth = $depth;
# handle comma-arrow
if ( $type eq '=>' ) {
next if ( $last_nonblank_type eq '=>' );
next if $rOpts_break_at_old_comma_breakpoints;
next if $rOpts_comma_arrow_breakpoints == 3;
$want_comma_break[$depth] = 1;
$index_before_arrow[$depth] = $i_last_nonblank_token;
next;
} ## end if ( $type eq '=>' )
elsif ( $type eq '.' ) {
$last_dot_index[$depth] = $i;
}
# Turn off alignment if we are sure that this is not a list
# environment. To be safe, we will do this if we see certain
# non-list tokens, such as ';', and also the environment is
# not a list. Note that '=' could be in any of the = operators
# (lextest.t). We can't just use the reported environment
# because it can be incorrect in some cases.
elsif ( ( $type =~ /^[\;\<\>\~]$/ || $is_assignment{$type} )
&& $container_environment_to_go[$i] ne 'LIST' )
{
$dont_align[$depth] = 1;
$want_comma_break[$depth] = 0;
$index_before_arrow[$depth] = -1;
} ## end elsif ( ( $type =~ /^[\;\<\>\~]$/...))
# now just handle any commas
next unless ( $type eq ',' );
$last_dot_index[$depth] = undef;
$last_comma_index[$depth] = $i;
# break here if this comma follows a '=>'
# but not if there is a side comment after the comma
if ( $want_comma_break[$depth] ) {
if ( $next_nonblank_type =~ /^[\)\}\]R]$/ ) {
if ($rOpts_comma_arrow_breakpoints) {
$want_comma_break[$depth] = 0;
next;
}
}
set_forced_breakpoint($i) unless ( $next_nonblank_type eq '#' );
# break before the previous token if it looks safe
# Example of something that we will not try to break before:
# DBI::SQL_SMALLINT() => $ado_consts->{adSmallInt},
# Also we don't want to break at a binary operator (like +):
# $c->createOval(
# $x + $R, $y +
# $R => $x - $R,
# $y - $R, -fill => 'black',
# );
my $ibreak = $index_before_arrow[$depth] - 1;
if ( $ibreak > 0
&& $tokens_to_go[ $ibreak + 1 ] !~ /^[\)\}\]]$/ )
{
if ( $tokens_to_go[$ibreak] eq '-' ) { $ibreak-- }
if ( $types_to_go[$ibreak] eq 'b' ) { $ibreak-- }
if ( $types_to_go[$ibreak] =~ /^[,wiZCUG\(\{\[]$/ ) {
# don't break pointer calls, such as the following:
# File::Spec->curdir => 1,
# (This is tokenized as adjacent 'w' tokens)
##if ( $tokens_to_go[ $ibreak + 1 ] !~ /^->/ ) {
# And don't break before a comma, as in the following:
# ( LONGER_THAN,=> 1,
# EIGHTY_CHARACTERS,=> 2,
# CAUSES_FORMATTING,=> 3,
# LIKE_THIS,=> 4,
# );
# This example is for -tso but should be general rule
if ( $tokens_to_go[ $ibreak + 1 ] ne '->'
&& $tokens_to_go[ $ibreak + 1 ] ne ',' )
{
set_forced_breakpoint($ibreak);
}
} ## end if ( $types_to_go[$ibreak...])
} ## end if ( $ibreak > 0 && $tokens_to_go...)
$want_comma_break[$depth] = 0;
$index_before_arrow[$depth] = -1;
# handle list which mixes '=>'s and ','s:
# treat any list items so far as an interrupted list
$interrupted_list[$depth] = 1;
next;
} ## end if ( $want_comma_break...)
# break after all commas above starting depth
if ( $depth < $starting_depth && !$dont_align[$depth] ) {
set_forced_breakpoint($i) unless ( $next_nonblank_type eq '#' );
next;
}
# add this comma to the list..
my $item_count = $item_count_stack[$depth];
if ( $item_count == 0 ) {
# but do not form a list with no opening structure
# for example:
# open INFILE_COPY, ">$input_file_copy"
# or die ("very long message");
if ( ( $opening_structure_index_stack[$depth] < 0 )
&& $container_environment_to_go[$i] eq 'BLOCK' )
{
$dont_align[$depth] = 1;
}
} ## end if ( $item_count == 0 )
$comma_index[$depth][$item_count] = $i;
++$item_count_stack[$depth];
if ( $last_nonblank_type =~ /^[iR\]]$/ ) {
$identifier_count_stack[$depth]++;
}
} ## end while ( ++$i <= $max_index_to_go)
#-------------------------------------------
# end of loop over all tokens in this batch
#-------------------------------------------
# set breaks for any unfinished lists ..
for ( my $dd = $current_depth ; $dd >= $minimum_depth ; $dd-- ) {
$interrupted_list[$dd] = 1;
$has_broken_sublist[$dd] = 1 if ( $dd < $current_depth );
set_comma_breakpoints($dd);
set_logical_breakpoints($dd)
if ( $has_old_logical_breakpoints[$dd] );
set_for_semicolon_breakpoints($dd);
# break open container...
my $i_opening = $opening_structure_index_stack[$dd];
set_forced_breakpoint($i_opening)
unless (
is_unbreakable_container($dd)
# Avoid a break which would place an isolated ' or "
# on a line
|| ( $type eq 'Q'
&& $i_opening >= $max_index_to_go - 2
&& $token =~ /^['"]$/ )
);
} ## end for ( my $dd = $current_depth...)
# Return a flag indicating if the input file had some good breakpoints.
# This flag will be used to force a break in a line shorter than the
# allowed line length.
if ( $has_old_logical_breakpoints[$current_depth] ) {
$saw_good_breakpoint = 1;
}
# A complex line with one break at an = has a good breakpoint.
# This is not complex ($total_depth_variation=0):
# $res1
# = 10;
#
# This is complex ($total_depth_variation=6):
# $res2 =
# (is_boundp("a", 'self-insert') && is_boundp("b", 'self-insert'));
elsif ($i_old_assignment_break
&& $total_depth_variation > 4
&& $old_breakpoint_count == 1 )
{
$saw_good_breakpoint = 1;
} ## end elsif ( $i_old_assignment_break...)
return $saw_good_breakpoint;
} ## end sub scan_list
} # end scan_list
sub find_token_starting_list {
# When testing to see if a block will fit on one line, some
# previous token(s) may also need to be on the line; particularly
# if this is a sub call. So we will look back at least one
# token. NOTE: This isn't perfect, but not critical, because
# if we mis-identify a block, it will be wrapped and therefore
# fixed the next time it is formatted.
my $i_opening_paren = shift;
my $i_opening_minus = $i_opening_paren;
my $im1 = $i_opening_paren - 1;
my $im2 = $i_opening_paren - 2;
my $im3 = $i_opening_paren - 3;
my $typem1 = $types_to_go[$im1];
my $typem2 = $im2 >= 0 ? $types_to_go[$im2] : 'b';
if ( $typem1 eq ',' || ( $typem1 eq 'b' && $typem2 eq ',' ) ) {
$i_opening_minus = $i_opening_paren;
}
elsif ( $tokens_to_go[$i_opening_paren] eq '(' ) {
$i_opening_minus = $im1 if $im1 >= 0;
# walk back to improve length estimate
for ( my $j = $im1 ; $j >= 0 ; $j-- ) {
last if ( $types_to_go[$j] =~ /^[\(\[\{L\}\]\)Rb,]$/ );
$i_opening_minus = $j;
}
if ( $types_to_go[$i_opening_minus] eq 'b' ) { $i_opening_minus++ }
}
elsif ( $typem1 eq 'k' ) { $i_opening_minus = $im1 }
elsif ( $typem1 eq 'b' && $im2 >= 0 && $types_to_go[$im2] eq 'k' ) {
$i_opening_minus = $im2;
}
return $i_opening_minus;
}
{ # begin set_comma_breakpoints_do
my %is_keyword_with_special_leading_term;
BEGIN {
# These keywords have prototypes which allow a special leading item
# followed by a list
my @q =
qw(formline grep kill map printf sprintf push chmod join pack unshift);
@is_keyword_with_special_leading_term{@q} = (1) x scalar(@q);
}
sub set_comma_breakpoints_do {
# Given a list with some commas, set breakpoints at some of the
# commas, if necessary, to make it easy to read.
my %input_hash = @_;
my $depth = $input_hash{depth};
my $i_opening_paren = $input_hash{i_opening_paren};
my $i_closing_paren = $input_hash{i_closing_paren};
my $item_count = $input_hash{item_count};
my $identifier_count = $input_hash{identifier_count};
my $rcomma_index = $input_hash{rcomma_index};
my $next_nonblank_type = $input_hash{next_nonblank_type};
my $list_type = $input_hash{list_type};
my $interrupted = $input_hash{interrupted};
my $rdo_not_break_apart = $input_hash{rdo_not_break_apart};
my $must_break_open = $input_hash{must_break_open};
# nothing to do if no commas seen
return if ( $item_count < 1 );
my $rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
my $rOpts_maximum_fields_per_table =
$rOpts->{'maximum-fields-per-table'};
my $i_first_comma = $rcomma_index->[0];
my $i_true_last_comma = $rcomma_index->[ $item_count - 1 ];
my $i_last_comma = $i_true_last_comma;
if ( $i_last_comma >= $max_index_to_go ) {
$i_last_comma = $rcomma_index->[ --$item_count - 1 ];
return if ( $item_count < 1 );
}
#---------------------------------------------------------------
# find lengths of all items in the list to calculate page layout
#---------------------------------------------------------------
my $comma_count = $item_count;
my @item_lengths;
my @i_term_begin;
my @i_term_end;
my @i_term_comma;
my $i_prev_plus;
my @max_length = ( 0, 0 );
my $first_term_length;
my $i = $i_opening_paren;
my $is_odd = 1;
foreach my $j ( 0 .. $comma_count - 1 ) {
$is_odd = 1 - $is_odd;
$i_prev_plus = $i + 1;
$i = $rcomma_index->[$j];
my $i_term_end =
( $types_to_go[ $i - 1 ] eq 'b' ) ? $i - 2 : $i - 1;
my $i_term_begin =
( $types_to_go[$i_prev_plus] eq 'b' )
? $i_prev_plus + 1
: $i_prev_plus;
push @i_term_begin, $i_term_begin;
push @i_term_end, $i_term_end;
push @i_term_comma, $i;
# note: currently adding 2 to all lengths (for comma and space)
my $length =
2 + token_sequence_length( $i_term_begin, $i_term_end );
push @item_lengths, $length;
if ( $j == 0 ) {
$first_term_length = $length;
}
else {
if ( $length > $max_length[$is_odd] ) {
$max_length[$is_odd] = $length;
}
}
}
# now we have to make a distinction between the comma count and item
# count, because the item count will be one greater than the comma
# count if the last item is not terminated with a comma
my $i_b =
( $types_to_go[ $i_last_comma + 1 ] eq 'b' )
? $i_last_comma + 1
: $i_last_comma;
my $i_e =
( $types_to_go[ $i_closing_paren - 1 ] eq 'b' )
? $i_closing_paren - 2
: $i_closing_paren - 1;
my $i_effective_last_comma = $i_last_comma;
my $last_item_length = token_sequence_length( $i_b + 1, $i_e );
if ( $last_item_length > 0 ) {
# add 2 to length because other lengths include a comma and a blank
$last_item_length += 2;
push @item_lengths, $last_item_length;
push @i_term_begin, $i_b + 1;
push @i_term_end, $i_e;
push @i_term_comma, undef;
my $i_odd = $item_count % 2;
if ( $last_item_length > $max_length[$i_odd] ) {
$max_length[$i_odd] = $last_item_length;
}
$item_count++;
$i_effective_last_comma = $i_e + 1;
if ( $types_to_go[ $i_b + 1 ] =~ /^[iR\]]$/ ) {
$identifier_count++;
}
}
#---------------------------------------------------------------
# End of length calculations
#---------------------------------------------------------------
#---------------------------------------------------------------
# Compound List Rule 1:
# Break at (almost) every comma for a list containing a broken
# sublist. This has higher priority than the Interrupted List
# Rule.
#---------------------------------------------------------------
if ( $has_broken_sublist[$depth] ) {
# Break at every comma except for a comma between two
# simple, small terms. This prevents long vertical
# columns of, say, just 0's.
my $small_length = 10; # 2 + actual maximum length wanted
# We'll insert a break in long runs of small terms to
# allow alignment in uniform tables.
my $skipped_count = 0;
my $columns = table_columns_available($i_first_comma);
my $fields = int( $columns / $small_length );
if ( $rOpts_maximum_fields_per_table
&& $fields > $rOpts_maximum_fields_per_table )
{
$fields = $rOpts_maximum_fields_per_table;
}
my $max_skipped_count = $fields - 1;
my $is_simple_last_term = 0;
my $is_simple_next_term = 0;
foreach my $j ( 0 .. $item_count ) {
$is_simple_last_term = $is_simple_next_term;
$is_simple_next_term = 0;
if ( $j < $item_count
&& $i_term_end[$j] == $i_term_begin[$j]
&& $item_lengths[$j] <= $small_length )
{
$is_simple_next_term = 1;
}
next if $j == 0;
if ( $is_simple_last_term
&& $is_simple_next_term
&& $skipped_count < $max_skipped_count )
{
$skipped_count++;
}
else {
$skipped_count = 0;
my $i = $i_term_comma[ $j - 1 ];
last unless defined $i;
set_forced_breakpoint($i);
}
}
# always break at the last comma if this list is
# interrupted; we wouldn't want to leave a terminal '{', for
# example.
if ($interrupted) { set_forced_breakpoint($i_true_last_comma) }
return;
}
#my ( $a, $b, $c ) = caller();
#print "LISTX: in set_list $a $c interrupt=$interrupted count=$item_count
#i_first = $i_first_comma i_last=$i_last_comma max=$max_index_to_go\n";
#print "depth=$depth has_broken=$has_broken_sublist[$depth] is_multi=$is_multiline opening_paren=($i_opening_paren) \n";
#---------------------------------------------------------------
# Interrupted List Rule:
# A list is forced to use old breakpoints if it was interrupted
# by side comments or blank lines, or requested by user.
#---------------------------------------------------------------
if ( $rOpts_break_at_old_comma_breakpoints
|| $interrupted
|| $i_opening_paren < 0 )
{
copy_old_breakpoints( $i_first_comma, $i_true_last_comma );
return;
}
#---------------------------------------------------------------
# Looks like a list of items. We have to look at it and size it up.
#---------------------------------------------------------------
my $opening_token = $tokens_to_go[$i_opening_paren];
my $opening_environment =
$container_environment_to_go[$i_opening_paren];
#-------------------------------------------------------------------
# Return if this will fit on one line
#-------------------------------------------------------------------
my $i_opening_minus = find_token_starting_list($i_opening_paren);
return
unless excess_line_length( $i_opening_minus, $i_closing_paren ) > 0;
#-------------------------------------------------------------------
# Now we know that this block spans multiple lines; we have to set
# at least one breakpoint -- real or fake -- as a signal to break
# open any outer containers.
#-------------------------------------------------------------------
set_fake_breakpoint();
# be sure we do not extend beyond the current list length
if ( $i_effective_last_comma >= $max_index_to_go ) {
$i_effective_last_comma = $max_index_to_go - 1;
}
# Set a flag indicating if we need to break open to keep -lp
# items aligned. This is necessary if any of the list terms
# exceeds the available space after the '('.
my $need_lp_break_open = $must_break_open;
if ( $rOpts_line_up_parentheses && !$must_break_open ) {
my $columns_if_unbroken =
maximum_line_length($i_opening_minus) -
total_line_length( $i_opening_minus, $i_opening_paren );
$need_lp_break_open =
( $max_length[0] > $columns_if_unbroken )
|| ( $max_length[1] > $columns_if_unbroken )
|| ( $first_term_length > $columns_if_unbroken );
}
# Specify if the list must have an even number of fields or not.
# It is generally safest to assume an even number, because the
# list items might be a hash list. But if we can be sure that
# it is not a hash, then we can allow an odd number for more
# flexibility.
my $odd_or_even = 2; # 1 = odd field count ok, 2 = want even count
if ( $identifier_count >= $item_count - 1
|| $is_assignment{$next_nonblank_type}
|| ( $list_type && $list_type ne '=>' && $list_type !~ /^[\:\?]$/ )
)
{
$odd_or_even = 1;
}
# do we have a long first term which should be
# left on a line by itself?
my $use_separate_first_term = (
$odd_or_even == 1 # only if we can use 1 field/line
&& $item_count > 3 # need several items
&& $first_term_length >
2 * $max_length[0] - 2 # need long first term
&& $first_term_length >
2 * $max_length[1] - 2 # need long first term
);
# or do we know from the type of list that the first term should
# be placed alone?
if ( !$use_separate_first_term ) {
if ( $is_keyword_with_special_leading_term{$list_type} ) {
$use_separate_first_term = 1;
# should the container be broken open?
if ( $item_count < 3 ) {
if ( $i_first_comma - $i_opening_paren < 4 ) {
${$rdo_not_break_apart} = 1;
}
}
elsif ($first_term_length < 20
&& $i_first_comma - $i_opening_paren < 4 )
{
my $columns = table_columns_available($i_first_comma);
if ( $first_term_length < $columns ) {
${$rdo_not_break_apart} = 1;
}
}
}
}
# if so,
if ($use_separate_first_term) {
# ..set a break and update starting values
$use_separate_first_term = 1;
set_forced_breakpoint($i_first_comma);
$i_opening_paren = $i_first_comma;
$i_first_comma = $rcomma_index->[1];
$item_count--;
return if $comma_count == 1;
shift @item_lengths;
shift @i_term_begin;
shift @i_term_end;
shift @i_term_comma;
}
# if not, update the metrics to include the first term
else {
if ( $first_term_length > $max_length[0] ) {
$max_length[0] = $first_term_length;
}
}
# Field width parameters
my $pair_width = ( $max_length[0] + $max_length[1] );
my $max_width =
( $max_length[0] > $max_length[1] ) ? $max_length[0] : $max_length[1];
# Number of free columns across the page width for laying out tables
my $columns = table_columns_available($i_first_comma);
# Estimated maximum number of fields which fit this space
# This will be our first guess
my $number_of_fields_max =
maximum_number_of_fields( $columns, $odd_or_even, $max_width,
$pair_width );
my $number_of_fields = $number_of_fields_max;
# Find the best-looking number of fields
# and make this our second guess if possible
my ( $number_of_fields_best, $ri_ragged_break_list,
$new_identifier_count )
= study_list_complexity( \@i_term_begin, \@i_term_end, \@item_lengths,
$max_width );
if ( $number_of_fields_best != 0
&& $number_of_fields_best < $number_of_fields_max )
{
$number_of_fields = $number_of_fields_best;
}
# ----------------------------------------------------------------------
# If we are crowded and the -lp option is being used, try to
# undo some indentation
# ----------------------------------------------------------------------
if (
$rOpts_line_up_parentheses
&& (
$number_of_fields == 0
|| ( $number_of_fields == 1
&& $number_of_fields != $number_of_fields_best )
)
)
{
my $available_spaces = get_available_spaces_to_go($i_first_comma);
if ( $available_spaces > 0 ) {
my $spaces_wanted = $max_width - $columns; # for 1 field
if ( $number_of_fields_best == 0 ) {
$number_of_fields_best =
get_maximum_fields_wanted( \@item_lengths );
}
if ( $number_of_fields_best != 1 ) {
my $spaces_wanted_2 =
1 + $pair_width - $columns; # for 2 fields
if ( $available_spaces > $spaces_wanted_2 ) {
$spaces_wanted = $spaces_wanted_2;
}
}
if ( $spaces_wanted > 0 ) {
my $deleted_spaces =
reduce_lp_indentation( $i_first_comma, $spaces_wanted );
# redo the math
if ( $deleted_spaces > 0 ) {
$columns = table_columns_available($i_first_comma);
$number_of_fields_max =
maximum_number_of_fields( $columns, $odd_or_even,
$max_width, $pair_width );
$number_of_fields = $number_of_fields_max;
if ( $number_of_fields_best == 1
&& $number_of_fields >= 1 )
{
$number_of_fields = $number_of_fields_best;
}
}
}
}
}
# try for one column if two won't work
if ( $number_of_fields <= 0 ) {
$number_of_fields = int( $columns / $max_width );
}
# The user can place an upper bound on the number of fields,
# which can be useful for doing maintenance on tables
if ( $rOpts_maximum_fields_per_table
&& $number_of_fields > $rOpts_maximum_fields_per_table )
{
$number_of_fields = $rOpts_maximum_fields_per_table;
}
# How many columns (characters) and lines would this container take
# if no additional whitespace were added?
my $packed_columns = token_sequence_length( $i_opening_paren + 1,
$i_effective_last_comma + 1 );
if ( $columns <= 0 ) { $columns = 1 } # avoid divide by zero
my $packed_lines = 1 + int( $packed_columns / $columns );
# are we an item contained in an outer list?
my $in_hierarchical_list = $next_nonblank_type =~ /^[\}\,]$/;
if ( $number_of_fields <= 0 ) {
# #---------------------------------------------------------------
# # We're in trouble. We can't find a single field width that works.
# # There is no simple answer here; we may have a single long list
# # item, or many.
# #---------------------------------------------------------------
#
# In many cases, it may be best to not force a break if there is just one
# comma, because the standard continuation break logic will do a better
# job without it.
#
# In the common case that all but one of the terms can fit
# on a single line, it may look better not to break open the
# containing parens. Consider, for example
#
# $color =
# join ( '/',
# sort { $color_value{$::a} <=> $color_value{$::b}; }
# keys %colors );
#
# which will look like this with the container broken:
#
# $color = join (
# '/',
# sort { $color_value{$::a} <=> $color_value{$::b}; } keys %colors
# );
#
# Here is an example of this rule for a long last term:
#
# log_message( 0, 256, 128,
# "Number of routes in adj-RIB-in to be considered: $peercount" );
#
# And here is an example with a long first term:
#
# $s = sprintf(
# "%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
# $r, $pu, $ps, $cu, $cs, $tt
# )
# if $style eq 'all';
my $i_last_comma = $rcomma_index->[ $comma_count - 1 ];
my $long_last_term = excess_line_length( 0, $i_last_comma ) <= 0;
my $long_first_term =
excess_line_length( $i_first_comma + 1, $max_index_to_go ) <= 0;
# break at every comma ...
if (
# if requested by user or is best looking
$number_of_fields_best == 1
# or if this is a sublist of a larger list
|| $in_hierarchical_list
# or if multiple commas and we don't have a long first or last
# term
|| ( $comma_count > 1
&& !( $long_last_term || $long_first_term ) )
)
{
foreach ( 0 .. $comma_count - 1 ) {
set_forced_breakpoint( $rcomma_index->[$_] );
}
}
elsif ($long_last_term) {
set_forced_breakpoint($i_last_comma);
${$rdo_not_break_apart} = 1 unless $must_break_open;
}
elsif ($long_first_term) {
set_forced_breakpoint($i_first_comma);
}
else {
# let breaks be defined by default bond strength logic
}
return;
}
# --------------------------------------------------------
# We have a tentative field count that seems to work.
# How many lines will this require?
# --------------------------------------------------------
my $formatted_lines = $item_count / ($number_of_fields);
if ( $formatted_lines != int $formatted_lines ) {
$formatted_lines = 1 + int $formatted_lines;
}
# So far we've been trying to fill out to the right margin. But
# compact tables are easier to read, so let's see if we can use fewer
# fields without increasing the number of lines.
$number_of_fields =
compactify_table( $item_count, $number_of_fields, $formatted_lines,
$odd_or_even );
# How many spaces across the page will we fill?
my $columns_per_line =
( int $number_of_fields / 2 ) * $pair_width +
( $number_of_fields % 2 ) * $max_width;
my $formatted_columns;
if ( $number_of_fields > 1 ) {
$formatted_columns =
( $pair_width * ( int( $item_count / 2 ) ) +
( $item_count % 2 ) * $max_width );
}
else {
$formatted_columns = $max_width * $item_count;
}
if ( $formatted_columns < $packed_columns ) {
$formatted_columns = $packed_columns;
}
my $unused_columns = $formatted_columns - $packed_columns;
# set some empirical parameters to help decide if we should try to
# align; high sparsity does not look good, especially with few lines
my $sparsity = ($unused_columns) / ($formatted_columns);
my $max_allowed_sparsity =
( $item_count < 3 ) ? 0.1
: ( $packed_lines == 1 ) ? 0.15
: ( $packed_lines == 2 ) ? 0.4
: 0.7;
# Begin check for shortcut methods, which avoid treating a list
# as a table for relatively small parenthesized lists. These
# are usually easier to read if not formatted as tables.
if (
$packed_lines <= 2 # probably can fit in 2 lines
&& $item_count < 9 # doesn't have too many items
&& $opening_environment eq 'BLOCK' # not a sub-container
&& $opening_token eq '(' # is paren list
)
{
# Shortcut method 1: for -lp and just one comma:
# This is a no-brainer, just break at the comma.
if (
$rOpts_line_up_parentheses # -lp
&& $item_count == 2 # two items, one comma
&& !$must_break_open
)
{
my $i_break = $rcomma_index->[0];
set_forced_breakpoint($i_break);
${$rdo_not_break_apart} = 1;
return;
}
# method 2 is for most small ragged lists which might look
# best if not displayed as a table.
if (
( $number_of_fields == 2 && $item_count == 3 )
|| (
$new_identifier_count > 0 # isn't all quotes
&& $sparsity > 0.15
) # would be fairly spaced gaps if aligned
)
{
my $break_count = set_ragged_breakpoints( \@i_term_comma,
$ri_ragged_break_list );
++$break_count if ($use_separate_first_term);
# NOTE: we should really use the true break count here,
# which can be greater if there are large terms and
# little space, but usually this will work well enough.
unless ($must_break_open) {
if ( $break_count <= 1 ) {
${$rdo_not_break_apart} = 1;
}
elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
{
${$rdo_not_break_apart} = 1;
}
}
return;
}
} # end shortcut methods
# debug stuff
FORMATTER_DEBUG_FLAG_SPARSE && do {
print STDOUT
"SPARSE:cols=$columns commas=$comma_count items:$item_count ids=$identifier_count pairwidth=$pair_width fields=$number_of_fields lines packed: $packed_lines packed_cols=$packed_columns fmtd:$formatted_lines cols /line:$columns_per_line unused:$unused_columns fmtd:$formatted_columns sparsity=$sparsity allow=$max_allowed_sparsity\n";
};
#---------------------------------------------------------------
# Compound List Rule 2:
# If this list is too long for one line, and it is an item of a
# larger list, then we must format it, regardless of sparsity
# (ian.t). One reason that we have to do this is to trigger
# Compound List Rule 1, above, which causes breaks at all commas of
# all outer lists. In this way, the structure will be properly
# displayed.
#---------------------------------------------------------------
# Decide if this list is too long for one line unless broken
my $total_columns = table_columns_available($i_opening_paren);
my $too_long = $packed_columns > $total_columns;
# For a paren list, include the length of the token just before the
# '(' because this is likely a sub call, and we would have to
# include the sub name on the same line as the list. This is still
# imprecise, but not too bad. (steve.t)
if ( !$too_long && $i_opening_paren > 0 && $opening_token eq '(' ) {
$too_long = excess_line_length( $i_opening_minus,
$i_effective_last_comma + 1 ) > 0;
}
# FIXME: For an item after a '=>', try to include the length of the
# thing before the '=>'. This is crude and should be improved by
# actually looking back token by token.
if ( !$too_long && $i_opening_paren > 0 && $list_type eq '=>' ) {
my $i_opening_minus = $i_opening_paren - 4;
if ( $i_opening_minus >= 0 ) {
$too_long = excess_line_length( $i_opening_minus,
$i_effective_last_comma + 1 ) > 0;
}
}
# Always break lists contained in '[' and '{' if too long for 1 line,
# and always break lists which are too long and part of a more complex
# structure.
my $must_break_open_container = $must_break_open
|| ( $too_long
&& ( $in_hierarchical_list || $opening_token ne '(' ) );
#print "LISTX: next=$next_nonblank_type avail cols=$columns packed=$packed_columns must format = $must_break_open_container too-long=$too_long opening=$opening_token list_type=$list_type formatted_lines=$formatted_lines packed=$packed_lines max_sparsity= $max_allowed_sparsity sparsity=$sparsity \n";
#---------------------------------------------------------------
# The main decision:
# Now decide if we will align the data into aligned columns. Do not
# attempt to align columns if this is a tiny table or it would be
# too spaced. It seems that the more packed lines we have, the
# sparser the list that can be allowed and still look ok.
#---------------------------------------------------------------
if ( ( $formatted_lines < 3 && $packed_lines < $formatted_lines )
|| ( $formatted_lines < 2 )
|| ( $unused_columns > $max_allowed_sparsity * $formatted_columns )
)
{
#---------------------------------------------------------------
# too sparse: would look ugly if aligned in a table;
#---------------------------------------------------------------
# use old breakpoints if this is a 'big' list
# FIXME: goal is to improve set_ragged_breakpoints so that
# this is not necessary.
if ( $packed_lines > 2 && $item_count > 10 ) {
write_logfile_entry("List sparse: using old breakpoints\n");
copy_old_breakpoints( $i_first_comma, $i_last_comma );
}
# let the continuation logic handle it if 2 lines
else {
my $break_count = set_ragged_breakpoints( \@i_term_comma,
$ri_ragged_break_list );
++$break_count if ($use_separate_first_term);
unless ($must_break_open_container) {
if ( $break_count <= 1 ) {
${$rdo_not_break_apart} = 1;
}
elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
{
${$rdo_not_break_apart} = 1;
}
}
}
return;
}
#---------------------------------------------------------------
# go ahead and format as a table
#---------------------------------------------------------------
write_logfile_entry(
"List: auto formatting with $number_of_fields fields/row\n");
my $j_first_break =
$use_separate_first_term ? $number_of_fields : $number_of_fields - 1;
for (
my $j = $j_first_break ;
$j < $comma_count ;
$j += $number_of_fields
)
{
my $i = $rcomma_index->[$j];
set_forced_breakpoint($i);
}
return;
}
}
sub study_list_complexity {
# Look for complex tables which should be formatted with one term per line.
# Returns the following:
#
# \@i_ragged_break_list = list of good breakpoints to avoid lines
# which are hard to read
# $number_of_fields_best = suggested number of fields based on
# complexity; = 0 if any number may be used.
#
my ( $ri_term_begin, $ri_term_end, $ritem_lengths, $max_width ) = @_;
my $item_count = @{$ri_term_begin};
my $complex_item_count = 0;
my $number_of_fields_best = $rOpts->{'maximum-fields-per-table'};
my $i_max = @{$ritem_lengths} - 1;
##my @item_complexity;
my $i_last_last_break = -3;
my $i_last_break = -2;
my @i_ragged_break_list;
my $definitely_complex = 30;
my $definitely_simple = 12;
my $quote_count = 0;
for my $i ( 0 .. $i_max ) {
my $ib = $ri_term_begin->[$i];
my $ie = $ri_term_end->[$i];
# define complexity: start with the actual term length
my $weighted_length = ( $ritem_lengths->[$i] - 2 );
##TBD: join types here and check for variations
##my $str=join "", @tokens_to_go[$ib..$ie];
my $is_quote = 0;
if ( $types_to_go[$ib] =~ /^[qQ]$/ ) {
$is_quote = 1;
$quote_count++;
}
elsif ( $types_to_go[$ib] =~ /^[w\-]$/ ) {
$quote_count++;
}
if ( $ib eq $ie ) {
if ( $is_quote && $tokens_to_go[$ib] =~ /\s/ ) {
$complex_item_count++;
$weighted_length *= 2;
}
else {
}
}
else {
if ( grep { $_ eq 'b' } @types_to_go[ $ib .. $ie ] ) {
$complex_item_count++;
$weighted_length *= 2;
}
if ( grep { $_ eq '..' } @types_to_go[ $ib .. $ie ] ) {
$weighted_length += 4;
}
}
# add weight for extra tokens.
$weighted_length += 2 * ( $ie - $ib );
## my $BUB = join '', @tokens_to_go[$ib..$ie];
## print "# COMPLEXITY:$weighted_length $BUB\n";
##push @item_complexity, $weighted_length;
# now mark a ragged break after this item it if it is 'long and
# complex':
if ( $weighted_length >= $definitely_complex ) {
# if we broke after the previous term
# then break before it too
if ( $i_last_break == $i - 1
&& $i > 1
&& $i_last_last_break != $i - 2 )
{
## FIXME: don't strand a small term
pop @i_ragged_break_list;
push @i_ragged_break_list, $i - 2;
push @i_ragged_break_list, $i - 1;
}
push @i_ragged_break_list, $i;
$i_last_last_break = $i_last_break;
$i_last_break = $i;
}
# don't break before a small last term -- it will
# not look good on a line by itself.
elsif ($i == $i_max
&& $i_last_break == $i - 1
&& $weighted_length <= $definitely_simple )
{
pop @i_ragged_break_list;
}
}
my $identifier_count = $i_max + 1 - $quote_count;
# Need more tuning here..
if ( $max_width > 12
&& $complex_item_count > $item_count / 2
&& $number_of_fields_best != 2 )
{
$number_of_fields_best = 1;
}
return ( $number_of_fields_best, \@i_ragged_break_list, $identifier_count );
}
sub get_maximum_fields_wanted {
# Not all tables look good with more than one field of items.
# This routine looks at a table and decides if it should be
# formatted with just one field or not.
# This coding is still under development.
my ($ritem_lengths) = @_;
my $number_of_fields_best = 0;
# For just a few items, we tentatively assume just 1 field.
my $item_count = @{$ritem_lengths};
if ( $item_count <= 5 ) {
$number_of_fields_best = 1;
}
# For larger tables, look at it both ways and see what looks best
else {
my $is_odd = 1;
my @max_length = ( 0, 0 );
my @last_length_2 = ( undef, undef );
my @first_length_2 = ( undef, undef );
my $last_length = undef;
my $total_variation_1 = 0;
my $total_variation_2 = 0;
my @total_variation_2 = ( 0, 0 );
foreach my $j ( 0 .. $item_count - 1 ) {
$is_odd = 1 - $is_odd;
my $length = $ritem_lengths->[$j];
if ( $length > $max_length[$is_odd] ) {
$max_length[$is_odd] = $length;
}
if ( defined($last_length) ) {
my $dl = abs( $length - $last_length );
$total_variation_1 += $dl;
}
$last_length = $length;
my $ll = $last_length_2[$is_odd];
if ( defined($ll) ) {
my $dl = abs( $length - $ll );
$total_variation_2[$is_odd] += $dl;
}
else {
$first_length_2[$is_odd] = $length;
}
$last_length_2[$is_odd] = $length;
}
$total_variation_2 = $total_variation_2[0] + $total_variation_2[1];
my $factor = ( $item_count > 10 ) ? 1 : ( $item_count > 5 ) ? 0.75 : 0;
unless ( $total_variation_2 < $factor * $total_variation_1 ) {
$number_of_fields_best = 1;
}
}
return ($number_of_fields_best);
}
sub table_columns_available {
my $i_first_comma = shift;
my $columns =
maximum_line_length($i_first_comma) -
leading_spaces_to_go($i_first_comma);
# Patch: the vertical formatter does not line up lines whose lengths
# exactly equal the available line length because of allowances
# that must be made for side comments. Therefore, the number of
# available columns is reduced by 1 character.
$columns -= 1;
return $columns;
}
sub maximum_number_of_fields {
# how many fields will fit in the available space?
my ( $columns, $odd_or_even, $max_width, $pair_width ) = @_;
my $max_pairs = int( $columns / $pair_width );
my $number_of_fields = $max_pairs * 2;
if ( $odd_or_even == 1
&& $max_pairs * $pair_width + $max_width <= $columns )
{
$number_of_fields++;
}
return $number_of_fields;
}
sub compactify_table {
# given a table with a certain number of fields and a certain number
# of lines, see if reducing the number of fields will make it look
# better.
my ( $item_count, $number_of_fields, $formatted_lines, $odd_or_even ) = @_;
if ( $number_of_fields >= $odd_or_even * 2 && $formatted_lines > 0 ) {
my $min_fields;
for (
$min_fields = $number_of_fields ;
$min_fields >= $odd_or_even
&& $min_fields * $formatted_lines >= $item_count ;
$min_fields -= $odd_or_even
)
{
$number_of_fields = $min_fields;
}
}
return $number_of_fields;
}
sub set_ragged_breakpoints {
# Set breakpoints in a list that cannot be formatted nicely as a
# table.
my ( $ri_term_comma, $ri_ragged_break_list ) = @_;
my $break_count = 0;
foreach ( @{$ri_ragged_break_list} ) {
my $j = $ri_term_comma->[$_];
if ($j) {
set_forced_breakpoint($j);
$break_count++;
}
}
return $break_count;
}
sub copy_old_breakpoints {
my ( $i_first_comma, $i_last_comma ) = @_;
for my $i ( $i_first_comma .. $i_last_comma ) {
if ( $old_breakpoint_to_go[$i] ) {
set_forced_breakpoint($i);
}
}
return;
}
sub set_nobreaks {
my ( $i, $j ) = @_;
if ( $i >= 0 && $i <= $j && $j <= $max_index_to_go ) {
FORMATTER_DEBUG_FLAG_NOBREAK && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"NOBREAK: forced_breakpoint $forced_breakpoint_count from $a $c with i=$i max=$max_index_to_go type=$types_to_go[$i]\n";
};
@nobreak_to_go[ $i .. $j ] = (1) x ( $j - $i + 1 );
}
# shouldn't happen; non-critical error
else {
FORMATTER_DEBUG_FLAG_NOBREAK && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"NOBREAK ERROR: from $a $c with i=$i j=$j max=$max_index_to_go\n";
};
}
return;
}
sub set_fake_breakpoint {
# Just bump up the breakpoint count as a signal that there are breaks.
# This is useful if we have breaks but may want to postpone deciding where
# to make them.
$forced_breakpoint_count++;
return;
}
sub set_forced_breakpoint {
my $i = shift;
return unless defined $i && $i >= 0;
# no breaks between welded tokens
return if ( weld_len_right_to_go($i) );
# when called with certain tokens, use bond strengths to decide
# if we break before or after it
my $token = $tokens_to_go[$i];
if ( $token =~ /^([\=\.\,\:\?]|and|or|xor|&&|\|\|)$/ ) {
if ( $want_break_before{$token} && $i >= 0 ) { $i-- }
}
# breaks are forced before 'if' and 'unless'
elsif ( $is_if_unless{$token} ) { $i-- }
if ( $i >= 0 && $i <= $max_index_to_go ) {
my $i_nonblank = ( $types_to_go[$i] ne 'b' ) ? $i : $i - 1;
FORMATTER_DEBUG_FLAG_FORCE && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"FORCE $forced_breakpoint_count from $a $c with i=$i_nonblank max=$max_index_to_go tok=$tokens_to_go[$i_nonblank] type=$types_to_go[$i_nonblank] nobr=$nobreak_to_go[$i_nonblank]\n";
};
if ( $i_nonblank >= 0 && $nobreak_to_go[$i_nonblank] == 0 ) {
$forced_breakpoint_to_go[$i_nonblank] = 1;
if ( $i_nonblank > $index_max_forced_break ) {
$index_max_forced_break = $i_nonblank;
}
$forced_breakpoint_count++;
$forced_breakpoint_undo_stack[ $forced_breakpoint_undo_count++ ] =
$i_nonblank;
# if we break at an opening container..break at the closing
if ( $tokens_to_go[$i_nonblank] =~ /^[\{\[\(\?]$/ ) {
set_closing_breakpoint($i_nonblank);
}
}
}
return;
}
sub clear_breakpoint_undo_stack {
$forced_breakpoint_undo_count = 0;
return;
}
sub undo_forced_breakpoint_stack {
my $i_start = shift;
if ( $i_start < 0 ) {
$i_start = 0;
my ( $a, $b, $c ) = caller();
warning(
"Program Bug: undo_forced_breakpoint_stack from $a $c has i=$i_start "
);
}
while ( $forced_breakpoint_undo_count > $i_start ) {
my $i =
$forced_breakpoint_undo_stack[ --$forced_breakpoint_undo_count ];
if ( $i >= 0 && $i <= $max_index_to_go ) {
$forced_breakpoint_to_go[$i] = 0;
$forced_breakpoint_count--;
FORMATTER_DEBUG_FLAG_UNDOBP && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"UNDOBP: undo forced_breakpoint i=$i $forced_breakpoint_undo_count from $a $c max=$max_index_to_go\n";
};
}
# shouldn't happen, but not a critical error
else {
FORMATTER_DEBUG_FLAG_UNDOBP && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"Program Bug: undo_forced_breakpoint from $a $c has i=$i but max=$max_index_to_go";
};
}
}
return;
}
{ # begin recombine_breakpoints
my %is_amp_amp;
my %is_ternary;
my %is_math_op;
my %is_plus_minus;
my %is_mult_div;
BEGIN {
my @q;
@q = qw( && || );
@is_amp_amp{@q} = (1) x scalar(@q);
@q = qw( ? : );
@is_ternary{@q} = (1) x scalar(@q);
@q = qw( + - * / );
@is_math_op{@q} = (1) x scalar(@q);
@q = qw( + - );
@is_plus_minus{@q} = (1) x scalar(@q);
@q = qw( * / );
@is_mult_div{@q} = (1) x scalar(@q);
}
sub Debug_dump_breakpoints {
# Debug routine to dump current breakpoints...not normally called
# We are given indexes to the current lines:
# $ri_beg = ref to array of BEGinning indexes of each line
# $ri_end = ref to array of ENDing indexes of each line
my ( $ri_beg, $ri_end, $msg ) = @_;
print STDERR "----Dumping breakpoints from: $msg----\n";
for my $n ( 0 .. @{$ri_end} - 1 ) {
my $ibeg = $ri_beg->[$n];
my $iend = $ri_end->[$n];
my $text = "";
foreach my $i ( $ibeg .. $iend ) {
$text .= $tokens_to_go[$i];
}
print STDERR "$n ($ibeg:$iend) $text\n";
}
print STDERR "----\n";
return;
}
sub delete_one_line_semicolons {
my ( $self, $ri_beg, $ri_end ) = @_;
my $rLL = $self->{rLL};
my $K_opening_container = $self->{K_opening_container};
# Walk down the lines of this batch and delete any semicolons
# terminating one-line blocks;
my $nmax = @{$ri_end} - 1;
foreach my $n ( 0 .. $nmax ) {
my $i_beg = $ri_beg->[$n];
my $i_e = $ri_end->[$n];
my $K_beg = $K_to_go[$i_beg];
my $K_e = $K_to_go[$i_e];
my $K_end = $K_e;
my $type_end = $rLL->[$K_end]->[_TYPE_];
if ( $type_end eq '#' ) {
$K_end = $self->K_previous_nonblank($K_end);
if ( defined($K_end) ) { $type_end = $rLL->[$K_end]->[_TYPE_]; }
}
# we are looking for a line ending in closing brace
next
unless ( $type_end eq '}' && $rLL->[$K_end]->[_TOKEN_] eq '}' );
# ...and preceded by a semicolon on the same line
my $K_semicolon = $self->K_previous_nonblank($K_end);
my $i_semicolon = $i_beg + ( $K_semicolon - $K_beg );
next if ( $i_semicolon <= $i_beg );
next unless ( $rLL->[$K_semicolon]->[_TYPE_] eq ';' );
# safety check - shouldn't happen
if ( $types_to_go[$i_semicolon] ne ';' ) {
Fault("unexpected type looking for semicolon, ignoring");
next;
}
# ... with the corresponding opening brace on the same line
my $type_sequence = $rLL->[$K_end]->[_TYPE_SEQUENCE_];
my $K_opening = $K_opening_container->{$type_sequence};
my $i_opening = $i_beg + ( $K_opening - $K_beg );
next if ( $i_opening < $i_beg );
# ... and only one semicolon between these braces
my $semicolon_count = 0;
foreach my $K ( $K_opening + 1 .. $K_semicolon - 1 ) {
if ( $rLL->[$K]->[_TYPE_] eq ';' ) {
$semicolon_count++;
last;
}
}
next if ($semicolon_count);
# ...ok, then make the semicolon invisible
$tokens_to_go[$i_semicolon] = "";
$token_lengths_to_go[$i_semicolon] = 0;
$rLL->[$K_semicolon]->[_TOKEN_] = "";
$rLL->[$K_semicolon]->[_TOKEN_LENGTH_] = 0;
}
return;
}
sub unmask_phantom_semicolons {
my ( $self, $ri_beg, $ri_end ) = @_;
# Walk down the lines of this batch and unmask any invisible line-ending
# semicolons. They were placed by sub respace_tokens but we only now
# know if we actually need them.
my $rLL = $self->{rLL};
my $nmax = @{$ri_end} - 1;
foreach my $n ( 0 .. $nmax ) {
my $i = $ri_end->[$n];
if ( $types_to_go[$i] eq ';' && $tokens_to_go[$i] eq '' ) {
my $tok = ';';
my $tok_len = 1;
if ( $want_left_space{';'} != WS_NO ) {
$tok = ' ;';
$tok_len = 2;
}
$tokens_to_go[$i] = $tok;
$token_lengths_to_go[$i] = $tok_len;
my $KK = $K_to_go[$i];
$rLL->[$KK]->[_TOKEN_] = $tok;
$rLL->[$KK]->[_TOKEN_LENGTH_] = $tok_len;
my $line_number = 1 + $self->get_old_line_index($KK);
note_added_semicolon($line_number);
}
}
return;
}
sub recombine_breakpoints {
# sub set_continuation_breaks is very liberal in setting line breaks
# for long lines, always setting breaks at good breakpoints, even
# when that creates small lines. Sometimes small line fragments
# are produced which would look better if they were combined.
# That's the task of this routine.
#
# We are given indexes to the current lines:
# $ri_beg = ref to array of BEGinning indexes of each line
# $ri_end = ref to array of ENDing indexes of each line
my ( $ri_beg, $ri_end ) = @_;
my $rOpts_short_concatenation_item_length =
$rOpts->{'short-concatenation-item-length'};
my $rOpts_break_at_old_semicolon_breakpoints =
$rOpts->{'break-at-old-semicolon-breakpoints'};
# Make a list of all good joining tokens between the lines
# n-1 and n.
my @joint;
my $nmax = @{$ri_end} - 1;
for my $n ( 1 .. $nmax ) {
my $ibeg_1 = $ri_beg->[ $n - 1 ];
my $iend_1 = $ri_end->[ $n - 1 ];
my $iend_2 = $ri_end->[$n];
my $ibeg_2 = $ri_beg->[$n];
my ( $itok, $itokp, $itokm );
foreach my $itest ( $iend_1, $ibeg_2 ) {
my $type = $types_to_go[$itest];
if ( $is_math_op{$type}
|| $is_amp_amp{$type}
|| $is_assignment{$type}
|| $type eq ':' )
{
$itok = $itest;
}
}
$joint[$n] = [$itok];
}
my $more_to_do = 1;
# We keep looping over all of the lines of this batch
# until there are no more possible recombinations
my $nmax_last = @{$ri_end};
my $reverse = 0;
while ($more_to_do) {
my $n_best = 0;
my $bs_best;
my $nmax = @{$ri_end} - 1;
# Safety check for infinite loop
unless ( $nmax < $nmax_last ) {
# Shouldn't happen because splice below decreases nmax on each
# pass.
Fault("Program bug-infinite loop in recombine breakpoints\n");
}
$nmax_last = $nmax;
$more_to_do = 0;
my $skip_Section_3;
my $leading_amp_count = 0;
my $this_line_is_semicolon_terminated;
# loop over all remaining lines in this batch
for my $iter ( 1 .. $nmax ) {
# alternating sweep direction gives symmetric results
# for recombining lines which exceed the line length
# such as eval {{{{.... }}}}
my $n;
if ($reverse) { $n = 1 + $nmax - $iter; }
else { $n = $iter }
#----------------------------------------------------------
# If we join the current pair of lines,
# line $n-1 will become the left part of the joined line
# line $n will become the right part of the joined line
#
# Here are Indexes of the endpoint tokens of the two lines:
#
# -----line $n-1--- | -----line $n-----
# $ibeg_1 $iend_1 | $ibeg_2 $iend_2
# ^
# |
# We want to decide if we should remove the line break
# between the tokens at $iend_1 and $ibeg_2
#
# We will apply a number of ad-hoc tests to see if joining
# here will look ok. The code will just issue a 'next'
# command if the join doesn't look good. If we get through
# the gauntlet of tests, the lines will be recombined.
#----------------------------------------------------------
#
# beginning and ending tokens of the lines we are working on
my $ibeg_1 = $ri_beg->[ $n - 1 ];
my $iend_1 = $ri_end->[ $n - 1 ];
my $iend_2 = $ri_end->[$n];
my $ibeg_2 = $ri_beg->[$n];
my $ibeg_nmax = $ri_beg->[$nmax];
# combined line cannot be too long
my $excess = excess_line_length( $ibeg_1, $iend_2, 1, 1 );
next if ( $excess > 0 );
my $type_iend_1 = $types_to_go[$iend_1];
my $type_iend_2 = $types_to_go[$iend_2];
my $type_ibeg_1 = $types_to_go[$ibeg_1];
my $type_ibeg_2 = $types_to_go[$ibeg_2];
# terminal token of line 2 if any side comment is ignored:
my $iend_2t = $iend_2;
my $type_iend_2t = $type_iend_2;
# some beginning indexes of other lines, which may not exist
my $ibeg_0 = $n > 1 ? $ri_beg->[ $n - 2 ] : -1;
my $ibeg_3 = $n < $nmax ? $ri_beg->[ $n + 1 ] : -1;
my $ibeg_4 = $n + 2 <= $nmax ? $ri_beg->[ $n + 2 ] : -1;
my $bs_tweak = 0;
#my $depth_increase=( $nesting_depth_to_go[$ibeg_2] -
# $nesting_depth_to_go[$ibeg_1] );
FORMATTER_DEBUG_FLAG_RECOMBINE && do {
print STDERR
"RECOMBINE: n=$n imid=$iend_1 if=$ibeg_1 type=$type_ibeg_1 =$tokens_to_go[$ibeg_1] next_type=$type_ibeg_2 next_tok=$tokens_to_go[$ibeg_2]\n";
};
# If line $n is the last line, we set some flags and
# do any special checks for it
if ( $n == $nmax ) {
next
if ( $type_ibeg_2 eq ';'
&& $rOpts_break_at_old_semicolon_breakpoints );
# a terminal '{' should stay where it is
# unless preceded by a fat comma
next if ( $type_ibeg_2 eq '{' && $type_iend_1 ne '=>' );
if ( $type_iend_2 eq '#'
&& $iend_2 - $ibeg_2 >= 2
&& $types_to_go[ $iend_2 - 1 ] eq 'b' )
{
$iend_2t = $iend_2 - 2;
$type_iend_2t = $types_to_go[$iend_2t];
}
$this_line_is_semicolon_terminated = $type_iend_2t eq ';';
}
#----------------------------------------------------------
# Recombine Section 0:
# Examine the special token joining this line pair, if any.
# Put as many tests in this section to avoid duplicate code and
# to make formatting independent of whether breaks are to the
# left or right of an operator.
#----------------------------------------------------------
my ($itok) = @{ $joint[$n] };
if ($itok) {
# FIXME: Patch - may not be necessary
my $iend_1 =
$type_iend_1 eq 'b'
? $iend_1 - 1
: $iend_1;
my $iend_2 =
$type_iend_2 eq 'b'
? $iend_2 - 1
: $iend_2;
## END PATCH
my $type = $types_to_go[$itok];
if ( $type eq ':' ) {
# do not join at a colon unless it disobeys the break request
if ( $itok eq $iend_1 ) {
next unless $want_break_before{$type};
}
else {
$leading_amp_count++;
next if $want_break_before{$type};
}
} ## end if ':'
# handle math operators + - * /
elsif ( $is_math_op{$type} ) {
# Combine these lines if this line is a single
# number, or if it is a short term with same
# operator as the previous line. For example, in
# the following code we will combine all of the
# short terms $A, $B, $C, $D, $E, $F, together
# instead of leaving them one per line:
# my $time =
# $A * $B * $C * $D * $E * $F *
# ( 2. * $eps * $sigma * $area ) *
# ( 1. / $tcold**3 - 1. / $thot**3 );
# This can be important in math-intensive code.
my $good_combo;
my $itokp = min( $inext_to_go[$itok], $iend_2 );
my $itokpp = min( $inext_to_go[$itokp], $iend_2 );
my $itokm = max( $iprev_to_go[$itok], $ibeg_1 );
my $itokmm = max( $iprev_to_go[$itokm], $ibeg_1 );
# check for a number on the right
if ( $types_to_go[$itokp] eq 'n' ) {
# ok if nothing else on right
if ( $itokp == $iend_2 ) {
$good_combo = 1;
}
else {
# look one more token to right..
# okay if math operator or some termination
$good_combo =
( ( $itokpp == $iend_2 )
&& $is_math_op{ $types_to_go[$itokpp] } )
|| $types_to_go[$itokpp] =~ /^[#,;]$/;
}
}
# check for a number on the left
if ( !$good_combo && $types_to_go[$itokm] eq 'n' ) {
# okay if nothing else to left
if ( $itokm == $ibeg_1 ) {
$good_combo = 1;
}
# otherwise look one more token to left
else {
# okay if math operator, comma, or assignment
$good_combo = ( $itokmm == $ibeg_1 )
&& ( $is_math_op{ $types_to_go[$itokmm] }
|| $types_to_go[$itokmm] =~ /^[,]$/
|| $is_assignment{ $types_to_go[$itokmm] }
);
}
}
# look for a single short token either side of the
# operator
if ( !$good_combo ) {
# Slight adjustment factor to make results
# independent of break before or after operator in
# long summed lists. (An operator and a space make
# two spaces).
my $two = ( $itok eq $iend_1 ) ? 2 : 0;
$good_combo =
# numbers or id's on both sides of this joint
$types_to_go[$itokp] =~ /^[in]$/
&& $types_to_go[$itokm] =~ /^[in]$/
# one of the two lines must be short:
&& (
(
# no more than 2 nonblank tokens right of
# joint
$itokpp == $iend_2
# short
&& token_sequence_length( $itokp, $iend_2 )
< $two +
$rOpts_short_concatenation_item_length
)
|| (
# no more than 2 nonblank tokens left of
# joint
$itokmm == $ibeg_1
# short
&& token_sequence_length( $ibeg_1, $itokm )
< 2 - $two +
$rOpts_short_concatenation_item_length
)
)
# keep pure terms; don't mix +- with */
&& !(
$is_plus_minus{$type}
&& ( $is_mult_div{ $types_to_go[$itokmm] }
|| $is_mult_div{ $types_to_go[$itokpp] } )
)
&& !(
$is_mult_div{$type}
&& ( $is_plus_minus{ $types_to_go[$itokmm] }
|| $is_plus_minus{ $types_to_go[$itokpp] } )
)
;
}
# it is also good to combine if we can reduce to 2 lines
if ( !$good_combo ) {
# index on other line where same token would be in a
# long chain.
my $iother =
( $itok == $iend_1 ) ? $iend_2 : $ibeg_1;
$good_combo =
$n == 2
&& $n == $nmax
&& $types_to_go[$iother] ne $type;
}
next unless ($good_combo);
} ## end math
elsif ( $is_amp_amp{$type} ) {
##TBD
} ## end &&, ||
elsif ( $is_assignment{$type} ) {
##TBD
} ## end assignment
}
#----------------------------------------------------------
# Recombine Section 1:
# Join welded nested containers immediately
#----------------------------------------------------------
if ( weld_len_right_to_go($iend_1)
|| weld_len_left_to_go($ibeg_2) )
{
$n_best = $n;
# Old coding alternated sweep direction: no longer needed
# $reverse = 1 - $reverse;
last;
}
$reverse = 0;
#----------------------------------------------------------
# Recombine Section 2:
# Examine token at $iend_1 (right end of first line of pair)
#----------------------------------------------------------
# an isolated '}' may join with a ';' terminated segment
if ( $type_iend_1 eq '}' ) {
# Check for cases where combining a semicolon terminated
# statement with a previous isolated closing paren will
# allow the combined line to be outdented. This is
# generally a good move. For example, we can join up
# the last two lines here:
# (
# $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
# $size, $atime, $mtime, $ctime, $blksize, $blocks
# )
# = stat($file);
#
# to get:
# (
# $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
# $size, $atime, $mtime, $ctime, $blksize, $blocks
# ) = stat($file);
#
# which makes the parens line up.
#
# Another example, from Joe Matarazzo, probably looks best
# with the 'or' clause appended to the trailing paren:
# $self->some_method(
# PARAM1 => 'foo',
# PARAM2 => 'bar'
# ) or die "Some_method didn't work";
#
# But we do not want to do this for something like the -lp
# option where the paren is not outdentable because the
# trailing clause will be far to the right.
#
# The logic here is synchronized with the logic in sub
# sub set_adjusted_indentation, which actually does
# the outdenting.
#
$skip_Section_3 ||= $this_line_is_semicolon_terminated
# only one token on last line
&& $ibeg_1 == $iend_1
# must be structural paren
&& $tokens_to_go[$iend_1] eq ')'
# style must allow outdenting,
&& !$closing_token_indentation{')'}
# only leading '&&', '||', and ':' if no others seen
# (but note: our count made below could be wrong
# due to intervening comments)
&& ( $leading_amp_count == 0
|| $type_ibeg_2 !~ /^(:|\&\&|\|\|)$/ )
# but leading colons probably line up with a
# previous colon or question (count could be wrong).
&& $type_ibeg_2 ne ':'
# only one step in depth allowed. this line must not
# begin with a ')' itself.
&& ( $nesting_depth_to_go[$iend_1] ==
$nesting_depth_to_go[$iend_2] + 1 );
# YVES patch 2 of 2:
# Allow cuddled eval chains, like this:
# eval {
# #STUFF;
# 1; # return true
# } or do {
# #handle error
# };
# This patch works together with a patch in
# setting adjusted indentation (where the closing eval
# brace is outdented if possible).
# The problem is that an 'eval' block has continuation
# indentation and it looks better to undo it in some
# cases. If we do not use this patch we would get:
# eval {
# #STUFF;
# 1; # return true
# }
# or do {
# #handle error
# };
# The alternative, for uncuddled style, is to create
# a patch in set_adjusted_indentation which undoes
# the indentation of a leading line like 'or do {'.
# This doesn't work well with -icb through
if (
$block_type_to_go[$iend_1] eq 'eval'
&& !$rOpts->{'line-up-parentheses'}
&& !$rOpts->{'indent-closing-brace'}
&& $tokens_to_go[$iend_2] eq '{'
&& (
( $type_ibeg_2 =~ /^(|\&\&|\|\|)$/ )
|| ( $type_ibeg_2 eq 'k'
&& $is_and_or{ $tokens_to_go[$ibeg_2] } )
|| $is_if_unless{ $tokens_to_go[$ibeg_2] }
)
)
{
$skip_Section_3 ||= 1;
}
next
unless (
$skip_Section_3
# handle '.' and '?' specially below
|| ( $type_ibeg_2 =~ /^[\.\?]$/ )
);
}
elsif ( $type_iend_1 eq '{' ) {
# YVES
# honor breaks at opening brace
# Added to prevent recombining something like this:
# } || eval { package main;
next if $forced_breakpoint_to_go[$iend_1];
}
# do not recombine lines with ending &&, ||,
elsif ( $is_amp_amp{$type_iend_1} ) {
next unless $want_break_before{$type_iend_1};
}
# Identify and recombine a broken ?/: chain
elsif ( $type_iend_1 eq '?' ) {
# Do not recombine different levels
next
if ( $levels_to_go[$ibeg_1] ne $levels_to_go[$ibeg_2] );
# do not recombine unless next line ends in :
next unless $type_iend_2 eq ':';
}
# for lines ending in a comma...
elsif ( $type_iend_1 eq ',' ) {
# Do not recombine at comma which is following the
# input bias.
# TODO: might be best to make a special flag
next if ( $old_breakpoint_to_go[$iend_1] );
# an isolated '},' may join with an identifier + ';'
# this is useful for the class of a 'bless' statement (bless.t)
if ( $type_ibeg_1 eq '}'
&& $type_ibeg_2 eq 'i' )
{
next
unless ( ( $ibeg_1 == ( $iend_1 - 1 ) )
&& ( $iend_2 == ( $ibeg_2 + 1 ) )
&& $this_line_is_semicolon_terminated );
# override breakpoint
$forced_breakpoint_to_go[$iend_1] = 0;
}
# but otherwise ..
else {
# do not recombine after a comma unless this will leave
# just 1 more line
next unless ( $n + 1 >= $nmax );
# do not recombine if there is a change in indentation depth
next
if (
$levels_to_go[$iend_1] != $levels_to_go[$iend_2] );
# do not recombine a "complex expression" after a
# comma. "complex" means no parens.
my $saw_paren;
foreach my $ii ( $ibeg_2 .. $iend_2 ) {
if ( $tokens_to_go[$ii] eq '(' ) {
$saw_paren = 1;
last;
}
}
next if $saw_paren;
}
}
# opening paren..
elsif ( $type_iend_1 eq '(' ) {
# No longer doing this
}
elsif ( $type_iend_1 eq ')' ) {
# No longer doing this
}
# keep a terminal for-semicolon
elsif ( $type_iend_1 eq 'f' ) {
next;
}
# if '=' at end of line ...
elsif ( $is_assignment{$type_iend_1} ) {
# keep break after = if it was in input stream
# this helps prevent 'blinkers'
next if $old_breakpoint_to_go[$iend_1]
# don't strand an isolated '='
&& $iend_1 != $ibeg_1;
my $is_short_quote =
( $type_ibeg_2 eq 'Q'
&& $ibeg_2 == $iend_2
&& token_sequence_length( $ibeg_2, $ibeg_2 ) <
$rOpts_short_concatenation_item_length );
my $is_ternary =
( $type_ibeg_1 eq '?'
&& ( $ibeg_3 >= 0 && $types_to_go[$ibeg_3] eq ':' ) );
# always join an isolated '=', a short quote, or if this
# will put ?/: at start of adjacent lines
if ( $ibeg_1 != $iend_1
&& !$is_short_quote
&& !$is_ternary )
{
next
unless (
(
# unless we can reduce this to two lines
$nmax < $n + 2
# or three lines, the last with a leading semicolon
|| ( $nmax == $n + 2
&& $types_to_go[$ibeg_nmax] eq ';' )
# or the next line ends with a here doc
|| $type_iend_2 eq 'h'
# or the next line ends in an open paren or brace
# and the break hasn't been forced [dima.t]
|| ( !$forced_breakpoint_to_go[$iend_1]
&& $type_iend_2 eq '{' )
)
# do not recombine if the two lines might align well
# this is a very approximate test for this
&& (
# RT#127633 - the leading tokens are not operators
( $type_ibeg_2 ne $tokens_to_go[$ibeg_2] )
# or they are different
|| ( $ibeg_3 >= 0
&& $type_ibeg_2 ne $types_to_go[$ibeg_3] )
)
);
if (
# Recombine if we can make two lines
$nmax >= $n + 2
# -lp users often prefer this:
# my $title = function($env, $env, $sysarea,
# "bubba Borrower Entry");
# so we will recombine if -lp is used we have
# ending comma
&& ( !$rOpts_line_up_parentheses
|| $type_iend_2 ne ',' )
)
{
# otherwise, scan the rhs line up to last token for
# complexity. Note that we are not counting the last
# token in case it is an opening paren.
my $tv = 0;
my $depth = $nesting_depth_to_go[$ibeg_2];
foreach my $i ( $ibeg_2 + 1 .. $iend_2 - 1 ) {
if ( $nesting_depth_to_go[$i] != $depth ) {
$tv++;
last if ( $tv > 1 );
}
$depth = $nesting_depth_to_go[$i];
}
# ok to recombine if no level changes before last token
if ( $tv > 0 ) {
# otherwise, do not recombine if more than two
# level changes.
next if ( $tv > 1 );
# check total complexity of the two adjacent lines
# that will occur if we do this join
my $istop =
( $n < $nmax )
? $ri_end->[ $n + 1 ]
: $iend_2;
foreach my $i ( $iend_2 .. $istop ) {
if ( $nesting_depth_to_go[$i] != $depth ) {
$tv++;
last if ( $tv > 2 );
}
$depth = $nesting_depth_to_go[$i];
}
# do not recombine if total is more than 2 level changes
next if ( $tv > 2 );
}
}
}
unless ( $tokens_to_go[$ibeg_2] =~ /^[\{\(\[]$/ ) {
$forced_breakpoint_to_go[$iend_1] = 0;
}
}
# for keywords..
elsif ( $type_iend_1 eq 'k' ) {
# make major control keywords stand out
# (recombine.t)
next
if (
#/^(last|next|redo|return)$/
$is_last_next_redo_return{ $tokens_to_go[$iend_1] }
# but only if followed by multiple lines
&& $n < $nmax
);
if ( $is_and_or{ $tokens_to_go[$iend_1] } ) {
next
unless $want_break_before{ $tokens_to_go[$iend_1] };
}
}
#----------------------------------------------------------
# Recombine Section 3:
# Examine token at $ibeg_2 (left end of second line of pair)
#----------------------------------------------------------
# join lines identified above as capable of
# causing an outdented line with leading closing paren
# Note that we are skipping the rest of this section
# and the rest of the loop to do the join
if ($skip_Section_3) {
$forced_breakpoint_to_go[$iend_1] = 0;
$n_best = $n;
last;
}
# handle lines with leading &&, ||
elsif ( $is_amp_amp{$type_ibeg_2} ) {
$leading_amp_count++;
# ok to recombine if it follows a ? or :
# and is followed by an open paren..
my $ok =
( $is_ternary{$type_ibeg_1}
&& $tokens_to_go[$iend_2] eq '(' )
# or is followed by a ? or : at same depth
#
# We are looking for something like this. We can
# recombine the && line with the line above to make the
# structure more clear:
# return
# exists $G->{Attr}->{V}
# && exists $G->{Attr}->{V}->{$u}
# ? %{ $G->{Attr}->{V}->{$u} }
# : ();
#
# We should probably leave something like this alone:
# return
# exists $G->{Attr}->{E}
# && exists $G->{Attr}->{E}->{$u}
# && exists $G->{Attr}->{E}->{$u}->{$v}
# ? %{ $G->{Attr}->{E}->{$u}->{$v} }
# : ();
# so that we either have all of the &&'s (or ||'s)
# on one line, as in the first example, or break at
# each one as in the second example. However, it
# sometimes makes things worse to check for this because
# it prevents multiple recombinations. So this is not done.
|| ( $ibeg_3 >= 0
&& $is_ternary{ $types_to_go[$ibeg_3] }
&& $nesting_depth_to_go[$ibeg_3] ==
$nesting_depth_to_go[$ibeg_2] );
next if !$ok && $want_break_before{$type_ibeg_2};
$forced_breakpoint_to_go[$iend_1] = 0;
# tweak the bond strength to give this joint priority
# over ? and :
$bs_tweak = 0.25;
}
# Identify and recombine a broken ?/: chain
elsif ( $type_ibeg_2 eq '?' ) {
# Do not recombine different levels
my $lev = $levels_to_go[$ibeg_2];
next if ( $lev ne $levels_to_go[$ibeg_1] );
# Do not recombine a '?' if either next line or
# previous line does not start with a ':'. The reasons
# are that (1) no alignment of the ? will be possible
# and (2) the expression is somewhat complex, so the
# '?' is harder to see in the interior of the line.
my $follows_colon = $ibeg_1 >= 0 && $type_ibeg_1 eq ':';
my $precedes_colon =
$ibeg_3 >= 0 && $types_to_go[$ibeg_3] eq ':';
next unless ( $follows_colon || $precedes_colon );
# we will always combining a ? line following a : line
if ( !$follows_colon ) {
# ...otherwise recombine only if it looks like a chain.
# we will just look at a few nearby lines to see if
# this looks like a chain.
my $local_count = 0;
foreach my $ii ( $ibeg_0, $ibeg_1, $ibeg_3, $ibeg_4 ) {
$local_count++
if $ii >= 0
&& $types_to_go[$ii] eq ':'
&& $levels_to_go[$ii] == $lev;
}
next unless ( $local_count > 1 );
}
$forced_breakpoint_to_go[$iend_1] = 0;
}
# do not recombine lines with leading '.'
elsif ( $type_ibeg_2 eq '.' ) {
my $i_next_nonblank = min( $inext_to_go[$ibeg_2], $iend_2 );
next
unless (
# ... unless there is just one and we can reduce
# this to two lines if we do. For example, this
#
#
# $bodyA .=
# '($dummy, $pat) = &get_next_tex_cmd;' . '$args .= $pat;'
#
# looks better than this:
# $bodyA .= '($dummy, $pat) = &get_next_tex_cmd;'
# . '$args .= $pat;'
(
$n == 2
&& $n == $nmax
&& $type_ibeg_1 ne $type_ibeg_2
)
# ... or this would strand a short quote , like this
# . "some long quote"
# . "\n";
|| ( $types_to_go[$i_next_nonblank] eq 'Q'
&& $i_next_nonblank >= $iend_2 - 1
&& $token_lengths_to_go[$i_next_nonblank] <
$rOpts_short_concatenation_item_length )
);
}
# handle leading keyword..
elsif ( $type_ibeg_2 eq 'k' ) {
# handle leading "or"
if ( $tokens_to_go[$ibeg_2] eq 'or' ) {
next
unless (
$this_line_is_semicolon_terminated
&& (
$type_ibeg_1 eq '}'
|| (
# following 'if' or 'unless' or 'or'
$type_ibeg_1 eq 'k'
&& $is_if_unless{ $tokens_to_go[$ibeg_1] }
# important: only combine a very simple or
# statement because the step below may have
# combined a trailing 'and' with this or,
# and we do not want to then combine
# everything together
&& ( $iend_2 - $ibeg_2 <= 7 )
)
)
);
#X: RT #81854
$forced_breakpoint_to_go[$iend_1] = 0
unless $old_breakpoint_to_go[$iend_1];
}
# handle leading 'and' and 'xor'
elsif ($tokens_to_go[$ibeg_2] eq 'and'
|| $tokens_to_go[$ibeg_2] eq 'xor' )
{
# Decide if we will combine a single terminal 'and'
# after an 'if' or 'unless'.
# This looks best with the 'and' on the same
# line as the 'if':
#
# $a = 1
# if $seconds and $nu < 2;
#
# But this looks better as shown:
#
# $a = 1
# if !$this->{Parents}{$_}
# or $this->{Parents}{$_} eq $_;
#
next
unless (
$this_line_is_semicolon_terminated
&& (
# following 'if' or 'unless' or 'or'
$type_ibeg_1 eq 'k'
&& ( $is_if_unless{ $tokens_to_go[$ibeg_1] }
|| $tokens_to_go[$ibeg_1] eq 'or' )
)
);
}
# handle leading "if" and "unless"
elsif ( $is_if_unless{ $tokens_to_go[$ibeg_2] } ) {
# FIXME: This is still experimental..may not be too useful
next
unless (
$this_line_is_semicolon_terminated
# previous line begins with 'and' or 'or'
&& $type_ibeg_1 eq 'k'
&& $is_and_or{ $tokens_to_go[$ibeg_1] }
);
}
# handle all other leading keywords
else {
# keywords look best at start of lines,
# but combine things like "1 while"
unless ( $is_assignment{$type_iend_1} ) {
next
if ( ( $type_iend_1 ne 'k' )
&& ( $tokens_to_go[$ibeg_2] ne 'while' ) );
}
}
}
# similar treatment of && and || as above for 'and' and 'or':
# NOTE: This block of code is currently bypassed because
# of a previous block but is retained for possible future use.
elsif ( $is_amp_amp{$type_ibeg_2} ) {
# maybe looking at something like:
# unless $TEXTONLY || $item =~ m%</?(hr>|p>|a|img)%i;
next
unless (
$this_line_is_semicolon_terminated
# previous line begins with an 'if' or 'unless' keyword
&& $type_ibeg_1 eq 'k'
&& $is_if_unless{ $tokens_to_go[$ibeg_1] }
);
}
# handle line with leading = or similar
elsif ( $is_assignment{$type_ibeg_2} ) {
next unless ( $n == 1 || $n == $nmax );
next if $old_breakpoint_to_go[$iend_1];
next
unless (
# unless we can reduce this to two lines
$nmax == 2
# or three lines, the last with a leading semicolon
|| ( $nmax == 3 && $types_to_go[$ibeg_nmax] eq ';' )
# or the next line ends with a here doc
|| $type_iend_2 eq 'h'
# or this is a short line ending in ;
|| ( $n == $nmax && $this_line_is_semicolon_terminated )
);
$forced_breakpoint_to_go[$iend_1] = 0;
}
#----------------------------------------------------------
# Recombine Section 4:
# Combine the lines if we arrive here and it is possible
#----------------------------------------------------------
# honor hard breakpoints
next if ( $forced_breakpoint_to_go[$iend_1] > 0 );
my $bs = $bond_strength_to_go[$iend_1] + $bs_tweak;
# Require a few extra spaces before recombining lines if we are
# at an old breakpoint unless this is a simple list or terminal
# line. The goal is to avoid oscillating between two
# quasi-stable end states. For example this snippet caused
# problems:
## my $this =
## bless {
## TText => "[" . ( join ',', map { "\"$_\"" } split "\n", $_ ) . "]"
## },
## $type;
next
if ( $old_breakpoint_to_go[$iend_1]
&& !$this_line_is_semicolon_terminated
&& $n < $nmax
&& $excess + 4 > 0
&& $type_iend_2 ne ',' );
# do not recombine if we would skip in indentation levels
if ( $n < $nmax ) {
my $if_next = $ri_beg->[ $n + 1 ];
next
if (
$levels_to_go[$ibeg_1] < $levels_to_go[$ibeg_2]
&& $levels_to_go[$ibeg_2] < $levels_to_go[$if_next]
# but an isolated 'if (' is undesirable
&& !(
$n == 1
&& $iend_1 - $ibeg_1 <= 2
&& $type_ibeg_1 eq 'k'
&& $tokens_to_go[$ibeg_1] eq 'if'
&& $tokens_to_go[$iend_1] ne '('
)
);
}
# honor no-break's
next if ( $bs >= NO_BREAK - 1 );
# remember the pair with the greatest bond strength
if ( !$n_best ) {
$n_best = $n;
$bs_best = $bs;
}
else {
if ( $bs > $bs_best ) {
$n_best = $n;
$bs_best = $bs;
}
}
}
# recombine the pair with the greatest bond strength
if ($n_best) {
splice @{$ri_beg}, $n_best, 1;
splice @{$ri_end}, $n_best - 1, 1;
splice @joint, $n_best, 1;
# keep going if we are still making progress
$more_to_do++;
}
}
return ( $ri_beg, $ri_end );
}
} # end recombine_breakpoints
sub break_all_chain_tokens {
# scan the current breakpoints looking for breaks at certain "chain
# operators" (. : && || + etc) which often occur repeatedly in a long
# statement. If we see a break at any one, break at all similar tokens
# within the same container.
#
my ( $self, $ri_left, $ri_right ) = @_;
my %saw_chain_type;
my %left_chain_type;
my %right_chain_type;
my %interior_chain_type;
my $nmax = @{$ri_right} - 1;
# scan the left and right end tokens of all lines
my $count = 0;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
my $typel = $types_to_go[$il];
my $typer = $types_to_go[$ir];
$typel = '+' if ( $typel eq '-' ); # treat + and - the same
$typer = '+' if ( $typer eq '-' );
$typel = '*' if ( $typel eq '/' ); # treat * and / the same
$typer = '*' if ( $typer eq '/' );
my $tokenl = $tokens_to_go[$il];
my $tokenr = $tokens_to_go[$ir];
if ( $is_chain_operator{$tokenl} && $want_break_before{$typel} ) {
next if ( $typel eq '?' );
push @{ $left_chain_type{$typel} }, $il;
$saw_chain_type{$typel} = 1;
$count++;
}
if ( $is_chain_operator{$tokenr} && !$want_break_before{$typer} ) {
next if ( $typer eq '?' );
push @{ $right_chain_type{$typer} }, $ir;
$saw_chain_type{$typer} = 1;
$count++;
}
}
return unless $count;
# now look for any interior tokens of the same types
$count = 0;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
foreach my $i ( $il + 1 .. $ir - 1 ) {
my $type = $types_to_go[$i];
$type = '+' if ( $type eq '-' );
$type = '*' if ( $type eq '/' );
if ( $saw_chain_type{$type} ) {
push @{ $interior_chain_type{$type} }, $i;
$count++;
}
}
}
return unless $count;
# now make a list of all new break points
my @insert_list;
# loop over all chain types
foreach my $type ( keys %saw_chain_type ) {
# quit if just ONE continuation line with leading . For example--
# print LATEXFILE '\framebox{\parbox[c][' . $h . '][t]{' . $w . '}{'
# . $contents;
last if ( $nmax == 1 && $type =~ /^[\.\+]$/ );
# loop over all interior chain tokens
foreach my $itest ( @{ $interior_chain_type{$type} } ) {
# loop over all left end tokens of same type
if ( $left_chain_type{$type} ) {
next if $nobreak_to_go[ $itest - 1 ];
foreach my $i ( @{ $left_chain_type{$type} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest - 1;
# Break at matching ? if this : is at a different level.
# For example, the ? before $THRf_DEAD in the following
# should get a break if its : gets a break.
#
# my $flags =
# ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE
# : ( $_ & 4 ) ? $THRf_R_DETACHED
# : $THRf_R_JOINABLE;
if ( $type eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
if ( $i_question > 0 ) {
push @insert_list, $i_question - 1;
}
}
last;
}
}
# loop over all right end tokens of same type
if ( $right_chain_type{$type} ) {
next if $nobreak_to_go[$itest];
foreach my $i ( @{ $right_chain_type{$type} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest;
# break at matching ? if this : is at a different level
if ( $type eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
if ( $i_question >= 0 ) {
push @insert_list, $i_question;
}
}
last;
}
}
}
}
# insert any new break points
if (@insert_list) {
insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
}
sub break_equals {
# Look for assignment operators that could use a breakpoint.
# For example, in the following snippet
#
# $HOME = $ENV{HOME}
# || $ENV{LOGDIR}
# || $pw[7]
# || die "no home directory for user $<";
#
# we could break at the = to get this, which is a little nicer:
# $HOME =
# $ENV{HOME}
# || $ENV{LOGDIR}
# || $pw[7]
# || die "no home directory for user $<";
#
# The logic here follows the logic in set_logical_padding, which
# will add the padding in the second line to improve alignment.
#
my ( $ri_left, $ri_right ) = @_;
my $nmax = @{$ri_right} - 1;
return unless ( $nmax >= 2 );
# scan the left ends of first two lines
my $tokbeg = "";
my $depth_beg;
for my $n ( 1 .. 2 ) {
my $il = $ri_left->[$n];
my $typel = $types_to_go[$il];
my $tokenl = $tokens_to_go[$il];
my $has_leading_op = ( $tokenl =~ /^\w/ )
? $is_chain_operator{$tokenl} # + - * / : ? && ||
: $is_chain_operator{$typel}; # and, or
return unless ($has_leading_op);
if ( $n > 1 ) {
return
unless ( $tokenl eq $tokbeg
&& $nesting_depth_to_go[$il] eq $depth_beg );
}
$tokbeg = $tokenl;
$depth_beg = $nesting_depth_to_go[$il];
}
# now look for any interior tokens of the same types
my $il = $ri_left->[0];
my $ir = $ri_right->[0];
# now make a list of all new break points
my @insert_list;
for ( my $i = $ir - 1 ; $i > $il ; $i-- ) {
my $type = $types_to_go[$i];
if ( $is_assignment{$type}
&& $nesting_depth_to_go[$i] eq $depth_beg )
{
if ( $want_break_before{$type} ) {
push @insert_list, $i - 1;
}
else {
push @insert_list, $i;
}
}
}
# Break after a 'return' followed by a chain of operators
# return ( $^O !~ /win32|dos/i )
# && ( $^O ne 'VMS' )
# && ( $^O ne 'OS2' )
# && ( $^O ne 'MacOS' );
# To give:
# return
# ( $^O !~ /win32|dos/i )
# && ( $^O ne 'VMS' )
# && ( $^O ne 'OS2' )
# && ( $^O ne 'MacOS' );
my $i = 0;
if ( $types_to_go[$i] eq 'k'
&& $tokens_to_go[$i] eq 'return'
&& $ir > $il
&& $nesting_depth_to_go[$i] eq $depth_beg )
{
push @insert_list, $i;
}
return unless (@insert_list);
# One final check...
# scan second and third lines and be sure there are no assignments
# we want to avoid breaking at an = to make something like this:
# unless ( $icon =
# $html_icons{"$type-$state"}
# or $icon = $html_icons{$type}
# or $icon = $html_icons{$state} )
for my $n ( 1 .. 2 ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
foreach my $i ( $il + 1 .. $ir ) {
my $type = $types_to_go[$i];
return
if ( $is_assignment{$type}
&& $nesting_depth_to_go[$i] eq $depth_beg );
}
}
# ok, insert any new break point
if (@insert_list) {
insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
}
sub insert_final_breaks {
my ( $self, $ri_left, $ri_right ) = @_;
my $nmax = @{$ri_right} - 1;
# scan the left and right end tokens of all lines
my $count = 0;
my $i_first_colon = -1;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
my $typel = $types_to_go[$il];
my $typer = $types_to_go[$ir];
return if ( $typel eq '?' );
return if ( $typer eq '?' );
if ( $typel eq ':' ) { $i_first_colon = $il; last; }
elsif ( $typer eq ':' ) { $i_first_colon = $ir; last; }
}
# For long ternary chains,
# if the first : we see has its ? is in the interior
# of a preceding line, then see if there are any good
# breakpoints before the ?.
if ( $i_first_colon > 0 ) {
my $i_question = $mate_index_to_go[$i_first_colon];
if ( $i_question > 0 ) {
my @insert_list;
for ( my $ii = $i_question - 1 ; $ii >= 0 ; $ii -= 1 ) {
my $token = $tokens_to_go[$ii];
my $type = $types_to_go[$ii];
# For now, a good break is either a comma or,
# in a long chain, a 'return'.
# Patch for RT #126633: added the $nmax>1 check to avoid
# breaking after a return for a simple ternary. For longer
# chains the break after return allows vertical alignment, so
# it is still done. So perltidy -wba='?' will not break
# immediately after the return in the following statement:
# sub x {
# return 0 ? 'aaaaaaaaaaaaaaaaaaaaa' :
# 'bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb';
# }
if (
(
$type eq ','
|| $type eq 'k' && ( $nmax > 1 && $token eq 'return' )
)
&& $self->in_same_container_i( $ii, $i_question )
)
{
push @insert_list, $ii;
last;
}
}
# insert any new break points
if (@insert_list) {
insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
}
}
return;
}
sub in_same_container_i {
# check to see if tokens at i1 and i2 are in the
# same container, and not separated by a comma, ? or :
# This is an interface between the _to_go arrays to the rLL array
my ( $self, $i1, $i2 ) = @_;
return $self->in_same_container_K( $K_to_go[$i1], $K_to_go[$i2] );
}
{ # sub in_same_container_K
my $ris_break_token;
my $ris_comma_token;
BEGIN {
# all cases break on seeing commas at same level
my @q = qw( => );
push @q, ',';
@{$ris_comma_token}{@q} = (1) x scalar(@q);
# Non-ternary text also breaks on seeing any of qw(? : || or )
# Example: we would not want to break at any of these .'s
# : "<A HREF=\"#item_" . htmlify( 0, $s2 ) . "\">$str</A>"
push @q, qw( or || ? : );
@{$ris_break_token}{@q} = (1) x scalar(@q);
}
sub in_same_container_K {
# Check to see if tokens at K1 and K2 are in the same container,
# and not separated by certain characters: => , ? : || or
# This version uses the newer $rLL data structure
my ( $self, $K1, $K2 ) = @_;
if ( $K2 < $K1 ) { ( $K1, $K2 ) = ( $K2, $K1 ) }
my $rLL = $self->{rLL};
my $depth_1 = $rLL->[$K1]->[_SLEVEL_];
return if ( $depth_1 < 0 );
return unless ( $rLL->[$K2]->[_SLEVEL_] == $depth_1 );
# Select character set to scan for
my $type_1 = $rLL->[$K1]->[_TYPE_];
my $rbreak = ( $type_1 ne ':' ) ? $ris_break_token : $ris_comma_token;
# Fast preliminary loop to verify that tokens are in the same container
my $KK = $K1;
while (1) {
$KK = $rLL->[$KK]->[_KNEXT_SEQ_ITEM_];
last if !defined($KK);
last if ( $KK >= $K2 );
my $depth_K = $rLL->[$KK]->[_SLEVEL_];
return if ( $depth_K < $depth_1 );
next if ( $depth_K > $depth_1 );
if ( $type_1 ne ':' ) {
my $tok_K = $rLL->[$KK]->[_TOKEN_];
return if ( $tok_K eq '?' || $tok_K eq ':' );
}
}
# Slow loop checking for certain characters
###########################################################
# This is potentially a slow routine and not critical.
# For safety just give up for large differences.
# See test file 'infinite_loop.txt'
###########################################################
return if ( $K2 - $K1 > 200 );
foreach my $K ( $K1 + 1 .. $K2 - 1 ) {
my $depth_K = $rLL->[$K]->[_SLEVEL_];
next if ( $depth_K > $depth_1 );
return if ( $depth_K < $depth_1 ); # redundant, checked above
my $tok = $rLL->[$K]->[_TOKEN_];
return if ( $rbreak->{$tok} );
}
return 1;
}
}
sub set_continuation_breaks {
# Define an array of indexes for inserting newline characters to
# keep the line lengths below the maximum desired length. There is
# an implied break after the last token, so it need not be included.
# Method:
# This routine is part of series of routines which adjust line
# lengths. It is only called if a statement is longer than the
# maximum line length, or if a preliminary scanning located
# desirable break points. Sub scan_list has already looked at
# these tokens and set breakpoints (in array
# $forced_breakpoint_to_go[$i]) where it wants breaks (for example
# after commas, after opening parens, and before closing parens).
# This routine will honor these breakpoints and also add additional
# breakpoints as necessary to keep the line length below the maximum
# requested. It bases its decision on where the 'bond strength' is
# lowest.
# Output: returns references to the arrays:
# @i_first
# @i_last
# which contain the indexes $i of the first and last tokens on each
# line.
# In addition, the array:
# $forced_breakpoint_to_go[$i]
# may be updated to be =1 for any index $i after which there must be
# a break. This signals later routines not to undo the breakpoint.
my ( $self, $saw_good_break ) = @_;
my @i_first = (); # the first index to output
my @i_last = (); # the last index to output
my @i_colon_breaks = (); # needed to decide if we have to break at ?'s
if ( $types_to_go[0] eq ':' ) { push @i_colon_breaks, 0 }
my $rOpts_fuzzy_line_length = $rOpts->{'fuzzy-line-length'};
set_bond_strengths();
my $imin = 0;
my $imax = $max_index_to_go;
if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
my $i_begin = $imin; # index for starting next iteration
my $leading_spaces = leading_spaces_to_go($imin);
my $line_count = 0;
my $last_break_strength = NO_BREAK;
my $i_last_break = -1;
my $max_bias = 0.001;
my $tiny_bias = 0.0001;
my $leading_alignment_token = "";
my $leading_alignment_type = "";
# see if any ?/:'s are in order
my $colons_in_order = 1;
my $last_tok = "";
my @colon_list = grep { /^[\?\:]$/ } @types_to_go[ 0 .. $max_index_to_go ];
my $colon_count = @colon_list;
foreach (@colon_list) {
if ( $_ eq $last_tok ) { $colons_in_order = 0; last }
$last_tok = $_;
}
# This is a sufficient but not necessary condition for colon chain
my $is_colon_chain = ( $colons_in_order && @colon_list > 2 );
#-------------------------------------------------------
# BEGINNING of main loop to set continuation breakpoints
# Keep iterating until we reach the end
#-------------------------------------------------------
while ( $i_begin <= $imax ) {
my $lowest_strength = NO_BREAK;
my $starting_sum = $summed_lengths_to_go[$i_begin];
my $i_lowest = -1;
my $i_test = -1;
my $lowest_next_token = '';
my $lowest_next_type = 'b';
my $i_lowest_next_nonblank = -1;
#-------------------------------------------------------
# BEGINNING of inner loop to find the best next breakpoint
#-------------------------------------------------------
my $strength = NO_BREAK;
for ( $i_test = $i_begin ; $i_test <= $imax ; $i_test++ ) {
my $type = $types_to_go[$i_test];
my $token = $tokens_to_go[$i_test];
my $next_type = $types_to_go[ $i_test + 1 ];
my $next_token = $tokens_to_go[ $i_test + 1 ];
my $i_next_nonblank = $inext_to_go[$i_test];
my $next_nonblank_type = $types_to_go[$i_next_nonblank];
my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
my $next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
my $maximum_line_length = maximum_line_length($i_begin);
# adjustments to the previous bond strength may have been made, and
# we must keep the bond strength of a token and its following blank
# the same;
my $last_strength = $strength;
$strength = $bond_strength_to_go[$i_test];
if ( $type eq 'b' ) { $strength = $last_strength }
# use old breaks as a tie-breaker. For example to
# prevent blinkers with -pbp in this code:
##@keywords{
## qw/ARG OUTPUT PROTO CONSTRUCTOR RETURNS DESC PARAMS SEEALSO EXAMPLE/}
## = ();
# At the same time try to prevent a leading * in this code
# with the default formatting:
#
## return
## factorial( $a + $b - 1 ) / factorial( $a - 1 ) / factorial( $b - 1 )
## * ( $x**( $a - 1 ) )
## * ( ( 1 - $x )**( $b - 1 ) );
# reduce strength a bit to break ties at an old breakpoint ...
if (
$old_breakpoint_to_go[$i_test]
# which is a 'good' breakpoint, meaning ...
# we don't want to break before it
&& !$want_break_before{$type}
# and either we want to break before the next token
# or the next token is not short (i.e. not a '*', '/' etc.)
&& $i_next_nonblank <= $imax
&& ( $want_break_before{$next_nonblank_type}
|| $token_lengths_to_go[$i_next_nonblank] > 2
|| $next_nonblank_type =~ /^[\,\(\[\{L]$/ )
)
{
$strength -= $tiny_bias;
}
# otherwise increase strength a bit if this token would be at the
# maximum line length. This is necessary to avoid blinking
# in the above example when the -iob flag is added.
else {
my $len =
$leading_spaces +
$summed_lengths_to_go[ $i_test + 1 ] -
$starting_sum;
if ( $len >= $maximum_line_length ) {
$strength += $tiny_bias;
}
}
my $must_break = 0;
# Force an immediate break at certain operators
# with lower level than the start of the line,
# unless we've already seen a better break.
#
##############################################
# Note on an issue with a preceding ?
##############################################
# We don't include a ? in the above list, but there may
# be a break at a previous ? if the line is long.
# Because of this we do not want to force a break if
# there is a previous ? on this line. For now the best way
# to do this is to not break if we have seen a lower strength
# point, which is probably a ?.
#
# Example of unwanted breaks we are avoiding at a '.' following a ?
# from pod2html using perltidy -gnu:
# )
# ? "\n<A NAME=\""
# . $value
# . "\">\n$text</A>\n"
# : "\n$type$pod2.html\#" . $value . "\">$text<\/A>\n";
if (
(
$next_nonblank_type =~ /^(\.|\&\&|\|\|)$/
|| ( $next_nonblank_type eq 'k'
&& $next_nonblank_token =~ /^(and|or)$/ )
)
&& ( $nesting_depth_to_go[$i_begin] >
$nesting_depth_to_go[$i_next_nonblank] )
&& ( $strength <= $lowest_strength )
)
{
set_forced_breakpoint($i_next_nonblank);
}
if (
# Try to put a break where requested by scan_list
$forced_breakpoint_to_go[$i_test]
# break between ) { in a continued line so that the '{' can
# be outdented
# See similar logic in scan_list which catches instances
# where a line is just something like ') {'. We have to
# be careful because the corresponding block keyword might
# not be on the first line, such as 'for' here:
#
# eval {
# for ("a") {
# for $x ( 1, 2 ) { local $_ = "b"; s/(.*)/+$1/ }
# }
# };
#
|| (
$line_count
&& ( $token eq ')' )
&& ( $next_nonblank_type eq '{' )
&& ($next_nonblank_block_type)
&& ( $next_nonblank_block_type ne $tokens_to_go[$i_begin] )
# RT #104427: Dont break before opening sub brace because
# sub block breaks handled at higher level, unless
# it looks like the preceding list is long and broken
&& !(
$next_nonblank_block_type =~ /$ANYSUB_PATTERN/
&& ( $nesting_depth_to_go[$i_begin] ==
$nesting_depth_to_go[$i_next_nonblank] )
)
&& !$rOpts->{'opening-brace-always-on-right'}
)
# There is an implied forced break at a terminal opening brace
|| ( ( $type eq '{' ) && ( $i_test == $imax ) )
)
{
# Forced breakpoints must sometimes be overridden, for example
# because of a side comment causing a NO_BREAK. It is easier
# to catch this here than when they are set.
if ( $strength < NO_BREAK - 1 ) {
$strength = $lowest_strength - $tiny_bias;
$must_break = 1;
}
}
# quit if a break here would put a good terminal token on
# the next line and we already have a possible break
if (
!$must_break
&& ( $next_nonblank_type =~ /^[\;\,]$/ )
&& (
(
$leading_spaces +
$summed_lengths_to_go[ $i_next_nonblank + 1 ] -
$starting_sum
) > $maximum_line_length
)
)
{
last if ( $i_lowest >= 0 );
}
# Avoid a break which would strand a single punctuation
# token. For example, we do not want to strand a leading
# '.' which is followed by a long quoted string.
# But note that we do want to do this with -extrude (l=1)
# so please test any changes to this code on -extrude.
if (
!$must_break
&& ( $i_test == $i_begin )
&& ( $i_test < $imax )
&& ( $token eq $type )
&& (
(
$leading_spaces +
$summed_lengths_to_go[ $i_test + 1 ] -
$starting_sum
) < $maximum_line_length
)
)
{
$i_test = min( $imax, $inext_to_go[$i_test] );
redo;
}
if ( ( $strength <= $lowest_strength ) && ( $strength < NO_BREAK ) )
{
# break at previous best break if it would have produced
# a leading alignment of certain common tokens, and it
# is different from the latest candidate break
last
if ($leading_alignment_type);
# Force at least one breakpoint if old code had good
# break It is only called if a breakpoint is required or
# desired. This will probably need some adjustments
# over time. A goal is to try to be sure that, if a new
# side comment is introduced into formatted text, then
# the same breakpoints will occur. scbreak.t
last
if (
$i_test == $imax # we are at the end
&& !$forced_breakpoint_count #
&& $saw_good_break # old line had good break
&& $type =~ /^[#;\{]$/ # and this line ends in
# ';' or side comment
&& $i_last_break < 0 # and we haven't made a break
&& $i_lowest >= 0 # and we saw a possible break
&& $i_lowest < $imax - 1 # (but not just before this ;)
&& $strength - $lowest_strength < 0.5 * WEAK # and it's good
);
# Do not skip past an important break point in a short final
# segment. For example, without this check we would miss the
# break at the final / in the following code:
#
# $depth_stop =
# ( $tau * $mass_pellet * $q_0 *
# ( 1. - exp( -$t_stop / $tau ) ) -
# 4. * $pi * $factor * $k_ice *
# ( $t_melt - $t_ice ) *
# $r_pellet *
# $t_stop ) /
# ( $rho_ice * $Qs * $pi * $r_pellet**2 );
#
if ( $line_count > 2
&& $i_lowest < $i_test
&& $i_test > $imax - 2
&& $nesting_depth_to_go[$i_begin] >
$nesting_depth_to_go[$i_lowest]
&& $lowest_strength < $last_break_strength - .5 * WEAK )
{
# Make this break for math operators for now
my $ir = $inext_to_go[$i_lowest];
my $il = $iprev_to_go[$ir];
last
if ( $types_to_go[$il] =~ /^[\/\*\+\-\%]$/
|| $types_to_go[$ir] =~ /^[\/\*\+\-\%]$/ );
}
# Update the minimum bond strength location
$lowest_strength = $strength;
$i_lowest = $i_test;
$lowest_next_token = $next_nonblank_token;
$lowest_next_type = $next_nonblank_type;
$i_lowest_next_nonblank = $i_next_nonblank;
last if $must_break;
# set flags to remember if a break here will produce a
# leading alignment of certain common tokens
if ( $line_count > 0
&& $i_test < $imax
&& ( $lowest_strength - $last_break_strength <= $max_bias )
)
{
my $i_last_end = $iprev_to_go[$i_begin];
my $tok_beg = $tokens_to_go[$i_begin];
my $type_beg = $types_to_go[$i_begin];
if (
# check for leading alignment of certain tokens
(
$tok_beg eq $next_nonblank_token
&& $is_chain_operator{$tok_beg}
&& ( $type_beg eq 'k'
|| $type_beg eq $tok_beg )
&& $nesting_depth_to_go[$i_begin] >=
$nesting_depth_to_go[$i_next_nonblank]
)
|| ( $tokens_to_go[$i_last_end] eq $token
&& $is_chain_operator{$token}
&& ( $type eq 'k' || $type eq $token )
&& $nesting_depth_to_go[$i_last_end] >=
$nesting_depth_to_go[$i_test] )
)
{
$leading_alignment_token = $next_nonblank_token;
$leading_alignment_type = $next_nonblank_type;
}
}
}
my $too_long = ( $i_test >= $imax );
if ( !$too_long ) {
my $next_length =
$leading_spaces +
$summed_lengths_to_go[ $i_test + 2 ] -
$starting_sum;
$too_long = $next_length > $maximum_line_length;
# To prevent blinkers we will avoid leaving a token exactly at
# the line length limit unless it is the last token or one of
# several "good" types.
#
# The following code was a blinker with -pbp before this
# modification:
## $last_nonblank_token eq '('
## && $is_indirect_object_taker{ $paren_type
## [$paren_depth] }
# The issue causing the problem is that if the
# term [$paren_depth] gets broken across a line then
# the whitespace routine doesn't see both opening and closing
# brackets and will format like '[ $paren_depth ]'. This
# leads to an oscillation in length depending if we break
# before the closing bracket or not.
if ( !$too_long
&& $i_test + 1 < $imax
&& $next_nonblank_type !~ /^[,\}\]\)R]$/ )
{
$too_long = $next_length >= $maximum_line_length;
}
}
FORMATTER_DEBUG_FLAG_BREAK
&& do {
my $ltok = $token;
my $rtok = $next_nonblank_token ? $next_nonblank_token : "";
my $i_testp2 = $i_test + 2;
if ( $i_testp2 > $max_index_to_go + 1 ) {
$i_testp2 = $max_index_to_go + 1;
}
if ( length($ltok) > 6 ) { $ltok = substr( $ltok, 0, 8 ) }
if ( length($rtok) > 6 ) { $rtok = substr( $rtok, 0, 8 ) }
print STDOUT
"BREAK: i=$i_test imax=$imax $types_to_go[$i_test] $next_nonblank_type sp=($leading_spaces) lnext= $summed_lengths_to_go[$i_testp2] 2long=$too_long str=$strength $ltok $rtok\n";
};
# allow one extra terminal token after exceeding line length
# if it would strand this token.
if ( $rOpts_fuzzy_line_length
&& $too_long
&& $i_lowest == $i_test
&& $token_lengths_to_go[$i_test] > 1
&& $next_nonblank_type =~ /^[\;\,]$/ )
{
$too_long = 0;
}
last
if (
( $i_test == $imax ) # we're done if no more tokens,
|| (
( $i_lowest >= 0 ) # or no more space and we have a break
&& $too_long
)
);
}
#-------------------------------------------------------
# END of inner loop to find the best next breakpoint
# Now decide exactly where to put the breakpoint
#-------------------------------------------------------
# it's always ok to break at imax if no other break was found
if ( $i_lowest < 0 ) { $i_lowest = $imax }
# semi-final index calculation
my $i_next_nonblank = $inext_to_go[$i_lowest];
my $next_nonblank_type = $types_to_go[$i_next_nonblank];
my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
#-------------------------------------------------------
# ?/: rule 1 : if a break here will separate a '?' on this
# line from its closing ':', then break at the '?' instead.
#-------------------------------------------------------
foreach my $i ( $i_begin + 1 .. $i_lowest - 1 ) {
next unless ( $tokens_to_go[$i] eq '?' );
# do not break if probable sequence of ?/: statements
next if ($is_colon_chain);
# do not break if statement is broken by side comment
next
if ( $tokens_to_go[$max_index_to_go] eq '#'
&& $self->terminal_type_i( 0, $max_index_to_go ) !~
/^[\;\}]$/ );
# no break needed if matching : is also on the line
next
if ( $mate_index_to_go[$i] >= 0
&& $mate_index_to_go[$i] <= $i_next_nonblank );
$i_lowest = $i;
if ( $want_break_before{'?'} ) { $i_lowest-- }
last;
}
#-------------------------------------------------------
# END of inner loop to find the best next breakpoint:
# Break the line after the token with index i=$i_lowest
#-------------------------------------------------------
# final index calculation
$i_next_nonblank = $inext_to_go[$i_lowest];
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
FORMATTER_DEBUG_FLAG_BREAK
&& print STDOUT
"BREAK: best is i = $i_lowest strength = $lowest_strength\n";
#-------------------------------------------------------
# ?/: rule 2 : if we break at a '?', then break at its ':'
#
# Note: this rule is also in sub scan_list to handle a break
# at the start and end of a line (in case breaks are dictated
# by side comments).
#-------------------------------------------------------
if ( $next_nonblank_type eq '?' ) {
set_closing_breakpoint($i_next_nonblank);
}
elsif ( $types_to_go[$i_lowest] eq '?' ) {
set_closing_breakpoint($i_lowest);
}
#-------------------------------------------------------
# ?/: rule 3 : if we break at a ':' then we save
# its location for further work below. We may need to go
# back and break at its '?'.
#-------------------------------------------------------
if ( $next_nonblank_type eq ':' ) {
push @i_colon_breaks, $i_next_nonblank;
}
elsif ( $types_to_go[$i_lowest] eq ':' ) {
push @i_colon_breaks, $i_lowest;
}
# here we should set breaks for all '?'/':' pairs which are
# separated by this line
$line_count++;
# save this line segment, after trimming blanks at the ends
push( @i_first,
( $types_to_go[$i_begin] eq 'b' ) ? $i_begin + 1 : $i_begin );
push( @i_last,
( $types_to_go[$i_lowest] eq 'b' ) ? $i_lowest - 1 : $i_lowest );
# set a forced breakpoint at a container opening, if necessary, to
# signal a break at a closing container. Excepting '(' for now.
if ( $tokens_to_go[$i_lowest] =~ /^[\{\[]$/
&& !$forced_breakpoint_to_go[$i_lowest] )
{
set_closing_breakpoint($i_lowest);
}
# get ready to go again
$i_begin = $i_lowest + 1;
$last_break_strength = $lowest_strength;
$i_last_break = $i_lowest;
$leading_alignment_token = "";
$leading_alignment_type = "";
$lowest_next_token = '';
$lowest_next_type = 'b';
if ( ( $i_begin <= $imax ) && ( $types_to_go[$i_begin] eq 'b' ) ) {
$i_begin++;
}
# update indentation size
if ( $i_begin <= $imax ) {
$leading_spaces = leading_spaces_to_go($i_begin);
}
}
#-------------------------------------------------------
# END of main loop to set continuation breakpoints
# Now go back and make any necessary corrections
#-------------------------------------------------------
#-------------------------------------------------------
# ?/: rule 4 -- if we broke at a ':', then break at
# corresponding '?' unless this is a chain of ?: expressions
#-------------------------------------------------------
if (@i_colon_breaks) {
# using a simple method for deciding if we are in a ?/: chain --
# this is a chain if it has multiple ?/: pairs all in order;
# otherwise not.
# Note that if line starts in a ':' we count that above as a break
my $is_chain = ( $colons_in_order && @i_colon_breaks > 1 );
unless ($is_chain) {
my @insert_list = ();
foreach (@i_colon_breaks) {
my $i_question = $mate_index_to_go[$_];
if ( $i_question >= 0 ) {
if ( $want_break_before{'?'} ) {
$i_question = $iprev_to_go[$i_question];
}
if ( $i_question >= 0 ) {
push @insert_list, $i_question;
}
}
insert_additional_breaks( \@insert_list, \@i_first, \@i_last );
}
}
}
return ( \@i_first, \@i_last, $colon_count );
}
sub insert_additional_breaks {
# this routine will add line breaks at requested locations after
# sub set_continuation_breaks has made preliminary breaks.
my ( $ri_break_list, $ri_first, $ri_last ) = @_;
my $i_f;
my $i_l;
my $line_number = 0;
foreach my $i_break_left ( sort { $a <=> $b } @{$ri_break_list} ) {
$i_f = $ri_first->[$line_number];
$i_l = $ri_last->[$line_number];
while ( $i_break_left >= $i_l ) {
$line_number++;
# shouldn't happen unless caller passes bad indexes
if ( $line_number >= @{$ri_last} ) {
warning(
"Non-fatal program bug: couldn't set break at $i_break_left\n"
);
report_definite_bug();
return;
}
$i_f = $ri_first->[$line_number];
$i_l = $ri_last->[$line_number];
}
# Do not leave a blank at the end of a line; back up if necessary
if ( $types_to_go[$i_break_left] eq 'b' ) { $i_break_left-- }
my $i_break_right = $inext_to_go[$i_break_left];
if ( $i_break_left >= $i_f
&& $i_break_left < $i_l
&& $i_break_right > $i_f
&& $i_break_right <= $i_l )
{
splice( @{$ri_first}, $line_number, 1, ( $i_f, $i_break_right ) );
splice( @{$ri_last}, $line_number, 1, ( $i_break_left, $i_l ) );
}
}
return;
}
sub set_closing_breakpoint {
# set a breakpoint at a matching closing token
# at present, this is only used to break at a ':' which matches a '?'
my $i_break = shift;
if ( $mate_index_to_go[$i_break] >= 0 ) {
# CAUTION: infinite recursion possible here:
# set_closing_breakpoint calls set_forced_breakpoint, and
# set_forced_breakpoint call set_closing_breakpoint
# ( test files attrib.t, BasicLyx.pm.html).
# Don't reduce the '2' in the statement below
if ( $mate_index_to_go[$i_break] > $i_break + 2 ) {
# break before } ] and ), but sub set_forced_breakpoint will decide
# to break before or after a ? and :
my $inc = ( $tokens_to_go[$i_break] eq '?' ) ? 0 : 1;
set_forced_breakpoint( $mate_index_to_go[$i_break] - $inc );
}
}
else {
my $type_sequence = $type_sequence_to_go[$i_break];
if ($type_sequence) {
my $closing_token = $matching_token{ $tokens_to_go[$i_break] };
$postponed_breakpoint{$type_sequence} = 1;
}
}
return;
}
sub compare_indentation_levels {
# check to see if output line tabbing agrees with input line
# this can be very useful for debugging a script which has an extra
# or missing brace
my ( $guessed_indentation_level, $structural_indentation_level ) = @_;
if ( $guessed_indentation_level ne $structural_indentation_level ) {
$last_tabbing_disagreement = $input_line_number;
if ($in_tabbing_disagreement) {
}
else {
$tabbing_disagreement_count++;
if ( $tabbing_disagreement_count <= MAX_NAG_MESSAGES ) {
write_logfile_entry(
"Start indentation disagreement: input=$guessed_indentation_level; output=$structural_indentation_level\n"
);
}
$in_tabbing_disagreement = $input_line_number;
$first_tabbing_disagreement = $in_tabbing_disagreement
unless ($first_tabbing_disagreement);
}
}
else {
if ($in_tabbing_disagreement) {
if ( $tabbing_disagreement_count <= MAX_NAG_MESSAGES ) {
write_logfile_entry(
"End indentation disagreement from input line $in_tabbing_disagreement\n"
);
if ( $tabbing_disagreement_count == MAX_NAG_MESSAGES ) {
write_logfile_entry(
"No further tabbing disagreements will be noted\n");
}
}
$in_tabbing_disagreement = 0;
}
}
return;
}
1;