+ # 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 + 1 ]->[_CUMULATIVE_LENGTH_] -
+ $rLL->[$Ko]->[_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_nonblank($KK);
+
+ # skip past comments
+ while ( $Knn && $rLL->[$Knn]->[_TYPE_] eq '#' ) {
+ $Knn = $self->K_next_nonblank($Knn);
+ }
+ 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 = sub {
+ my ($rtoken_hash) = @_;
+
+ # Estimate the length from the line start to a given token
+ my $length = $rtoken_hash->[_CUMULATIVE_LENGTH_] - $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 = $rLL->[$KK]->[_CUMULATIVE_LENGTH_];
+ return $lentot;
+ };
+ my $length_to_closing_seqno = sub {
+ my ($seqno) = @_;
+ my $KK = $K_closing_container->{$seqno};
+ my $lentot = $rLL->[$KK]->[_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_];
+
+ # 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 = $rLL->[$Kfirst]->[_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:
+ # $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'
+
+ my $iline_oc = $outer_closing->[_LINE_INDEX_];
+ if ( $iline_oc <= $iline_oo + 1 ) {
+
+ # 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;
+ }
+ }
+ }
+ }
+
+ my $iline_ic = $inner_closing->[_LINE_INDEX_];
+
+ # 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_];
+ my $block_type_io = $inner_opening->[_BLOCK_TYPE_];
+ my $token_io = $inner_opening->[_TOKEN_];
+ $do_not_weld ||= $token_oo eq '(' && $token_io eq '{';
+ }
+
+ # DO-NOT-WELD RULE 3:
+ # Do not weld if this makes our line too long
+ $do_not_weld ||= $excess_length_to->($inner_opening) > 0;
+
+ if ($do_not_weld) {
+
+ # After neglecting a pair, we start measuring from start of point io
+ $starting_lentot = $inner_opening->[_CUMULATIVE_LENGTH_];
+ $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_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 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 sum_token_lengths {
+ my $self = shift;
+
+ # This has been merged into 'respace_tokens' but retained for reference
+ my $rLL = $self->{rLL};
+ my $cumulative_length = 0;
+ for ( my $KK = 0 ; $KK < @{$rLL} ; $KK++ ) {
+
+ # Save the length sum to just BEFORE this token
+ $rLL->[$KK]->[_CUMULATIVE_LENGTH_] = $cumulative_length;
+
+ # now set the length of this token
+ my $token_length = length( $rLL->[$KK]->[_TOKEN_] );
+
+ $cumulative_length += $token_length;
+ }
+ 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 ];
+ }
+ }
+
+ # 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();
+
+ # Implement any welding needed for the -wn or -cb options
+ $self->weld_containers();
+
+ # 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->break_lines();
+
+ ############################################################
+ # A possible future decomposition of 'break_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 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;
+}
+
+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, $level,
+ $ci_level, $available_spaces,
+ $index, $gnu_sequence_number,
+ $align_paren, $max_gnu_stack_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
+ # 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 ( $level_abs, $ci_level, $in_continued_quote ) = @_;
+
+ # Adjust levels if necessary to recycle whitespace:
+ # given $level_abs, the absolute level
+ # define $level, a possibly reduced level for whitespace
+ my $level = $level_abs;
+ if ( $rOpts_whitespace_cycle && $rOpts_whitespace_cycle > 0 ) {
+ 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];
+ }
+ $whitespace_last_level = $level_abs;
+
+ # modify for -bli, which adds one continuation indentation for
+ # opening braces
+ if ( $rOpts_brace_left_and_indent
+ && $max_index_to_go == 0
+ && $block_type_to_go[$max_index_to_go] =~ /$bli_pattern/o )
+ {
+ $ci_level++;
+ }
+
+ # patch to avoid trouble when input file has negative indentation.
+ # other logic should catch this error.
+ if ( $level < 0 ) { $level = 0 }
+
+ #-------------------------------------------
+ # handle the standard indentation scheme
+ #-------------------------------------------
+ unless ($rOpts_line_up_parentheses) {
+ my $space_count =
+ $ci_level * $rOpts_continuation_indentation +
+ $level * $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;
+ return;
+ }
+
+ #-------------------------------------------------------------
+ # handle case of -lp indentation..
+ #-------------------------------------------------------------
+
+ # 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_to_go =~ /^([\:\?\,f])$/
+
+ # or previous character was opening and this does not close it
+ || ( $last_nonblank_type_to_go eq '{' && $type ne '}' )
+ || ( $last_nonblank_type_to_go eq '(' and $type ne ')' )
+
+ # or this token is one of these:
+ || $type =~ /^([\.]|\|\||\&\&)$/
+
+ # or this is a closing structure
+ || ( $last_nonblank_type_to_go eq '}'
+ && $last_nonblank_token_to_go eq $last_nonblank_type_to_go )
+
+ # or previous token was keyword 'return'
+ || ( $last_nonblank_type_to_go eq 'k'
+ && ( $last_nonblank_token_to_go 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_to_go}
+ && (
+ $last_last_nonblank_type_to_go =~ /^[\}\)\]]$/
+
+ # 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_to_go eq 'k' ) {
+
+ if ( $want_break_before{$last_nonblank_token_to_go} ) {
+ $line_start_index_to_go--;
+ }
+ }
+ elsif ( $want_break_before{$last_nonblank_type_to_go} ) {
+ $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 -ndsc 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;
+
+ 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_bli_pattern();
+ make_block_brace_vertical_tightness_pattern();
+ make_blank_line_pattern();
+
+ prepare_cuddled_block_types();
+ if ( $rOpts->{'dump-cuddled-block-list'} ) {
+ dump_cuddled_block_list(*STDOUT);
+ Perl::Tidy::Exit 0;
+ }
+
+ if ( $rOpts->{'line-up-parentheses'} ) {
+
+ if ( $rOpts->{'indent-only'}
+ || !$rOpts->{'add-newlines'}
+ || !$rOpts->{'delete-old-newlines'} )
+ {
+ Perl::Tidy::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'} ) {
+ Perl::Tidy::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'} ) {
+ Perl::Tidy::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'} ) {
+ Perl::Tidy::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 = ();
+ unless ( @_ = split_words( $rOpts->{'outdent-keyword-okl'} ) ) {
+ @_ = qw(next last redo goto return); # defaults
+ }
+
+ # FUTURE: if not a keyword, assume that it is an identifier
+ foreach (@_) {
+ if ( $Perl::Tidy::Tokenizer::is_keyword{$_} ) {
+ $outdent_keyword{$_} = 1;
+ }
+ else {
+ Perl::Tidy::Warn "ignoring '$_' in -okwl list; not a perl keyword";
+ }
+ }
+
+ # implement user whitespace preferences
+ if ( @_ = split_words( $rOpts->{'want-left-space'} ) ) {
+ @want_left_space{@_} = (1) x scalar(@_);
+ }
+
+ if ( @_ = split_words( $rOpts->{'want-right-space'} ) ) {
+ @want_right_space{@_} = (1) x scalar(@_);
+ }
+
+ if ( @_ = split_words( $rOpts->{'nowant-left-space'} ) ) {
+ @want_left_space{@_} = (-1) x scalar(@_);
+ }
+
+ if ( @_ = split_words( $rOpts->{'nowant-right-space'} ) ) {
+ @want_right_space{@_} = (-1) x scalar(@_);
+ }
+ if ( $rOpts->{'dump-want-left-space'} ) {
+ dump_want_left_space(*STDOUT);
+ Perl::Tidy::Exit 0;
+ }
+
+ if ( $rOpts->{'dump-want-right-space'} ) {
+ dump_want_right_space(*STDOUT);
+ Perl::Tidy::Exit 0;
+ }
+
+ # default keywords for which space is introduced before an opening paren
+ # (at present, including them messes up vertical alignment)
+ @_ = qw(my local our and or err eq ne if else elsif until
+ unless while for foreach return switch case given when catch);
+ @space_after_keyword{@_} = (1) x scalar(@_);
+
+ # first remove any or all of these if desired
+ if ( @_ = split_words( $rOpts->{'nospace-after-keyword'} ) ) {
+
+ # -nsak='*' selects all the above keywords
+ if ( @_ == 1 && $_[0] eq '*' ) { @_ = keys(%space_after_keyword) }
+ @space_after_keyword{@_} = (0) x scalar(@_);
+ }
+
+ # then allow user to add to these defaults
+ if ( @_ = split_words( $rOpts->{'space-after-keyword'} ) ) {
+ @space_after_keyword{@_} = (1) x scalar(@_);
+ }
+
+ # implement user break preferences
+ my @all_operators = qw(% + - * / x != == >= <= =~ !~ < > | &
+ = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
+ . : ? && || and or err xor
+ );
+
+ my $break_after = sub {
+ foreach my $tok (@_) {
+ 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 {
+ foreach my $tok (@_) {
+ 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);
+ @_ = qw(until while unless if ; : );
+ push @_, ',';
+ @is_do_follower{@_} = (1) x scalar(@_);