Perl::Tidy - Parses and beautifies perl source
use Perl::Tidy;
my $error_flag = Perl::Tidy::perltidy(
source => $source,
destination => $destination,
stderr => $stderr,
argv => $argv,
perltidyrc => $perltidyrc,
logfile => $logfile,
errorfile => $errorfile,
teefile => $teefile,
debugfile => $debugfile,
formatter => $formatter, # callback object (see below)
dump_options => $dump_options,
dump_options_type => $dump_options_type,
prefilter => $prefilter_coderef,
postfilter => $postfilter_coderef,
);This module makes the functionality of the perltidy utility available to perl scripts. Any or all of the input parameters may be omitted, in which case the @ARGV array will be used to provide input parameters as described in the perltidy(1) man page.
For example, the perltidy script is basically just this:
use Perl::Tidy;
Perl::Tidy::perltidy();The call to perltidy returns a scalar $error_flag which is TRUE if an error caused premature termination, and FALSE if the process ran to normal completion. Additional discuss of errors is contained below in the ERROR HANDLING section.
The module accepts input and output streams by a variety of methods. The following list of parameters may be any of the following: a filename, an ARRAY reference, a SCALAR reference, or an object with either a getline or print method, as appropriate.
source - the source of the script to be formatted
destination - the destination of the formatted output
stderr - standard error output
perltidyrc - the .perltidyrc file
logfile - the .LOG file stream, if any
errorfile - the .ERR file stream, if any
dump_options - ref to a hash to receive parameters (see below),
dump_options_type - controls contents of dump_options
dump_getopt_flags - ref to a hash to receive Getopt flags
dump_options_category - ref to a hash giving category of options
dump_abbreviations - ref to a hash giving all abbreviationsThe following chart illustrates the logic used to decide how to treat a parameter.
ref($param) $param is assumed to be:
----------- ---------------------
undef a filename
SCALAR ref to string
ARRAY ref to array
(other) object with getline (if source) or print methodIf the parameter is an object, and the object has a close method, that close method will be called at the end of the stream.
If the source parameter is given, it defines the source of the input stream. If an input stream is defined with the source parameter then no other source filenames may be specified in the @ARGV array or argv parameter.
If the destination parameter is given, it will be used to define the file or memory location to receive output of perltidy.
Important note if destination is a string or array reference. Perl strings of characters which are decoded as utf8 by Perl::Tidy can be returned in either of two possible states, decoded or encoded, and it is important that the calling program and Perl::Tidy are in agreement regarding the state to be returned. A flag --encode-output-strings, or simply -eos, was added in Perl::Tidy version 20220217 for this purpose.
Use -eos if Perl::Tidy should encode any string which it decodes. This is the current default because it makes perltidy behave well as a filter, and is the correct setting for most programs. But do not use this setting if the calling program will encode the data too, because double encoding will corrupt data.
Use -neos if a string should remain decoded if it was decoded by Perl::Tidy. This is only appropriate if the calling program will handle any needed encoding before outputting the string. If needed, this flag can be added to the end of the argv parameter passed to Perl::Tidy.
For some background information see https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md.
This change in default behavior was made over a period of time as follows:
For versions before 20220217 the -eos flag was not available and the behavior was equivalent to -neos.
In version 20220217 the -eos flag was added but the default remained -neos.
For versions after 20220217 the default was set to -eos.
The stderr parameter allows the calling program to redirect the stream that would otherwise go to the standard error output device to any of the stream types listed above. This stream contains important warnings and errors related to the parameters passed to perltidy.
If the perltidyrc file is given, it will be used instead of any .perltidyrc configuration file that would otherwise be used.
The errorfile parameter allows the calling program to capture the stream that would otherwise go to either a .ERR file. This stream contains warnings or errors related to the contents of one source file or stream.
The reason that this is different from the stderr stream is that when perltidy is called to process multiple files there will be up to one .ERR file created for each file and it would be very confusing if they were combined.
However if perltidy is called to process just a single perl script then it may be more convenient to combine the errorfile stream with the stderr stream. This can be done by setting the -se parameter, in which case this parameter is ignored.
The logfile parameter allows the calling program to capture the log stream. This stream is only created if requested with a -g parameter. It contains detailed diagnostic information about a script which may be useful for debugging.
The teefile parameter allows the calling program to capture the tee stream. This stream is only created if requested with one of the 'tee' parameters, a --tee-pod , --tee-block-comments, --tee-side-commnts, or --tee-all-comments.
The debugfile parameter allows the calling program to capture the stream produced by the --DEBUG parameter. This parameter is mainly used for debugging perltidy itself.
If the argv parameter is given, it will be used instead of the @ARGV array. The argv parameter may be a string, a reference to a string, or a reference to an array. If it is a string or reference to a string, it will be parsed into an array of items just as if it were a command line string.
If the dump_options parameter is given, it must be the reference to a hash. In this case, the parameters contained in any perltidyrc configuration file will be placed in this hash and perltidy will return immediately. This is equivalent to running perltidy with --dump-options, except that the parameters are returned in a hash rather than dumped to standard output. Also, by default only the parameters in the perltidyrc file are returned, but this can be changed (see the next parameter). This parameter provides a convenient method for external programs to read a perltidyrc file. An example program using this feature, perltidyrc_dump.pl, is included in the distribution.
Any combination of the dump_ parameters may be used together.
This parameter is a string which can be used to control the parameters placed in the hash reference supplied by dump_options. The possible values are 'perltidyrc' (default) and 'full'. The 'full' parameter causes both the default options plus any options found in a perltidyrc file to be returned.
If the dump_getopt_flags parameter is given, it must be the reference to a hash. This hash will receive all of the parameters that perltidy understands and flags that are passed to Getopt::Long. This parameter may be used alone or with the dump_options flag. Perltidy will exit immediately after filling this hash. See the demo program perltidyrc_dump.pl for example usage.
If the dump_options_category parameter is given, it must be the reference to a hash. This hash will receive a hash with keys equal to all long parameter names and values equal to the title of the corresponding section of the perltidy manual. See the demo program perltidyrc_dump.pl for example usage.
If the dump_abbreviations parameter is given, it must be the reference to a hash. This hash will receive all abbreviations used by Perl::Tidy. See the demo program perltidyrc_dump.pl for example usage.
A code reference that will be applied to the source before tidying. It is expected to take the full content as a string in its input, and output the transformed content.
A code reference that will be applied to the tidied result before outputting. It is expected to take the full content as a string in its input, and output the transformed content.
Note: A convenient way to check the function of your custom prefilter and postfilter code is to use the --notidy option, first with just the prefilter and then with both the prefilter and postfilter. See also the file filter_example.pl in the perltidy distribution.
An exit value of 0, 1, or 2 is returned by perltidy to indicate the status of the result.
A exit value of 0 indicates that perltidy ran to completion with no error messages.
An exit value of 1 indicates that the process had to be terminated early due to errors in the input parameters. This can happen for example if a parameter is misspelled or given an invalid value. The calling program should check for this flag because if it is set the destination stream will be empty or incomplete and should be ignored. Error messages in the stderr stream will indicate the cause of any problem.
An exit value of 2 indicates that perltidy ran to completion but there are warning messages in the stderr stream related to parameter errors or conflicts and/or warning messages in the errorfile stream relating to possible syntax errors in the source code being tidied.
In the event of a catastrophic error for which recovery is not possible perltidy terminates by making calls to croak or confess to help the programmer localize the problem. These should normally only occur during program development.
Parameters which control formatting may be passed in several ways: in a .perltidyrc configuration file, in the perltidyrc parameter, and in the argv parameter.
If the -pbp style is used it will typically be necessary to also specify a -nst flag. This is necessary to turn off the -st flag contained in the -pbp parameter set which otherwise would direct the output stream to the standard output.
The following example uses string references to hold the input and output code and error streams, and illustrates checking for errors.
use Perl::Tidy;
my $source_string = <<'EOT';
my$error=Perl::Tidy::perltidy(argv=>$argv,source=>\$source_string,
destination=>\$dest_string,stderr=>\$stderr_string,
errorfile=>\$errorfile_string,);
EOT
my $dest_string;
my $stderr_string;
my $errorfile_string;
my $argv = "-npro"; # Ignore any .perltidyrc at this site
$argv .= " -pbp"; # Format according to perl best practices
$argv .= " -nst"; # Must turn off -st in case -pbp is specified
$argv .= " -se"; # -se appends the errorfile to stderr
## $argv .= " --spell-check"; # uncomment to trigger an error
print "<<RAW SOURCE>>\n$source_string\n";
my $error = Perl::Tidy::perltidy(
argv => $argv,
source => \$source_string,
destination => \$dest_string,
stderr => \$stderr_string,
errorfile => \$errorfile_string, # ignored when -se flag is set
##phasers => 'stun', # uncomment to trigger an error
);
if ($error) {
# serious error in input parameters, no tidied output
print "<<STDERR>>\n$stderr_string\n";
die "Exiting because of serious errors\n";
}
if ($dest_string) { print "<<TIDIED SOURCE>>\n$dest_string\n" }
if ($stderr_string) { print "<<STDERR>>\n$stderr_string\n" }
if ($errorfile_string) { print "<<.ERR file>>\n$errorfile_string\n" }Additional examples are given in examples section of the perltidy distribution.
The formatter parameter is an optional callback object which allows the calling program to receive tokenized lines directly from perltidy for further specialized processing. When this parameter is used, the two formatting options which are built into perltidy (beautification or html) are ignored. The following diagram illustrates the logical flow:
|-- (normal route) -> code beautification
caller->perltidy->|-- (-html flag ) -> create html
|-- (formatter given)-> callback to write_lineThis can be useful for processing perl scripts in some way. The parameter $formatter in the perltidy call,
formatter => $formatter,is an object created by the caller with a write_line method which will accept and process tokenized lines, one line per call. Here is a simple example of a write_line which merely prints the line number, the line type (as determined by perltidy), and the text of the line:
sub write_line {
# This is called from perltidy line-by-line
my $self = shift;
my $line_of_tokens = shift;
my $line_type = $line_of_tokens->{_line_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $input_line = $line_of_tokens->{_line_text};
print "$input_line_number:$line_type:$input_line";
}The complete program, perllinetype, is contained in the examples section of the source distribution. As this example shows, the callback method receives a parameter $line_of_tokens, which is a reference to a hash of other useful information. This example uses these hash entries:
$line_of_tokens->{_line_number} - the line number (1,2,...)
$line_of_tokens->{_line_text} - the text of the line
$line_of_tokens->{_line_type} - the type of the line, one of:
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 scriptMost applications will be only interested in lines of type CODE. For another example, let's write a program which checks for one of the so-called naughty matching variables &`, $&, and $', which can slow down processing. Here is a write_line, from the example program find_naughty.pl, which does that:
sub write_line {
# This is called back from perltidy line-by-line
# We're looking for $`, $&, and $'
my ( $self, $line_of_tokens ) = @_;
# pull out some stuff we might need
my $line_type = $line_of_tokens->{_line_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $input_line = $line_of_tokens->{_line_text};
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
chomp $input_line;
# skip comments, pod, etc
return if ( $line_type ne 'CODE' );
# loop over tokens looking for $`, $&, and $'
for ( my $j = 0 ; $j < @$rtoken_type ; $j++ ) {
# we only want to examine token types 'i' (identifier)
next unless $$rtoken_type[$j] eq 'i';
# pull out the actual token text
my $token = $$rtokens[$j];
# and check it
if ( $token =~ /^\$[\`\&\']$/ ) {
print STDERR
"$input_line_number: $token\n";
}
}
}This example pulls out these tokenization variables from the $line_of_tokens hash reference:
$rtoken_type = $line_of_tokens->{_rtoken_type};
$rtokens = $line_of_tokens->{_rtokens};The variable $rtoken_type is a reference to an array of token type codes, and $rtokens is a reference to a corresponding array of token text. These are obviously only defined for lines of type CODE. Perltidy classifies tokens into types, and has a brief code for each type. You can get a complete list at any time by running perltidy from the command line with
perltidy --dump-token-typesIn the present example, we are only looking for tokens of type i (identifiers), so the for loop skips past all other types. When an identifier is found, its actual text is checked to see if it is one being sought. If so, the above write_line prints the token and its line number.
The examples section of the source distribution has some examples of programs which use the formatter option.
For help with perltidy's peculiar way of breaking lines into tokens, you might run, from the command line,
perltidy -D filenamewhere filename is a short script of interest. This will produce filename.DEBUG with interleaved lines of text and their token types. The -D flag has been in perltidy from the beginning for this purpose. If you want to see the code which creates this file, it is sub Perl::Tidy::Debugger::write_debug_entry
&perltidyThe module 'Perl::Tidy' comes with a binary 'perltidy' which is installed when the module is installed. The module name is case-sensitive. For example, the basic command for installing with cpanm is 'cpanm Perl::Tidy'.
This man page documents Perl::Tidy version 20250105
This package is free software; you can redistribute it and/or modify it under the terms of the "GNU General Public License".
Please refer to the file "COPYING" for details.
The source code repository is at https://github.com/perltidy/perltidy.
To report a new bug or problem, use the "issues" link on this page.
The perltidy(1) man page describes all of the features of perltidy. It can be found at http://perltidy.sourceforge.net.
Perl-Tidy-20250105/docs/BugLog.html 0000644 0001750 0001750 00000710260 14735777212 015643 0 ustar steve steveAutomated random testing produced an error tokenizing the following code fragment:
s s(..)(.)sss
;This is equivalent to 's/(..)(.)//s' with 's' as the delimiter instead of '/'. It was tokenized correctly except when the final 's' was followed by a newline, as in the example. When the delimiter is a letter rather than a punctuation character, perltidy exercises some seldom-used code which had an off-by-one loop limit. This has been fixed.
12 Nov 2021.
Automated random testing produced an error tokenizing the following fragment:
my$seed=$$^$^T;The first ^ should have been tokenized as the bitwise xor operator but was not. This is fixed with this update.
8 Nov 2021
Automated random testing produced an error with something like the following input line taken from an obfuscated perl script:
open(IN, $ 0);The '0' was missing in the output:
open( IN, $ );The tokenization was correct, but a line of code in the formatter which removes the space between the '$' and the '0' should have used a 'defined' when doing a check:
$token .= $word if ($word); # OLD: errorThis if test fails on '0'. The corrected line is
$token .= $word if ( defined($word) ); # NEW: fixes c104This fixes the problem and gives the correct formatted result
open( IN, $0 );8 Nov 2021.
Random testing produced an undefined variable reference for the following input
make_sorter ( sort_sha => sub {sha512 ( $_} );
make_sorter ( sort_ids => sub {/^ID:(\d+)/} );when formatted with the following input parameters:
--space-function-paren
--maximum-line-length=26
--noadd-newlinesNotice that the input script has a peculiar syntax error - the last two closing tokens of the first line are transposed. (Ironically, this snippet is taken from code which accompanied the book Perl Best Practices). The perltidy tokenizer caught the syntax error, but the formatter touched an undefined variable while attempting to do the formatting. It would be possible to just skip formatting for errors like this, but it can sometimes help finding bugs to see an attempted formatting. So the formatter coding has been corrected to avoid the undefined variable reference.
This fixes issue c102.
5 Nov 2021.
In some rare cases, one-line blocks with side comments were exceeding the line length limit. These usually had a semicolon between the closing block brace and the side comment. For example:
my $size
= do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipeThis update breaks the one-line block in an attempt to keep the total length below the line length limit. The result on the above is:
my $size = do {
local $^W;
-f $local && -s _;
}; # no ALLO if sending data from a pipeNote that this break can be prevented by including the flag --ignore-side-comment-lengths or -iscl.
3 Nov 2021.
For something like the following snippet, a warning about deprecated syntax was either going into the error file or the log file, depending on formatting. This has been fixed.
do $roff ( &verify($tpage) );20 Oct 2021, 72e4bb1.
An error was discovered and corrected in the behavior of the --closing-side-comment (-csc) flag when only subs were being marked with the setting -cscl='sub'. The problem was that in rare cases a closing paren could be marked with '## end'. The cause of the problem is that the pattern matching regex which was generated for this case happens to match an empty string, and it could happen that certain parens had empty strings as block names. This was fixed in two ways. First, the regex was fixed so that it cannot match an empty string. Second, a test for an empty string was added.
20 Oct 2021, aa1a019.
An update was made to improve vertical alignment in situations where parens are omitted around lists. The goal is to make lists without parens align as they would if they were contained in parens. Some examples:
# OLD, no parens, no alignment:
glVertex3d $cx + $s * $xs, $cy, $z;
glVertex3d $cx, $cy + $s * $ys, $z;
glVertex3d $cx - $s * $xs, $cy, $z;
glVertex3d $cx, $cy - $s * $ys, $z;
# OLD, with parens and aligned:
glVertex3d( $cx + $s * $xs, $cy, $z );
glVertex3d( $cx, $cy + $s * $ys, $z );
glVertex3d( $cx - $s * $xs, $cy, $z );
glVertex3d( $cx, $cy - $s * $ys, $z );
# NEW, no parens but aligned
glVertex3d $cx + $s * $xs, $cy, $z;
glVertex3d $cx, $cy + $s * $ys, $z;
glVertex3d $cx - $s * $xs, $cy, $z;
glVertex3d $cx, $cy - $s * $ys, $z;
# OLD
mkTextConfig $c, $x, $y, -anchor => 'se', $color;
mkTextConfig $c, $x + 30, $y, -anchor => 's', $color;
mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color;
mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color;
# NEW
mkTextConfig $c, $x, $y, -anchor => 'se', $color;
mkTextConfig $c, $x + 30, $y, -anchor => 's', $color;
mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color;
mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color;
# OLD
permute_test [ 'a', 'b', 'c' ], '/', '/', [ 'a', 'b', 'c' ];
permute_test [ 'a,', 'b', 'c,' ], '/', '/', [ 'a,', 'b', 'c,' ];
permute_test [ 'a', ',', '#', 'c' ], '/', '/', [ 'a', ',', '#', 'c' ];
permute_test [ 'f_oo', 'b_ar' ], '/', '/', [ 'f_oo', 'b_ar' ];
# NEW
permute_test [ 'a', 'b', 'c' ], '/', '/', [ 'a', 'b', 'c' ];
permute_test [ 'a,', 'b', 'c,' ], '/', '/', [ 'a,', 'b', 'c,' ];
permute_test [ 'a', ',', '#', 'c' ], '/', '/', [ 'a', ',', '#', 'c' ];
permute_test [ 'f_oo', 'b_ar' ], '/', '/', [ 'f_oo', 'b_ar' ];
# OLD:
is $thingy, "fee", "source filters apply to evalbytten strings";
is "foo", $unfiltered_foo, 'filters leak not out of byte evals';
is $av->[2], "NAME:my_xop", "OP_NAME returns registered name";
is $av->[3], "DESC:XOP for testing", "OP_DESC returns registered desc";
is $av->[4], "CLASS:$OA_UNOP", "OP_CLASS returns registered class";
is scalar @$av, 7, "registered peep called";
is $av->[5], "peep:$unop", "...with correct 'o' param";
is $av->[6], "oldop:$kid", "...and correct 'oldop' param";
# NEW
is $av->[2], "NAME:my_xop", "OP_NAME returns registered name";
is $av->[3], "DESC:XOP for testing", "OP_DESC returns registered desc";
is $av->[4], "CLASS:$OA_UNOP", "OP_CLASS returns registered class";
is scalar @$av, 7, "registered peep called";
is $av->[5], "peep:$unop", "...with correct 'o' param";
is $av->[6], "oldop:$kid", "...and correct 'oldop' param";20 Oct 2021, 1dffec5.
This update keeps both of these configurations stable for all cases except when the -lp option is used. For the -lp option, both become one-line blocks (the second case) to prevents the -lp indentation style from being lost. This update was made to minimize changes to existing formatting.
$obj = {
foo => sub { "bar" }
};
$obj = { foo => sub { "bar" } };17 Oct 2021, f05e6b5.
In some structures used in Moose coding, some asymmetrical container breaks were being caused by the braces being tokenized as hash braces rather than block braces. This was also causing some unwanted warning messages.
# OLD
::is(
::exception { has '+bar' => ( default => sub { 100 } );
},
undef,
'... extended the attribute successfully'
);
# NEW
::is(
::exception {
has '+bar' => ( default => sub { 100 } );
},
undef,
'... extended the attribute successfully'
);This fixes issue c074.
12 Oct 2021, 7e873fa.
Random testing revealed a problem in which an old closing side comment was not being deleted when it fell below the interval specified on -csci=n and the -cscw flag was also set.
For example, the following snippet has been formatted with -csc -csci=1. The interval -csci=1 insures that all blocks get side comments:
if ($x3) {
$zz;
if ($x2) {
if ($x1) {
..;
} ## end if ($x1)
$a;
$b;
$c;
} ## end if ($x2)
} ## end if ($x3)If we then run with -csc -csci=6, the comment ## end if ($x1) will fall below the threshold and be removed (correctly):
if ($x3) {
$zz;
if ($x2) {
if ($x1) {
..;
}
$a;
$b;
$c;
} ## end if ($x2)
} ## end if ($x3)But if we also add the -cscw flag (warnings) then it was not being removed. This update fixes this problem (issue c081).
2 Oct 2021, 25ef8e8
In the following snippet, the final one-line anonymous sub is not followed by a comma. This caused the -lp mode to revert to standard indentation mode because a forced line break was being made after the closing sub brace:
# OLD, perltidy -lp
$got = timethese(
$iterations,
{
Foo => sub { ++$foo },
Bar => '++$bar',
Baz => sub { ++$baz }
}
);An update was made to check for and fix this.
# NEW, perltidy -lp
$got = timethese(
$iterations,
{
Foo => sub { ++$foo },
Bar => '++$bar',
Baz => sub { ++$baz }
}
);But note that this only applies to one-line anonymous subs. If an anonymous sub is broken into several lines due to its length or complexity, then these forced line breaks cause indentation to revert to the standard indentation scheme.
22 Sep 2021, 4fd58f7.
Testing with random parameters produced a formatting instability related to the -vmll flag. The problem was due to a subtle difference in the definition of nesting depth and indentation level. The vertical aligner was using nesting depth instead of indentation level to compute the maximum line length when -vmll is set. In some rare cases there is a difference. The problem was fixed by passing the maximum line length to the vertical aligner so that the calculation is only done in the formatter. This fixes b1209.
20 Sep 2021, acf1d2d.
Testing with random parameters produced a formatting instability which could be triggered when there is a short line length limit and there is a long side comment on the closing brace of a sort/map/grep/eval block. The problem was due to not correctly including the length of the side comment when testing to see if the block could fit on one line. This update fixes issue b1208.
18 Sep 2021, 0af1321.
The -nfpva parameter was not working correctly for functions called with pointers. For example
# OLD: perltidy -sfp -nfpva
$self->method ( 'parameter_0', 'parameter_1' );
$self->method_with_long_name ( 'parameter_0', 'parameter_1' );
# FIXED: perltidy -sfp -nfpva
$self->method ( 'parameter_0', 'parameter_1' );
$self->method_with_long_name ( 'parameter_0', 'parameter_1' );The problem had to do with how the pointer tokens '->' are represented internally and has been fixed.
17 Sep 2021,e3b4a6f.
Testing with random parameters produced another instability caused by misparsing an 'x' operator after a possible file handle. This is very similar to b1205, but involves a sigil immediately following a times operator.
To illustrate some cases, consider:
sub x {print "arg is $_[0]\n"}
my $num = 3;
my @list=(1,2,3);
my %hash=(1,2,3,4);
open (my $fh, ">", "junk.txt");
print $fh x$num; # prints a GLOB $num times to STDOUT
print $fh x9; # prints 'x9' to file 'junk.txt'
print $fh x@list; # prints a GLOB 3 times to STDOUT
print $fh x%hash; # prints a GLOB 2 times to STDOUTNote in particular the different treatment of the first two print statements.
This update fixes case b1207.
15 Sep 2021, 107586f.
Testing with random parameters produced an instability due welding with a very short line length and large value of -ci. This is similar to issues b1197-b1204 and fixed with a similar method.
14 Sep 2021, 9704cd7.
Testing with random parameters produced an instability caused by misparsing an 'x' operator after a possible file handle. Testing with Perl showed that an 'x' followed by a '(' in this location is always the 'times' operator and never a call to a function 'x'. If x is immediately followed by a number it is subject to the usual weird parsing rules at such a location.
To illustrate, consider what these statements do:
open( my $zz, ">", "junk.txt" );
sub x { return $_[0] } # never called
print $zz x(2); # prints a glob 2 times; not a function call
print $zz x 2; # prints a glob 2 times
print $zz x2; # syntax error
print $zz x; # syntax error
print $zz z; # prints 'z' in file 'junk.txt'This update fixes case b1205.
13 Sep 2021, cfa2515.
Testing with random input parameters produced a number of cases of unstable formatting. All of these involved some combination of a short maximum line length, a large -ci and -i, and often one or more of -xci -lp and -wn. These parameters can force lines to break at poor locations. All of these cases were fixed by introducing a quantity called the 'stress_level', which is the approximate indentation level at which the line break logic comes under high stress and become unstable. For default parameters the stress level is about 12, but unusual parameter combinations can make it much less, even as low as zero. For code which is at an indentation level greater than this depth, some defensive actions are taken to avoid instability, such as temporarily turning off the -xci flag when the indentation depth exceeds the stress level. Most actual working code will not be influenced by this logic. Actual code which has a very deep indentation level can avoid problems by using a long line length, a short number of indentation spaces, or even the whitespace-cycle parameter.
This update fixes issues b1197 b1198 b1199 b1200 b1201 b1202 b1203 b1204
12 Sep 2021, 0ac771e.
This issues can be illustrated with the following input script:
{
if ($xxx) {
...
} ## end if ($xxx ...
# b <filename>:<line> [<condition>]
}
# OLD: perltidy -fpsc=21
{
if ($xxx) {
...;
} ## end if ($xxx ...
# b <filename>:<line> [<condition>]
}The comment '# b ..' moved over to the column 21 to the right as if it were a side comment. The reason is that it accidentally got marked as a hanging side comment. It should not have been because the previous side comment was a closing side comment. This update fixes this:
# NEW: perltidy -fpsc=21
{
if ($xxx) {
...;
} ## end if ($xxx ...
# b <filename>:<line> [<condition>]
}This fixes issue c070.
10 Sep 2021, ec6ccf9.
This issue is illustrated with the following line:
my $aa = $^ ? "defined" : "not defined";If we tell perltidy to remove the space before the '?', then the output will no longer be a valid script:
# perltidy -nwls='?':
my $aa = $^? "defined" : "not defined";The problem is that Perl considers '$^?' to be a special variable. So Rerunning perltidy on this gives an error, and perl also gives an error. This update fixes the problem by preventing a space after anything like '$^' from being removed a new special variable would be created.
This fixes issue c068.
7 Sep 2021, 9bc23d1.
This issue is illustrated with the following line (rt80058):
my $ok=$^Oeq"linux";Running perltidy generated a warning message which is caused by the lack of space before the 'eq'. This update fixes the problem.
4 Sep 2021, df79a20.
Testing produced an unusual parsing problem in perltidy which can be illustrated with the following simple script:
my $str = 'a'x2.2;
print $str,"\n";Normally an integer would follow the 'x' operator, but Perl seems to accept any valid number and truncates it to an integer. So in this case the number 2.2 is truncated to 2 and the output is 'aa'.
But perltidy, with default parameters, formats this as
my $str = 'a' x 2 . 2;
print $str,"\n";which prints the result "aa2". The problem is fixed with this update. With the update, the result is
my $str = 'a' x 2.2;
print $str, "\n";which is equivalent to the original script.
This fixes issue c065.
4 Sep 2021, f242f78.
Testing with random parameters produced two similar cases of unstable formatting which are fixed with this update.
28 Aug 2021, ab9ad39.
Testing with random parameters produced a case of unstable formatting which is fixed with this update.
This fixes case b1194, and at the same time it simplifies the logic which handles issues b1183 and b1191.
21 Aug 2021, 62e5b01.
This update fixes some problems found in random testing with tab characters. For example, in the following snippet there is a tab character after 'sub'
do sub : lvalue {
return;
}Running perltidy on this repeatedly keep increasing the space between 'sub' and ':'
# OLD: perltidy
do sub : lvalue {
return;
}
# OLD: perltidy
do sub : lvalue {
return;
}etc.
# NEW: perltidy
do sub : lvalue {
return;
}Problems like this can occur if string comparisons use ' ' instead of the regex \s when working on spaces. Several instances of this were located and corrected.
This fixes issue c062.
18 Aug 2021, d86787f.
Testing with random input produced an error condition involving a side comment placed between a sub name and prototype, as in the following snippet:
sub
witch # sc
() # prototype may be on new line ...
{ print "which?\n" }
witch();The current version of perltidy makes an error:
# OLD: perltidy
sub witch # sc () # prototype may be on new line ...
{ print "which?\n" }
witch();This update corrects the problem:
# NEW: perltidy
sub witch # sc
() # prototype may be on new line ...
{ print "which?\n" }
witch();This fixes case c061;
18 Aug 2021, 3bb2b2c.
The default formatting produced an undesirable line break at the last '&&' term in the following:
my $static = grep {
$class =~ /^$_$/
|| $fullname =~ /^$_$/
|| $method_name =~ /^$_$/
&& ( $class eq 'main' )
} grep { !m![/\\.]! } $self->dispatch_to; # filter PATHThis update corrects this to give
my $static = grep {
$class =~ /^$_$/
|| $fullname =~ /^$_$/
|| $method_name =~ /^$_$/ && ( $class eq 'main' )
} grep { !m![/\\.]! } $self->dispatch_to; # filter PATH15 Aug 2021, 9d1c8a9.
Testing with random parameters triggered an an internal error check. This was caused by a recent coding change which allowed a weld across a side comment. The problem was in the development version, not in the latest released version, and is fixed with this update. This closes issue c058.
14 Aug 2021, 5a13886.
Testing with random parameters produced unstable formatting involving parameters which included -lp -sbvtc=1. This update fixes this problem, case b1193.
13 Aug 2021, d4c3425.
The ultimate cause of the undefined variable reference in the previous issue was found to be a typo in the tokenizer. This update finishes fixing issue c055.
10 Aug 2021, 2963db3
In testing, the following unbalanced snippet caused a reference to an undefined value in the current development version (but not in the current released version).
if($CPAN::Config->{term_is_latin}){
$swhat=~s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg;}if($self->colorize_output){if($CPAN::DEBUG&&$swhat=~/^Debug\(/){
$ornament=$CPAN::Config->{colorize_debug}||"black on_cyan";}A check has been added to fix this.
10 Aug 2021, a3f9774.
Testing with random parameters produced unstable formatting with the following snippet when run with some unusual parameters:
@EXPORT =
( @{$EXPORT_TAGS{standard}}, );It was also be formatted as
@EXPORT = (
@{$EXPORT_TAGS{standard}},
);The problem was that a list formatting style was turning on and off due to the the needless terminal comma within the parens. A patch was made to ignore commas like this when deciding if list formatting should be used.
This fixes case b1192.
10 Aug 2021, b949215.
Random testing produced an instability involving an unusual parameter combination and the following input code:
$_[0]eq$_[1]
or($_[1]=~/^([!~])(.)([\x00-\xff]*)/)
and($1 eq '!')
^(eval{($_[2]."::".$_[0])=~/$2$3/;});This update fixes case b1191.
9 Aug 2021, 16b4575.
Testing with random parameters produced an instability which was caused by incorrect parsing of a sub attribute list without spaces, as in
sub:lvalue{"a"}This update fixes case b1190.
9 Aug 2021, 7008bcc.
This update corrects a rare loss of vertical alignment in welded containers.
To illustrate the issue, the normal formatting of the following snippet is
# perltidy -sil=1
( $msg, $defstyle ) = do {
$i == 1 ? ( "First", "Color" )
: $i == 2 ? ( "Then", "Rarity" )
: ( "Then", "Name" );
};If it appears within a welded container, the alignment of the last line was being lost:
# OLD: perltidy -wn -sil=1
{ {
( $msg, $defstyle ) = do {
$i == 1 ? ( "First", "Color" )
: $i == 2 ? ( "Then", "Rarity" )
: ( "Then", "Name" );
};
} }The corrected result is
# NEW: perltidy -wn -sil=1
{ {
( $msg, $defstyle ) = do {
$i == 1 ? ( "First", "Color" )
: $i == 2 ? ( "Then", "Rarity" )
: ( "Then", "Name" );
};
} }Several other minor vertical alignment issues are fixed with this updated. The problem was that two slightly different measures of the depth of indentation were being compared in the vertical aligner.
This fixes case c053.
8 Aug 2021, 97f02ee.
Testing with random parameters produced a case of unstable formatting involving welding with parameter -notrim-qw. The problem was that the -notrim-qw flag converts a qw quote into a quote with fixed leading whitespace. The lines of these types of quotes which have no other code are are output early in the formatting process, since they have a fixed format, so welding does not work. In particular, the closing tokens cannot be welded if they are on a separate line. This also holds for all types of non-qw quotes. So welding can only be done if the first and last lines of a non-qw quote contain other code. A check for this was added.
For example, in the following snippet the terminal '}' is alone on a line:
is eval(q{
$[ = 3;
BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; }
$t[3];
}
), "a";# In the previous version this was half-welded: # OLD: perltidy -wn -sil=0
is eval( q{
$[ = 3;
BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; }
$t[3];
}
),
"a";The new check avoids welding in this case, giving
# NEW: perltidy -wn -sil=0
is eval(
q{
$[ = 3;
BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; }
$t[3];
}
),
"a";Welding can still be done if the opening and closing container tokens have other code. For example, welding can be done for the following snippet:
is eval(q{
$[ = 3;
BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; }
$t[3];
}), "a";And welding can still be done on all qw quotes unless the -notrim-qw flag is set.
This fixes case b1189.
7 Aug 2021, e9c25f2.
Testing with random parameters produced some cases of instability involving -wn -lp and several other parameters. The mechanism involved an interaction between the formatter and vertical aligner.
This fixes cases b1187 and b1188.
3 Aug 2021, 5be949b.
Testing with random parameters produced a case of instability involving parameter -lp -pvt=n and a short maximum line length.
This fixes case b1186.
2 Aug 2021, f3dbee1.
Testing with random parameters produced a case of welding instability involving parameters -wn, -vt=2, -lp and a short maximum line length.
This fixes case b1185.
1 Aug 2021, d2ab2b7.
Testing with random parameters produced a case of welding instability involving parameters -wn, -vt=n, -lp. This update fixes the problem.
This fixes case b1183.
30 Jul 2021, 055650b.
Testing with random parameters produced a case of welding instability involving a tripple weld with parameters -wn, -vt=n, -lp. This update fixes the problem.
This fixes case b1184.
29 Jul 2021, 6dd53fb.
Testing with random parameters produced a case of welding instability involving unusual parameters and welding long ternary expressions. This update fixes the problem.
This fixes case b1182.
28 Jul 2021, 01d6c40.
Random testing with random input parameters produced cases of formatting instability involving welding with unusual parameter settings. This update makes a small tolarance adjustment to fix it.
This fixes cases b1180 b1181.
28 Jul 2021, b38ccfc.
This update fixes an extremely rare problem in formatting nested ternary statements, illustrated in the following snippet:
# OLD: There should be a break before the '?' in line 11 here:
WriteMakefile(
(
$PERL_CORE ? ()
: (
(
eval { ExtUtils::MakeMaker->VERSION(6.48) }
? ( MIN_PERL_VERSION => '5.006' )
: ()
),
(
eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (
META_MERGE => {
#
}
)
: ()
),
)
),
);
# NEW: Line 12 correctly begins with a '?'
WriteMakefile(
(
$PERL_CORE ? ()
: (
(
eval { ExtUtils::MakeMaker->VERSION(6.48) }
? ( MIN_PERL_VERSION => '5.006' )
: ()
),
(
eval { ExtUtils::MakeMaker->VERSION(6.46) }
? (
META_MERGE => {
#
}
)
: ()
),
)
),
);This fixes issue c050, 63784d8.
22 Jul 2021.
Automated testing with random parameters produced a case of instability caused by a conflict of parameters -bom and -scp. In the following script the -bom command says to keep the tokens ')->' on a new line, whereas the -scp command says to stack the closing paren on the previous line.
$resource = {
id => $package->new_from_mana(
$result->{data}
)->id
};The parameters are:
--break-at-old-method-breakpoints
--indent-columns=8
--maximum-line-length=60
--stack-closing-parenThis caused an instability which was fixed by giving priority to the -bom flag. The stable state is then
$resource = { id => $package->new_from_mana(
$result->{data}
)->id };This fixes case b1179.
21 Jul 2021, 4ecc078.
This update fixes two problems involving the -kgb option.
The first problem is that testing with random parameters produced some examples of formatting instabilities involving applying --keyword-group-blanks to complex structures, particularly welded structures. The -kgb parameters work well on simple statements or simple lists, so a check was added to prevent them from working on lists which are more than one level deep. This fixes issues b1177 and b1178 without significantly changing the -kgb functionality.
The second problem is that a terminal blank line could be misplaced if the last statement was a structure. This is illustrated with the following snippet:
sub new {
my $class = shift;
my $number = shift || croak "What?? No number??\n";
my $classToGenerate = shift || croak "Need a class to generate, man!\n";
my $hash = shift; #No carp here, some operators do not need specific stuff
my $self = { _number => $number,
_class => $classToGenerate,
_hash => $hash };
bless $self, $class; # And bless it
return $self;
}
# OLD: perltidy -kgb -sil=0 gave
sub new {
my $class = shift;
my $number = shift || croak "What?? No number??\n";
my $classToGenerate = shift || croak "Need a class to generate, man!\n";
my $hash = shift; #No carp here, some operators do not need specific stuff
my $self = {
_number => $number,
_class => $classToGenerate,
_hash => $hash
};
bless $self, $class; # And bless it
return $self;
}The blank line which has appeared after the line '_number =>' was intended to go after the closing brace but a line count was off. This has been fixed:
# NEW: perltidy -kgb -sil=0 gives
sub new {
my $class = shift;
my $number = shift || croak "What?? No number??\n";
my $classToGenerate = shift || croak "Need a class to generate, man!\n";
my $hash = shift; #No carp here, some operators do not need specific stuff
my $self = {
_number => $number,
_class => $classToGenerate,
_hash => $hash
};
bless $self, $class; # And bless it
return $self;
}This fixes issue c048.
19 Jul 2021, 071a3f6.
A problem in the current version of perltidy is that a blank line after the closing code-skipping comment can be lost if there was a blank line before the start of the code skipping section. For example, given the following code:
$x = 1;
#<<V
% # = ( foo => 'bar', baz => 'buz' );
print keys(%#), "\n";
#>>V
@# = ( foo, 'bar', baz, 'buz' );
print @#, "\n";running perltidy gives:
$x = 1;
#<<V
% # = ( foo => 'bar', baz => 'buz' );
print keys(%#), "\n";
#>>V
@# = ( foo, 'bar', baz, 'buz' );
print @#, "\n";Notice that the blank line after the closing comment #>>V is missing. What happened is that the formatter is counting blank lines and did not 'see' the code skipping section. So the blank after the closing comment looked like the second blank in a row, so it got removed since the default is --maximum-consecutive-blank-lines=1.
This update fixes this by resetting the counter. This fixes case c047. A simple workaround until the next release is to include the parameter
--maximum-consecutive-blank-lines=2, or -mbl=2.
It can be removed after the next release.
18 Jul 2021, 9648e16.
Random testing produced a case of formatting instability involving welding within a ternary expression following a fat comma:
if ( $op and $op eq 'do_search' ) {
@{$invoices} =
GetInvoices(
shipmentdatefrom =>
$shipmentdatefrom ? output_pref( {
str => $shipmentdatefrom,
dateformat => 'iso'
} )
: undef,
publicationyear => $publicationyear,
);
}when the following specific parameters were used
--extended-continuation-indentation
--line-up-parentheses
--maximum-line-length=38
--variable-maximum-line-length
--weld-nested-containersThis update fixes this issue, case b1174.
18 Jul 2021, 12ae46b.
Random testing produced the following case in which formatting was unstable because the variable '$t' was being mis-tokenized as a possible indirect object.
--break-before-all-operators
--ignore-old-breakpoints
--maximum-line-length=22
-sil=0
my $json_response
= decode_json $t
->tx->res->content
->get_body_chunk;This update fixes cases b1175, b1176.
17 Jul 2021, 4aa1318.
Testing with random parameters produced some cases where the combination of -wn and various -bbxx=n flags were not working together. To illustrate, consider the following script (-sil=1 just means start at 1 indentation level)
# perltidy -sil=1
$$d{"day_name"} = [
[
"lundi", "mardi", "mercredi", "jeudi",
"vendredi", "samedi", "dimanche"
]
];With welding we get:
# -sil=1 -wn
$$d{"day_name"} = [ [
"lundi", "mardi", "mercredi", "jeudi",
"vendredi", "samedi", "dimanche"
] ];With -bbsb=3 (--break-before-square-brackets) we get:
# -sil=1 -bbsb=3
$$d{"day_name"} =
[
[
"lundi", "mardi", "mercredi", "jeudi",
"vendredi", "samedi", "dimanche"
]
];So far, so good. But for the combination -bbsb=3 -wn we get
# OLD: ERROR
# -sil=1 -bbsb=3 -wn
$$d{"day_name"} = [ [
"lundi", "mardi", "mercredi", "jeudi",
"vendredi", "samedi", "dimanche"
] ];which is incorrect because it ignors the -bbsb flag. The corrected result is
# NEW: OK
# -sil=1 -bbsb=3 -wn
$$d{"day_name"} =
[ [
"lundi", "mardi", "mercredi", "jeudi",
"vendredi", "samedi", "dimanche"
] ];This update fixes case b1173. It works for any number of welded containers, and the -bbxxi=n flags also work correctly.
16 Jul 2021, c71f882.
Testing with randomly placed side comments produced an error illustrated with the following snippet:
testit
/A (*THEN) X | B (*THEN) C/x#sc#
,
"Simple (*THEN) test"
;If 'testit' is an unknown bareword then perltidy has to guess if the '/' is a division or can start a pattern. In this case the side comment caused a bad guess. This is case c044 and is fixed with this update. There are no other known issues with side comments at the present time but testing continues.
13 Jul 2021, 8b36de8.
This update fixes some incorrect tokenization produced by a side comment placed between a pointer and a bareword as in this snippet:
sub tzoffset {};
...
my $J
+=
(
$self
->#sc
tzoffset
/ (
24
*
3600
)
);If a sub declaration for the bareword has been seen, the following '/' was being rejected as an operator. This update fixes this case, which is issue c043.
13 Jul 2021, cab7ed3.
This is a modification to the previous update for case c039 which prevents a line break before a '/' character which follows a bareword or possible indirect object. This rule will be only be used to prevent creating new line breaks. Existing line breaks can remain.
11 Jul 2021, 7afee47.
Testing with side comments produced an error in the following snippet:
sub plugh () :#
Ugly('\(") : Bad;This is fixed in this update, case c038.
11 Jul 2021, 80f2a3a.
Random testing produced case b1172, a failure to converge with unusual parametrs. This update fixes this case. There are no other known cases of instability at the present time but testing continues.
10 Jul 2021, 47e7f9b.
This update prevents a line break before a '/' character which follows a bareword or possible indirect object. The purpose is reduce the chance of introducing a syntax error in cases where perl is using spaces to distinguish between a division and the start of a pattern.
This fixes case c039.
10 Jul 2021, 461199c.
In the previous version, a warning was produced if a 'code-skipping' opening comment '#<<V' was not followed by a closing comment '#>>V'. But the related 'format-skipping' commands do not give a warning if a '#<<<' comment is not ended with a '#>>>' closing comment. In order to be able to smoothly change between these options, it seems best to remove the warning about a missing '#>>V'. There is still a message in the log file about this, so if there is any uncertainty about it, a log file can be saved and consulted.
10 Jul 2021, 461199c.
Testing with side comments produced the following snippet which caused a error due to the side comment on the '/'
$bond_str
=
VERY_WEAK #sc#
/ #sc#
1.05
;Several related examples were found in which side comments triggered errors. For example
ok
/[^\s]+/#sc#
,
'm/[^\s]/ utf8'
;This update fixes these problems, case c040.
9 Jul 2021, ffe4351.
Testing with side comments produced an incorrect error message for this snippet:
xxx
++#
$test,
Internals::SvREADONLY( %$copy) ,
"cloned hash restricted?" ;The problem was caused by the side comment between the '++' and '$test'. The same problem occurs for '--' instead of '++'. This is fixed with this update, case c042.
8 Jul 2021, 20cc9a0.
This is related to the previous issue, c037. The following snippet was misparsed at the old style ' package separater due to the side comment following the pointer.
@ret
=
$o
->#
SUPER'method
(
'whatever'
)
;This is fixed in this update, case c041.
7 Jul 2021, 1806772.
The following test script
is(
$one
->#sc#
package
,
"bar"
,
"Got package"
)
;Caused the following error message:
4: package
^
found package where operator expectedThe problem was caused by a side comment between the pointer '->' and the word 'package'. This caused package to be misparsed as a keyword, causing the error.
This is fixed in this update, case c037, 96f2ebb.
Perltidy was correctly distinguishing between '$#' and '$ #' but not between '@#' and '@ #' and '%#' and '% #'. The coding for parsing these types of expressions has been corrected. Some simple examples:
# this is a valid program, '%#' is a punctuation variable
%# = ( foo => 'bar', baz => 'buz' );
print keys(%#), "\n";
# but this is a syntax error (space before # makes a side comment)
# (perltidy was ignoring the space and forming '%#' here)
% # = ( foo => 'bar', baz => 'buz' );
print keys(%#), "\n";
# this is a valid program, '@#' is a punctuation variable
@# = ( foo , 'bar', baz , 'buz' );
print @#, "\n";
# this is a valid program, the space makes the '#' a side comment
# perltidy formed %# here, causing an error
% #
var = ( foo => 'bar', baz => 'buz' );
print keys(%var), "\n";This fixes case c036.
6 Jul 2021, e233d41.
The following test script caused an error when perltidy did not correctly parse the tight side comment after the '&' (it parsed correctly if there was a space before the '#').
print$my_bag
&#sc#
$your_bag
,
"\n"
;This update fixes this issue, c033.
5 Jul 2021, 0d784e0.
The following test script caused an error when perltidy took 'format' to start a format statement.
my$ascii#sc#
=#sc#
$formatter#sc#
->#sc#
format#sc#
(#sc#
$html#sc#
)#sc#
;#sc#This was fixed by requiring a format statement to begin where a new statement can occur. This fixes issue c035.
5 Jan 2021, 2ef16fb.
Testing with large numbers of side comments caused perltidy to produce some incorrect error messages. Two issues are fixed with this update. First, a side comment between a pointer '->' and the next identifier caused a message. Second, in some cases a comment after an opening paren could cause a message. The following snippet is an example.
$Msg#sc#
->#sc#
$field#sc#
(#sc#
)#sc#
;#sc#This update fixes cases c029 and c030.
4 Jul 2021, caffc2c.
Testing produced a situation in which version 20200625 could cause an undefined variable to be accessed (the variable 'Ktoken_vars') as in this snippet:
#!/usr/bin/perl
#<<<
my $ra= (
[ 'Shine', 40 ], [ 'Specular', [ 1, 1, 0.3, 0 ] ] );
#<<<
...The conditions for this to happen are:
(1) format skipping (#<<<) begins before the first line of code, and
(2) the format skipping section contains the two successive characters ', ['.The undefined variable was 'Ktoken_vars'. This problem was introduced by commit 21ef53b, an update which fixed case b1100. This undefined variable access does influence the formatted output.
This update fixes this problem.
4 Jul 2021, 82916fe.
Testing with randomly placed side comments caused perltidy to produce an incorrect warning when a side comment is placed before the end of a package statement:
package double # side comment
;This update fixes this. 3 Jul 2021, c00059a.
Testing revealed a formatting irregularity which was caused when the flag -cab=2 got applied to a container which was not a list. This is fixed with update, which fixes case b939a.
1 Jul 2021, 021b938.
Testing showed that a previously fixed case of instability, b1144, which was fixed 21 Jun 2021, 1b682fd, was unstable again. This update is a small change which fixes this. There are no other known unstable cases at this time but automated testing runs continue to search for instabilities.
1 Jul 2021, 021b938.
The previous Tokenizer update caused the use of an unitialized value when run on case b1053:
Use of uninitialized value $next_nonblank_token in pattern match (m//) at /home/steve/bin/Perl/Tidy/Tokenizer.pm line 7589.
Use of uninitialized value $nn_nonblank_token in pattern match (m//) at /home/steve/bin/Perl/Tidy/Tokenizer.pm line 3723.
b1053 converged on iteration 2This update fixes this.
1 Jul 2021, ea139bd.
In the following example
print "not " unless ref +(
map {
sub : lvalue { "a" }
} 1
)[0] eq "CODE";the colon after 'sub' was being marked as part of a label rather than the start of an attribute list. This does not cause an error, but the space before the ':' is lost. This is fixed in this update.
Note that something like 'sub :' can also be a label, so the tokenizer has to look ahead to decide what to do. For example, this 'sub :' is a label:
my $xx = 0;
sub : {
$xx++;
print "looping with label sub:, a=$xx\n";
if ( $xx < 10 ) { goto "sub" }
}In this case, the goto statement needs quotes around "sub" because it is a keyword.
29 Jun 2021, d5fb3d5.
Testing with random input parameters produced several new cases of formatting instability involving unusual parameter combinations. This update fixes these cases, b1169 b1170 b1171, and all previously discovered cases remain stable with the update.
28 Jun 2021, e1f22e0.
This update undoes the update c16c5ee of 20 Feb 2021, in which the value of -ci=n was limited to the value of -i=n when -xci was set. Recent improvements in stability tolerances allow this limit to be removed.
28 Jun 2021, 1b3c5e9.
Added a quick check to bypass a needless sub call.
26 Jan 2021, e7822df.
It was possible to eliminate this token variable by changing the order of welding operations. This reduces the number of variables per token from 12 to 11.
26 Jun 2021, 1f4f78c.
Testing with NYT_Prof shows that the number of variables per token has a direct effect on efficiency. This update reduces the number of token variables from 13 to 12, and also simplifies the coding. It was possible to compute this variable from the others, so it was redundant.
26 Jun 2021, 300ca1e.
24 Jun 2021, a4ff53d.
Testing with random input parameters produced a number of edge cases of unstable formatting which were traced to the parameter combinations which included -lp and some other unusual settings.
This fixes cases b1103 b1134 b1135 b1136 b1138 b1140 b1143 b1144 b1145 b1146 b1147 b1148 b1151 b1152 b1153 b1154 b1156 b1157 b1163 b1164 b1165
There are no other known cases of formatting instability at the present time, but testing with random input parameters will continue.
21 Jun 2021, 1b682fd.
Testing with random input parameters produced a number of edge cases of unstable formatting which were traced to the parameter combinations which included -bbxi=2 and -cab=2. A small adjustment to length tolerances was made to fix the problem.
This fixes cases b1137 b1149 b1150 b1155 b1158 b1159 b1160 b1161 b1166 b1167 b1168.
19 Jun 2021, 4d4970a.
This flag, which is enabled by default, allows perltidy to terminate the last line of the output stream with a newline character, regardless of whether or not the input stream was terminated with a newline character. If this flag is negated, with -natnl, then perltidy will add a terminal newline to the the output stream only if the input stream is terminated with a newline.
Negating this flag may be useful for manipulating one-line scripts intended for use on a command line.
This update also removes the description of the obsolete --check-syntax flag from the man pages and help text.
18 Jun 2021, 6f83170.
The -nanl flag (--noadd-newlines) was preventing side comments from being deleted, for example:
# perltidy -dsc -nanl
calc() # side commentThe same issue was happening for --delete-closing-side comments. This has been fixed.
18 Jun 2021, dbfd802.
Testing with random input parameters produced a formatting instability involving an unusual parameter combination:
--noadd-whitespace
--break-before-paren=3
--continuation-indentation=8
--delete-old-whitespace
--line-up-parentheses
--weld-nested-containersand the following code
if(defined$hints{family}){
@infos=({
family=>$hints{family},
socktype=>$hints{socktype},
protocol=>$hints{protocol},
});
}This update fixes the problem, case b1162.
18 Jun 2021, 76873ea.
This is a minor optimization. These subs are eliminated: is_welded_right_at_K, is_welded_left_at_K, weld_len_right_at_K.
17 Jun 2021, 1691013.
This update is necessary to eventually prevent an unwanted terminal newline being added to a file.
17 Jun 2021, 2600533.
This fixes an incorrect call which could cause an incorrect weld.
16 Jun 2021, 068a28b.
Added a new option '--code-skipping', requested in git #65, in which code between comment lines '#<<V' and '#>>V' is passed verbatim to the output stream without error checking. It is simmilar to --format skipping but there is no error checking, and is useful for skipping an extended syntax.
16 Jun 2021, 99ec876.
Perltidy was producing an error at nested print format blocks, such as
format NEST =
@<<<
{
my $birds = "birds";
local *NEST = *BIRDS{FORMAT};
write NEST;
format BIRDS =
@<<<<<
$birds;
.
"nest"
}
.It was ending the first format at the first '.' rather than the second '.' in this example. This update fixes this, issue c019.
13 Jun 2021.
When labels are stacked in a single line, such as
A:B:C:
the default is to space them:
A: B: C:
This update allows the spaces to be removed if desired:
# perltidy -naws -dws A:B:C:
13 Jun 2021, c2a63b2
Random testing produced some cases of instability involving -wn -lp and some unusual additional parameters. These were traced to a test for welding, and were fixed by refining a certain tolerance. This fixes cases b1141, b1142.
12 Jun 2021, 125494b.
This update removes an incorrect error messagge at the construct ')('. To illustrate, the following is a valid program:
my @words = qw(To view this email as a web page go here);
my @subs;
push @subs, sub { my $i=shift; $i %= @words; print "$words[$i] "; return $subs[0]};
$subs[0](0)(1)(2)(3)(4)(5)(6)(7)(8)(9)(10)(11);
print "\n";However perltidy was giving an error message at the ')(' combination, which is unusual in perl scripts. This update fixes this.
These are function call parens, so logically they should be under control of the -sfp or --space-function-parens parameter. I wrote a patch to do this, but decided not to implement it. The reason is that, as noted in the manual, subtle errors in perl scripts can occur when spaces are placed before parens. So, to avoid possible problems, the -sfp parameter will be restricted to spaces between a bareword [assumed to be a function] and a paren.
This update is in Tokenizer.pm and fixes case c017.
6 Jun 2021, 6551d65.
This update adds a warning when lexical subs have names which match some builtin names which will almost certainly cause a parsing error in the current version of perltidy. For example, the following program is valid and will run, but perltidy will produce an error.
use feature qw(lexical_subs);
use warnings; no warnings "experimental::lexical_subs";
{
my sub y { print "Hello from y: $_[0]\n"; }
y(1);
}6 Jun 2021, 32729fb.
This update fixes a case of formatting instability recently found with random testing. It also does some minor coding cleanups.
This fixes case b1139.
5 Jun 2021, b8527ab.
This update replaces the data structures used for the welding option with simpler but more general structures. This cleans up the code and will simplify future coding. No formatting changes should occur with this update.
4 Jun 2021, 4a886c8.
This update improves the treatment of lexical subs. Previously they were formatted correctly but an error would have been produced if the same name was used for lexical subs defined in different blocks.
For example, running the previous version of perltidy on the following:
use feature qw(lexical_subs);
use warnings; no warnings "experimental::lexical_subs";
{
my sub hello { print "Hello from hello1\n" }
{
my sub hello { print "Hello from hello2\n" }
hello();
}
hello();
}
{
my sub hello { print "Hello from hello3\n" }
hello();
}gave the (incorrect) error message:
6: already saw definition of 'sub hello' in package 'main' at line 4
12: already saw definition of 'sub hello' in package 'main' at line 6This update fixes that.
1 Jun 2021, 85ecb7a.
This update cleans up a couple of open issues in the tokenizer.
A warning message will be produced for a list which begins with a comma:
my %string = (
, "saddr", $stest, "daddr",
$dtest, "source", $sname, "dest")This warning had been temporarily deactivated.
Underscores in v-strings without a leading 'v' are now parsed correctly.
Several comments have been updated.
31 May 2021, ef44e70.
The following lines are syntactically correct but some were producing a syntax error
print "hello1\n", || print "hi1\n";
print "hello2\n", && print "bye2\n";
print "hello3\n", or print "bye3\n";
print "hello4\n", and print "bye4\n";For example, the first line produced this message
1: print "hello1\n", || print "hi1\n";
- ^
found || where term expected (previous token underlined)This has been fixed. This fixes case c015.
27 May 2021, b537a72.
An optional letter 'o' or 'O' in the octal representation of numbers, which was added in perl version 5.33.5, is now recogized. The leading zero is still required.
For example:
$a = 0o100;
$a = 0O100;26 May 2021, 544df8c.
This update fixes several problems with -lp formatting which are all somewhat related.
ISSUE #1 (cases c002 and c004): A problem involving -lp -wn and certain qw lists
The last line of a welded qw list was being outdented even if it contained text as well as the closing container token. This update fixes the problem and simplifies the logic.
A few examples (all use 'perltidy -wn -lp'):
# OLD and NEW: OK, closing qw paren is on separate line
$roads->add_capacity_path( qw( CoolCity 10 ChocolateGulch 8
PecanPeak 10 BlueberryWoods 6
HotCity
) );
# OLD: poor; outdented text not aligned with previous text
$roads->add_capacity_path( qw( CoolCity 10 ChocolateGulch 8
PecanPeak 10 BlueberryWoods 6
HotCity ) );
# NEW:
$roads->add_capacity_path( qw( CoolCity 10 ChocolateGulch 8
PecanPeak 10 BlueberryWoods 6
HotCity ) );
# OLD:
$roads->add_capacity_path( qw( ChocolateGulch 3 StrawberryFields 0
StrawberryFields ) );
# NEW:
$roads->add_capacity_path( qw( ChocolateGulch 3 StrawberryFields 0
StrawberryFields ) );
# OLD:
my $mon_name = ( qw(January February March April
May June July August
September October November December) )[$mon];
# NEW
my $mon_name = ( qw(January February March April
May June July August
September October November December) )[$mon];ISSUE #2 (case c007): A rare program error could be triggered with -lp -xci
In some very rare circumstances it was possible to trigger a "Program error" message. The program still ran to completion. The conditions for this to occur were that flags -lp -xci were set, and that there was a container of sort/map/grep blocks, and there was a side comment on the closing paren. For example:
# OLD: perltidy -lp -xci, gave an error message and extra indentation here
my %specified_opts = (
(
map { /^no-?(.*)$/i ? ($1 => 0) : ($_ => 1) }
map { /^--([\-_\w]+)$/ } @ARGV
), # this comment caused an error with flags -lp -xci
);
# NEW: perltidy -lp -xci, no error
my %specified_opts = (
(
map { /^no-?(.*)$/i ? ( $1 => 0 ) : ( $_ => 1 ) }
map { /^--([\-_\w]+)$/ } @ARGV
), # this comment caused an error with flags -lp -xci
);ISSUE #3 (case c008): In some unusual cases the -lp formatting style was not being applied when it should have been. For example (text is shifted right):
# NEW: perltidy -lp
$result = runperl(
switches => [ '-I.', "-w" ],
stderr => 1,
prog => <<'PROG' );
SIG
PROG
# NEW: perltidy -lp
$result = runperl(
switches => [ '-I.', "-w" ],
stderr => 1,
prog => <<'PROG' );
SIG
PROG25 May 2021, 6947fe9.
This is an update to the patch 19 Apr 2021, eeeaf09. It restricts that patch to -lp formatting mode.
This fixes case b1131.
21 May 2021, a4ec4c1.
Random testing produced a formatting instability involving the combination of flags -bbp=2 -xci -vt=2 -bvtc=2. The problem was traced to an error in counting the number of line ending commas in lists.
This fixes case b1130.
15 May 2021, 90cceb1.
Random testing produced an edge case of formatting instability for -lp indentation which was traced to checking for an old line break at a '=>'. This has been fixed. Some existing formatting with deeply nested structures may be slightly changed due to the fix, but most existing formatting will be unchanged.
This fixes b1035.
15 May 2021, dd42648.
Random testing produced some examples of formatting instability involving the -bom flag in combination with certain other flags which are fixed with this update. As part of this update, a previous update to fix case b977 (21 Feb 2021, commit 28114e9) was revised to use a better criterion for deciding when not to keep a ')->' break. The previous criterion was that the opening and closing containers should be separated by more than one line. The new criterion is that they should contain a list. This still fixes case b977. Another case, b1120, was fixed by requiring that only parentheses expressions be considered for keeping a line break, not '}->' or ']->'.
Some issues are illustrated in the following examples using '-bom -gnu'. In the first example the leading ')->' was being lost due to the old b977 fix:
# input:
$show = $top->Entry( '-width' => 20,
)->pack('-side' => 'left');
# OLD: perltidy -gnu -bom
$show = $top->Entry('-width' => 20,)->pack('-side' => 'left');
# NEW: perltidy -gnu -bom
$show = $top->Entry(
'-width' => 20,
)->pack('-side' => 'left');In the following example a leading '->' was being lost. The NEW version keeps the leading '->' but has to give up on the -lp alignment because of complexity:
# input
$_make_phase_arg = join(" ",
map {CPAN::HandleConfig
->safe_quote($_)} @{$prefs->{$phase}{args}},
);
# OLD: perltidy -gnu -bom
$_make_phase_arg = join(" ",
map { CPAN::HandleConfig->safe_quote($_) }
@{$prefs->{$phase}{args}},
);
# NEW: perltidy -gnu -bom
$_make_phase_arg = join(
" ",
map {
CPAN::HandleConfig
->safe_quote($_)
} @{$prefs->{$phase}{args}},
);In the following example, a leading ')->' was being converted to a leading '->' due to the old b977 fix:
# Starting script
$lb = $t->Scrolled("Listbox", -scrollbars => "osoe"
)->pack(-fill => "both", -expand => 1);
# OLD: perltidy -bom -gnu
$lb = $t->Scrolled( "Listbox", -scrollbars => "osoe" )
->pack( -fill => "both", -expand => 1 );
# NEW: perltidy -bom -gnu
$lb = $t->Scrolled(
"Listbox", -scrollbars => "osoe"
)->pack(-fill => "both", -expand => 1);In the following example, a leading ')->' was being lost, again due to the old b977 fix:
$myDiag->Label(-text => $text,
)->pack(-fill => 'x',
-padx => 3,
-pady => 3);
# OLD: -gnu -bom
$myDiag->Label(-text => $text,)->pack(
-fill => 'x',
-padx => 3,
-pady => 3
);
# NEW -gnu -bom
$myDiag->Label(
-text => $text,
)->pack(
-fill => 'x',
-padx => 3,
-pady => 3
);This update fixes case b1120 and revises the fix for b977.
13 May 2021, d0ac5e9.
Random testing produced some edge cases of unstable formatting involving the -lp format. These were fixed by using a slightly larger tolerance in the length test for containers which were broken in the input file.
This fixes cases b1059 b1063 b1117.
13 May 2021, 24a11d3.
If a container contains text of a here-doc then the indentation is fixed by the here-doc text, so applying -lp formatting does not work well. So this update turns off the -lp formatting in this case.
But note that if a container contains a here target but not the here text so it still gets the -lp indentation:
# perltidy -lp
&WH::Spell::AddSpell(
"Cause Light Wounds", "WFP",
"CauseLightWounds", <<'EOH');
...
EOHThis fixes case b1081.
10 May 2021, 4f7a56b.
Some adjustments in welding coding was made to maintain stability for some unusual parameter combinations.
This fixes cases b1111 b1112.
9 May 2021, 68f619a.
The tolerance for welding qw quotes has been update to be the same as used for welding other tokens. This fixes case b1129.
9 May 2021, d1de85f.
The welding process uses a tolerance to keep results stable. Basically, a zero tolerance is used if it looks like it is welding an existing weld, while a finite tolerance is used otherwise. The effect is to reject a few marginal welds to gain stability. The coding to do this was simplified and the tolerance was made more precise to fix case b1124.
Another change with this update is that at welded containers, the value of the -ci flag of an outer opening token is transferred to the inner opening token. This may improve some indentation in a few cases if the -lp flag is also used. It has no effect if -lp is not used.
# OLD: perltidy -wn -gnu
emit_symbols([qw(
ctermid
get_sysinfo
Perl_OS2_init
...
CroakWinError
)]);
# NEW: perltidy -wn -gnu
emit_symbols([qw(
ctermid
get_sysinfo
Perl_OS2_init
...
CroakWinError
)]);9 May 2021, ad8870b.
This is a generalization of commit 7d3bf4 in which the tokenizer sends a signal to the formatter if the type of a brace following an unknown bareword had to be guessed. The formatter has more information and can fix the problem. This fixes case b1128.
8 May 2021, b3eaf23.
In commit c16c5ee an update was made to prevent instability with -xci when the value of -ci exceeds -i (which is not recommended). This update adds a warning message to avoid confusing the user.
7 May 2021, e9e14e4.
Formatting of multiline qw lists with welding works best if the opening and closing qw tokens are on separate lines, like this:
# perltidy -wn
my $mon_name = ( qw(
January February March April
May June July August
September October November December
) )[$mon];
# perltidy -wn -lp
my $mon_name = ( qw(
January February March April
May June July August
September October November December
) )[$mon];Otherwise formatting can be poor, particularly if the last line has text and a closing container.
# OLD: perltidy -wn
my $mon_name = ( qw(January February March April
May June July August
September October November December) )[$mon];Note that perltidy does not change the line breaks within multiline quotes, so they must be changed by hand if desired.
This update indents the last line of a multiline quote which contains both text and the closing token, such as:
# NEW: perltidy -wn
my $mon_name = ( qw(January February March April
May June July August
September October November December) )[$mon];This update is only when the -lp flag is not used. If -lp is used and the last line contains text, the last line is still outdented:
$ OLD and NEW: perltidy -wn -lp
my $mon_name = ( qw(January February March April
May June July August
September October November December) )[$mon];This is difficult to fix. The best solution is to place the closing qw qw containers on a separate line.
This fix is for case c002.
6 May 2021, 176f8a7.
Random testing produced an unstable state which was due to not checking for excessive length of the last line of a multiline qw quote. A check was added, this fixes issue b1039.
5 May 2021, b72ad24.
Random testing with unusual parameter combinations produced some unstable welds. For example case b1106 has these parameters
--noadd-whitespace
--continuation-indentation=6
--delete-old-whitespace
--line-up-parentheses
--maximum-line-length=36
--variable-maximum-line-length
--weld-nested-containersand was switching between these two states:
return map{
($_,[$self->$_(@_[1..$#_])])
}@every;
return map { (
$_, [ $self->$_( @_[ 1 .. $#_ ] ) ]
) } @every;An existing rule, WELD RULE 2, was updated to prevent welding to an intact one-line weld, as in the first snippet, if it is on a separate line from the first opening token. With this change, both of these states are stable.
This update fixes cases b1082 b1102 b1106 b1115.
4 May 2021, 07efa9d.
Several random test cases produced an instability involving -otr and -lp. In -lp mode, when an opening paren follows an equals and is far to the right, a break is made at the equals to minimize the indentation of the next lines. The -otr flag is a suggestion that an opening paren should be place on the right. A check has been made to avoid this in -lp mode following an equals, since that defeats the purpose of the original break.
This fixes cases b964 b1040 b1062 b1083 b1089.
4 May 2021, 24a0d32.
A new integer option, n=3, has been added to the vertical tightness closing flags. For a container with n=3, the closing token will behave as for n=0 if the opening token is preceded by an '=' or '=>', and like n=1 otherwise.
3 May 2021, 93063a7.
This update fixes a problem with unwanted vertical alignment rasied in rt#136416. The example is
use File::Spec::Functions 'catfile', 'catdir';
use Mojo::Base 'Mojolicious', '-signatures';An update was made to reject alignments in use statements with different module names. The test file t/snippets/align35.in has more examples.
3 May 2021, 048126c.
Random testing produced some rare cases of unstable formatting involving the -lp option which are fixed with this update. This is a generalization of commit edc7878 of 23 Jan 2021. This fixes cases b1109 b1110.
2 May 2021, a8d1c8b.
This is a generalization of commit 7d23bf4 to fix some additional cases found in random testing in which the type of a curly brace could not be determined in the tokenizer and was not being corrected by the formatter.
This fixes cases b1125 b1126 b1127.
2 May 2021, dac97cb.
Random testing produced several cases in which the flags -bbx=2 -lp and -xci were causing formatting instability. The fix is to locally turn off -xci when -lp and -bbx=2 are in effect. This is an extension of commit 2b05051.
This fixes cases b1090 b1095 b1101 b1116 b1118 b1121 b1122 b1099
1 May 2021, 4cb81ba.
Logic was added to turn off -cab=3 in complex structures. Otherwise, instability can occur. When it is overridden the behavior of the closest match, -cab=2, is used instead.
For example, using these parameters for case b1113
--noadd-whitespace
--break-before-hash-brace-and-indent=2
--break-before-hash-brace=1
--comma-arrow-breakpoints=3
--continuation-indentation=9
--maximum-line-length=76
--variable-maximum-line-lengthformatting of the following snippet was unstable:
$STYLESHEET{'html-light'}={
'tags'=>{
'predefined identifier'=>
{
'start'=>'<font color="#2040a0"><strong>',
'stop'=>'</strong></font>'
},
}
};This update fixes cases b1096 b1113.
29 Apr 2021, 32a1830.
The wording regarding when -lp reverts to the default indentation scheme has been revised to include side comment as follows:
In situations where perltidy does not have complete freedom to choose line breaks it may temporarily revert to its default indentation method. This can occur for example if there are blank lines, block comments, multi-line quotes, or side comments between the opening and closing parens, braces, or brackets.
The word 'may' is significant for side comments. In a list which is just one level deep side comments will work (perhaps with -iscl if side comments are long). For example this is ok
# perltidy -lp
$gif->arc(
50, 50, # Center x, y.
30, 30, # Width, Height.
0, 360, # Start Angle, End Angle.
$red
);But if a list is more than one level deep then the default indentation is used.
28 Apr 2021, 49977b8.
This is an adjustment of update 344519e which had to do with breaking lines with commas which were not inside of a container. In a few cases it was producing very long lines when -l=0 was set. The solution was to remove the concatenation operator from the list of operators at which breaks were prevented.
Other updates are: Remove unused indentation table. Correct maximum_line_length table for -vmll when -wc is also set. Also fix whitespace rule for '$ =' within a signature to fix case b1123.
26 Apr 2021, d014c2a.
Random testing produced some cases in which the -wn flag was unstable when -wc=n was used with very small n. This has been fixed.
This fixes cases: b1098 b1107 25 Apr 2021, 92babdf.
Random testing produced case c1119 which was unstable due to the formatting rules for breaking lines at commas which occur outside of containers. The rules were modified to fix the problem.
20 Apr 2021, 344519e.
Random testing produced case c001 in which the following snipppet
ok $mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 &&
$ss/(@mtime+@atime) >= 0.2;when processed with these parameters
--maximum-line-length=20
--nowant-right-space=' / '
--want-break-before='* /'produced the following result
ok $mi
/( @mtime - 1 ) >=
0.75
&& $ai
/( @atime - 1 )
>= 0.75
&& $ss
/( @mtime +
@atime ) >=
0.2;using 'perl -cw' on this snippet gives a syntax error
syntax error at /tmp/issues.t line 5, near "/( "
(Might be a runaway multi-line // string starting on line 2)The error is due to perl's weird parsing rules near a possible indrect object. This is a situation where perltidy must ignore a user spacing and line break request. This should have been done but in this case a flag to prevent this was not being propagated to later stages of formatting. This has been fixed.
20 Apr 2021, 4fbc69a.
Random testing produced case b1114 which gave unstable formatting with these parameters
--noadd-whitespace
--indent-columns=8
--line-up-parentheses
--maximum-line-length=25
--weld-nested-containersand this snippet
is(length(pack("j", 0)),
$Config{ivsize});Fixed 19 Apr 2021, eeeaf09.
The following lines produced an error message due to the side comment
my $fragment = $parser-> #parse_html_string
parse_balanced_chunk($I);Fixed 18 Apr 2021, c2030cf.
Random testing produced several cases of unstable welds in which the inner container something like 'sort ('. The problem was that there are special rules which prevent a break following such a paren. The problem was fixed by preventing welds at these locations.
This update fixes cases b1077 b1092 b1093 b1094 b1104 b1105 b1108.
17 Apr 2021, d679b48.
This fixes issue git #62. A similar issue for the % operator was fixed. 17 Apr 2021, f80d677.
Random testing produced case b1100 in which the output style produced by the --opening-token-right flags interfered with counting line-ending commas, and this in turn caused the -bbx flag to turn off the -xci flag. This problem was fixed.
15 Apr 2021, 21ef53b.
Random testing produced case b1097 with this parameter set
--brace-vertical-tightness-closing=1
--continuation-indentation=8
--indent-columns=10
--maximum-line-length=36and either this output
my (@files) = @{
$args{-files} };or this output
my (@files) =
@{ $args{-files}
};The different results were caused by the unusual combination of parameters. The problem was fixed by not allowing the formatter to consider existing breaks at highly stressed locations such as these.
15 Apr 2021, 9f15b9d.
Random testing produced case b994 with unstable formatting:
do
sub :
lvalue
{
return;
}when run with parameters:
--continuation-indentation=0
--ignore-old-breakpoints
--maximum-line-length=7
--opening-anonymous-sub-brace-on-new-lineThe line 'sub :' was being correctly parsed but the following opening block brace was not correctly marked as an anonymous sub brace. This fixes cases b994 and b1053.
15 Apr 2021, 84c1123.
Testing with random parameters produced a case in which a brace following an unknown bareword was marked by the tokenizer as a code block brace rather than a hash brace. This can cause poor formatting. The problem was solved by having the tokenizer send a signal to the formatter if a block type was guessed. The formatter has more information and can fix the problem. This fixes case b1085.
11 Apr 2021, 7d23bf4.
Random testing produced some cases where welded quotes were not converging. These were found to be due to the same problem previouly encountered and fixed for normal containers. The problem was fixed by moving the corrected coding to a new common sub.
This update fixes cases b1066 b1067 b1071 b1079 b1080.
10 Apr 2021, 5d73dd5.
Random testing produced some cases of instability with some unusual input parameter combinations involving the -wn parameter. This was fixed by revising a line length calculation. This fixes cases b604 and b605.
9 Apr 2021, a25cfaa.
Random testing showed a weakness in the treatment of the -vmll flag in combination with the -wn flag. This has been fixed.
This fixes cases b866 b1074 b1075 b1084 b1086 b1087 b1088
8 Apr 2021, a6effa3.
One of the welding rules, RULE 6, has been merged into RULE 3 for generality. This rule restricts welding to an opening container followed by a bare word, which can cause instability in some cases. The updated code is less restrictive and fixes some cases recently found with random testing, b1078 b1091.
8 Apr 2021, f28ab55.
The previous update regarding blank line generation was not sufficiently general to handle all possible parameter combinations. The problem was solved and simplified by moving the logic to a lower level, in the FileWriter module.
6 Apr 2021, 756e930.
Random testing produced some cases where excess blank lines could be generated with the parameter -blank-lines-after-opening-block. Case b1073 has the following script
sub stop {
1;
}and the following parameters
--blank-lines-after-opening-block=2
--maximum-consecutive-blank-lines=10
--maximum-line-length=15When run, blank lines keep getting generated until the maximum is reached. This has been fixed.
6 Apr 2021, 9216298.
A change was made to a welding rule involving the -lp option or -wbb='=', and very short maximum line lengths. This correctly fixes case b1041. It replaces a fix for this case reported on 2 Apr 2021.
5 Apr 2021.
Random testing produced some edge cases in which formatting with the -bbx=2 flags, in combination with certain other parameters, was not converging. An existing criterion for the -bbx=2 flag to apply is that there be a broken sub-list with at least one line-ending comma. This was updated to also require either a fat comma or one additional line-ending comma. This filters out some problem cases without changing much existing formatting.
This update fixes cases b1068 b1069 b1070 b1072 b1073 b1076.
5 Apr 2021, 16c4591.
The previous update produced some problems in testing which are corrected with this update.
5 Apr 2021, ffef089.
Random testing produced some cases in which unusual parameter combinations caused lack of convergence for the -wn flag. The problem was fixed by adjusting a tolerance in the line length calculation.
This fixes cases b1041 b1055.
2 Apr 2021, a8b6259.
Random testing produced a case with the combination -bli and -xci which did not converge. This was fixed by turning off -xci for braces under -bli control.
This fixes case b1065.
2 Apr 2021, d20ea80.
Random testing produced a number of cases of unstable formatting when both -xci and -bbp=2 or similar flags were set. The problem was that -xci can cause one-line blocks to break open, causing the -bbp=2 flag to continually switch formatting. The problem is fixed by locally turning off -xci at containers which do not themselves contain broken containers.
This fixes cases b1033 b1036 b1037 b1038 b1042 b1043 b1044 b1045 b1046 b1047 b1051 b1052 b1061.
30 Mar 2021, 2b05051.
Random testing produced a case which was not converging due to a rule which avoids welding when a bareword follows. The rule was modified to allow an exception for an existing one-line weld. A non-fatal typo was also discovered and fixed.
This fixes cases b1057 b1064.
29 Mar 2021, d677082.
Random testing produced a problem with convergence due to a conflict between two parameters for the following code
my $lxy =
( @$cx - @$cy ) ||
(
length ( int ( $cx->[-1] ) ) -
length ( int ( $cy->[-1] ) ) );when using these parameters
--break-after-all-operators
--maximum-line-length=61
--opening-paren-rightBoth the '||' and the '(' want to be at the end of a line according to the parameters. The problem is resolved by giving priority to the '||'. This fixes case b1060.
29 Mar 2021, 6921a7d.
Random testing produced some cases in which user requests to break before selected operators were not being followed. For example
# OLD: perltidy -wbb='.='
$value .=
( grep /\s/, ( $value, $next ) )
? " $next"
: $next;
# FIXED: perltidy -wbb='.='
$value
.= ( grep /\s/, ( $value, $next ) )
? " $next"
: $next;This fixes case b1054.
28 Mar 2021, 94f0877.
This is an correction to the update of 13 Mar 2021, 71adc77. Random testing produced several additional problems with convergence involving the combination -iob -lp. This update fixes the problem by overriding -iob at some breakpoins which are essential to the -lp parameter.
This update fixes these old cases: b1021 b1023
and these new cases: b1034 b1048 b1049 b1050 b1056 b1058
27 Mar 2021, cc94623.
The flag -lpxl=s provides control over which containers get -lp formatting. A shortcut flag -lfp is also added for limiting -lp to simple function calls.
Updated 25 Mar 2021, bfc00fp.
There was an error in the coding for an error message which checks for conflicting requests in the -wnxl parameter.
Fixed 21 Mar 2021, 2ef97a2.
This update fixes issue git #57, in which a warning flag was not getting zeroed on each new call to perltidy.
19 Mar 2021, b6d296a.
This update fixes case b1032 by includeing lines starting with 'if', 'or', and || among the stable breakpoints for welding when -lp -naws flags are also set.
This update also modifies update 7a6be43 of 16 Mar 2021 to exclude list items when checking token lengths. This reduces changes to existing formatting while still fixing the problem in case b1031.
18 Mar 2021, 6200034.
Testing produced a blinking state involving a -bbx=2 flag with an unusual combination of other parameters. The problem was traced to the definition of a list containing another list being too restrictive. This update fixes case 1024.
17 Mar 2021, 7f5da0a.
Testing produced an unstable situation involving the -xci flag and tokens which exceed the maximum line length. This fix identifies this situation and locally deactivates the -xci flag. This fixes case b1031.
16 Mar 2021, 7a6be43.
Testing with random parameters produced some cases where the -xci option was not producing stable results when the maximum line length was set to a very small value. The problem was traced to the tokenizer misparsing a hash brace of a use statement as a code block type. This influences the value of continuation indentation within the braces. The problem was fixed.
This fixes cases b1022 b1025 b1026 b1027 b1028 b1029 b1030
16 Mar 2021, 6371be2.
Testing with random parameters produced some situation where the parameter -iob interfered with convergence when parameters -lp and/or -wn were also set. The combination -wn -lp -dws -naws also produced some non-converging states in testing. This update fixes these issues.
The following cases are fixed: b1019 b1020 b1021 b1023
13 Mar 2021, 71adc77.
This update consolidates a number of specialized rules for welding into fewer, simpler rules which accomplish the same effect.
These cases are fixed with this update: b186 b520 b872 b937 b996 b997 b1002 b1003 b1004 b1005 b1006 b1013 b1014
There are no current open issues with the weld logic.
10 Mar 2021, cf3ed23.
A minor tolerance adjustment was needed to fix some edge welding cases.
This fixes cases b995 b998 b1000 b1001 b1007 b1008 b1009 b1010 b1011 b1012 b1016 b1017 b1018
7 Mar 2021, b9166ca.
Random testing produced an issue with -vtc=1 and an outdented long line. The parameters for b999 are
--maximum-line-length=75
--paren-vertical-tightness-closing=1File 'b999.in' state 1 is
while ( $line =~
s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
)and state 2 is
while ( $line =~
s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e)The problem was fixed by turning off caching for outdented long lines. This fixes case b999.
7 Mar 2021, 3da7e41.
Random testing produced case b932 in which the combination -lp and -wbb='=' was not stable.
File 'b932.par' is:
--line-up-parentheses
--maximum-line-length=51
--want-break-before='='File 'b932.in' in the desired state is:
my @parts
= decompose( '(\s+|/|\!|=)',
$line, undef, 1, undef, '["\']' );The alternate state is
my @parts = decompose( '(\s+|/|\!|=)',
$line, undef, 1, undef, '["\']' );The problem was that the -lp code which set a line break at the equals did not check the -wba flag setting.
This update fixes case b932.
7 Mar 2021, 63129c3.
Random testing produced some cases where formatting with parameters of the form --break-before-..=2 can lead to unstable final states. The problem lies in the definition of a broken list. The problem is fixed by defining a broken list for this particular flag to be a list with at least one non-terminal line-ending comma. This insures that the list will remain broken on subsequent iterations. This fixes cases b789 and b938.
6 Mar 2021, 360d669.
A flag -fpva, --function-paren-vertical-alignment, is added to prevent vertical alignment of function parens when the -sfp flag is used. This is on by default, so that existing formatting remains unchanged unless the user requests that vertical alignment not occur with -nfpva.
5 Mar 2021, 312be4c.
Introducing a space before a function call paren had a side effect of allowing the vertical aligner to align the parens, as in the example.
# OLD and NEW, default without -sfp:
log_something_with_long_function( 'This is a log message.', 2 );
Coro::AnyEvent::sleep( 3, 4 );
# OLD: perltidy -sfp
log_something_with_long_function ( 'This is a log message.', 2 );
Coro::AnyEvent::sleep ( 3, 4 );
# NEW: perltidy -sfp
log_something_with_long_function ( 'This is a log message.', 2 );
Coro::AnyEvent::sleep ( 3, 4 );This update changes the default to not do this vertical alignment. This should have been the default but this side-effect was missed when the -sfp parameter was added. Note that parens following keywords are likewise not vertically aligned.
5 Mar 2021, 00431bf.
In this issue, different results were obtained depending upon the existence of a comma in a list. To fix this, the definition of a list was adjusted from requiring one or more commas to requiring either a fat comma or a comma.
At the same time, a known problem involving the combination -lp -bbp=n -bbpi=n was fixed. This fixes cases b826 b909 b989.
4 Mar 2021, 872d4b4.
Some edge cases for the welding parameter -wn have been fixed. There are no other currently known weld issues. Some debug code for welding has been left in the code for possible future use.
This fixes cases b109 b110 b520 b756 b901 b937 b965 b982 b988 b991 b992 b993
3 Mar 2021, cfef087.
This is the parameter file b990.pro: --noadd-whitespace --continuation-indentation=0 --maximum-line-length=7 --space-terminal-semicolon
Applying perltidy -pro=b990.pro to the following snippet gave two states
# State 1
print
H;
# State 2
print H
;The tokenizer was alternately parsing 'H' as either possble indirect object, 'Z', or indirect object, 'Y'. Two fixes were tested. The first was to modify the tokenizer to recognize a ';' as well as a space as a direct object terminator. An alternative fix is to not allowing a break before type 'Y' so that the tokenizer kept parsing as type 'Y'. Both fixes work, but the latter fix would change existing formatting by the -extrude option, so the first fix was used. With this fix, the stable state is 'State 1' above.
This update is a generalization of the update "Fixed blinker related to line break at indirect object" of 16 Jan 2021.
This fixes case b990. 1 Mar 2021, 49cd66f.
Perltidy does final formatting in discrete batches of tokens, where a batch is a continuous section of the total token list. A batch begins a new line and will be broken into one or more lines. If a batch starts with a blank token it will simply be skipped on on output. However, some rare problems have been found in random testing which can occur if a batch starts with a blank. An example is case b984 which has the following parameters:
# this is file 'b984.pro'
--block-brace-vertical-tightness=2
--indent-columns=10
--maximum-line-length=27
--outdent-keywords
--variable-maximum-line-length
# OLD: perltidy -pro=b984.pro
unless (
exists $self->{
'accession_number'} )
{ return "unknown";
}
# NEW: perltidy -pro=b984.pro
unless (
exists $self->{
'accession_number'} )
{ return "unknown";
}Both look OK, but the OLD version did not outdent the keyword 'return' as requested with the -okw flag.
This update fixes cases b149 b888 b984 b985 b986 b987.
28 Feb 2021, 8aaf599.
Random testing produced some rare cases where two spaces could occur in -csc text. This happened when there were multiple lines and the formatter placed a leading blank in one of the continuation lines as padding. This has been fixed.
For example
while (
<>;
)
{
...
} ## end while ( <>; )Previously, the last line had an extra space after the ';'
} ## end while ( <>; )Another example
while (
do {
{ package DB; @a = caller( $i++ ) }
}
)
{
...
} ## end while ( do { { package DB...}})Previously the last line had an extra space between the opening braces:
} ## end while ( do { { package DB...}})27 Feb 2021, b22e891.
Random testing produced an unstable state when a debug flag, -nfll, was set. The only time it is appropriate to set this flag is if the -extrude option is set, so a check was added to verify this. This fixes case b935.
27 Feb 2021, 9155b3d.
The previous update was found to occasionally needlessly change existing formatting with very long long lines. So it is restricted to just when -vmll is set. For example, it is ok to keep the long quote following the opening paren in the following case.
# perltidy -gnu
ok( "got to the end without dying (note without DEBUGGING passing this test means nothing)"
);26 Feb 2021, 2b88464.
This fixes case b965. The -vmll flag can produce gaps in lines which need to be included in weld line length estimates.
26 Feb 2021, a643cf2.
Random testing produced an unstable state for the following snippet (case b934)
sub pi();
if (
$t >
pi( )
)when run with these parameters:
--continuation-indentation=6
--maximum-line-length=17
--paren-vertical-tightness-closing=2The formatting was stable without the first line, which declares 'pi' to be a constant sub. The problem was fixed by updating a regex to treat the spacing of a paren following a sub the same for the two token types, 'U' or 'C' (constant function).
This fixes case b934, 12bfdfe.
26 Feb 2021.
This is a small change to the update of 13 Feb 2021, f79a4f1. Random testing produced additional blinking states caused by the combination of -vtc=2 and -vmll flag, plus several others. The problem was that a line length check in the vertical aligner was being skipped as an optimization if it didn't appear necessary. The unusual properties of the -vmll flag require that the check always be done.
This fixes cases b656 b862 b971 b972.
26 Feb 2021, 80107e0.
Some oscillating states produced in random parameter tests were traced to problems with forming one-line blocks. A more precise length test was added to fix this.
This fixes cases b562 b563 b574 b777 b778 b924 b936 b975 b976 b983.
In the process of fixing this issue, a glitch was discovered in the previous coding of the -bl (braces-left) flag that caused somewhat random results for block types sort/map/grep/eval. The problem was a conflict between the logic for forming one-line blocks and the logic for applying the -bl flag. Usually, -bl formatting was not applied to these block types, but occasionally it was. To minimize changes in existing formatting, in the new version the -bl flag is not applied to these block types. A future flag could be added to give user control over which of these block types are under -bl control.
25 Feb 2021, 92bec8d.
Testing with random input parameters produced some cases in which a stable solution could not be found due to attempts to form one-line blocks near the end of a long line. The problem was fixed by adding a small tolerance to the line length test. This does not change existing formatting.
This fixes cases b069 b070 b077 b078.
21 Feb 2021, 0b97b94.
The -bom flag tries to keep old breakpoints at lines beginning with '->' and also with some lines beginning with ')->'. These latter lines can lead to blinking states in cases where the opening paren is on the previous line. To fix this, a restriction was added that the line difference between the opening and closing parens should be more than 1.
This fixes case b977.
21 Feb 2021, 28114e9.
Testing with ramdom input parameters produced states which were oscillating because of a conflict between the -wn and -bom parameters. The problem was resolved by giving the -bom parameter priority over -wn.
These cases are fixed with this update: b966 b973
20 Feb 2021.
Testing with random input parameters produced a number of oscillating states which had both parameter -xci as well as a value of -ci=n which exceeded the value of -i=n. To correct this, perltidy will silently reduce the -ci value to the -i value when -xci is also set. This should not change existing formatting because a value of -ci greater than -i would not normally be used in practice.
These cases are fixed with this update: b707 b770 b912 b920 b930 b933 b939 b940 b941 b942 b978 b974 b979 b980 b981
20 Feb 2021, c16c5ee.
Several cases of alternating states were produced in random testing which were caused by line length limits being reached when welding to qw lists. This was fixed by adding a small tolerance to line length tests.
This fixes cases b654 b655 b943 b944 b967 b968 b969 b970.
19 Feb 2021, 0baafc8.
The update of 13 Feb 2021, cf414fe, has been modified to be less restrictive. Space between a binary plus and minus and a bareword may now be removed in some cases where no tokenization ambiguity exists. 18 Feb 2021, a8564c8.
This update fixes cases b899 b935. 17 Feb 2021, b955a7c.
The reason is that it has a very strong bond strength to the next token, so a line break after it may not work. Previously we allowed welding to something like '@{' but even that caused blinking states (cases b751, b779).
This will not change much existing code. This update fixes cases b751 b779.
16 Feb 2021, eb2f4e7.
Random testing with very short maximum line lengths produced some blinking states which were traced to the tokenizer alternately parsed an unknown bareword as type 'w' or type 'G', depending on whether or not an opening block brace immediately followed on the same line. To fix this, a rule was added which prevents a line break between a type 'G' token and an opening code block brace.
This update fixes these cases: b900 b902 b928 b929
15 Feb 2021, f005a95.
Random testing with very short maximum line lengths produced some blinking states which were traced to duplicating old comma breakpoints which were not really good breakpoints. A patch was made to be more selective.
These cases are fixed with this update: b610 b757 b931
15 Feb 2021, 98b41a0.
The line length test which was added Feb 13 2021 turns out to be more restrictive than necessary. A modification was made to only apply it if a new one-line block would be formed. This prevents it from needlessly changing existing formatting.
The following cases were re-activated after this update: b654 b655 b656 b862
15 Feb 2021, 4673fdd.
In testing perltidy with random input parameters, some blinking states occurred when the value of -ci was significantly larger than the value of -i. (In actual practice, -ci is not normally set greater than -i). This update adds a tolerance to line length tests which avoids this problem. This fixes the following cases
b775 b776 b826 b908 b910 b911 b923 b925 b926 b927
14 Feb 2021, 8451f2f.
This update makes a space between a binary + or - and a bareword an essential whitespace. Otherwise, they may be converted into unary + or - on the next pass, which can lead to blinking states. Fixes cases b660 b670 b780 b781 b787 b788 b790.
13 Feb 2021, cf414fe.
Some alternating states were produced when extremely maximum line lengths forced a break after a unary plus or minus. Fixes cases b670 b790.
13 Feb 2021, cf414fe.
Random testing produced a number of cases of blinking states which were caused when the -vtc=2 flag caused the vertical aligner to combine lines which exceeded the allowable line length. These long lines were then getting reduced in size on every other iteration. A line length test was added in the vertical aligner to prevent this. This fixes these cases:
b654 b655 b656 b657 b761 b762 b763 b764 b765 b766 b767 b768 b769 b862 b904 b905 b906 b907 b913 b914 b915 b916 b917 b918 b919
13 Feb 2021, f79a4f1.
Random testing produced a blinking state which was traced to the unary plus not having a defined strength in the line break algorithm. This was fixed by setting it to be the same as the left strength of a plus. This fixes case b511. 12 Feb 2021, 58a7895.
Random testing produced some blinking cases which were related to detecting an old good breakpoint at an equals. If the user requested that a break be done before an equals, and the input script had a break after an equals, then that break should not have been marked as a good existing break point before a keyword. This update fixes cases b434 b903.
11 Feb 2021, f9a8543.
Random testing produced a case where a blank line after an =cut was alternately being deleted and added due to a conflict with the flag setting -keep-old-blank-lines=0. This was resolved by giving prioritiy to the essential blank line after the =cut line.
This fixes case b860. 11 Feb 2021, 8c13609.
A blinking state produced by random testing was traced to a line of coding which which unnecessarily prevented one-line blocks from being formed when a here-target was encountered. This has been fixed.
For example, the code block in the following contains a here target and was being broken into two lines:
unless ($INC{$file}) {
die <<"END_DIE" }These will now be output with the blocks intact, like this
unless ($INC{$file}) { die <<"END_DIE" }This fixes case b523. 11 Feb 2021, 6d5bb74.
Random testing produced an alternating state which was caused by -kgb flags being active on keywords which were in a list rather than a code block. A check was added to prevent this. Also, the -kgb* flags have no effect if no blank lines can be output, so a check was added for this situation. This fixes case b760.
10 Feb 2021, 177fc3a.
Random testing with unusual parameters produced some blinking weld states which were fixed by modifying a tolerance used in a line length test. The following cases were fixed with this update:
b746 b748 b749 b750 b752 b753 b754 b755 b756 b758 b759 b771 b772 b773 b774 b782 b783 b784 b785 b786
9 Feb 2021, a4609ac.
Random testing produced some blinking cases resulting from the treatment of old line breaks at commas not contained within containers. The following cases were fixed with this update:
b064 b065 b068 b210 b747
This change has no effect on scripts with normal parameter values. 9 Feb 2021, 5c23661.
A number of cases of blinking states were traced to code which biased the breaking of long lines to existing breaks. This was fixed by restricting this coding to just use old comma line break points.
The following cases were fixed with this update:
b193 b194 b195 b197 b198 b199 b216 b217 b218 b219 b220 b221 b244 b245 b246 b247 b249 b251 b252 b253 b254 b256 b257 b258 b259 b260 b261 b262 b263 b264 b265 b266 b268 b269 b270 b271 b272 b274 b275 b278 b280 b281 b283 b285 b288 b291 b295 b296 b297 b299 b302 b304 b305 b307 b310 b311 b312 b313 b314 b315 b316 b317 b318 b319 b320 b321 b322 b323 b324 b325 b326 b327 b329 b330 b331 b332 b333 b334 b335 b336 b337 b338 b339 b340 b341 b342 b343 b344 b345 b346 b347 b348 b349
8 Feb 2021, 66be455.
Random testing revealed a rare alternating state which could occur when both flags --one-line-block-nesting=n and --weld-nested-containers are set, and the maximum line length is set very low. The problem was fixed by ignoring the first flag at welded tokens. This should not have any effect on scripts with realistic parameter values.
The following case was fixed with this update: b690.
6 Feb 2021, 3e96930.
A rule was added to prevent certain rare blinking states involving welding. The rule is that if an opening container is immediately followed by a bareword which is unknown, a weld will be avoided.
The following cases were fixed with this update: b611 b626.
6 Feb 2021, 6b1f44a
This update adds a new variable which indicates if a container is permanently broken due to a side comment or blank line. This helps reduce the number of cases where the -bbxi=n flag cannot be applied. Another change was to always apply the -bbx=n flag, even if the -bbxi=n flag cannot be applied. These two flags now operate almost exactly as in previous versions but without the blinking problem. The only difference is that now the -bbxi=n flag with n>0 will revert to n=0 for some short containers which might not be broken open.
The options of the form bbxi=2, such as break-before-paren-and-indent=2, have been found to cause blinking states if the -lp flag is set. Both of these options are fairly rare. To correct this the -bbxi=2 flag is now reset to -bbxi=0 if the -lp flag is set. Note that -bbxi=2 and -bbxi=0 give the same formatting result with the common setting -ci=4 and -i=4.
The following cases were fixed with this update:
b396 b397 b398 b429 b435 b457 b502 b503 b504 b505 b538 b540 b542 b617 b618 b619 b620 b621
3 Feb 2021, 67ab0ef.
sub break_before_list_opening_containers was rewritten to reduce the chance of producing alternating states.
The following cases were fixed with this update:
b030 b032 b455 b456 b458 b459 b460 b461 b462 b536 b622 b651 b652 b653 b708 b709 b710 b713 b714 b719 b723 b724 b725 b726 b727 b729 b731 b733 b735 b736 b737 b738 b739 b740 b743 b744
3 Feb 2021, 5083ab9.
Random testing produced some blinking states which could be fixed by changing the definition of a list, for formatting purposes, to have one or more interior commas rather than simply one or more commas. The difference is that something with a single terminal comma, like '( $x, )', is no longer classified as a list. This makes no difference except when perltidy is stress tested with unusual parameters.
The following cases were fixed with this update:
b116 b119 b122 b174 b179 b187 b361 b369 b370 b372 b376 b427 b428 b448 b449 b450 b451 b452 b453 b469 b473 b474 b475 b476 b477 b479 b480 b481 b482 b497 b552 b553 b554 b558 b559 b634 b637 b642 b644 b645 b647 b650 b661 b662 b663 b664 b666 b677 b685 b688 b698 b699 b700 b702 b703 b704 b711 b712 b715 b716 b717 b718 b721 b730 b734 b741 b742
1 Feb 2021, 35078f7.
Random testing produced a large number of blinking states involving parameters such as --break-before-parens=n and --break-before-parens-and-indent=n and similar pairs. The problem was traced to the fact that the former parameter was implemented late in the pipeline whereas the latter parameter was implemented early in the pipeline. Normally there was no problem, but in some extreme cases, often involving very short maximum line lengths, this could produce alternating output states. The problem was resolved by combining the implementation of both flags in a single new sub to avoid any inconsistencies. The following cases were fixed with this update:
b018 b066 b071 b079 b090 b105 b146 b149 b158 b160 b161 b163 b164 b166 b167 b169 b170 b171 b172 b178 b185 b190 b192 b203 b206 b222 b223 b224 b237 b359 b362 b377 b379 b381 b382 b389 b395 b407 b408 b409 b410 b411 b412 b414 b417 b418 b419 b421 b433 b438 b443 b444 b478 b483 b484 b486 b490 b492 b493 b494 b496 b506 b507 b517 b521 b522 b524 b525 b535 b537 b539 b541 b543 b546 b550 b551 b555 b564 b566 b567 b569 b570 b572 b573 b575 b576 b577 b578 b579 b580 b582 b586 b587 b588 b589 b590 b591 b592 b593 b603 b607 b609 b613 b615 b616 b623 b624 b630 b635 b636 b638 b639 b640 b641 b643 b646 b648 b649 b658 b659 b665 b667 b668 b669 b671 b672 b673 b674 b675 b676 b678 b679 b680 b681 b682 b683 b684 b686 b687 b689 b691 b692 b693 b694 b695 b696 b697 b701 b705 b706 b720 b722 b728 b732 b745
31 Jan 2021, 10e8bfd.
Most remaining edge cases of blinking states involving the -wn parameter have been fixed by adjusting some tolerances in sub weld_nested_containers. The following cases are fixed with this update:
b156 b157 b186 b196 b454 b520 b527 b530 b532 b533 b534 b612 b614 b625 b627
This update has no effect for realistic parameter settings.
30 Jan 2021, d359a60.
Some blinking cases produced in random testing were traced to welding in very short lines (length = 20 for example) in which a weld was made to a square bracket containing just a single parameter, so that it had no good internal breaking points. A rule was added to avoid welding to a square bracket not containing any commas. The following cases were fixed with the update:
b002 b003 b005 b006 b007 b009 b010 b014 b015 b017 b020 b111 b112 b113 b124 b126 b128 b151 b153 b439 b606
29 Jan 2021, 33f1f2b.
Random testing produced some blinking states which were traced to the precision of a line length test. In sub weld_nested_containers, the test
$do_not_weld ||= $excess_length_to_K->($Kinner_opening) > 0;was changed to allow a 1 character margin of error:
$do_not_weld ||= $excess_length_to_K->($Kinner_opening) >= 0;The following cases were fixed with this update:
b025 b075 b091 b109 b110 b152 b154 b155 b162 b168 b176 b422 b423 b424 b425 b426 b565
29 Jan 2021, 33f1f2b.
Random testing produced some blinking states which were eliminated by a simplification of the definition of a one_line_weld in sub weld_nested_containers. The following cases were fixed with this update:
b131 b134 b136 b205 b233 b238 b284 b350 b352 b358 b385 b487 b604 b605
29 Jan 2021, 33f1f2b.
The following cases were fixed with this update:
b041 b182 b184 b366 b367 b368 b370 b371 b382 b420 b432 b438 b464 b466 b467 b468 b500 b501 b508 b509 b510 b512 b513 b514 b515 b516 b526 b528 b529 b531 b544 b545 b547 b548 b549 b556 b557 b568 b571 b581 b583 b584 b585 b594 b595 b596 b597 b598 b599 b600 b601 b602 b608 b041 b182 b184 b355 b356 b366 b367 b368 b371 b420 b432 b464 b465 b466 b467 b468 b500 b501 b508 b509 b510 b512 b513 b514 b515 b516 b526 b528 b529 b531 b544 b545 b547 b548 b549 b556 b557 b568 b571 b581 b583 b584
28 Jan 2021.
Random testing produced a number of cases in which the combination -cab=2 and bbhbi=n and similar flags were in conflict, causing alternating states. This was fixed by not changing ci for containers which can fit entirely on one line, which is what -cab=2 says to do. The following cases were fixed with this update:
b046 b061 b081 b084 b089 b093 b130 b133 b135 b138 b142 b145 b147 b150 b165 b173 b191 b211 b294 b309 b360 b363 b364 b365 b373 b386 b387 b388 b392 b437 b440 b472 b488 b489
27 Jan 2021, 6d710de.
Random testing produced a case in which the --freeze-whitespace flag (which is mainly useful for testing) could cause a blank space which kept increasing. The problem was caused by the "vertical tightness" mechanism. Turning it off when the -freeze-whitespace-flag is on fixed the problem. The following cases were fixed with this update:
b037 b038 b043 b059 b060 b067 b072 b215 b225 b267 b273 b276 b279 b282 b289 b292 b300 b303 b354 b374 b375 b383 b384 b402 b403 b404 b405 b436 b441 b445 b446 b471 b485 b498 b499
27 Jan 2021, 6d710de.
Random testing with extreme parameter values revealed blinking states associated with the -bbpi and related flags. The problem was that continuation indentation was sometimes being added according to the flag but the lists were not actually being broken. After this was fixed the following cases ran correctly:
b024 b035 b036 b040 b042 b047 b049 b050 b051 b052 b053 b054 b057 b062 b063 b073 b074 b076 b080 b083 b085 b086 b087 b088 b102 b103 b104 b106 b107 b108 b115 b118 b121 b123 b125 b127 b132 b137 b139 b140 b141 b143 b144 b148 b159 b175 b177 b180 b181 b188 b189 b200 b201 b202 b204 b207 b212 b213 b214 b226 b227 b228 b229 b230 b232 b239 b240 b241 b243 b248 b250 b255 b277 b286 b287 b290 b293 b298 b301 b306 b308 b328 b351 b353 b357 b378 b380 b390 b391 b393 b394 b399 b400 b401 b406 b413 b415 b416 b430 b431 b442 b447 b463 b470 b491 b495
27 Jan 2021, 96144a3.
Random testing produced some blinking states which were traced to an incorrect implementation of the --freeze-whitespace option (which is mainly useful in stress testing perltidy). A related flag, --add-whitespace is involved. This update corrects these problems. Test cases include b057, b183, b242. 24 Jan 2021, 9956a57.
The problem is that a bare closing qw paren was not being outdented if the flag '-nodelete-old-newlines is set. For example
# OLD (OK, outdented): perltidy -ci=4 -xci
{
modules => [
qw(
JSON
)
],
}
# OLD (indented) : perltidy -ndnl -ci=4 -xci
{
modules => [
qw(
JSON
)
],
}
# FIXED: perltidy -ndnl -ci=4 -xci
{
modules => [
qw(
JSON
)
],
}The problem happened because the -ndnl flag forces each line to be written immediately, so the next line (which needs to be checked in this case) was not available when the outdent decision had to be made. A patch to work around this was added 24 Jan 2021, 52996fb.
Random testing revealed some problems involving the -lp option which are fixed with this update.
The problem is illustrated with the following snippet
# perltidy -lp
Alien::FillOutTemplate(
"$main::libdir/to-$main::desttype/$main::filetype/spec",
"$workdir/$fields{NAME}-$fields{VERSION}-$fields{RELEASE}.spec",
%fields
);which alternately formats to this form
# perltidy -lp
Alien::FillOutTemplate(
"$main::libdir/to-$main::desttype/$main::filetype/spec",
"$workdir/$fields{NAME}-$fields{VERSION}-$fields{RELEASE}.spec",
%fields );when formatted with the single parameter -lp. A number of similar examples were found in testing. The problem was traced to the treatment of the space which perltidy tentatively adds wherever there is a newline, just in case the formatted output has different line breaks. The problem was that the indentation level of these spaces was being set as the level of the next token rather than the previous token. Normally the indentation level of a space has no effect, but the -lp option does use it and this caused the problem. This was fixed 23 Jan 2021, edc7878.
In random testing, the following two alternating states
# State 1
{
if ( defined
($symbol_table{$direccion}) )
}
# State 2
{
if (defined (
$symbol_table{
$direccion}
)
)
}were occurring with the following particular parameter set
--weld-nested-containers
--maximum-line-length=40
--continuation-indentation=7
--paren-tightness=2
--extended-continuation-indentationThe problem was traced to welding to the opening hash brace. A rule was added to prevent this, and testing with a large body of code showed that it did not significantly change existing formatting. With this change, the above snippet formats in the stable state
{
if (defined(
$symbol_table{$direccion}
))
}20 Jan 2021, 4021436.
A blinking state was found in random testing for the following snippet
=head1 TODO
handle UNIMARC encodings
=cut
use strict;
use warnings;when run with the following parameters
--keyword-group-blanks-size='2.8'
--keyword-group-blanks-before=0The space after the =cut was alternately being added as an essential blank which is required by pod utilities, and then deleted by these parameters. This was fixed 17 Jan 2021, b9a5f5d.
In random testing, the cause of a blinker was traced to both flags --ignore-old-breakpoints and --break-at-old-comma-breakpoints being set. There is a warning message but the -boc flag was not actually being turned off. This was fixed 17 Jan 2021, b9a5f5d.
A space following a token type 'Y' (filehandle) should not be removed. Otherwise it might be converted into type 'Z' (possible filehandle). If that were to happen, the space could not be added back automatically in later formatting, so the user would have to do it by hand. This fix prevents this from happening. 17 Jan 2021, bef9a83.
In random testing a blinker was reduced to the following snippet
{
print FILE
GD::Barcode
->new();
}which switched to the following state on each iteration
{
print FILE GD::Barcode
->new();
}with the following parameters
--maximum-line-length=20
--indent-columns=9
--continuation-indentation=1The problem was that the token 'FILE' was either parsed as type 'Y' or 'Z' depending on the existence of a subsequent space. These have different line break rules, causing a blinker. The problem was fixed by modifying the tokenizer to consider a newline to be a space. Updated 16 Jan 2021, d40cca9.
A conflict arises if both -bli and -bar are set. In this case a warning message is given and -bli is turned off. Updated 15 Jan 2021, ef69531.
A blinking state was discovered in testing between the following two states
my$table=
[[1,2,3],[2,4,6],[3,6,9],
];
my$table=
[[1,2,3],[2,4,6],[3,6,9],];with these parameters
--continuation-indentation=5
--maximum-line-length=31
--break-before-square-bracket-and-indent=2
--break-before-square-bracket=1
--noadd-whitespaceThe problem was found to be caused by the -bbsb parameters causing the indentation level of the first square bracket to change depending upon whether the term was broken on input or not. Two fixes would correct this. One is to turn off the option if the -ci=n value exceeds the -i=n value. The other is to require a broken container to span at least three lines before turning this option on. The latter option was made to sub 'adjust_container_indentation'. With this change the snippet remains stable at the second state above. Fixed 14 Jan 2021, 5c793a1.
In random testing with convergence a 'blinker' (oscillating states) was found for the following script
sub _prompt {
print $_[0];
return (
readline
(*{$_[1]})!~
/^q/i)
; # Return false if user types 'q'
}with the following specific parameters:
--maximum-line-length=32
--indent-columns=6
--continuation-indentation=7
--weld-nested-containers
--extended-continuation-indentation
--noadd-whitespaceThe other state was
sub _prompt {
print $_[0];
return (
readline(
*{
$_
[
1
]
}
)!~/^q/i
)
; # Return false if user types 'q'
}All of the listed parameters are required to cause this, but the main cause is the very large continuation indentation and short line length. Welding was being turned on and off in this case. Normally welding is not done if all containers are on a single line, but an exception was made to detect a situation like this and keep the welded string together. Updated 13 Jan 2021, 5c793a1.
A syntax error was produced in random testing when perltidy was fed the following line:
sub _DR () { pi2 /360 } sub _RD () { 360 /pi2 }The bareword 'pi2' was not recognized and the text between the two slashes was a taken as a possible pattern argument in a parenless call to pi2. Two fixes were made to fix this. Perltidy looks for 'pi' but not 'pi2', so the first fix was to expand its table to include all variations of 'pi' in Trig.pm. Second, the fact that the first slash was followed by a number should have tipped the guess to favor division, so this was fixed. As it was, a backup spacing rule was used, which favored a pattern.
The formatted result is now
sub _DR () { pi2 / 360 }
sub _RD () { 360 / pi2 }This update was made 13 Jan 2021, a50ecf8.
A formula used to estimating maximum line length when the -wn option is set was missing a term for continuation indentation. No actual changes in formatting have been seen. This update made 12 Jan 2021.
The following blinker was found in random testing. The following statement (with @j starting at level 0)
@j = ( $x, $y, $z );run with the following parameters
--indent-columns=5
--continuation-indentation=7
--maximum-line-length=20
--break-before-paren-and-indent=2
--break-before-paren=2
--maximum-fields-per-table=4caused an oscillation between two states. An unusual feature which contributed to the problem is the very large ci value. This is fixed in a patch made 12 Jan 2021, 9a97dba.
The indentation of multiline qw quotes runs into problems when there is nesting, as in the following.
# OLD: perltidy -xci -ci=4
for my $feep (
qw{
pwage pwchange pwclass pwcomment
pwexpire pwgecos pwpasswd pwquota
}
)The problem is that multiline qw quotes do not get the same indentation treatment as lists.
This update fixes this in the following circumstances:
- the leading qw( and trailing ) are on separate lines
- the closing token is one of ) } ] >
- the -xci flag is setThe above example becomes
# NEW: perltidy -xci -ci=4
for my $feep (
qw{
pwage pwchange pwclass pwcomment
pwexpire pwgecos pwpasswd pwquota
}
)The reason that the -xci flag is required is to minimize unexpected changes to existing scripts. The extra indentation is removed if the -wn flag is also given, so both old and new versions with -wn give
# OLD and NEW: perltidy -wn -xci -ci=4
for my $feep ( qw{
pwage pwchange pwclass pwcomment
pwexpire pwgecos pwpasswd pwquota
} )This update added 8 Jan 2021, 474cfa8.
A rare case in which a vertical alignment opportunity of leading equals was missed has been fixed. This involved lines with additional varying alignment tokens, such as 'unless' and second '=' in lines 1-3 below. In this example lines 4 and 5 were not 'looking' backwards to align their leading equals.
# OLD:
$them = 'localhost' unless ( $them = shift );
$cmd = '!print' unless ( $cmd = shift );
$port = 2345 unless ( $port = shift );
$saddr = 'S n a4 x8';
$SIG{'INT'} = 'dokill';
# NEW
$them = 'localhost' unless ( $them = shift );
$cmd = '!print' unless ( $cmd = shift );
$port = 2345 unless ( $port = shift );
$saddr = 'S n a4 x8';
$SIG{'INT'} = 'dokill';Fixed 5 Jan 2021, 9244678.
The previous patch was moved to a location where it only applies if there is a side comment on the line with a closing token. This minimizes changes to other side comment locations.
The code for forgetting the last side comment location was rewritten to improve formatting in some edge cases. The update also fixes a very rare problem discovered during testing and illustrated with the following snippet. The problem occurs for the particular combination of parameters -sct -act=2 and when a closing paren has a side comment:
OLD: perltidy -sct -act=2
foreach $line (
[0, 1, 2], [3, 4, 5], [6, 7, 8], # rows
[0, 3, 6], [1, 4, 7], [2, 5, 8], # columns
[0, 4, 8], [2, 4, 6]) # diagonals
NEW: perltidy -sct -act=2
foreach $line (
[0, 1, 2], [3, 4, 5], [6, 7, 8], # rows
[0, 3, 6], [1, 4, 7], [2, 5, 8], # columns
[0, 4, 8], [2, 4, 6]) # diagonalsIn the old version the last side comment was aligned before the closing paren was attached to the previous line, causing the final side comment to be far to the right. A patch in the new version just places it at the default location. This is the best than can be done for now, but is preferable to the old formatting. 3 Jan 2021, e57d8db.
The code which aligns side comments remembers the most recent side comment and in some cases tries to start aligning at that column for later side comments. Sometimes the old side comment column was being remembered too long, causing occasional poor formatting and causing a noticeable and unexpected drift of side comment locations to the right. The rule for forgetting the previous side comment column has been modified to reduce this problem. The new rule is essentially to forget the previous side comment location at a new side comment with different indentation level or significant number of lines without side comments (about 12). The previous implementation forgetting changes in indentation level across code blocks only. Below is an example where the old method gets into trouble and the new method is ok:
# OLD:
foreach my $r (@$array) {
$Dat{Data}{ uc $r->[0] } = join( ";", @$r ); # store all info
my $name = $Dat{GivenName}{ uc $r->[0] } || $r->[1];
# pass array as ad-hoc string, mark missing values
$Dat{Data}{ uc $r->[0] } = join(
";",
(
uc $r->[0], uc $name, # symbol, name
$r->[2], $r->[3], $r->[4], # price, date, time
$r->[5], $r->[6], # change, %change
$r->[7], "-", "-", "-", # vol, avg vol, bid,ask
$r->[8], $r->[9], # previous, open
"$r->[10] - $r->[11]", $r->[12], # day range,year range,
"-", "-", "-", "-", "-"
)
); # eps,p/e,div,yld,cap
}The second side comment is at a deeper indentation level but was not being forgotten, causing line length limits to interfere with later alignment. The new rule gives a better result:
# NEW:
foreach my $r (@$array) {
$Dat{Data}{ uc $r->[0] } = join( ";", @$r ); # store all info
my $name = $Dat{GivenName}{ uc $r->[0] } || $r->[1];
# pass array as ad-hoc string, mark missing values
$Dat{Data}{ uc $r->[0] } = join(
";",
(
uc $r->[0], uc $name, # symbol, name
$r->[2], $r->[3], $r->[4], # price, date, time
$r->[5], $r->[6], # change, %change
$r->[7], "-", "-", "-", # vol, avg vol, bid,ask
$r->[8], $r->[9], # previous, open
"$r->[10] - $r->[11]", $r->[12], # day range,year range,
"-", "-", "-", "-", "-"
)
); # eps,p/e,div,yld,cap
}The following exampel shows an unexpected alignment in the cascade of trailing comments which are aligned but slowly separating from their closing containers:
# OLD:
{
$a = [
Cascade => $menu_cb,
-menuitems => [
[ Checkbutton => 'Oil checked', -variable => \$OIL ],
[
Button => 'See current values',
-command => [
\&see_vars, $TOP,
], # end see_vars
], # end button
], # end checkbutton menuitems
]; # end checkbuttons cascade
}This was caused by forgetting side comments only across code block changes. The new result is more reasonable:
# NEW:
{
$a = [
Cascade => $menu_cb,
-menuitems => [
[ Checkbutton => 'Oil checked', -variable => \$OIL ],
[
Button => 'See current values',
-command => [
\&see_vars, $TOP,
], # end see_vars
], # end button
], # end checkbutton menuitems
]; # end checkbuttons cascade
}This change will cause occasional differences in side comment locations from previous versions but overall it gives fewer unexpected results so it is a worthwhile change. 29-Dec-2020, 76993f4.
In rare cases it is necessary to update the type of lists, and this influences vertical alignment. This update fixes a minor inconsistency in doing this. In some rare cases with complex list elements vertical alignment can be improved. 27 Dec, 2020, 751faec.
# OLD
return join( '',
$pre, '<IMG ', $iconsizes{$alt} || '',
$align, 'BORDER=', $nav_border,
' ALT="', $alt, "\"\n",
' SRC="', $ICONSERVER, "/$icon",
'">' );
# NEW
return join( '',
$pre, '<IMG ', $iconsizes{$alt} || '',
$align, 'BORDER=', $nav_border,
' ALT="', $alt, "\"\n",
' SRC="', $ICONSERVER, "/$icon",
'">' );The existing rules for aligning two lines with very different lengths were rejecting some good alignments, such as the first line of numbers in the example below:
# OLD:
@gg_3 = (
[
0.0, 1.360755E-2, 9.569446E-4, 9.569446E-4,
1.043498E-3, 1.043498E-3
],
[
9.569446E-4, 9.569446E-4, 0.0, 7.065964E-5,
1.422811E-4, 1.422811E-4
],
...
);
# NEW:
@gg_3 = (
[
0.0, 1.360755E-2, 9.569446E-4, 9.569446E-4,
1.043498E-3, 1.043498E-3
],
[
9.569446E-4, 9.569446E-4, 0.0, 7.065964E-5,
1.422811E-4, 1.422811E-4
],
...
);The rule in sub 'two_line_pad' was updated to allow alignment of any lists if the patterns match exactly (all numbers in this case). Updated 27-Dec-2020, 035d2b7.
The -lp formatting style often does not work well when lists contain multiline qw quotes. This update avoids this problem by not formatting such lists with the -lp style. For example,
# OLD, perltidy -gnu
@EXPORT = (
qw(
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig,
);
# NEW, perltidy -gnu
@EXPORT = (
qw(
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig,
);27-Dec-2020, 948c9bd.
This update adds a sequence numbering system for multiline qw quotes. In the perltidy tokenizer normal container pair types, like { }, (), [], are given unique serial numbers which are used as keys to data structures. qw quoted lists do not get serial numbers by the tokenizer, so this update creates a separate serial number scheme for them to correct this problem. One formatting problem that this solves is that of preventing the closing token of a multiline quote from being outdented more than the opening token. This is a general formatting rule which should be followed. Without a sequence number, the closing qw token could not lookup its corresponding opening indentation so it had to resort to a default, breaking the rule, as in the following:
# OLD, perltidy -wn
# qw line
if ( $pos == 0 ) {
@return = grep( /^$word/,
sort qw(
! a b d h i m o q r u autobundle clean
make test install force reload look
) ); #<-- outdented more than 'sort'
}
# Here is the same with a list instead of a qw; note how the
# closing sort paren does not outdent more than the 'sort' line.
# This is the desired result for qw.
# perltidy -wn
if ( $pos == 0 ) {
@return = grep( /^$word/,
sort (
'!', 'a', 'b', 'd', 'h', 'i', 'm', 'o', 'q', 'r', 'u',
'autobundle', 'clean',
'make', 'test', 'install', 'force', 'reload', 'look'
) ); #<-- not outdented more than 'sort'
}
# NEW (perltidy -wn)
if ( $pos == 0 ) {
@return = grep( /^$word/,
sort qw(
! a b d h i m o q r u autobundle clean
make test install force reload look
) ); #<-- not outdented more than sort
}Here is another example # OLD: $_->meta->make_immutable( inline_constructor => 0, constructor_name => "_new", inline_accessors => 0, ) for qw( Class::XYZ::Package Class::XYZ::Module Class::XYZ::Class
Class::XYZ::Overload
); #<-- outdented more than the line with 'for qw('
# NEW:
$_->meta->make_immutable(
inline_constructor => 0,
constructor_name => "_new",
inline_accessors => 0,
)
for qw(
Class::XYZ::Package
Class::XYZ::Module
Class::XYZ::Class
Class::XYZ::Overload
); #<-- outdented same as the line with 'for qw('26 Dec 2020, cdbf0e4.
In the process of making vertical alignments, lines which are simple lists of items are treated different from other lines. The old method for finding and marking these lines had a few problems which are corrected with this update. The main problem was that the old method ran into trouble when there were side comments. For example, the old method was not marking the following list and as a result the two columns of values were not aligned:
# OLD
return (
$startpos, $ldelpos - $startpos, # PREFIX
$ldelpos, 1, # OPENING BRACKET
$ldelpos + 1, $endpos - $ldelpos - 2, # CONTENTS
$endpos - 1, 1, # CLOSING BRACKET
$endpos, length($$textref) - $endpos, # REMAINDER
);
# NEW
return (
$startpos, $ldelpos - $startpos, # PREFIX
$ldelpos, 1, # OPENING BRACKET
$ldelpos + 1, $endpos - $ldelpos - 2, # CONTENTS
$endpos - 1, 1, # CLOSING BRACKET
$endpos, length($$textref) - $endpos, # REMAINDER
);Another problem was that occasionally unwanted alignments were made between lines which were not really lists because the lines were incorrectly marked. For example (note padding after first comma)
# OLD: (undesirable alignment)
my ( $isig2, $chisq ) = ( 1 / ( $sig * $sig ), 0 );
my ( $ym, $al, $cov, $bet, $olda, $ochisq, $di, $pivt, $info ) =
map { null } ( 0 .. 8 );
# NEW: (no alignment)
my ( $isig2, $chisq ) = ( 1 / ( $sig * $sig ), 0 );
my ( $ym, $al, $cov, $bet, $olda, $ochisq, $di, $pivt, $info ) =
map { null } ( 0 .. 8 );This update was made 22 Dec 2020, 36d4c35.
Closing pattern delimiter tokens of qw quotes were not following the -cti flag settings for containers in all cases, as would be expected, in particular when followed by a comma. For example, the closing qw paren below was indented with continuation indentation but would not have that extra indentation if it followed the default -cpi setting for a paren:
# OLD:
@EXPORT = (
qw(
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig
);
# NEW
@EXPORT = (
qw(
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig
);This update makes closing qw quote terminators follow the settings for their corresponding container tokens as closely as possible. For a closing '>' the setting for a closing paren will now be followed. Other closing qw terminators will remain indented, to minimize changes to existing formatting. For example ('>' is outdented):
@EXPORT = (
qw<
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
>,
@trig
);but (';' remains indented):
@EXPORT = (
qw;
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
;,
@trig
);This update was added 18 Dec 2020 and modified 24 Dec 2020, 538688f.
Additional wording was added to the man pages regarding situations in which perltidy does not change whitespace. This update was added 17 Dec 2020.
Moved inner part of sub check_match into sub match_line_pair in order to make info available earlier. This gave some minor alignment improvements. This was done 16 Dec 2020, 7ba4f3b.
# OLD:
@tests = (
@common, '$_',
'"\$_"', '@_',
'"\@_"', '??N',
'"??N"', chr 256,
'"\x{100}"', chr 65536,
'"\x{10000}"', ord 'N' == 78 ? ( chr 11, '"\013"' ) : ()
);
# NEW:
@tests = (
@common, '$_',
'"\$_"', '@_',
'"\@_"', '??N',
'"??N"', chr 256,
'"\x{100}"', chr 65536,
'"\x{10000}"', ord 'N' == 78 ? ( chr 11, '"\013"' ) : ()
);There is a step in vertical alignment where the alignments are formed into a tree with different levels, and some deeper levels are pruned to preserve lower level alignments. This usually works well, but some deeper alignments will be lost, which is what was happening in the example below. It turns out that if the tree pruning is skipped when alignment depths increase monotonically across lines, as in the example, then better overall alignment is achieved by the subsequent 'sweep' pass.
# OLD
my $cmd = shift @ARGV;
if ( $cmd eq "new" ) { $force_new = 1; }
elsif ( $cmd eq "interactive" ) { $interactive = 1; $batch = 0; }
elsif ( $cmd eq "batch" ) { $batch = 1; $interactive = 0; }
elsif ( $cmd eq "use_old" ) { $use_old = 1; }
elsif ( $cmd eq "show" ) { $show = 1; last; }
elsif ( $cmd eq "showall" ) { $showall = 1; last; }
elsif ( $cmd eq "show_all" ) { $showall = 1; last; }
elsif ( $cmd eq "remove" ) { $remove = 1; last; }
elsif ( $cmd eq "help" ) { $help = 1; last; }
# NEW
my $cmd = shift @ARGV;
if ( $cmd eq "new" ) { $force_new = 1; }
elsif ( $cmd eq "interactive" ) { $interactive = 1; $batch = 0; }
elsif ( $cmd eq "batch" ) { $batch = 1; $interactive = 0; }
elsif ( $cmd eq "use_old" ) { $use_old = 1; }
elsif ( $cmd eq "show" ) { $show = 1; last; }
elsif ( $cmd eq "showall" ) { $showall = 1; last; }
elsif ( $cmd eq "show_all" ) { $showall = 1; last; }
elsif ( $cmd eq "remove" ) { $remove = 1; last; }
elsif ( $cmd eq "help" ) { $help = 1; last; }This update was made 14 Dec 2020, 44e0afa.
This update fixed a rare situation in which some vertical alignment was missed. The problem had to do with two lines being incorrectly marked as a marginal match. A new routine, 'match_line_pairs' was added to set a flag with the information needed to detect and prevent this. This fix was made 13 Dec 2020, 9a8e49b.
# OLD
$sec = $sec + ( 60 * $min );
$graphcpu[$sec] = $line;
$secmax = $sec if ( $sec > $secmax );
$linemax = $line if ( $line > $linemax );
# NEW
$sec = $sec + ( 60 * $min );
$graphcpu[$sec] = $line;
$secmax = $sec if ( $sec > $secmax );
$linemax = $line if ( $line > $linemax );A rule was added to prevent vertical alignment of lines with leading '=' across a change in continuation indentation. Sometimes aligning across a change in CI can come out okay, but sometimes it can be very poor. For example:
# BAD:
$! = 2, die qq/$0: can't stat -${arg}'s "$file"./
unless $time = ( stat($file) )[$STAT_MTIME];
# FIXED:
$! = 2, die qq/$0: can't stat -${arg}'s "$file"./
unless $time = ( stat($file) )[$STAT_MTIME];The second line is a continuation of the first, and this update prevents this alignment. The above 'BAD' formatting was in the previous developmental version of perltidy, not the previous release. This update added 12 Dec 2020, 5b56147.
When two lines would be perfectly aligned except for the line length limit, previously they would only be aligned if they had a common leading equals. The update removes this restriction and allows as many alignments to be made as possible. The results are generally improved. This update was made 11 Dec 2020, f3c6cd8. Some examples:
# In this example the side comments were limiting the matches
# OLD
shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
# NEW
shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like# The same is true here.
# OLD
if ($tvg::o_span) { $tvg::hour_span = $tvg::o_span; }
if ( $tvg::hour_span % 2 > 0 ) { $tvg::hour_span++; } # Multiple of 2
# NEW
if ($tvg::o_span) { $tvg::hour_span = $tvg::o_span; }
if ( $tvg::hour_span % 2 > 0 ) { $tvg::hour_span++; } # Multiple of 2In the next example, the first comma is now aligned but not the second, because of the line length limit:
# OLD
is( MyClass->meta, $mc, '... these metas are still the same thing' );
is( MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing' );
# NEW
is( MyClass->meta, $mc, '... these metas are still the same thing' );
is( MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing' );In this last example, the first comma is not aligned, but alignment resumes after the second comma.
# OLD
is( $obj->name, $COMPRESS_FILE, " Name now set to '$COMPRESS_FILE'" );
is( $obj->prefix, '', " Prefix now empty" );
# NEW
is( $obj->name, $COMPRESS_FILE, " Name now set to '$COMPRESS_FILE'" );
is( $obj->prefix, '', " Prefix now empty" );In perltidy a 'marginal match' occurs for example when two lines share some alignment tokens but are somewhat different. When this happens some limits are placed on the size of the padding spaces that can be introduced. In this update the amount of allowed padding is significantly increased for certain 'good' alignment tokens. Results of extensive testing were favorable provided that the change is restricted to alignments of '=', 'if' and 'unless'. Update made 10 Dec 2020, a585f0b.
# OLD
my @roles = $self->role_names;
my $role_names = join "|", @roles;
# NEW
my @roles = $self->role_names;
my $role_names = join "|", @roles;
# OLD
$sysname .= 'del' if $self->label =~ /deletion/;
$sysname .= 'ins' if $self->label =~ /insertion/;
$sysname .= uc $self->allele_ori->seq if $self->allele_ori->seq;
# NEW
$sysname .= 'del' if $self->label =~ /deletion/;
$sysname .= 'ins' if $self->label =~ /insertion/;
$sysname .= uc $self->allele_ori->seq if $self->allele_ori->seq;A minor adjustment was made to the rule for aligning lines which end in '=>'. When there are just two lines in an alignment group, the alignment is avoided if the first of the two ends in a '=>'. Previously, alignment was avoided if either ended in a '=>'. The old rule was preventing some good alignments in a later stage of the iteration. In the following example, the last two lines are processed separately because they do not match the comma in 'sprintf'. The new rule allows the fat comma alignment to eventually get made later in the iteration. Update made 9 Dec 2020, ca0ddf4.
# OLD
$template->param(
classlist => $classlist,
...,
suggestion => $suggestion,
totspent => sprintf( "%.2f", $totspent ),
totcomtd => sprintf( "%.2f", $totcomtd ),
totavail => sprintf( "%.2f", $totavail ),
nobudget => $#results == -1 ? 1 : 0,
intranetcolorstylesheet =>
C4::Context->preference("intranetcolorstylesheet"),
...
);
# NEW
$template->param(
classlist => $classlist,
...,
suggestion => $suggestion,
totspent => sprintf( "%.2f", $totspent ),
totcomtd => sprintf( "%.2f", $totcomtd ),
totavail => sprintf( "%.2f", $totavail ),
nobudget => $#results == -1 ? 1 : 0,
intranetcolorstylesheet =>
C4::Context->preference("intranetcolorstylesheet"),
...
);In the unlikely event that a user enters a filename more than once on the command line to perltidy, as for 'file1.pl' here
perltidy file1.pl file1.pl then that file will be processed more than once. This looks harmless, but if the user was also using the -b (backup) parameter, then the original backup would be overwritten, which is not good. To avoid this, a filter has been placed on the list of files to remove duplicates. 9 Dec 2020, 646a542.
The exit status flag was not being set for the -w option if the -se or if the -q flag were set. Issue git #44 was similar but a special case of the problem. The problem was fixed 8 Dec 2020, cb6028f.
This issue has to do with the --weld-nested-containers option in the specific case of formatting a function which returns a list of anonymous subs. For example
$promises[$i]->then(
sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
}
);A bug introduced in v20201202 caused an incorrect welding to occur when the -wn flag was set
$promises[$i]->then( sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
} );This bug has been fixed, and code which has been incorrectly formatted will be correctly formatted with the next release. The bug was a result of a new coding introduced in v20201202 for fixing some issues with parsing sub signatures. Previously they were sometimes parsed the same as prototypes and sometimes as lists, now they are always parsed as lists. Fixed 6 Dec 2020, 6fd0c4f.
Testing revealed that for a line such as
package Bob::Dog;which has extra spaces or even tabs after the keyword 'package', the extra spaces or tabs were not being removed. This was fixed 28 Nov 2020, 008443d. The line now formats to
package Bob::Dog;For the parameter combination --indent-only and --closing-side-comments, old closing side comments were getting deleted but new closing side comments were not made. A fix was made to prevent this deletion. This fix was made 27 Nov 2020, 957e0ca.
Previously, for the combination --indent-only and -conv, two iterations would be done. Only one iteration is necessary in this case. Fix made 23 Nov 2020, ae493d8.
In developing an improved convergence test, an issue slowing convergence was found related to signed numbers as in the following line,
@london = (deg2rad(- 0.5), deg2rad(90 - 51.3));The leading '-' here is separated from the following number '0.5'. This is handled by tokenizing the minus as type 'm' and the number as type 'n'. The whitespace between them is removed in formatting, and so the space is gone in the output. But a little problem is that the default rule for placing spaces within the parens is based on the token count, after the first formatting the result is
@london = ( deg2rad( -0.5 ), deg2rad( 90 - 51.3 ) );The next time it is formatted, the '-0.5' counts as one token, resulting in
@london = ( deg2rad(-0.5), deg2rad( 90 - 51.3 ) );Notice that the space within the parens around the '-0.5' is gone. An update was made to fix this, so that the final state is reached in one step. This fix was made 23 Nov 2020, f477c8b.
A rare situation was identified during testing in which a block comment could be converted to be a hanging side comment. For example:
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
local (%name) = ();
...
}For the following specific contitions the block comment in line 2 could be converted into a hanging side comment, which is undesirable:
1. The line contains nothing except for a '#' with no leading space
2. It follows a line with side comment
3. It has indentation level > 0An update was made to prevent this from happening. There are two cases, depending on the value of --maximum-consecutive-blank-lines, or -mbl. If this value is positive (the default) then a blank line is inserted above the block comment to prevent it from becoming a hanging side comment. If this -mbl is zero, then the comment is converted to be a static block comment which again prevents it from becoming a hanging side comment. This fix was made 23 Nov 2020, 2eb3de1.
A better test for convergence has been added. When iterations are requested, the new test will stop after the first pass if no changes in line break locations are made. Previously, at least two passes were required to verify convergnece unless the output stream had the same checksum as the input stream. Extensive testing has been made to verify the correctness of the new test. This update was made 23 Nov 2020, 29efb63.
An update was made to break vertical alignment when a new sequence of if-like statements or ternary statements is encountered. This situation was causing a loss of alignment in some cases. For example
OLD:
$m1 = 0;
if ( $value =~ /\bset\b/i ) { $m0 = 1; }
if ( $value =~ /\barithmetic/i ) { $m1 = 1; }
if ( $m0 && !$m1 ) { $CONFIG[1] = 0; }
elsif ( !$m0 && $m1 ) { $CONFIG[1] = 1; }
else { $ok = 0; last; }
NEW:
$m1 = 0;
if ( $value =~ /\bset\b/i ) { $m0 = 1; }
if ( $value =~ /\barithmetic/i ) { $m1 = 1; }
if ( $m0 && !$m1 ) { $CONFIG[1] = 0; }
elsif ( !$m0 && $m1 ) { $CONFIG[1] = 1; }
else { $ok = 0; last; }This update was made 15 Nov 2020, 2b7784d.
The parameter string can restrict the types of containers which are welded. This was added 11 Nov 2020 in 'added -wnxl=s for control of -wn', 2e642d2.
The man page gave the incorrect string for -fse. This was fixed 11 Nov 2020 in 1f9869e.
RPerl uses some bareword operators which caused error messages. An update was made to avoid this problem in files containing 'use RPerl'. This update was made 6 Nov 2020, f8bd088.
When -wn was set, the -vtc=n flag was being ignored. This was a simple fix made 5 Nov 2020 in 'fix issue git #45, -wn and -vtc=n now work together', 1fbc381.
These parameters request that old breakpoints be kept before or after selected token types. For example, -kbb='=>' means that newlines before fat commas should be kept. This was added 4 Nov 2020.
These parameters had tentatively been hardwired in the tokenizer. Now the user can control them or turn the checks off altogether.
In random testing, an error was encountered parsing the following line
$self->{"mod_id"}=($$*1001)%(10**(rand()*6));
---^
found Number where operator expected (previous token underlined)The line parsed correctly with a space between the '$$' and the '*'. The problem had to do with an error in some newer code for postfix dereferencing, and this was fixed on 2 Nov 2020, 'fix problem scanning '$$'; revise call to operator_expected', 49d993b.
The exit status was always 0 for --assert-tidy if the user had turned off error messages with -quiet. This was fixed by gluesys/master in 'fix exit status for assert-tidy/untidy options', 625d250.
A parsing error was encountered in a test parsing the following extruded signature:
sub foo2
(
$
first
,
$
,
$
third
)
{
return
"first=$first, third=$third"
;
}The second '$' combined with the ',' on the next line to form a punctuation variable. This was fixed 20 Oct 2020 in 'fixed problem parsing extruded signature', 9b454f6.
The file parses correctly now, with formatted output
sub foo2 ( $first, $, $third ) {
return "first=$first, third=$third";
}Several instances of incorrect array indexing were found in testing and fixed. These each involved incorrectly indexing with index -1. They were found by placing undefs at the end of arrays. None of these was causing incorrect formatting. They were fixed 26 Oct 2020 in 'fixed several instances of incorrect array indexing', c60f694.
In stress testing perltidy with the -extrude option, the following test snippet
use perl6-alpha;was broken into sepate lines
use
perl6
-
alpha
;A rule was added to prevent breaking around a dash separating two barewords. Rerunning gives
use
perl6-alpha
;This was fixed 26 Oct 2020 in 'prevent breaking package names with trailing dashes', 9234be4.
In stress testing perltidy with the -extrude option, using the following test snippet
my %var;
{
$var{-y} = 1;
$var{-q} = 1;
$var{-qq} = 1;
$var{-m} = 1;
$var{y} = 1;
$var{q} = 1;
$var{qq} = 1;
$var{m} = 1;
}a syntax error was created when newlines were placed before or after the dashes. It is necessary to always keep a dash on the same line with its surrounding tokens. A rule was added to do this. The new 'extruded' result for the above snippet is:
my%var
;
{
$var{-y}
=
1
;
$var{-q}
=
1
;
$var{-qq}
=
1
;
$var{-m}
=
1
;
$var{y}
=
1
;
$var{q}
=
1
;
$var{qq}
=
1
;
$var{m}
=
1
;
}This update was added 26 Oct 2020, 'prevent syntax error by breaking dashed barewords', e121cae.
Files for which 'severe errors' are found have always been output verbatim rather than being formatted. The definition of 'severe error' has been expanded to include a final indentation level error greater than 1, more than 2 brace errors, and more than 3 "unexpected token type" parsing errors. The goal is to avoid formatting a non-perl script or a perl script with severe errors. So for example the following snippet has a level error of 2
{{{{
}}was previously output with default parameters as
{
{
{
{}
}along with an error message. But now it is just output verbatim as
{{{{
}}along with an error message. This update was added 25 Oct 2020, 'avoid formatting files with more types of severe errors', 2a86f51.
A statement such as the following was generating an error message at the colon:
state $a : shared;The problem was that 'state' was not in the list of keywords. This has been fixed and the line now parses without error. The 'state.t' test file for perl 5.31 now formats without error. This was added 18 Oct 2020 in "add 'state' as keyword", d73e15f.
Simple signatures (those without commas) were being parsed with code originally written for prototypes. This prevented them from being formatted with the usual formatting rules. This was changed so that all signatures are now formatted with the normal formatting rules. For example:
# Old, input and after formatting:
sub t123 ($list=wantarray) { $list ? "list" : "scalar" }
# New, after formatting
sub t123 ( $list = wantarray ) { $list ? "list" : "scalar" }Notice that some spaces have been introduced within the signature. Previously the contents of the parens not changed unless the parens contained a list.
This change introduced a problem parsing extended syntax within signatures which has been fixed. In the following snippet, the ':' caused a parsing error which was fixed.
# perltidy -sal='method'
method foo4 ( $class : $bar, $bubba ) { $class->bar($bar) }The ':' here is given a type of 'A'. This may be used to change the spacing around it. For example:
# perltidy -sal='method' -nwls='A'
method foo4 ( $class: $bar, $bubba ) { $class->bar($bar) }This update was added 18 Oct 2020, in 'format all signatures separately from prototypes', e6a10f3. The test file 'signatures.t' distributed with perl5.31 formats without error now.
A problem with parsing variables of the form $# and $#array was found in testing and fixed. For most variables the leading sigil may be separated from the remaining part of the identifier by whitespace. An exception is for a variable beginning with '$#'. If there is any space between the '$' and '#' then the '#' starts a comment. So the following snippet is has valid syntax and is equivalent to $ans=40;
my $ #
#
ans = 40;This was being misparsed and was fixed 17 Oct 2020, in 'fixed parsing error with spaces in $#' a079cdb.
During testing the following error was found and fixed. Given the following input snippet:
get(
on_ready => sub ($worker) {
$on_ready->end;
return;
},
on_exit => sub ( $worker, $status ) { return; },
);The resulting formatting was
get(
on_ready => sub ($worker) {
$on_ready->end;
return;
}, on_exit => sub ( $worker, $status ) { return; },
);Notice that the break after the comma has been lost. The problem was traced to a short-cut taken by the code looking for one-line blocks. The unique circumstances in which this occurred involved a hash of anonymous subs, one with a signature with multiple parameters and short enough to be a one-line block, as in the last sub definition line. This was fixed 17 Oct 2020 in 'fix missing line break for hash of subs with signatures', 51428db.
Problems with parsing prototypes and signatures were found during testing and fixed 17 Oct 2020 in 'fixed problem parsing multi-line signatures with comments', 017fd07. For example the following snippet was mis-parsed because of the hash mark.
sub test ( # comment )))
$x, $x) { $x+$y }Complex signature expressions such as the following are now parsed without error:
sub t086
( #foo)))
$ #foo)))
a #foo)))
) #foo)))
{ $a.$b }The following line caused a tokenization error in which the two slashes were parsed as a pattern.
my $masksize = ceil( Opcode::opcodes / 8 ); # /This problem was discovered in random testing. When a slash follows a bareword whose prototype is not known to perltidy, it has to guess whether the slash starts a pattern or is a division. The guessing logic was rewritten and improved 14 Oct 2020 in 'rewrote logic to guess if divide or pattern', afebe2f.
The flag -bos, or --break-at-old-semicolon-breakpoints, keeps breaks at old isolated semicolons. For example
$z = sqrt($x**2 + $y**2)
;In testing it was found not to be doing this after braces which require semicolons, such as 'do' and anonymous subs. This was fixed 12 Oct 2020 in 'fix -bos to work with semicolons after braces', 03ee7fc. For example
my $dist = sub {
$z = sqrt( $x**2 + $y**2 )
;
}
;If a line break occurs after use overload then it will now be kept. Previously it was dropped. For example, this would be kept intact:
use overload
'+' => sub {
print length $_[2], "\n";
my ( $x, $y ) = _order(@_);
Number::Roman->new( int $x + $y );
},
'-' => sub {
my ( $x, $y ) = _order(@_);
Number::Roman->new( int $x - $y );
},
...This keeps the list from shifting to the right and can avoid problems in formatting the list with certain styles, including with the -xci flag. Fixed 12 Oct 2020 in 'keep break after use overload statement', 8485afa.
This flag causes continuation indentation to "extend" deeper into structures. If you use -ci=n and -i=n with the same value of n you will probably want to set this flag. Since this is a fairly new flag, the default is -nxci to avoid disturbing existing formatting.
This problem is illustrated with the following snippet when run with -bli -blil='*'
#-bli -bli list='*'
try
{
die;
}
catch
{
die;
}; # <-- this was not indentingThis was due to conflicting rules and was fixed 1 Oct 2020 in commit 'fix issue git #40, incorrect closing brace indentation with -bli', a5aefe9.
At the same time, it was noted that block types sort/map/grep and eval were not following -bli formatting when -blil='*' and this was fixed. For example, with corrected formatting, we would have
# perltidy -bli -blil='*'
eval
{
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
}
or do
{
$error = $@;
$produced_error = 1;
};This is a detailed log of changes since the release 20200907. All bugs were found with the help of automated random testing.
In random testing, the -mangle option introduced a syntax error by deleting the space between barewords and quotes (test file 'MxScreen'), such as:
oops"Your login, $Bad_Login, is not valid";Sub 'is_essential_whitespace' was updated to prevent this on 27 Sep 2020, in 'keep any space between a bareword and quote', f32553c.
The .LOG file reports any disagreements between the indentation of the input and output files. This can help locate brace errors. These were incorrect when some of the options were used, including --whitespace-cycle, -bbhb, -nib. This was corrected 24 Sep 2020, 'fixed incorrect log entry for indentation disagreement', 3d40545. At the same time, locations of closing brace indentation disagreements are now tracked and reported in the .ERR file when there is a brace error. This can help localize the error if the file was previously formatted by perltidy.
Previously only a complaint was given, which went into the log file and was not normally seen. Perl silently accepts this but it can cause significant problems with pod utilities, so a clear warning is better. This situation arose in testing on random files in combination with a -dp flag and it took some time to understand the results because of the lack of a warning.
This is not a bug, but is cleaner coding and insures that error messages get reported. This change was made 20 Sep 2020, 'switch from eval { } to ->can('finish_formatting')', 28f2a4f.
The following message was generated during automated testing
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 12079.
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 12089.
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 12097.The problem could be simplified to running perltidy -wn on this snippet:
__PACKAGE__->load_components( qw(
> Core
>
> ) );This was fixed 20 Sep 2020 in 'fixed_uninitialized_value', 8d6c4ed.
The following snippet was being incorrectly parsed:
print <<
# Hello World 13!
;
print "DONE\n";This is a deprecated here-doc without a specified target but currently still a valid program. It would have been correctly parsed if the semicolon followed the '<<' operator rather than the here-doc.
This was found in random testing and fixed 16 Sep 2020. A warning message about deprecated here-doc targets was added.
The -> can now be vertically aligned if a space is placed before it with -wls='->'. Added 15 Sep 2020 as part of previous item, 9ac6af6.
These flags give control over the opening token of a multiple-line list. They are described in the man pages, perltidy.html. Added 15 Sep 2020 in "added flags -bbhb=n, -bbsb=n, -bbq=n, suggestion git #38". 9ac6af6.
A change was made to allow a '=>' at the end of a line to align vertically, provided that it aligns with two or more other '=>' tokens. This update was 14 Sep 2020, 'Allow line-ending '=>' to align vertically', ea96739.
The following message was generated when running perltidy on random text:
Use of uninitialized value $K_semicolon in subtraction (-) at /home/steve/bin/Perl/Tidy/Formatter.pm line 16467.This was fixed 14 Sep 2020, included in 'Allow line-ending '=>' to align vertically', ea96739.
A rule was added to prevent a file consisting of a single semicolon
;from becoming a zero length file. This could cause problems with other software. Fixed 13 Sep 2020, 'do not create a zero length file by deleting semicolons', b39195e.
The following message was generated when running perltidy on random text:
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 11926.
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 11936.
Use of uninitialized value $cti in numeric eq (==) at /home/steve/bin/Perl/Tidy/Formatter.pm line 11944.This was fixed 13 Sep 2020 in 'fixed unitialized variable problem ', adb2096.
The following message was generated when running perltidy on random text:
substr outside of string at /home/steve/bin/Perl/Tidy/Tokenizer.pm line 7362.
Use of uninitialized value in concatenation (.) or string at /home/steve/bin/Perl/Tidy/Tokenizer.pm line 7362.This was fixed 13 Sep 2020 in 'fixed unitialized variable problem', 5bf49a3.
The following message was generated when running perltidy on random text:
Use of uninitialized value $K_opening in subtraction (-) at /home/steve/bin/Perl/Tidy/Formatter.pm line 16467.This was fixed 13 Sep 2020 in 'fix undefined variable reference', 1919482.
The following snippet generated a warning that there might be a hash-bang after the start of the script.
$x = 2;
#! sunos does not yet provide a /usr/bin/perl
$script = "$^X $script";To prevent this annoyance, the warning is not given unless the first nonblank character after the '#!' is a '/'. Note that this change is just for the warning message. The actual hash bang check does not require the slash.
Fixed 13 Sep 2020, 'prevent unnecessary hash-bang warning message' 4f7733e and 'improved hash-bang warning filter', fa84904.
An unitialized index was referenced when running on a file of randomly generated text:
Use of uninitialized value $K_oo in subtraction (-) at /home/steve/bin/Perl/Tidy/Formatter.pm line 7259.This was fixed 12 Sep 2020 in 'fixed undefined index', 616bb88.
The parameter combination -lp -wc triggered an internal bug message from perltidy:
398: Program bug with -lp. seqno=77 should be 254 and i=1 should be less than max=-1
713: The logfile perltidy.LOG may contain useful information
713:
713: Oops, you seem to have encountered a bug in perltidy. Please check the
713: BUGS file at http://perltidy.sourceforge.net. If the problem is not
713: listed there, please report it so that it can be corrected. Include the
...The problem is that the parameters --line-up-parentheses and --whitespace-cycle=n are not compatible. The fix is to write a message and turn off the -wc parameter when the both occur. This was fixed 8 Sep 2020 in "do not allow -wc and -lp together, can cause bugs", 7103781.
This snippet after processing with the indicated parameters triggered a Fault message in store-token-to-go due to discontinuous internal index values :
perltidy --noadd-newlines --space-terminal-semicolon
if ( $_ =~ /PENCIL/ ) { $pencil_flag= 1 } ; ;
$yy=1;This triggered the message:
==============================================================================
While operating on input stream with name: '<stdin>'
A fault was detected at line 7472 of sub 'Perl::Tidy::Formatter::store_token_to_go'
in file '/home/steve/bin/Perl/Tidy/Formatter.pm'
which was called from line 8298 of sub 'Perl::Tidy::Formatter::process_line_of_CODE'
Message: 'Unexpected break in K values: 591 != 589+1'
This is probably an error introduced by a recent programming change.
==============================================================================The deletion of the extra, spaced, comma had created an extra space in the token array which had not been forseen in the original programming. It was fixed 10 Sep 2020 in "fixed very rare fault found with automated testing", eb1b1d9.
This problem can be illustrated with this two-line snippet:
$#
eq$,?print"yes\n":print"no\n";Perltidy joined '$#' and 'eq' to get $#eq, but should have stopped at the line end to get $# followed by keyword 'eq'. (Note that $# is deprecated). This was fixed 11 Sep 2020 in "fixed several fringe parsing bugs found in testing", 85e01b7.
This problem can be illustrated with the following test snippet which was not correctly parsed.
print$$ <300?"$$<300\n":$$<700?"$$<700\n":$$<2_000?"$$<2,000\n":$$<10_000?"$$ <10,000\n":"$$>9,999\n";The problem is related to the '<' symbol following the '$$' variable, a possible filehandle, and is similar to a previous bug. The problem was corrected 11 Sep 2020 in "fixed several fringe parsing bugs found in testing", 85e01b7. The line now correctly formats to
print $$ < 300 ? "$$<300\n"
: $$ < 700 ? "$$<700\n"
: $$ < 2_000 ? "$$<2,000\n"
: $$ < 10_000 ? "$$ <10,000\n"
: "$$>9,999\n";A file with incorrect bracing which effectively gave negative indentation caused a crash when a stack was referenced with a negative index. The problem was fixed 8 Sept 2020 in "convert array to hash to avoid trouble with neg levels in bad files", a720e0d.
This error can be demonstrated with this line.
print $i <10 ? "yes" : "no";Perl has some strange parsing rules near a possible filehandle, and they change over time. The '<' here is a less than symbol, but perltidy expected that it might be the start of an angle operator, based on the old rules, and gave a warning. The formatting was still correct, but the warning was confusing. This has been fixed 8 Sep 2020 in 'remove confusing warning message', 0a4d725.
This problem is illustrated with the following snippet
$sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECTWhen run with a short line length it got broken after the here target, causing an error. This was due to a recent program change and fixed 7 Sep 2020 in 'fixed bug where long line with here target got broken', 8f7e4cb.
An uninitialized value was being referenced and triggered this message:
undefined test2, i_opening=5, max=18, caller=Perl::Tidy::Formatter ./perltidy-20200907.pl 13465
Use of uninitialized value $test2 in numeric eq (==) at ./perltidy-20200907.pl line 19692.Fixed 8 Sep 2020 in 'fixed rare problem with stored index values for -lp option', 4147c8c.
This problem arose in several scripts involving the parameter --line-up-parentheses pluse one or more of the vertical tightness flags. It can be illustrated with the following snippet:
perltidy --line-up-parentheses --paren-vertical-tightness=1
if (
( $name, $chap ) =
$cur_fname =~ m!^Bible/
.*?/ # testament
.*?/ # range of books
(.*?)/ # book name
.*? # optional range of verses
(\d+)$!x
)
{
$cur_name = "$name $chap";
}This gave
if (( $name, $chap ) =
.*?/ # testament
$cur_fname =~ m!^Bible/
.*?/ # range of books
(.*?)/ # book name
.*? # optional range of verses
(\d+)$!x
)
{
$cur_name = "$name $chap";
}Notice the incorrect line order. The problem was an incorrect order of operations in the vertical aligner flush, leaving a line stranded and coming out in the wrong order. This was fixed 11 Sep 2020.
This crash was due to an index error which caused a non-existent object to be referenced. The problem is fixed 2020-09-07 in "fix problem of undefined values involving j_terminal_match", c5bfa77. The particular parameters which caused this were:
--noadd-newlines --nowant-left-space='=' This is not a bug but did take some time to resolve. The problem was reduced to the following script run with the -x flag (--look-for-hash-bang)
print(SCRIPT$headmaybe . <<EOB . <<'EOF' .$tailmaybe),$!;
#!$wd/perl
EOB
print "\$^X is $^X, \$0 is $0\n";
EOFThe resulting file had a syntax error (here-doc target EOB changed).
print(SCRIPT$headmaybe . <<EOB . <<'EOF' .$tailmaybe),$!;
#!$wd/perl
EOB print "\$^X is $^X, \$0 is $0\n";
EOFThe problem is that the -x flag tells perltidy not to start parsing until it sees a line starting with '#!', which happens to be in a here-doc in this case.
A warning was added to the manual 7 Sept 2020 in "add warning about inappropriate -x flag", fe66743.
This problem was reduced to the following snippet:
substr
(
$#
)The deprecated variable '$#' was being parsed incorrectly, and this was due to an error in which the word 'substr' followed by a paren was taken as the start of a sub signature. The problem was fixed 8 Sep 2020 in 'fix problem parsing sub prototypes' 569e05f. The code
$container_type =~ /^sub/;was corrected to be
$container_type =~ /^sub\b/;Unitialized values were referenced. An index was not being tested. Fixed 8 Sep 2020 in "fix undefined variable", 9729965.
Use of uninitialized value $Kon in array element at /home/steve/bin/Perl/Tidy/Formatter.pm line 4022.
Use of uninitialized value $Kon in array element at /home/steve/bin/Perl/Tidy/Formatter.pm line 4023.
Use of uninitialized value $Ko in subtraction (-) at /home/steve/bin/Perl/Tidy/Formatter.pm line 4023.These are known issues which have not been fixed.
Basic parsing of lexical subs works but some aspects of lexical subs are not yet functional. One of these is that unlike regular subs, lexical subs can override names of builtin functions.
First consider the following snippet
sub s {
my $arg=$_[0];
print "s called with arg $arg\n";
}
s(1);
s(2);The 's' in the two last lines is the builtin s function, not the sub. Both perltidy and perl make the same assumption here. This program happens to still run but prints nothing. It will not run if the last semicolon is removed.
Now consider the following snippet in which the sub has a preceding 'my'
use feature 'lexical_subs', 'signatures';
my sub s {
my $arg=$_[0];
print "s called with arg $arg\n";
}
s(1);
s(2);The builtin function 's' is replaced by the sub s here, and the program runs. Perltidy will format this but it is assuming that the s in the two last lines are the builtin s function. If the last semicolon is removed, there will be an formatting error. So perltidy and perl make different assumptions in this case.
Another issue is that perltidy does not yet remember the extent of the scope of a lexical sub.
Consider the following snippet:
use Test::More;
ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno', || _diag $!;Note the unusual situation of a comma followed by an '||'. Perltidy will format this satisfactorily but it will write an error message. The syntax is correct, however. Perl knows the prototype of the 'ok' function, which is called here without parens, so the last comma marks the last arg and is needed to keep the || from attaching to the last arg.
Full support of peren-less calls will probably never be implemented in perltidy because it would require that it parse all of the modules used to find the prototypes. This would make it impossible to run perltidy on small snippets of code from within an editor.
The problem can be avoid if parens are used:
ok ( open($stdin, "<&", $1), 'open ... "<&", $magical_fileno') || _diag $!;Perltidy currently flags as an error a closing paren followed by an opening paren, as in the following
$subsubs[0]()(0)This syntax is ok. The example is from test 'current_sub.t' in perl5.31.
Source Files in .tar.gz and .zip format
This document tells how to install perltidy from the basic source
distribution files in .tar.gz or .zip format. These files are
identical except for the line endings. The .tar.gz has Unix style
line endings, and the .zip file has Windows style line endings. The
standard perl MakeMaker method should work for these in most cases.
Source files in RPM and .deb format
The web site also has links to RPM and Debian .deb Linux packages, which may be convenient for some users.
If you want to do a quick test of perltidy without doing any installation, get
a .tar.gz or a .zip source file and see the section below "Method 2: Installation
as a single binary script".
In certain circumstances, it is best to remove an older version of perltidy before installing the latest version. These are:
Uninstall a Version older than 20020225
You can use perltidy -v to determine the version number. The first
version of perltidy to use Makefile.PL for installation was 20020225, so
if your previous installation is older than this, it is best to remove
it, because the installation path may now be different. There were up
to 3 files these older installations: the script perltidy and
possibly two man pages, perltidy.1 and perl2web.1. If you saved
your Makefile, you can probably use make uninstall. Otherwise, you
can use a locate or find command to find and remove these files.
Uninstall older versions when changing installation method
If you switch from one installation method to another, the paths to the
components of perltidy may change, so it is probably best to remove the older
version before installing the new version. If your older installation method
had an uninstall option (such as with RPM's and debian packages), use it.
Otherwise, you can locate and remove the older files by hand. There are two
key files: Tidy.pm and perltidy. In addition, there may be one or two
man pages, something like Perl::Tidy.3pm and perltidy.1p. You can use a
locate and/or find command to find and remove these files. After
installation, you can verify that the new version of perltidy is working with
the perltidy -v command.
These are generic instructions. Some system-specific notes and hints are given in later sections.
Two separate installation methods are possible.
Method 1: Standard Installation Method
The standard method based on MakeMaker should work in a normal perl environment. This is the recommended installation procedure for systems which support it.
perl Makefile.PL
make
make test
make install
The make command is probably nmake under a Windows system. You
may need to become root (or administrator) before doing the make
install step.
Method 2: Installation as a single binary script
If you just want to take perltidy for a quick test drive without installing it, or are having trouble installing modules, you can bundle it all in one independent executable script. This might also be helpful on a system for which the Makefile.PL method does not work, or if you are temporarily a guest on some system, or if you want to try hacking a special version of perltidy without messing up your regular version.
You just need to uncompress the source distribution, cd down into it, and enter the command:
perl pm2pl
which will combine the pieces of perltidy into a single script named
perltidy in the current directory. This script should be
fully functional. Try it out on a handy perl script, for example
perl perltidy Makefile.PL
This should create Makefile.PL.tdy.
After Installation
After installation by either method, verify that the installation worked and that the correct new version is being by entering:
perltidy -v
If the version number disagrees with the version number embedded in the
distribution file name, search for and remove the old version.
For example, under a Unix system, the command which perltidy might
show where it is. Also, see the above notes on uninstalling older
versions.
On a Unix system running the bash shell, if you had a previous
installation of perltidy, you may have to use
hash -r
to get the shell to find the new one.
After perltidy is installed, you can find where it will look for
configuration files and environment variables on your system with
the command:
perltidy -dpro
How to Uninstall
Unfortunately, the standard Perl installation method does not seem able to do an uninstall.
But try this:
make uninstall
On some systems, it will give you a list of files to remove by hand. If
not, you need to find the script perltidy and its module file
Tidy.pm, which will be in a subdirectory named Perl in the site
library.
If you installed perltidy with the alternative method, you should just reverse the steps that you used.
Alternative method - Unix
If the alternative method is used, test the script produced by the
pm2pl perl script:
perl ./perltidy somefile.pl
where somefile.pl is any convenient test file, such as Makefile.PL
itself. Then,
1. If the script is not executable, use
chmod +x perltidy
2. Verify that the initial line in perltidy works for your system by entering:
./perltidy -h
which should produce the usage text and then exit. This should usually
work, but if it does not, you will need to change the first line in
perltidy to reflect the location of perl on your system. On a Unix
system, you might find the path to perl with the command 'which perl'.
3. A sample Makefile for this installation method is Makefile.npm.
Edit it to have the correct paths.
You will need to become root unless you change the paths to point to somewhere in your home directory. Then issue the command
make -f Makefile.npm install
This installs perltidy and the man page perltidy.1.
5. Test the installation using
perltidy -h
You should see the usage screen. Then, if you installed the man pages, try
man perltidy
which should bring up the manual page.
If you ever want to remove perltidy, you can remove perltidy and its man pages by hand or use
make uninstall
On a Windows 9x/Me system you should CLOSE ANY OPEN APPLICATIONS to avoid losing unsaved data in case of trouble.
Standard Method - Windows
After you unzip the distribution file, the procedure is probably this:
perl Makefile.PL
nmake
nmake test
nmake install
You may need to download a copy of unzip to unzip the .zip distribution
file; you can get this at
http://www.info-zip.org/pub/infozip/UnZip.html
If you have ActiveState Perl, the installation method is outlined at http://aspn.activestate.com//ASPN/Reference/Products/ActivePerl/faq/Windows/ActivePerl-Winfaq9.html#How_can_I_use_modules_from_CPAN_
You may need to download a copy of Microsoft's nmake program from
ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe
If you are not familiar with installing modules, or have trouble doing so, and want to start testing perltidy quickly, you may want to use the alternative method instead (next section).
Alternative Method - Windows
From the main installation directory, just enter
perl pm2pl
Placing the resulting file perltidy and the example batch file
perltidy.bat, located in the examples directory, in your path should
work. (You can determine your path by issuing the msdos command
PATH). However, the batch file probably will not support file
redirection. So, for example, to pipe the long help message through
'more', you might have to invoke perltidy with perl directly, like this:
perl \somepath\perltidy -h | more
The batch file will not work properly with wildcard filenames, but you may use wildcard filenames if you place them in quotes. For example
perltidy '*.pl'
Links to VMS Utilities and Documentation
To install perltidy you will need the following utilities Perl, of course, source with VMS goodies available from http://www.sidhe.org/vmsperl or binary available from the Compaq OpenVMS freeware CD. To unpack the source either gunzip and vmstar available from the Compaq OpenVMS freeware CD or zip available from http://www.info-zip.org/
To build perltidy you can use either MMS, Compaq's VMS equivalent of make, or MMK, an MMS clone available from http://www.madgoat.com.
Information on running perl under VMS can be found at: http://w4.lns.cornell.edu/~pvhp/perl/VMS.html
Unpack the source:
$ unzip -a perl-tidy-yyyymmdd.zip ! or
$ unzip /text=auto perl-tidy-yyyymmdd.zip ! or
$ gunzip perl-tidy-yyyymmdd.tgz
$ vmstar perl-tidy-yyyymmdd.tar
Build and install perltidy under VMS:
$ set default [.perl-tidy-yyymmdd]
$ perl perltidy.pl
$ mmk
$ mmk test
$ mmk install
Using Perltidy under VMS
Create a symbol. This should be put in a logon script, eg sylogin.com
$ perltidy == "perl perl_root:[utils]perltidy."
Default parameters can be placed in a perltidyrc file. Perltidy
looks for one in the following places and uses the first found if the
logical PERLTIDY is a file and the file exists then that is used if the
logical PERLTIDY is a directory then look for a .perltidyrc file in the
directory look for a .perltidyrc file in the user's home directory
To see where the search is done and which .perltidyrc is used type
$ perltidy -dpro
A system PERLTIDY logical can be defined pointing to a file with a
minimal configuration, and users can defined their own logical to use a
personal .perltidyrc file.
$ define /system perltidy perl_root:[utils]perltidy.rc
The -x Parameter
If you have one of the magic incantations at the start of perl scripts,
so that they can be invoked as a .com file, then you will need to use
the -x parameter which causes perltidy to skip all lines until it
finds a hash bang line eg #!perl -w. Since it is such a common
option this is probably a good thing to put in a .perltidyrc file.
VMS File Extensions
VMS file extensions will use an underscore character instead of a dot, when necessary, to create a valid filename. So
perltidy myfile.pl
will generate the output file myfile.pl_tdy instead of
myfile.pl.tdy, and so on.
If there seems to be a problem locating a configuration file, you can see what is going on in the config file search with:
perltidy -dpro
If you want to customize where perltidy looks for configuration files, look at the routine 'find_config_file' in module 'Tidy.pm'. You should be able to at least use the '-pro=filename' method under most systems.
Remember to place quotes (either single or double) around input parameters which contain spaces, such as file names. For example:
perltidy "file name with spaces"
Without the quotes, perltidy would look for four files: file,
name, with, and spaces.
If you develop a system-dependent patch that might be of general interest, please let us know.
You do not need a configuration file, but you may eventually want to create one to save typing; the tutorial and man page discuss this.
Perltidy needs to create a system temporary file when it invokes
Pod::Html to format pod text under the -html option. For Unix systems,
this will normally be a file in /tmp, and for other systems, it will be
a file in the current working directory named perltidy.TMP. This file
will be removed when the run finishes.
Documentation is contained in .pod format, either in the docs directory
or appended to the scripts.
These documents can also be found at http://perltidy.sourceforge.net
Reading the brief tutorial should help you use perltidy effectively.
The tutorial can be read interactively with perldoc, for
example
cd docs
perldoc tutorial.pod
or else an html version can be made with pod2html:
pod2html tutorial.pod >tutorial.html
If you use the Makefile.PL installation method on a Unix system, the perltidy and Perl::Tidy man pages should automatically be installed. Otherwise, you can extract the man pages with the pod2xxxx utilities, as follows:
cd bin
pod2text perltidy >perltidy.txt
pod2html perltidy >perltidy.html
cd lib/Perl
pod2text Tidy.pm >Tidy.txt
pod2html Tidy.pm >Tidy.html
After installation, the installation directory of files may be deleted.
Perltidy is still being developed, so please check sourceforge occasionally for updates if you find that it is useful. New releases are announced on freshmeat.net.
Thanks to the many programmers who have documented problems, made suggestions and sent patches.
If you see ways to improve these notes, please let us know.
A list of current bugs and issues can be found at the CPAN site https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy
To report a new bug or problem, use the link on this page .
Perl-Tidy-20250105/docs/index.html 0000644 0001750 0001750 00000006162 14735777213 015573 0 ustar steve stevePerltidy is a Perl script which indents and reformats Perl scripts to make them easier to read. If you write Perl scripts, or spend much time reading them, you will probably find it useful.
Perltidy is free software released under the GNU General Public License -- please see the included file COPYING for details.
The formatting can be controlled with command line parameters. The default parameter settings approximately follow the suggestions in the Perl Style Guide.
Besides reformatting scripts, Perltidy can help in tracking down errors with missing or extra braces, parentheses, and square brackets because it is very good at localizing errors.
Perltidy Style Key will help in methodically selecting a set of style parameters.
The Perltidy man page explains how to precisely control the formatting details.
The Perl::Tidy man page discusses how to use the Perl::Tidy module
Perltidy should run on any system with perl 5.008 or later. The total disk space needed after removing the installation directory will be about 4 Mb.
The most recent release is always at CPAN
The most recent release is also at sourceforge
Perl::Tidy can be installed directly from CPAN one of the standard methods.
One way is to download a distribution file, unpack it and then test and install using the Makefile.PL:
perl Makefile.PL
make
make test
make install
The INSTALL file has additional installation notes. They are mainly for older systems but also tell how to use perltidy without doing an installation.
The best place to report bugs and issues is GitHub
Bugs and issues can also be reported at the CPAN site https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy
Perl-Tidy-20250105/docs/ci_update.md 0000644 0001750 0001750 00000027235 14706034401 016040 0 ustar steve steve # An update to the basic Perl::Tidy continuation indentation model Perl::Tidy version 20230701 has several changes in the basic method for computing "continuation indentation". This has been on the TODO list for a long time. The changes mainly apply to some unusual situations, and most programs will remain unchanged. This note explains what the changes are and why they are needed. To briefly review, the indentation of a line is the sum of two parts: (1) **structural indentation**, and (2) **continuation indentation**. These are occasionally called primary and secondary indentation. **Structural indentation** is introduced by opening container tokens **{**, **(**, or **[**. Default structural indentation is 4 characters by default but can be changed with the **-i=n** parameter. The total structural indentation is easily determined by keeping a stack of the opening tokens which contain a given line. **Continuation indentation** is introduced to help show structure in multi-line statements, list items, and logical expressions. The first line of such long lines usually starts with the basic structural indentation. Subsequent lines are given the additional continuation indentation to emphasize that they are a continuation of the statement. The default continuation indentation is 2 characters but this can be changed with the **-ci=n** parameter. Previously, computation of continuation indentation was done in the initial pass through a file, and this placed some limits on what it could do. This computation has been moved downstream in the processing pipeline, where the entire file is accessible with full data structures, and this allows several improvements to be made. These mainly involve (1) the continuation indentation assigned to comments in unusual circumstances, or (2) the indentation of complex ternary expressions, or (3) the indentation of chains of ``sort/map/grep`` blocks. Some examples are as follows. ## Block comment indentation changes before closing braces, brackets and parens The indentation of one-line comments, also called block comments, which appear near the end of a containing structure are now independent of the existence of any optional trailing comma or semicolon. To illustrate the issue, consider the following example, in which the last statement is not terminated with a semicolon. Previously, the subsequent comments would have continuation indentation, since the statement is not terminated: ``` BEGIN { $my_hash{'word1'} = 1; $my_hash{'word2'} = 1 # comment # ... } ``` In the updated version, since the final semicolon is optional, the comments do not have the continuation indentation: ``` BEGIN { $my_hash{'word1'} = 1; $my_hash{'word2'} = 1 # comment # ... } ``` This makes the comments have the same indentation as if there were a terminal semicolon. This update keeps large blocks of comments from shifting when an optional trailing semicolon or comma is added or removed. ## Closing brace indentation changes A related issue which has been fixed is illustrated with the following example which shows the previous formatting: ``` if ( $term->ReadLine eq "Term::ReadLine::Gnu" ) { my $attribs = $term->Attribs; $attribs->{attempted_completion_function} = sub { &CPAN::Complete::gnu_cpl; } # comment # comment } ``` Here again, an optional terminal semicolon is missing after the closing sub brace, and there are some comments before the closing ``if`` block brace. The previous logic had a limited look-ahead ability, and in this case the continuation indentation of the closing sub brace was not removed. The updated logic fixes this problem: ``` if ( $term->ReadLine eq "Term::ReadLine::Gnu" ) { my $attribs = $term->Attribs; $attribs->{attempted_completion_function} = sub { &CPAN::Complete::gnu_cpl; } # comment # comment } ``` ## Block comment indentation changes in ternary statements Another change is that the indentation of block comments within ternary statements is improved. These can be difficult to format. For example, here is the old default formatting of a complex ternary with lots of comments: ``` # a) under an interactive shell? my $rl_avail = ( !$term->isa('CPANPLUS::Shell::_Faked') ) # b) do we have a tty terminal? ? ( -t STDIN ) # c) should we enable the term? ? ( !$self->__is_bad_terminal($term) ) # d) external modules available? ? ( $term->ReadLine ne "Term::ReadLine::Stub" ) # a+b+c+d => "Smart" terminal ? loc("enabled") # a+b+c => "Stub" terminal : loc("available (try 'i Term::ReadLine::Perl')") # a+b => "Bad" terminal : loc("disabled") # a => "Dumb" terminal : loc("suppressed") # none => "Faked" terminal : loc("suppressed in batch mode"); ``` The comment indentation is very poor here. Here is the new formatting: ``` # a) under an interactive shell? my $rl_avail = ( !$term->isa('CPANPLUS::Shell::_Faked') ) # b) do we have a tty terminal? ? ( -t STDIN ) # c) should we enable the term? ? ( !$self->__is_bad_terminal($term) ) # d) external modules available? ? ( $term->ReadLine ne "Term::ReadLine::Stub" ) # a+b+c+d => "Smart" terminal ? loc("enabled") # a+b+c => "Stub" terminal : loc("available (try 'i Term::ReadLine::Perl')") # a+b => "Bad" terminal : loc("disabled") # a => "Dumb" terminal : loc("suppressed") # none => "Faked" terminal : loc("suppressed in batch mode"); ``` ## Improved indentation for some nested welds. An issue has been fixed involving cases where the **--weld-nested**, or **-wn** parameter was used on comma-separated lists of items at block level (paren-less lists). For example, here is the old default formatting with the **-wn** parameter. ``` is_deeply $fixer->fix( { demo => { nl => 'Tuin der lusten', en => 'The Garden of Earthly Delights' } } ), { demo => { NL => 'TUIN DER LUSTEN', en => 'The Garden of Earthly Delights' }, titles => ['The Garden of Earthly Delights'] }, 'specific testing'; ``` The closing '} )' is missing some continuation indentation. The new default formatting is ``` is_deeply $fixer->fix( { demo => { nl => 'Tuin der lusten', en => 'The Garden of Earthly Delights' } } ), { demo => { NL => 'TUIN DER LUSTEN', en => 'The Garden of Earthly Delights' }, titles => ['The Garden of Earthly Delights'] }, 'specific testing'; ``` ## Problems with excess continuation indentation A very rare problem has been fixed in which excess indentation could occur. This is illustrated in the following example which is run with **-ci=4** to emphasize the problem: ``` ( $foo, $dayC[$cnt], $foo ) = split /;/, $slist[ &UnixDate( &ParseDate( $week_name[ $cnt - 1 ] . " week " . $uweek . " " . $this_year ), "%j" ) - 1 ]; ``` The problem is that the lines with leading dots have twice the amount of indentation that they should. The new version fixes this: ``` ( $foo, $dayC[$cnt], $foo ) = split /;/, $slist[ &UnixDate( &ParseDate( $week_name[ $cnt - 1 ] . " week " . $uweek . " " . $this_year ), "%j" ) - 1 ]; ``` Here is another example, also run with **-ci=4** for emphasis: ``` $a ? $b ? $c ? $d ? $e : $f : $g : $h : print "hello\n"; ``` Note how $e and $f have excess indentation. The updated version is: ``` $a ? $b ? $c ? $d ? $e : $f : $g : $h : print "hello\n"; ``` ## Some problems with indentation in ternary expressions The continuation indentation in some complex ternary statements has been improved. For example, in the following old formatting the lines beginning with ``&&`` lack continuation indentation: ``` if ( $file eq '-' ? open(PHONES, '<&STDIN') : $file =~ /\.Z$/ ? open(PHONES, "zcat '$file' 2>/dev/null |") : $file =~ /\.pgp$/ ? $usepgp && length($ENV{PGPPASS}) && open(PHONES, "pgp -fd <'$file' |") : open(PHONES, "< $file\0") ) { } ``` The updated version adds indentation to these lines to help indicate that they are a continuation of the previous line. ``` if ( $file eq '-' ? open(PHONES, '<&STDIN') : $file =~ /\.Z$/ ? open(PHONES, "zcat '$file' 2>/dev/null |") : $file =~ /\.pgp$/ ? $usepgp && length($ENV{PGPPASS}) && open(PHONES, "pgp -fd <'$file' |") : open(PHONES, "< $file\0") ) { } ``` ## Some improved indentation of filter block chains The lines of an isolated chain of ``sort/map/grep`` blocks are normally all given the same indentation. For example ``` @new_in_dir = ( grep { not $seen{$_} } map { $dir . "/" . $_ } grep { not ignore_file($_) } grep { not $skip{$_} } readdir(D) ); ``` Previously, there were a a number of situations where this could not be achieved. As an example, if the above example had side comments then the formatting would be ``` @new_in_dir = ( grep { not $seen{$_} } # files not yet processed map { $dir . "/" . $_ } # map from file to dir/file grep { not ignore_file($_) } # ignore files in cvsignore grep { not $skip{$_} } # skip files to be ignored readdir(D) ); ``` The first line now has a different indentation from the rest, and this is undesirable because ideally indentation should be independent of the existence of side comments. The new version handles this correctly: ``` @new_in_dir = ( grep { not $seen{$_} } # files not yet processed map { $dir . "/" . $_ } # map from file to dir/file grep { not ignore_file($_) } # ignore files in cvsignore grep { not $skip{$_} } # skip files to be ignored readdir(D) ); ``` A related change is that some undesirable alignments across changes in continuation indentation have been removed. For example, here is an example of this issue as previously formatted: ``` print $fh map { $_->[0] } sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] } map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] } @manifest; ``` The alignment of the ``map`` and ``sort`` braces produces an undesirable gap. The revised formatting avoids this: ``` print $fh map { $_->[0] } sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] } map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] } @manifest; ``` Perl-Tidy-20250105/docs/index.md 0000644 0001750 0001750 00000005270 14706034401 015205 0 ustar steve steve # Welcome to Perltidy Perltidy is a Perl script which indents and reformats Perl scripts to make them easier to read. If you write Perl scripts, or spend much time reading them, you will probably find it useful. Perltidy is free software released under the GNU General Public License -- please see the included file [COPYING](../COPYING) for details. The formatting can be controlled with command line parameters. The default parameter settings approximately follow the suggestions in the [Perl Style Guide](https://perldoc.perl.org/perlstyle.html). Besides reformatting scripts, Perltidy can help in tracking down errors with missing or extra braces, parentheses, and square brackets because it is very good at localizing errors. ## Documentation - [A Brief Perltidy Tutorial](./tutorial.html) - [Perltidy Style Key](./stylekey.html) will help in methodically selecting a set of style parameters. - [The Perltidy man page](./perltidy.html) explains how to precisely control the formatting details. - [The Perl::Tidy man page](./Tidy.html) discusses how to use the Perl::Tidy module - [Change Log](./ChangeLog.html) ## Prerequisites Perltidy should run on any system with perl 5.008 or later. The total disk space needed after removing the installation directory will be about 4 Mb. ## Download - The most recent release is always at [CPAN](https://metacpan.org/release/Perl-Tidy) - The most recent release is also at [sourceforge](https://sourceforge.net/projects/perltidy/) ## Installation Perl::Tidy can be installed directly from CPAN one of the standard methods. One way is to download a distribution file, unpack it and then test and install using the Makefile.PL: perl Makefile.PL make make test make install The [INSTALL file](./INSTALL.html) has additional installation notes. They are mainly for older systems but also tell how to use perltidy without doing an installation. ## Links - [Perl::Tidy source code repository at GitHub](https://github.com/perltidy/perltidy) - [tidyall](https://metacpan.org/pod/distribution/Code-TidyAll/bin/tidyall) is a great tool for automatically running perltidy and other tools including perlcritic on a set of project files. - [Tidyview](http://sourceforge.net/projects/tidyview) is a graphical program for tweaking your .perltidyrc configuration parameters. - [A perltidy plugin for Sublime Text 2/3](https://github.com/vifo/SublimePerlTidy) ## FEEDBACK / BUG REPORTS The best place to report bugs and issues is [GitHub](https://github.com/perltidy/perltidy/issues) Bugs and issues can also be reported at the CPAN site [https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy](https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy) Perl-Tidy-20250105/docs/perltidy.html 0000644 0001750 0001750 00001223453 14735777213 016325 0 ustar steve steveperltidy - a perl script indenter and reformatter
perltidy [ options ] file1 file2 file3 ...
(output goes to file1.tdy, file2.tdy, file3.tdy, ...)
perltidy [ options ] file1 -o outfile
perltidy [ options ] file1 -st >outfile
perltidy [ options ] <infile >outfilePerltidy reads a perl script and writes an indented, reformatted script. The formatting process involves converting the script into a string of tokens, removing any non-essential whitespace, and then rewriting the string of tokens with whitespace using whatever rules are specified, or defaults. This happens in a series of operations which can be controlled with the parameters described in this document.
Perltidy is a commandline frontend to the module Perl::Tidy. For documentation describing how to call the Perl::Tidy module from other applications see the separate documentation for Perl::Tidy. It is the file Perl::Tidy.pod in the source distribution.
Many users will find enough information in "EXAMPLES" to get started. New users may benefit from the short tutorial which can be found at http://perltidy.sourceforge.net/tutorial.html
A convenient aid to systematically defining a set of style parameters can be found at http://perltidy.sourceforge.net/stylekey.html
Perltidy can produce output on either of two modes, depending on the existence of an -html flag. Without this flag, the output is passed through a formatter. The default formatting tries to follow the recommendations in perlstyle(1), but it can be controlled in detail with numerous input parameters, which are described in "FORMATTING OPTIONS".
When the -html flag is given, the output is passed through an HTML formatter which is described in "HTML OPTIONS".
Here are some example perltidy commands followed by their meanings:
perltidy somefile.plThis will produce a file somefile.pl.tdy containing the script reformatted using the default options, which approximate the style suggested in perlstyle(1). The source file somefile.pl is unchanged.
perltidy *.plExecute perltidy on all .pl files in the current directory with the default options. The output will be in files with an appended .tdy extension. For any file with an error, there will be a file with extension .ERR.
perltidy -b file1.pl file2.plModify file1.pl and file2.pl in place, and backup the originals to file1.pl.bak and file2.pl.bak. If file1.pl.bak and/or file2.pl.bak already exist, they will be overwritten.
perltidy -b -bext='/' file1.pl file2.plSame as the previous example except that the backup files file1.pl.bak and file2.pl.bak will be deleted if there are no errors.
perltidy -gnu somefile.plExecute perltidy on file somefile.pl with a style which approximates the GNU Coding Standards for C programs. The output will be somefile.pl.tdy.
perltidy -i=3 somefile.plExecute perltidy on file somefile.pl, with 3 columns for each level of indentation (-i=3) instead of the default 4 columns. There will not be any tabs in the reformatted script, except for any which already exist in comments, pod documents, quotes, and here documents. Output will be somefile.pl.tdy.
perltidy -i=3 -et=8 somefile.plSame as the previous example, except that leading whitespace will be entabbed with one tab character per 8 spaces.
perltidy -ce -l=72 somefile.plExecute perltidy on file somefile.pl with all defaults except use "cuddled elses" (-ce) and a maximum line length of 72 columns (-l=72) instead of the default 80 columns.
perltidy -g somefile.plExecute perltidy on file somefile.pl and save a log file somefile.pl.LOG which shows the nesting of braces, parentheses, and square brackets at the start of every line.
perltidy -dbs -dbl=10 somefile.pl >blocks.csvThis will dump a table of comma-separated metrics for subroutines longer than 10 lines to blocks.csv.
perltidy -duv somefile.pl >vars.txtThis will dump a list of unused and reused lexical variable names to vars.txt.
perltidy -html somefile.plThis will produce a file somefile.pl.html containing the script with html markup. The output file will contain an embedded style sheet in the <HEAD> section which may be edited to change the appearance.
perltidy -html -css=mystyle.css somefile.plThis will produce a file somefile.pl.html containing the script with html markup. This output file will contain a link to a separate style sheet file mystyle.css. If the file mystyle.css does not exist, it will be created. If it exists, it will not be overwritten.
perltidy -html -pre somefile.plWrite an html snippet with only the <PRE> section to somefile.pl.html. This is useful when code snippets are being formatted for inclusion in a larger web page. No style sheet will be written in this case.
perltidy -html -ss >mystyle.cssWrite a style sheet to mystyle.css and exit.
perltidy -html -frm mymodule.pmWrite html with a frame holding a table of contents and the source code. The output files will be mymodule.pm.html (the frame), mymodule.pm.toc.html (the table of contents), and mymodule.pm.src.html (the source code).
The entire command line is scanned for options, and they are processed before any files are processed. As a result, it does not matter whether flags are before or after any filenames. However, the relative order of parameters is important, with later parameters overriding the values of earlier parameters.
For each parameter, there is a long name and a short name. The short names are convenient for keyboard input, while the long names are self-documenting and therefore useful in scripts. It is customary to use two leading dashes for long names, but one may be used.
Most parameters which serve as on/off flags can be negated with a leading "n" (for the short name) or a leading "no" or "no-" (for the long name). For example, the flag to outdent long quotes is -olq or --outdent-long-quotes. The flag to skip this is -nolq or --nooutdent-long-quotes or --no-outdent-long-quotes.
Options may not be bundled together. In other words, options -q and -g may NOT be entered as -qg.
Option names may be terminated early as long as they are uniquely identified. For example, instead of --dump-token-types, it would be sufficient to enter --dump-tok, or even --dump-t, to uniquely identify this command.
The following parameters concern the files which are read and written.
Show summary of usage and exit.
Show perltidy VERSION number and exit.
Name of the output file (only if a single input file is being processed). If no output file is specified, and output is not redirected to the standard output (see -st), the output will go to filename.tdy. [Note: - does not redirect to standard output. Use -st instead.]
Perltidy must be able to operate on an arbitrarily large number of files in a single run, with each output being directed to a different output file. Obviously this would conflict with outputting to the single standard output device, so a special flag, -st, is required to request outputting to the standard output. For example,
perltidy somefile.pl -st >somefile.new.plThis option may only be used if there is just a single input file. The default is -nst or --nostandard-output.
If perltidy detects an error when processing file somefile.pl, its default behavior is to write error messages to file somefile.pl.ERR. Use -se to cause all error messages to be sent to the standard error output stream instead. This directive may be negated with -nse. Thus, you may place -se in a .perltidyrc and override it when desired with -nse on the command line.
Change the extension of the output file to be ext instead of the default tdy (or html in case the --html option is used). See "Specifying File Extensions".
When perltidy creates a filename for an output file, by default it merely appends an extension to the path and basename of the input file. This parameter causes the path to be changed to path instead.
The path should end in a valid path separator character, but perltidy will try to add one if it is missing.
For example
perltidy somefile.pl -opath=/tmp/will produce /tmp/somefile.pl.tdy. Otherwise, somefile.pl.tdy will appear in whatever directory contains somefile.pl.
If the path contains spaces, it should be placed in quotes.
This parameter will be ignored if output is being directed to standard output, or if it is being specified explicitly with the --outfile=s parameter.
Modify the input file or files in-place and save the original with the extension .bak. Any existing .bak file will be deleted. See next item for changing the default backup extension, and for eliminating the backup file altogether.
Please Note: Writing back to the input file increases the risk of data loss or corruption in the event of a software or hardware malfunction. Before using the -b parameter please be sure to have backups and verify that it works correctly in your environment and operating system.
A -b flag will be ignored if input is from standard input or goes to standard output, or if the -html flag is set.
In particular, if you want to use both the -b flag and the --perl-best-practices (-pbp) flag, then you must put a --nostandard-output (-nst) flag after the -pbp flag because it contains a --standard-output flag as one of its components, which means that output will go to the standard output stream.
This parameter serves two purposes: (1) to change the extension of the backup file to be something other than the default .bak, and (2) to indicate that no backup file should be saved.
To change the default extension to something other than .bak see "Specifying File Extensions".
A backup file of the source is always written, but you can request that it be deleted at the end of processing if there were no errors. This is risky unless the source code is being maintained with a source code control system.
To indicate that the backup should be deleted include one forward slash, /, in the extension. If any text remains after the slash is removed it will be used to define the backup file extension (which is always created and only deleted if there were no errors).
Here are some examples:
Parameter Extension Backup File Treatment
-bext=bak .bak Keep (same as default behavior)
-bext='/' .bak Delete if no errors
-bext='/backup' .backup Delete if no errors
-bext='original/' .original Delete if no errorsThis parameter should not normally be used but is available in the event that problems arise as a transition is made from an older implementation of the backup logic to a newer implementation. The newer implementation is the default and is specified with -bm='copy'. The older implementation is specified with -bm='move'. The difference is that the older implementation made the backup by moving the input file to the backup file, and the newer implementation makes the backup by copying the input file. The newer implementation preserves the file system inode value. This may avoid problems with other software running simultaneously. This change was made as part of issue git #103 at github.
Setting -w causes any non-critical warning messages to be reported as errors. These include messages about possible pod problems, possibly bad starting indentation level, and cautions about indirect object usage. The default, -nw or --nowarning-output, is not to include these warnings.
Deactivate error messages (for running under an editor).
For example, if you use a vi-style editor, such as vim, you may execute perltidy as a filter from within the editor using something like
:n1,n2!perltidy -qwhere n1,n2 represents the selected text. Without the -q flag, any error message may mess up your screen, so be prepared to use your "undo" key.
Save the .LOG file, which has many useful diagnostics. Perltidy always creates a .LOG file, but by default it is deleted unless a program bug is suspected. Setting the -log flag forces the log file to be saved.
Set maximum interval between input code lines in the logfile. This purpose of this flag is to assist in debugging nesting errors. The value of n is optional. If you set the flag -g without the value of n, it will be taken to be 1, meaning that every line will be written to the log file. This can be helpful if you are looking for a brace, paren, or bracket nesting error.
Setting -g also causes the logfile to be saved, so it is not necessary to also include -log.
If no -g flag is given, a value of 50 will be used, meaning that at least every 50th line will be recorded in the logfile. This helps prevent excessively long log files.
Setting a negative value of n is the same as not setting -g at all.
Ignore any .perltidyrc command file. Normally, perltidy looks first in your current directory for a .perltidyrc file of parameters. (The format is described below). If it finds one, it applies those options to the initial default values, and then it applies any that have been defined on the command line. If no .perltidyrc file is found, it looks for one in your home directory.
If you set the -npro flag, perltidy will not look for this file.
To simplify testing and switching .perltidyrc files, this command may be used to specify a configuration file which will override the default name of .perltidyrc. There must not be a space on either side of the '=' sign. For example, the line
perltidy -pro=testcfgwould cause file testcfg to be used instead of the default .perltidyrc.
A pathname begins with three dots, e.g. ".../.perltidyrc", indicates that the file should be searched for starting in the current directory and working upwards. This makes it easier to have multiple projects each with their own .perltidyrc in their root directories.
Write a list of all options used to the .LOG file. Please see --dump-options for a simpler way to do this.
Force perltidy to process binary files. To avoid producing excessive error messages, perltidy skips files identified by the system as non-text. However, valid perl scripts containing binary data may sometimes be identified as non-text, and this flag forces perltidy to process them.
This flag asserts that the input and output code streams are identical, or in other words that the input code is already 'tidy' according to the formatting parameters. If this is not the case, an error message noting this is produced. This error message will cause the process to return a non-zero exit code. The test for this is made by comparing an MD5 hash value for the input and output code streams. This flag has no other effect on the functioning of perltidy. This might be useful for certain code maintenance operations. Note: you will not see this message if you have error messages turned off with the -quiet flag.
This flag asserts that the input and output code streams are different, or in other words that the input code is 'untidy' according to the formatting parameters. If this is not the case, an error message noting this is produced. This flag has no other effect on the functioning of perltidy.
When the standard input supplies the input stream, and the input has not been received within n seconds, perltidy will end with a timeout message. The intention is to catch a situation where perltidy is accidentally invoked without a file to process and therefore waits for input from the system standard input (stdin), which never arrives. The default is n=10 seconds. This check can be turned off with n=0.
If --format=tidy (the default) then perltidy will reformat the input file, and if --format=html then perltidy will produce html output.
For convenience, the abbreviation --tidy is equivalent to --format=tidy, and -html is equivalent to --format=html.
This flag disables all formatting and causes the input to be copied unchanged to the output except for possible changes in line ending characters and any pre- and post-filters. This can be useful in conjunction with a hierarchical set of .perltidyrc files to avoid unwanted code tidying. See also "Skipping Selected Sections of Code" for a way to avoid tidying specific sections of code.
Use n columns per indentation level (default n=4).
The default maximum line length is n=80 characters. Perltidy will try to find line break points to keep lines below this length. However, long quotes and side comments may cause lines to exceed this length. And long lines may sometimes be broken at a length less than n characters because some of the line break decisions employ small tolerances to prevent formatting instabilities.
The default length of 80 comes from the past when this was the standard CRT screen width. Many programmers prefer to increase this to something like 120.
Setting -l=0 is equivalent to setting -l=(a very large number). But this is not recommended because, for example, a very long list will be formatted in a single long line.
A problem arises using a fixed maximum line length with very deeply nested code and data structures because eventually the amount of leading whitespace used for indicating indentation takes up most or all of the available line width, leaving little or no space for the actual code or data. One solution is to use a very long line length. Another solution is to use the -vmll flag, which basically tells perltidy to ignore leading whitespace when measuring the line length.
To be precise, when the -vmll parameter is set, the maximum line length of a line of code will be M+L*I, where
M is the value of --maximum-line-length=M (-l=M), default 80,
I is the value of --indent-columns=I (-i=I), default 4,
L is the indentation level of the line of codeWhen this flag is set, the choice of breakpoints for a block of code should be essentially independent of its nesting depth. However, the absolute line lengths, including leading whitespace, can still be arbitrarily large. This problem can be avoided by including the next parameter.
The default is not to do this (-nvmll).
This flag also addresses problems with very deeply nested code and data structures. When the nesting depth exceeds the value n the leading whitespace will be reduced and start at a depth of 1 again. The result is that blocks of code will shift back to the left rather than moving arbitrarily far to the right. This occurs cyclically to any depth.
For example if one level of indentation equals 4 spaces (-i=4, the default), and one uses -wc=15, then if the leading whitespace on a line exceeds about 4*15=60 spaces it will be reduced back to 4*1=4 spaces and continue increasing from there. If the whitespace never exceeds this limit the formatting remains unchanged.
The combination of --variable-maximum-line-length and --whitespace-cycle=n provides a solution to the problem of displaying arbitrarily deep data structures and code in a finite window, although --whitespace-cycle=n may of course be used without --variable-maximum-line-length.
The default is not to use this, which can also be indicated using -wc=0.
Using tab characters will almost certainly lead to future portability and maintenance problems, so the default and recommendation is not to use them. For those who prefer tabs, however, there are two different options.
Except for possibly introducing tab indentation characters, as outlined below, perltidy does not introduce any tab characters into your file, and it removes any tabs from the code (unless requested not to do so with --freeze-whitespace). If you have any tabs in your comments, quotes, or here-documents, they will remain.
This flag causes each n leading space characters produced by the formatting process to be replaced by one tab character. The formatting process itself works with space characters. The -et=n parameter is applied as a last step, after formatting is complete, to convert leading spaces into tabs. Before starting to use tabs, it is essential to first get the indentation controls set as desired without tabs, particularly the two parameters --indent-columns=n (or -i=n) and --continuation-indentation=n (or -ci=n).
The value of the integer n can be any value but can be coordinated with the number of spaces used for indentation. For example, -et=4 -ci=4 -i=4 will produce one tab for each indentation level and and one for each continuation indentation level. You may want to coordinate the value of n with what your display software assumes for the spacing of a tab.
The default is not to use this, which can also be indicated using -et=0.
This flag causes one leading tab character to be inserted for each level of indentation. Certain other features are incompatible with this option, and if these options are also given, then a warning message will be issued and this flag will be unset. One example is the --line-up-parentheses option. This flag is retained for backwards compatibility, but if you use tabs, the --entab-leading-whitespace=n flag is recommended. If both --tabs and --entab-leading-whitespace=n are set, then --entab-leading-whitespace=n is used.
If the first line of code passed to perltidy contains leading tabs but no tab scheme is specified for the output stream then perltidy must guess how many spaces correspond to each leading tab. This number of spaces n corresponding to each leading tab of the input stream may be specified with -dt=n. The default is n=8.
This flag has no effect if a tab scheme is specified for the output stream, because then the input stream is assumed to use the same tab scheme and indentation spaces as for the output stream (any other assumption would lead to unstable editing).
This flag is used to deactivate all whitespace and line break changes within non-blank lines of code. When it is in effect, the only change to the script will be to the indentation and to the number of blank lines. And any flags controlling whitespace and newlines will be ignored. You might want to use this if you are perfectly happy with your whitespace and line breaks, and merely want perltidy to handle the indentation. (This also speeds up perltidy by well over a factor of two, so it might be useful when perltidy is merely being used to help find a brace error in a large script).
Setting this flag is equivalent to setting --freeze-newlines and --freeze-whitespace.
If you also want to keep your existing blank lines exactly as they are, you can add --freeze-blank-lines.
With this option perltidy is still free to modify the indenting (and outdenting) of code and comments as it normally would. If you also want to prevent long comment lines from being outdented, you can add either --nooutdent-long-lines (-noll) or --maximum-line-length=0 (l=0).
Setting this flag will prevent perltidy from doing any special operations on closing side comments. You may still delete all side comments however when this flag is in effect.
This flag indicates if the input data stream uses a character encoding. Perltidy does not look for the encoding directives in the source stream, such as use utf8, and instead relies on this flag to determine the encoding. (This is because perltidy often works on snippets of code rather than complete files, so it cannot rely on use utf8 directives). Consequently perltidy is likely to encounter problems formatting a file which is only partially encoded.
The possible values for s are:
-enc=none if no encoding is used, or
-enc=utf8 for encoding in utf8
-enc=guess if perltidy should guess between these two possibilities.The value none causes the stream to be processed without special encoding assumptions. This is appropriate for files which are written in single-byte character encodings such as latin-1.
The value utf8 causes the stream to be read and written as UTF-8. If the input stream cannot be decoded with this encoding then processing is not done.
The value guess tells perltidy to guess between either utf8 encoding or no encoding (meaning one character per byte). The guess option uses the Encode::Guess module which has been found to be reliable at detecting if a file is encoded in utf8 or not.
The current default is guess.
The abbreviations -utf8 or -UTF8 are equivalent to -enc=utf8, and the abbreviation -guess is equivalent to -enc=guess. So to process a file named file.pl which is encoded in UTF-8 you can use:
perltidy -utf8 file.plor
perltidy -guess file.plor simply
perltidy file.plsince -guess is the default.
To process files with an encoding other than UTF-8, it would be necessary to write a short program which calls the Perl::Tidy module with some pre- and post-processing to handle decoding and encoding.
This flag was added to resolve an issue involving the interface between Perl::Tidy and calling programs, and in particular Code::TidyAll (tidyall).
If you only run the perltidy binary this flag has no effect. If you run a program which calls the Perl::Tidy module and receives a string in return, then the meaning of the flag is as follows:
The setting -eos means Perl::Tidy should encode any string which it decodes. This is the default because it makes perltidy behave well as a filter, and is the correct setting for most programs.
The setting -neos means that a string should remain decoded if it was decoded by Perl::Tidy. This is only appropriate if the calling program will handle any needed encoding before outputting the string.
The default was changed from -neos to -eos in versions after 20220217. If this change causes a program to start running incorrectly on encoded files, an emergency fix might be to set -neos. Additional information can be found in the man pages for the Perl::Tidy module and also in https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md.
This flag controls whether or not perltidy may use module Unicode::GCString to obtain accurate display widths of wide characters. The default is --nouse-unicode-gcstring.
If this flag is set, and text is encoded, perltidy will look for the module Unicode::GCString and, if found, will use it to obtain character display widths. This can improve displayed vertical alignment for files with wide characters. It is a nice feature but it is off by default to avoid conflicting formatting when there are multiple developers. Perltidy installation does not require Unicode::GCString, so users wanting to use this feature need set this flag and also to install Unicode::GCString separately.
If this flag is set and perltidy does not find module Unicode::GCString, a warning message will be produced and processing will continue but without the potential benefit provided by the module.
Also note that actual vertical alignment depends upon the fonts used by the text display software, so vertical alignment may not be optimal even when Unicode::GCString is used.
where s=win, dos, unix, or mac. This flag tells perltidy to output line endings for a specific system. Normally, perltidy writes files with the line separator character of the host system. The win and dos flags have an identical result.
This flag tells perltidy to write its output files with the same line endings as the input file, if possible. It should work for dos, unix, and mac line endings. It will only work if perltidy input comes from a filename (rather than stdin, for example). If perltidy has trouble determining the input file line ending, it will revert to the default behavior of using the line ending of the host system.
This flag, which is enabled by default, allows perltidy to terminate the last line of the output stream with a newline character, regardless of whether or not the input stream was terminated with a newline character. If this flag is negated, with -natnl, then perltidy will add a terminal newline to the the output stream only if the input stream is terminated with a newline.
Negating this flag may be useful for manipulating one-line scripts intended for use on a command line.
This flag causes perltidy to do n complete iterations. The reason for this flag is that code formatting is an iterative process and in some cases the output from perltidy can be different if it is applied a second time. For most purposes the default of n=1 should be satisfactory. However n=2 can be useful when a major style change is being made, or when code is being beautified on check-in to a source code control system. It has been found to be extremely rare for the output to change after 2 iterations. If a value n is greater than 2 is input then a convergence test will be used to stop the iterations as soon as possible, almost always after 2 iterations. See the next item for a simplified iteration control.
This flag has no effect when perltidy is used to generate html.
This flag is equivalent to -it=4 and is included to simplify iteration control. Perltidy will check for convergence and stop iterating as soon as possible. The default is -nconv (no convergence check). Using -conv will approximately double run time since typically one extra iteration is required to verify convergence. No extra iterations are required if no new line breaks are made, and two extra iterations are occasionally needed when reformatting complex code structures, such as deeply nested ternary statements.
Continuation indentation is extra indentation spaces applied when a long line is broken. The default is n=2, illustrated here:
my $level = # -ci=2
( $max_index_to_go >= 0 ) ? $levels_to_go[0] : $last_output_level;The same example, with n=0, is a little harder to read:
my $level = # -ci=0
( $max_index_to_go >= 0 ) ? $levels_to_go[0] : $last_output_level;The value given to -ci is also used by some commands when a small space is required. Examples are commands for outdenting labels, --outdent-labels (-ola), and control keywords, --outdent-keywords (-okw).
When default values are not used, it is recommended that either
(1) the value n given with -ci=n be no more than about one-half of the number of spaces assigned to a full indentation level on the -i=n command, or
(2) the flag --extended-continuation-indentation is used (see next section).
This flag allows perltidy to use some improvements which have been made to its indentation model. One of the things it does is "extend" continuation indentation deeper into structures, hence the name. The improved indentation is particularly noticeable when the flags -ci=n and -i=n use the same value of n. There are no significant disadvantages to using this flag, but to avoid disturbing existing formatting the default is not to use it, -nxci.
Please see the section "-pbp, --perl-best-practices" for an example of how this flag can improve the formatting of ternary statements. It can also improve indentation of some multiline qw lists as shown below.
# perltidy
foreach $color (
qw(
AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3
),
qw(
LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2
SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4
)
)
# perltidy -xci
foreach $color (
qw(
AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3
),
qw(
LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2
SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4
)
)This flag allows perltidy to remove continuation indentation in some special cases where it is not really unnecessary. For a simple example, the default formatting for the following snippet is:
# perltidy -nmci
$self->blurt( "Error: No INPUT for type '$type', typekind '"
. $type->xstype
. "' found" );The second and third lines are one level deep in a container, and are also statement continuations, so they get indented by the sum of the full indentation -i value and the continuation indentation -ci value. If this flag is set, the indentation is reduced by -ci spaces, giving
# perltidy -mci
$self->blurt( "Error: No INPUT for type '$type', typekind '"
. $type->xstype
. "' found" );This flag is off by default.
By default, perltidy examines the input file and tries to determine the starting indentation level. While it is often zero, it may not be zero for a code snippet being sent from an editing session.
To guess the starting indentation level perltidy simply assumes that indentation scheme used to create the code snippet is the same as is being used for the current perltidy process. This is the only sensible guess that can be made. It should be correct if this is true, but otherwise it probably won't. For example, if the input script was written with -i=2 and the current perltidy flags have -i=4, the wrong initial indentation will be guessed for a code snippet which has non-zero initial indentation. Likewise, if an entabbing scheme is used in the input script and not in the current process then the guessed indentation will be wrong.
If the default method does not work correctly, or you want to change the starting level, use -sil=n, to force the starting level to be n.
These flags provide an alternative indentation method for list data. The original flag for this is -lp, but it has some limitations (explained below) which are avoided with the newer -xlp flag. So -xlp is probably the better choice for new work, but the -lp flag is retained to minimize changes to existing formatting. If you enter both -lp and -xlp, then -xlp will be used.
In the default indentation method perltidy indents lists with 4 spaces, or whatever value is specified with -i=n. Here is a small list formatted in this way:
# perltidy (default)
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);The -lp or -xlp flags add extra indentation to cause the data to begin past the opening parentheses of a sub call or list, or opening square bracket of an anonymous array, or opening curly brace of an anonymous hash. With this option, the above list would become:
# perltidy -lp or -xlp
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);If the available line length (see -l=n ) does not permit this much space, perltidy will use less. For alternate placement of the closing paren, see the next section.
These flags have no effect on code BLOCKS, such as if/then/else blocks, which always use whatever is specified with -i=n.
Some limitations on these flags are:
A limitation on -lp, but not -xlp, occurs in situations where perltidy does not have complete freedom to choose line breaks. Then it may temporarily revert to its default indentation method. This can occur for example if there are blank lines, block comments, multiline quotes, or side comments between the opening and closing parens, braces, or brackets. It will also occur if a multiline anonymous sub occurs within a container since that will impose specific line breaks (such as line breaks after statements).
For both the -lp and -xlp flags, any parameter which significantly restricts the ability of perltidy to choose newlines will conflict with these flags and will cause them to be deactivated. These include --indent-only, --freeze-newlines, --noadd-newlines, and --nodelete-old-newlines.
The -lp and -xlp options may not be used together with the -t tabs option. They may, however, be used with the -et=n tab method
There are some potential disadvantages of this indentation method compared to the default method that should be noted:
The available line length can quickly be used up if variable names are long. This can cause deeply nested code to quickly reach the line length limit, and become badly formatted, much sooner than would occur with the default indentation method.
Since the indentation depends on the lengths of variable names, small changes in variable names can cause changes in indentation over many lines in a file. This means that minor name changes can produce significant file differences. This can be annoying and does not occur with the default indentation method.
Some things that can be done to minimize these problems are:
Increase --maximum-line-length=n above the default n=80 characters if necessary.
If you use -xlp then long side comments can limit the indentation over multiple lines. Consider adding the flag --ignore-side-comment-lengths to prevent this, or minimizing the use of side comments.
Apply this style in a limited way. By default, it applies to all list containers (not just lists in parentheses). The next section describes how to limit this style to, for example, just function calls. The default indentation method will be applied elsewhere.
The following discussion is written for -lp but applies equally to the newer -xlp version. By default, the -lp flag applies to as many containers as possible. The set of containers to which the -lp style applies can be reduced by either one of these two flags:
Use --line-up-parentheses-inclusion-list=s (-lpil=s) to specify the containers to which -lp applies, or
use --line-up-parentheses-exclusion-list=s (-lpxl=s) to specify the containers to which -lp does NOT apply.
Only one of these two flags may be used. Both flags can achieve the same result, but the -lpil=s flag is much easier to describe and use and is recommended. The -lpxl=s flag was the original implementation and is only retained for backwards compatibility.
This list s for these parameters is a string with space-separated items. Each item consists of up to three pieces of information in this order: (1) an optional letter code (2) a required container type, and (3) an optional numeric code.
The only required piece of information is a container type, which is one of '(', '[', or '{'. For example the string
-lpil='('means use -lp formatting only on lists within parentheses, not lists in square-brackets or braces. The same thing could alternatively be specified with
-lpxl = '[ {'which says to exclude lists within square-brackets and braces. So what remains is lists within parentheses.
A second optional item of information which can be given for parentheses is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the paren. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings for matching whatever precedes an opening paren:
'k' matches if the previous nonblank token is a perl keyword
(such as 'if', 'while'),
'K' matches if 'k' does not: previous token is not a keyword
'f' matches if previous token is a function (not a keyword)
'F' matches if 'f' does not.
'w' matches if either 'k' or 'f' match.
'W' matches if 'w' does not.For example:
-lpil = 'f('means only apply -lp to function calls, and
-lpil = 'w('means only apply -lp to parenthesized lists which follow a function or a keyword.
This last example could alternatively be written using the -lpxl=s flag as
-lpxl = '[ { W('which says exclude -lp for lists within square-brackets, braces, and parens NOT preceded by a keyword or function. Clearly, the -lpil=s method is easier to understand.
An optional numeric code may follow any of the container types to further refine the selection based on container contents. The numeric codes are:
'0' or blank: no restriction is placed on container contents
'1' the container contents must be a simple list without sublists
'2' the container contents must be a simple list without sublists,
without code blocks, and without ternary operatorsFor example,
-lpil = 'f(2'means only apply -lp to function calls with simple lists (not containing any sublists, code blocks or ternary expressions).
The -cti=n flag controls the indentation of a line beginning with a ), ], or a non-block }. Such a line receives:
-cti = 0 no extra indentation (default)
-cti = 1 extra indentation such that the closing token
aligns with its opening token.
-cti = 2 one extra indentation level if the line looks like:
); or ]; or };
-cti = 3 one extra indentation level alwaysThe flags -cti=1 and -cti=2 work well with the --line-up-parentheses (-lp) flag (previous section).
# perltidy -lp -cti=1
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);
# perltidy -lp -cti=2
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);These flags are merely hints to the formatter and they may not always be followed. In particular, if -lp is not being used, the indentation for cti=1 is constrained to be no more than one indentation level.
If desired, this control can be applied independently to each of the closing container token types. In fact, -cti=n is merely an abbreviation for -cpi=n -csbi=n -cbi=n, where: -cpi or --closing-paren-indentation controls )'s, -csbi or --closing-square-bracket-indentation controls ]'s, -cbi or --closing-brace-indentation controls non-block }'s.
The -icp flag is equivalent to -cti=2, described in the previous section. The -nicp flag is equivalent -cti=0. They are included for backwards compatibility.
The -icb option gives one extra level of indentation to a brace which terminates a code block . For example,
if ($task) {
yyy();
} # -icb
else {
zzz();
}The default is not to do this, indicated by -nicb.
A line which begins with a leading semicolon will, by default, have the extra number of indentation spaces defined by --continuation-indentation=n. This extra indentation can be removed by setting -nils.
# default
$z = sqrt( $x**2 + $y**2 )
; # <-- indented by ci spaces
# -nils
$z = sqrt( $x**2 + $y**2 )
; # <-- not indented by ci spacesNote that leading semicolons do not normally occur unless requested with --break-at-old-semicolon-breakpoints or forced, for example by a blank line as in this example.
Normally, lines of code contained within a pair of block braces receive one additional level of indentation. This flag, which is enabled by default, causes perltidy to look for opening block braces which are followed by a special side comment. This special side comment is #<<< by default. If found, the code between this opening brace and its corresponding closing brace will not be given the normal extra indentation level. For example:
{ #<<< a closure to contain lexical vars
my $var; # this line does not get one level of indentation
...
}
# this line does not 'see' $var;This can be useful, for example, when combining code from different files. Different sections of code can be placed within braces to keep their lexical variables from being visible to the end of the file. To keep the new braces from causing all of their contained code to be indented if you run perltidy, and possibly introducing new line breaks in long lines, you can mark the opening braces with this special side comment.
Only the opening brace needs to be marked, since perltidy knows where the closing brace is. Braces contained within marked braces may also be marked as non-indenting.
If your code happens to have some opening braces followed by '#<<<', and you don't want this behavior, you can use -nnib to deactivate it. To make it easy to remember, the default string is the same as the string for starting a format-skipping section. There is no confusion because in that case it is for a block comment rather than a side-comment.
The special side comment can be changed with the next parameter.
The -nibp=string parameter may be used to change the marker for non-indenting braces. The default is equivalent to -nibp='#<<<'. The string that you enter must begin with a # and should be in quotes as necessary to get past the command shell of your system. This string is the leading text of a regex pattern that is constructed by prepending a '^' and appending a'\s', so you must also include backslashes for characters to be taken literally rather than as patterns.
For example, to match the side comment '#++', the parameter would be
-nibp='#\+\+'When -olq is set, lines which is a quoted string longer than the value maximum-line-length will have their indentation removed to make them more readable. This is the default. To prevent such out-denting, use -nolq.
This command is equivalent to the combination --outdent-long-quotes and --outdent-long-comments, and it is included for compatibility with previous versions of perltidy. The negation of this also works, -noll or --nooutdent-long-lines, and is equivalent to setting -nolq and -nolc.
This command will cause labels to be outdented by the number of spaces defined by --continuation-indentation=n, if possible. This is the default. For example:
my $i;
LOOP: while ( $i = <FOTOS> ) {
chomp($i);
next unless $i;
fixit($i);
}Use -nola to prevent this. To control line breaks after labels see "-bal=n, --break-after-labels=n".
The command -okw will cause certain leading control keywords to be outdented by the number of spaces defined by --continuation-indentation=nspaces, if possible. By default, these keywords are redo, next, last, goto, and return. The intention is to make these control keywords easier to see. To change this list of keywords being outdented, see the next section.
For example, using perltidy -okw on the previous example gives:
my $i;
LOOP: while ( $i = <FOTOS> ) {
chomp($i);
next unless $i;
fixit($i);
}Notice that the keyword next has been outdented. The default is not to do this.
This command can be used to change the keywords which are outdented with the -okw command. The parameter string is a required list of perl keywords, which should be placed in quotes if there are more than one. By itself, it does not cause any outdenting to occur, so the -okw command is still required.
For example, the commands -okwl="next last redo goto" -okw will cause those four keywords to be outdented.
Whitespace refers to the blank space between variables, operators, and other code tokens.
This flag causes your original whitespace to remain unchanged, and causes the rest of the whitespace commands in this section, the Code Indentation section, and the Comment Control section to be ignored.
Here the term "tightness" will mean the closeness with which pairs of enclosing tokens, such as parentheses, contain the quantities within. A numerical value of 0, 1, or 2 defines the tightness, with 0 being least tight and 2 being most tight. Spaces within containers are always symmetric, so if there is a space after a ( then there will be a space before the corresponding ).
The -pt=n or --paren-tightness=n parameter controls the space within parens. The example below shows the effect of the three possible values, 0, 1, and 2:
if ( ( my $len_tab = length( $tabstr ) ) > 0 ) { # -pt=0
if ( ( my $len_tab = length($tabstr) ) > 0 ) { # -pt=1 (default)
if ((my $len_tab = length($tabstr)) > 0) { # -pt=2When n is 0, there is always a space to the right of a '(' and to the left of a ')'. For n=2 there is never a space. For n=1, the default, there is a space unless the quantity within the parens is a single token, such as an identifier or quoted string.
Likewise, the parameter -sbt=n or --square-bracket-tightness=n controls the space within square brackets, as illustrated below.
$width = $col[ $j + $k ] - $col[ $j ]; # -sbt=0
$width = $col[ $j + $k ] - $col[$j]; # -sbt=1 (default)
$width = $col[$j + $k] - $col[$j]; # -sbt=2Curly braces which do not contain code blocks are controlled by the parameter -bt=n or --brace-tightness=n.
$obj->{ $parsed_sql->{ 'table' }[0] }; # -bt=0
$obj->{ $parsed_sql->{'table'}[0] }; # -bt=1 (default)
$obj->{$parsed_sql->{'table'}[0]}; # -bt=2And finally, curly braces which contain blocks of code are controlled by the parameter -bbt=n or --block-brace-tightness=n as illustrated in the example below (-bbt=0 is the default).
%bf = map { $_ => -M $_ } grep { /\.deb$/ } dirents '.'; # -bbt=0
%bf = map { $_ => -M $_ } grep {/\.deb$/} dirents '.'; # -bbt=1
%bf = map {$_ => -M $_} grep {/\.deb$/} dirents '.'; # -bbt=2To simplify input in the case that all of the tightness flags have the same value n, the parameter -act=n or --all-containers-tightness=n is an abbreviation for the combination -pt=n -sbt=n -bt=n -bbt=n.
To review, the tightness controls described in the previous section have three possible integer values: 0, 1, and 2, where n=0 always adds a space, and n=2 never adds a space.
The default value n=1 adds space only if the container holds multiple tokens. Some perltidy tokens may be rather long, and it can be preferable to space some of them as if they were multple tokens. This can be done with this paramter.
For example, in the following expression the qw list is a single token and therefore there the default formatting does not put spaces within the square brackets:
my $rlist = [qw(alpha beta gamma)];This can be changed with
# perltidy -mutt='qw'
my $rlist = [ qw(alpha beta gamma) ];This tells perltidy to space a qwlist as if it were multiple tokens when the default tightness is used.
The parameter s may contain any of the following perl operators:
qw q qq qx qr s y tr mOther possible specifications are
q* - all of the above operators
Q - all of the above plus any quoted text
h - a here-doc target, such as '<<EOT'
<<>> - the double-diamond operatorA symbol may be negated by preceding it with a carat ^ symbol. The double-diamond operator is always included unless negated in this way.
There are two controls for spacing within curly braces, namely --block-brace-tightness=n for code block braces and --brace-tightness=n for all other braces.
There is a little fuzziness in this division of brace types though because the curly braces considered by perltidy to contain code blocks for formatting purposes, such as highlighting code structure, exclude some of the small code blocks used by Perl mainly for isolating terms. These include curly braces following a keyword where an indirect object might occur, or curly braces following a type symbol. For example, perltidy does not mark the following braces as code block braces:
print {*STDERR} $message;
return ${$foo};Consequently, the spacing within these small braced containers by default follows the flag --brace-tightness=n rather than --block-brace-tightness=n, as one might expect.
If desired, small blocks such as these can be made to instead follow the spacing defined by the --block-brace-tightness=n flag by setting --extended-block-tightness. The specific types of small blocks to which this parameter applies is controlled by a companion control parameter, described in the next section.
Note that if the two flags --block-brace-tightness=n and --brace-tightness=n have the same value n then there would be no reason to set this flag.
The previous parameter --extended-block-tightness (-xbt) can be made to apply to curly braces preceded by any of the keywords
print printf exec system sayand/or the special symbols
$ @ % & * $#The parameter string s may contain a selection of these keywords and symbols to indicate the brace types to which --extended-block-tightness applies. For convenience, all of the keywords can be selected with 'k', and all of the special symbols can be selected with 't'. The default is equivalent to -xbtl='k', which selects all of the keywords.
Examples:
-xbtl='k' # selects just the keywords [DEFAULT]
-xbtl="t" # selects just the special type symbols
-xbtl="k t" # selects all keywords and symbols, or simply
-xbtl="kt" # selects all keywords and symbols
-xbtl="print say" # selects just keywords B<print> and B<say>:Here are some formatting examples using the default values of --brace-tightness=n and --block-brace-tightness=n. Note that in these examples $ref is in block braces but $key is not.
# default formatting
print {*STDERR} $message;
my $val = ${$ref}{$key};
# perltidy -xbt or
# perltidy -xbt -xbtl=k
print { *STDERR } $message;
my $val = ${$ref}{$key};
# perltidy -xbt -xbtl=t
print {*STDERR} $message;
my $val = ${ $ref }{$key};
# perltidy -xbt -xbtl=kt
print { *STDERR } $message;
my $val = ${ $ref }{$key};Finally, note that this parameter merely changes the way that the parameter --extended-block-tightness works. It has no effect unless --extended-block-tightness is actually set.
The flag -tso causes certain perl token sequences (secret operators) which might be considered to be a single operator to be formatted "tightly" (without spaces). The operators currently modified by this flag are:
0+ +0 ()x!! ~~<> ,=> =( )=For example the sequence 0 +, which converts a string to a number, would be formatted without a space: 0+ when the -tso flag is set. This flag is off by default.
Some programmers prefer a space before all terminal semicolons. The default is for no such space, and is indicated with -nsts or --nospace-terminal-semicolon.
$i = 1 ; # -sts
$i = 1; # -nsts (default)Semicolons within for loops may sometimes be hard to see, particularly when commas are also present. This option places spaces on both sides of these special semicolons, and is the default. Use -nsfs or --nospace-for-semicolon to deactivate it.
for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { # -sfs (default)
for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { # -nsfsSetting -asc allows perltidy to add any missing optional semicolon at the end of a line which is followed by a closing curly brace on the next line. This is the default, and may be deactivated with -nasc or --noadd-semicolons.
Setting -dsm allows perltidy to delete extra semicolons which are simply empty statements. This is the default, and may be deactivated with -ndsm or --nodelete-semicolons. (Such semicolons are not deleted, however, if they would promote a side comment to a block comment).
Setting this option allows perltidy to add certain whitespace to improve code readability. This is the default. If you do not want any whitespace added, but are willing to have some whitespace deleted, use -naws. (Use --freeze-whitespace (-fws) to leave whitespace completely unchanged).
Setting this option allows perltidy to remove optional whitespace between characters in the input file. The default is to not to do this (-nodelete-old-whitespace). This parameter has little effect by itself. But in combination with --noadd-whitespace it will cause most of the whitespace in a file to be removed.
For those who want more detailed control over the whitespace around tokens, there are four parameters which can directly modify the default whitespace rules built into perltidy for any token. They are:
-wls=s or --want-left-space=s,
-nwls=s or --nowant-left-space=s,
-wrs=s or --want-right-space=s,
-nwrs=s or --nowant-right-space=s.
These parameters are each followed by a quoted string, s, containing a list of token types. No more than one of each of these parameters should be specified, because repeating a command-line parameter always overwrites the previous one before perltidy ever sees it.
To illustrate how these are used, suppose it is desired that there be no space on either side of the token types = + - / *. The following two parameters would specify this desire:
-nwls="= + - / *" -nwrs="= + - / *"(Note that the token types are in quotes, and that they are separated by spaces). With these modified whitespace rules, the following line of math:
$root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );becomes this:
$root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );These parameters should be considered to be hints to perltidy rather than fixed rules, because perltidy must try to resolve conflicts that arise between them and all of the other rules that it uses. One conflict that can arise is if, between two tokens, the left token wants a space and the right one doesn't. In this case, the token not wanting a space takes priority.
It is necessary to have a list of all token types in order to create this type of input. Such a list can be obtained by the command --dump-token-types. Also try the -D flag on a short snippet of code and look at the .DEBUG file to see the tokenization.
To illustrate, suppose we do not want a space after a colon which introduces a sub attribute. We need to know its type. It is not a colon because that is the type of a ternary operator. The output of --dump-token-types states that it is token type 'A'. To verify this, we can run perltidy -D on a short piece of code containing such a colon, such as
sub foo : lvalue;This produces a .DEBUG file which contains
1: sub foo : lvalue;
1: SSSSSSSbAbwwwwww;The top line is the input, and the bottom line shows the token types. The 'A' beneath the colon verifies that it is type A.
So to prevent a space on the right of this colon we can use
# perltidy -nwrs='A'
sub foo :lvalue;WARNING Be sure to put these tokens in quotes to avoid having them misinterpreted by your command shell.
The various parameters controlling whitespace within a program are requests which perltidy follows as well as possible, but there are a number of situations where changing whitespace could change program behavior and is not done. Some of these are obvious; for example, we should not remove the space between the two plus symbols in '$x+ +$y' to avoid creating a '++' operator. Some are more subtle and involve the whitespace around bareword symbols and locations of possible filehandles. For example, consider the problem of formatting the following subroutine:
sub print_div {
my ($x,$y)=@_;
print $x/$y;
}Suppose the user requests that / signs have a space to the left but not to the right. Perltidy will refuse to do this, but if this were done the result would be
sub print_div {
my ($x,$y)=@_;
print $x /$y;
}If formatted in this way, the program will not run (at least with recent versions of perl) because the $x is taken to be a filehandle and / is assumed to start a quote. In a complex program, there might happen to be a / which terminates the multiline quote without a syntax error, allowing the program to run, but not as intended.
Related issues arise with other binary operator symbols, such as + and -, and in older versions of perl there could be problems with ternary operators. So to avoid changing program behavior, perltidy has the simple rule that whitespace around possible filehandles is left unchanged. Likewise, whitespace around unknown barewords is left unchanged. The reason is that if the barewords are defined in other modules, or in code that has not even been written yet, perltidy will not have seen their prototypes and must treat them cautiously.
In perltidy this is implemented in the tokenizer by marking token following a print keyword as a special type Z. When formatting is being done, whitespace following this token type is generally left unchanged as a precaution against changing program behavior. This is excessively conservative but simple and easy to implement. Keywords which are treated similarly to print include printf, sort, exec, system. Changes in spacing around parameters following these keywords may have to be made manually. For example, the space, or lack of space, after the parameter $foo in the following line will be unchanged in formatting.
system($foo );
system($foo);To find if a token is of type Z you can use perltidy -DEBUG. For the first line above the result is
1: system($foo );
1: kkkkkk{ZZZZb};which shows that system is type k (keyword) and $foo is type Z.
Despite these precautions, it is still possible to introduce syntax errors with some asymmetric whitespace rules, particularly when call parameters are not placed in containing parens or braces. For example, the following two lines will be parsed by perl without a syntax error:
# original programming, syntax ok
my @newkeys = map $_-$nrecs+@data, @oldkeys;
# perltidy default, syntax ok
my @newkeys = map $_ - $nrecs + @data, @oldkeys;But the following will give a syntax error:
# perltidy -nwrs='-'
my @newkeys = map $_ -$nrecs + @data, @oldkeys;For another example, the following two lines will be parsed without syntax error:
# original programming, syntax ok
for my $severity ( reverse $LOWEST+1 .. $HIGHEST ) { ... }
# perltidy default, syntax ok
for my $severity ( reverse $LOWEST + 1 .. $HIGHEST ) { ... }But the following will give a syntax error:
# perltidy -nwrs='+', syntax error:
for my $severity ( reverse $LOWEST +1 .. $HIGHEST ) { ... }To avoid subtle parsing problems like this, it is best to avoid spacing a binary operator asymmetrically with a space on the left but not on the right.
When an opening paren follows a Perl keyword, no space is introduced after the keyword, unless it is (by default) one of these:
my local our state and or xor err eq ne if else elsif until unless
while for foreach return switch case given when catchThese defaults can be modified with two commands:
-sak=s or --space-after-keyword=s adds keywords.
-nsak=s or --nospace-after-keyword=s removes keywords.
where s is a list of keywords (in quotes if necessary). For example,
my ( $a, $b, $c ) = @_; # default
my( $a, $b, $c ) = @_; # -nsak="my local our"The abbreviation -nsak='*' is equivalent to including all of the keywords in the above list.
When both -nsak=s and -sak=s commands are included, the -nsak=s command is executed first. For example, to have space after only the keywords (my, local, our) you could use -nsak="*" -sak="my local our".
To put a space after all keywords, see the next item.
When an opening paren follows a function or keyword, no space is introduced after the keyword except for the keywords noted in the previous item. To always put a space between a function or keyword and its opening paren, use the command:
-skp or --space-keyword-paren
You may also want to use the flag -sfp (next item) too.
When an opening paren follows a function the default and recommended formatting is not to introduce a space. To cause a space to be introduced use:
-sfp or --space-function-paren
myfunc( $a, $b, $c ); # default
myfunc ( $a, $b, $c ); # -sfpYou will probably also want to use the flag -skp (previous item) too.
The parameter is not recommended because spacing a function paren can make a program vulnerable to parsing problems by Perl. For example, the following two-line program will run as written but will have a syntax error if reformatted with -sfp:
if ( -e filename() ) { print "I'm here\n"; }
sub filename { return $0 }In this particular case the syntax error can be removed if the line order is reversed, so that Perl parses 'sub filename' first.
A side-effect of using the -sfp flag is that the parens may become vertically aligned. For example,
# perltidy -sfp
myfun ( $aaa, $b, $cc );
mylongfun ( $a, $b, $c );This is the default behavior. To prevent this alignment use -nfpva:
# perltidy -sfp -nfpva
myfun ( $aaa, $b, $cc );
mylongfun ( $a, $b, $c );This flag can be used to control whether a function prototype is preceded by a space. For example, the following prototype does not have a space.
sub usage();This integer n may have the value 0, 1, or 2 as follows:
-spp=0 means no space before the paren
-spp=1 means follow the example of the source code [DEFAULT]
-spp=2 means always put a space before the parenThe default is -spp=1, meaning that a space will be used if and only if there is one in the source code. Given the above line of code, the result of applying the different options would be:
sub usage(); # n=0 [no space]
sub usage(); # n=1 [default; follows input]
sub usage (); # n=2 [space]This flag is analogous to the previous except that it applies to the space before the opening paren of a sub signature rather than a sub prototype.
For example, consider the following line:
sub circle( $xc, $yc, $rad )This space before the opening paren can be controlled with integer n which may have the value 0, 1, or 2 with these meanings:
-ssp=0 means no space before the paren
-ssp=1 means follow the example of the source code [DEFAULT]
-ssp=2 means always put a space before the parenThe default is -ssp=1, meaning that will be a space in the output if, and only if, there is one in the input. Given the above line of code, the result of applying the different options would be:
sub circle( $xc, $yc, $rad ) # n=0 [no space]
sub circle( $xc, $yc, $rad ) # n=1 [default; same as input]
sub circle ( $xc, $yc, $rad ) # n=2 [space]The space inside of an opening paren, which itself follows a certain keyword, can be controlled by this parameter. The space on the inside of the corresponding closing paren will be treated in the same (balanced) manner. This parameter has precedence over any other paren spacing rules. The values of n are as follows:
-kpit=0 means always put a space (not tight)
-kpit=1 means ignore this parameter [default]
-kpit=2 means never put a space (tight)To illustrate, the following snippet is shown formatted in three ways:
if ( seek( DATA, 0, 0 ) ) { ... } # perltidy (default)
if (seek(DATA, 0, 0)) { ... } # perltidy -pt=2
if ( seek(DATA, 0, 0) ) { ... } # perltidy -pt=2 -kpit=0In the second case the -pt=2 parameter makes all of the parens tight. In the third case the -kpit=0 flag causes the space within the 'if' parens to have a space, since 'if' is one of the keywords to which the -kpit flag applies by default. The remaining parens are still tight because of the -pt=2 parameter.
The set of keywords to which this parameter applies are by default are:
if elsif unless while until for foreachThese can be changed with the parameter -kpitl=s described in the next section.
This command can be used to change the keywords to which the previous parameter, -kpit=n, applies. The parameter string is a required list either keywords or functions, which should be placed in quotes if there are more than one. By itself, this parameter does not cause any change in spacing, so the -kpit=n command is still required.
For example, the commands -kpitl="if else while" -kpit=2 will cause the just the spaces inside parens following 'if', 'else', and 'while' keywords to follow the tightness value indicated by the -kpit=2 flag.
In the following example some extra space has been inserted on the second line between the two open parens. This extra space is called "logical padding" and is intended to help align similar things vertically in some logical or ternary expressions.
# perltidy [default formatting]
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );Note that this is considered to be a different operation from "vertical alignment" because space at just one line is being adjusted, whereas in "vertical alignment" the spaces at all lines are being adjusted. So it is sort of a local version of vertical alignment.
Here is an example involving a ternary operator:
# perltidy [default formatting]
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;This behavior is controlled with the flag --logical-padding, which is set 'on' by default. If it is not desired it can be turned off using --nological-padding or -nlop. The above two examples become, with -nlop:
# perltidy -nlop
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
# perltidy -nlop
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;qw quotes-tqw or --trim-qw provide the default behavior of trimming spaces around multiline qw quotes and indenting them appropriately.
-ntqw or --notrim-qw cause leading and trailing whitespace around multiline qw quotes to be left unchanged. This option will not normally be necessary, but was added for testing purposes, because in some versions of perl, trimming qw quotes changes the syntax tree.
lines like
$str1=\"string1";
$str2=\'string2';can confuse syntax highlighters unless a space is included between the backslash and the single or double quotation mark.
this can be controlled with the value of n as follows:
-sbq=0 means no space between the backslash and quote
-sbq=1 means follow the example of the source code
-sbq=2 means always put a space between the backslash and quoteThe default is -sbq=1, meaning that a space will be used if there is one in the source code.
-trp or --trim-pod will remove trailing whitespace from lines of POD. The default is not to do this.
Perltidy has a number of ways to control the appearance of both block comments and side comments. The term block comment here refers to a full-line comment, whereas side comment will refer to a comment which appears on a line to the right of some code.
Perltidy does not do any word wrapping of commented text to match a selected maximum line length. This is because there is no way to determine if this is appropriate for the given content. However, an interactive program named perlcomment.pl is available in the examples folder of the perltidy distribution which can assist in doing this.
Block comments normally look best when they are indented to the same level as the code which follows them. This is the default behavior, but you may use -nibc to keep block comments left-justified. Here is an example:
# this comment is indented (-ibc, default)
if ($task) { yyy(); }The alternative is -nibc:
# this comment is not indented (-nibc)
if ($task) { yyy(); }See also the next item, -isbc, as well as -sbc, for other ways to have some indented and some outdented block comments.
If there is no leading space on the line, then the comment will not be indented, and otherwise it may be.
If both -ibc and -isbc are set, then -isbc takes priority.
When -olc is set, lines which are full-line (block) comments longer than the value maximum-line-length will have their indentation removed. This is the default; use -nolc to prevent outdenting.
Side comments look best when lined up several spaces to the right of code. Perltidy will try to keep comments at least n spaces to the right. The default is n=4 spaces.
This parameter tells perltidy to line up side comments in column number n whenever possible. The default, n=0, will not do this.
This parameter causes perltidy to ignore the length of side comments when setting line breaks. The default, -niscl, is to include the length of side comments when breaking lines to stay within the length prescribed by the -l=n maximum line length parameter. For example, the following long single line would remain intact with -l=80 and -iscl:
perltidy -l=80 -iscl
$vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer versionwhereas without the -iscl flag the line will be broken:
perltidy -l=80
$vmsfile =~ s/;[\d\-]*$//
; # Clip off version number; we can use a newer versionPerltidy, by default, will look for side comments beginning with ## no critic and ignore their lengths when making line break decisions, even if the user has not set -iscl. The reason is that an unwanted line break can make these special comments ineffective in controlling perlcritic.
Setting --ignore-perlcritic-comments tells perltidy not to look for these ## no critic comments.
By default, perltidy tries to identify and align "hanging side comments", which are something like this:
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is thisA comment is considered to be a hanging side comment if (1) it immediately follows a line with a side comment, or another hanging side comment, and (2) there is some leading whitespace on the line. To deactivate this feature, use -nhsc or --nohanging-side-comments. If block comments are preceded by a blank line, or have no leading whitespace, they will not be mistaken as hanging side comments.
A closing side comment is a special comment which perltidy can automatically create and place after the closing brace of a code block. They can be useful for code maintenance and debugging. The command -csc (or --closing-side-comments) adds or updates closing side comments. For example, here is a small code snippet
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}And here is the result of processing with perltidy -csc:
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
} ## end sub messageA closing side comment was added for sub message in this case, but not for the if and else blocks, because they were below the 6 line cutoff limit for adding closing side comments. This limit may be changed with the -csci command, described below.
The command -dcsc (or --delete-closing-side-comments) reverses this process and removes these comments.
Several commands are available to modify the behavior of these two basic commands, -csc and -dcsc:
where n is the minimum number of lines that a block must have in order for a closing side comment to be added. The default value is n=6. To illustrate:
# perltidy -csci=2 -csc
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
} ## end if ( !defined( $_[0] ))
else {
print( $_[0], "\n" );
} ## end else [ if ( !defined( $_[0] ))
} ## end sub messageNow the if and else blocks are commented. However, now this has become very cluttered.
where string is the prefix used before the name of the block type. The default prefix, shown above, is ## end. This string will be added to closing side comments, and it will also be used to recognize them in order to update, delete, and format them. Any comment identified as a closing side comment will be placed just a single space to the right of its closing brace.
where string is a list of block types to be tagged with closing side comments. By default, all code block types preceded by a keyword or label (such as if, sub, and so on) will be tagged. The -cscl command changes the default list to be any selected block types; see "Specifying Block Types". For example, the following command requests that only sub's, labels, BEGIN, and END blocks be affected by operations which add (-csc) or delete (-dcsc) closing side comments:
--closing-side-comment-list='sub : BEGIN END'where string is a list of block types which should NOT be tagged with closing side comments. If a block type appears in both -cscl and -cscxl, then -cscxl has priority and the block will not be tagged.
For example, the following command requests that anonymous subs should not be affected by any -csc or -dcsc operation:
--closing-side-comment-exclusion-list='asub'By default, no block types are excluded.
The text appended to certain block types, such as an if block, is whatever lies between the keyword introducing the block, such as if, and the opening brace. Since this might be too much text for a side comment, there needs to be a limit, and that is the purpose of this parameter. The default value is n=20, meaning that no additional tokens will be appended to this text after its length reaches 20 characters. Omitted text is indicated with .... (Tokens, including sub names, are never truncated, however, so actual lengths may exceed this). To illustrate, in the above example, the appended text of the first block is ( !defined( $_[0] ).... The existing limit of n=20 caused this text to be truncated, as indicated by the .... See the next flag for additional control of the abbreviated text.
As discussed in the previous item, when the closing-side-comment-maximum-text limit is exceeded the comment text must be truncated. Older versions of perltidy terminated with three dots, and this can still be achieved with -ncscb:
perltidy -csc -ncscb
} ## end foreach my $foo (sort { $b cmp $a ...However this causes a problem with editors which cannot recognize comments or are not configured to do so because they cannot "bounce" around in the text correctly. The -cscb flag has been added to help them by appending appropriate balancing structure:
perltidy -csc -cscb
} ## end foreach my $foo (sort { $b cmp $a ... })The default is -cscb.
The default, n=0, places the text of the opening if statement after any terminal else.
If n=2 is used, then each elsif is also given the text of the opening if statement. Also, an else will include the text of a preceding elsif statement. Note that this may result some long closing side comments.
If n=1 is used, the results will be the same as n=2 whenever the resulting line length is less than the maximum allowed.
When using closing-side-comments, and the closing-side-comment-maximum-text limit is exceeded, then the comment text must be abbreviated. It is terminated with three dots if the -cscb flag is negated:
perltidy -csc -ncscb
} ## end foreach my $foo (sort { $b cmp $a ...This causes a problem with older editors which do not recognize comments because they cannot "bounce" around in the text correctly. The -cscb flag tries to help them by appending appropriate terminal balancing structures:
perltidy -csc -cscb
} ## end foreach my $foo (sort { $b cmp $a ... })The default is -cscb.
This parameter is intended to help make the initial transition to the use of closing side comments. It causes two things to happen if a closing side comment replaces an existing, different closing side comment: first, an error message will be issued, and second, the original side comment will be placed alone on a new specially marked comment line for later attention.
The intent is to avoid clobbering existing hand-written side comments which happen to match the pattern of closing side comments. This flag should only be needed on the first run with -csc.
Important Notes on Closing Side Comments:
Closing side comments are only placed on lines terminated with a closing brace. Certain closing styles, such as the use of cuddled elses (-ce), preclude the generation of some closing side comments.
Please note that adding or deleting of closing side comments takes place only through the commands -csc or -dcsc. The other commands, if used, merely modify the behavior of these two commands.
It is recommended that the -cscw flag be used along with -csc on the first use of perltidy on a given file. This will prevent loss of any existing side comment data which happens to have the csc prefix.
Once you use -csc, you should continue to use it so that any closing side comments remain correct as code changes. Otherwise, these comments will become incorrect as the code is updated.
If you edit the closing side comments generated by perltidy, you must also change the prefix to be different from the closing side comment prefix. Otherwise, your edits will be lost when you rerun perltidy with -csc. For example, you could simply change ## end to be ## End, since the test is case sensitive. You may also want to use the -ssc flag to keep these modified closing side comments spaced the same as actual closing side comments.
Temporarily generating closing side comments is a useful technique for exploring and/or debugging a perl script, especially one written by someone else. You can always remove them with -dcsc.
Static block comments are block comments with a special leading pattern, ## by default, which will be treated slightly differently from other block comments. They effectively behave as if they had glue along their left and top edges, because they stick to the left edge and previous line when there is no blank spaces in those places. This option is particularly useful for controlling how commented code is displayed.
When -sbc is used, a block comment with a special leading pattern, ## by default, will be treated specially.
Comments so identified are treated as follows:
If there is no leading space on the line, then the comment will not be indented, and otherwise it may be,
no new blank line will be inserted before such a comment, and
such a comment will never become a hanging side comment.
For example, assuming @month_of_year is left-adjusted:
@month_of_year = ( # -sbc (default)
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov'
'Nov', 'Dec');Without this convention, the above code would become
@month_of_year = ( # -nsbc
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov'
'Nov', 'Dec'
);which is not as clear. The default is to use -sbc. This may be deactivated with -nsbc.
This parameter defines the prefix used to identify static block comments when the -sbc parameter is set. The default prefix is ##, corresponding to -sbcp=##. The prefix is actually part of a perl pattern used to match lines and it must either begin with # or ^#. In the first case a prefix ^\s* will be added to match any leading whitespace, while in the second case the pattern will match only comments with no leading whitespace. For example, to identify all comments as static block comments, one would use -sbcp=#. To identify all left-adjusted comments as static block comments, use -sbcp='^#'.
Please note that -sbcp merely defines the pattern used to identify static block comments; it will not be used unless the switch -sbc is set. Also, please be aware that since this string is used in a perl regular expression which identifies these comments, it must enable a valid regular expression to be formed.
A pattern which can be useful is:
-sbcp=^#{2,}[^\s#]This pattern requires a static block comment to have at least one character which is neither a # nor a space. It allows a line containing only '#' characters to be rejected as a static block comment. Such lines are often used at the start and end of header information in subroutines and should not be separated from the intervening comments, which typically begin with just a single '#'.
The command -osbc will cause static block comments to be outdented by the number of --continuation-spaces=n, if possible.
Static side comments are side comments with a special leading pattern. This option can be useful for controlling how commented code is displayed when it is a side comment.
When -ssc is used, a side comment with a static leading pattern, which is ## by default, will be spaced only a single space from previous character, and it will not be vertically aligned with other side comments.
The default is -nssc.
This parameter defines the prefix used to identify static side comments when the -ssc parameter is set. The default prefix is ##, corresponding to -sscp=##.
Please note that -sscp merely defines the pattern used to identify static side comments; it will not be used unless the switch -ssc is set. Also, note that this string is used in a perl regular expression which identifies these comments, so it must enable a valid regular expression to be formed.
Selected lines of code may be passed verbatim to the output without any formatting by marking the starting and ending lines with special comments. There are two options for doing this. The first option is called --format-skipping or -fs, and the second option is called --code-skipping or -cs.
In both cases the lines of code will be output without any changes. The difference is that in --format-skipping perltidy will still parse the marked lines of code and check for errors, whereas in --code-skipping perltidy will simply pass the lines to the output without any checking.
Both of these features are enabled by default and are invoked with special comment markers. --format-skipping uses starting and ending markers '#<<<' and '#>>>', like this:
#<<< format skipping: do not let perltidy change my nice formatting
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>--code-skipping uses starting and ending markers '#<<V' and '#>>V', like this:
#<<V code skipping: perltidy passes this verbatim, no error checking
token ident_digit {
[ [ <?word> | _ | <?digit> ] <?ident_digit>
| <''>
]
};
#>>V(The last character V is like a < or > rotated 90 degrees). Additional text may appear on the special comment lines provided that it is separated from the marker by at least one space to highlight the sign, as in the above examples.
Any number of code-skipping or format-skipping sections may appear in a file. If an opening code-skipping or format-skipping comment is not followed by a corresponding closing comment, then skipping continues to the end of the file. If a closing code-skipping or format-skipping comment appears in a file but does not follow a corresponding opening comment, then it is treated as an ordinary comment without any special meaning.
It is recommended to use --code-skipping only if you need to hide a block of an extended syntax which would produce errors if parsed by perltidy, and use --format-skipping otherwise. This is because the --format-skipping option provides the benefits of error checking, and there are essentially no limitations on which lines to which it can be applied. The --code-skipping option, on the other hand, does not do error checking and its use is more restrictive because the code which remains, after skipping the marked lines, must be syntactically correct code with balanced containers.
These features should be used sparingly to avoid littering code with markers, but they can be helpful for working around occasional problems.
Note that it may be possible to avoid the use of --format-skipping for the specific case of a comma-separated list of values, as in the above example, by simply inserting a blank or comment somewhere between the opening and closing parens. See the section "Controlling List Formatting".
The following sections describe the available controls for these options. They should not normally be needed.
As explained above, this flag, which is enabled by default, causes any code between special beginning and ending comment markers to be passed to the output without formatting. The code between the comments is still checked for errors however. The default beginning marker is #<<< and the default ending marker is #>>>.
Format skipping begins when a format skipping beginning comment is seen and continues until a format-skipping ending comment is found.
This feature can be disabled with -nfs. This should not normally be necessary.
This and the next parameter allow the special beginning and ending comments to be changed. However, it is recommended that they only be changed if there is a conflict between the default values and some other use. If they are used, it is recommended that they only be entered in a .perltidyrc file, rather than on a command line. This is because properly escaping these parameters on a command line can be difficult.
If changed comment markers do not appear to be working, use the -log flag and examine the .LOG file to see if and where they are being detected.
The -fsb=string parameter may be used to change the beginning marker for format skipping. The default is equivalent to -fsb='#<<<'. The string that you enter must begin with a # and should be in quotes as necessary to get past the command shell of your system. It is actually the leading text of a pattern that is constructed by appending a '\s', so you must also include backslashes for characters to be taken literally rather than as patterns.
Some examples show how example strings become patterns:
-fsb='#\{\{\{' becomes /^#\{\{\{\s/ which matches #{{{ but not #{{{{
-fsb='#\*\*' becomes /^#\*\*\s/ which matches #** but not #***
-fsb='#\*{2,}' becomes /^#\*{2,}\s/ which matches #** and #*****The -fse=string is the corresponding parameter used to change the ending marker for format skipping. The default is equivalent to -fse='#<<<'.
The beginning and ending strings may be the same, but it is preferable to make them different for clarity.
As explained above, this flag, which is enabled by default, causes any code between special beginning and ending comment markers to be directly passed to the output without any error checking or formatting. Essentially, perltidy treats it as if it were a block of arbitrary text. The default beginning marker is #<<V and the default ending marker is #>>V.
This feature can be disabled with -ncs. This should not normally be necessary.
This may be used to change the beginning comment for a --code-skipping section, and its use is similar to the -fsb=string. The default is equivalent to -csb='#<<V'.
This may be used to change the ending comment for a --code-skipping section, and its use is similar to the -fse=string. The default is equivalent to -cse='#>>V'.
A command --line-range-tidy=n1:n2 is available to process just a selected range of lines of an input stream with perltidy. This command is mainly of interest for programming interactive code editors. When it is used, the entire input stream is read but just the selected range of lines of the input file are processed by the perltidy tokenizer and formatter, and then the stream is reassembled for output. The selected lines need to contain a complete statement or balanced container. Otherwise, a syntax error will occur and the code will not be tidied. There are a couple of limitations on the use of this command: (1) it may not be applied to multiple files, and (2) it only applies to code tidying and not, for example, html formatting.
The range of lines is specified by integers n1 and n2, where n1 is the first line number to be formatted (start counting with 1) and n2 is the last line number to be formatted. If n2 is not given, or exceeds the actual number of lines, then formatting continues to the end of the file.
Examples:
--line-range-tidy=43:109 # tidy lines 43 through 109
--line-range-tidy=' 43 : 109' # tidy lines 43 through 109
--line-range-tidy=1: # tidy all lines
--line-range-tidy=0:90 # ERROR (n1 must be >= 1)The second example shows that spaces are okay if placed in quotes.
The parameters in this and the next sections control breaks after non-blank lines of code. Blank lines are controlled separately by parameters in the section "Blank Line Control".
By default, perltidy first deletes all old line break locations, and then it looks for good break points to match the desired line length. Use -ndnl or --nodelete-old-newlines to force perltidy to retain all old line break points.
By default, perltidy will add line breaks when necessary to create continuations of long lines and to improve the script appearance. Use -nanl or --noadd-newlines to prevent any new line breaks.
This flag does not prevent perltidy from eliminating existing line breaks; see --freeze-newlines to completely prevent changes to line break points.
If you do not want any changes to the line breaks within lines of code in your script, set -fnl, and they will remain fixed, and the rest of the commands in this section and sections "Controlling List Formatting", "Retaining or Ignoring Existing Line Breaks". You may want to use --nooutdent-long-lines with this.
Note: If you also want to keep your blank lines exactly as they are, you can use the --freeze-blank-lines flag which is described in the section "Blank Line Control".
Enable the "cuddled else" style, in which else and elsif are follow immediately after the curly brace closing the previous block. The default is not to use cuddled elses, and is indicated with the flag -nce or --nocuddled-else. Here is a comparison of the alternatives:
# -ce
if ($task) {
yyy();
} else {
zzz();
}
# -nce (default)
if ($task) {
yyy();
}
else {
zzz();
}In this example the keyword else is placed on the same line which begins with the preceding closing block brace and is followed by its own opening block brace on the same line. Other keywords and function names which are formatted with this "cuddled" style are elsif, continue, catch, finally.
Other block types can be formatted by specifying their names on a separate parameter --cuddled-block-list, described in a later section.
Cuddling between a pair of code blocks requires that the closing brace of the first block start a new line. If this block is entirely on one line in the input file, it is necessary to decide if it should be broken to allow cuddling. This decision is controlled by the flag --cuddled-break-options=n (-cbo=n) discussed below. The default and recommended value of -cbo=1 bases this decision on the first block in the chain. If it spans multiple lines then cuddling is made and continues along the chain, regardless of the sizes of subsequent blocks. Otherwise, short lines remain intact.
So for example, the --cuddled-else flag would not have any effect if the above snippet is rewritten as
if ($task) { yyy() }
else { zzz() }If the first block spans multiple lines, then cuddling can be done and will continue for the subsequent blocks in the chain, as illustrated in the previous snippet.
If there are blank lines between cuddled blocks they will be eliminated. If there are comments after the closing brace where cuddling would occur then cuddling will be prevented. If this occurs, cuddling will restart later in the chain if possible.
This flag is equivalent to --cuddled-else (-ce).
The built-in default cuddled block types are else, elsif, continue, catch, finally.
Additional block types to which the --cuddled-blocks style applies can be defined by this parameter. This parameter is a character string, giving a list of block types separated by commas or spaces. For example, to cuddle code blocks of type sort, map and grep, in addition to the default types, the string could be set to
-cbl="sort map grep"or equivalently
-cbl=sort,map,grepNote however that these particular block types are typically short so there might not be much opportunity for the cuddled format style.
Using commas avoids the need to protect spaces with quotes.
As a diagnostic check, the flag --dump-cuddled-block-list or -dcbl can be used to view the hash of values that are generated by this flag.
Finally, note that the --cuddled-block-list parameter by itself merely specifies which blocks are formatted with the cuddled format. It has no effect unless this formatting style is activated with --cuddled-else.
When cuddled else formatting is selected with --cuddled-else, setting this flag causes perltidy to ignore its built-in defaults and rely exclusively on the block types specified on the --cuddled-block-list flag described in the previous section. For example, to avoid using cuddled catch and finally, which are among the defaults, the following set of parameters could be used:
perltidy -ce -cbl='else elsif continue' -cblxCuddled formatting is only possible between a pair of code blocks if the closing brace of the first block starts a new line. If a block is encountered which is entirely on a single line, and cuddled formatting is selected, it is necessary to make a decision as to whether or not to "break" the block, meaning to cause it to span multiple lines. This parameter controls that decision. The options are:
cbo=0 Never force a short block to break.
cbo=1 If the first of a pair of blocks is broken in the input
file, then break the second [DEFAULT].
cbo=2 Break open all blocks for maximal cuddled formatting.The default and recommended value is cbo=1. With this value, if the starting block of a chain spans multiple lines, then a cascade of breaks will occur for remaining blocks causing the entire chain to be cuddled.
The option cbo=0 can produce erratic cuddling if there are numerous one-line blocks.
The option cbo=2 produces maximal cuddling but will not allow any short blocks.
Use the flag -bl to place an opening block brace on a new line:
if ( $input_file eq '-' )
{
...
}By default it applies to all structural blocks except sort map grep eval and anonymous subs.
The default is -nbl which places an opening brace on the same line as the keyword introducing it if possible. For example,
# default
if ( $input_file eq '-' ) {
...
}When -bl is set, the blocks to which this applies can be controlled with the parameters --brace-left-list and --brace-left-exclusion-list described in the next sections.
Use this parameter to change the types of block braces for which the -bl flag applies; see "Specifying Block Types". For example, -bll='if elsif else sub' would apply it to only if/elsif/else and named sub blocks. The default is all blocks, -bll='*'.
Use this parameter to exclude types of block braces for which the -bl flag applies; see "Specifying Block Types". For example, the default settings -bll='*' and -blxl='sort map grep eval asub' mean all blocks except sort map grep eval and anonymous sub blocks.
Note that the lists -bll=s and -blxl=s control the behavior of the -bl flag but have no effect unless the -bl flag is set. These two lists provide complete control for this flag, but two shortcut flags are available and described in the next sections.
The flag -sbl provides a shortcut way to turn on -bl just for named subs. The same effect can be achieved by turning on -bl with the block list set as -bll='sub'. To avoid conflicts, it is recommended to either use the more general list method described above to control -bl, or this shortcut method, but not both.
For example,
perltidy -sblproduces this result:
sub message
{
if (!defined($_[0])) {
print("Hello, World\n");
}
else {
print($_[0], "\n");
}
}This negative version of this flag, -nsbl, turns off -bl for named subs. The same effect can be achieved with the exclusion list method, -blxl=sub.
The flag -asbl is like the -sbl flag except that it applies to anonymous sub's instead of named subs. The same effect can be achieved by turning on -bl with the block list set to include -bll='asub'.
For example
perltidy -asblproduces this result:
$a = sub
{
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
};This negative version of this flag, -nasbl, turns off -bl for anonymous subs.
The flag -bli is similar to the -bl flag but in addition it causes one unit of continuation indentation ( see --continuation-indentation ) to be placed before an opening and closing block braces.
For example
# perltidy -bli
if ( $input_file eq '-' )
{
important_function();
}By default, this extra indentation occurs for block types: if, elsif, else, unless, while, for, foreach, do, and also named subs and blocks preceded by a label. The next item shows how to change this.
Note: The -bli flag is similar to the -bl flag, with the difference being that braces get indented. But these two flags are implemented independently, and have different default settings for historical reasons. If desired, a mixture of effects can be achieved if desired by turning them both on with different -list settings. In the event that both settings are selected for a certain block type, the -bli style has priority.
Use this parameter to change the types of block braces for which the -bli flag applies; see "Specifying Block Types".
The default is -blil='if else elsif unless while for foreach do : sub'.
Use this parameter to exclude types of block braces for which the -bli flag applies; see "Specifying Block Types".
This might be useful in conjunction with selecting all blocks -blil='*'. The default setting is -blixl=' ', which does not exclude any blocks.
Note that the two parameters -blil and -blixl control the behavior of the -bli flag but have no effect unless the -bli flag is set.
The default style, -nbl places the opening code block brace on a new line if it does not fit on the same line as the opening keyword, like this:
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 )
{
big_waste_of_time();
}To force the opening brace to always be on the right, use the -bar flag. In this case, the above example becomes
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 ) {
big_waste_of_time();
}A conflict occurs if both --opening-brace-on_new-line (-bl) and -bar are specified.
A related parameter, --cuddled-paren-brace, causes perltidy to join two lines which otherwise would be
)
{to be
) {For example:
# default
foreach my $dir (
'05_lexer', '07_token', '08_regression', '11_util',
'13_data', '15_transform'
)
{
...
}
# perltidy -cpb
foreach my $dir (
'05_lexer', '07_token', '08_regression', '11_util',
'13_data', '15_transform'
) {
...;
}The -otr flag is a hint that perltidy should not place a break between a comma and an opening token. For example:
# default formatting
push @{ $self->{$module}{$key} },
{
accno => $ref->{accno},
description => $ref->{description}
};
# perltidy -otr
push @{ $self->{$module}{$key} }, {
accno => $ref->{accno},
description => $ref->{description}
};The flag -otr is actually an abbreviation for three other flags which can be used to control parens, hash braces, and square brackets separately if desired:
-opr or --opening-paren-right
-ohbr or --opening-hash-brace-right
-osbr or --opening-square-bracket-rightWhen a list of items spans multiple lines, the default formatting is to place the opening brace (or other container token) at the end of the starting line, like this:
$romanNumerals = {
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
};This flag can change the default behavior to cause a line break to be placed before the opening brace according to the value given to the integer n:
-bbhb=0 never break [default]
-bbhb=1 stable: break if the input script had a break
-bbhb=2 break if list is 'complex' (see note below)
-bbhb=3 always breakFor example,
# perltidy -bbhb=3
$romanNumerals =
{
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
};There are several points to note about this flag:
This parameter only applies if the opening brace is preceded by an '=' or '=>'.
This parameter only applies if the contents of the container looks like a list. The contents need to contain some commas or '=>'s at the next interior level to be considered a list.
For the n=2 option, a list is considered 'complex' if it is part of a nested list structure which spans multiple lines in the input file.
If multiple opening tokens have been 'welded' together with the -wn parameter, then this parameter has no effect.
The indentation of the braces will normally be one level of continuation indentation by default. This can be changed with the parameter -bbhbi=n in the next section.
Similar flags for controlling parens and square brackets are given in the subsequent section.
This flag is a companion to -bbhb=n for controlling the indentation of an opening hash brace which is placed on a new line by that parameter. The indentation is as follows:
-bbhbi=0 one continuation level [default]
-bbhbi=1 outdent by one continuation level
-bbhbi=2 indent one full indentation levelFor example:
# perltidy -bbhb=3 -bbhbi=1
$romanNumerals =
{
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
};
# perltidy -bbhb=3 -bbhbi=2
$romanNumerals =
{
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
};Note that this parameter has no effect unless -bbhb=n is also set.
This flag is similar to the flag described above, except it applies to lists contained within square brackets.
-bbsb=0 never break [default]
-bbsb=1 stable: break if the input script had a break
-bbsb=2 break if list is 'complex' (part of nested list structure)
-bbsb=3 always breakThis flag is a companion to -bbsb=n for controlling the indentation of an opening square bracket which is placed on a new line by that parameter. The indentation is as follows:
-bbsbi=0 one continuation level [default]
-bbsbi=1 outdent by one continuation level
-bbsbi=2 indent one full indentation levelThis flag is similar to -bbhb=n, described above, except it applies to lists contained within parens.
-bbp=0 never break [default]
-bbp=1 stable: break if the input script had a break
-bpb=2 break if list is 'complex' (part of nested list structure)
-bbp=3 always breakThis flag is a companion to -bbp=n for controlling the indentation of an opening paren which is placed on a new line by that parameter. The indentation is as follows:
-bbpi=0 one continuation level [default]
-bbpi=1 outdent by one continuation level
-bbpi=2 indent one full indentation levelSome types of closing block braces, such as eval, may be followed by additional code. A line break may be inserted between such a closing brace and the following code depending on the parameter n and the length of the trailing code, as follows:
If the trailing code fits on a single line, then
-bfvt=0 Follow the input style regarding break/no-break
-bfvt=1 Follow the input style regarding break/no-break [Default]
-bfvt=2 Do not insert a line breakIf the trailing code requires multiple lines, then
-bfvt=0 Insert a line break
-bfvt=1 Insert a line break except for a cuddled block chain
-bfvt=2 Do not insert a line breakThe default is -bfvt=1. The most compact code is achieved with -bfvt=2.
Example (non-cuddled, multiple lines ):
# -bfvt=0 or -bvft=1 [DEFAULT]
eval {
( $line, $cond ) = $self->_normalize_if_elif($line);
1;
}
or die sprintf "Error at line %d\nLine %d: %s\n%s",
( $line_info->start_line_num() ) x 2, $line, $@;
# -bfvt=2
eval {
( $line, $cond ) = $self->_normalize_if_elif($line);
1;
} or die sprintf "Error at line %d\nLine %d: %s\n%s",
( $line_info->start_line_num() ) x 2, $line, $@;Example (cuddled, multiple lines):
# -bfvt=0
eval {
#STUFF;
1; # return true
}
or do {
##handle error
};
# -bfvt=1 [DEFAULT] or -bfvt=2
eval {
#STUFF;
1; # return true
} or do {
##handle error
};The -wn flag causes closely nested pairs of opening and closing container symbols (curly braces, brackets, or parens) to be "welded" together, meaning that they are treated as if combined into a single unit, with the indentation of the innermost code reduced to be as if there were just a single container symbol.
For example:
# default formatting
do {
{
next if $x == $y;
}
} until $x++ > $z;
# perltidy -wn
do { {
next if $x == $y;
} } until $x++ > $z;When this flag is set perltidy makes a preliminary pass through the file and identifies all nested pairs of containers. To qualify as a nested pair, the closing container symbols must be immediately adjacent and the opening symbols must either (1) be adjacent as in the above example, or (2) have an anonymous sub declaration following an outer opening container symbol which is not a code block brace, or (3) have an outer opening paren separated from the inner opening symbol by any single non-container symbol or something that looks like a function evaluation, as illustrated in the next examples. An additional option (4) which can be turned on with the flag --weld-fat-comma is when the opening container symbols are separated by a hash key and fat comma (=>).
Any container symbol may serve as both the inner container of one pair and as the outer container of an adjacent pair. Consequently, any number of adjacent opening or closing symbols may join together in weld. For example, here are three levels of wrapped function calls:
# default formatting
my (@date_time) = Localtime(
Date_to_Time(
Add_Delta_DHMS(
$year, $month, $day, $hour, $minute, $second,
'0', $offset, '0', '0'
)
)
);
# perltidy -wn
my (@date_time) = Localtime( Date_to_Time( Add_Delta_DHMS(
$year, $month, $day, $hour, $minute, $second,
'0', $offset, '0', '0'
) ) );Notice how the indentation of the inner lines are reduced by two levels in this case. This example also shows the typical result of this formatting, namely it is a sandwich consisting of an initial opening layer, a central section of any complexity forming the "meat" of the sandwich, and a final closing layer. This predictable structure helps keep the compacted structure readable.
The inner sandwich layer is required to be at least one line thick. If this cannot be achieved, welding does not occur. This constraint can cause formatting to take a couple of iterations to stabilize when it is first applied to a script. The --converge flag can be used to insure that the final format is achieved in a single run.
Here is an example illustrating a welded container within a welded containers:
# default formatting
$x->badd(
bmul(
$class->new(
abs(
$sx * int( $xr->num() ) & $sy * int( $yr->num() )
)
),
$m
)
);
# perltidy -wn
$x->badd( bmul(
$class->new( abs(
$sx * int( $xr->num() ) & $sy * int( $yr->num() )
) ),
$m
) );The welded closing tokens are by default on a separate line but this can be modified with the --vertical-tightness-closing=n (-vtc=n) flag (described in the next section). For example, the same example adding -vtc=2 is
# perltidy -wn -vtc=2
$x->badd( bmul(
$class->new( abs(
$sx * int( $xr->num() ) & $sy * int( $yr->num() ) ) ),
$m ) );This format option is quite general but there are some limitations.
One limitation is that any line length limit still applies and can cause long welded sections to be broken into multiple lines.
Also, the stacking of containers defined by this flag have priority over any other container stacking flags. This is because any welding is done first.
When the -wfc flag is set, along with -wn (--weld-nested-containers), perltidy is allowed to weld an opening paren to an inner opening container when they are separated by a hash key and fat comma (=>). for example
# perltidy -wn -wfc
elf->call_method( method_name_foo => {
some_arg1 => $foo,
some_other_arg3 => $bar->{'baz'},
} );This option is off by default.
The -wnxl=s flag provides some control over the types of containers which can be welded. The -wn flag by default is "greedy" in welding adjacent containers. If it welds more types of containers than desired, this flag provides a capability to reduce the amount of welding by specifying a list of things which should not be welded.
The logic in perltidy to apply this is straightforward. As each container token is being considered for joining a weld, any exclusion rules are consulted and used to reject the weld if necessary.
This list is a string with space-separated items. Each item consists of up to three pieces of information: (1) an optional position, (2) an optional preceding type, and (3) a container type.
The only required piece of information is a container type, which is one of '(', '[', '{' or 'q'. The first three of these are container tokens and the last represents a quoted list. For example the string
-wnxl='[ { q'means do NOT include square-brackets, braces, or quotes in any welds. The only unspecified container is '(', so this string means that only welds involving parens will be made.
To illustrate, following welded snippet consists of a chain of three welded containers with types '(' '[' and 'q':
# perltidy -wn
skip_symbols( [ qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
) ] );Even though the qw term uses parens as the quote delimiter, it has a special type 'q' here. If it appears in a weld it always appears at the end of the welded chain.
Any of the container types '[', '{', and '(' may be prefixed with a position indicator which is either '^', to indicate the first token of a welded sequence, or '.', to indicate an interior token of a welded sequence. (Since a quoted string 'q' always ends a chain it does need a position indicator).
For example, if we do not want a sequence of welded containers to start with a square bracket we could use
-wnxl='^['In the above snippet, there is a square bracket but it does not start the chain, so the formatting would be unchanged if it were formatted with this restriction.
A third optional item of information which can be given is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the container. If given, it goes just before the container symbol. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings:
'k' matches if the previous nonblank token is a perl keyword
(such as 'if', 'while'),
'K' matches if 'k' does not: previous token is not a keyword
'f' matches if previous token is a function (not a keyword)
'F' matches if 'f' does not
'w' matches if either 'k' or 'f' match
'W' matches if 'w' does notFor example, compare
# perltidy -wn
if ( defined( $_Cgi_Query{
$Config{'methods'}{'auth'}{'remote'}{'cgi'}{'username'}
} ) )with
# perltidy -wn -wnxl='^K( {'
if ( defined(
$_Cgi_Query{ $Config{'methods'}{'auth'}{'remote'}{'cgi'}
{'username'} }
) )The first case does maximum welding. In the second case the leading paren is retained by the rule (it would have been rejected if preceded by a non-keyword) but the curly brace is rejected by the rule.
Here are some additional example strings and their meanings:
'^(' - the weld must not start with a paren
'.(' - second and later tokens may not be parens
'.w(' - second and later tokens may not be a keyword or call parens
'(' - no parens in a weld
'^K(' - exclude a leading paren preceded by a non-keyword
'.k(' - exclude a secondary paren preceded by a keyword
'[ {' - exclude all brackets and braces
'[ ( ^K{' - exclude all except nested structures like do {{ ... }}These parameters control what shall be called vertical tightness. Here are the main points:
Opening tokens (except for block braces) are controlled by -vt=n, or --vertical-tightness=n, where
-vt=0 always break a line after opening token (default).
-vt=1 do not break unless this would produce more than one
step in indentation in a line.
-vt=2 never break a line after opening tokenYou must also use the -lp (--line-up-parentheses) flag when you use the -vt flag; the reason is explained below.
Closing tokens (except for block braces) are controlled by -vtc=n, or --vertical-tightness-closing=n, where
-vtc=0 always break a line before a closing token (default),
-vtc=1 do not break before a closing token which is followed
by a semicolon or another closing token, and is not in
a list environment.
-vtc=2 never break before a closing token.
-vtc=3 Like -vtc=1 except always break before a closing token
if the corresponding opening token follows an = or =>.The rules for -vtc=1 and -vtc=3 are designed to maintain a reasonable balance between tightness and readability in complex lists.
Different controls may be applied to different token types, and it is also possible to control block braces; see below.
Finally, please note that these vertical tightness flags are merely hints to the formatter, and it cannot always follow them. Things which make it difficult or impossible include comments, blank lines, blocks of code within a list, and possibly the lack of the --line-up-parentheses parameter. Also, these flags may be ignored for very small lists (2 or 3 lines in length).
Here are some examples:
# perltidy -lp -vt=0 -vtc=0
%romanNumerals = (
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
);
# perltidy -lp -vt=1 -vtc=0
%romanNumerals = ( one => 'I',
two => 'II',
three => 'III',
four => 'IV',
);
# perltidy -lp -vt=1 -vtc=1
%romanNumerals = ( one => 'I',
two => 'II',
three => 'III',
four => 'IV', );
# perltidy -vtc=3
my_function(
one => 'I',
two => 'II',
three => 'III',
four => 'IV', );
# perltidy -vtc=3
%romanNumerals = (
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
);In the last example for -vtc=3, the opening paren is preceded by an equals so the closing paren is placed on a new line.
The difference between -vt=1 and -vt=2 is shown here:
# perltidy -lp -vt=1
$init->add(
mysprintf( "(void)find_threadsv(%s);",
cstring( $threadsv_names[ $op->targ ] )
)
);
# perltidy -lp -vt=2
$init->add( mysprintf( "(void)find_threadsv(%s);",
cstring( $threadsv_names[ $op->targ ] )
)
);With -vt=1, the line ending in add( does not combine with the next line because the next line is not balanced. This can help with readability, but -vt=2 can be used to ignore this rule.
The tightest, and least readable, code is produced with both -vt=2 and -vtc=2:
# perltidy -lp -vt=2 -vtc=2
$init->add( mysprintf( "(void)find_threadsv(%s);",
cstring( $threadsv_names[ $op->targ ] ) ) );Notice how the code in all of these examples collapses vertically as -vt increases, but the indentation remains unchanged. This is because perltidy implements the -vt parameter by first formatting as if -vt=0, and then simply overwriting one output line on top of the next, if possible, to achieve the desired vertical tightness. The -lp (--line-up-parentheses) indentation style has been designed to allow this vertical collapse to occur, which is why it is required for the -vt parameter.
The -vt=n and -vtc=n parameters apply to each type of container token. If desired, vertical tightness controls can be applied independently to each of the closing container token types.
The parameters for controlling parentheses are -pvt=n or --paren-vertical-tightness=n, and -pvtc=n or --paren-vertical-tightness-closing=n.
Likewise, the parameters for square brackets are -sbvt=n or --square-bracket-vertical-tightness=n, and -sbvtc=n or --square-bracket-vertical-tightness-closing=n.
Finally, the parameters for controlling non-code block braces are -bvt=n or --brace-vertical-tightness=n, and -bvtc=n or --brace-vertical-tightness-closing=n.
In fact, the parameter -vt=n is actually just an abbreviation for -pvt=n -bvt=n sbvt=n, and likewise -vtc=n is an abbreviation for -pvtc=n -bvtc=n -sbvtc=n.
The -bbvt=n flag is just like the -vt=n flag but applies to opening code block braces.
-bbvt=0 break after opening block brace (default).
-bbvt=1 do not break unless this would produce more than one
step in indentation in a line.
-bbvt=2 do not break after opening block brace.It is necessary to also use either -bl or -bli for this to work, because, as with other vertical tightness controls, it is implemented by simply overwriting a line ending with an opening block brace with the subsequent line. For example:
# perltidy -bli -bbvt=0
if ( open( FILE, "< $File" ) )
{
while ( $File = <FILE> )
{
$In .= $File;
$count++;
}
close(FILE);
}
# perltidy -bli -bbvt=1
if ( open( FILE, "< $File" ) )
{ while ( $File = <FILE> )
{ $In .= $File;
$count++;
}
close(FILE);
}By default this applies to blocks associated with keywords if, elsif, else, unless, for, foreach, sub, while, until, and also with a preceding label. This can be changed with the parameter -bbvtl=string, or --block-brace-vertical-tightness-list=string, where string is a space-separated list of block types. For more information on the possible values of this string, see "Specifying Block Types"
For example, if we want to just apply this style to if, elsif, and else blocks, we could use perltidy -bli -bbvt=1 -bbvtl='if elsif else'.
There is no vertical tightness control for closing block braces; with one exception they will be placed on separate lines. The exception is that a cascade of closing block braces may be stacked on a single line. See --stack-closing-block-brace.
The -sot flag tells perltidy to "stack" opening tokens when possible to avoid lines with isolated opening tokens.
For example:
# default
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);
# -sot
$opt_c = Text::CSV_XS->new( {
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);For detailed control of individual closing tokens the following controls can be used:
-sop or --stack-opening-paren
-sohb or --stack-opening-hash-brace
-sosb or --stack-opening-square-bracket
-sobb or --stack-opening-block-braceThe flag -sot is an abbreviation for -sop -sohb -sosb.
The flag -sobb is an abbreviation for -bbvt=2 -bbvtl='*'. This will case a cascade of opening block braces to appear on a single line, although this an uncommon occurrence except in test scripts.
The -sct flag tells perltidy to "stack" closing tokens when possible to avoid lines with isolated closing tokens.
For example:
# default
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);
# -sct
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
} );The -sct flag is somewhat similar to the -vtc (--vertical-tightness-closing flags, and in some cases it can give a similar result. The difference is that the -vtc flags try to avoid lines with leading opening tokens by "hiding" them at the end of a previous line, whereas the -sct flag merely tries to reduce the number of lines with isolated closing tokens by stacking them but does not try to hide them. For example:
# -vtc=2
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1, } );For detailed control of the stacking of individual closing tokens the following controls can be used:
-scp or --stack-closing-paren
-schb or --stack-closing-hash-brace
-scsb or --stack-closing-square-bracket
-scbb or --stack-closing-block-braceThe flag -sct is an abbreviation for stacking the non-block closing tokens, -scp -schb -scsb.
Stacking of closing block braces, -scbb, causes a cascade of isolated closing block braces to be combined into a single line as in the following example:
# -scbb:
for $w1 (@w1) {
for $w2 (@w2) {
for $w3 (@w3) {
for $w4 (@w4) {
push( @lines, "$w1 $w2 $w3 $w4\n" );
} } } }To simplify input even further for the case in which both opening and closing non-block containers are stacked, the flag -sac or --stack-all-containers is an abbreviation for --stack-opening-tokens --stack-closing-tokens.
Please note that if both opening and closing tokens are to be stacked, then the newer flag --weld-nested-containers may be preferable because it insures that stacking is always done symmetrically. It also removes an extra level of unnecessary indentation within welded containers. It is able to do this because it works on formatting globally rather than locally, as the --stack-opening-tokens and --stack-closing-tokens flags do.
Four command line parameters provide some control over whether a line break should be before or after specific token types. Two parameters give detailed control:
-wba=s or --want-break-after=s, and
-wbb=s or --want-break-before=s.
These parameters are each followed by a quoted string, s, containing a list of token types (separated only by spaces). No more than one of each of these parameters should be specified, because repeating a command-line parameter always overwrites the previous one before perltidy ever sees it.
By default, perltidy breaks after these token types: % + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
And perltidy breaks before these token types by default: . << >> -> && || //
To illustrate, to cause a break after a concatenation operator, '.', rather than before it, the command line would be
-wba="."As another example, the following command would cause a break before math operators '+', '-', '/', and '*':
-wbb="+ - / *"These commands should work well for most of the token types that perltidy uses (use --dump-token-types for a list). Also try the -D flag on a short snippet of code and look at the .DEBUG file to see the tokenization. However, for a few token types there may be conflicts with hardwired logic which cause unexpected results. One example is curly braces, which should be controlled with the parameter --opening-brace-on-new-line provided for that purpose.
WARNING Be sure to put these tokens in quotes to avoid having them misinterpreted by your command shell.
Two additional parameters are available which, though they provide no further capability, can simplify input are:
-baao or --break-after-all-operators,
-bbao or --break-before-all-operators.
The -baao sets the default to be to break after all of the following operators:
% + - * / x != == >= <= =~ !~ < > | &
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
. : ? && || and or err xorand the -bbao flag sets the default to break before all of these operators. These can be used to define an initial break preference which can be fine-tuned with the --want-break-after and --want-break-before flags. For example, to break before all operators except an = one could use -bbao -wba='=' rather than listing every single perl operator except = on a -wbb flag.
This flag controls whether or not a line break occurs after a label. There are three possible values for n:
-bal=0 break if there is a break in the input [DEFAULT]
-bal=1 always break after a label
-bal=2 never break after a labelFor example,
# perltidy -bal=1
RETURN:
return;
# perltidy -bal=2
RETURN: return;Perltidy attempts to format lists of comma-separated values in tables which look good. Its default algorithms usually work well, but sometimes they don't. In this case, there are several methods available to control list formatting.
A very simple way to prevent perltidy from changing the line breaks within a comma-separated list of values is to insert a blank line, comment, or side-comment anywhere between the opening and closing parens (or braces or brackets). This causes perltidy to skip over its list formatting logic. (The reason is that any of these items put a constraint on line breaks, and perltidy needs complete control over line breaks within a container to adjust a list layout). For example, let us consider
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);The default formatting, which allows a maximum line length of 80, will flatten this down to one line:
# perltidy (default)
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );This formatting loses the nice structure. The original line breaks can be retained by adding comment or a blank line somewhere between the two parens. For example,
my @list = (
1, # a side comment forces the original breakpoints to be kept
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,
);We could achieve the same result with a blank line or full comment anywhere between the opening and closing parens. Vertical alignment of the list items will still occur if possible. The blank line method is shown here:
my @list = (
1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,
);For another possibility see the -fs flag in "Skipping Selected Sections of Code".
The -boc flag is another way to prevent comma-separated lists from being reformatted. Using -boc on the above example, plus additional flags to retain the original style, yields
# perltidy -boc -lp -pt=2 -vt=1 -vtc=1
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);A disadvantage of this flag compared to the methods discussed above is that all tables in the file must already be nicely formatted.
A trailing comma is an optional comma following the last item of a list. The -btct=s tells perltidy to end a line at selected trailing commas. The string s selects the trailing commas, as follows:
s=1 or '*' : every trailing comma
s=m a trailing comma in a multiline list
s=b a bare trailing comma
s=0 noneFor example, given the following input
$w->bind(
'<Page_Down>' => xx,
);The default formatting would flatten this into a single line. But the container can be kept open with
# perltidy -btct='b'
$w->bind(
'<Page_Down>' => xx,
);This can be particularly useful for short function calls like this, where the default perltidy formatting does not keep the container open.
The options s=m and s=1 can be used to open up containers with non-bare trailing commas. For example, given this input
$w->bind( '<Page_Down>' => xx, );we can break it open with
# perltidy -btct=1
$w->bind(
'<Page_Down>' => xx,
);Afterwards, we could switch to -btct='b' since the trailing comma is now bare. But the -btct parameter must be retained in this case because otherwise this small list will be flattened the next time it is formatted.
This logic can be restricted to specific container types by including an opening token ahead of the letter in the above table. For example
-btct='(b'means that this operation should only apply to bare trailing commas within parentheses.
For parentheses, an additional item of information which can be given is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the opening paren. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings for matching whatever precedes an opening paren:
'k' matches if the previous nonblank token is a perl keyword
(such as 'if', 'while'),
'K' matches if 'k' does not: previous token is not a keyword
'f' matches if previous token is a function (not a keyword)
'F' matches if 'f' does not.
'w' matches if either 'k' or 'f' match.
'W' matches if 'w' does not.These are the same codes used for --line-up-parentheses-inclusion-list. For example,
-btct='f(b'means that bare trailing commas in function call lists in the input stream should be followed by line breaks in the formatted output stream.
The section "Adding and Deleting Commas" describes additional controls for working with trailing commas. These can be combined with the -break-trailing-comma-types parameter for additional control of list formatting.
If n is a positive number, and the computed number of fields for any table exceeds n, then it will be reduced to n. This parameter might be used on a small section of code to force a list to have a particular number of fields per line, and then either the -boc flag could be used to retain this formatting, or a blank line or comment could be introduced somewhere to freeze the formatting in future applications of perltidy. For example
# perltidy -mft=2
@month_of_year = (
'Jan', 'Feb',
'Mar', 'Apr',
'May', 'Jun',
'Jul', 'Aug',
'Sep', 'Oct',
'Nov', 'Dec'
);The default value is n=0, which does not place a limit on the number of fields in a table.
A comma which follows a comma arrow, '=>', is given special consideration. In a long list, it is common to break at all such commas. This parameter can be used to control how perltidy breaks at these commas. (However, it will have no effect if old comma breaks are being forced because -boc is used). The possible values of n are:
n=0 break at all commas after =>
n=1 stable: break at all commas after => if container is open,
EXCEPT FOR one-line containers
n=2 break at all commas after =>, BUT try to form the maximum
one-line container lengths
n=3 do not treat commas after => specially at all
n=4 break everything: like n=0 but ALSO break a short container with
a => not followed by a comma when -vt=0 is used
n=5 stable: like n=1 but ALSO break at open one-line containers when
-vt=0 is used (default)For example, given the following single line, perltidy by default will not add any line breaks because it would break the existing one-line container:
bless { B => $B, Root => $Root } => $package;Using -cab=0 will force a break after each comma-arrow item:
# perltidy -cab=0:
bless {
B => $B,
Root => $Root
} => $package;If perltidy is subsequently run with this container broken, then by default it will break after each '=>' because the container is now broken. To reform a one-line container, the parameter -cab=2 could be used.
The flag -cab=3 can be used to prevent these commas from being treated specially. In this case, an item such as "01" => 31 is treated as a single item in a table. The number of fields in this table will be determined by the same rules that are used for any other table. Here is an example.
# perltidy -cab=3
my %last_day = (
"01" => 31, "02" => 29, "03" => 31, "04" => 30,
"05" => 31, "06" => 30, "07" => 31, "08" => 31,
"09" => 30, "10" => 31, "11" => 30, "12" => 31
);This option tells perltidy to format a qw list which is delimited with parentheses as if it were a function call whose call args are a list of quoted items. Normally, a qw list is output verbatim except for an adjustment of leading whitespace to indicate the indentation level. For example, here is an example of the default formatting of a poorly formatted qw list:
# perltidy
@fields = qw( $st_dev $st_ino $st_mode $st_nlink $st_uid
$st_gid $st_rdev $st_size $st_atime $st_mtime $st_ctime
$st_blksize $st_blocks);If we format with -qwaf then the result will be:
# perltidy -qwaf
@fields = qw(
$st_dev $st_ino $st_mode $st_nlink
$st_uid $st_gid $st_rdev $st_size
$st_atime $st_mtime $st_ctime $st_blksize
$st_blocks
);The way this works is that just before formatting begins, the tokens of the qw text are replaced with the tokens of an equivalent function call with a comma-separated list of quoted items as call args. Then it is formatted like any other list. Special comma tokens are employed which have no display text, so when the code is eventually displayed it remains a valid qw quote.
Some things to note are:
This only works for qw quotes which begin with qw(, with no space before the paren.
If the option --space-function-paren is employed, it is ignored for these special function calls because it would deactivate them.
Otherwise the various formatting control flags operate on these lists the same as for other comma-separated lists. In particular, note that if --break-at-old-comma-breakpoints, or -boc, is set, then the old line break locations will be retained. And old line breaks will be retained if there are any blank lines between the opening and closing parens.
Before using this option for the first time, it is a good idea to scan the code and decide if any lists have a special order which should be retained. This can be accomplished for example by changing the quote delimiters to something other than parens, or by inserting a blank line as discussed at the start of this section.
This option causes repeated commas to be removed. For example, given this list with a repeated comma
ignoreSpec( $file, "file",, \%spec, \%Rspec );we can remove it with -drc
# perltidy -drc:
ignoreSpec( $file, "file", \%spec, \%Rspec );This parameter also deletes repeated fat commas, '=>'. The complete list of actions taken when this flag is set are as follows:
Repeated commas like ',,' are removed with a warning.
Repeated fat commas like '=> =>' are removed with a warning.
The combination '=>,' produces a warning but is not changed (it is likely an error but only its author would know how to fix it).
The remaining combination ',=>' (sometimes called a 'winking fat comma') is ignored by this parameter.
These warnings are only output if the --warning-output, or -w, flag is set.
This option is on by default. Use -ndrc to turn it off.
A trailing comma is a comma following the last item of a list. Perl allows trailing commas but they are not required. Including them can sometimes simplify the maintenance of large or complex lists, and help display structure. But they may not be appropriate in all lists, for example in a list which always has just one term. By default, perltidy does not add or delete trailing commas, but it is possible to manipulate them with the following set of related parameters:
--want-trailing-commas=s, -wtc=s - defines where trailing commas are wanted (the style)
--add-trailing-commas, -atc - gives permission to add trailing commas to match the style wanted
--delete-trailing-commas, -dtc - gives permission to delete trailing commas which do not match the style wanted
The parameter --want-trailing-commas=s, or -wtc=s, defines a preferred style. The string s indicates which lists should get trailing commas, as follows:
s=1 or '*' : every list
s=m a multiline list
s=b a multiline list, bare trailing comma
s=i a multiline list, bare trailing comma, about one comma per line
s=h a multiline list, bare trailing comma, about one key=>value
pair per line
s=0 : no list
s=' ' or not defined : leave trailing commas unchanged [DEFAULT]where:
A list here is basically taken to be a container of items (parens, square brackets, or braces), which is not a code block, which contains one or more commas or fat commas. These parameters only apply to something that fits this definition of a list.
A paren-less list of parameters is not a list by this definition, so these parameters do not apply to a paren-less list.
A multiline list is a list for which the opening and closing brackets on different lines.
A bare trailing comma is a comma which is at the end of a line. That is, the closing container token follows on a different line. So a list with a bare trailing comma is a special case of a multiline list.
In fact the above options for trailing commas can be seen as a hierarchy of nesting sets which can be expressed as
1 > m > b > i > h > 0This indicates that multiline trailing commas m are a subset of all trailing commas, and bare trailing commas b are a subset of all multiline trailing commas, and so on.
This parameter by itself only indicates where trailing commas are wanted. Perltidy only adds these trailing commas if permission is granted by setting the flag --add-trailing-commas, or -atc. And perltidy only removes unwanted trailing commas if the flag --delete-trailing-commas, or -dtc is set.
Here are some example parameter combinations and their meanings
-wtc=0 -dtc : delete all trailing commas
-wtc=1 -atc : add trailing commas to all lists
-wtc=m -atc : add trailing commas to all multiline lists
(single line lists remain unchanged)
-wtc=b -atc : add commas so that all lists whose closing
bracket starts a new line have trailing commas
-wtc=b -dtc : all trailing commas which are not bare
(not followed by a newline) get deleted.
-wtc=b -atc -dtc : do both of the above operations so that
all trailing commas are bareFor example, given the following input
$wine_list = $top->Box(
"-length" => 5,
"-width" => 3
)->select( "red", "white", "gold", );we have
# perltidy -wtc=b -atc -dtc
$wine_list = $top->Box(
"-length" => 5,
"-width" => 3,
)->select( "red", "white", "gold" );A comma was added after the 3, since it is bare, and a comma was removed after "gold", since it not bare.
It is possible to apply a different style to each type of container token by including an opening token ahead of the style character in the above table. For example
-wtc='(m [b'means that lists within parens should have multiline trailing commas, and that lists within square brackets have bare trailing commas. Since there is no specification for curly braces in this example, their trailing commas would remain unchanged.
For parentheses, an additional item of information which can be given is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the opening paren. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings for matching whatever precedes an opening paren:
'k' matches if the previous nonblank token is a perl keyword
(such as 'if', 'while'),
'K' matches if 'k' does not: previous token is not a keyword
'f' matches if previous token is a function (not a keyword)
'F' matches if 'f' does not.
'w' matches if either 'k' or 'f' match.
'W' matches if 'w' does not.These are the same codes used for --line-up-parentheses-inclusion-list. For example,
-wtc='w(m'means that trailing commas are wanted for multiline parenthesized lists following a function call or keyword.
Finally, a leading + can be placed on any term to indicate that it only applies when adding commas. A leading - indicates that it only applies when deleting commas. For example,
-wtc='+h -b' -atc -dtcmeans that missing trailing commas should be added to lists of key => value pairs, and trailing commas which are not bare should be removed. No other changes are made. When both plus and minus terms are used like this, they must not be in conflict. There is no conflict in this example because the trailing comma locations of the key=>value pairs selected by the +h term are a subset of all bare trailing commas, and thus will not be deleted by the -b term. The general rule is that the letter of the plus term should occur after the letter of the minus term in the hierarchical nesting order, 1 > m > b > i > h > 0.
Some points to note regarding adding and deleting trailing commas:
It is recommended to also use the --converge parameter when adding and/or deleting trailing commas, especially if the formatter may be making other line break changes at the same time. The reason is that the decision regarding whether or not a list is multiline or bare is made based on the input stream if only one iteration is made, which is the default.
When iterations are requested with the --converge parameter, any comma deletion operations are postponed until the start of the second iteration, after most changes in line breaks have been made.
To illustrate, if we start with
f(
a => 1,
b => 2, );and attempt to delete non-bare commas,
# perltidy -wtc=b -dtc
f(
a => 1,
b => 2
);we delete a comma which has become bare, which is not what is wanted. This happened because the change was based on the starting rather than the final line breaks. Running with --converge gives the desired result:
# perltidy -wtc=b -dtc --converge
f(
a => 1,
b => 2,
);because comma changes are based on the line breaks after the first iteration.
A parameter --delay-trailing-comma-operations, or -dtco, is available to control this behavior if desired. Negating this parameter, with -ndtco, tells perltidy to always use the starting state to make decisions regarding comma addition and deletion, even when iterations are requested. This should not normally be necessary.
Perltidy does not add a trailing comma in some edge cases which appear to be near a stability limit. So if a comma is unexpectedly not added, this is probably the reason.
If the parameter --break-at-trailing-comma-types, or -btct. is also employed, it operates on the state after any adding or deleting of commas. And it will allow trailing commas to be added in most edge cases. For example, given the following input text
plot(
'g', Canvas => $overview_canvas
);formatting with -wtc=f(b) -atc will not add a trailing comma because the list will be flattened and the comma will not remain bare. But we can add a trailing comma, and keep the container open, with
# perltidy -wtc='f(b' -atc -btct='f(b'
plot(
'g', Canvas => $overview_canvas,
);As another example, given the same text on a single line without a trailing comma
plot( 'g', Canvas => $overview_canvas );we can add a trailing comma and break the container open with
# perltidy -wtc=1 -atc -btct=1
plot(
'g', Canvas => $overview_canvas,
);After that, we could use -btct='f(b' to keep the container open.
When using these parameters for the first time it is a good idea to practice on some test scripts and verify that the results are as expected.
Special Considerations for Lone Trailing Commas
Adding or deleting the only comma in a list can have some implications which need to be explained and possibly controlled. Two additional controls are available for these lone commas:
--add-lone-trailing-commas, -altc - gives permission to add a comma if it will be the only comma. This is on by default and explained below.
--delete-lone-trailing-commas, -dltc - gives permission to delete the only comma in a list. This is on by default and explained below.
One issue with deleting a lone comma is that if it is deleted, then it might not be possible add it back automatically since perltidy uses the existence of commas to help locate containers where commas are appropriate. For example, given
my ( $self, ) = @_;and if we remove the comma with
# perltidy -wtc=m -dtc
my ( $self ) = @_;then we cannot use the trailing comma controls to add this comma back. The parameter --delete-lone-trailing-commas allows such a comma to be deleted, and is on by default, but can be turned off to prevent this. This might be useful if one is experimenting with formatting options and wants to restrict testing to operations which are reversible. Note that this parameter is a fine-tuning control for --delete-trailing-commas which must also be set for it to have any effect.
However, if a single item in a list is itself is a list with multiple lines, such as the item in braces here
$self->make_grammar(
{
iterator => $self->_iterator,
parser => $self,
}
);then perltidy can add and/or delete a lone comma:
# perltidy -atc -wtc=b
$self->make_grammar(
{
iterator => $self->_iterator,
parser => $self,
},
);But it turns out that these cases usually coincide with situations where the --weld-nested-containers, or -wn, parameter would apply, and adding such commas can block welding. For example, the -wn parameter would succeed on the first of the above snippets, but it would fail on the second because of the added trailing comma.
The parameter --add-lone-trailing-commas, or -altc allows these commas to be added, provide that --add-trailing-commas is also set. It is on by default. Users of -wn may want to turn it off with --noadd-lone-trailing-commas, -naltc to prevent such commas from being added.
If such commas do get added, then can be removed to allow welding with the control described in the next section.
If the closing tokens of two nested containers are separated by a comma, then welding requested with --weld-nested-containers cannot occur. Any commas in this situation are optional trailing commas and can be removed with -dwic. For example, a comma in this script prevents welding:
# perltidy -wn
$self->make_grammar(
{
iterator => $self->_iterator,
parser => $self,
},
);Adding -dwic removes the comma and allows welding:
# perltidy -wn -dwic
$self->make_grammar( {
iterator => $self->_iterator,
parser => $self,
} );This feature is off by default. Here are some points to note about the -dwic parameter
This operation is not always reversible, so please check results of using this parameter carefully.
Removing this type of isolated trailing comma is necessary for welding to be possible, but not sufficient. So welding will not always occur where these commas are removed.
This operation is independent of --add-trailing-commas and --delete-trailing-commas. If it conflicts with any of those settings, it has priority.
In the following expression, the arrow operator '->' between the closing and opening brackets of hash keys and array indexes are optional:
return $self->{'commandline'}->{'args'}->[0]->[0]->{'hgroups'};These will be called interbracket arrows here, for lack of a better term. Perltidy will not change them by default, but they can be added or removed with the following parameters.
This parameter deletes interbracket arrows. Applied to the above example we have
# perltidy -dia
return $self->{'commandline'}{'args'}[0][0]{'hgroups'};By default this applies to all interbracket arrows, but selective deletion is possible with controls described below.
This parameter adds interbracket arrows. Applied to the line of code above, we get back the original line.
# perltidy -aia
return $self->{'commandline'}->{'args'}->[0]->[0]->{'hgroups'};Selective changes can be made with controls described below.
By default the -add- and -delete- parameters apply to all interbracket arrows.
An optional style can be specified with this parameter string s. In that case the parameters --add-interbracket-arrows and --delete-interbracket-arrows only apply where they would bring the formatting into agreement with the specified style. They may both be used in a single run if a mixed style is specified since there is no conflict.
The style string s gives a graphical description of the desired style. It lists up to four possible pairs of bracket types with an optional arrow between them. For example:
-ias='][ }->{'This means no arrows are wanted between '][' but arrows should be between '}{'. And it means that the unlisted pairs ']{' and '}[' should remain unchanged, either with or without arrows.
In this particular example, if the parameter --delete-interbracket-arrows is used, then only arrows like ']->[' will be deleted, since they are the only ones which disagree with the style.
And likewise, if --add-interbracket-arrows is used, then arrows will only be inserted between brackets like '}{' to bring the formatting into conformity with the style in this example.
Spaces in the string s are optional. They are ignored when the expression is parsed.
The style corresponding to all possible arrows is
-ias=']->[ ]->{ }->[ }->{'For convenience, this may also be requested with -ias=1 or -ias='*'.
The style corresponding to no interbracket arrows is
-ias='] [ ] { } [ } {'which may also be requested with -ias=0.
If this parameter is set, then a message is written to the error file in the following cases:
If an arrow is added or deleted by an add or delete command.
If a style is defined and an arrow would have been added or deleted if requested. So for example, the command
perltidy -wia -ias=']['will show where a file has arrows like ]->[' since they do not match the style, but no changes will be made because the delete command -dia has not been given. And
perltidy -wia -ias=0will warn if any arrows exist, since the flag -ias=0 means that no arrows are wanted.
This parameter makes it possible to skip adding or deleting arrows following a container which is complex in some sense. Three levels of complexity can be specified with the integer n, as follows:
n=0 the left container must contain be a single thing (token)
n=1 the left container must not contain other containers [DEFAULT]
n=2 the left container may contain anythingSome examples:
# Container complexity
{'commandline'} 0 single token OK by default
{ $type . $name } 1 multiple tokens OK by default
[ $plot{'x-axis'} - 1 ] 2 contains a container SKIPPED by defaultSo, with the default complexity level of 1, an arrow could be added or deleted following the first two of these containers but not the third.
Some points to consider when working with these parameters are:
There are no known bugs, but this is a relatively new feature. So please carefully check file differences and run tests when interbracket arrows are added or removed.
For some unusual spacing parameters, it could take an extra iteration for the spaces between brackets to reach their final state after arrows are added or deleted.
Any comments between brackets will prevent the adding and deleting of arrows.
A defensive programming technique is to require that every if-elsif- chain be terminated with an else block, even though it is not strictly required. This helps insure that there are no holes in the logic.
For example, consider the following snippet:
my $type = get_cards();
if ( $type = 1 ) { action("hold 'em") }
elsif ( $type = 2 ) { action("fold 'em") }
elsif ( $type = 3 ) { action("walk away") }What if the variable $type is some other value? It might have been obvious that this was okay when the code was first written, but it might not be so clear when the code is reviewed a few years later. A terminal else block with a comment would help clarify things.
The parameters in this section can help by either issuing a warning if an else is missing, or even inserting an empty else block where one is missing, or both.
This flag tells perltidy to issue a warning if a program is missing a terminal else block. The default is not to issue such a warning.
This flag tells perltidy to output an empty else block wherever a program is missing a terminal else block. To get a warning when this is done you should also set -wme. The default is not to add missing else blocks.
This string is a side comment which will be written to highlight a new empty else block. The default is:
-amec='##FIXME - added with perltidy -ame'For example, on the above example we can add a missing else and also get a warning notice with:
# perltidy -ame -wme
my $type = get_cards();
if ( $type == 1 ) { action("hold 'em") }
elsif ( $type == 2 ) { action("fold 'em") }
elsif ( $type == 3 ) { action("walk away") }
else {
##FIXME - added with perltidy -ame
}Any ##FIXME comments created in this way should be reviewed and changed appropriately. For example, one might decide that the code fine as is, and just change the comment to indicate that nothing has been overlooked:
my $type = get_cards();
if ( $type == 1 ) { action("hold 'em") }
elsif ( $type == 2 ) { action("fold 'em") }
elsif ( $type == 3 ) { action("walk away") }
else {
# ok - no worries
}Or maybe a deeper analysis reveals that something was missed:
my $type = get_cards();
if ( $type == 1 ) { action("hold 'em") }
elsif ( $type == 2 ) { action("fold 'em") }
elsif ( $type == 3 ) { action("walk away") }
else { action("run") }Sometimes it turns out that the else block should not reachable, in which case an error exit might be appropriate. In any case, having the else block can improve code maintainability.
Several additional parameters are available for controlling the extent to which line breaks in the input script influence the output script. In most cases, the default parameter values are set so that, if a choice is possible, the output style follows the input style. For example, if a short logical container is broken in the input script, then the default behavior is for it to remain broken in the output script.
Most of the parameters in this section would only be required for a one-time conversion of a script from short container lengths to longer container lengths. The opposite effect, of converting long container lengths to shorter lengths, can be obtained by temporarily using a short maximum line length.
By default, if a logical expression is broken at a &&, ||, and, or or, then the container will remain broken. Also, breaks at internal keywords if and unless will normally be retained. To prevent this, and thus form longer lines, use -nbol.
Please note that this flag does not duplicate old logical breakpoints. They are merely used as a hint with this flag that a statement should remain broken. Without this flag, perltidy will normally try to combine relatively short expressions into a single line.
For example, given this snippet:
return unless $cmd = $cmd || ($dot
&& $Last) || &prompt('|');
# perltidy -bol [default]
return
unless $cmd = $cmd
|| ( $dot
&& $Last )
|| &prompt('|');
# perltidy -nbol
return unless $cmd = $cmd || ( $dot && $Last ) || &prompt('|');By default, a method call arrow -> is considered a candidate for a breakpoint, but method chains will fill to the line width before a break is considered. With -bom, breaks before the arrow are preserved, so if you have pre-formatted a method chain:
# perltidy -bom
$Document
->schild(0)
->schildren();the flag -bom will keep these line breaks, rather than become this:
# perltidy [DEFAULT]
$Document->schild(0)->schildren();This flag will also look for and keep a 'cuddled' style of calls, in which lines begin with a closing paren followed by a call arrow, as in this example:
# perltidy -bom
my $q = $rs->related_resultset(
'CDs'
)->related_resultset(
'Tracks'
)->search(
{
'track.id' => { -ident => 'none_search.id' },
}
)->as_query;Semicolons are normally placed at the end of a statement. This means that formatted lines do not normally begin with semicolons. If the input stream has some lines which begin with semicolons, these can be retained by setting this flag. For example, consider the following two-line input snippet:
$z = sqrt($x**2 + $y**2)
;The default formatting will be:
$z = sqrt( $x**2 + $y**2 );Using the -bos flag keeps the isolated semicolon:
# perltidy -bos
$z = sqrt( $x**2 + $y**2 )
;The extra continuation indentation spaces on the semicolon can be removed by also setting --noindent-leading-semicolon.
# perltidy -bos -nils
$z = sqrt( $x**2 + $y**2 )
;The default is not to do this, -nbos.
By default, perltidy will retain a breakpoint before keywords which may return lists, such as sort and map. This allows chains of these operators to be displayed one per line. Use -nbok to prevent retaining these breakpoints.
By default, if a conditional (ternary) operator is broken at a :, then it will remain broken. To prevent this, and thereby form longer lines, use -nbot.
By default, if an attribute list is broken at a : in the source file, then it will remain broken. For example, given the following code, the line breaks at the ':'s will be retained:
my @field
: field
: Default(1)
: Get('Name' => 'foo') : Set('Name');If the attributes are on a single line in the source code then they will remain on a single line if possible.
To prevent this, and thereby always form longer lines, use -nboa.
It is possible to override the choice of line breaks made by perltidy, and force it to follow certain line breaks in the input stream, with these two parameters:
-kbb=s or --keep-old-breakpoints-before=s, and
-kba=s or --keep-old-breakpoints-after=s
These parameters are each followed by a quoted string, s, containing a list of token types (separated only by spaces). No more than one of each of these parameters should be specified, because repeating a command-line parameter always overwrites the previous one before perltidy ever sees it.
For example, -kbb='=>' means that if an input line begins with a '=>' then the output script should also have a line break before that token.
For example, given the script:
method 'foo'
=> [ Int, Int ]
=> sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
# perltidy [default]
method 'foo' => [ Int, Int ] => sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
# perltidy -kbb='=>'
method 'foo'
=> [ Int, Int ]
=> sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};For the container tokens '{', '[' and '(' and, their closing counterparts, use the token symbol. Thus, the command to keep a break after all opening parens is:
perltidy -kba='('It is possible to be more specific in matching parentheses by preceding them with a letter. The possible letters are 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings (these are the same as used in the --weld-nested-exclusion-list and --line-up-parentheses-exclusion-list parameters):
'k' matches if the previous nonblank token is a perl keyword
(such as 'if', 'while'),
'K' matches if 'k' does not: previous token is not a keyword
'f' matches if previous token is a function (not a keyword)
'F' matches if 'f' does not.
'w' matches if either 'k' or 'f' match.
'W' matches if 'w' does not.So for example the the following parameter will keep breaks after opening function call parens:
perltidy -kba='f('NOTE: A request to break before an opening container, such as -kbb='(', will be silently ignored because it can lead to formatting instability. Likewise, a request to break after a closing container, such as -kba=')', will also be silently ignored.
Use this flag to tell perltidy to ignore existing line breaks to the maximum extent possible. This will tend to produce the longest possible containers, regardless of type, which do not exceed the line length limit. But please note that this parameter has priority over all other parameters requesting that certain old breakpoints be kept.
To illustrate, consider the following input text:
has subcmds => (
is => 'ro',
default => sub { [] },
);The default formatting will keep the container broken, giving
# perltidy [default]
has subcmds => (
is => 'ro',
default => sub { [] },
);If old breakpoints are ignored, the list will be flattened:
# perltidy -iob
has subcmds => ( is => 'ro', default => sub { [] }, );Besides flattening lists, this parameter also applies to lines broken at certain logical breakpoints such as 'if' and 'or'.
Even if this is parameter is not used globally, it provides a convenient way to flatten selected lists from within an editor.
Use the -kis flag to prevent breaking at a semicolon if there was no break there in the input file. Normally perltidy places a newline after each semicolon which terminates a statement unless several statements are contained within a one-line brace block. To illustrate, consider the following input lines:
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;The default is to break after each statement, giving
dbmclose(%verb_delim);
undef %verb_delim;
dbmclose(%expanded);
undef %expanded;With perltidy -kis the multiple statements are retained:
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;The statements are still subject to the specified value of maximum-line-length and will be broken if this maximum is exceeded.
Blank lines can improve the readability of a script if they are carefully placed. Perltidy has several commands for controlling the insertion, retention, and removal of blank lines.
Set -fbl if you want to the blank lines in your script to remain exactly as they are. The rest of the parameters in this section may then be ignored. (Note: setting the -fbl flag is equivalent to setting -mbl=0 and -kbl=2).
A blank line will be introduced before a full-line comment. This is the default. Use -nbbc or --noblanks-before-comments to prevent such blank lines from being introduced.
The parameter -blbs=n requests that least n blank lines precede a sub definition which does not follow a comment and which is more than one-line long. The default is -blbs=1. BEGIN and END blocks are included.
The requested number of blanks statement will be inserted regardless of the value of --maximum-consecutive-blank-lines=n (-mbl=n) with the exception that if -mbl=0 then no blanks will be output.
This parameter interacts with the value k of the parameter --maximum-consecutive-blank-lines=k (-mbl=k) as follows:
1. If -mbl=0 then no blanks will be output. This allows all blanks to be suppressed with a single parameter. Otherwise,
2. If the number of old blank lines in the script is less than n then additional blanks will be inserted to make the total n regardless of the value of -mbl=k.
3. If the number of old blank lines in the script equals or exceeds n then this parameter has no effect, however the total will not exceed value specified on the -mbl=k flag.
The parameter -blbp=n requests that least n blank lines precede a package which does not follow a comment. The default is -blbp=1.
This parameter interacts with the value k of the parameter --maximum-consecutive-blank-lines=k (-mbl=k) in the same way as described for the previous item -blbs=n.
For compatibility with previous versions, -bbs or --blanks-before-subs is equivalent to -blbp=1 and -blbs=1.
Likewise, -nbbs or --noblanks-before-subs is equivalent to -blbp=0 and -blbs=0.
A blank line will be introduced before blocks of coding delimited by for, foreach, while, until, and if, unless, in the following circumstances:
The block is not preceded by a comment.
The block is not a one-line block.
The number of consecutive non-blank lines at the current indentation depth is at least -lbl (see next section).
This is the default. The intention of this option is to introduce some space within dense coding. This is negated with -nbbb or --noblanks-before-blocks.
This controls how often perltidy is allowed to add blank lines before certain block types (see previous section). The default is 8. Entering a value of 0 is equivalent to entering a very large number.
This control places a minimum of i blank lines after a line which ends with an opening block brace of a specified type. By default, this only applies to the block of a named sub, but this can be changed (see -blaol below). The default is not to do this (i=0).
Please see the note below on using the -blao and -blbc options.
This control places a minimum of i blank lines before a line which begins with a closing block brace of a specified type. By default, this only applies to the block of a named sub, but this can be changed (see -blbcl below). The default is not to do this (i=0).
The parameter s is a list of block type keywords to which the flag -blao should apply. The section "Specifying Block Types" explains how to list block types.
This parameter is a list of block type keywords to which the flag -blbc should apply. The section "Specifying Block Types" explains how to list block types.
These blank line controls introduce a certain minimum number of blank lines in the text, but the final number of blank lines may be greater, depending on values of the other blank line controls and the number of old blank lines. A consequence is that introducing blank lines with these and other controls cannot be exactly undone, so some experimentation with these controls is recommended before using them.
For example, suppose that for some reason we decide to introduce one blank space at the beginning and ending of all blocks. We could do this using
perltidy -blao=2 -blbc=2 -blaol='*' -blbcl='*' filenameNow suppose the script continues to be developed, but at some later date we decide we don't want these spaces after all. We might expect that running with the flags -blao=0 and -blbc=0 will undo them. However, by default perltidy retains single blank lines, so the blank lines remain.
We can easily fix this by telling perltidy to ignore old blank lines by including the added parameter --keep-old-blank-lines=0 and rerunning. Then the unwanted blank lines will be gone. However, this will cause all old blank lines to be ignored, perhaps even some that were added by hand to improve formatting. So please be cautious when using these parameters.
This parameter specifies the maximum number of consecutive blank lines which will be output within code sections of a script. The default is n=1. If the input file has more than n consecutive blank lines, the number will be reduced to n except as noted above for the --blank-lines-before-subs and --blank-lines-before-subs parameters. If n=0 then no blank lines will be output (unless all old blank lines are retained with the --keep-old-blank-lines=2 flag of the next section).
This flag obviously does not apply to pod sections, here-documents, and quotes.
The -kbl=n flag gives you control over how your existing blank lines are treated.
The possible values of n are:
n=0 ignore all old blank lines
n=1 stable: keep old blanks, but limited by the B<-mbl=n> flag
n=2 keep all old blank lines, regardless of the B<-mbl=n> flagThe default is n=1.
This is equivalent to --keep-old-blank-lines=0 and is included for compatibility with previous versions.
This is equivalent to --keep-old-blank-lines=1 and is included for compatibility with previous versions.
Controls for blank lines around lines of consecutive keywords
The parameters in this section provide some control over the placement of blank lines within and around groups of statements beginning with selected keywords. These blank lines are called here keyword group blanks, and all of the parameters begin with --keyword-group-blanks*, or -kgb* for short. The default settings do not employ these controls but they can be enabled with the following parameters:
-kgbl=s or --keyword-group-blanks-list=s; s is a quoted string of keywords
-kgbs=s or --keyword-group-blanks-size=s; s gives the number of keywords required to form a group.
-kgbb=n or --keyword-group-blanks-before=n; n = (0, 1, or 2) controls a leading blank
-kgba=n or --keyword-group-blanks-after=n; n = (0, 1, or 2) controls a trailing blank
-kgbi or --keyword-group-blanks-inside is a switch for adding blanks between subgroups
-kgbd or --keyword-group-blanks-delete is a switch for removing initial blank lines between keywords
-kgbr=n or --keyword-group-blanks-repeat-count=n can limit the number of times this logic is applied
In addition, the following abbreviations are available to for simplified usage:
-kgb or --keyword-group-blanks is short for -kgbb=2 -kgba=2 kgbi
-nkgb or --nokeyword-group-blanks, is short for -kgbb=1 -kgba=1 nkgbi
Before describing the meaning of the parameters in detail let us look at an example which is formatted with default parameter settings.
print "Entering test 2\n";
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
my @encodings = grep( /iso-?8859/, Encode::encodings() );
my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
my @source = qw(ascii iso8859-1 cp1250);
my @destiny = qw(cp1047 cp37 posix-bc);
my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
return unless ($str);using perltidy -kgb gives:
print "Entering test 2\n";
<----------this blank controlled by -kgbb
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
<---------this blank controlled by -kgbi
my @encodings = grep( /iso-?8859/, Encode::encodings() );
my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
my @source = qw(ascii iso8859-1 cp1250);
my @destiny = qw(cp1047 cp37 posix-bc);
my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
<----------this blank controlled by -kgba
return unless ($str);Blank lines have been introduced around the my and use sequences. What happened is that the default keyword list includes my and use but not print and return. So a continuous sequence of nine my and use statements was located. This number exceeds the default threshold of five, so blanks were placed before and after the entire group. Then, since there was also a subsequence of six my lines, a blank line was introduced to separate them.
Finer control over blank placement can be achieved by using the individual parameters rather than the -kgb flag. The individual controls are as follows.
-kgbl=s or --keyword-group-blanks-list=s, where s is a quoted string, defines the set of keywords which will be formed into groups. The string is a space separated list of keywords. The default set is s="use require local our my", but any list of keywords may be used. Comment lines may also be included in a keyword group, even though they are not keywords. To include ordinary block comments, include the symbol BC. To include static block comments (which normally begin with '##'), include the symbol SBC.
-kgbs=s or --keyword-group-blanks-size=s, where s is a string describing the number of consecutive keyword statements forming a group (Note: statements separated by blank lines in the input file are considered consecutive for purposes of this count). If s is an integer then it is the minimum number required for a group. A maximum value may also be given with the format s=min.max, where min is the minimum number and max is the maximum number, and the min and max values are separated by one or more dots. No groups will be found if the maximum is less than the minimum. The maximum is unlimited if not given. The default is s=5. Some examples:
s min max number for group
3 3 unlimited 3 or more
1.1 1 1 1
1..3 1 3 1 to 3
1.0 1 0 (no match)There is no really good default value for this parameter. If it is set too small, then an excessive number of blank lines may be generated. However, some users may prefer reducing the value somewhat below the default, perhaps to s=3.
-kgbb=n or --keyword-group-blanks-before=n specifies whether a blank should appear before the first line of the group, as follows:
n=0 => (delete) an existing blank line will be removed
n=1 => (stable) no change to the input file is made [DEFAULT]
n=2 => (insert) a blank line is introduced if possible-kgba=n or --keyword-group-blanks-after=n likewise specifies whether a blank should appear after the last line of the group, using the same scheme (0=delete, 1=stable, 2=insert).
-kgbi or --keyword-group-blanks-inside controls the insertion of blank lines between the first and last statement of the entire group. If there is a continuous run of a single statement type with more than the minimum threshold number (as specified with -kgbs=s) then this switch causes a blank line be inserted between this subgroup and the others. In the example above this happened between the use and my statements.
-kgbd or --keyword-group-blanks-delete controls the deletion of any blank lines that exist in the the group when it is first scanned. When statements are initially scanned, any existing blank lines are included in the collection. Any such original blank lines will be deleted before any other insertions are made when the parameter -kgbd is set. The default is not to do this, -nkgbd.
-kgbr=n or --keyword-group-blanks-repeat-count=n specifies n, the maximum number of times this logic will be applied to any file. The special value n=0 is the same as n=infinity which means it will be applied to an entire script [Default]. A value n=1 could be used to make it apply just one time for example. This might be useful for adjusting just the use statements in the top part of a module for example.
-kgb or --keyword-group-blanks is an abbreviation equivalent to setting -kgbb=1 -kgba=1 -kgbi. This turns on keyword group formatting with a set of default values.
-nkgb or --nokeyword-group-blanks is equivalent to -kgbb=0 -kgba nkgbi. This flag turns off keyword group blank lines and is the default setting.
Here are a few notes about the functioning of this technique.
These parameters are probably more useful as part of a major code reformatting operation rather than as a routine formatting operation.
In particular, note that deleting old blank lines with -kgbd is an irreversible operation so it should be applied with care. Existing blank lines may be serving an important role in controlling vertical alignment.
Conflicts which arise among these kgb* parameters and other blank line controls are generally resolved by producing the maximum number of blank lines implied by any parameter.
For example, if the flags --freeze-blank-lines, or --keep-old-blank-lines=2, are set, then they have priority over any blank line deletion implied by the -kgb flags of this section, so no blank lines will be deleted.
For another example, if a keyword group ends at a sub and the flag kgba=0 requests no blank line there, but we also have --blank-lines-before-subs=2, then two blank lines will still be introduced before the sub.
The introduction of blank lines does not occur if it would conflict with other input controls or code validity. For example, a blank line will not be placed within a here-doc or within a section of code marked with format skipping comments. And in general, a blank line will only be introduced at the end of a group if the next statement is a line of code.
The count which is used to determine the group size is not the number of lines but rather the total number of keywords which are found. Individual statements with a certain leading keyword may continue on multiple lines, but if any of these lines is nested more than one level deep then that group will be ended.
The search for groups of lines with similar leading keywords is based on the input source, not the final formatted source. Consequently, if the source code is badly formatted, it would be best to make a first formatting pass without these options.
A style refers to a convenient collection of existing parameters.
-gnu gives an approximation to the GNU Coding Standards (which do not apply to perl) as they are sometimes implemented. At present, this style overrides the default style with the following parameters:
-lp -bl -noll -pt=2 -bt=2 -sbt=2 -icpTo use this style with -xlp (--extended-line-up-parentheses) instead of -lp (--line-up-parentheses) use -gnu -xlp.
-pbp is an abbreviation for the parameters in the book Perl Best Practices by Damian Conway:
-l=78 -i=4 -ci=4 -st -se -vt=2 -cti=0 -pt=1 -bt=1 -sbt=1 -bbt=1
-nsfs -nolq
-wbb="% + - * / x != == >= <= =~ !~ < > | & =
**= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x="Please note that this parameter set includes -st (--standard-output) and -se (--standard-error-output) flags, which make perltidy act as a filter on one file only. These can be overridden by placing -nst and/or -nse after the -pbp parameter.
Also note that the value of continuation indentation, -ci=4, is equal to the value of the full indentation, -i=4. It is recommended that the either (1) the parameter -ci=2 be used instead, or (2) the flag -xci be set. This will help show structure, particularly when there are ternary statements. The following snippet illustrates these options.
# perltidy -pbp
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. (
$page
? ( $section ? ' in ' : '' ) . "the $page_ext manpage"
: ' elsewhere in this document'
);
# perltidy -pbp -ci=2
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. (
$page
? ( $section ? ' in ' : '' ) . "the $page_ext manpage"
: ' elsewhere in this document'
);
# perltidy -pbp -xci
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. ( $page
? ( $section ? ' in ' : '' ) . "the $page_ext manpage"
: ' elsewhere in this document'
);The -xci flag was developed after the -pbp parameters were published so you need to include it separately.
The goal of perltidy is to improve the readability of files, but there are two commands which have the opposite effect, --mangle and --extrude. They are actually merely aliases for combinations of other parameters. Both of these strip all possible whitespace, but leave comments and pod documents, so that they are essentially reversible. The difference between these is that --mangle puts the fewest possible line breaks in a script while --extrude puts the maximum possible. Note that these options do not provided any meaningful obfuscation, because perltidy can be used to reformat the files. They were originally developed to help test the tokenization logic of perltidy, but they have other uses. One use for --mangle is the following:
perltidy --mangle myfile.pl -st | perltidy -o myfile.pl.newThis will form the maximum possible number of one-line blocks (see next section), and can sometimes help clean up a badly formatted script.
A similar technique can be used with --extrude instead of --mangle to make the minimum number of one-line blocks.
Another use for --mangle is to combine it with --delete-all-comments (-dac) to reduce the file size of a perl script.
A one-line block is a block of code where the contents within the curly braces is short enough to fit on a single line. For example,
if ( -e $file ) { print "'$file' exists\n" }The alternative, a block which spans multiple lines, is said to be a broken block. With few exceptions, perltidy retains existing one-line blocks, if it is possible within the line-length constraint, but it does not attempt to form new ones. In other words, perltidy will try to follow the input file regarding broken and unbroken blocks.
The main exception to this rule is that perltidy will attempt to form new one-line blocks following the keywords map, eval, and sort, eval, because these code blocks are often small and most clearly displayed in a single line. This behavior can be controlled with the flag --one-line-block-exclusion-list described below.
When the cuddled-else style is used, the default treatment of one-line blocks may interfere with the cuddled style. In this case, the default behavior may be changed with the flag --cuddled-break-option=n described elsewhere.
When an existing one-line block is longer than the maximum line length, and must therefore be broken into multiple lines, perltidy checks for and adds any optional terminating semicolon (unless the -nasc option is used) if the block is a code block.
As noted above, perltidy will, by default, attempt to create new one-line blocks for certain block types. This flag allows the user to prevent this behavior for the block types listed in the string s. The list s may include any of the words sort, map, grep, eval, or it may be * to indicate all of these.
So for example to prevent multiline eval blocks from becoming one-line blocks, the command would be -olbxl='eval'. In this case, existing one-line eval blocks will remain on one-line if possible, and existing multiline eval blocks will remain multiline blocks.
Nested one-line blocks are lines with code blocks which themselves contain code blocks. For example, the following line is a nested one-line block.
foreach (@list) { if ($_ eq $asked_for) { last } ++$found }The default behavior is to break such lines into multiple lines, but this behavior can be controlled with this flag. The values of n are:
n=0 break nested one-line blocks into multiple lines [DEFAULT]
n=1 stable: keep existing nested-one line blocks intactFor the above example, the default formatting (-olbn=0) is
foreach (@list) {
if ( $_ eq $asked_for ) { last }
++$found;
}If the parameter -olbn=1 is given, then the line will be left intact if it is a single line in the source, or it will be broken into multiple lines if it is broken in multiple lines in the source.
This flag controls the placement of semicolons at the end of one-line blocks. Semicolons are optional before a closing block brace, and frequently they are omitted at the end of a one-line block containing just a single statement. By default, perltidy follows the input file regarding these semicolons, but this behavior can be controlled by this flag. The values of n are:
n=0 remove terminal semicolons in single-statement one-line blocks
n=1 stable; keep input terminal semicolons [DEFAULT ]
n=2 add terminal semicolons in all one-line blocksNote that the n=2 option has no effect if adding semicolons is prohibited with the -nasc flag. Also not that while n=2 adds missing semicolons to all one-line blocks, regardless of complexity, the n=0 option only removes ending semicolons which terminate one-line blocks containing just one semicolon. So these two options are not exact inverses.
Sometimes it might be desirable to convert a script to have one-line blocks whenever possible. Although there is currently no flag for this, a simple workaround is to execute perltidy twice, once with the flag --noadd-newlines and then once again with normal parameters, like this:
cat infile | perltidy -nanl | perltidy >outfileWhen executed on this snippet
if ( $? == -1 ) {
die "failed to execute: $!\n";
}
if ( $? == -1 ) {
print "Had enough.\n";
die "failed to execute: $!\n";
}the result is
if ( $? == -1 ) { die "failed to execute: $!\n"; }
if ( $? == -1 ) {
print "Had enough.\n";
die "failed to execute: $!\n";
}This shows that blocks with a single statement become one-line blocks.
There is no automatic way to break existing long one-line blocks into multiple lines, but this can be accomplished by processing a script, or section of a script, with a short value of the parameter maximum-line-length=n. Then, when the script is reformatted again with the normal parameters, the blocks which were broken will remain broken (with the exceptions noted above).
Another trick for doing this for certain block types is to format one time with the --cuddled-else flag and --cuddled-break-option=2. Then format again with the normal parameters. This will break any one-line blocks which are involved in a cuddled-else style.
Vertical alignment refers to lining up certain symbols in a list of consecutive similar lines to improve readability. For example, the "fat commas" are aligned in the following statement:
$data = $pkg->new(
PeerAddr => join( ".", @port[ 0 .. 3 ] ),
PeerPort => $port[4] * 256 + $port[5],
Proto => 'tcp'
);Vertical alignment can be completely turned off using the -novalign flag mentioned below. However, vertical alignment can be forced to stop and restart by selectively introducing blank lines. For example, a blank has been inserted in the following code to keep somewhat similar things aligned.
%option_range = (
'format' => [ 'tidy', 'html', 'user' ],
'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
'character-encoding' => [ 'none', 'utf8' ],
'block-brace-tightness' => [ 0, 2 ],
'brace-tightness' => [ 0, 2 ],
'paren-tightness' => [ 0, 2 ],
'square-bracket-tightness' => [ 0, 2 ],
);Vertical alignment is implemented by locally increasing an existing blank space to produce alignment with an adjacent line. It cannot occur if there is no blank space to increase. So if a particular space is removed by one of the existing controls then vertical alignment cannot occur. Likewise, if a space is added with one of the controls, then vertical alignment might occur.
For example,
# perltidy -nwls='=>'
$data = $pkg->new(
PeerAddr=> join( ".", @port[ 0 .. 3 ] ),
PeerPort=> $port[4] * 256 + $port[5],
Proto=> 'tcp'
);The default is to use vertical alignment, but vertical alignment can be completely turned of with the -novalign flag.
A lower level of control of vertical alignment is possible with three parameters -vc, -vsc, and -vbc. These independently control alignment of code, side comments and block comments. They are described in the next section.
The parameter -valign is in fact an alias for -vc -vsc -vbc, and its negative -novalign is an alias for -nvc -nvsc -nvbc.
The -vc flag enables alignment of code symbols such as =. The default is -vc. For detailed control of which symbols to align, see the -valign-exclude-list parameter below.
The -vsc flag enables alignment of side comments and is enabled by default. If side comment alignment is disabled with -nvsc they will appear at a fixed space from the preceding code token. The default is -vsc
When -vbc is enabled, block comments can become aligned for example if one comment of a consecutive sequence of comments becomes outdented due a length in excess of the maximum line length. If this occurs, the entire group of comments will remain aligned and be outdented by the same amount. This coordinated alignment will not occur if -nvbc is set. The default is -vbc.
More detailed control of alignment types is available with these two parameters. Most of the vertical alignments in typical programs occur at one of the tokens ',', '=', and '=>', but many other alignments are possible and are given in the following list:
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
{ ( ? : , ; => && || ~~ !~~ =~ !~ // <=> -> q
if unless and or err for foreach while untilThese alignment types correspond to perl symbols, operators and keywords except for 'q', which refers to the special case of alignment in a 'use' statement of qw quotes and empty parens.
They are all enabled by default, but they can be selectively disabled by including one or more of these tokens in the space-separated list valign-exclusion-list=s. For example, the following would prevent alignment at = and if:
--valign-exclusion-list='= if'If it is simpler to specify only the token types which are to be aligned, then include the types which are to be aligned in the list of --valign-inclusion-list. In that case you may leave the valign-exclusion-list undefined, or use the special symbol * for the exclusion list. For example, the following parameters enable alignment only at commas and 'fat commas':
--valign-inclusion-list=', =>'
--valign-exclusion-list='*' ( this is optional and may be omitted )These parameter lists should consist of space-separated tokens from the above list of possible alignment tokens, or a '*'. If an unrecognized token appears, it is simply ignored. And if a specific token is entered in both lists by mistake then the exclusion list has priority.
The default values of these parameters enable all alignments and are equivalent to
--valign-exclusion-list=' '
--valign-inclusion-list='*'To illustrate, consider the following snippet with default formatting
# perltidy
$co_description = ($color) ? 'bold cyan' : ''; # descr
$co_prompt = ($color) ? 'bold green' : ''; # prompt
$co_unused = ($color) ? 'on_green' : 'reverse'; # unusedTo exclude all alignments except the equals (i.e., include only equals) we could use:
# perltidy -vil='='
$co_description = ($color) ? 'bold cyan' : ''; # descr
$co_prompt = ($color) ? 'bold green' : ''; # prompt
$co_unused = ($color) ? 'on_green' : 'reverse'; # unusedTo exclude only the equals we could use:
# perltidy -vxl='='
$co_description = ($color) ? 'bold cyan' : ''; # descr
$co_prompt = ($color) ? 'bold green' : ''; # prompt
$co_unused = ($color) ? 'on_green' : 'reverse'; # unusedNotice in this last example that although only the equals alignment was excluded, the ternary alignments were also lost. This happens because the vertical aligner sweeps from left-to-right and usually stops if an important alignment cannot be made for some reason.
But also notice that side comments remain aligned because their alignment is controlled separately with the parameter --valign-side-comments described above.
By default, postfix if terms align and postfix unless terms align, but separately. For example,
# perltidy [DEFAULT]
print "Tried to add: @Resolve\n" if ( @Resolve and !$Quiet );
print "Would need: @DepList\n" if ( @DepList and !$Quiet );
print "Output:\n" unless $Quiet;
print join( "\n", @Output ) . "\n" unless $Quiet;The -viu flag causes a postfix unless to be treated as if it were a postfix if for purposes of alignment, and thus they align:
# perltidy -viu
print "Tried to add: @Resolve\n" if ( @Resolve and !$Quiet );
print "Would need: @DepList\n" if ( @DepList and !$Quiet );
print "Output:\n" unless $Quiet;
print join( "\n", @Output ) . "\n" unless $Quiet;Setting -vsn causes columns of numbers containing both signed and unsigned values to have leading signs placed in their own column. For example:
# perltidy -vsn
my @correct = (
[ 123456.79, 86753090000.868, 11 ],
[ -123456.79, -86753090000.868, -11 ],
[ 123456.001, 80.080, 10 ],
[ -123456.001, -80.080, 0 ],
[ 10.9, 10.9, 11 ],
);The default is -vsn. This can be turned off to get is strict left justification:
# perltidy -nvsn
my @correct = (
[ 123456.79, 86753090000.868, 11 ],
[ -123456.79, -86753090000.868, -11 ],
[ 123456.001, 80.080, 10 ],
[ -123456.001, -80.080, 0 ],
[ 10.9, 10.9, 11 ],
);Some points regarding -vsn are:
This option works by inserting a single space ahead of unsigned numbers when possible. This is not done if it would require increasing the maximum width of a column.
This option is mainly limited to lists of comma-separated numbers. For multiline lists of numbers, having trailing commas can sometimes improve the results. If missing, perltidy can add them for example with parameters -wtc=b -atc. See "Adding and Deleting Commas".
This option has a control parameter --valign-signed-number-limit=N, or -vsnl=N. This value controls formatting of very long columns of numbers and should not normally need to be changed. To see its purpose, consider a very long column of just unsigned numbers, say 1000 lines. If we add a single negative number, it is undesirable to move all of the other numbers over by one space. This could create many lines of file differences but not really improve the appearance when a local section of the table was viewed. The number N avoids this problem by not adding extra indentation to a run of more than N lines of unsigned numbers. The default value, N=20, is set to be a number of lines for which the ends of a long column of unsigned numbers are not normally both in view.
The following assignment operators are aligned independently by default:
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=Setting --valign-wide-equals, or -vwe, causes them to be vertically aligned together with the trailing = all aligned. For example, here is the default formatting for some code with several of these operators:
$str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
$str_len += $rfield_lengths->[$j];And here is the same code formatted with -vme:
# perltidy -vme
$str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
$str_len += $rfield_lengths->[$j];This option was added for issue git #135 and can improve readability, but it is off by default to avoid changing existing formatting.
This section describes some parameters for dealing with extended syntax.
For another method of handling extended syntax see the section "Skipping Selected Sections of Code".
Also note that the module Perl::Tidy supplies a pre-filter and post-filter capability. This requires calling the module from a separate program rather than through the binary perltidy.
This flag allows perltidy to handle certain common extensions to the standard syntax without complaint.
For example, without this flag a structure such as the following would generate a syntax error:
Method deposit( Num $amount) {
$self->balance( $self->balance + $amount );
}This flag is enabled by default but it can be deactivated with -nxs. Probably the only reason to deactivate this flag is to generate more diagnostic messages when debugging a script.
This flag causes one or more words to be treated the same as if they were the keyword sub. The string s contains one or more alias words, separated by spaces or commas.
For example,
perltidy -sal='method fun _sub M4'will cause the perltidy to treat the words 'method', 'fun', '_sub' and 'M4' the same as if they were 'sub'. Note that if the alias words are separated by spaces then the string of words should be placed in quotes.
Note that several other parameters accept a list of keywords, including 'sub' (see "Specifying Block Types"). You do not need to include any sub aliases in these lists. Just include keyword 'sub' if you wish, and all aliases are automatically included.
This flag allows a code block following an external 'list operator' function to be formatted as if it followed one of the built-in keywords grep, map or sort. The string s contains the names of one or more such list operators, separated by spaces or commas.
By 'list operator' is meant a function which is invoked in the form
word {BLOCK} @listPerltidy tries to keep code blocks for these functions intact, since they are usually short, and does not automatically break after the closing brace since a list may follow. It also does some special handling of continuation indentation.
For example, the code block arguments to functions 'My_grep' and 'My_map' can be given formatting like 'grep' with
perltidy -gal='My_grep My_map'By default, the following list operators in List::Util are automatically included:
all any first none notall reduce reductionsAny operators specified with --grep-alias-list are added to this list. The next parameter can be used to remove words from this default list.
The -gaxl=s flag provides a method for removing any of the default list operators given above by listing them in the string s. To remove all of the default operators use -gaxl='*'.
This flag tells perltidy to allow or disallow the syntax associated a pragma in string s. The current possible settings are:
--use-feature='class'. This tells perltidy to recognized the special words class, method, field, and ADJUST as defined for this feature.
--use-feature='noclass'. This tells perltidy not to treat words class, method, field, ADJUST specially.
Neither of these (--use-feature not defined). This is the DEFAULT and recommended setting. In this case perltidy will try to automatically handle both the newer --use-feature 'class' syntax as well as some conflicting uses of some of these special words by existing modules.
Note that this parameter is independent of any use feature control lines within a script. Perltidy does not look for or read such control lines. This is because perltidy must be able to work on small chunks of code sent from an editor, so it cannot assume that such lines will be within the lines being formatted.
Perltidy contains a number of rules which help avoid known subtleties and problems with older versions of perl, and these rules always take priority over whatever formatting flags have been set. For example, perltidy will usually avoid starting a new line with a bareword, because this might cause problems if use strict is active.
There is no way to override these rules.
Perltidy can selectively delete comments and/or pod documentation. The command -dac or --delete-all-comments will delete all comments and all pod documentation, leaving just code and any leading system control lines.
The command -dp or --delete-pod will remove all pod documentation (but not comments).
Two commands which remove comments (but not pod) are: -dbc or --delete-block-comments and -dsc or --delete-side-comments. (Hanging side comments will be deleted with side comments here.)
When side comments are deleted, any special control side comments for non-indenting braces will be retained unless they are deactivated with a -nnib flag.
The negatives of these commands also work, and are the defaults. When block comments are deleted, any leading 'hash-bang' will be retained. Also, if the -x flag is used, any system commands before a leading hash-bang will be retained (even if they are in the form of comments).
When perltidy writes a formatted text file, it has the ability to also send selected text to a file with a .TEE extension. This text can include comments and pod documentation.
The command -tac or --tee-all-comments will write all comments and all pod documentation.
The command -tp or --tee-pod will write all pod documentation (but not comments).
The commands which write comments (but not pod) are: -tbc or --tee-block-comments and -tsc or --tee-side-comments. (Hanging side comments will be written with side comments here.)
The negatives of these commands also work, and are the defaults.
If you use perltidy frequently, you probably won't be happy until you create a .perltidyrc file to avoid typing commonly-used parameters. Perltidy will first look in your current directory for a command file named .perltidyrc. If it does not find one, it will continue looking for one in other standard locations.
These other locations are system-dependent, and may be displayed with the command perltidy -dpro. Under Unix systems, it will first look for an environment variable PERLTIDY. Then it will look for a .perltidyrc file in the home directory, and then for a system-wide file /usr/local/etc/perltidyrc, and then it will look for /etc/perltidyrc. Note that these last two system-wide files do not have a leading dot. Further system-dependent information will be found in the INSTALL file distributed with perltidy.
Under Windows, perltidy will also search for a configuration file named perltidy.ini since Windows does not allow files with a leading period (.). Use perltidy -dpro to see the possible locations for your system. An example might be C:\Documents and Settings\All Users\perltidy.ini.
Another option is the use of the PERLTIDY environment variable. The method for setting environment variables depends upon the version of Windows that you are using.
Under Windows NT / 2000 / XP the PERLTIDY environment variable can be placed in either the user section or the system section. The later makes the configuration file common to all users on the machine. Be sure to enter the full path of the configuration file in the value of the environment variable. Ex. PERLTIDY=C:\Documents and Settings\perltidy.ini
The configuration file is free format, and simply a list of parameters, just as they would be entered on a command line. Any number of lines may be used, with any number of parameters per line, although it may be easiest to read with one parameter per line. Comment text begins with a #, and there must also be a space before the # for side comments. It is a good idea to put complex parameters in either single or double quotes.
Here is an example of a .perltidyrc file:
# This is a simple of a .perltidyrc configuration file
# This implements a highly spaced style
-se # errors to standard error output
-w # show all warnings
-bl # braces on new lines
-pt=0 # parens not tight at all
-bt=0 # braces not tight
-sbt=0 # square brackets not tightThe parameters in the .perltidyrc file are installed first, so any parameters given on the command line will have priority over them.
To avoid confusion, perltidy ignores any command in the .perltidyrc file which would cause some kind of dump and an exit. These include:
-h -v -ddf -dln -dop -dsn -dtt -dwls -dwrs -ssThere are several options may be helpful in debugging a .perltidyrc file:
A very helpful command is --dump-profile or -dpro. It writes a list of all configuration filenames tested to standard output, and if a file is found, it dumps the content to standard output before exiting. So, to find out where perltidy looks for its configuration files, and which one if any it selects, just enter
perltidy -dproIt may be simplest to develop and test configuration files with alternative names, and invoke them with -pro=filename on the command line. Then rename the desired file to .perltidyrc when finished.
The parameters in the .perltidyrc file can be switched off with the -npro option on the command line.
Any parameter in the .perltidyrc file can be overridden with a replacement value on the command line. This is because the command line is processed after the .perltidyrc file.
The commands --dump-options, --dump-defaults, --dump-long-names, and --dump-short-names, all described below, may all be helpful.
Versions of perltidy greater than 20240511 have an option to filter unrecognized parameters from a perltidy command file. If a line in the file begins with three dashes followed by a parameter name (rather than one or two), then the line will be removed if the parameter is unknown. Otherwise, a dash will be removed to make the line valid. This option was added to allow a single command file to be used during the transition to a new version of perltidy.
A special notation is available for use in a .perltidyrc file for creating an abbreviation for a group of options. This can be used to create a shorthand for one or more styles which are frequently, but not always, used. The notation is to group the options within curly braces which are preceded by the name of the alias (without leading dashes), like this:
newword {
-opt1
-opt2
}where newword is the abbreviation, and opt1, etc, are existing parameters or other abbreviations. The main syntax requirement is that the new abbreviation along with its opening curly brace must begin on a new line. Space before and after the curly braces is optional.
For a specific example, the following line
oneliner { --maximum-line-length=0 --noadd-newlines --noadd-terminal-newline}or equivalently with abbreviations
oneliner { -l=0 -nanl -natnl }could be placed in a .perltidyrc file to temporarily override the maximum line length with a large value, to temporarily prevent new line breaks from being added, and to prevent an extra newline character from being added the file. All other settings in the .perltidyrc file still apply. Thus it provides a way to format a long 'one liner' when perltidy is invoked with
perltidy --oneliner ...(Either -oneliner or --oneliner may be used).
If your script has leading lines of system commands or other text which are not valid perl code, and which are separated from the start of the perl code by a "hash-bang" line, ( a line of the form #!...perl ), you must use the -x flag to tell perltidy not to parse and format any lines before the "hash-bang" line. This option also invokes perl with a -x flag when checking the syntax. This option was originally added to allow perltidy to parse interactive VMS scripts, but it should be used for any script which is normally invoked with perl -x.
Please note: do not use this flag unless you are sure your script needs it. Parsing errors can occur if it does not have a hash-bang, or, for example, if the actual first hash-bang is in a here-doc. In that case a parsing error will occur because the tokenization will begin in the middle of the here-doc.
The following flags are available for debugging. Note that all commands named --dump-... will simply write some requested information to standard output and then immediately exit.
--dump-cuddled-block-list or -dcbl will dump to standard output the internal hash of cuddled block types created by a --cuddled-block-list input string.
--dump-defaults or -ddf will write the default option set to standard output and quit
--dump-integer-option-range or -dior will write a list of comma-separated values. Each line contains the name of an integer option along with its minimum, maximum, and default values.
--dump-profile or -dpro will write the name of the current configuration file and its contents to standard output and quit.
--dump-options or -dop will write current option set to standard output and quit.
--dump-long-names or -dln will write all command line long names (passed to Get_options) to standard output and quit.
--dump-short-names or -dsn will write all command line short names to standard output and quit.
--dump-token-types or -dtt will write a list of all token types to standard output and quit.
--dump-want-left-space or -dwls will write the hash %want_left_space to standard output and quit. See the section on controlling whitespace around tokens.
--dump-want-right-space or -dwrs will write the hash %want_right_space to standard output and quit. See the section on controlling whitespace around tokens.
See "Analyzing Code" for additional --dump- parameters.
--no-memoize or -nmem will turn of memoizing. Memoization can reduce run time when running perltidy repeatedly in a single process. It is on by default but can be deactivated for testing with -nmem.
--no-timestamp or -nts will eliminate any time stamps in output files to prevent differences in dates from causing test installation scripts to fail. There are just a couple of places where timestamps normally occur. One is in the headers of html files, and another is when the -cscw option is selected. The default is to allow timestamps (--timestamp or -ts).
--file-size-order or -fso will cause files to be processed in order of increasing size, when multiple files are being processed. This is particularly useful during program development, when large numbers of files with varying sizes are processed, because it can reduce virtual memory usage. This is the default and can be deactivated with -nfso.
--maximum-file-size-mb=n or -maxfs=n specifies the maximum file size in megabytes that perltidy will attempt to format. This parameter is provided to avoid causing system problems by accidentally attempting to format an extremely large data file. Most perl scripts are less than about 2 MB in size. The integer n has a default value of 10, so perltidy will skip formatting files which have a size greater than 10 MB. The command to increase the limit to 20 MB for example would be
perltidy -maxfs=20This length test is applied to named files before they are read into memory. It is applied to files arriving from standard input after they are read into memory. It is not applied to character strings arriving by a call to the Perl::Tidy module.
--maximum-level-errors=n or -maxle=n specifies the maximum number of indentation level errors are allowed before perltidy skips formatting and just outputs a file verbatim. The default is n=1. This means that if the final indentation of a script differs from the starting indentation by more than 1 levels, the file will be output verbatim. To avoid formatting if there are any indentation level errors use -maxle=0. To skip this check you can either set n equal to a large number, such as n=100, or set n=-1.
For example, the following script has level error of 3 and will be output verbatim
Input and default output:
{{{
perltidy -maxle=100
{
{
{--maximum-unexpected-errors=n or -maxue=n specifies the maximum number of unexpected tokenization errors are allowed before formatting is skipped and a script is output verbatim. The intention is to avoid accidentally formatting a non-perl script, such as an html file for example. This check can be turned off by setting n=0.
A recommended value is n=3. However, the default is n=0 (skip this check) to avoid causing problems with scripts which have extended syntaxes.
Many of the input parameters take integer values. Before processing begins, a check is made to see if any of these integer parameters exceed their valid ranges. The default behavior when a range is exceeded is to write a warning message and reset the value to its default setting. This default behavior can be changed with the parameter --integer-range-check=n, or -irc=n, as follows:
n=0 skip check completely (for stress-testing perltidy only)
n=1 reset bad values to defaults but do not issue a warning
n=2 reset bad values to defaults and issue warning [DEFAULT]
n=3 stop if any values are out of boundsThe values n=0 and n=1 are mainly useful for testing purposes.
-DEBUG, -D will write a file with extension .DEBUG for each input file showing the tokenization of all lines of code. This can produce a lot of output and is mainly useful for debugging tokenization issues during perltidy development.
Perltidy reports any obvious issues that are found during formatting, such as unbalanced braces. But several parameters are available for making certain additional checks for issues which might be of interest to a programmer. These parameters fall into two categories as indicated by their prefix, --dump- or --warn-:
The --dump- parameters read a file, write information to the standard output, and then exit without doing any formatting.
The --warn- parameters, on the other hand, cause perltidy to function normally but issue warnings to the error output when certain conditions are encountered.
Some of these have associated control parameters.
A table listing information about the blocks of code in a file can be made with --dump-block-summary, or -dbs. This causes perltidy to read and parse the file, write a table of comma-separated values for selected code blocks to the standard output, and then exit. This parameter must be on the command line, not in a .perlticyrc file, and it requires a single file name on the command line. For example
perltidy -dbs somefile.pl >blocks.csvproduces an output file blocks.csv whose lines hold these parameters:
filename - name of the file
line - line number of the opening brace of this block
line_count - number of lines between opening and closing braces
code_lines - number of lines excluding blanks, comments, and pod
type - block type (sub, for, foreach, ...)
name - block name if applicable (sub or asub name, label..)
depth - nesting depth of the opening block brace
max_change - change in depth to the most deeply nested code block
block_count - total number of code blocks nested in this block
mccabe_count - McCabe complexity measure of this code blockThis feature was developed to help identify complex sections of code as an aid in refactoring. The McCabe complexity measure follows the definition used by Perl::Critic. By default the table contains these values for subroutines, but the user may request them for any or all blocks of code or packages. For blocks which are loops nested within loops, a postfix '+' to the type is added to indicate possible code complexity. Although the table does not otherwise indicate which blocks are nested in other blocks, this can be determined by computing and comparing the block ending line numbers.
For subroutines, the number of call arguments (args) is listed in parentheses in the type column. For example, sub(9) indicates a sub with 9 args. Subroutines whose arg count cannot easily be determined are indicated as sub(*). The count includes any leading object passed in a method call (such as $self).
By default the table lists subroutines with more than 20 code_lines, but this can be changed with the following two parameters:
--dump-block-minimum-lines=n, or -dbl=n, where n is the minimum number of code_lines to be included. The default is -n=20. Note that code_lines is the number of lines excluding comments, blanks and pod.
--dump-block-types=s, or -dbt=s, where string s is a list of block types to be included. The type of a block is either the name of the perl builtin keyword for that block (such as sub if elsif else for foreach ..) or the word immediately before the opening brace. In addition, there are a few symbols for special block types, as follows:
if elsif else for foreach ... any keyword introducing a block
sub - any sub or anonymous sub
asub - any anonymous sub
* - any block except nameless blocks
+ - any nested inner block loop
package - any package or class
closure - any nameless block
elsif3 - an if-elsif- chain with 3 or more elsif's (see below)A chain of if-elsif-... blocks may be reported as a single line item by entering the word elsif with an appended integer, as indicated by the last item in this list. The integer indicates the number of elsif blocks required for a chain to be reported. If you use this, you may want to also use -dbl=n, with a smaller number of lines n than the default.
In addition, specific block loop types which are nested in other loops can be selected by adding a + after the block name. (Nested loops are sometimes good candidates for restructuring).
The default is -dbt='sub'.
In the following examples a table block.csv is created for a file somefile.pl:
This selects both subs and packages which have 20 or more lines of code. This can be useful in code which contains multiple packages.
perltidy -dbs -dbt='sub package' somefile.pl >blocks.csvThis selects block types sub for foreach while with 10 or more code lines.
perltidy -dbs -dbl=10 -dbt='sub for foreach while' somefile.pl >blocks.csvThis selects blocks with 2 or more code lines which are type sub or which are inner loops.
perltidy -dbs -dbl=2 -dbt='sub +' somefile.pl >blocks.csvThis selects every block and package.
perltidy -dbs -dbl=1 -dbt='* closure' somefile.pl >blocks.csvThis selects every if-chain which contains 2 or more elsif blocks:
perltidy -dbs -dbl=1 -dbt='elsif2' somefile.pl >blocks.csvThis selects every while block with 6 or more code lines
perltidy -dbs -dbt=while -dbl=6 somfile.pl >while.csvVariables with certain properties of interest to a programmer can be listed with --dump-unusual-variables or -duv. This parameter must be on the command line, along with a single file name. It causes perltidy to scan the file for certain variable types, write any found to the standard output, and then immediately exit without doing any formatting. For example
perltidy -duv somefile.pl >vars.txtproduces a file with lines which look something like
1778:u: my $input_file
6089:r: my $j: reused - see line 6076The values on the line are separated by colons and have the following meaning:
line number - the number of the line of the input file
issue - a single letter indicating the issue, see below
variable name - the name of the variable, preceded by a keyword
note - an optional note referring to another lineIf there are a large number of issues it can be convenient to read the file into a spreadsheet.
The checks are made for variables introduced by the keywords my, state, and our, along with variables defined with use vars and use constant. It is a good idea to also set use strict in a script so that Perl itself can find issues with variables which appear in a script without one of these methods.
The types of checks which are made are identified in the output with one of the letters r, s, p, u, and c as follows:
These are variables which are re-declared in the scope of a variable with the identical name. This can be confusing, perhaps not when the code is first written, but possibly later during maintenance work. For example, this can make it difficult to locate the correct variable with an editor when changes are being made. This issue can be avoided by renaming one of the conflicting variables. Note that this is similar to the Perl::Critic policy Variables::ProhibitReusedNames.
These are variables which have the same bareword name but a different sigil ($, @, or %) as another variable in the same scope. For example, this occurs if variables $data and %data share the same scope. This can also be confusing for the reasons mentioned above and can be avoided by renaming one of the variables.
These are lexical variables which are declared in one package and still visible in subroutines of a different package in the same file. This can be confusing, and it might cause the program to run differently, or fail, if the the packages were ever split into separate files. This issue can usually be avoided by placing code in block braces of some type. For example, this issue is often found in test code and can sometimes be fixed by using the structure
main();
sub main { #<<<
## old main code goes here
}The non-indenting-braces side comment #<<< is not required but will keep the indentation of the old code unchanged.
This check is only applied to package statements which are not enclosed in block braces in order avoid warnings at temporary package changes.
These are lexical variables declared with my or state (but not our) and not referenced again within their scope. Calling them unused is convenient but not really accurate; this is a "gray area" for a program. There are some good reasons for having such variables. For example, they might occur in a list of values provided by another routine or data structure, and therefore must be listed, even though they might not be referenced again. Having such variables can make them immediately available for future development and debugging, and can be beneficial for program clarity.
But sometimes they can occur due to being orphaned by a coding change, due to a misspelling, or by having an unintentional preceding my. So it is worth reviewing them, especially for new code. Here is an example of an unused variable in a script located with this method:
BEGIN { my $string = "" }
...
$string .= "ok";This looks nice at first glance, but the scope of the my declaration is limited to the surrounding braces, so it is not the same variable as the other $string and must therefore be reported as unused. This particular problem would have also been caught by perl if the author had used strict.
These are names which are declared with a use constant and a reference was not seen again within their package. They might be needed by an external package, or a set of standard definitions, or available for future development. And in some unusual cases a reference may have been missed by perltidy. But they might also be unused remnants from code development, or due to a misspelling, so it can be worthwhile reviewing them.
Exception: The following our variables are exempt from warnings: $VERSION, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, @ISA, $AUTOLOAD.
The flag --warn-variable-types=string, or -wvt=string, is the --warn counterpart to --dump-unusual-variables, and can be used to produce a warning message if certain of the above variable types are encountered during formatting. All possible variable warnings may be requested with -wvt='*' or -wvt=1.
For example,
perltidy -wvt='*' somefile.plThe default is not to do any of these checks, and it can also be indicated with -wvt=0.
To restrict the check to a specific set warnings, set the input string to be a space-separated or comma-separated list of the letters associated with the types of variables to be checked. For example:
perltidy -wvt='s r' somefile.plwill process somefile.pl normally but issue a warning if either of the issues s or r, described above, are encountered.
A companion flag, --warn-variable-exclusion-list=string, or -wvxl=string, can be used to skip warning checks for a list of variable names. A leading and/or trailing '*' may be placed on any of these variable names to allow a partial match.
For example,
perltidy -wvt=1 -wvxl='$self $class *_unused' somefile.plwill do all possible checks but not report any warnings for variables $self, $class, and for example $value_unused.
This partial match option provides a way to trigger a warning message when a new unused variable is detected in a script. This can be accomplished by adding a unique suffix to the names of existing unused variables, such as _unused. This suffix is then added to the exclusion list.
As a specific example, consider the following line which is part of some debug code which only references the latter three variables (but might someday need to reference the package variable too).
my ( $package_uu, $filename, $line, $subroutine ) = caller();The unused variable, $package_uu, has been specially marked with suffix _uu. No type u (unused variable) warning will be produced provided that this wildcard suffix is in the exclusion list:
-wvxl='*_uu'The parameter --dump-unique-keys, or -duk, dumps a list of hash keys which appear to be used just once, and do not appear among the quoted strings in a file. For example:
perltidy -duk File.pm >output.txtThe lines in the output file list each unique key and its line number. Typically, most of the listed keys listed will be perfectly valid keys needed, for example, for communication with other modules or for future development. But the list might also include something unexpected, such as a misspelled key.
A program dump_unique_keys.pl at https://github.com/perltidy/perltidy/tree/master/examples can run perltidy with -duk on multiple files, and then remove any common keys from the list.
The parameter --dump-mixed-call-parens, or -dmcp, provides information on the use of call parens within a program. It produces a list of keywords and sub names which occur both both with and without parens. In other words, with a mixed style. This might be useful if one is working to standardize the call style for some particular keyword or function. For example,
perltidy -dmcp somefile.pl >output.txtwill analyze the text of somefile.pl, write the results to output.txt, and then immediately exit (like all dump- parameters).
The output shows a list of operators and the number of times they were used with parens and the number of times without parens. For example, here is a small section of the output from one file in a past Perl distribution:
k:length:17:9
k:open:30:9
k:pop:3:4The first line shows that the length function occurs 17 times with parens and 9 times without parens. The 'k' indicates that length is a Perl builtin keyword ('U' would mean user-defined sub, and 'w' would mean unknown bareword). So from this partial output we see that the author had a preference for parens around the args of length and open, whereas pop was about equally likely to have parens as not.
More detailed information can be obtained with the parameters described in the next section.
The parameter --want-call-parens=s, or -wcp=s, can be used to to produce a warning message if call parens are missing from selected functions. Likewise, --nowant-call-parens=s, or -nwcp=s, can warn if call parens exist for selected functions. When either of these parameters are set, perltidy will report any discrepancies from the requested style in its error output.
Before using either of these parameters, it may be helpful to first use --dump-mixed-call-parens=s, described in the previous section, to get an overview of the existing paren usage in a file.
The string arguments s are space-separated lists of the names of the functions to be checked. The function names may be builtin keywords or user-defined subs. They may not include a package prefix or sigil. To illustrate,
perltidy -wcp='length open' -nwcp='pop' somefile.plmeans that the builtin functions length and open should have parens around their call args but pop should not. The error output might contain lines such as:
2314:open FD_TO_CLOSE: no call parens
3652:pop (: has call parens
3783:length $DB: no call parens
...For builtin keywords which have both a block form and a trailing modifier form, such as if, only the trailing modifier form will be checked since parens are mandatory for the block form.
The symbol & may entered instead of a function name to mean all user-defined subs not explicitly listed. So the compact expression
perltidy -wcp='&' somefile.plmeans that calls to all user-defined subs in the file being processed should have their call arguments enclosed in parens.
Perltidy does not have the ability to add or delete call parens because it is difficult to automate, so changes must be made manually. When adding or removing parentheses, it is essential to pay attention to operator precedence issues. For example, if the parens in the following statement are removed, then || must be changed to or:
open( IN, "<", $infile ) || die("cannot open $infile:$!\n");Otherwise, the || will operate on $infile rather than the return value of open.
The parameter --dump-mismatched-args, or -dma, causes perltidy to examine the definitions of subroutines in a file, and calls to those subs, and report certain differences. Like all --dump commands, it writes its report to standard output and exits immediately. For example
perltidy -dma somefile.pl >results.txtFour types of issues are reported, types a, o, u, and i:
For example the following two lines would be reported as a mismatch:
Fault();and
$self->Fault();This may or may not be an error, but it is worth checking. It might become an error in the future if sub Fault starts to access $self.
For example
sub gnab_gib {
my $self=shift;
my ($v1,$v2)=@_;
...
}
$self->gnab_gib(42);In this case, the sub is expecting a total of three args ($self, $v1, and $v2) but only receives two ($self and 42), so an undercount is reported. This is not necessarily an error because the sub may allow for this possibility, but it is worth checking.
Although it is not possible to automatically determine which sub args are optional, if optional sub args are enclosed in an extra set of parentheses, perltidy will take this a signal that they are optional and not issue a warning. So if the above example is written as
sub gnab_gib {
my $self = shift;
my ( $v1, ($v2) ) = @_; # <-- $v2 is optional
...;
}then perltidy will consider that the second arg is optional and not issue a warning for:
$self->gnab_gib(42);For multiple default call args, place one set of parens around them all. Some examples:
my ( ($v1) ) = @_; # <-- $v1 is optional
my ( $v1, ( $v2, $v3 ) ) = @_; # <-- $v2, $v3 are optionalNotes and Limitations:
This option works best for subs which unpack call args in an orderly manner near the beginning of the sub from @_ and/or with shift operations. It will also work for direct access to specific elements of the @_ array. However if the coding for arg extraction is complex then the number of sub args will be considered indeterminate and a count cannot be checked.
Sub calls made without parentheses around the args are not checked.
Anonymous subs and lexical subs (introduced with my) are not checked.
Only calls which appear to be to subs defined within the file being processed are checked. But note that a file may contain multiple packages.
This is similar to the -dump parameter described above except that any mismatches are reported in the error file and otherwise formatting continues normally. The basic usage is
perltidy -wma somefile.plSeveral companion controls are available to avoid unwanted error messages:
--warn-mismatched-arg-types=s, or -wmat=s, can be used to select specific tests, type a (arrow test) or o (overcounts) or u (undercounts). All checks may be requested with -wmat='*' or -wmat=1. This is the default.
To restrict the check to a specific warning type, set the string equal to the letter of that warning, any a, o, or u. For example
perltidy -wmat='a o' somefile.plwill format somefile.pl and report any arrow-type mismatches and overcount mismatches, but will skip undercount mismatches.
--warn-mismatched-arg-exclusion-list, or -wmaxl=string, can be given to skip the warning checks for a list of subroutine names, entered as a quoted string of space- or comma-separated names, without a package prefix. All subs with those names will be skipped, regardless of package. A leading and/or trailing * on a name may be used to indicate a partial string match.
--warn-mismatched-arg-undercount-cutoff=n, or -wmauc=n, can be used to avoid undercount warnings when the expected number of args is less than n. Please note that this number n is the number of args from the point of view of the sub definition, so an object like $self passed with an arrow operator counts as one arg.
The default value is n=4. This has been found to allow most programs to pass without warnings, but it should be reduced if possible for better error checking. The minimum possible value of n needed to avoid triggering an error for a program can be determined by running with -wma -wmauc=0. If there are undercount errors, a note at the bottom of the error output indicates the value of n required to avoid reporting them.
As noted above for the parameter --dump-mismatched-args, if optional call args are enclosed in separate parentheses, then perltidy will recognize them as optional args and avoid needless warnings. If this method is used, then -wmauc=0 should be used for maximal checking.
--warn-mismatched-arg-overcount-cutoff=n, or -wmaoc=n, can be used to avoid overcount warnings when the expected number of args is less than n. The default value is n=1. This avoids warning messages for subroutines which are dummy placeholders for possible expansion.
To illustrate these controls,
perltidy -wma -wmat='o u' -wmaxl='new old' -wmauc=2 somefile.plmeans format somefile.pl as usual and check for mismatched overcounts and undercounts but not arrows. Skip checking for any sub named new or old, and only warn of undercounts for subs expecting more than 2 args.
The parameter --dump-mismatched-returns, or -dmr, examines the return side of sub call statements. Like all --dump commands, it writes its report to standard output and exits immediately. For example
perltidy -dmr somefile.pl >results.txtThe following types of issues are reported:
These issue types are illustrated with the following code
sub macho {
...
( $name, $flags ); # 2 values but no 'return' statement
}
( $name, $flags ) = macho(); # 'x' (want array, but no return)
$name = macho(); # 'y' (want scalar but no return)
sub wimp {
...;
return ( $name, $flags ); # 2 values with 'return' statement
}
( $name, $flags, $access) = wimp(); # 'o' (want array 3 > 2)
($name) = wimp(); # 'u' (want array 1 < 2)
$name = wimp(); # 's' (want scalar but 2 values returned)This analysis works by scanning all call statements and all sub return statements, and comparing the the number of items wanted with the possible number of items returned. If a specific value for either of these numbers cannot be determined for a call then it cannot be checked.
Since only return statements are scanned for return values, this analysis will not be useful for programming which relies on the default return mechanism, as in the first sub above. Note that the Perl::Critic policy RequireFinalReturn can be used to check for code in this situation.
Reported issues are not necessarily errors, but they might be, or they might indicate potentially confusing code.
This is similar to the -dump parameter described above except that any mismatches are reported in the error file and otherwise formatting continues normally. The basic usage is
perltidy -wmr somefile.plThe following companion controls are available to avoid unwanted error messages:
--warn-mismatched-return-types=string, or -wmrt=string, can be used to limit checks.
To restrict the checking, set the string equal to the letter(s) of that warning, any x, y, o, u, or s. For example
perltidy -wmrt='x o s' somefile.plwill format somefile.pl and report issue types x, o, and s but not types u and y. All checks may be requested with -wmrt='*' or -wmrt=1. This is the default.
--warn-mismatched-return-exclusion-list, or -wmrxl=string, can be given to skip the warning checks for a list of subroutine names, entered as a quoted string of space- or comma-separated names, without a package prefix. All subs with those names will be skipped, regardless of package. A leading and/or trailing * on a name may be used to indicate a partial string match.
The first $VERSION line of a file which might be eval'd by MakeMaker is passed through unchanged except for indentation. The default --pass-version-line, or -pvl, is to do this. Use --nopass-version-line, or -npvl, to deactivate this feature.
If the AutoLoader module is used, perltidy will continue formatting code after seeing an __END__ line. The default --look-for-autoloader, or -lal, is to do this. Use --nolook-for-autoloader, or -nlal, to deactivate this feature.
Likewise, if the SelfLoader module is used, perltidy will continue formatting code after seeing a __DATA__ line. The default --look-for-selfloader, or -lsl, is to do this. Use --nolook-for-selfloader, or -nlsl, to deactivate this feature.
The flag -html causes perltidy to write an html file with extension .html. So, for example, the following command
perltidy -html somefile.plwill produce a syntax-colored html file named somefile.pl.html which may be viewed with a browser.
Please Note: In this case, perltidy does not do any formatting to the input file, and it does not write a formatted file with extension .tdy. This means that two perltidy runs are required to create a fully reformatted, html copy of a script.
When the -pre flag is given, only the pre-formatted section, within the <PRE> and </PRE> tags, will be output. This simplifies inclusion of the output in other files. The default is to output a complete web page.
When the -nnn flag is given, the output lines will be numbered.
By default, a table of contents to packages and subroutines will be written at the start of html output. Use -ntoc to prevent this. This might be useful, for example, for a pod document which contains a number of unrelated code snippets. This flag only influences the code table of contents; it has no effect on any table of contents produced by pod2html (see next item).
There are two options for formatting pod documentation. The default is to pass the pod through the Pod::Html module (which forms the basis of the pod2html utility). Any code sections are formatted by perltidy, and the results then merged. Note: perltidy creates a temporary file when Pod::Html is used; see "FILES". Also, Pod::Html creates temporary files for its cache.
NOTE: Perltidy counts the number of =cut lines, and either moves the pod text to the top of the html file if there is one =cut, or leaves the pod text in its original order (interleaved with code) otherwise.
Most of the flags accepted by pod2html may be included in the perltidy command line, and they will be passed to pod2html. In some cases, the flags have a prefix pod to emphasize that they are for the pod2html, and this prefix will be removed before they are passed to pod2html. The flags which have the additional pod prefix are:
--[no]podheader --[no]podindex --[no]podrecurse --[no]podquiet
--[no]podverbose --podflushThe flags which are unchanged from their use in pod2html are:
--backlink=s --cachedir=s --htmlroot=s --libpods=s --title=s
--podpath=s --podroot=swhere 's' is an appropriate character string. Not all of these flags are available in older versions of Pod::Html. See your Pod::Html documentation for more information.
The alternative, indicated with -npod, is not to use Pod::Html, but rather to format pod text in italics (or whatever the stylesheet indicates), without special html markup. This is useful, for example, if pod is being used as an alternative way to write comments.
By default, a single html output file is produced. This can be changed with the -frm option, which creates a frame holding a table of contents in the left panel and the source code in the right side. This simplifies code browsing. Assume, for example, that the input file is MyModule.pm. Then, for default file extension choices, these three files will be created:
MyModule.pm.html - the frame
MyModule.pm.toc.html - the table of contents
MyModule.pm.src.html - the formatted source codeObviously this file naming scheme requires that output be directed to a real file (as opposed to, say, standard output). If this is not the case, or if the file extension is unknown, the -frm option will be ignored.
Use this flag to specify the extra file extension of the table of contents file when html frames are used. The default is "toc". See "Specifying File Extensions".
Use this flag to specify the extra file extension of the content file when html frames are used. The default is "src". See "Specifying File Extensions".
This flag controls the use of Html::Entities for html formatting. By default, the module Html::Entities is used to encode special symbols. This may not be the right thing for some browser/language combinations. Use --nohtml-entities or -nhent to prevent this.
Style sheets make it very convenient to control and adjust the appearance of html pages. The default behavior is to write a page of html with an embedded style sheet.
An alternative to an embedded style sheet is to create a page with a link to an external style sheet. This is indicated with the -css=filename, where the external style sheet is filename. The external style sheet filename will be created if and only if it does not exist. This option is useful for controlling multiple pages from a single style sheet.
To cause perltidy to write a style sheet to standard output and exit, use the -ss, or --stylesheet, flag. This is useful if the style sheet could not be written for some reason, such as if the -pre flag was used. Thus, for example,
perltidy -html -ss >mystyle.csswill write a style sheet with the default properties to file mystyle.css.
The use of style sheets is encouraged, but a web page without a style sheets can be created with the flag -nss. Use this option if you must to be sure that older browsers (roughly speaking, versions prior to 4.0 of Netscape Navigator and Internet Explorer) can display the syntax-coloring of the html files.
Note: It is usually more convenient to accept the default properties and then edit the stylesheet which is produced. However, this section shows how to control the properties with flags to perltidy.
Syntax colors may be changed from their default values by flags of the either the long form, -html-color-xxxxxx=n, or more conveniently the short form, -hcx=n, where xxxxxx is one of the following words, and x is the corresponding abbreviation:
Token Type xxxxxx x
---------- -------- --
comment comment c
number numeric n
identifier identifier i
bareword, function bareword w
keyword keyword k
quote, pattern quote q
here doc text here-doc-text h
here doc target here-doc-target hh
punctuation punctuation pu
parentheses paren p
structural braces structure s
semicolon semicolon sc
colon colon co
comma comma cm
label label j
sub definition name subroutine m
pod text pod-text pdA default set of colors has been defined, but they may be changed by providing values to any of the following parameters, where n is either a 6 digit hex RGB color value or an ascii name for a color, such as 'red'.
To illustrate, the following command will produce an html file somefile.pl.html with "aqua" keywords:
perltidy -html -hck=00ffff somefile.pland this should be equivalent for most browsers:
perltidy -html -hck=aqua somefile.plPerltidy merely writes any non-hex names that it sees in the html file. The following 16 color names are defined in the HTML 3.2 standard:
black => 000000,
silver => c0c0c0,
gray => 808080,
white => ffffff,
maroon => 800000,
red => ff0000,
purple => 800080,
fuchsia => ff00ff,
green => 008000,
lime => 00ff00,
olive => 808000,
yellow => ffff00
navy => 000080,
blue => 0000ff,
teal => 008080,
aqua => 00ffff,Many more names are supported in specific browsers, but it is safest to use the hex codes for other colors. Helpful color tables can be located with an internet search for "HTML color tables".
Besides color, two other character attributes may be set: bold, and italics. To set a token type to use bold, use the flag --html-bold-xxxxxx or -hbx, where xxxxxx or x are the long or short names from the above table. Conversely, to set a token type to NOT use bold, use --nohtml-bold-xxxxxx or -nhbx.
Likewise, to set a token type to use an italic font, use the flag --html-italic-xxxxxx or -hix, where again xxxxxx or x are the long or short names from the above table. And to set a token type to NOT use italics, use --nohtml-italic-xxxxxx or -nhix.
For example, to use bold braces and lime color, non-bold, italics keywords the following command would be used:
perltidy -html -hbs -hck=00FF00 -nhbk -hik somefile.plThe background color can be specified with --html-color-background=n, or -hcbg=n for short, where n is a 6 character hex RGB value. The default color of text is the value given to punctuation, which is black as a default.
Here are some notes and hints:
1. If you find a preferred set of these parameters, you may want to create a .perltidyrc file containing them. See the perltidy man page for an explanation.
2. Rather than specifying values for these parameters, it is probably easier to accept the defaults and then edit a style sheet. The style sheet contains comments which should make this easy.
3. The syntax-colored html files can be very large, so it may be best to split large files into smaller pieces to improve download times.
Several parameters which refer to code block types may be customized by also specifying an associated list of block types. The type of a block is the name of the keyword which introduces that block, such as if, else, or sub. An exception is a labeled block, which has no keyword, and should be specified with just a colon. To specify all blocks use '*'.
The keyword sub indicates a named sub. For anonymous subs, use the special keyword asub.
For example, the following parameter specifies sub, labels, BEGIN, and END blocks:
-cscl="sub : BEGIN END"(the meaning of the -cscl parameter is described above.) Note that quotes are required around the list of block types because of the spaces. For another example, the following list specifies all block types for vertical tightness:
-bbvtl='*'Several parameters allow default file extensions to be overridden. For example, a backup file extension may be specified with -bext=ext, where ext is some new extension. In order to provides the user some flexibility, the following convention is used in all cases to decide if a leading '.' should be used. If the extension ext begins with A-Z, a-z, or 0-9, then it will be appended to the filename with an intermediate '.' (or perhaps a '_' on VMS systems). Otherwise, it will be appended directly.
For example, suppose the file is somefile.pl. For -bext=old, a '.' is added to give somefile.pl.old. For -bext=.old, no additional '.' is added, so again the backup file is somefile.pl.old. For -bext=~, then no dot is added, and the backup file will be somefile.pl~ .
The following list shows all short parameter names which allow a prefix 'n' to produce the negated form:
D aia altc ame anl asbl asc ast asu atc
atnl aws b baa baao bar bbao bbb bbc bbs
bl bli boa boc bok bol bom bos bot cblx
ce conv cpb cs csc cscb cscw dac dbc dbs
dcbl dcsc ddf dia dior dln dltc dma dmcp dmr
dnl dop dp dpro drc dsc dsm dsn dtc dtco
dtt duk duv dwic dwls dwrs dws eos f fpva
frm fs fso gcs hbc hbcm hbco hbh hbhh hbi
hbj hbk hbm hbn hbp hbpd hbpu hbq hbs hbsc
hbv hbw hent hic hicm hico hih hihh hii hij
hik him hin hip hipd hipu hiq his hisc hiv
hiw hsc html ibc icb icp ils iob ipc isbc
iscl kgb kgbd kgbi kis lal log lop lp lsl
mci mem nib ohbr okw ola olc oll olq opr
opt osbc osbr otr ple pod pvl q qwaf sac
sbc sbl scbb schb scp scsb sct se sfp sfs
skp sob sobb sohb sop sosb sot ssc st sts
t tac tbc toc tp tqw trp ts tsc tso
vbc vc viu vmll vsc vsn vwe w wfc wia
wma wme wmr wn x xbt xci xlp xsEquivalently, the prefix 'no' or 'no-' on the corresponding long names may be used.
Perltidy should work properly on most perl scripts. It does a lot of self-checking, but still, it is possible that an error could be introduced and go undetected. Therefore, it is essential to make careful backups and to test reformatted scripts.
The main current limitation is that perltidy does not scan modules included with 'use' statements. This makes it necessary to guess the context of any bare words introduced by such modules. Perltidy has good guessing algorithms, but they are not infallible. When it must guess, it leaves a message in the log file.
If you encounter a bug, please report it.
Perltidy indents but does not reformat comments and qw quotes. Perltidy does not in any way modify the contents of here documents or quoted text, even if they contain source code. (You could, however, reformat them separately). Perltidy does not format 'format' sections in any way. And, of course, it does not modify pod documents.
Under the -html option with the default --pod2html flag, a temporary file is required to pass text to Pod::Html. Unix systems will try to use the POSIX tmpnam() function. Otherwise the file perltidy.TMP will be temporarily created in the current working directory.
When standard input is used, the log file, if saved, is perltidy.LOG, and any errors are written to perltidy.ERR unless the -se flag is set. These are saved in the current working directory.
The following file extensions are used by perltidy, and files with these extensions may be overwritten or deleted: .ERR, .LOG, .TEE, and/or .tdy, .html, and .bak, depending on the run type and settings.
Perltidy does not operate on files for which the run could produce a file with a duplicated file extension. These extensions include .LOG, .ERR, .TEE, and perhaps .tdy and .bak, depending on the run type. The purpose of this rule is to prevent generating confusing filenames such as somefile.tdy.tdy.tdy.
An exit value of 0, 1, or 2 is returned by perltidy to indicate the status of the result.
A exit value of 0 indicates that perltidy ran to completion with no error messages.
A non-zero exit value indicates some kind of problem was detected.
An exit value of 1 indicates that perltidy terminated prematurely, usually due to some kind of errors in the input parameters. This can happen for example if a parameter is misspelled or given an invalid value. Error messages in the standard error output will indicate the cause of any problem. If perltidy terminates prematurely then no output files will be produced.
An exit value of 2 indicates that perltidy was able to run to completion but there there are (1) warning messages in the standard error output related to parameter errors or problems and/or (2) warning messages in the perltidy error file(s) relating to possible syntax errors in one or more of the source script(s) being tidied. When multiple files are being processed, an error detected in any single file will produce this type of exit condition.
perlstyle(1), Perl::Tidy(3)
The perltidy binary uses the Perl::Tidy module and is installed when that module is installed. The module name is case-sensitive. For example, the basic command for installing with cpanm is 'cpanm Perl::Tidy'.
This man page documents perltidy version 20250105
The source code repository is at https://github.com/perltidy/perltidy.
To report a new bug or problem, use the "issues" link on this page.
Copyright (c) 2000-2025 by Steve Hancock
This package is free software; you can redistribute it and/or modify it under the terms of the "GNU General Public License".
Please refer to the file "COPYING" for details.
This package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the "GNU General Public License" for more details.
Perl-Tidy-20250105/docs/stylekey.html 0000644 0001750 0001750 00000103573 14735777212 016340 0 ustar steve steveWhen perltidy was first developed, the main parameter choices were the number of indentation spaces and if the user liked cuddled else's. As the number of users has grown so has the number of parameters. Now there are so many that it can be difficult for a new user to find a good initial set. This document is one attempt to help with this problem, and some other suggestions are given at the end.
Use this document to methodically find a starting set of perltidy parameters to approximate your style. We will be working on just one aspect of formatting at a time. Just read each question and select the best answer. Enter your parameters in a file named .perltidyrc (examples are listed at the end). Then move it to one of the places where perltidy will find it. You can run perltidy with the parameter -dpro to see where these places are for your system.
Before you begin, experiment using just perltidy filename.pl on some of your files. From the results (which you will find in files with a .tdy extension), you will get a sense of what formatting changes, if any, you'd like to make. If the default formatting is acceptable, you do not need a .perltidyrc file.
The default is based on the recommendations in the Perl style guide. It is worth noting that, although many variations are possible with the available parameters, this style has some significant advantages when small sections of code are sent to perltidy from within an editor. The reason is that perltidy can usually format a small container spanning multiple lines of code provided that the parens, braces and brackets are balanced. For the default style, the number of lines required to make a balanced selection of code is generally less than for other styles. For example, if a cuddled style is used, then an entire if-elsif- chain must be selected for formatting rather than an individual elsif block. This can be tedious and time consuming.
Do you almost always want to run perltidy as a standard filter on just one input file? If yes, use -st and -se.
Perltidy will set line breaks to prevent lines from exceeding the maximum line length.
Do you want the maximum line length to be 80 columns? If no, use -l=n, where n is the number of columns you prefer.
When setting the maximum line length, something to consider is that perltidy will use this to decide when a list of items should be broken into multiple lines. So if it is set excessively large, lists may be so wide that they are hard to read.
In the block below, the variable $anchor is one indentation level deep and is indented by 4 spaces as shown here:
if ( $flag eq "a" ) {
$anchor = $header;
}If you want to change this to be a different number n of spaces per indentation level, use -i=n.
Look at the statement beginning with $anchor:
if ( $flag eq "a" ) {
$anchor =
substr( $header, 0, 6 )
. substr( $char_list, $place_1, 1 )
. substr( $char_list, $place_2, 1 );
}The statement is too long for the line length (80 characters by default), so it has been broken into 4 lines. The second and later lines have some extra "continuation indentation" to help make the start of the statement easy to find. The default number of extra spaces is 2. If you prefer a number n different from 2, you may specify this with -ci=n. It is probably best if it does not exceed the value of the primary indentation.
The default, and recommendation, is to represent leading whitespace with actual space characters. However, if you prefer to entab leading whitespace of lines of code with one tab character for each n spaces, use -et=n. The value of n should be set to be the same as used by your display software. If there is a disagreement, then vertical alignment will not be displayed correctly.
Please note that this number n has nothing to do with the number of spaces for one level of indentation, which is specified separately with -i=n.
Opening and closing curly braces, parentheses, and square brackets are divided into two separate categories and controlled separately in most cases. The two categories are (1) code block curly braces, which contain perl code, and (2) everything else. Basically, a code block brace is one which could contain semicolon-terminated lines of perl code. We will first work on the scheme for code block curly braces.
Decide which of the following opening brace styles you prefer for most blocks of code (with the possible exception of a sub block brace which will be covered later):
If you like opening braces on the right, like this, go to "Opening Braces Right".
if ( $flag eq "h" ) {
$headers = 0;
}If you like opening braces on the left, like this, go to "Opening Braces Left".
if ( $flag eq "h" )
{
$headers = 0;
}In a multi-line if test expression, the default is to place the opening brace on the left, like this:
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 )
{
big_waste_of_time();
}This helps to visually separate the block contents from the test expression.
An alternative is to keep the brace on the right even for multiple-line test expressions, like this:
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 ) {
big_waste_of_time();
}If you prefer this alternative, use -bar.
Do you prefer this Cuddled Else style
if ( $flag eq "h" ) {
$headers = 0;
} elsif ( $flag eq "f" ) {
$sectiontype = 3;
} else {
print "invalid option: " . substr( $arg, $i, 1 ) . "\n";
dohelp();
}instead of this default style?
if ( $flag eq "h" ) {
$headers = 0;
}
elsif ( $flag eq "f" ) {
$sectiontype = 3;
}
else {
print "invalid option: " . substr( $arg, $i, 1 ) . "\n";
dohelp();
}If yes, you should use -ce. Now skip ahead to "Opening Sub Braces".
Use -bl if you prefer this style:
if ( $flag eq "h" )
{
$headers = 0;
}Use -bli if you prefer this indented-brace style:
if ( $flag eq "h" )
{
$headers = 0;
}The number of spaces of extra indentation will be the value specified for continuation indentation with the -ci=n parameter (2 by default).
By default, the opening brace of a sub block will be treated the same as other code blocks. If this is okay, skip ahead to "Block Brace Vertical Tightness".
If you prefer an opening sub brace to be on a new line, like this:
sub message
{
# -sbl
}use -sbl. If you prefer the sub brace on the right like this
sub message {
# -nsbl
}use -nsbl.
If you wish to give this opening sub brace some indentation you can do that with the parameters -bli and -blil which are described in the manual.
If you chose to put opening block braces of all types to the right, skip ahead to "Closing Block Brace Indentation".
If you chose to put braces of any type on the left, the default is to leave the opening brace on a line by itself, like this (shown for -bli, but also true for -bl):
if ( $flag eq "h" )
{
$headers = 0;
}But you may also use this more compressed style if you wish:
if ( $flag eq "h" )
{ $headers = 0;
}If you do not prefer this more compressed form, go to "Opening Sub Braces".
Otherwise use parameter -bbvt=n, where n=1 or n=2. To decide, look at this snippet:
# -bli -bbvt=1
sub _directives
{
{
'ENDIF' => \&_endif,
'IF' => \&_if,
};
}
# -bli -bbvt=2
sub _directives
{ {
'ENDIF' => \&_endif,
'IF' => \&_if,
};
}The difference is that -bbvt=1 breaks after an opening brace if the next line is unbalanced, whereas -bbvt=2 never breaks.
If you were expecting the 'ENDIF' word to move up vertically here, note that the second opening brace in the above example is not a code block brace (it is a hash brace), so the -bbvt does not apply to it (another parameter will).
The default is to place closing braces at the same indentation as the opening keyword or brace of that code block, as shown here:
if ($task) {
yyy();
} # defaultIf you chose the -bli style, however, the default closing braces will be indented one continuation indentation like the opening brace:
if ($task)
{
yyy();
} # -bliIf you prefer to give closing block braces one full level of indentation, independently of how the opening brace is treated, for example like this:
if ($task) {
yyy();
} # -icbuse -icb.
This completes the definition of the placement of code block braces.
You have a choice of two basic indentation schemes for non-block containers. The default is to use a fixed number of spaces per indentation level (the same number of spaces used for code blocks, which is 4 by default). Here is an example of the default:
$dbh = DBI->connect(
undef, undef, undef,
{
PrintError => 0,
RaiseError => 1
}
);In this default indentation scheme, a simple formula is used to find the indentation of every line. Notice how the first 'undef' is indented 4 spaces (one level) to the right, and how 'PrintError' is indented 4 more spaces (one more level) to the right.
The alternate is to let the location of the opening paren (or square bracket, or curly brace) define the indentation, like this:
$dbh = DBI->connect(
undef, undef, undef,
{
PrintError => 0,
RaiseError => 1
}
);The first scheme is completely robust. The second scheme often looks a little nicer, but be aware that deeply nested structures it can be spoiled if the line length limit is exceeded. Also, if there are comments or blank lines within a complex structure perltidy will temporarily fall back on the default indentation scheme. You may want to try both on large sections of code to see which works best.
Also note that a disadvantage of this second scheme is that small changes in code, such as a change in the length of a sub name, can cause changes in many lines of code. For example, if we decide to change the name connect to connect_to_destination, then all of the call args would have to move right by 15 spaces. This can produce a lot of lines of differences when changes are committed.
If you prefer the first (default) scheme, no parameter is needed.
If you prefer the latter scheme, use --line-up-parentheses, or -lp. There is an alternative version of this option named --extended-line-up-parentheses, or -xlp which can also be used. For simplicity, the name -lp will refer to either of these options in the following text.
The following snippet is displayed with the default formatting:
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);For this type of structure, where an inner container is nested within an outer container, we can get a more compact display with the parameter --weld-nested-containers, or -wn:
# perltidy -wn
$opt_c = Text::CSV_XS->new( {
binary => 1,
sep_char => $opt_c,
always_quote => 1,
} );The name of the parameter comes from the idea that the two opening and two closing tokens have been 'welded' together to act as a single unit. The indentation spaces of the contents has also been reduced by one level.
This is a nice transformation because it is symmetric at the opening and closing, and leaves a sort of 'sandwich' structure 0which is still quite readable.
Some parameters available for asymmetric compressions, at just the opening or closing of complex structures, are described in the next sections.
The information in this section applies mainly to the -lp style but it also applies in some cases to the default style. It will be illustrated for the -lp indentation style.
The default -lp indentation style ends a line at the opening tokens, like this:
$dbh = DBI->connect(
undef, undef, undef,
{
PrintError => 0,
RaiseError => 1
}
);Here is a tighter alternative, which does not end a line with the opening tokens:
$dbh = DBI->connect( undef, undef, undef,
{ PrintError => 0,
RaiseError => 1
}
);The difference is that the lines have been compressed vertically without any changes to the indentation. This can almost always be done with the -lp indentation style, but only in limited cases for the default indentation style.
If you prefer the default, skip ahead to "Closing Token Placement".
Otherwise, use -vt=n, where n should be either 1 or 2. To help decide, observe the first three opening parens in the following snippet and choose the value of n you prefer. Here it is with -lp -vt=1:
if (
!defined(
start_slip( $DEVICE, $PHONE, $ACCOUNT, $PASSWORD,
$LOCAL, $REMOTE, $NETMASK, $MTU
)
)
&& $continuation_flag
)
{
do_something_about_it();
}And here it is again formatted with -lp -vt=2:
if ( !defined( start_slip( $DEVICE, $PHONE, $ACCOUNT, $PASSWORD,
$LOCAL, $REMOTE, $NETMASK, $MTU
)
)
&& $continuation_flag
)
{
do_something_about_it();
}The -vt=1 style tries to display the structure by preventing more than one step in indentation per line. In this example, the first two opening parens were not followed by balanced lines, so -vt=1 broke after them.
The -vt=2 style does not limit itself to a single indentation step per line.
Note that in the above example the function 'do_something_about_it' started on a new line. This is because it follows an opening code block brace and is governed by the flag previously set in "Block Brace Vertical Tightness".
You have several options for dealing with the terminal closing tokens of non-blocks. In the following examples, a closing parenthesis is shown, but these parameters apply to closing square brackets and non-block curly braces as well.
The default behavior for parenthesized relatively large lists is to place the closing paren on a separate new line. The flag -cti=n controls the amount of indentation of such a closing paren.
The default, -cti=0, for a line beginning with a closing paren, is to use the indentation defined by the next (lower) indentation level. This works well for the default indentation scheme:
# perltidy
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);but it may not look very good with the -lp indentation scheme:
# perltidy -lp
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);An alternative which works well with -lp indentation is -cti=1, which aligns the closing paren vertically with its opening paren, if possible:
# perltidy -lp -cti=1
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);Another alternative, -cti=3, indents a line with leading closing paren one full indentation level:
# perltidy -lp -cti=3
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);If you prefer the closing paren on a separate line like this, note the value of -cti=n that you prefer and skip ahead to "Define Horizontal Tightness".
Finally, the question of paren indentation can be avoided by placing it at the end of the previous line, like this:
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );Perltidy will automatically do this to save space for very short lists but not for longer lists.
Use -vtc=n if you prefer to usually do this, where n is either 1 or 2. To determine n, we have to look at something more complex. Observe the behavior of the closing tokens in the following snippet:
Here is -lp -vtc=1:
$srec->{'ACTION'} = [
$self->read_value(
$lookup->{'VFMT'},
$loc, $lookup, $fh
),
$self->read_value(
$lookup->{'VFMT2'},
$loc, $lookup, $fh
) ];Here is -lp -vtc=2:
$srec->{'ACTION'} = [
$self->read_value(
$lookup->{'VFMT'},
$loc, $lookup, $fh ),
$self->read_value(
$lookup->{'VFMT2'},
$loc, $lookup, $fh ) ];Choose the one that you prefer. The difference is that -vtc=1 leaves closing tokens at the start of a line within a list, which can assist in keeping hierarchical lists readable. The -vtc=2 style always tries to move closing tokens to the end of a line.
If you choose -vtc=1, you may also want to specify a value of -cti=n (previous section) to handle cases where a line begins with a closing paren.
In the following snippet the opening hash brace has been placed alone on a new line.
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);If you prefer to avoid isolated opening tokens by "stacking" them together with other opening tokens like this:
$opt_c = Text::CSV_XS->new( {
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);use -sot.
Likewise, in the same snippet the default formatting leaves the closing paren on a line by itself here:
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);If you would like to avoid leaving isolated closing tokens by stacking them with other closing tokens, like this:
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
} );use -sct.
The -sct flag is somewhat similar to the -vtc flags, and in some cases it can give a similar result. The difference is that the -vtc flags try to avoid lines with leading opening tokens by "hiding" them at the end of a previous line, whereas the -sct flag merely tries to reduce the number of lines with isolated closing tokens by stacking multiple closing tokens together, but it does not try to hide them.
The manual shows how all of these vertical tightness controls may be applied independently to each type of non-block opening and opening token.
Also, note that --weld-nested-containers, or -wn, mentioned previously, operates like the combination of -sot and -sct and also reduces the indentation level of the contents.
Horizontal tightness parameters define how much space is included within a set of container tokens.
For parentheses, decide which of the following values of -pt=n you prefer:
if ( ( my $len_tab = length( $tabstr ) ) > 0 ) { # -pt=0
if ( ( my $len_tab = length($tabstr) ) > 0 ) { # -pt=1 (default)
if ((my $len_tab = length($tabstr)) > 0) { # -pt=2For n=0, space is always used, and for n=2, space is never used. For the default n=1, space is used if the parentheses contain more than one token.
For square brackets, decide which of the following values of -sbt=n you prefer:
$width = $col[ $j + $k ] - $col[ $j ]; # -sbt=0
$width = $col[ $j + $k ] - $col[$j]; # -sbt=1 (default)
$width = $col[$j + $k] - $col[$j]; # -sbt=2For curly braces, decide which of the following values of -bt=n you prefer:
$obj->{ $parsed_sql->{ 'table' }[0] }; # -bt=0
$obj->{ $parsed_sql->{'table'}[0] }; # -bt=1 (default)
$obj->{$parsed_sql->{'table'}[0]}; # -bt=2For code block curly braces, decide which of the following values of -bbt=n you prefer:
%bf = map { $_ => -M $_ } grep { /\.deb$/ } dirents '.'; # -bbt=0 (default)
%bf = map { $_ => -M $_ } grep {/\.deb$/} dirents '.'; # -bbt=1
%bf = map {$_ => -M $_} grep {/\.deb$/} dirents '.'; # -bbt=2The default is not to place a space after a function call:
myfunc( $a, $b, $c ); # defaultIf you prefer a space:
myfunc ( $a, $b, $c ); # -sfpuse -sfp.
The default is to place a space between only these keywords and an opening paren:
my local our and or eq ne if else elsif until unless
while for foreach return switch case given whenbut no others. For example, the default is:
$aa = pop(@bb);If you want a space between all Perl keywords and an opening paren,
$aa = pop (@bb);use -skp. For detailed control of individual keywords, see the manual.
The default is not to put a space before a statement termination semicolon, like this:
$i = 1;If you prefer a space, like this:
$i = 1 ;enter -sts.
The default is to place a space before a semicolon in a for statement, like this:
for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { # -sfs (default)If you prefer no such space, like this:
for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { # -nsfsenter -nsfs.
Block comments are comments which occupy a full line, as opposed to side comments. The default is to indent block comments with the same indentation as the code block that contains them (even though this will allow long comments to exceed the maximum line length).
If you would like block comments indented except when this would cause the maximum line length to be exceeded, use -olc. This will cause a group of consecutive block comments to be outdented by the amount needed to prevent any one from exceeding the maximum line length.
If you never want block comments indented, use -nibc.
If block comments may only be indented if they have some space characters before the leading # character in the input file, use -isbc.
The manual shows many other options for controlling comments.
Long quoted strings may exceed the specified line length limit. The default, when this happens, is to outdent them to the first column. Here is an example of an outdented long quote:
if ($source_stream) {
if ( @ARGV > 0 ) {
die
"You may not specify any filenames when a source array is given\n";
}
}The effect is not too different from using a here document to represent the quote. If you prefer to leave the quote indented, like this:
if ($source_stream) {
if ( @ARGV > 0 ) {
die
"You may not specify any filenames when a source array is given\n";
}
}use -nolq.
This document has only covered the most popular parameters. The manual contains many more and should be consulted if you did not find what you need here.
Now gather together all of the parameters you prefer and enter them in a file called .perltidyrc.
Here are some example .perltidyrc files and the corresponding style.
Here is a little test snippet, shown the way it would appear with the default style.
for (@methods) {
push (
@results,
{
name => $_->name,
help => $_->help,
}
);
}You do not need a .perltidyrc file for this style.
Here is the same snippet
for (@methods)
{
push(@results,
{ name => $_->name,
help => $_->help,
}
);
}for a .perltidyrc file containing these parameters:
-bl
-lp
-cti=1
-vt=1
-pt=2You do not need to place just one parameter per line, but this may be convenient for long lists. You may then hide any parameter by placing a # symbol before it.
And here is the snippet
for (@methods) {
push ( @results,
{ name => $_->name,
help => $_->help,
} );
}for a .perltidyrc file containing these parameters:
-lp
-vt=1
-vtc=1For further information see the perltidy documentation at Sourceforge or at metacpan. or at GitHub
The source code is maintained at GitHub.
Perl-Tidy-20250105/docs/ChangeLog.html 0000644 0001750 0001750 00000614615 14735777213 016323 0 ustar steve steve- If a file consists only of comments, then the starting indentation will
be guessed from the indentation of the first comment. Previously it would
be guessed to be zero. Parameter --starting-indentation-level=n can be
used to specify an indentation and avoid a guess. This issue can
arise when formatting a block of comments from within an editor.
- Added missing 'use File::Temp' for -html option. This was causing the
message: "Undefined subroutine &File::Temp::tempfile called at ..."
See git #176.
- A new parameter --dump-unique-keys, or -duk, dumps a list of hash keys
which appear to be used just once, and do not appear among the quoted
strings in a file. For example:
perltidy -duk File.pm >output.txt
This can help locate misspelled hash keys.
- Line breaks at long chains of method calls now break at all calls
with args in parens, as in this example from git #171
# Old default
sub bla_p( $value = 42 ) {
return Mojo::Promise->resolve($value)->then( sub { shift() / 2 } )
->then( sub { shift() + 6 } )->then( sub { shift() / 2 } )
->catch( sub { warn shift } );
}
# New default
sub bla_p( $value = 42 ) {
return Mojo::Promise->resolve($value)
->then( sub { shift() / 2 } )
->then( sub { shift() + 6 } )
->then( sub { shift() / 2 } )
->catch( sub { warn shift } );
}
- Parameter --break-at-old-method-breakpoints, or -bom, has been
updated to insure that it only applies to lines beginning with
method calls, as intended. Line breaks for all lines beginning with
'->', even non-method calls, can be retained by using
--keep-old-breakpoints_before='->'.
- Added parameter --multiple-token-tightness=s, or -mutt=s.
The default value --paren-tightness=1 adds space within the parens
if, and only if, the container holds multiple tokens. Some perltidy
tokens may be rather long, and it can be preferable to also space some of
them as if they were multiple tokens. This can be done with this parameter,
and it applies to parens as well as square brackets and curly braces.
For example, the default below has no space within the square brackets:
# perltidy
my $rlist = [qw( alpha beta gamma )];
Spaces can be obtained with:
# perltidy -mutt='q*'
my $rlist = [ qw( alpha beta gamma ) ];
The parameter -mutt='q*' means treat qw and similar quote operators as
multiple tokens. The manual has details; git #120 has another example.
- Added parameter --indent-leading-semicolon, -ils; see git #171. When
this is negated, a line with a leading semicolon does not get the extra
leading continuation indentation spaces (defined with -ci=n).
- Space around here doc delimiters follow spacing controls better. For
example, a space is now added before the closing paren here:
OLD: (without the here doc):
push( @script, <<'EOT');
NEW:
push( @script, <<'EOT' );
Also, any spaces between the '<<' and here target are removed (git #174):
OLD:
push( @script, << 'EOT');
NEW:
push( @script, <<'EOT' );
- Added parameter --break-at-trailing-comma-types=s, or -btct=s, where
s is a string which selects trailing commas. For example, -btct='f(b'
places a line break after all bare trailing commas in function calls.
The manual has details.
- Fix git #165, strings beginning with v before => gave an incorrect error
message.
- The parameter --add-lone-trailing-commas, -altc, is now on by default.
This will simplify input for trailing comma operations. Use
--noadd-lone-trailing-commas, or -naltc to turn it off.
- More edge cases for adding and deleting trailing commas are now handled
(git #156).
- A problem has been fixed in which the addition or deletion of trailing
commas with the -atc or -dtc flags did not occur due to early convergence
when the -conv flag was set (git #143).
- Added parameter --qw-as-function, or -qwaf, discussed in git #164.
When this parameter is set, a qw list which begins with 'qw(' is
formatted as if it were a function call with call args being a list
of comma-separated quoted items. For example, given this input:
@fields = qw( $st_dev $st_ino $st_mode $st_nlink $st_uid
$st_gid $st_rdev $st_size $st_atime $st_mtime $st_ctime
$st_blksize $st_blocks);
# perltidy -qwaf
@fields = qw(
$st_dev $st_ino $st_mode $st_nlink
$st_uid $st_gid $st_rdev $st_size
$st_atime $st_mtime $st_ctime $st_blksize
$st_blocks
);
- Add partial support for Syntax::Operator::In and Syntax::Keyword::Match
(see git #162).
- Add --timeout-in-seconds=n, or -tos=n. When the standard input supplies
the input stream, and the input has not been received within n seconds,
perltidy will end with a timeout message. The intention is to catch
a situation where perltidy is accidentally invoked without a file to
process and therefore waits for input from the system standard input
(stdin), which never arrives. The default is n=10.
This check can be turned off with -tos=0.
- Add parameter --closing-side-comment-exclusion-list=string, or
-cscxl=string, where string is a list of block types to exclude
for closing side comment operations. Also, closing side comments
now work for anonymous subs if a --closing-side-comment-list (-cscl)
is not specified, and when 'asub' is requested with -cscl=asub.
Use -cscxl=asub to prevent this.
- Include check for unused constants in --dump-unusual-variables and
--warn-variable-types (new issue type 'c'). Also expand checks to
cover variables introduced with 'use vars'.
- Include signature variables in --dump-unusual-variables and
--warn-variable-types; see git #158.
- Add logical xor operator ^^ available in perl version 5.40, as
noted in git #157.
- Keyword 'state' now has default space before a paren, like 'my'.
Previously there was no space and no control. So the default
is now "state ($x)". This space can be removed with -nsak='state'.
- Add options --add-lone-trailing-commas, -altc and
--delete-lone-trailing-commas, -dltc, to provide control over adding
and deleting the only comma in a list. See discussion in git #143
and the updated manual.
- Add options --dump-mismatched-returns (or -dmr) and
--warn-mismatched-returns (or -wmr). These options report function
calls where the number of values requested may disagree with sub
return statements. The -dump version writes the results for a single
file to standard output and exits:
perltidy -dmr somefile.pl >results.txt
The -warn version formats as normal but reports any issues as warnings in
the error file:
perltidy -wmr somefile.pl
The -warn version may be customized with the following additional
parameters if necessary to avoid needless warnings:
--warn-mismatched-return-types=s (or -wmrt=s),
--warn-mismatched-return-exclusion-list=s (or -wmrxl=s)
where 's' is a control string. These are explained in the manual.
- Updates for issue git #151:
(1) --warn-variable-types=u is now okay if a named file is processed.
(2) --warn-variable-exclusion-list=s now allows leading and/or
trailing * on variable names to allow a wildcard match. For example
-wvxl='*_unused' is okay and would match $var1_unused and $var2_unused.
(3) --dump-unusual-variables now outputs the filename.
- A option was added to filter unimplemented parameters from perltidy
configuration files, suggested in git #146. It works like this: if
a line in the config file begins with three dashes followed by a
parameter name (rather than two dashes), then the line will be removed
if the parameter is unknown. Otherwise, a dash will be removed to make
the line valid.
- Parameters --dump-mismatched-args (or -dma) and
--warn-mismatched-args (or -wma) have been updated to catch more
arg count issues.
- Fixed issue git #143, extend -add-trailing-commas to apply to a list
with just a fat comma.
- The minimum perl version is 5.8.1. Previously it was 5.8.0, which was
not correct because of the use of utf8::is_utf8.
- Fixed issue git #142, test failure installing on perl versions before
version 5.10. The error caused the new parameter
-interbracket-arrow-style=s not to work. Except for this limitation,
Version 20240511 will work on older perl versions.
- The option --valign-signed-numbers, or -vsn is now the default. It
was introduced in the previous release has been found to significantly
improve the overall appearance of columns of signed and unsigned
numbers. See the previous Change Log entry for an example.
This will change the formatting in scripts with columns
of vertically aligned signed and unsigned numbers.
Use -nvsn to turn this option off and avoid this change.
- The option --delete-repeated-commas is now the default.
It makes the following checks and changes:
- Repeated commas like ',,' are removed with a warning
- Repeated fat commas like '=> =>' are removed with a warning
- The combination '=>,' produces a warning but is not changed
These warnings are only output if --warning-output, or -w, is set.
Use --nodelete-repeated-commas, or -ndrc, to retain repeated commas.
- Previously, a line break was always made before a concatenated
quoted string, such as "\n", if the previous line had a greater
starting indentation. An exception is now made for a short concatenated
terminal quote. This keeps code a little more compact. For example:
# basic rule: break before "\n" here because '$name' has more indentation:
my $html = $this->SUPER::genObject( $query, $bindNode, $field . ":$var",
$name, "remove", "UNCHECKED" )
. "\n";
# modified rule: make an exception for a short terminal quote like "\n"
my $html = $this->SUPER::genObject( $query, $bindNode, $field . ":$var",
$name, "remove", "UNCHECKED" ) . "\n";
- The operator ``**=`` now has spaces on both sides by default. Previously,
there was no space on the left. This change makes its spacing the same
as all other assignment operators. The previous behavior can be obtained
with the parameter setting -nwls='**='.
- The option --file-size-order, or -fso is now the default. When
perltidy is given a list of multiple filenames to process, they
are sorted by size and processed in order of increasing size.
This can significantly reduce memory usage by Perl. This
option has always been used in testing, where typically several
jobs each operating on thousands of filenames are running at the
same time and competing for system resources. If this option
is not wanted for some reason, it can be deactivated with -nfso.
- In the option --dump-block-summary, the number of sub arguments indicated
for each sub now includes any leading object variable passed with
an arrow-operator call. Previously the count would have been decreased
by one in this case. This change is needed for compatibility with future
updates.
- Fix issue git #138 involving -xlp (--extended-line-up-parentheses).
When multiple-line quotes and regexes have long secondary lines, these
line lengths could influencing some spacing and indentation, but they
should not have since perltidy has no control over their indentation.
This has been fixed. This will mainly influence code which uses -xlp
and has long multi-line quotes.
- Add option --minimize-continuation-indentation, -mci (see git #137).
This flag allows perltidy to remove continuation indentation in some
special cases where it is not really unnecessary. For a simple example,
the default formatting for the following snippet is:
# perltidy -nmci
$self->blurt( "Error: No INPUT definition for type '$type', typekind '"
. $type->xstype
. "' found" );
The second and third lines are one level deep in a container, and
are also statement continuations, so they get indented by the sum
of the -i value and the -ci value. If this flag is set, the
indentation is reduced by -ci spaces, giving
# perltidy -mci
$self->blurt( "Error: No INPUT definition for type '$type', typekind '"
. $type->xstype
. "' found" );
This situation is relatively rare except in code which has long
quoted strings and the -nolq flag is also set. This flag is currently
off by default, but it could become the default in a future version.
- Add options --dump-mismatched-args (or -dma) and
--warn-mismatched-args (or -wma). These options look
for and report instances where the number of args expected by a
sub appear to differ from the number passed to the sub. The -dump
version writes the results for a single file to standard output
and exits:
perltidy -dma somefile.pl >results.txt
The -warn version formats as normal but reports any issues as warnings in
the error file:
perltidy -wma somefile.pl
The -warn version may be customized with the following additional parameters
if necessary to avoid needless warnings:
--warn-mismatched-arg-types=s (or -wmat=s),
--warn-mismatched-arg-exclusion-list=s (or -wmaxl=s), and
--warn-mismatched-arg-undercount-cutoff=n (or -wmauc=n).
--warn-mismatched-arg-overcount-cutoff=n (or -wmaoc=n).
These are explained in the manual.
- Add option --valign-wide-equals, or -vwe, for issue git #135.
Setting this parameter causes the following assignment operators
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
to be aligned vertically with the ending = all aligned. For example,
here is the default formatting of a snippet of code:
$str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
$str_len += $rfield_lengths->[$j];
And here is the same code formatted with -vwe:
# perltidy -vwe
$str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
$str_len += $rfield_lengths->[$j];
This option currently is off by default to avoid changing existing
formatting.
- Added control --delete-interbracket-arrows, or -dia, to delete optional
hash ref and array ref arrows between brackets as in the following
expression (see git #131)
return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'};
# perltidy -dia gives:
return $self->{'commandline'}{'arg_list'}[0][0]{'hostgroups'};
Added the opposite control --aia-interbracket-arrows, or -aia, to
add arrows. So applied to the previous line the arrows are restored:
# perltidy -aia
return $self->{'commandline'}->{'arg_list'}->[0]->[0]->{'hostgroups'};
The manual describes additional controls for adding and deleting
just selected interbracket arrows.
- Added --valign-signed-numbers, or -vsn. This improves the appearance
of columns of numbers by aligning leading algebraic signs. For example:
# perltidy -vsn
my $xyz_shield = [
[ -0.060, -0.060, 0. ],
[ 0.060, -0.060, 0. ],
[ 0.060, 0.060, 0. ],
[ -0.060, 0.060, 0. ],
[ -0.0925, -0.0925, 0.092 ],
[ 0.0925, -0.0925, 0.092 ],
[ 0.0925, 0.0925, 0.092 ],
[ -0.0925, 0.0925, 0.092 ],
];
# perltidy -nvsn (current DEFAULT)
my $xyz_shield = [
[ -0.060, -0.060, 0. ],
[ 0.060, -0.060, 0. ],
[ 0.060, 0.060, 0. ],
[ -0.060, 0.060, 0. ],
[ -0.0925, -0.0925, 0.092 ],
[ 0.0925, -0.0925, 0.092 ],
[ 0.0925, 0.0925, 0.092 ],
[ -0.0925, 0.0925, 0.092 ],
];
This new option works well but is currently OFF to allow more testing
and fine-tuning. It is expected to be activated in a future release.
- Added --dump-mixed-call-parens (-dmcp ) which will dump a list of
operators which are sometimes followed by parens and sometimes not.
This can be useful for developing a uniform style for selected operators.
Issue git #128. For example
perltidy -dmcp somefile.pl >out.txt
produces lines like this, where the first number is the count of
uses with parens, and the second number is the count without parens.
k:caller:2:1
k:chomp:3:4
k:close:7:4
- Added --want-call-parens=s (-wcp=s) and --nowant-call-parens=s (-nwcp=s)
options which will warn of paren uses which do not match a selected
style. The manual has details. But for example,
perltidy -wcp='&' somefile.pl
will format as normal but warn if any user subs are called without parens.
- Added --dump-unusual-variables (-duv) option to dump a list of
variables with certain properties of interest. For example
perltidy -duv somefile.pl >vars.txt
produces a file with lines which look something like
1778:u: my $input_file
6089:r: my $j: reused - see line 6076
The values on the line which are separated by colons are:
line number - the number of the line of the input file
issue - a single letter indicating the issue, see below
variable name - the name of the variable, preceded by a keyword
note - an optional note referring to another line
The issue is indicated by a letter which may be one of:
r: reused variable name
s: sigil change but reused bareword
p: lexical variable with scope in multiple packages
u: unused variable
This is very useful for locating problem areas and bugs in code.
- Added a related flag --warn-variable-types=string (-wvt=string) option
to warn if certain types of variables are found in a script. The types
are a space-separated string which may include 'r', 's', and 'p' but
not 'u'. For example
perltidy -wvt='r s' somefile.pl
will check for and warn if any variabls of type 'r', or 's' are seen,
but not 'p'. All possible checks may be indicated with a '*' or '1':
perltidy -wvt='*' somefile.pl
The manual has further details.
- All parameters taking integer values are now checked for
out-of-range values before processing starts. When a maximum or
maximum range is exceeded, the new default behavior is to write a
warning message, reset the value to its default setting, and continue.
This default behavior can be changed with the new parameter
--integer-range-check=n, or -irc=n, as follows:
n=0 skip check completely (for stress-testing perltidy only)
n=1 reset bad values to defaults but do not issue a warning
n=2 reset bad values to defaults and issue a warning [DEFAULT]
n=3 stop immediately if any values are out of bounds
The settings n=0 and n=1 are mainly useful for testing purposes.
- The --dump-block-summary (-dbs) option now includes the number of sub
args in the 'type' column. For example, 'sub(9)' indicates a sub
with 9 args. Subs whose arg count cannot easily be determined are
indicated as 'sub(*)'. The count does not include a leading '$self'
or '$class' arg.
- Added flag --space-signature-paren=n, or -ssp=n (issue git #125).
This flag works the same as the existing flag --space-prototype-paren=n
except that it applies to the space before the opening paren of a sub
signature instead of a sub prototype. Previously, there was no control
over this (a space always occurred). For example, given the following
line:
sub circle( $xc, $yc, $rad );
The following results can now be obtained, according to the value of n:
sub circle( $xc, $yc, $rad ); # n=0 [no space]
sub circle( $xc, $yc, $rad ); # n=1 [default; same as input]
sub circle ( $xc, $yc, $rad ); # n=2 [space]
The spacing in previous versions of perltidy corresponded to n=2 (always
a space). The new default value, n=1, will produce a space if and only
if there was a space in the input text.
- The --dump-block-summary option can report an if-elsif-elsif-.. chain
as a single line item with the notation -dbt='elsif3', for example,
where the '3' is an integer which specifies the minimum number of elsif
blocks required for a chain to be reported. The manual has details.
- Fix problem c269, in which the new -ame parameter could incorrectly
emit an else block when two elsif blocks were separated by a hanging
side comment (a very rare situation).
- When braces are detected to be unbalanced, an attempt is made to
localize the error by comparing the indentation at closing braces
with their actual nesting levels. This can be useful for files which
have previously been formatted by perltidy. To illustrate, a test was
made in which the closing brace at line 30644 was commented out in
a file with a total of over 62000 lines. The new error message is
Final nesting depth of '{'s is 1
The most recent un-matched '{' is on line 6858
...
Table of nesting level differences at closing braces.
This might help localize brace errors if the file was previously formatted.
line: (brace level) - (level expected from old indentation)
30643: 0
30645: 1
Previously, the error file only indicated that the error in this case
was somewhere after line 6858, so the new table is very helpful. Closing
brace indentation is checked because it is unambiguous and can be done
very efficiently.
- The -DEBUG option no longer automatically also writes a .LOG file.
Use --show-options if the .LOG file is needed.
- The run time of this version with all new options in use is no greater
than that of the previous version thanks to optimization work.
- Fix for git #124: remove a syntax error check which could cause
an incorrect error message when List::Gather::gather was used.
- Added new parameters -wme, or --warn-missing-else, and -ame,
or --add-missing else. The parameter -wme tells perltidy to issue
a warning if an if-elsif-... chain does not end in an else block.
The parameter -ame tells perltidy to insert an else block at the
end of such a chain if there is none.
For example, given the following snippet:
if ( $level == 3 ) { $val = $global{'section'} }
elsif ( $level == 2 ) { $val = $global{'chapter'} }
# perltidy -ame
if ( $level == 3 ) { $val = $global{'section'} }
elsif ( $level == 2 ) { $val = $global{'chapter'} }
else {
##FIXME - added with perltidy -ame
}
The resulting code should be carefully reviewed, and the ##FIXME comment
should be updated as appropriate. The text of the ##FIXME comment can be
changed with parameter -amec=s, where 's' is the comment to mark the new
else block. The man pages have more details.
- The syntax of the parameter --use-feature=class, or -uf=class, which
new in the previous release, has been changed slightly for clarity.
The default behavior, which occurs if this flag is not entered, is
to automatically try to handle both old and new uses of the keywords
'class', 'method', 'field', and 'ADJUST'.
To force these keywords to only follow the -use feature 'class' syntax,
enter --use-feature=class.
To force perltidy to ignore the -use feature 'class' syntax, enter
--use-feature=noclass.
- Issue git #122. Added parameter -lrt=n1:n2, or --line-range-tidy=n1:n2
to limit tidy operations to a limited line range. Line numbers start
with 1. This parameter is mainly of interest to editing programs which
drive perltidy. The man pages have details.
- Some fairly rare instances of incorrect spacing have been fixed. The
problem was that the tokenizer being overly conservative in marking
terms as possible filehandles or indirect objects. This causes the space
after the possible filehandle to be frozen to its input value in order not
to introduce an error in case Perl had to guess. The problem was fixed
by having the tokenizer look ahead for operators which can eliminate the
uncertainty. To illustrate, in the following line the term ``$d`` was
previously marked as a possible filehandle, so no space was added after it.
print $d== 1 ? " [ON]\n" : $d ? " [$d]\n" : "\n";
^
In the current version, the next token is seen to be an equality, so
``$d`` is marked as an ordinary identifier and normal spacing rules
can apply:
print $d == 1 ? " [ON]\n" : $d ? " [$d]\n" : "\n";
^
- This version runs 7 to 10 percent faster than the previous release on
large files, depending on options and file type. Much of the gain comes
from streamlined I/O operations.
- This version was stress-tested for many cpu hours with random
input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- Issue git #121. Added parameters -xbt, or --extended-block-tightness,
and -xbtl=s, or --extended-block-tightness-list=s, to allow
certain small code blocks to have internal spacing controlled by
-bbt=n rather than -bt=n. The man pages have details.
- Issue git #118. A warning will be issued if a duplicate format-skipping
starting marker is seen within a format-skipping section. The same
applies to duplicate code-skipping starting markers within code-skipping
sections.
- Issue git #116. A new flag --valign-if-unless, -viu, was added to
allow postfix 'unless' terms to align with postfix 'if' terms. The
default remains not to do this.
- Fixed git #115. In the two most recent CPAN releases, when the
Perl::Tidy module was called with the source pointing to a file,
but no destination specified, the output went to the standard
output instead of to a file with extension ``.tdy``, as it should
have. This has been fixed.
- Fixed git #110, add missing documentation for new options
-cpb and -bfvt=n. These work in version 20230309 but the pod
documentation was missing and has been added.
- Fixed an undefined reference message when running with
--dump-block-summary on a file without any subs or other
selected block types.
- Add parameter -ipc, or --ignore-perlcritic-comments. Perltidy, by
default, will look for side comments beginning with ``## no critic`` and
ignore their lengths when making line break decisions, even if the user
has not set ``-iscl``. The reason is that an unwanted line break can
make these special comments ineffective in controlling ``perlcritic``.
The parameter -ipc can be set if, for some reason, this is not wanted.
- Some minor issues with continuation indentation have been fixed.
Most scripts will remain unchanged. The main change is that block
comments which occur just before a closing brace, bracket or paren
now have an indentation which is independent of the existence of
an optional comma or semicolon. Previously, adding or deleting
an optional trailing comma could cause their indentation to jump.
Also, indentation of comments within ternary statements has been
improved. For additional details see:
https://github.com/perltidy/perltidy/blob/master/docs/ci_update.md
- This version was stress-tested for many cpu hours with random
input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- This version runs several percent faster than the previous release
on large files.
- No significant bugs have been found since the last release to CPAN.
Several minor issues have been fixed, and some new parameters have been
added, as follows:
- Added parameter --one-line-block-exclusion-list=s, or -olbxl=s, where
s is a list of block types which should not automatically be turned
into one-line blocks. This implements the issue raised in PR #111.
The list s may include any of the words 'sort map grep eval', or
it may be '*' to indicate all of these. So for example to prevent
multi-line 'eval' blocks from becoming one-line blocks, the command
would be -olbxl='eval'.
- For the -b (--backup-and-modify-in-place) option, the file timestamps
are changing (git #113, rt#145999). First, if there are no formatting
changes to an input file, it will keep its original modification time.
Second, any backup file will keep its original modification time. This
was previously true for --backup-method=move but not for the default
--backup-method=copy. The purpose of these changes is to avoid
triggering Makefile operations when there are no actual file changes.
If this causes a problem please open an issue for discussion on github.
- A change was made to the way line breaks are made at the '.'
operator when the user sets -wba='.' to requests breaks after a '.'
( this setting is not recommended because it can be hard to read ).
The goal of the change is to make switching from breaks before '.'s
to breaks after '.'s just move the dots from the end of
lines to the beginning of lines. For example:
# default and recommended (--want-break-before='.'):
$output_rules .=
( 'class'
. $dir
. '.stamp: $('
. $dir
. '_JAVA)' . "\n" . "\t"
. '$(CLASSPATH_ENV) $(JAVAC) -d $(JAVAROOT) '
. '$(JAVACFLAGS) $?' . "\n" . "\t"
. 'echo timestamp > class'
. $dir
. '.stamp'
. "\n" );
# perltidy --want-break-after='.'
$output_rules .=
( 'class' .
$dir .
'.stamp: $(' .
$dir .
'_JAVA)' . "\n" . "\t" .
'$(CLASSPATH_ENV) $(JAVAC) -d $(JAVAROOT) ' .
'$(JAVACFLAGS) $?' . "\n" . "\t" .
'echo timestamp > class' .
$dir .
'.stamp' .
"\n" );
For existing code formatted with -wba='.', this may cause some
changes in the formatting of code with long concatenation chains.
- Added option --use-feature=class, or -uf=class, for issue rt #145706.
This adds keywords 'class', 'method', 'field', and 'ADJUST' in support of
this feature which is being tested for future inclusion in Perl.
An effort has been made to avoid conflicts with past uses of these
words, especially 'method' and 'class'. The default setting
is --use-feature=class. If this causes a conflict, this option can
be turned off by entering -uf=' '.
In other words, perltidy should work for both old and new uses of
these keywords with the default settings, but this flag is available
if a conflict arises.
- Added option -bfvt=n, or --brace-follower-vertical-tightness=n,
for part of issue git #110. For n=2, this option looks for lines
which would otherwise be, by default,
}
or ..
and joins them into a single line
} or ..
where the or can be one of a number of logical operators or if unless.
The default is not to do this and can be indicated with n=1.
- Added option -cpb, or --cuddled-paren-brace, for issue git #110.
This option will cause perltidy to join two lines which
otherwise would be, by default,
)
{
into a single line
) {
- Some minor changes to existing formatted output may occur as a result
of fixing minor formatting issues with edge cases. This is especially
true for code which uses the -lp or -xlp styles.
- Added option -dbs, or --dump-block-summary, to dump summary
information about code blocks in a file to standard output.
The basic command is:
perltidy -dbs somefile.pl >blocks.csv
Instead of formatting ``somefile.pl``, this dumps the following
comma-separated items describing its blocks to the standard output:
filename - the name of the file
line - the line number of the opening brace of this block
line_count - the number of lines between opening and closing braces
code_lines - the number of lines excluding blanks, comments, and pod
type - the block type (sub, for, foreach, ...)
name - the block name if applicable (sub name, label, asub name)
depth - the nesting depth of the opening block brace
max_change - the change in depth to the most deeply nested code block
block_count - the total number of code blocks nested in this block
mccabe_count - the McCabe complexity measure of this code block
This can be useful for code restructuring. The man page for perltidy
has more information and describes controls for selecting block types.
- This version was stress-tested for over 100 cpu hours with random
input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- This version runs a few percent faster than the previous release on
large files due to optimizations made with the help of Devel::NYTProf.
- Fix rt #145095, undef warning in Perl before 5.12. Version 20221112 is
identical to 2022111 except for this fix for older versions of Perl.
- No significant bugs have been found since the last release to CPAN.
Several minor issues have been fixed, and some new parameters have been
added, as follows:
- Fixed rare problem with irregular indentation involving --cuddled-else,
usually also with the combination -xci and -lp. Reported in rt #144979.
- Add option --weld-fat-comma (-wfc) for issue git #108. When -wfc
is set, along with -wn, perltidy is allowed to weld an opening paren
to an inner opening container when they are separated by a hash key
and fat comma (=>). For example:
# perltidy -wn
elf->call_method(
method_name_foo => {
some_arg1 => $foo,
some_other_arg3 => $bar->{'baz'},
}
);
# perltidy -wn -wfc
elf->call_method( method_name_foo => {
some_arg1 => $foo,
some_other_arg3 => $bar->{'baz'},
} );
This flag is off by default.
- Fix issue git #106. This fixes some edge cases of formatting with the
combination -xlp -pt=2, mainly for two-line lists with short function
names. One indentation space is removed to improve alignment:
# OLD: perltidy -xlp -pt=2
is($module->VERSION, $expected,
"$main_module->VERSION matches $module->VERSION ($expected)");
# NEW: perltidy -xlp -pt=2
is($module->VERSION, $expected,
"$main_module->VERSION matches $module->VERSION ($expected)");
- Fix for issue git #105, incorrect formatting with 5.36 experimental
for_list feature.
- Fix for issue git #103. For parameter -b, or --backup-and-modify-in-place,
the default backup method has been changed to preserve the inode value
of the file being formatted. If this causes a problem, the previous
method is available and can be used by setting -backup-mode='move', or
-bm='move'. The new default corresponds to -bm='copy'. The difference
between the two methods is as follows. For the older method,
-bm='move', the input file was moved to the backup, and a new file was
created for the formatted output. This caused the inode to change. For
the new default method, -bm='copy', the input is copied to the backup
and then the input file is reopened and rewritten. This preserves the
file inode. Tests have not produced any problems with this change, but
before using the --backup-and-modify-in-place parameter please verify
that it works correctly in your environment and operating system. The
initial update for this had an error which was caught and fixed
in git #109.
- Fix undefined value message when perltidy -D is used (git #104)
- Fixed an inconsistency in html colors near pointers when -html is used.
Previously, a '->' at the end of a line got the 'punctuation color', black
by default but a '->' before an identifier got the color of the following
identifier. Now all pointers get the same color, which is black by default.
Also, previously a word following a '->' was given the color of a bareword,
black by default, but now it is given the color of an identifier.
- Fixed incorrect indentation of any function named 'err'. This was
due to some old code from when "use feature 'err'" was valid.
# OLD:
my ($curr) = current();
err (@_);
# NEW:
my ($curr) = current();
err(@_);
- Added parameter --delete-repeated-commas (-drc) to delete repeated
commas. This is off by default. For example, given:
ignoreSpec( $file, "file",, \%spec, \%Rspec );
# perltidy -drc:
ignoreSpec( $file, "file", \%spec, \%Rspec );
- Add continuation indentation to long C-style 'for' terms; i.e.
# OLD
for (
$j = $i - $shell ;
$j >= 0
&& ++$ncomp
&& $array->[$j] gt $array->[ $j + $shell ] ;
$j -= $shell
)
# NEW
for (
$j = $i - $shell ;
$j >= 0
&& ++$ncomp
&& $array->[$j] gt $array->[ $j + $shell ] ;
$j -= $shell
)
This will change some existing formatting with very long 'for' terms.
- The following new parameters are available for manipulating
trailing commas of lists. They are described in the manual.
--want-trailing-commas=s, -wtc=s
--add-trailing-commas, -atc
--delete-trailing-commas, -dtc
--delete-weld-interfering-commas, -dwic
- Files with errors due to missing, extra or misplaced parens, braces,
or square brackets are now written back out verbatim, without any
attempt at formatting.
- This version runs 10 to 15 percent faster than the previous
release on large files due to optimizations made with the help of
Devel::NYTProf.
- This version was stress-tested for over 200 cpu hours with random
input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- No significant bugs have been found since the last release but users
of programs which call the Perl::Tidy module should note the first
item below, which changes a default setting. The main change to
existing formatting is the second item below, which adds vertical
alignment to 'use' statements.
- The flag --encode-output-strings, or -eos, is now set 'on' by default.
This has no effect on the use of the 'perltidy' binary script, but could
change the behavior of some programs which use the Perl::Tidy module on
files encoded in UTF-8. If any problems are noticed, an emergency fix
can be made by reverting to the old default by setting -neos. For
an explanation of why this change needs to be made see:
https://github.com/perltidy/perltidy/issues/92
https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md
- Added vertical alignment for qw quotes and empty parens in 'use'
statements (see issue #git 93). This new alignment is 'on' by default
and will change formatting as shown below. If this is not wanted it can
be turned off with the parameter -vxl='q' (--valign-exclusion-list='q').
# old default, or -vxl='q'
use Getopt::Long qw(GetOptions);
use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
use Symbol qw(gensym);
use Exporter ();
# new default
use Getopt::Long qw(GetOptions);
use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
use Symbol qw(gensym);
use Exporter ();
- The parameter -kbb (--keep-break-before) now ignores a request to break
before an opening token, such as '('. Likewise, -kba (--keep-break-after)
now ignores a request to break after a closing token, such as ')'. This
change was made to avoid a rare instability discovered in random testing.
- Previously, if a -dsc command was used to delete all side comments,
then any special side comments for controlling non-indenting braces got
deleted too. Now, these control side comments are retained when -dsc is
set unless a -nnib (--nonon-indenting-braces) flag is also set to
deactivate them.
- This version runs about 10 percent faster on large files than the previous
release due to optimizations made with the help of Devel::NYTProf. Much
of the gain came from faster processing of blank tokens and comments.
- This version of perltidy was stress-tested for many cpu hours with
random input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- A new flag, --encode-output-strings, or -eos, has been added to resolve
issue git #83. This issue involves the interface between Perl::Tidy and
calling programs, and Code::TidyAll (tidyall) in particular. The problem
is that perltidy by default returns decoded character strings, but
tidyall expects encoded strings. This flag provides a fix for that.
So, tidyall users who process encoded (utf8) files should update to this
version of Perl::Tidy and use -eos for tidyall. For further info see:
https://github.com/houseabsolute/perl-code-tidyall/issues/84, and
https://github.com/perltidy/perltidy/issues/83
If there are other applications having utf8 problems at the interface
with Perl::Tidy, this flag probably may need to be set.
- The default value of the new flag, --encode-output-strings, -eos, is currently
-neos BUT THIS MAY CHANGE in a future release because the current
default is inconvenient. So authors of programs which receive character
strings back from Perl::Tidy should set this flag, if necessary,
to avoid any problems when the default changes. For more information see the
above links and the Perl::Tidy man pages for example coding.
- The possible values of the string 's' for the flag '--character-encoding=s'
have been limited to 'utf8' (or UTF-8), 'none', or 'guess'. Previously an
arbitrary encoding could also be specified, but as a result of discussions
regarding git #83 it became clear that this could cause trouble
since the output encoding was still restricted to UTF-8. Users
who need to work in other encodings can write a short program calling
Perl::Tidy with pre- and post-processing to handle encoding/decoding.
- A new flag --break-after-labels=i, or -bal=i, was added for git #86. This
controls line breaks after labels, to provide a uniform style, as follows:
-bal=0 follows the input line breaks [DEFAULT]
-bal=1 always break after a label
-bal=2 never break after a label
For example:
# perltidy -bal=1
INIT:
{
$xx = 1.234;
}
# perltidy -bal=2
INIT: {
$xx = 1.234;
}
- Fix issue git #82, an error handling something like ${bareword} in a
possible indirect object location. Perl allows this, now perltidy does too.
- The flags -kbb=s or --keep-old-breakpoints-before=s, and its counterpart
-kba=s or --keep-old-breakpoints-after=s have expanded functionality
for the container tokens: { [ ( } ] ). The updated man pages have
details.
- Two new flags have been added to provide finer vertical alignment control,
--valign-exclusion-list=s (-vxl=s) and --valign-inclusion-list=s (-vil=s).
This has been requested several times, most recently in git #79, and it
finally got done. For example, -vil='=>' means just align on '=>'.
- A new flag -gal=s, --grep-alias-list=s, has been added as suggested in
git #77. This allows code blocks passed to list operator functions to
be formatted in the same way as a code block passed to grep, map, or sort.
By default, the following list operators in List::Util are included:
all any first none notall reduce reductions
They can be changed with the flag -gaxl=s, -grep-alias-exclusion-list=s
- A new flag -xlp has been added which can be set to avoid most of the
limitations of the -lp flag regarding side comments, blank lines, and
code blocks. See the man pages for more info. This fixes git #64 and git #74.
The older -lp flag still works.
- A new flag -lpil=s, --line-up-parentheses-inclusion-list=s, has been added
as an alternative to -lpxl=s, --line-up-parentheses-exclusion-list=s.
It supplies equivalent information but is much easier to describe and use.
It works for both the older -lp version and the newer -xlp.
- The coding for the older -lp flag has been updated to avoid some problems
and limitations. The new coding allows the -lp indentation style to
mix smoothly with the standard indentation in a single file. Some problems
where -lp and -xci flags were not working well together have been fixed, such
as happened in issue rt140025. As a result of these updates some minor
changes in existing code using the -lp style may occur.
- This version of perltidy was stress-tested for many cpu hours with
random input parameters. No failures to converge, internal fault checks,
undefined variable references or other irregularities were seen.
- Numerous minor fixes have been made, mostly very rare formatting
instabilities found in random testing.
- No significant bugs have been found since the last release, but several
minor issues have been fixed. Vertical alignment has been improved for
lists of call args which are not contained within parens (next item).
- Vertical alignment of function calls without parens has been improved with
the goal of making vertical alignment essentially the same with or
without parens around the call args. Some examples:
# OLD
mkTextConfig $c, $x, $y, -anchor => 'se', $color;
mkTextConfig $c, $x + 30, $y, -anchor => 's', $color;
mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color;
mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color;
# NEW
mkTextConfig $c, $x, $y, -anchor => 'se', $color;
mkTextConfig $c, $x + 30, $y, -anchor => 's', $color;
mkTextConfig $c, $x + 60, $y, -anchor => 'sw', $color;
mkTextConfig $c, $x, $y + 30, -anchor => 'e', $color;
# OLD
is id_2obj($id), undef, "unregistered object not retrieved";
is scalar keys %$ob_reg, 0, "object registry empty";
is register($obj), $obj, "object returned by register";
is scalar keys %$ob_reg, 1, "object registry nonempty";
is id_2obj($id), $obj, "registered object retrieved";
# NEW
is id_2obj($id), undef, "unregistered object not retrieved";
is scalar keys %$ob_reg, 0, "object registry empty";
is register($obj), $obj, "object returned by register";
is scalar keys %$ob_reg, 1, "object registry nonempty";
is id_2obj($id), $obj, "registered object retrieved";
This will cause some changes in alignment, hopefully for the better,
particularly in test code which often uses numerous parenless function
calls with functions like 'ok', 'is', 'is_deeply', ....
- Two new parameters were added to control the block types to which the
-bl (--opening-brace-on-new-line) flag applies. The new parameters are
-block-left-list=s, or -bll=s, and --block-left-exclusion-list=s,
or -blxl=s. Previously the -bl flag was 'hardwired' to apply to
nearly all blocks. The default values of the new parameters
retain the the old default behavior but allow it to be changed.
- The default behavior of the -bli (-brace-left-and-indent) flag has changed
slightly. Previously, if you set -bli, then the -bl flag would also
automatically be set. Consequently, block types which were not included
in the default list for -bli would get -bl formatting. This is no longer done,
and these two styles are now controlled independently. The manual describes
the controls. If you want to recover the exact previous default behavior of
the -bli then add the -bl flag.
- A partial fix was made for issue for git #74. The -lp formatting style was
being lost when a one-line anonymous sub was followed by a closing brace.
- Fixed issue git #73, in which the -nfpva flag was not working correctly.
Some unwanted vertical alignments of spaced function perens
were being made.
- Updated the man pages to clarify the flags -valign and -novalign
for turning vertical alignment on and off (issue git #72).
Added parameters -vc -vsc -vbc for separately turning off vertical
alignment of code, side comments and block comments.
- Fixed issue git #68, where a blank line following a closing code-skipping
comment, '#>>V', could be lost.
- This version runs 10 to 15 percent faster on large files than the
previous release due to optimizations made with the help of NYTProf.
- This version of perltidy was stress-tested for many cpu hours with
random input parameters. No instabilities, internal fault checks,
undefined variable references or other irregularities were seen.
- Numerous minor fixes have been made, mostly very rare formatting instabilities
found in random testing. An effort has been made to minimize changes to
existing formatting that these fixes produce, but occasional changes
may occur. Many of these updates are listed at:
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- This release is being made mainly because of the next item, in which an
error message about an uninitialized value error message could be produced
in certain cases when format-skipping is used. The error message was
annoying but harmless to formatting.
- Fixed an undefined variable message, see git #67. When a format skipping
comment '#<<' is placed before the first line of code in a script, a
message 'Use of uninitialized value $Ktoken_vars in numeric ...' can
occur.
- A warning will no longer be given if a script has an opening code-skipping
comment '#<<V' which is not terminated with a closing comment '#>>V'. This
makes code-skipping and format-skipping behave in a similar way: an
opening comment without a corresponding closing comment will cause
the rest of a file to be skipped. If there is a question about which lines
are skipped, a .LOG file can be produced with the -g flag and it will have
this information.
- Removed the limit on -ci=n when -xci is set, reference: rt #136415.
This update removes a limit in the previous two versions in which the
value of -ci=n was limited to the value of -i=n when -xci was set.
This limit had been placed to avoid some formatting instabilities,
but recent coding improvements allow the limit to be removed.
- The -wn and -bbxx=n flags were not working together correctly. This has
been fixed.
- This version may produce occasional differences in formatting compared to
previous versions, mainly for lines which are near the specified line
length limit. This is due to ongoing efforts to eliminate edge cases of
formatting instability.
- Numerous minor fixes have been made. A complete list is at:
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- This release adds several new requested parameters. No significant bugs have
been found since the last release, but a number of minor problems have been
corrected.
- Added a new option '--code-skipping', requested in git #65, in which code
between comment lines '#<<V' and '#>>V' is passed verbatim to the output
stream without error checking. It is similar to --format-skipping
but there is no error checking of the skipped code. This can be useful for
skipping past code which employs an extended syntax.
- Added a new option for closing paren placement, -vtc=3, requested in rt #136417.
- Added flag -atnl, --add-terminal-newline, to help issue git #58.
This flag tells perltidy to terminate the last line of the output stream
with a newline character, regardless of whether or not the input stream
was terminated with a newline character. This is the default.
If this flag is negated, with -natnl, then perltidy will add a terminal
newline character to the the output stream only if the input
stream is terminated with a newline.
- Some nested structures formatted with the -lp indentation option may have
some changes in indentation. This is due to updates which were made to
prevent formatting instability when line lengths are limited by the maximum line
length. Most scripts will not be affected. If this causes unwanted formatting
changes, try increasing the --maximum-line-length by a few characters.
- Numerous minor fixes have been made. A complete list is at:
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- This release fixes several non-critical bugs which have been found since the last
release. An effort has been made to keep existing formatting unchanged.
- Fixed issue git #57 regarding uninitialized warning flag.
- Added experimental flag -lpxl=s requested in issue git #56 to provide some
control over which containers get -lp indentation.
- Fixed issue git #55 regarding lack of coordination of the --break-before-xxx
flags and the --line-up-parens flag.
- Fixed issue git #54 regarding irregular application of the --break-before-paren
and similar --break-before-xxx flags, in which lists without commas were not
being formatted according to these flags.
- Fixed issue git #53. A flag was added to turn off alignment of spaced function
parens. If the --space-function-paren, -sfp flag is set, a side-effect is that the
spaced function parens may get vertically aligned. This can be undesirable,
so a new parameter '--function-paren-vertical-alignment', or '-fpva', has been
added to turn this vertical alignment off. The default is '-fpva', so that
existing formatting is not changed. Use '-nfpva' to turn off unwanted
vertical alignment. To illustrate the possibilities:
# perltidy [default]
myfun( $aaa, $b, $cc );
mylongfun( $a, $b, $c );
# perltidy -sfp
myfun ( $aaa, $b, $cc );
mylongfun ( $a, $b, $c );
# perltidy -sfp -nfpva
myfun ( $aaa, $b, $cc );
mylongfun ( $a, $b, $c );
- Fixed issue git #51, a closing qw bare paren was not being outdented when
the -nodelete-old-newlines flag was set.
- Fixed numerous edge cases involving unusual parameter combinations which
could cause alternating output states. Most scripts will not be
changed by these fixes.
- A more complete list of updates is at
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- Fixed issue git #49, -se breaks warnings exit status behavior.
The exit status flag was not always being set when the -se flag was set.
- Some improvements have been made in the method for aligning side comments.
One of the problems that was fixed is that there was a tendency for side comment
placement to drift to the right in long scripts. Programs with side comments
may have a few changes.
- Some improvements have been made in formatting qw quoted lists. This
fixes issue git #51, in which closing qw pattern delimiters not always
following the settings specified by the --closing-token-indentation=n settings.
Now qw closing delimiters ')', '}' and ']' follow these flags, and the
delimiter '>' follows the flag for ')'. Other qw pattern delimiters remain
indented as the are now. This change will cause some small formatting changes
in some existing programs.
- Another change involving qw lists is that they get full indentation,
rather than just continuation indentation, if
(1) the closing delimiter is one of } ) ] > and is on a separate line,
(2) the opening delimiter (i.e. 'qw{' ) is also on a separate line, and
(3) the -xci flag (--extended-continuation-indentation) is set.
This improves formatting when qw lists are contained in other lists. For example,
# OLD: perltidy
foreach $color (
qw(
AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3
),
qw(
LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2
SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4
)
)
# NEW, perltidy -xci
foreach $color (
qw(
AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3
),
qw(
LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2
SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4
)
)
- Some minor improvements have been made to the rules for formatting
some edge vertical alignment cases, usually involving two dissimilar lines.
- A more complete list of updates is at
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- Fixed issue git #47, incorrect welding of anonymous subs.
An incorrect weld format was being made when the --weld-nested-containers option
(-wn) was used in to format a function which returns a list of anonymous subs.
For example, the following snippet was incorrectly being welded.
$promises[$i]->then(
sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
}
);
This was due to an error introduced in v20201201 related to parsing sub
signatures. Reformatting with the current version will fix the problem.
- This release is being made primarily to make available a several new formatting
parameters, in particular -xci, -kbb=s, -kba=s, and -wnxl=s. No significant
bugs have been found since the previous release, but numerous minor issues have
been found and fixed as listed below.
- This version is about 20% faster than the previous version due to optimizations
made with the help of Devel::NYTProf.
- Added flag -wnxl=s, --weld-nested-exclusion-list=s, to provide control which containers
are welded with the --weld-nested-containers parameter. This is related to issue git #45.
- Merged pull request git #46 which fixes the docs regarding the -fse flag.
- Fixed issue git #45, -vtc=n flag was ignored when -wn was set.
- implement request RT #133649, delete-old-newlines selectively. Two parameters,
-kbb=s or --keep-old-breakpoints-before=s, and
-kba=s or --keep-old-breakpoints-after=s
were added to request that old breakpoints be kept before or after
selected token types. For example, -kbb='=>' means that newlines before
fat commas should be kept.
- Fix git #44, fix exit status for assert-tidy/untidy. The exit status was
always 0 for --assert-tidy if the user had turned off all error messages with
the -quiet flag. This has been fixed.
- Add flag -maxfs=n, --maximum-file-size-mb=n. This parameter is provided to
avoid causing system problems by accidentally attempting to format an
extremely large data file. The default is n=10. The command to increase
the limit to 20 MB for example would be -mfs=20. This only applies to
files specified by filename on the command line.
- Skip formatting if there are too many indentation level errors. This is
controlled with -maxle=n, --maximum-level-errors=n. This means that if
the ending indentation differs from the starting indentation by more than
n levels, the file will be output verbatim. The default is n=1.
To skip this check, set n=-1 or set n to a large number.
- A related new flag, --maximum-unexpected-errors=n, or -maxue=n, is available
but is off by default.
- Add flag -xci, --extended-continuation-indentation, regarding issue git #28
This flag causes continuation indentation to "extend" deeper into structures.
Since this is a fairly new flag, the default is -nxci to avoid disturbing
existing formatting. BUT you will probably see some improved formatting
in complex data structures by setting this flag if you currently use -ci=n
and -i=n with the same value of 'n' (as is the case if you use -pbp,
--perl-best-practices, where n=4).
- Fix issue git #42, clarify how --break-at-old-logical-breakpoints works.
The man page was updated to note that it does not cause all logical breakpoints
to be replicated in the output file.
- Fix issue git #41, typo in manual regarding -fsb.
- Fix issue git #40: when using the -bli option, a closing brace followed by
a semicolon was not being indented. This applies to braces which require
semicolons, such as a 'do' block.
- Added 'state' as a keyword.
- A better test for convergence has been added. When iterations are requested,
the new test will stop after the first pass if no changes in line break
locations are made. Previously, file checksums were used and required at least two
passes to verify convergence unless no formatting changes were made. With the new test,
only a single pass is needed when formatting changes are limited to adjustments of
indentation and whitespace on the lines of code. Extensive testing has been made to
verify the correctness of the new convergence test.
- Line breaks are now automatically placed after 'use overload' to
improve formatting when there are numerous overloaded operators. For
example
use overload
'+' => sub {
...
- A number of minor problems with parsing signatures and prototypes have
been corrected, particularly multi-line signatures. Some signatures
had previously been parsed as if they were prototypes, which meant the
normal spacing rules were not applied. For example
OLD:
sub echo ($message= 'Hello World!' ) {
...;
}
NEW:
sub echo ( $message = 'Hello World!' ) {
...;
}
- Numerous minor issues that the average user would not encounter were found
and fixed. They can be seen in the more complete list of updates at
https://github.com/perltidy/perltidy/blob/master/local-docs/BugLog.pod
- Robustness of perltidy has been significantly improved. Updating is recommended. Continual
automated testing runs began about 1 Sep 2020 and numerous issues have been found and fixed.
Many involve references to uninitialized variables when perltidy is fed random text and random
control parameters.
- Added the token '->' to the list of alignment tokens, as suggested in git
#39, so that it can be vertically aligned if a space is placed before them with -wls='->'.
- Added parameters -bbhb=n (--break-before-hash-brace=n), -bbsb=n (--break-before-square-bracket=n),
and -bbp=n (--break-before-paren=n) suggested in git #38. These provide control over the
opening container token of a multiple-line list. Related new parameters -bbhbi=n, -bbsbi=n, -bbpi=n
control indentation of these tokens.
- Added keyword 'isa'.
- Fixed bug git #37, an error when the combination -scbb -csc was used.
It occurs in perltidy versions 20200110, 20200619, and 20200822. What happens is
that when two consecutive lines with isolated closing braces had new side
comments generated by the -csc parameter, a separating newline was missing.
The resulting script will not then run, but worse, if it is reformatted with
the same parameters then closing side comments could be overwritten and data
lost.
This problem was found during automated random testing. The parameter
-scbb is rarely used, which is probably why this has not been reported. Please
upgrade your version.
- Added parameter --non-indenting-braces, or -nib, which prevents
code from indenting one level if it follows an opening brace marked
with a special side comment, '#<<<'. For example,
{ #<<< a closure to contain lexical vars
my $var; # this line does not indent
}
# this line cannot 'see' $var;
This is on by default. If your code happens to have some
opening braces followed by '#<<<', and you
don't want this, you can use -nnib to deactivate it.
- Side comment locations reset at a line ending in a level 0 open
block, such as when a new multi-line sub begins. This is intended to
help keep side comments from drifting to far to the right.
- Fix RT #133166, encoding not set for -st. Also reported as RT #133171
and git #35.
This is a significant bug in version 20200616 which can corrupt data if
perltidy is run as a filter on encoded text.
Please upgrade
- Fix issue RT #133161, perltidy -html was not working on pod
- Fix issue git #33, allow control of space after '->'
- Vertical alignment has been improved. Numerous minor issues have
been fixed.
- Formatting with the -lp option is improved.
- Fixed issue git #32, misparse of bare 'ref' in ternary
- When --assert-tidy is used and triggers an error, the first difference
between input and output files is shown in the error output. This is
a partial response to issue git #30.
- Added support for Switch::Plain syntax, issue git #31.
- Fixed minor problem where trailing 'unless' clauses were not
getting vertically aligned.
- Added a parameter --logical-padding or -lop to allow logical padding
to be turned off. Requested by git #29. This flag is on by default.
The man pages have examples.
- Added a parameter -kpit=n to control spaces inside of parens following
certain keywords, requested in git#26. This flag is off by default.
- Added fix for git#25, improve vertical alignment for long lists with
varying numbers of items per line.
- calls to the module Perl::Tidy can now capture any output produced
by a debug flag or one of the 'tee' flags through the new 'debugfile' and
'teefile' call parameters. These output streams are rarely used but
they are now treated the same as any 'logfile' stream.
- add option --break-at-old-semicolon-breakpoints', -bos, requested
in RT#131644. This flag will keep lines beginning with a semicolon.
- Added --use-unicode-gcstring to control use of Unicode::GCString for
evaluating character widths of encoded data. The default is
not to use this (--nouse-unicode-gcstring). If this flag is set,
perltidy will look for Unicode::GCString and, if found, will use it
to evaluate character display widths. This can improve displayed
vertical alignment for files with wide characters. It is a nice
feature but it is off by default to avoid conflicting formatting
when there are multiple developers. Perltidy installation does not
require Unicode::GCString, so users wanting to use this feature need
set this flag and also to install Unicode::GCString separately.
- Added --character-encoding=guess or -guess to have perltidy guess
if a file (or other input stream) is encoded as -utf8 or some
other single-byte encoding. This is useful when processing a mixture
of file types, such as utf8 and latin-1.
Please Note: The default encoding has been set to be 'guess'
instead of 'none'. This seems like the best default, since
it allows perltidy work properly with both
utf8 files and older latin-1 files. The guess mode uses Encode::Guess,
which is included in standard perl distributions, and only tries to
guess if a file is utf8 or not, never any other encoding. If the guess is
utf8, and if the file successfully decodes as utf8, then it the encoding
is assumed to be utf8. Otherwise, no encoding is assumed.
If you do not want to use this new default guess mode, or have a
problem with it, you can set --character-encoding=none (the previous
default) or --character-encoding=utf8 (if you deal with utf8 files).
- Specific encodings of input files other than utf8 may now be given, for
example --character-encoding=euc-jp.
- Fix for git#22, Preserve function signature on a single line. An
unwanted line break was being introduced when a closing signature paren
followed a closing do brace.
- Fix RT#132059, the -dac parameter was not working and caused an error exit
- When -utf8 is used, any error output is encoded as utf8
- Fix for git#19, adjust line break around an 'xor'
- Fix for git#18, added warning for missing comma before unknown bare word.
- This release adds a flag to control the feature RT#130394 (allow short nested blocks)
introduced in the previous release. Unfortunately that feature breaks
RPerl installations, so a control flag has been introduced and that feature is now
off by default. The flag is:
--one-line-block-nesting=n, or -olbn=n, where n is an integer as follows:
-olbn=0 break nested one-line blocks into multiple lines [new DEFAULT]
-olbn=1 stable; keep existing nested-one line blocks intact [previous DEFAULT]
For example, consider this input line:
foreach (@list) { if ($_ eq $asked_for) { last } ++$found }
The new default behavior (-olbn=0), and behavior prior to version 20191203, is to break it into multiple lines:
foreach (@list) {
if ( $_ eq $asked_for ) { last }
++$found;
}
To keep nested one-line blocks such as this on a single line you can add the parameter -olbn=1.
- Fixed issue RT#131288: parse error for un-prototyped constant function without parenthesized
call parameters followed by ternary.
- Fixed issue RT#131360, installation documentation. Added a note that the binary
'perltidy' comes with the Perl::Tidy module. They can both normally be installed with
'cpanm Perl::Tidy'
- Fixed issue RT#131115: -bli option not working correctly.
Closing braces were not indented in some cases due to a glitch
introduced in version 20181120.
- Fixed issue RT#130394: Allow short nested blocks. Given the following
$factorial = sub { reduce { $a * $b } 1 .. 11 };
Previous versions would always break the sub block because it
contains another block (the reduce block). The fix keeps
short one-line blocks such as this intact.
- Implement issue RT#130640: Allow different subroutine keywords.
Added a flag --sub-alias-list=s or -sal=s, where s is a string with
one or more aliases for 'sub', separated by spaces or commas.
For example,
perltidy -sal='method fun'
will cause the perltidy to treat the words 'method' and 'fun' to be
treated the same as if they were 'sub'.
- Added flag --space-prototype-paren=i, or -spp=i, to control spacing
before the opening paren of a prototype, where i=0, 1, or 2:
i=0 no space
i=1 follow input [current and default]
i=2 always space
Previously, perltidy always followed the input.
For example, given the following input
sub usage();
The result will be:
sub usage(); # i=0 [no space]
sub usage(); # i=1 [default; follows input]
sub usage (); # i=2 [space]
- Fixed issue git#16, minor vertical alignment issue.
- Fixed issue git#10, minor conflict of -wn and -ce
- Improved some vertical alignments involving two lines.
- fixed issue RT#130344: false warning "operator in print statement"
for "use lib".
- fixed issue RT#130304: standard error output should include filename.
When perltidy error messages are directed to the standard error output
with -se or --standard-error-output, the message lines now have a prefix
'filename:' for clarification in case multiple files
are processed, where 'filename' is the name of the input file. If
input is from the standard input the displayed filename is '<stdin>',
and if it is from a data structure then displayed filename
is '<source_stream>'.
- implement issue RT#130425: check mode. A new flag '--assert-tidy'
will cause an error message if the output script is not identical to
the input script. For completeness, the opposite flag '--assert-untidy'
has also been added. The next item, RT#130297, insures that the script
will exit with a non-zero exit flag if the assertion fails.
- fixed issue RT#130297; the perltidy script now exits with a nonzero exit
status if it wrote to the standard error output. Previously only fatal
run errors produced a non-zero exit flag. Now, even non-fatal messages
requested with the -w flag will cause a non-zero exit flag. The exit
flag now has these values:
0 = no errors
1 = perltidy could not run to completion due to errors
2 = perltidy ran to completion with error messages
- added warning message for RT#130008, which warns of conflicting input
parameters -iob and -bom or -boc.
- fixed RT#129850; concerning a space between a closing block brace and
opening bracket or brace, as occurs before the '[' in this line:
my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
Formerly, any space was removed. Now it is optional, and the output will
follow the input.
- fixed issue git#13, needless trailing whitespace in error message
- fixed issue git#9: if the -ce (--cuddled-else) flag is used,
do not try to form new one line blocks for a block type
specified with -cbl, particularly map, sort, grep
- iteration speedup for unchanged code. Previously, when iterations were
requested, at least two formatting passes were made. Now just a single pass
is made if the formatted code is identical to the input code.
- some improved vertical alignments
- rt #128477: Prevent inconsistent owner/group and setuid/setgid bits.
In the -b (--backup-and-modify-in-place) mode, an attempt is made to set ownership
of the output file equal to the input file, if they differ.
In all cases, if the final output file ownership differs from input file, any setuid/setgid bits are cleared.
- Added option -bom (--break-at-old-method-breakpoints) by
merrillymeredith which preserves breakpoints of method chains. Modified to also handle a cuddled call style.
- Merged patch to fix Windows EOL translation error with UTF-8 written by
Ron Ivy. This update prevents automatic conversion to 'DOS' CRLF line
endings. Also, Windows system testing at the appveyor site is working again.
- RT #128280, added flag --one-line-block-semicolons=n (-olbs=n)
to control semicolons in one-line blocks. The values of n are:
n=0 means no semicolons termininating simple one-line blocks
n=1 means stable; do not change from input file [DEFAULT and current]
n=2 means always add semicolons in one-line blocks
The current behavior corresponds to the default n=1.
- RT #128216, Minor update to prevent inserting unwanted blank line at
indentation level change. This should not change existing scripts.
- RT #81852: Improved indentation when quoted word (qw) lists are
nested within other containers using the --weld-nested (-wn) flag.
The example given previously (below) is now closer to what it would
be with a simple list instead of qw:
# perltidy -wn
use_all_ok( qw{
PPI
PPI::Tokenizer
PPI::Lexer
PPI::Dumper
PPI::Find
PPI::Normal
PPI::Util
PPI::Cache
} );
- RT#12764, introduced new feature allowing placement of blanks around
sequences of selected keywords. This can be activated with the -kgb*
series of parameters described in the manual.
- Rewrote vertical algnment module. It is better at finding
patterns in complex code. For example,
OLD:
/^-std$/ && do { $std = 1; next; };
/^--$/ && do { @link_args = @argv; last; };
/^-I(.*)/ && do { $path = $1 || shift @argv; next; };
NEW:
/^-std$/ && do { $std = 1; next; };
/^--$/ && do { @link_args = @argv; last; };
/^-I(.*)/ && do { $path = $1 || shift @argv; next; };
- Add repository URLs to META files
- RT #118553, "leave only one newline at end of file". This option was not
added because of undesirable side effects, but a new filter script
was added which can do this, "examples/delete_ending_blank_lines.pl".
- fix RT#127736 Perl-Tidy-20181119 has the EXE_FILES entry commented out in
Makefile.PL so it doesn't install the perltidy script or its manpage.
- Removed test case 'filter_example.t' which was causing a failure on a
Windows installation for unknown reasons, possibly due to an unexpected
perltidyrc being read by the test script. Added VERSION numbers to all
new modules.
- Fixed RT #126965, in which a ternary operator was misparsed if immediately
following a function call without arguments, such as:
my $restrict_customer = shift ? 1 : 0;
- Fixed RT #125012: bug in -mangle --delete-all-comments
A needed blank space before bareword tokens was being removed when comments
were deleted
- Fixed RT #81852: Stacked containers and quoting operators. Quoted words
(qw) delimited by container tokens ('{', '[', '(', '<') are now included in
the --weld-nested (-wn) flag:
# perltidy -wn
use_all_ok( qw{
PPI
PPI::Tokenizer
PPI::Lexer
PPI::Dumper
PPI::Find
PPI::Normal
PPI::Util
PPI::Cache
} );
- The cuddled-else (-ce) coding was merged with the new cuddled-block (-cb)
coding. The change is backward compatible and simplifies input.
The --cuddled-block-option=n (-cbo=n) flag now applies to both -ce and -cb
formatting. In fact the -cb flag is just an alias for -ce now.
- Fixed RT #124594, license text desc. changed from 'GPL-2.0+' to 'gpl_2'
- Fixed bug in which a warning about a possible code bug was issued in a
script with brace errors.
- added option --notimestamp or -nts to eliminate any time stamps in output
files. This is used to prevent differences in test scripts from causing
failure at installation. For example, the -cscw option will put a date
stamp on certain closing side comments. We need to avoid this in order
to test this feature in an installation test.
- Fixed bug with the entab option, -et=8, in which the leading space of
some lines was was not entabbed. This happened in code which was adjusted
for vertical alignment and in hanging side comments. Thanks to Glenn.
- Fixed RT #127633, undesirable line break after return when -baao flag is set
- Fixed RT #127035, vertical alignment. Vertical alignment has been improved
in several ways. Thanks especially to Michael Wardman and Glenn for sending
helpful snippets.
- Alignment of the =~ operators has been reactivated.
OLD:
$service_profile =~ s/^\s+|\s+$//g;
$host_profile =~ s/^\s+|\s+$//g;
NEW:
$service_profile =~ s/^\s+|\s+$//g;
$host_profile =~ s/^\s+|\s+$//g;
- Alignment of the // operator has been reactivated.
OLD:
is( pop // 7, 7, 'pop // ... works' );
is( pop() // 7, 0, 'pop() // ... works' );
is( pop @ARGV // 7, 3, 'pop @array // ... works' );
NEW:
is( pop // 7, 7, 'pop // ... works' );
is( pop() // 7, 0, 'pop() // ... works' );
is( pop @ARGV // 7, 3, 'pop @array // ... works' );
- The rules for alignment of just two lines have been adjusted,
hopefully to be a little better overall. In some cases, two
lines which were previously unaligned are now aligned, and vice-versa.
OLD:
$expect = "1$expect" if $expect =~ /^e/i;
$p = "1$p" if defined $p and $p =~ /^e/i;
NEW:
$expect = "1$expect" if $expect =~ /^e/i;
$p = "1$p" if defined $p and $p =~ /^e/i;
- RT #106493; source code repository location has been added to docs; it is
https://github.com/perltidy/perltidy
- The packaging for this version has changed. The Tidy.pm module is much
smaller. Supporting modules have been split out from it and placed below
it in the path Perl/Tidy/*.
- A number of new installation test cases have been added. Updates are now
continuously tested at Travis CI against versions back to Perl 5.08.
- RT #124469, #124494, perltidy often making empty files. The previous had
an index error causing it to fail, particularly in version 5.18 of Perl.
Please avoid version 20180219.
- RT #79947, cuddled-else generalization. A new flag -cb provides
'cuddled-else' type formatting for an arbitrary type of block chain. The
default is try-catch-finally, but this can be modified with the
parameter -cbl.
- Fixed RT #124298: add space after ! operator without breaking !! secret
operator
- RT #123749: numerous minor improvements to the -wn flag were made.
- Fixed a problem with convergence tests in which iterations were stopping
prematurely.
- Here doc targets for <<~ type here-docs may now have leading whitespace.
- Fixed RT #124354. The '-indent-only' flag was not working correctly in the
previous release. A bug in version 20180101 caused extra blank lines
to be output.
- Issue RT #124114. Some improvements were made in vertical alignment
involving 'fat commas'.
- Added new flag -wn (--weld-nested-containers) which addresses these issues:
RT #123749: Problem with promises;
RT #119970: opening token stacking strange behavior;
RT #81853: Can't stack block braces
This option causes closely nested pairs of opening and closing containers
to be "welded" together and essentially be formatted as a single unit,
with just one level of indentation.
Since this is a new flag it is set to be "off" by default but it has given
excellent results in testing.
EXAMPLE 1, multiple blocks, default formatting:
do {
{
next if $x == $y; # do something here
}
} until $x++ > $z;
perltidy -wn
do { {
next if $x == $y;
} } until $x++ > $z;
EXAMPLE 2, three levels of wrapped function calls, default formatting:
p(
em(
conjug(
translate( param('verb') ), param('tense'),
param('person')
)
)
);
# perltidy -wn
p( em( conjug(
translate( param('verb') ),
param('tense'), param('person')
) ) );
# EXAMPLE 3, chained method calls, default formatting:
get('http://mojolicious.org')->then(
sub {
my $mojo = shift;
say $mojo->res->code;
return get('http://metacpan.org');
}
)->then(
sub {
my $cpan = shift;
say $cpan->res->code;
}
)->catch(
sub {
my $err = shift;
warn "Something went wrong: $err";
}
)->wait;
# perltidy -wn
get('http://mojolicious.org')->then( sub {
my $mojo = shift;
say $mojo->res->code;
return get('http://metacpan.org');
} )->then( sub {
my $cpan = shift;
say $cpan->res->code;
} )->catch( sub {
my $err = shift;
warn "Something went wrong: $err";
} )->wait;
- Fixed RT #114359: Missparsing of "print $x ** 0.5;
- Deactivated the --check-syntax flag for better security. It will be
ignored if set.
- Corrected minimum perl version from 5.004 to 5.008 based on perlver
report. The change is required for coding involving wide characters.
- For certain severe errors, the source file will be copied directly to the
output without formatting. These include ending in a quote, ending in a
here doc, and encountering an unidentified character.
- RT #123749, partial fix. "Continuation indentation" is removed from lines
with leading closing parens which are part of a call chain.
For example, the call to pack() is is now outdented to the starting
indentation in the following expression:
# OLD
$mw->Button(
-text => "New Document",
-command => \&new_document
)->pack(
-side => 'bottom',
-anchor => 'e'
);
# NEW
$mw->Button(
-text => "New Document",
-command => \&new_document
)->pack(
-side => 'bottom',
-anchor => 'e'
);
This modification improves readability of complex expressions, especially
when the user uses the same value for continuation indentation (-ci=n) and
normal indentation (-i=n). Perltidy was already programmed to
do this but a minor bug was preventing it.
- RT #123774, added flag to control space between a backslash and a single or
double quote, requested by Robert Rothenberg. The issue is that lines like
$str1=\"string1";
$str2=\'string2';
confuse syntax highlighters unless a space is left between the backslash and
the quote.
The new flag to control this is -sbq=n (--space-backslash-quote=n),
where n=0 means no space, n=1 means follow existing code, n=2 means always
space. The default is n=1, meaning that a space will be retained if there
is one in the source code.
- Fixed RT #123492, support added for indented here doc operator <<~ added
in v5.26. Thanks to Chris Weyl for the report.
- Fixed docs; --closing-side-comment-list-string should have been just
--closing-side-comment-list. Thanks to F.Li.
- Added patch RT #122030] Perl::Tidy sometimes does not call binmode.
Thanks to Irilis Aelae.
- Fixed RT #121959, PERLTIDY doesn't honor the 'three dot' notation for
locating a config file using environment variables. Thanks to John
Wittkowski.
- Minor improvements to formatting, in which some additional vertical
aligmnemt is done. Thanks to Keith Neargarder.
- RT #119588. Vertical alignment is no longer done for // operator.
- Fixed debian #862667: failure to check for perltidy.ERR deletion can lead
to overwriting arbitrary files by symlink attack. Perltidy was continuing
to write files after an unlink failure. Thanks to Don Armstrong
for a patch.
- Fixed RT #116344, perltidy fails on certain anonymous hash references:
in the following code snippet the '?' was misparsed as a pattern
delimiter rather than a ternary operator.
return ref {} ? 1 : 0;
- Fixed RT #113792: misparsing of a fat comma (=>) right after
the __END__ or __DATA__ tokens. These keywords were getting
incorrectly quoted by the following => operator.
- Fixed RT #118558. Custom Getopt::Long configuration breaks parsing
of perltidyrc. Perltidy was resetting the users configuration too soon.
- Fixed RT #119140, failure to parse double diamond operator. Code to
handle this new operator has been added.
- Fixed RT #120968. Fixed problem where -enc=utf8 didn't work
with --backup-and-modify-in-place. Thanks to Heinz Knutzen for this patch.
- Fixed minor formatting issue where one-line blocks for subs with signatures
were unnecessarily broken
- RT #32905, patch to fix utf-8 error when output was STDOUT.
- RT #79947, improved spacing of try/catch/finally blocks. Thanks to qsimpleq
for a patch.
- Fixed #114909, Anonymous subs with signatures and prototypes misparsed as
broken ternaries, in which a statement such as this was not being parsed
correctly:
return sub ( $fh, $out ) : prototype(*$) { ... }
- Implemented RT #113689, option to introduces spaces after an opening block
brace and before a closing block brace. Four new optional controls are
added. The first two define the minimum number of blank lines to be
inserted
-blao=i or --blank-lines-after-opening-block=i
-blbc=i or --blank-lines-before-closing-block=i
where i is an integer, the number of lines (the default is 0).
The second two define the types of blocks to which the first two apply
-blaol=s or --blank-lines-after-opening-block-list=s
-blbcl=s or --blank-lines-before-closing-block-list=s
where s is a string of possible block keywords (default is just 'sub',
meaning a named subroutine).
For more information please see the documentation.
- The method for specifying block types for certain input parameters has
been generalized to distinguish between normal named subroutines and
anonymous subs. The keyword for normal subroutines remains 'sub', and
the new keyword for anonymous subs is 'asub'.
- Minor documentation changes. The BUGS sections now have a link
to CPAN where most open bugs and issues can be reviewed and bug reports
can be submitted. The information in the AUTHOR and CREDITS sections of
the man pages have been removed from the man pages to streamline the
documentation. This information is still in the source code.
- RT #112534. Corrected a minor problem in which an unwanted newline
was placed before the closing brace of an anonymous sub with
a signature, if it was in a list. Thanks to Dmytro Zagashev.
- Corrected a minor problem in which occasional extra indentation was
given to the closing brace of an anonymous sub in a list when the -lp
parameter was set.
- RT #104427. Added support for signatures.
- RT #111512. Changed global warning flag $^W = 1 to use warnings;
Thanks to Dmytro Zagashev.
- RT #110297, added support for new regexp modifier /n
Thanks to Dmytro Zagashev.
- RT #111519. The -io (--indent-only) and -dac (--delete-all-comments)
can now both be used in one pass. Thanks to Dmitry Veltishev.
- Patch to avoid error message with 'catch' used by TryCatch, as in
catch($err){
# do something
}
Thanks to Nick Tonkin.
- RT #32905, UTF-8 coding is now more robust. Thanks to qsimpleq
and Dmytro for patches.
- RT #106885. Added string bitwise operators ^. &. |. ~. ^.= &.= |.=
- Fixed RT #107832 and #106492, lack of vertical alignment of two lines
when -boc flag (break at old commas) is set. This bug was
inadvertently introduced in previous bug fix RT #98902.
- Some common extensions to Perl syntax are handled better.
In particular, the following snippet is now foratted cleanly:
method deposit( Num $amount) {
$self->balance( $self->balance + $amount );
}
A new flag -xs (--extended-syntax) was added to enable this, and the default
is to use -xs.
In previous versions, and now only when -nxs is set, this snippet of code
generates the following error message:
"syntax error at ') {', didn't see one of: case elsif for foreach given if switch unless until when while"
- Fixed RT# 105484, Invalid warning about 'else' in 'switch' statement. The
warning happened if a 'case' statement did not use parens.
- Fixed RT# 101547, misparse of // caused error message. Also..
- Fixed RT# 102371, misparse of // caused unwated space in //=
- Fixed RT# 100871, "silent failure of HTML Output on Windows".
Changed calls to tempfile() from:
my ( $fh_tmp, $tmpfile ) = tempfile();
to have the full path name:
my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile()
because of problems in the Windows version reported by Dean Pearce.
- Fixed RT# 99514, calling the perltidy module multiple times with
a .perltidyrc file containing the parameter --output-line-ending
caused a crash. This was a glitch in the memoization logic.
- Fixed RT#99961, multiple lines inside a cast block caused unwanted
continuation indentation.
- RT# 32905, broken handling of UTF-8 strings.
A new flag -utf8 causes perltidy assume UTF-8 encoding for input and
output of an io stream. Thanks to Sebastian Podjasek for a patch.
This feature may not work correctly in older versions of Perl.
It worked in a linux version 5.10.1 but not in a Windows version 5.8.3 (but
otherwise perltidy ran correctly).
- Warning files now report perltidy VERSION. Suggested by John Karr.
- Fixed long flag --nostack-closing-tokens (-nsct has always worked though).
This was due to a typo. This also fixed --nostack-opening-tokens to
behave correctly. Thanks to Rob Dixon.
- Fixed RT #94902: abbreviation parsing in .perltidyrc files was not
working for multi-line abbreviations. Thanks to Eric Fung for
supplying a patch.
- Fixed RT #95708, misparsing of a hash when the first key was a perl
keyword, causing a semicolon to be incorrectly added.
- Fixed RT #94338 for-loop in a parenthesized block-map. A code block within
parentheses of a map, sort, or grep function was being mistokenized. In
rare cases this could produce in an incorrect error message. The fix will
produce some minor formatting changes. Thanks to Daniel Trizen
discovering and documenting this.
- Fixed RT #94354, excess indentation for stacked tokens. Thanks to
Colin Williams for supplying a patch.
- Added support for experimental postfix dereferencing notation introduced in
perl 5.20. RT #96021.
- Updated documentation to clarify the behavior of the -io flag
in response to RT #95709. You can add -noll or -l=0 to prevent
long comments from being outdented when -io is used.
- Added a check to prevent a problem reported in RT #81866, where large
scripts which had been compressed to a single line could not be formatted
because of a check for VERSION for MakeMaker. The workaround was to
use -nvpl, but this shouldn't be necessary now.
- Fixed RT #96101; Closing brace of anonymous sub in a list was being
indented. For example, the closing brace of the anonymous sub below
will now be lined up with the word 'callback'. This problem
occurred if there was no comma after the closing brace of the anonymous sub.
This update may cause minor changes to formatting of code with lists
of anonymous subs, especially TK code.
# OLD
my @menu_items = (
#...
{
path => '/_Operate/Transcode and split',
callback => sub {
return 1 if not $self->project_opened;
$self->comp('project')->transcode( split => 1 );
}
}
);
# NEW
my @menu_items = (
#...
{
path => '/_Operate/Transcode and split',
callback => sub {
return 1 if not $self->project_opened;
$self->comp('project')->transcode( split => 1 );
}
}
);
- Fixed RT #94190 and debian Bug #742004: perltidy.LOG file left behind.
Thanks to George Hartzell for debugging this. The problem was
caused by the memoization speedup patch in version 20121207. An
unwanted flag was being set which caused a LOG to be written if
perltidy was called multiple times.
- New default behavior for LOG files: If the source is from an array or
string (through a call to the perltidy module) then a LOG output is only
possible if a logfile stream is specified. This is to prevent
unexpected perltidy.LOG files.
- Fixed debian Bug #740670, insecure temporary file usage. File::Temp is now
used to get a temporary file. Thanks to Don Anderson for a patch.
- Any -b (--backup-and-modify-in-place) flag is silently ignored when a
source stream, destination stream, or standard output is used.
This is because the -b flag may have been in a .perltidyrc file and
warnings break Test::NoWarnings. Thanks to Marijn Brand.
- Fixed RT #88020. --converge was not working with wide characters.
- Fixed RT #78156. package NAMESPACE VERSION syntax not accepted.
- First attempt to fix RT #88588. INDEX END tag change in pod2html breaks
perltidy -html. I put in a patch which should work but I don't yet have
a way of testing it.
- Fixed RT #87107, spelling
- Fixed RT #87502, incorrect of parsing of smartmatch before hash brace
- Added feature request RT #87330, trim whitespace after POD.
The flag -trp (--trim-pod) will trim trailing whitespace from lines of POD
- Fixed RT #86929, #86930, missing lhs of assignment.
- Fixed RT #84922, moved pod from Tidy.pm into Tidy.pod
- The flag -cab=n or --comma-arrow-breakpoints=n has been generalized
to give better control over breaking open short containers. The
possible values are now:
n=0 break at all commas after =>
n=1 stable: break at all commas after => if container is open,
EXCEPT FOR one-line containers
n=2 break at all commas after =>, BUT try to form the maximum
maximum one-line container lengths
n=3 do not treat commas after => specially at all
n=4 break everything: like n=0 but also break a short container with
a => not followed by a comma
n=5 stable: like n=1 but ALSO break at open one-line containers (default)
New values n=4 and n=5 have been added to allow short blocks to be
broken open. The new default is n=5, stable. It should more closely
follow the breaks in the input file, and previously formatted code
should remain unchanged. If this causes problems use -cab=1 to recover
the former behavior. Thanks to Tony Maszeroski for the suggestion.
To illustrate the need for the new options, if perltidy is given
the following code, then the old default (-cab=1) was to close up
the 'index' container even if it was open in the source. The new
default (-cab=5) will keep it open if it was open in the source.
our $fancypkg = {
'ALL' => {
'index' => {
'key' => 'value',
},
'alpine' => {
'one' => '+',
'two' => '+',
'three' => '+',
},
}
};
- New debug flag --memoize (-mem). This version contains a
patch supplied by Jonathan Swartz which can significantly speed up
repeated calls to Perl::Tidy::perltidy in a single process by caching
the result of parsing the formatting parameters. A factor of up to 10
speedup was achieved for masontidy (https://metacpan.org/module/masontidy).
The memoization patch is on by default but can be deactivated for
testing with -nmem (or --no-memoize).
- New flag -tso (--tight-secret-operators) causes certain perl operator
sequences (secret operators) to be formatted "tightly" (without spaces).
The most common of these are 0 + and + 0 which become 0+ and +0. The
operators currently modified by this flag are:
=( )= 0+ +0 ()x!! ~~<> ,=>
Suggested by by Philippe Bruhat. See https://metacpan.org/module/perlsecret
This flag is off by default.
- New flag -vmll (--variable-maximum-line-length) makes the maximum
line length increase with the nesting depth of a line of code.
Basically, it causes the length of leading whitespace to be ignored when
setting line breaks, so the formatting of a block of code is independent
of its nesting depth. Try this option if you have deeply nested
code or data structures, perhaps in conjunction with the -wc flag
described next. The default is not todo this.
- New flag -wc=n (--whitespace-cycle=n) also addresses problems with
very deeply nested code and data structures. When this parameter is
used and the nesting depth exceeds the value n, the leading whitespace
will be reduced and start at 1 again. The result is that deeply
nested blocks of code will shift back to the left. This occurs cyclically
to any nesting depth. This flag may be used either with or without -vmll.
The default is not to use this (-wc=0).
- Fixed RT #78764, error parsing smartmatch operator followed by anonymous
hash or array and then a ternary operator; two examples:
qr/3/ ~~ ['1234'] ? 1 : 0;
map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
- Fixed problem with specifying spaces around arrows using -wls='->'
and -wrs='->'. Thanks to Alain Valleton for documenting this problem.
- Implemented RT #53183, wishlist, lines of code with the same indentation
level which are contained with multiple stacked opening and closing tokens
(requested with flags -sot -sct) now have reduced indentation.
# Default
$sender->MailMsg(
{
to => $addr,
subject => $subject,
msg => $body
}
);
# OLD: perltidy -sot -sct
$sender->MailMsg( {
to => $addr,
subject => $subject,
msg => $body
} );
# NEW: perltidy -sot -sct
$sender->MailMsg( {
to => $addr,
subject => $subject,
msg => $body
} );
- New flag -act=n (--all-containers-tightness=n) is an abbreviation for
-pt=n -sbt=n -bt=n -bbt=n, where n=0,1, or 2. It simplifies input when all
containers have the same tightness. Using the same example:
# NEW: perltidy -sot -sct -act=2
$sender->MailMsg({
to => $addr,
subject => $subject,
msg => $body
});
- New flag -sac (--stack-all-containers) is an abbreviation for -sot -sct
This is part of wishlist item RT #53183. Using the same example again:
# NEW: perltidy -sac -act=2
$sender->MailMsg({
to => $addr,
subject => $subject,
msg => $body
});
- new flag -scbb (--stack-closing-block-brace) causes isolated closing
block braces to stack as in the following example. (Wishlist item RT#73788)
DEFAULT:
for $w1 (@w1) {
for $w2 (@w2) {
for $w3 (@w3) {
for $w4 (@w4) {
push( @lines, "$w1 $w2 $w3 $w4\n" );
}
}
}
}
perltidy -scbb:
for $w1 (@w1) {
for $w2 (@w2) {
for $w3 (@w3) {
for $w4 (@w4) {
push( @lines, "$w1 $w2 $w3 $w4\n" );
} } } }
There is, at present, no flag to place these closing braces at the end
of the previous line. It seems difficult to develop good rules for
doing this for a wide variety of code and data structures.
- Parameters defining block types may use a wildcard '*' to indicate
all block types. Previously it was not possible to include bare blocks.
- A flag -sobb (--stack-opening-block-brace) has been introduced as an
alias for -bbvt=2 -bbvtl='*'. So for example the following test code:
{{{{{{{ $testing }}}}}}}
cannot be formatted as above but can at least be kept vertically compact
using perltidy -sobb -scbb
{ { { { { { { $testing
} } } } } } }
Or even, perltidy -sobb -scbb -i=1 -bbt=2
{{{{{{{$testing
}}}}}}}
- Error message improved for conflicts due to -pbp; thanks to Djun Kim.
- Fixed RT #80645, error parsing special array name '@$' when used as
@{$} or $#{$}
- Eliminated the -chk debug flag which was included in version 20010406 to
do a one-time check for a bug with multi-line quotes. It has not been
needed since then.
- Numerous other minor formatting improvements.
- Added flag -iscl (--ignore-side-comment-lengths) which causes perltidy
to ignore the length of side comments when setting line breaks,
RT #71848. The default is to include the length of side comments when
breaking lines to stay within the length prescribed by the -l=n
maximum line length parameter. For example,
Default behavior on a single line with long side comment:
$vmsfile =~ s/;[\d\-]*$//
; # Clip off version number; we can use a newer version as well
perltidy -iscl leaves the line intact:
$vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
- Fixed RT #78182, side effects with STDERR. Error handling has been
revised and the documentation has been updated. STDERR can now be
redirected to a string reference, and perltidy now returns an
error flag instead of calling die when input errors are detected.
If the error flag is set then no tidied output was produced.
See man Perl::Tidy for an example.
- Fixed RT #78156, erroneous warning message for package VERSION syntax.
- Added abbreviations -conv (--converge) to simplify iteration control.
-conv is equivalent to -it=4 and will insure that the tidied code is
converged to its final state with the minimum number of iterations.
- Minor formatting modifications have been made to insure convergence.
- Simplified and hopefully improved the method for guessing the starting
indentation level of entabbed code. Added flag -dt=n (--default_tabsize=n)
which might be helpful if the guessing method does not work well for
some editors.
- Added support for stacked labels, upper case X/B in hex and binary, and
CORE:: namespace.
- Eliminated warning messages for using keyword names as constants.
- Corrected problem introduced by using a chomp on scalar references, RT #77978
- Added support for Perl 5.14 package block syntax, RT #78114.
- A convergence test is made if three or more iterations are requested with
the -it=n parameter to avoid wasting computer time. Several hundred Mb of
code gleaned from the internet were searched with the results that:
- It is unusual for two iterations to be required unless a major
style change is being made.
- Only one case has been found where three iterations were required.
- No cases requiring four iterations have been found with this version.
For the previous version several cases where found the results could
oscillate between two semi-stable states. This version corrects this.
So if it is important that the code be converged it is okay to set -it=4
with this version and it will probably stop after the second iteration.
- Improved ability to identify and retain good line break points in the
input stream, such as at commas and equals. You can always tell
perltidy to ignore old breakpoints with -iob.
- Fixed glitch in which a terminal closing hash brace followed by semicolon
was not outdented back to the leading line depth like other closing
tokens. Thanks to Keith Neargarder for noting this.
OLD:
my ( $pre, $post ) = @{
{
"pp_anonlist" => [ "[", "]" ],
"pp_anonhash" => [ "{", "}" ]
}->{ $kid->ppaddr }
}; # terminal brace
NEW:
my ( $pre, $post ) = @{
{
"pp_anonlist" => [ "[", "]" ],
"pp_anonhash" => [ "{", "}" ]
}->{ $kid->ppaddr }
}; # terminal brace
- Removed extra indentation given to trailing 'if' and 'unless' clauses
without parentheses because this occasionally produced undesirable
results. This only applies where parens are not used after the if or
unless.
OLD:
return undef
unless my ( $who, $actions ) =
$clause =~ /^($who_re)((?:$action_re)+)$/o;
NEW:
return undef
unless my ( $who, $actions ) =
$clause =~ /^($who_re)((?:$action_re)+)$/o;
- Updated perltidy to handle all quote modifiers defined for perl 5 version 16.
- Side comment text in perltidyrc configuration files must now begin with
at least one space before the #. Thus:
OK:
-l=78 # Max line width is 78 cols
BAD:
-l=78# Max line width is 78 cols
This is probably true of almost all existing perltidyrc files,
but if you get an error message about bad parameters
involving a '#' the first time you run this version, please check the side
comments in your perltidyrc file, and add a space before the # if necessary.
You can quickly see the contents your perltidyrc file, if any, with the
command:
perltidy -dpro
The reason for this change is that some parameters naturally involve
the # symbol, and this can get interpreted as a side comment unless the
parameter is quoted. For example, to define -sphb=# it used to be necessary
to write
-sbcp='#'
to keep the # from becoming part of a comment. This was causing
trouble for new users. Now it can also be written without quotes:
-sbcp=#
- Fixed bug in processing some .perltidyrc files containing parameters with
an opening brace character, '{'. For example the following was
incorrectly processed:
--static-block-comment-prefix="^#{2,}[^\s#]"
Thanks to pdagosto.
- Added flag -boa (--break-at-old-attribute-breakpoints) which retains
any existing line breaks at attribute separation ':'. This is now the
default, use -nboa to deactivate. Thanks to Daphne Phister for the patch.
For example, given the following code, the line breaks at the ':'s will be
retained:
my @field
: field
: Default(1)
: Get('Name' => 'foo') : Set('Name');
whereas the previous version would have output a single line. If
the attributes are on a single line then they will remain on a single line.
- Added new flags --blank-lines-before-subs=n (-blbs=n) and
--blank-lines-before-packages=n (-blbp=n) to put n blank lines before
subs and packages. The old flag -bbs is now equivalent to -blbs=1 -blbp=1.
and -nbbs is equivalent to -blbs=0 -blbp=0. Requested by M. Schwern and
several others.
- Added feature -nsak='*' meaning no space between any keyword and opening
paren. This avoids listing entering a long list of keywords. Requested
by M. Schwern.
- Added option to delete a backup of original file with in-place-modify (-b)
if there were no errors. This can be requested with the flag -bext='/'.
See documentation for details. Requested by M. Schwern and others.
- Fixed bug where the module postfilter parameter was not applied when -b
flag was used. This was discovered during testing.
- Fixed in-place-modify (-b) to work with symbolic links to source files.
Thanks to Ted Johnson.
- Fixed bug where the Perl::Tidy module did not allow -b to be used
in some cases.
- No extra blank line is added before a comment which follows
a short line ending in an opening token, for example like this:
OLD:
if (
# unless we follow a blank or comment line
$last_line_leading_type !~ /^[#b]$/
...
NEW:
if (
# unless we follow a blank or comment line
$last_line_leading_type !~ /^[#b]$/
...
The blank is not needed for readability in these cases because there
already is already space above the comment. If a blank already
exists there it will not be removed, so this change should not
change code which has previously been formatted with perltidy.
Thanks to R.W.Stauner.
- Likewise, no extra blank line is added above a comment consisting of a
single #, since nothing is gained in readability.
- Fixed error in which a blank line was removed after a #>>> directive.
Thanks to Ricky Morse.
- Unnecessary semicolons after given/when/default blocks are now removed.
- Fixed bug where an unwanted blank line could be added before
pod text in __DATA__ or __END__ section. Thanks to jidani.
- Changed exit flags from 1 to 0 to indicate success for -help, -version,
and all -dump commands. Also added -? as another way to dump the help.
Requested by Keith Neargarder.
- Fixed bug where .ERR and .LOG files were not written except for -it=2 or more
- Fixed bug where trailing blank lines at the end of a file were dropped when
-it>1.
- Fixed bug where a line occasionally ended with an extra space. This reduces
the number of instances where a second iteration gives a result different
from the first.
- Updated documentation to note that the Tidy.pm module <stderr> parameter may
not be a reference to SCALAR or ARRAY; it must be a file.
- Syntax check with perl now work when the Tidy.pm module is processing
references to arrays and strings. Thanks to Charles Alderman.
- Zero-length files are no longer processed due to concerns for data loss
due to side effects in some scenarios.
- block labels, if any, are now included in closing side comment text
when the -csc flag is used. Suggested by Aaron. For example,
the label L102 in the following block is now included in the -csc text:
L102: for my $i ( 1 .. 10 ) {
...
} ## end L102: for my $i ( 1 .. 10 )
- added new flag -it=n or --iterations=n
This flag causes perltidy to do n complete iterations.
For most purposes the default of n=1 should be satisfactory. However n=2
can be useful when a major style change is being made, or when code is being
beautified on check-in to a source code control system. The run time will be
approximately proportional to n, and it should seldom be necessary to use a
value greater than n=2. Thanks to Jonathan Swartz
- A configuration file pathname begins with three dots, e.g.
".../.perltidyrc", indicates that the file should be searched for starting
in the current directory and working upwards. This makes it easier to have
multiple projects each with their own .perltidyrc in their root directories.
Thanks to Jonathan Swartz for this patch.
- Added flag --notidy which disables all formatting and causes the input to be
copied unchanged. This can be useful in conjunction with hierarchical
F<.perltidyrc> files to prevent unwanted tidying.
Thanks to Jonathan Swartz for this patch.
- Added prefilters and postfilters in the call to the Tidy.pm module.
Prefilters and postfilters. The prefilter is a code reference that
will be applied to the source before tidying, and the postfilter
is a code reference to the result before outputting.
Thanks to Jonathan Swartz for this patch. He writes:
This is useful for all manner of customizations. For example, I use
it to convert the 'method' keyword to 'sub' so that perltidy will work for
Method::Signature::Simple code:
Perl::Tidy::perltidy(
prefilter => sub { $_ = $_[0]; s/^method (.*)/sub $1 \#__METHOD/gm; return $_ },
postfilter => sub { $_ = $_[0]; s/^sub (.*?)\s* \#__METHOD/method $1/gm; return $_ }
);
- The starting indentation level of sections of code entabbed with -et=n
is correctly guessed if it was also produced with the same -et=n flag. This
keeps the indentation stable on repeated formatting passes within an editor.
Thanks to Sam Kington and Glenn.
- Functions with prototype '&' had a space between the function and opening
peren. This space now only occurs if the flag --space-function-paren (-sfp)
is set. Thanks to Zrajm Akfohg.
- Patch to never put spaces around a bare word in braces beginning with ^ as in:
my $before = ${^PREMATCH};
even if requested with the -bt=0 flag because any spaces cause a syntax error in perl.
Thanks to Fabrice Dulanoy.
- Allow configuration file to be 'perltidy.ini' for Windows systems.
i.e. C:\Documents and Settings\User\perltidy.ini
and added documentation for setting configuration file under Windows in man
page. Thanks to Stuart Clark.
- Corrected problem of unwanted semicolons in hash ref within given/when code.
Thanks to Nelo Onyiah.
- added new flag -cscb or --closing-side-comments-balanced
When using closing-side-comments, and the closing-side-comment-maximum-text
limit is exceeded, then the comment text must be truncated. Previous
versions of perltidy terminate with three dots, and this can still be
achieved with -ncscb:
perltidy -csc -ncscb
} ## end foreach my $foo (sort { $b cmp $a ...
However this causes a problem with older editors which cannot recognize
comments or are not configured to doso because they cannot "bounce" around in
the text correctly. The B<-cscb> flag tries to help them by
appending appropriate terminal balancing structure:
perltidy -csc -cscb
} ## end foreach my $foo (sort { $b cmp $a ... })
Since there is much to be gained and little to be lost by doing this,
the default is B<-cscb>. Use B<-ncscb> if you do not want this.
Thanks to Daniel Becker for suggesting this option.
- After an isolated closing eval block the continuation indentation will be
removed so that the braces line up more like other blocks. Thanks to Yves Orton.
OLD:
eval {
#STUFF;
1; # return true
}
or do {
#handle error
};
NEW:
eval {
#STUFF;
1; # return true
} or do {
#handle error
};
-A new flag -asbl (or --opening-anonymous-sub-brace-on-new-line) has
been added to put the opening brace of anonymous sub's on a new line,
as in the following snippet:
my $code = sub
{
my $arg = shift;
return $arg->(@_);
};
This was not possible before because the -sbl flag only applies to named
subs. Thanks to Benjamin Krupp.
-Fix tokenization bug with the following snippet
print 'hi' if { x => 1, }->{x};
which resulted in a semicolon being added after the comma. The workaround
was to use -nasc, but this is no longer necessary. Thanks to Brian Duggan.
-Fixed problem in which an incorrect error message could be triggered
by the (unusual) combination of parameters -lp -i=0 -l=2 -ci=0 for
example. Thanks to Richard Jelinek.
-A new flag --keep-old-blank-lines=n has been added to
give more control over the treatment of old blank lines in
a script. The manual has been revised to discuss the new
flag and clarify the treatment of old blank lines. Thanks
to Oliver Schaefer.
-Improved support for perl 5.10: New quote modifier 'p', new block type UNITCHECK,
new keyword break, improved formatting of given/when.
-Corrected tokenization bug of something like $var{-q}.
-Numerous minor formatting improvements.
-Corrected list of operators controlled by -baao -bbao to include
. : ? && || and or err xor
-Corrected very minor error in log file involving incorrect comment
regarding need for upper case of labels.
-Fixed problem where perltidy could run for a very long time
when given certain non-perl text files.
-Line breaks in un-parenthesized lists now try to follow
line breaks in the input file rather than trying to fill
lines. This usually works better, but if this causes
trouble you can use -iob to ignore any old line breaks.
Example for the following input snippet:
print
"conformability (Not the same dimension)\n",
"\t", $have, " is ", text_unit($hu), "\n",
"\t", $want, " is ", text_unit($wu), "\n",
;
OLD:
print "conformability (Not the same dimension)\n", "\t", $have, " is ",
text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n",;
NEW:
print "conformability (Not the same dimension)\n",
"\t", $have, " is ", text_unit($hu), "\n",
"\t", $want, " is ", text_unit($wu), "\n",
;
-Added -fpsc option (--fixed-position-side-comment). Thanks to Ueli Hugenschmidt.
For example -fpsc=40 tells perltidy to put side comments in column 40
if possible.
-Added -bbao and -baao options (--break-before-all-operators and
--break-after-all-operators) to simplify command lines and configuration
files. These define an initial preference for breaking at operators which can
be modified with -wba and -wbb flags. For example to break before all operators
except an = one could use --bbao -wba='=' rather than listing every
single perl operator (except =) on a -wbb flag.
-Added -kis option (--keep-interior-semicolons). Use the B<-kis> flag
to prevent breaking at a semicolon if there was no break there in the
input file. To illustrate, consider the following input lines:
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;
dbmclose(%global); undef %global;
Normally these would be broken into six lines, but
perltidy -kis gives:
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;
dbmclose(%global); undef %global;
-Improved formatting of complex ternary statements, with indentation
of nested statements.
OLD:
return defined( $cw->{Selected} )
? (wantarray)
? @{ $cw->{Selected} }
: $cw->{Selected}[0]
: undef;
NEW:
return defined( $cw->{Selected} )
? (wantarray)
? @{ $cw->{Selected} }
: $cw->{Selected}[0]
: undef;
-Text following un-parenthesized if/unless/while/until statements get a
full level of indentation. Suggested by Jeff Armstrong and others.
OLD:
return $ship->chargeWeapons("phaser-canon")
if $encounter->description eq 'klingon'
and $ship->firepower >= $encounter->firepower
and $location->status ne 'neutral';
NEW:
return $ship->chargeWeapons("phaser-canon")
if $encounter->description eq 'klingon'
and $ship->firepower >= $encounter->firepower
and $location->status ne 'neutral';
-Fixed bug where #line directives were being indented. Thanks to
Philippe Bruhat.
-Fixed problem where an extra blank line was added after an =cut when either
(a) the =cut started (not stopped) a POD section, or (b) -mbl > 1.
Thanks to J. Robert Ray and Bill Moseley.
-ole (--output-line-ending) and -ple (--preserve-line-endings) should
now work on all systems rather than just unix systems. Thanks to Dan
Tyrell.
-Fixed problem of a warning issued for multiple subs for BEGIN subs
and other control subs. Thanks to Heiko Eissfeldt.
-Fixed problem where no space was introduced between a keyword or
bareword and a colon, such as:
( ref($result) eq 'HASH' && !%$result ) ? undef: $result;
Thanks to Niek.
-Added a utility program 'break_long_quotes.pl' to the examples directory of
the distribution. It breaks long quoted strings into a chain of concatenated
sub strings no longer than a selected length. Suggested by Michael Renner as
a perltidy feature but was judged to be best done in a separate program.
-Updated docs to remove extra < and >= from list of tokens
after which breaks are made by default. Thanks to Bob Kleemann.
-Removed improper uses of $_ to avoid conflicts with external calls, giving
error message similar to:
Modification of a read-only value attempted at
/usr/share/perl5/Perl/Tidy.pm line 6907.
Thanks to Michael Renner.
-Fixed problem when errorfile was not a plain filename or filehandle
in a call to Tidy.pm. The call
perltidy(source => \$input, destination => \$output, errorfile => \$err);
gave the following error message:
Not a GLOB reference at /usr/share/perl5/Perl/Tidy.pm line 3827.
Thanks to Michael Renner and Phillipe Bruhat.
-Fixed problem where -sot would not stack an opening token followed by
a side comment. Thanks to Jens Schicke.
-improved breakpoints in complex math and other long statements. Example:
OLD:
return
log($n) + 0.577215664901532 + ( 1 / ( 2 * $n ) ) -
( 1 / ( 12 * ( $n**2 ) ) ) + ( 1 / ( 120 * ( $n**4 ) ) );
NEW:
return
log($n) + 0.577215664901532 +
( 1 / ( 2 * $n ) ) -
( 1 / ( 12 * ( $n**2 ) ) ) +
( 1 / ( 120 * ( $n**4 ) ) );
-more robust vertical alignment of complex terminal else blocks and ternary
statements.
-Eliminated bug where a here-doc invoked through an 'e' modifier on a pattern
replacement text was not recognized. The tokenizer now recursively scans
replacement text (but does not reformat it).
-improved vertical alignment of terminal else blocks and ternary statements.
Thanks to Chris for the suggestion.
OLD:
if ( IsBitmap() ) { return GetBitmap(); }
elsif ( IsFiles() ) { return GetFiles(); }
else { return GetText(); }
NEW:
if ( IsBitmap() ) { return GetBitmap(); }
elsif ( IsFiles() ) { return GetFiles(); }
else { return GetText(); }
OLD:
$which_search =
$opts{"t"} ? 'title'
: $opts{"s"} ? 'subject'
: $opts{"a"} ? 'author'
: 'title';
NEW:
$which_search =
$opts{"t"} ? 'title'
: $opts{"s"} ? 'subject'
: $opts{"a"} ? 'author'
: 'title';
-improved indentation of try/catch blocks and other externally defined
functions accepting a block argument. Thanks to jae.
-Added support for Perl 5.10 features say and smartmatch.
-Added flag -pbp (--perl-best-practices) as an abbreviation for parameters
suggested in Damian Conway's "Perl Best Practices". -pbp is the same as:
-l=78 -i=4 -ci=4 -st -se -vt=2 -cti=0 -pt=1 -bt=1 -sbt=1 -bbt=1 -nsfs -nolq
-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < =
**= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
Please note that the -st here restricts input to standard input; use
-nst if necessary to override.
-Eliminated some needless breaks at equals signs in -lp indentation.
OLD:
$c =
Math::Complex->make(LEFT + $x * (RIGHT - LEFT) / SIZE,
TOP + $y * (BOTTOM - TOP) / SIZE);
NEW:
$c = Math::Complex->make(LEFT + $x * (RIGHT - LEFT) / SIZE,
TOP + $y * (BOTTOM - TOP) / SIZE);
A break at an equals is sometimes useful for preventing complex statements
from hitting the line length limit. The decision to do this was
over-eager in some cases and has been improved. Thanks to Royce Reece.
-qw quotes contained in braces, square brackets, and parens are being
treated more like those containers as far as stacking of tokens. Also
stack of closing tokens ending ');' will outdent to where the ');' would
have outdented if the closing stack is matched with a similar opening stack.
OLD: perltidy -soc -sct
__PACKAGE__->load_components(
qw(
PK::Auto
Core
)
);
NEW: perltidy -soc -sct
__PACKAGE__->load_components( qw(
PK::Auto
Core
) );
Thanks to Aran Deltac
-Eliminated some undesirable or marginally desirable vertical alignments.
These include terminal colons, opening braces, and equals, and particularly
when just two lines would be aligned.
OLD:
my $accurate_timestamps = $Stamps{lnk};
my $has_link =
...
NEW:
my $accurate_timestamps = $Stamps{lnk};
my $has_link =
-Corrected a problem with -mangle in which a space would be removed
between a keyword and variable beginning with ::.
-Attribute argument lists are now correctly treated as quoted strings
and not formatted. This is the most important update in this version.
Thanks to Borris Zentner, Greg Ferguson, Steve Kirkup.
-Updated to recognize the defined or operator, //, to be released in Perl 10.
Thanks to Sebastien Aperghis-Tramoni.
-A useful utility perltidyrc_dump.pl is included in the examples section. It
will read any perltidyrc file and write it back out in a standard format
(though comments are lost).
-Added option to have perltidy read and return a hash with the contents of a
perltidyrc file. This may be used by Leif Eriksen's tidyview code. This
feature is used by the demonstration program 'perltidyrc_dump.pl' in the
examples directory.
-Improved error checking in perltidyrc files. Unknown bare words were not
being caught.
-The --dump-options parameter now dumps parameters in the format required by a
perltidyrc file.
-V-Strings with underscores are now recognized.
For example: $v = v1.2_3;
-cti=3 option added which gives one extra indentation level to closing
tokens always. This provides more predictable closing token placement
than cti=2. If you are using cti=2 you might want to try cti=3.
-To identify all left-adjusted comments as static block comments, use C<-sbcp='^#'>.
-New parameters -fs, -fsb, -fse added to allow sections of code between #<<<
and #>>> to be passed through verbatim. This is enabled by default and turned
off by -nfs. Flags -fsb and -fse allow other beginning and ending markers.
Thanks to Wolfgang Werner and Marion Berryman for suggesting this.
-added flag -skp to put a space between all Perl keywords and following paren.
The default is to only do this for certain keywords. Suggested by
H.Merijn Brand.
-added flag -sfp to put a space between a function name and following paren.
The default is not to do this. Suggested by H.Merijn Brand.
-Added patch to avoid breaking GetOpt::Long::Configure set by calling program.
Thanks to Philippe Bruhat.
-An error was fixed in which certain parameters in a .perltidyrc file given
without the equals sign were not recognized. That is,
'--brace-tightness 0' gave an error but '--brace-tightness=0' worked
ok. Thanks to Zac Hansen.
-An error preventing the -nwrs flag from working was corrected. Thanks to
Greg Ferguson.
-Corrected some alignment problems with entab option.
-A bug with the combination of -lp and -extrude was fixed (though this
combination doesn't really make sense). The bug was that a line with
a single zero would be dropped. Thanks to Cameron Hayne.
-Updated Windows detection code to avoid an undefined variable.
Thanks to Joe Yates and Russ Jones.
-Improved formatting for short trailing statements following a closing paren.
Thanks to Joe Matarazzo.
-The handling of the -icb (indent closing block braces) flag has been changed
slightly to provide more consistent and predictable formatting of complex
structures. Instead of giving a closing block brace the indentation of the
previous line, it is now given one extra indentation level. The two methods
give the same result if the previous line was a complete statement, as in this
example:
if ($task) {
yyy();
} # -icb
else {
zzz();
}
The change also fixes a problem with empty blocks such as:
OLD, -icb:
elsif ($debug) {
}
NEW, -icb:
elsif ($debug) {
}
-A problem with -icb was fixed in which a closing brace was misplaced when
it followed a quote which spanned multiple lines.
-Some improved breakpoints for -wba='&& || and or'
-Fixed problem with misaligned cuddled else in complex statements
when the -bar flag was also used. Thanks to Alex and Royce Reese.
-Corrected documentation to show that --outdent-long-comments is the default.
Thanks to Mario Lia.
-New flag -otr (opening-token-right) is similar to -bar (braces-always-right)
but applies to non-structural opening tokens.
-new flags -sot (stack-opening-token), -sct (stack-closing-token).
Suggested by Tony.
-The default has been changed to not do syntax checking with perl.
Use -syn if you want it. Perltidy is very robust now, and the -syn
flag now causes more problems than it's worth because of BEGIN blocks
(which get executed with perl -c). For example, perltidy will never
return when trying to beautify this code if -syn is used:
BEGIN { 1 while { }; }
Although this is an obvious error, perltidy is often run on untested
code which is more likely to have this sort of problem. A more subtle
example is:
BEGIN { use FindBin; }
which may hang on some systems using -syn if a shared file system is
unavailable.
-Changed style -gnu to use -cti=1 instead of -cti=2 (see next item).
In most cases it looks better. To recover the previous format, use
'-gnu -cti=2'
-Added flags -cti=n for finer control of closing token indentation.
-cti = 0 no extra indentation (default; same as -nicp)
-cti = 1 enough indentation so that the closing token
aligns with its opening token.
-cti = 2 one extra indentation level if the line has the form
); ]; or }; (same as -icp).
The new option -cti=1 works well with -lp:
EXAMPLES:
# perltidy -lp -cti=1
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);
# perltidy -lp -cti=2
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);
This is backwards compatible with -icp. See revised manual for
details. Suggested by Mike Pennington.
-Added flag '--preserve-line-endings' or '-ple' to cause the output
line ending to be the same as in the input file, for unix, dos,
or mac line endings. Only works under unix. Suggested by
Rainer Hochschild.
-Added flag '--output-line-ending=s' or '-ole=s' where s=dos or win,
unix, or mac. Only works under unix.
-Files with Mac line endings should now be handled properly under unix
and dos without being passed through a converter.
-You may now include 'and', 'or', and 'xor' in the list following
'--want-break-after' to get line breaks after those keywords rather than
before them. Suggested by Rainer Hochschild.
-Corrected problem with command line option for -vtc=n and -vt=n. The
equals sign was being eaten up by the Windows shell so perltidy didn't
see it.
-Corrected cause of warning message with recent versions of Perl:
"Possible precedence problem on bitwise & operator at ..."
Thanks to Jim Files.
-fixed bug with -html with '=for pod2html' sections, in which code/pod
output order was incorrect. Thanks to Tassilo von Parseval.
-fixed bug when the -html flag is used, in which the following error
message, plus others, appear:
did not see <body> in pod2html output
This was caused by a change in the format of html output by pod2html
VERSION 1.04 (included with perl 5.8). Thanks to Tassilo von Parseval.
-Fixed bug where an __END__ statement would be mistaken for a label
if it is immediately followed by a line with a leading colon. Thanks
to John Bayes.
-Implemented guessing logic for brace types when it is ambiguous. This
has been on the TODO list a long time. Thanks to Boris Zentner for
an example.
-Long options may now be negated either as '--nolong-option'
or '--no-long-option'. Thanks to Philip Newton for the suggestion.
-added flag --html-entities or -hent which controls the use of
Html::Entities for html formatting. Use --nohtml-entities or -nhent to
prevent the use of Html::Entities to encode special symbols. The
default is -hent. Html::Entities when formatting perl text to escape
special symbols. This may or may not be the right thing to do,
depending on browser/language combinations. Thanks to Burak Gursoy for
this suggestion.
-Bareword strings with leading '-', like, '-foo' now count as 1 token
for horizontal tightness. This way $a{'-foo'}, $a{foo}, and $a{-foo}
are now all treated similarly. Thus, by default, OLD: $a{ -foo } will
now be NEW: $a{-foo}. Suggested by Mark Olesen.
-added 2 new flags to control spaces between keywords and opening parens:
-sak=s or --space-after-keyword=s, and
-nsak=s or --nospace-after-keyword=s, where 's' is a list of keywords.
The new default list of keywords which get a space is:
"my local our and or eq ne if else elsif until unless while for foreach
return switch case given when"
Use -sak=s and -nsak=s to add and remove keywords from this list,
respectively.
Explanation: Stephen Hildrey noted that perltidy was being inconsistent
in placing spaces between keywords and opening parens, and sent a patch
to give user control over this. The above list was selected as being
a reasonable default keyword list. Previously, perltidy
had a hardwired list which also included these keywords:
push pop shift unshift join split die
but did not have 'our'. Example: if you prefer to make perltidy behave
exactly as before, you can include the following two lines in your
.perltidyrc file:
-sak="push pop local shift unshift join split die"
-nsak="our"
-Corrected html error in .toc file when -frm -html is used (extra ");
browsers were tolerant of it.
-Improved alignment of chains of binary and ?/: operators. Example:
OLD:
$leapyear =
$year % 4 ? 0
: $year % 100 ? 1
: $year % 400 ? 0
: 1;
NEW:
$leapyear =
$year % 4 ? 0
: $year % 100 ? 1
: $year % 400 ? 0
: 1;
-improved breakpoint choices involving '->'
-Corrected tokenization of things like ${#}. For example,
${#} is valid, but ${# } is a syntax error.
-Corrected minor tokenization errors with indirect object notation.
For example, 'new A::()' works now.
-Minor tokenization improvements; all perl code distributed with perl 5.8
seems to be parsed correctly except for one instance (lextest.t)
of the known bug.
-Implemented scalar attributes. Thanks to Sean Tobin for noting this.
-Fixed glitch introduced in previous release where -pre option
was not outputting a leading html <pre> tag.
-Numerous minor improvements in vertical alignment, including the following:
-Improved alignment of opening braces in many cases. Needed for improved
switch/case formatting, and also suggested by Mark Olesen for sort/map/grep
formatting. For example:
OLD:
@modified =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, -M ] } @filenames;
NEW:
@modified =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, -M ] } @filenames;
-Eliminated alignments across unrelated statements. Example:
OLD:
$borrowerinfo->configure( -state => 'disabled' );
$borrowerinfo->grid( -col => 1, -row => 0, -sticky => 'w' );
NEW:
$borrowerinfo->configure( -state => 'disabled' );
$borrowerinfo->grid( -col => 1, -row => 0, -sticky => 'w' );
Thanks to Mark Olesen for suggesting this.
-Improved alignment of '='s in certain cases.
Thanks to Norbert Gruener for sending an example.
-Outdent-long-comments (-olc) has been re-instated as a default, since
it works much better now. Use -nolc if you want to prevent it.
-Added check for 'perltidy file.pl -o file.pl', which causes file.pl
to be lost. (The -b option should be used instead). Thanks to mreister
for reporting this problem.
-Switch/case or given/when syntax is now recognized. Its vertical alignment
is not great yet, but it parses ok. The words 'switch', 'case', 'given',
and 'when' are now treated as keywords. If this causes trouble with older
code, we could introduce a switch to deactivate it. Thanks to Stan Brown
and Jochen Schneider for recommending this.
-Corrected error parsing sub attributes with call parameters.
Thanks to Marc Kerr for catching this.
-Sub prototypes no longer need to be on the same line as sub names.
-a new flag -frm or --frames will cause html output to be in a
frame, with table of contents in the left panel and formatted source
in the right panel. Try 'perltidy -html -frm somemodule.pm' for example.
-The new default for -html formatting is to pass the pod through Pod::Html.
The result is syntax colored code within your pod documents. This can be
deactivated with -npod. Thanks to those who have written to discuss this,
particularly Mark Olesen and Hugh Myers.
-the -olc (--outdent-long-comments) option works much better. It now outdents
groups of consecutive comments together, and by just the amount needed to
avoid having any one line exceeding the maximum line length.
-block comments are now trimmed of trailing whitespace.
-if a directory specified with -opath does not exist, it will be created.
-a table of contents to packages and subs is output when -html is used.
Use -ntoc to prevent this.
-fixed an unusual bug in which a 'for' statement following a 'format'
statement was not correctly tokenized. Thanks to Boris Zentner for
catching this.
-Tidy.pm is no longer dependent on modules IO::Scalar and IO::ScalarArray.
There were some speed issues. Suggested by Joerg Walter.
-The treatment of quoted wildcards (file globs) is now system-independent.
For example
perltidy 'b*x.p[lm]'
would match box.pl, box.pm, brinx.pm under any operating system. Of
course, anything unquoted will be subject to expansion by any shell.
-default color for keywords under -html changed from
SaddleBrown (#8B4513) to magenta4 (#8B008B).
-fixed an arg parsing glitch in which something like:
perltidy quick-help
would trigger the help message and exit, rather than operate on the
file 'quick-help'.
-New option '-b' or '--backup-and-modify-in-place' will cause perltidy to
overwrite the original file with the tidied output file. The original
file will be saved with a '.bak' extension (which can be changed with
-bext=s). Thanks to Rudi Farkas for the suggestion.
-An index to all subs is included at the top of -html output, unless
only the <pre> section is written.
-Anchor lines of the form <a name="mysub"></a> are now inserted at key points
in html output, such as before sub definitions, for the convenience of
postprocessing scripts. Suggested by Howard Owen.
-The cuddled-else (-ce) flag now also makes cuddled continues, like
this:
while ( ( $pack, $file, $line ) = caller( $i++ ) ) {
# bla bla
} continue {
$prevpack = $pack;
}
Suggested by Simon Perreault.
-Fixed bug in which an extra blank line was added before an =head or
similar pod line after an __END__ or __DATA__ line each time
perltidy was run. Also, an extra blank was being added after
a terminal =cut. Thanks to Mike Birdsall for reporting this.
-Fixed bug in which space was inserted in a hyphenated hash key:
my $val = $myhash{USER-NAME};
was converted to:
my $val = $myhash{USER -NAME};
Thanks to an anonymous bug reporter at sourceforge.
-Fixed problem with the '-io' ('--indent-only') where all lines
were double spaced. Thanks to Nick Andrew for reporting this bug.
-Fixed tokenization error in which something like '-e1' was
parsed as a number.
-Corrected a rare problem involving older perl versions, in which
a line break before a bareword caused problems with 'use strict'.
Thanks to Wolfgang Weisselberg for noting this.
-More syntax error checking added.
-Outdenting labels (-ola) has been made the default, in order to follow the
perlstyle guidelines better. It's probably a good idea in general, but
if you do not want this, use -nola in your .perltidyrc file.
-Updated rules for padding logical expressions to include more cases.
Thanks to Wolfgang Weisselberg for helpful discussions.
-Added new flag -osbc (--outdent-static-block-comments) which will
outdent static block comments by 2 spaces (or whatever -ci equals).
Requested by Jon Robison.
-Corrected a bug, introduced in the previous release, in which some
closing side comments (-csc) could have incorrect text. This is
annoying but will be correct the next time perltidy is run with -csc.
-Fixed bug where whitespace was being removed between 'Bar' and '()'
in a use statement like:
use Foo::Bar ();
-Whenever possible, if a logical expression is broken with leading
'&&', '||', 'and', or 'or', then the leading line will be padded
with additional space to produce alignment. This has been on the
todo list for a long time; thanks to Frank Steinhauer for reminding
me to do it. Notice the first line after the open parens here:
OLD: perltidy -lp
if (
!param("rules.to.$linecount")
&& !param("rules.from.$linecount")
&& !param("rules.subject.$linecount")
&& !(
param("rules.fieldname.$linecount")
&& param("rules.fieldval.$linecount")
)
&& !param("rules.size.$linecount")
&& !param("rules.custom.$linecount")
)
NEW: perltidy -lp
if (
!param("rules.to.$linecount")
&& !param("rules.from.$linecount")
&& !param("rules.subject.$linecount")
&& !(
param("rules.fieldname.$linecount")
&& param("rules.fieldval.$linecount")
)
&& !param("rules.size.$linecount")
&& !param("rules.custom.$linecount")
)
-Corrected a mistokenization of variables for a package with a name
equal to a perl keyword. For example:
my::qx();
package my;
sub qx{print "Hello from my::qx\n";}
In this case, the leading 'my' was mistokenized as a keyword, and a
space was being place between 'my' and '::'. This has been
corrected. Thanks to Martin Sluka for discovering this.
-A new flag -bol (--break-at-old-logic-breakpoints)
has been added to control whether containers with logical expressions
should be broken open. This is the default.
-A new flag -bok (--break-at-old-keyword-breakpoints)
has been added to follow breaks at old keywords which return lists,
such as sort and map. This is the default.
-A new flag -bot (--break-at-old-trinary-breakpoints) has been added to
follow breaks at trinary (conditional) operators. This is the default.
-A new flag -cab=n has been added to control breaks at commas after
'=>' tokens. The default is n=1, meaning break unless this breaks
open an existing on-line container.
-A new flag -boc has been added to allow existing list formatting
to be retained. (--break-at-old-comma-breakpoints). See updated manual.
-A new flag -iob (--ignore-old-breakpoints) has been added to
prevent the locations of old breakpoints from influencing the output
format.
-Corrected problem where nested parentheses were not getting full
indentation. This has been on the todo list for some time; thanks
to Axel Rose for a snippet demonstrating this issue.
OLD: inner list is not indented
$this->sendnumeric(
$this->server,
(
$ret->name, $user->username, $user->host,
$user->server->name, $user->nick, "H"
),
);
NEW:
$this->sendnumeric(
$this->server,
(
$ret->name, $user->username, $user->host,
$user->server->name, $user->nick, "H"
),
);
-Code cleaned up by removing the following unused, undocumented flags.
They should not be in any .perltidyrc files because they were just
experimental flags which were never documented. Most of them placed
artificial limits on spaces, and Wolfgang Weisselberg convinced me that
most of them they do more harm than good by causing unexpected results.
--maximum-continuation-indentation (-mci)
--maximum-whitespace-columns
--maximum-space-to-comment (-xsc)
--big-space-jump (-bsj)
-Pod file 'perltidy.pod' has been appended to the script 'perltidy', and
Tidy.pod has been append to the module 'Tidy.pm'. Older MakeMaker's
were having trouble.
-A new flag -isbc has been added for more control on comments. This flag
has the effect that if there is no leading space on the line, then the
comment will not be indented, and otherwise it may be. If both -ibc and
-isbc are set, then -isbc takes priority. Thanks to Frank Steinhauer
for suggesting this.
-A new document 'stylekey.pod' has been created to quickly guide new users
through the maze of perltidy style parameters. An html version is
on the perltidy web page. Take a look! It should be very helpful.
-Parameters for controlling 'vertical tightness' have been added:
-vt and -vtc are the main controls, but finer control is provided
with -pvt, -pcvt, -bvt, -bcvt, -sbvt, -sbcvt. Block brace vertical
tightness controls have also been added.
See updated manual and also see 'stylekey.pod'. Simple examples:
# perltidy -lp -vt=1 -vtc=1
@month_of_year = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
# perltidy -lp -vt=1 -vtc=0
@month_of_year = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
);
-Lists which do not format well in uniform columns are now better
identified and formatted.
OLD:
return $c->create( 'polygon', $x, $y, $x + $ruler_info{'size'},
$y + $ruler_info{'size'}, $x - $ruler_info{'size'},
$y + $ruler_info{'size'} );
NEW:
return $c->create(
'polygon', $x, $y,
$x + $ruler_info{'size'},
$y + $ruler_info{'size'},
$x - $ruler_info{'size'},
$y + $ruler_info{'size'}
);
OLD:
radlablist($f1, pad('Initial', $p), $b->{Init}->get_panel_ref, 'None ',
'None', 'Default', 'Default', 'Simple', 'Simple');
NEW:
radlablist($f1,
pad('Initial', $p),
$b->{Init}->get_panel_ref,
'None ', 'None', 'Default', 'Default', 'Simple', 'Simple');
-Corrected problem where an incorrect html filename was generated for
external calls to Tidy.pm module. Fixed incorrect html title when
Tidy.pm is called with IO::Scalar or IO::Array source.
-Output file permissions are now set as follows. An output script file
gets the same permission as the input file, except that owner
read/write permission is added (otherwise, perltidy could not be
rerun). Html output files use system defaults. Previously chmod 0755
was used in all cases. Thanks to Mark Olesen for bringing this up.
-Missing semicolons will not be added in multi-line blocks of type
sort, map, or grep. This brings perltidy into closer agreement
with common practice. Of course, you can still put semicolons
there if you like. Thanks to Simon Perreault for a discussion of this.
-Most instances of extra semicolons are now deleted. This is
particularly important if the -csc option is used. Thanks to Wolfgang
Weisselberg for noting this. For example, the following line
(produced by 'h2xs' :) has an extra semicolon which will now be
removed:
BEGIN { plan tests => 1 };
-New parameter -csce (--closing-side-comment-else-flag) can be used
to control what text is appended to 'else' and 'elsif' blocks.
Default is to just add leading 'if' text to an 'else'. See manual.
-The -csc option now labels 'else' blocks with additional information
from the opening if statement and elsif statements, if space.
Thanks to Wolfgang Weisselberg for suggesting this.
-The -csc option will now remove any old closing side comments
below the line interval threshold. Thanks to Wolfgang Weisselberg for
suggesting this.
-The abbreviation feature, which was broken in the previous version,
is now fixed. Thanks to Michael Cartmell for noting this.
-Vertical alignment is now done for '||=' .. somehow this was
overlooked.
-This version uses modules for the first time, and a standard perl
Makefile.PL has been supplied. However, perltidy may still be
installed as a single script, without modules. See INSTALL for
details.
-The man page 'perl2web' has been merged back into the main 'perltidy'
man page to simplify installation. So you may remove that man page
if you have an older installation.
-Added patch from Axel Rose for MacPerl. The patch prompts the user
for command line arguments before calling the module
Perl::Tidy::perltidy.
-Corrected bug with '-bar' which was introduced in the previous
version. A closing block brace was being indented. Thanks to
Alexandros M Manoussakis for reporting this.
-New parameter '--entab-leading-whitespace=n', or '-et=n', has been
added for those who prefer tabs. This behaves different from the
existing '-t' parameter; see updated man page. Suggested by Mark
Olesen.
-New parameter '--perl-syntax-check-flags=s' or '-pcsf=s' can be
used to change the flags passed to perltidy in a syntax check.
See updated man page. Suggested by Mark Olesen.
-New parameter '--output-path=s' or '-opath=s' will cause output
files to be placed in directory s. See updated man page. Thanks for
Mark Olesen for suggesting this.
-New parameter --dump-profile (or -dpro) will dump to
standard output information about the search for a
configuration file, the name of whatever configuration file
is selected, and its contents. This should help debugging
config files, especially on different Windows systems.
-The -w parameter now notes possible errors of the form:
$comment = s/^\s*(\S+)\..*/$1/; # trim whitespace
-Corrections added for a leading ':' and for leaving a leading 'tcsh'
line untouched. Mark Olesen reported that lines of this form were
accepted by perl but not by perltidy:
: # use -*- perl -*-
eval 'exec perl -wS $0 "$@"' # shell should exec 'perl'
unless 1; # but Perl should skip this one
Perl will silently swallow a leading colon on line 1 of a
script, and now perltidy will do likewise. For example,
this is a valid script, provided that it is the first line,
but not otherwise:
: print "Hello World\n";
Also, perltidy will now mark a first line with leading ':' followed by
'#' as type SYSTEM (just as a #! line), not to be formatted.
-List formatting improved for certain lists with special
initial terms, such as occur with 'printf', 'sprintf',
'push', 'pack', 'join', 'chmod'. The special initial term is
now placed on a line by itself. For example, perltidy -gnu
OLD:
$Addr = pack(
"C4", hex($SourceAddr[0]),
hex($SourceAddr[1]), hex($SourceAddr[2]),
hex($SourceAddr[3])
);
NEW:
$Addr = pack("C4",
hex($SourceAddr[0]), hex($SourceAddr[1]),
hex($SourceAddr[2]), hex($SourceAddr[3]));
OLD:
push (
@{$$self{states}}, '64', '66', '68',
'70', '72', '74', '76',
'78', '80', '82', '84',
'86', '88', '90', '92',
'94', '96', '98', '100',
'102', '104'
);
NEW:
push (
@{$$self{states}},
'64', '66', '68', '70', '72', '74', '76',
'78', '80', '82', '84', '86', '88', '90',
'92', '94', '96', '98', '100', '102', '104'
);
-Lists of complex items, such as matrices, are now detected
and displayed with just one item per row:
OLD:
$this->{'CURRENT'}{'gfx'}{'MatrixSkew'} = Text::PDF::API::Matrix->new(
[ 1, tan( deg2rad($a) ), 0 ], [ tan( deg2rad($b) ), 1, 0 ],
[ 0, 0, 1 ]
);
NEW:
$this->{'CURRENT'}{'gfx'}{'MatrixSkew'} = Text::PDF::API::Matrix->new(
[ 1, tan( deg2rad($a) ), 0 ],
[ tan( deg2rad($b) ), 1, 0 ],
[ 0, 0, 1 ]
);
-The perl syntax check will be turned off for now when input is from
standard input or standard output. The reason is that this requires
temporary files, which has produced far too many problems during
Windows testing. For example, the POSIX module under Windows XP/2000
creates temporary names in the root directory, to which only the
administrator should have permission to write.
-Merged patch sent by Yves Orton to handle appropriate
configuration file locations for different Windows varieties
(2000, NT, Me, XP, 95, 98).
-Added patch to properly handle a for/foreach loop without
parens around a list represented as a qw. I didn't know this
was possible until Wolfgang Weisselberg pointed it out:
foreach my $key qw\Uno Due Tres Quadro\ {
print "Set $key\n";
}
But Perl will give a syntax error without the $ variable; ie this will
not work:
foreach qw\Uno Due Tres Quadro\ {
print "Set $_\n";
}
-Merged Windows version detection code sent by Yves Orton. Perltidy
now automatically turns off syntax checking for Win 9x/ME versions,
and this has solved a lot of robustness problems. These systems
cannot reliably handle backtick operators. See man page for
details.
-Merged VMS filename handling patch sent by Michael Cartmell. (Invalid
output filenames were being created in some cases).
-Numerous minor improvements have been made for -lp style indentation.
-Long C-style 'for' expressions will be broken after each ';'.
'perltidy -gnu' gives:
OLD:
for ($status = $db->seq($key, $value, R_CURSOR()) ; $status == 0
and $key eq $origkey ; $status = $db->seq($key, $value, R_NEXT()))
NEW:
for ($status = $db->seq($key, $value, R_CURSOR()) ;
$status == 0 and $key eq $origkey ;
$status = $db->seq($key, $value, R_NEXT()))
-For the -lp option, a single long term within parens
(without commas) now has better alignment. For example,
perltidy -gnu
OLD:
$self->throw("Must specify a known host, not $location,"
. " possible values ("
. join (",", sort keys %hosts) . ")");
NEW:
$self->throw("Must specify a known host, not $location,"
. " possible values ("
. join (",", sort keys %hosts) . ")");
-This version is about 20 percent faster than the previous
version as a result of optimization work. The largest gain
came from switching to a dispatch hash table in the
tokenizer.
-perltidy -html will check to see if HTML::Entities is
installed, and if so, it will use it to encode unsafe
characters.
-Added flag -oext=ext to change the output file extension to
be different from the default ('tdy' or 'html'). For
example:
perltidy -html -oext=htm filename
will produce filename.htm
-Added flag -cscw to issue warnings if a closing side comment would replace
an existing, different side comments. See the man page for details.
Thanks to Peter Masiar for helpful discussions.
-Corrected tokenization error of signed hex/octal/binary numbers. For
example, the first hex number below would have been parsed correctly
but the second one was not:
if ( ( $tmp >= 0x80_00_00 ) || ( $tmp < -0x80_00_00 ) ) { }
-'**=' was incorrectly tokenized as '**' and '='. This only
caused a problem with the -extrude option.
-Corrected a divide by zero when -extrude option is used
-The flag -w will now contain all errors reported by 'perl -c' on the
input file, but otherwise they are not reported. The reason is that
perl will report lots of problems and syntax errors which are not of
interest when only a small snippet is being formatted (such as missing
modules and unknown bare words). Perltidy will always report all
significant syntax errors that it finds, such as unbalanced braces,
unless the -q (quiet) flag is set.
-Merged modifications created by Hugh Myers into perltidy.
These include a 'streamhandle' routine which allows perltidy
as a module to operate on input and output arrays and strings
in addition to files. Documentation and new packaging as a
module should be ready early next year; This is an elegant,
powerful update; many thanks to Hugh for contributing it.
-added a tentative patch which tries to keep any existing breakpoints
at lines with leading keywords map,sort,eval,grep. The idea is to
improve formatting of sequences of list operations, as in a schwartzian
transform. Example:
INPUT:
my @sorted = map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, rand ] } @list;
OLD:
my @sorted =
map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list;
NEW:
my @sorted = map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, rand ] } @list;
The new alignment is not as nice as the input, but this is an improvement.
Thanks to Yves Orton for this suggestion.
-modified indentation logic so that a line with leading opening paren,
brace, or square bracket will never have less indentation than the
line with the corresponding opening token. Here's a simple example:
OLD:
$mw->Button(
-text => "New Document",
-command => \&new_document
)->pack(
-side => 'bottom',
-anchor => 'e'
);
Note how the closing ');' is lined up with the first line, even
though it closes a paren in the 'pack' line. That seems wrong.
NEW:
$mw->Button(
-text => "New Document",
-command => \&new_document
)->pack(
-side => 'bottom',
-anchor => 'e'
);
This seems nicer: you can up-arrow with an editor and arrive at the
opening 'pack' line.
-corrected minor glitch in which cuddled else (-ce) did not get applied
to an 'unless' block, which should look like this:
unless ($test) {
} else {
}
Thanks to Jeremy Mates for reporting this.
-The man page has been reorganized to parameters easier to find.
-Added check for multiple definitions of same subroutine. It is easy
to introduce this problem when cutting and pasting. Perl does not
complain about it, but it can lead to disaster.
-The command -pro=filename or -profile=filename may be used to specify a
configuration file which will override the default name of .perltidyrc.
There must not be a space on either side of the '=' sign. I needed
this to be able to easily test perltidy with a variety of different
configuration files.
-Side comment alignment has been improved somewhat across frequent level
changes, as in short if/else blocks. Thanks to Wolfgang Weisselberg
for pointing out this problem. For example:
OLD:
if ( ref $self ) { # Called as a method
$format = shift;
}
else { # Regular procedure call
$format = $self;
undef $self;
}
NEW:
if ( ref $self ) { # Called as a method
$format = shift;
}
else { # Regular procedure call
$format = $self;
undef $self;
}
-New command -ssc (--static-side-comment) and related command allows
side comments to be spaced close to preceding character. This is
useful for displaying commented code as side comments.
-New command -csc (--closing-side-comment) and several related
commands allow comments to be added to (and deleted from) any or all
closing block braces. This can be useful if you have to maintain large
programs, especially those that you didn't write. See updated man page.
Thanks to Peter Masiar for this suggestion. For a simple example:
perltidy -csc
sub foo {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
} ## end sub foo
This added '## end sub foo' to the closing brace.
To remove it, perltidy -ncsc.
-New commands -ola, for outdenting labels, and -okw, for outdenting
selected control keywords, were implemented. See the perltidy man
page for details. Thanks to Peter Masiar for this suggestion.
-Hanging side comment change: a comment will not be considered to be a
hanging side comment if there is no leading whitespace on the line.
This should improve the reliability of identifying hanging side comments.
Thanks to Peter Masiar for this suggestion.
-Two new commands for outdenting, -olq (outdent-long-quotes) and -olc
(outdent-long-comments), have been added. The original -oll
(outdent-long-lines) remains, and now is an abbreviation for -olq and -olc.
The new default is just -olq. This was necessary to avoid inconsistency with
the new static block comment option.
-Static block comments: to provide a way to display commented code
better, the convention is used that comments with a leading '##' should
not be formatted as usual. Please see '-sbc' (or '--static-block-comment')
for documentation. It can be deactivated with with -nsbc, but
should not normally be necessary. Thanks to Peter Masiar for this
suggestion.
-Two changes were made to help show structure of complex lists:
(1) breakpoints are forced after every ',' in a list where any of
the list items spans multiple lines, and
(2) List items which span multiple lines now get continuation indentation.
The following example illustrates both of these points. Many thanks to
Wolfgang Weisselberg for this snippet and a discussion of it; this is a
significant formatting improvement. Note how it is easier to see the call
parameters in the NEW version:
OLD:
assert( __LINE__, ( not defined $check )
or ref $check
or $check eq "new"
or $check eq "old", "Error in parameters",
defined $old_new ? ( ref $old_new ? ref $old_new : $old_new ) : "undef",
defined $db_new ? ( ref $db_new ? ref $db_new : $db_new ) : "undef",
defined $old_db ? ( ref $old_db ? ref $old_db : $old_db ) : "undef" );
NEW:
assert(
__LINE__,
( not defined $check )
or ref $check
or $check eq "new"
or $check eq "old",
"Error in parameters",
defined $old_new ? ( ref $old_new ? ref $old_new : $old_new ) : "undef",
defined $db_new ? ( ref $db_new ? ref $db_new : $db_new ) : "undef",
defined $old_db ? ( ref $old_db ? ref $old_db : $old_db ) : "undef"
);
Another example shows how this helps displaying lists:
OLD:
%{ $self->{COMPONENTS} } = (
fname =>
{ type => 'name', adj => 'yes', font => 'Helvetica', 'index' => 0 },
street =>
{ type => 'road', adj => 'yes', font => 'Helvetica', 'index' => 2 },
);
The structure is clearer with the added indentation:
NEW:
%{ $self->{COMPONENTS} } = (
fname =>
{ type => 'name', adj => 'yes', font => 'Helvetica', 'index' => 0 },
street =>
{ type => 'road', adj => 'yes', font => 'Helvetica', 'index' => 2 },
);
-The structure of nested logical expressions is now displayed better.
Thanks to Wolfgang Weisselberg for helpful discussions. For example,
note how the status of the final 'or' is displayed in the following:
OLD:
return ( !null($op)
and null( $op->sibling )
and $op->ppaddr eq "pp_null"
and class($op) eq "UNOP"
and ( ( $op->first->ppaddr =~ /^pp_(and|or)$/
and $op->first->first->sibling->ppaddr eq "pp_lineseq" )
or ( $op->first->ppaddr eq "pp_lineseq"
and not null $op->first->first->sibling
and $op->first->first->sibling->ppaddr eq "pp_unstack" ) ) );
NEW:
return (
!null($op)
and null( $op->sibling )
and $op->ppaddr eq "pp_null"
and class($op) eq "UNOP"
and (
(
$op->first->ppaddr =~ /^pp_(and|or)$/
and $op->first->first->sibling->ppaddr eq "pp_lineseq"
)
or ( $op->first->ppaddr eq "pp_lineseq"
and not null $op->first->first->sibling
and $op->first->first->sibling->ppaddr eq "pp_unstack" )
)
);
-A break will always be put before a list item containing a comma-arrow.
This will improve formatting of mixed lists of this form:
OLD:
$c->create(
'text', 225, 20, -text => 'A Simple Plot',
-font => $font,
-fill => 'brown'
);
NEW:
$c->create(
'text', 225, 20,
-text => 'A Simple Plot',
-font => $font,
-fill => 'brown'
);
-For convenience, the command -dac (--delete-all-comments) now also
deletes pod. Likewise, -tac (--tee-all-comments) now also sends pod
to a '.TEE' file. Complete control over the treatment of pod and
comments is still possible, as described in the updated help message
and man page.
-The logic which breaks open 'containers' has been rewritten to be completely
symmetric in the following sense: if a line break is placed after an opening
{, [, or (, then a break will be placed before the corresponding closing
token. Thus, a container either remains closed or is completely cracked
open.
-Improved indentation of parenthesized lists. For example,
OLD:
$GPSCompCourse =
int(
atan2( $GPSTempCompLong - $GPSLongitude,
$GPSLatitude - $GPSTempCompLat ) * 180 / 3.14159265 );
NEW:
$GPSCompCourse = int(
atan2(
$GPSTempCompLong - $GPSLongitude,
$GPSLatitude - $GPSTempCompLat
) * 180 / 3.14159265
);
Further improvements will be made in future releases.
-Some improvements were made in formatting small lists.
-Correspondence between Input and Output line numbers reported in a
.LOG file should now be exact. They were sometimes off due to the size
of intermediate buffers.
-Corrected minor tokenization error in which a ';' in a foreach loop
control was tokenized as a statement termination, which forced a
line break:
OLD:
foreach ( $i = 0;
$i <= 10;
$i += 2
)
{
print "$i ";
}
NEW:
foreach ( $i = 0 ; $i <= 10 ; $i += 2 ) {
print "$i ";
}
-Corrected a problem with reading config files, in which quote marks were not
stripped. As a result, something like -wba="&& . || " would have the leading
quote attached to the && and not work correctly. A workaround for older
versions is to place a space around all tokens within the quotes, like this:
-wba=" && . || "
-Removed any existing space between a label and its ':'
OLD : { }
NEW: { }
This was necessary because the label and its colon are a single token.
-Corrected tokenization error for the following (highly non-recommended)
construct:
$user = @vars[1] / 100;
-Resolved cause of a difference between perltidy under perl v5.6.1 and
5.005_03; the problem was different behavior of \G regex position
marker(!)
-Corrected a bug in which a break was not being made after a full-line
comment within a short eval/sort/map/grep block. A flag was not being
zeroed. The syntax error check catches this. Here is a snippet which
illustrates the bug:
eval {
#open Socket to Dispatcher
$sock = &OpenSocket;
};
The formatter mistakenly thought that it had found the following
one-line block:
eval {#open Socket to Dispatcher$sock = &OpenSocket; };
The patch fixes this. Many thanks to Henry Story for reporting this bug.
-Changes were made to help diagnose and resolve problems in a
.perltidyrc file:
(1) processing of command parameters has been into two separate
batches so that any errors in a .perltidyrc file can be localized.
(2) commands --help, --version, and as many of the --dump-xxx
commands are handled immediately, without any command line processing
at all.
(3) Perltidy will ignore any commands in the .perltidyrc file which
cause immediate exit. These are: -h -v -ddf -dln -dop -dsn -dtt
-dwls -dwrs -ss. Thanks to Wolfgang Weisselberg for helpful
suggestions regarding these updates.
-Syntax check has been reinstated as default for MSWin32 systems. This
way Windows 2000 users will get syntax check by default, which seems
like a better idea, since the number of Win 95/98 systems will be
decreasing over time. Documentation revised to warn Windows 95/98
users about the problem with empty '&1'. Too bad these systems
all report themselves as MSWin32.
-Fixed tokenization error in which a method call of the form
Module::->new();
got a space before the '::' like this:
Module ::->new();
Thanks to David Holden for reporting this.
-Added -html control over pod text, using a new abbreviation 'pd'. See
updated perl2web man page. The default is to use the color of a comment,
but italicized. Old .css style sheets will need a new line for
.pd to use this. The old color was the color of a string, and there
was no control.
-.css lines are now printed in sorted order.
-Fixed interpolation problem where html files had '$input_file' as title
instead of actual input file name. Thanks to Simon Perreault for finding
this and sending a patch, and also to Tobias Weber.
-Breaks will now have the ':' placed at the start of a line,
one per line by default because this shows logical structure
more clearly. This coding has been completely redone. Some
examples of new ?/: formatting:
OLD:
wantarray ? map( $dir::cwd->lookup($_)->path, @_ ) :
$dir::cwd->lookup( $_[0] )->path;
NEW:
wantarray
? map( $dir::cwd->lookup($_)->path, @_ )
: $dir::cwd->lookup( $_[0] )->path;
OLD:
$a = ( $b > 0 ) ? {
a => 1,
b => 2
} : { a => 6, b => 8 };
NEW:
$a = ( $b > 0 )
? {
a => 1,
b => 2
}
: { a => 6, b => 8 };
OLD: (-gnu):
$self->note($self->{skip} ? "Hunk #$self->{hunk} ignored at 1.\n" :
"Hunk #$self->{hunk} failed--$@");
NEW: (-gnu):
$self->note($self->{skip}
? "Hunk #$self->{hunk} ignored at 1.\n"
: "Hunk #$self->{hunk} failed--$@");
OLD:
$which_search =
$opts{"t"} ? 'title' :
$opts{"s"} ? 'subject' : $opts{"a"} ? 'author' : 'title';
NEW:
$which_search =
$opts{"t"} ? 'title'
: $opts{"s"} ? 'subject'
: $opts{"a"} ? 'author'
: 'title';
You can use -wba=':' to recover the previous default which placed ':'
at the end of a line. Thanks to Michael Cartmell for helpful
discussions and examples.
-Tokenizer updated to do syntax checking for matched ?/: pairs. Also,
the tokenizer now outputs a unique serial number for every balanced
pair of brace types and ?/: pairs. This greatly simplifies the
formatter.
-Long lines with repeated 'and', 'or', '&&', '||' will now have
one such item per line. For example:
OLD:
if ( $opt_d || $opt_m || $opt_p || $opt_t || $opt_x
|| ( -e $archive && $opt_r ) )
{
( $pAr, $pNames ) = readAr($archive);
}
NEW:
if ( $opt_d
|| $opt_m
|| $opt_p
|| $opt_t
|| $opt_x
|| ( -e $archive && $opt_r ) )
{
( $pAr, $pNames ) = readAr($archive);
}
OLD:
if ( $vp->{X0} + 4 <= $x && $vp->{X0} + $vp->{W} - 4 >= $x
&& $vp->{Y0} + 4 <= $y && $vp->{Y0} + $vp->{H} - 4 >= $y )
NEW:
if ( $vp->{X0} + 4 <= $x
&& $vp->{X0} + $vp->{W} - 4 >= $x
&& $vp->{Y0} + 4 <= $y
&& $vp->{Y0} + $vp->{H} - 4 >= $y )
-Long lines with multiple concatenated tokens will have concatenated
terms (see below) placed one per line, except for short items. For
example:
OLD:
$report .=
"Device type:" . $ib->family . " ID:" . $ib->serial . " CRC:"
. $ib->crc . ": " . $ib->model() . "\n";
NEW:
$report .= "Device type:"
. $ib->family . " ID:"
. $ib->serial . " CRC:"
. $ib->model()
. $ib->crc . ": " . "\n";
NOTE: at present 'short' means 8 characters or less. There is a
tentative flag to change this (-scl), but it is undocumented and
is likely to be changed or removed later, so only use it for testing.
In the above example, the tokens " ID:", " CRC:", and "\n" are below
this limit.
-If a line which is short enough to fit on a single line was
nevertheless broken in the input file at a 'good' location (see below),
perltidy will try to retain a break. For example, the following line
will be formatted as:
open SUM, "<$file"
or die "Cannot open $file ($!)";
if it was broken in the input file, and like this if not:
open SUM, "<$file" or die "Cannot open $file ($!)";
GOOD: 'good' location means before 'and','or','if','unless','&&','||'
The reason perltidy does not just always break at these points is that if
there are multiple, similar statements, this would preclude alignment. So
rather than check for this, perltidy just tries to follow the input style,
in the hopes that the author made a good choice. Here is an example where
we might not want to break before each 'if':
($Locale, @Locale) = ($English, @English) if (@English > @Locale);
($Locale, @Locale) = ($German, @German) if (@German > @Locale);
($Locale, @Locale) = ($French, @French) if (@French > @Locale);
($Locale, @Locale) = ($Spanish, @Spanish) if (@Spanish > @Locale);
-Added wildcard file expansion for systems with shells which lack this.
Now 'perltidy *.pl' should work under MSDOS/Windows. Thanks to Hugh Myers
for suggesting this. This uses builtin glob() for now; I may change that.
-Added new flag -sbl which, if specified, overrides the value of -bl
for opening sub braces. This allows formatting of this type:
perltidy -sbl
sub foo
{
if (!defined($_[0])) {
print("Hello, World\n");
}
else {
print($_[0], "\n");
}
}
Requested by Don Alexander.
-Fixed minor parsing error which prevented a space after a $$ variable
(pid) in some cases. Thanks to Michael Cartmell for noting this.
For example,
old: $$< 700
new: $$ < 700
-Improved line break choices 'and' and 'or' to display logic better.
For example:
OLD:
exists $self->{'build_dir'} and push @e,
"Unwrapped into directory $self->{'build_dir'}";
NEW:
exists $self->{'build_dir'}
and push @e, "Unwrapped into directory $self->{'build_dir'}";
-Fixed error of multiple use of abbreviatioin '-dsc'. -dsc remains
abbreviation for delete-side-comments; -dsm is new abbreviation for
delete-semicolons.
-Corrected and updated 'usage' help routine. Thanks to Slaven Rezic for
noting an error.
-The default for Windows is, for now, not to do a 'perl -c' syntax
check (but -syn will activate it). This is because of problems with
command.com. James Freeman sent me a patch which tries to get around
the problems, and it works in many cases, but testing revealed several
issues that still need to be resolved. So for now, the default is no
syntax check for Windows.
-I added a -T flag when doing perl -c syntax check.
This is because I test it on a large number of scripts from sources
unknown, and who knows what might be hidden in initialization blocks?
Also, deactivated the syntax check if perltidy is run as root. As a
benign example, running the previous version of perltidy on the
following file would cause it to disappear:
BEGIN{
print "Bye, bye baby!\n";
unlink $0;
}
The new version will not let that happen.
-I am contemplating (but have not yet implemented) making '-lp' the
default indentation, because it is stable now and may be closer to how
perl is commonly formatted. This could be in the next release. The
reason that '-lp' was not the original default is that the coding for
it was complex and not ready for the initial release of perltidy. If
anyone has any strong feelings about this, I'd like to hear. The
current default could always be recovered with the '-nlp' flag.
-html updates:
- sub definition names are now specially colored, red by default.
The letter 'm' is used to identify them.
- keyword 'sub' now has color of other keywords.
- restored html keyword color to __END__ and __DATA__, which was
accidentally removed in the previous version.
-A new -se (--standard-error-output) flag has been implemented and
documented which causes all errors to be written to standard output
instead of a .ERR file.
-A new -w (--warning-output) flag has been implemented and documented
which causes perltidy to output certain non-critical messages to the
error output file, .ERR. These include complaints about pod usage,
for example. The default is to not include these.
NOTE: This replaces an undocumented -w=0 or --warning-level flag
which was tentatively introduced in the previous version to avoid some
unwanted messages. The new default is the same as the old -w=0, so
that is no longer needed.
-Improved syntax checking and corrected tokenization of functions such
as rand, srand, sqrt, ... These can accept either an operator or a term
to their right. This has been corrected.
-Corrected tokenization of semicolon: testing of the previous update showed
that the semicolon in the following statement was being mis-tokenized. That
did no harm, other than adding an extra blank space, but has been corrected.
for (sort {strcoll($a,$b);} keys %investments) {
...
}
-New syntax check: after wasting 5 minutes trying to resolve a syntax
error in which I had an extra terminal ';' in a complex for (;;) statement,
I spent a few more minutes adding a check for this in perltidy so it won't
happen again.
-The behavior of --break-before-subs (-bbs) and --break-before-blocks
(-bbb) has been modified. Also, a new control parameter,
--long-block-line-count=n (-lbl=n) has been introduced to give more
control on -bbb. This was previously a hardwired value. The reason
for the change is to reduce the number of unwanted blank lines that
perltidy introduces, and make it less erratic. It's annoying to remove
an unwanted blank line and have perltidy put it back. The goal is to
be able to sprinkle a few blank lines in that dense script you
inherited from Bubba. I did a lot of experimenting with different
schemes for introducing blank lines before and after code blocks, and
decided that there is no really good way to do it. But I think the new
scheme is an improvement. You can always deactivate this with -nbbb.
I've been meaning to work on this; thanks to Erik Thaysen for bringing
it to my attention.
-The .LOG file is seldom needed, and I get tired of deleting them, so
they will now only be automatically saved if perltidy thinks that it
made an error, which is almost never. You can still force the logfile
to be saved with -log or -g.
-Improved method for computing number of columns in a table. The old
method always tried for an even number. The new method allows odd
numbers when it is obvious that a list is not a hash initialization
list.
old: my (
$name, $xsargs, $parobjs, $optypes,
$hasp2child, $pmcode, $hdrcode, $inplacecode,
$globalnew, $callcopy
)
= @_;
new: my (
$name, $xsargs, $parobjs, $optypes, $hasp2child,
$pmcode, $hdrcode, $inplacecode, $globalnew, $callcopy
)
= @_;
-I fiddled with the list threshold adjustment, and some small lists
look better now. Here is the change for one of the lists in test file
'sparse.t':
old:
%units =
("in", "in", "pt", "pt", "pc", "pi", "mm", "mm", "cm", "cm", "\\hsize", "%",
"\\vsize", "%", "\\textwidth", "%", "\\textheight", "%");
new:
%units = (
"in", "in", "pt", "pt", "pc", "pi",
"mm", "mm", "cm", "cm", "\\hsize", "%",
"\\vsize", "%", "\\textwidth", "%", "\\textheight", "%"
);
-Improved -lp formatting at '=' sign. A break was always being added after
the '=' sign in a statement such as this, (to be sure there was enough room
for the parameters):
old: my $fee =
CalcReserveFee(
$env, $borrnum,
$biblionumber, $constraint,
$bibitems
);
The updated version doesn't do this unless the space is really needed:
new: my $fee = CalcReserveFee(
$env, $borrnum,
$biblionumber, $constraint,
$bibitems
);
-I updated the tokenizer to allow $#+ and $#-, which seem to be new to
Perl 5.6. Some experimenting with a recent version of Perl indicated
that it allows these non-alphanumeric '$#' array maximum index
variables: $#: $#- $#+ so I updated the parser accordingly. Only $#:
seems to be valid in older versions of Perl.
-Fixed a rare formatting problem with -lp (and -gnu) which caused
excessive indentation.
-Many additional syntax checks have been added.
-Revised method for testing here-doc target strings; the following
was causing trouble with a regex test because of the '*' characters:
print <<"*EOF*";
bla bla
*EOF*
Perl seems to allow almost anything to be a here doc target, so an
exact string comparison is now used.
-Made update to allow underscores in binary numbers, like '0b1100_0000'.
-Corrected problem with scanning certain module names; a blank space was
being inserted after 'warnings' in the following:
use warnings::register;
The problem was that warnings (and a couple of other key modules) were
being tokenized as keywords. They should have just been identifiers.
-Corrected tokenization of indirect objects after sort, system, and exec,
after testing produced an incorrect error message for the following
line of code:
print sort $sortsubref @list;
-Corrected minor problem where a line after a format had unwanted
extra continuation indentation.
-Delete-block-comments (and -dac) now retain any leading hash-bang line
-Update for -lp (and -gnu) to not align the leading '=' of a list
with a previous '=', since this interferes with alignment of parameters.
old: my $hireDay = new Date;
my $self = {
firstName => undef,
lastName => undef,
hireDay => $hireDay
};
new: my $hireDay = new Date;
my $self = {
firstName => undef,
lastName => undef,
hireDay => $hireDay
};
-Modifications made to display tables more compactly when possible,
without adding lines. For example,
old:
'1', "I", '2', "II", '3', "III", '4', "IV",
'5', "V", '6', "VI", '7', "VII", '8', "VIII",
'9', "IX"
new:
'1', "I", '2', "II", '3', "III",
'4', "IV", '5', "V", '6', "VI",
'7', "VII", '8', "VIII", '9', "IX"
-Corrected minor bug in which -pt=2 did not keep the right paren tight
around a '++' or '--' token, like this:
for ($i = 0 ; $i < length $key ; $i++ )
The formatting for this should be, and now is:
for ($i = 0 ; $i < length $key ; $i++)
Thanks to Erik Thaysen for noting this.
-Discovered a new bug involving here-docs during testing! See BUGS.html.
-Finally fixed parsing of subroutine attributes (A Perl 5.6 feature).
However, the attributes and prototypes must still be on the same line
as the sub name.
-Corrected minor, uncommon bug found during routine testing, in which a
blank got inserted between a function name and its opening paren after
a file test operator, but only in the case that the function had not
been previously seen. Perl uses the existence (or lack thereof) of
the blank to guess if it is a function call. That is,
if (-l pid_filename()) {
became
if (-l pid_filename ()) {
which is a syntax error if pid_filename has not been seen by perl.
-If the AutoLoader module is used, perltidy will continue formatting
code after seeing an __END__ line. Use -nlal to deactivate this feature.
Likewise, if the SelfLoader module is used, perltidy will continue
formatting code after seeing a __DATA__ line. Use -nlsl to
deactivate this feature. Thanks to Slaven Rezic for this suggestion.
-pod text after __END__ and __DATA__ is now identified by perltidy
so that -dp works correctly. Thanks to Slaven Rezic for this suggestion.
-The first $VERSION line which might be eval'd by MakeMaker
is now passed through unchanged. Use -npvl to deactivate this feature.
Thanks to Manfred Winter for this suggestion.
-Improved indentation of nested parenthesized expressions. Tests have
given favorable results. Thanks to Wolfgang Weisselberg for helpful
examples.
-Fixed a very rare problem in which an unwanted semicolon was inserted
due to misidentification of anonymous hash reference curly as a code
block curly. (No instances of this have been reported; I discovered it
during testing). A workaround for older versions of perltidy is to use
-nasc.
-Added -icb (-indent-closing-brace) parameter to indent a brace which
terminates a code block to the same level as the previous line.
Suggested by Andrew Cutler. For example,
if ($task) {
yyy();
} # -icb
else {
zzz();
}
-Rewrote error message triggered by an unknown bareword in a print or
printf filehandle position, and added flag -w=0 to prevent issuing this
error message. Suggested by Byron Jones.
-Added modification to align a one-line 'if' block with similar
following 'elsif' one-line blocks, like this:
if ( $something eq "simple" ) { &handle_simple }
elsif ( $something eq "hard" ) { &handle_hard }
(Suggested by Wolfgang Weisselberg).
-Eliminated all constants with leading underscores because perl 5.005_03
does not support that. For example, _SPACES changed to XX_SPACES.
Thanks to kromJx for this update.
-the directory of test files has been moved to a separate distribution
file because it is getting large but is of little interest to most users.
For the current distribution:
perltidy-20010701.tgz contains the source and docs for perltidy
perltidy-20010701-test.tgz contains the test files
-fixed bug where temporary file perltidy.TMPI was not being deleted
when input was from stdin.
-adjusted line break logic to not break after closing brace of an
eval block (suggested by Boris Zentner).
-added flag -gnu (--gnu-style) to give an approximation to the GNU
style as sometimes applied to perl. The programming style in GNU
'automake' was used as a guide in setting the parameters; these
parameters will probably be adjusted over time.
-an empty code block now has one space for emphasis:
if ( $cmd eq "bg_untested" ) {} # old
if ( $cmd eq "bg_untested" ) { } # new
If this bothers anyone, we could create a parameter.
-the -bt (--brace-tightness) parameter has been split into two
parameters to give more control. -bt now applies only to non-BLOCK
braces, while a new parameter -bbt (block-brace-tightness) applies to
curly braces which contain code BLOCKS. The default value is -bbt=0.
-added flag -icp (--indent-closing-paren) which leaves a statement
termination of the form );, };, or ]; indented with the same
indentation as the previous line. For example,
@month_of_year = ( # default, or -nicp
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
'Nov', 'Dec'
);
@month_of_year = ( # -icp
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
'Nov', 'Dec'
);
-Vertical alignment updated to synchronize with tokens &&, ||,
and, or, if, unless. Allowable space before forcing
resynchronization has been increased. (Suggested by Wolfgang
Weisselberg).
-html corrected to use -nohtml-bold-xxxxxxx or -nhbx to negate bold,
and likewise -nohtml-italic-xxxxxxx or -nhbi to negate italic. There
was no way to negate these previously. html documentation updated and
corrected. (Suggested by Wolfgang Weisselberg).
-Some modifications have been made which improve the -lp formatting in
a few cases.
-Perltidy now retains or creates a blank line after an =cut to keep
podchecker happy (Suggested by Manfred H. Winter). This appears to be
a glitch in podchecker, but it was annoying.
-Added -bli flag to give continuation indentation to braces, like this
if ($bli_flag)
{
extra_indentation();
}
-Corrected an error with the tab (-t) option which caused the last line
of a multi-line quote to receive a leading tab. This error was in
version 2001 06 08 but not 2001 04 06. If you formatted a script
with -t with this version, please check it by running once with the
-chk flag and perltidy will scan for this possible error.
-Corrected an invalid pattern (\R should have been just R), changed
$^W =1 to BEGIN {$^W=1} to use warnings in compile phase, and corrected
several unnecessary 'my' declarations. Many thanks to Wolfgang Weisselberg,
2001-06-12, for catching these errors.
-A '-bar' flag has been added to require braces to always be on the
right, even for multi-line if and foreach statements. For example,
the default formatting of a long if statement would be:
if ($bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4)
{
bigwastoftime();
}
With -bar, the formatting is:
if ($bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4) {
bigwastoftime();
}
Suggested by Eli Fidler 2001-06-11.
-Uploaded perltidy to sourceforge cvs 2001-06-10.
-An '-lp' flag (--line-up-parentheses) has been added which causes lists
to be indented with extra indentation in the manner sometimes
associated with emacs or the GNU suggestions. Thanks to Ian Stuart for
this suggestion and for extensive help in testing it.
-Subroutine call parameter lists are now formatted as other lists.
This should improve formatting of tables being passed via subroutine
calls. This will also cause full indentation ('-i=n, default n= 4) of
continued parameter list lines rather than just the number of spaces
given with -ci=n, default n=2.
-Added support for hanging side comments. Perltidy identifies a hanging
side comment as a comment immediately following a line with a side
comment or another hanging side comment. This should work in most
cases. It can be deactivated with --no-hanging-side-comments (-nhsc).
The manual has been updated to discuss this. Suggested by Brad
Eisenberg some time ago, and finally implemented.
-fixed problem with parsing command parameters containing quoted
strings in .perltidyrc files. (Reported by Roger Espel Llima 2001-06-07).
-added two command line flags, --want-break-after and
--want-break-before, which allow changing whether perltidy
breaks lines before or after any operators. Please see the revised
man pages for details.
-added system-wide configuration file capability.
If perltidy does not find a .perltidyrc command line file in
the current directory, nor in the home directory, it now looks
for '/usr/local/etc/perltidyrc' and then for '/etc/perltidyrc'.
(Suggested by Roger Espel Llima 2001-05-31).
-fixed problem in which spaces were trimmed from lines of a multi-line
quote. (Reported by Roger Espel Llima 2001-05-30). This is an
uncommon situation, but serious, because it could conceivably change
the proper function of a script.
-fixed problem in which a semicolon was incorrectly added within
an anonymous hash. (Reported by A.C. Yardley, 2001-5-23).
(You would know if this happened, because perl would give a syntax
error for the resulting script).
-fixed problem in which an incorrect error message was produced
after a version number on a 'use' line, like this ( Reported
by Andres Kroonmaa, 2001-5-14):
use CGI 2.42 qw(fatalsToBrowser);
Other than the extraneous error message, this bug was harmless.
-fixed serious bug in which the last line of some multi-line quotes or
patterns was given continuation indentation spaces. This may make
a pattern incorrect unless it uses the /x modifier. To find
instances of this error in scripts which have been formatted with
earlier versions of perltidy, run with the -chk flag, which has
been added for this purpose (SLH, 2001-04-05).
** So, please check previously formatted scripts by running with -chk
at least once **
-continuation indentation has been reprogrammed to be hierarchical,
which improves deeply nested structures.
-fixed problem with undefined value in list formatting (reported by Michael
Langner 2001-04-05)
-Switched to graphical display of nesting in .LOG files. If an
old format string was "(1 [0 {2", the new string is "{{(". This
is easier to read and also shows the order of nesting.
-added outdenting of cuddled paren structures, like ")->pack(".
-added line break and outdenting of ')->' so that instead of
$mw->Label(
-text => "perltidy",
-relief => 'ridge')->pack;
the current default is:
$mw->Label(
-text => "perltidy",
-relief => 'ridge'
)->pack;
(requested by Michael Langner 2001-03-31; in the future this could
be controlled by a command-line parameter).
-revised list indentation logic, so that lists following an assignment
operator get one full indentation level, rather than just continuation
indentation. Also corrected some minor glitches in the continuation
indentation logic.
-Fixed problem with unwanted continuation indentation after a blank line
(reported by Erik Thaysen 2001-03-28):
-minor update to avoid stranding a single '(' on one line
-corrected serious error tokenizing filehandles, in which a sub call
after a print or printf, like this:
print usage() and exit;
became this:
print usage () and exit;
Unfortunately, this converts 'usage' to a filehandle. To fix this, rerun
perltidy; it will look for this situation and issue a warning.
-fixed another cuddled-else formatting bug (Reported by Craig Bourne)
-added several diagnostic --dump routines
-added token-level whitespace controls (suggested by Hans Ecke)
-added support for special variables of the form ${^WANT_BITS}
-space added between scalar and left paren in 'for' and 'foreach' loops,
(suggestion by Michael Cartmell):
for $i( 1 .. 20 ) # old
for $i ( 1 .. 20 ) # new
-html now outputs cascading style sheets (thanks to suggestion from
Hans Ecke)
-flags -o and -st now work with -html
-added missing -html documentation for comments (noted by Alex Izvorski)
-support for VMS added (thanks to Michael Cartmell for code patches and
testing)
-v-strings implemented (noted by Hans Ecke and Michael Cartmell; extensive
testing by Michael Cartmell)
-fixed problem where operand may be empty at line 3970
(\b should be just b in lines 3970, 3973) (Thanks to Erik Thaysen,
Keith Marshall for bug reports)
-fixed -ce bug (cuddled else), where lines like '} else {' were indented
(Thanks to Shawn Stepper and Rick Measham for reporting this)
-fixed undefined value in line 153 (only worked with -I set)
(Thanks to Mike Stok, Phantom of the Opcodes, Ian Ehrenwald, and others)
-fixed undefined value in line 1069 (filehandle problem with perl versions <
5.6) (Thanks to Yuri Leikind, Mike Stok, Michael Holve, Jeff Kolber)
-Initial announcement at freshmeat.net; started Change Log
(Unfortunately this version was DOA, but it was fixed the next day)
Perltidy can save you a lot of tedious editing if you spend a few minutes learning to use it effectively. Perltidy is highly configurable, but for many programmers the default parameter set will be satisfactory, with perhaps a few additional parameters to account for style preferences.
This tutorial assumes that perltidy has been installed on your system. Installation instructions accompany the package. To follow along with this tutorial, please find a small Perl script and place a copy in a temporary directory. For example, here is a small (and silly) script:
print "Help Desk -- What Editor do you use?";
chomp($editor = <STDIN>);
if ($editor =~ /emacs/i) {
print "Why aren't you using vi?\n";
} elsif ($editor =~ /vi/i) {
print "Why aren't you using emacs?\n";
} else {
print "I think that's the problem\n";
}It is included in the docs section of the distribution.
Assume that the name of your script is testfile.pl. You can reformat it with the default options to use the style recommended in the perlstyle man pages with the command:
perltidy testfile.plFor safety, perltidy never overwrites your original file. In this case, its output will go to a file named testfile.pl.tdy, which you should examine now with your editor. Here is what the above file looks like with the default options:
print "Help Desk -- What Editor do you use?";
chomp( $editor = <STDIN> );
if ( $editor =~ /emacs/i ) {
print "Why aren't you using vi?\n";
}
elsif ( $editor =~ /vi/i ) {
print "Why aren't you using emacs?\n";
}
else {
print "I think that's the problem\n";
}You'll notice an immediate style change from the "cuddled-else" style of the original to the default "non-cuddled-else" style. This is because perltidy has to make some kind of default selection of formatting options, and this default tries to follow the suggestions in the perlstyle man pages.
If you prefer the original "cuddled-else" style, don't worry, you can indicate that with a -ce flag. So if you rerun with that flag
perltidy -ce testfile.plyou will see a return to the original "cuddled-else" style. There are many more parameters for controlling style, and some of the most useful of these are discussed below.
Another noticeable difference between the original and the reformatted file is that the indentation has been changed from 2 spaces to 4 spaces. That's because 4 spaces is the default. You may change this to be a different number with -i=n.
To get some practice, try these examples, and examine the resulting testfile.pl.tdy file:
perltidy -i=8 testfile.plThis changes the default of 4 spaces per indentation level to be 8. Now just to emphasize the point, try this and examine the result:
perltidy -i=0 testfile.plThere will be no indentation at all in this case.
This is a good place to mention a few points regarding the input flags. First, for each option, there are two forms, a long form and a short form, and either may be used.
For example, if you want to change the number of columns corresponding to one indentation level to 3 (from the default of 4) you may use either
-i=3 or --indent-columns=3The short forms are convenient for entering parameters by hand, whereas the long forms, though often ridiculously long, are self-documenting and therefore useful in configuration scripts. You may use either one or two dashes ahead of the parameters. Also, the '=' sign is optional, and may be a single space instead. However, the value of a parameter must NOT be adjacent to the flag, like this -i3 (WRONG). Also, flags must be input separately, never bundled together.
If you change the indentation spaces you will probably also need to change the continuation indentation spaces with the parameter -ci=n. The continuation indentation is the extra indentation -- 2 spaces by default -- given to that portion of a long line which has been placed below the start of a statement. For example:
croak "Couldn't pop genome file"
unless sysread( $impl->{file}, $element, $impl->{group} )
and truncate( $impl->{file}, $new_end );It works well to use a value n equal to one-half the number of spaces to a full indentation level. If it is set equal to the full indentation level, then formatting will be improved by also setting --extended-continuation-indentation, or -xci. The manual has some examples.
In the above snippet, the statement was broken into three lines. The actual number is governed by a parameter, the maximum line length, as well as by what perltidy considers to be good break points. The maximum line length is 80 characters by default. You can change this to be any number n with the -l=n flag. Perltidy tries to produce lines which do not exceed this length, and it does this by finding good break points. For example, the above snippet would look like this with perltidy -l=40:
croak "Couldn't pop genome file"
unless
sysread( $impl->{file}, $element,
$impl->{group} )
and
truncate( $impl->{file}, $new_end );You may be wondering what would happen with, say, -l=1. Go ahead and try it.
With indentation, there is always a tab issue to resolve. By default, perltidy will use leading ascii space characters instead of tabs. The reason is that this will be displayed correctly by virtually all editors, and in the long run, will avoid maintenance problems.
However, if you prefer, you may have perltidy entab the leading whitespace of a line with the command -et=n, where n is the number of spaces which will be represented by one tab. But note that your text will not be displayed properly unless viewed with software that is configured to display n spaces per tab.
In the first example, we saw that if we pass perltidy the name of a file on the command line, it reformats it and creates a new filename by appending an extension, .tdy. This is the default behavior, but there are several other options.
On most systems, you may use wildcards to reformat a whole batch of files at once, like this for example:
perltidy *.pland in this case, each of the output files will be have a name equal to the input file with the extension .tdy appended. If you decide that the formatting is acceptable, you will want to backup your originals and then remove the .tdy extensions from the reformatted files. There is a powerful perl script called rename that can be used for this purpose; if you don't have it, you can find it for example in The Perl Cookbook.
If you find that the formatting done by perltidy is usually acceptable, you may want to save some effort by letting perltidy do a simple backup of the original files and then reformat them in place. You specify this with a -b flag. For example, the command
perltidy -b *.plwill rename the original files by appending a .bak extension, and then create reformatted files with the same names as the originals. (If you don't like the default backup extension choice .bak, the manual tells how to change it). Each time you run perltidy with the -b option, the previous .bak files will be overwritten, so please make regular separate backups.
If there is no input filename specified on the command line, then input is assumed to come from standard input and output will go to standard output. On systems with a Unix-like interface, you can use perltidy as a filter, like this:
perltidy <somefile.pl >newfile.plWhat happens in this case is that the shell takes care of the redirected input files, '<somefile.pl', and so perltidy never sees the filename. Therefore, it knows to use the standard input and standard output channels.
If you ever find that you enter perltidy and nothing seems to happen, it could be that you did not give it source to work on. So in that case it is waiting for input from the standard input, which is probably the keyboard.
If you are executing perltidy on a file and want to force the output to standard output, rather than create a .tdy file, you can indicate this with the flag -st, like this:
perltidy somefile.pl -st >otherfile.plIf you just enter
You can also control the name of the output file with the -o flag, like this:
perltidy testfile.pl -o=testfile.new.plPerltidy has to make some kind of default selection of formatting options, and its choice is to try to follow the suggestions in the perlstyle man pages. The default parameter settings will produce quite readable code, and should be sufficient for many purposes. Many programmers more or less follow these suggestions with a few exceptions. In this section we will look at just a few of the most commonly used style parameters. Later, you may want to systematically develop a set of style parameters with the help of the perltidy stylekey web page at http://perltidy.sourceforge.net/stylekey.html
If you prefer cuddled elses, use the -ce flag.
Here is what the if block in the above script looks like with -bl:
if ( $editor =~ /emacs/i )
{
print "Why aren't you using vi?\n";
}
elsif ( $editor =~ /vi/i )
{
print "Why aren't you using emacs?\n";
}
else
{
print "I think that's the problem\n";
}These are parameters for controlling the amount of space within containing parentheses, braces, and square brackets. The example below shows the effect of the three possible values, 0, 1, and 2, for the case of parentheses:
if ( ( my $len_tab = length( $tabstr ) ) > 0 ) { # -pt=0
if ( ( my $len_tab = length($tabstr) ) > 0 ) { # -pt=1 (default)
if ((my $len_tab = length($tabstr)) > 0) { # -pt=2A value of 0 causes all parens to be padded on the inside with a space, and a value of 2 causes this never to happen. With a value of 1, spaces will be introduced if the item within is more than a single token.
While style preferences vary, most people would agree that it is important to maintain a uniform style within a script, and this is a major benefit provided by perltidy. Once you have decided on which, if any, special options you prefer, you may want to avoid having to enter them each time you run it. You can do this by creating a special file named .perltidyrc in either your home directory, your current directory, or certain system-dependent locations. (Note the leading "." in the file name).
A handy command to know when you start using a configuration file is
perltidy -dprowhich will dump to standard output the search that perltidy makes when looking for a configuration file, and the contents of the one that it selects, if any. This is one of a number of useful "dump and die" commands, in which perltidy will dump some information to standard output and then immediately exit. Others include -h, which dumps help information, and -v, which dumps the version number.
Another useful command when working with configuration files is
perltidy -pro=filewhich causes the contents of file to be used as the configuration file instead of a .perltidyrc file. With this command, you can easily switch among several different candidate configuration files during testing.
This .perltidyrc file is free format. It is simply a list of parameters, just as they would be entered on a command line. Any number of lines may be used, with any number of parameters per line, although it may be easiest to read with one parameter per line. Blank lines are ignored, and text after a '#' is ignored to the end of a line.
Here is an example of a .perltidyrc file:
# This is a simple of a .perltidyrc configuration file
# This implements a highly spaced style
-bl # braces on new lines
-pt=0 # parens not tight at all
-bt=0 # braces not tight
-sbt=0 # square brackets not tightIf you experiment with this file, remember that it is in your directory, since if you are running on a Unix system, files beginning with a "." are normally hidden.
If you have a .perltidyrc file, and want perltidy to ignore it, use the -npro flag on the command line.
Let's run through a 'fire drill' to see how perltidy reports errors. Try introducing an extra opening brace somewhere in a test file. For example, introducing an extra brace in the file listed above produces the following message on the terminal (or standard error output):
## Please see file testfile.pl.ERR!Here is what testfile.pl.ERR contains:
10: final indentation level: 1
Final nesting depth of '{'s is 1
The most recent un-matched '{' is on line 6
6: } elsif ($temperature < 68) {{
^This shows how perltidy will, by default, write error messages to a file with the extension .ERR, and it will write a note that it did so to the standard error device. If you would prefer to have the error messages sent to standard output, instead of to a .ERR file, use the -se flag.
Almost every programmer would want to see error messages of this type, but there are a number of messages which, if reported, would be annoying. To manage this problem, perltidy puts its messages into two categories: errors and warnings. The default is to just report the errors, but you can control this with input flags, as follows:
flag what this does
---- --------------
default: report errors but not warnings
-w report all errors and warnings
-q quiet! do not report either errors or warningsThe default is generally a good choice, but it's not a bad idea to check programs with -w occasionally, especially if your are looking for a bug. For example, it will ask if you really want '=' instead of '=~' in this line:
$line = s/^\s*//;This kind of error can otherwise be hard to find.
Most programmer's editors allow a selected group of lines to be passed through an external filter. Perltidy has been designed to work well as a filter, and it is well worthwhile learning the appropriate commands to do this with your editor. This means that you can enter a few keystrokes and watch a block of text get reformatted. If you are not doing this, you are missing out of a lot of fun! You may want to supply the -q flag to prevent error messages regarding incorrect syntax, since errors may be obvious in the indentation of the reformatted text. This is entirely optional, but if you do not use the -q flag, you will need to use the undo keys in case an error message appears on the screen.
For example, within the vim editor it is only necessary to select the text by any of the text selection methods, and then issue the command !perltidy in command mode. Thus, an entire file can be formatted using
:%!perltidy -qor, without the -q flag, just
:%!perltidyIt isn't necessary to format an entire file, however. Perltidy will probably work well as long as you select blocks of text whose braces, parentheses, and square brackets are properly balanced. You can even format an elsif block without the leading if block, as long as the text you select has all braces balanced.
For the emacs editor, first mark a region and then pipe it through perltidy. For example, to format an entire file, select it with C-x h and then pipe it with M-1 M-| and then perltidy. The numeric argument, M-1 causes the output from perltidy to replace the marked text. See "GNU Emacs Manual" for more information, http://www.gnu.org/manual/emacs-20.3/html_node/emacs_toc.html
If you have difficulty with an editor, try the -st flag, which will force perltidy to send output to standard output. This might be needed, for example, if the editor passes text to perltidy as temporary filename instead of through the standard input. If this works, you might put the -st flag in your .perltidyrc file.
After you get your editor and perltidy successfully talking to each other, try formatting a snippet of code with a brace error to see what happens. (Do not use the quiet flag, -q, for this test). Perltidy will send one line starting with ## to standard error output. Your editor may either display it at the top of the reformatted text or at the bottom (or even midstream!). You probably cannot control this, and perltidy can't, but you need to know where to look when an actual error is detected.
In the following example, the return list of five values has been automatically formatted over two lines:
my (
$rinput_string, $is_encoded_data, $decoded_input_as,
$encoding_log_message, $length_function,
) = $self->get_decoded_string_buffer($input_file);As a general rule, if there are no blank lines or comments between the opening and closing parens, as in this example, perltidy will use an automated rule to set line breaks. Otherwise, it will keep the line breaks unchanged. So by inserting a blank line somewhere within a list we can 'freeze' the line breaks to be the way we would like.
For example, here is the above list with a line break at every comma, and with a blank line to prevent perltidy from changing it:
my (
$rinput_string,
$is_encoded_data,
$decoded_input_as,
$encoding_log_message,
$length_function,
) = $self->get_decoded_string_buffer($input_file);An easy way to switch to a single column list such as this is to select the list from within an editor and reformat with with --maximum-fields-per-table=1, or -mft=1. This will format the list in a single column. Then insert a blank line to keep this format.
Vertical alignment refers to the insertion of blank spaces to align tokens which successive lines have in common, such as the = here:
my $self = shift;
my $debug_file = $self->{_debug_file};
my $is_encoded_data = $self->{_is_encoded_data};Vertical alignment is automatic unless it has been deactivated by one of its controls, but it always stops and tries to restart at blank lines. So a blank line can be inserted to stop an unwanted alignment. So, for example, we can can insert a blank line to break the alignment in the above example like this:
my $self = shift;
my $debug_file = $self->{_debug_file};
my $is_encoded_data = $self->{_is_encoded_data};To have perltidy leave existing formatting unchanged, surround the lines to be skipped with special comments like this:
#<<<
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>A related comment control is --code-skipping, indicated with '#<<V>. and '#>>V>', which simply passes lines of code to the output without tokenization. This is useful for some extended syntaxes. Another is --non-indenting-braces, indicated by placing a side comment '#<<<' following a block brace, which prevents code within the marked braces from getting an extra level indentation. This is useful if we want to put braces around code and want to minimize the changes in formatting.
Perltidy has several parameters which can assist in locating problems in code. One of these is -dump-unusual-variables, or -duv. It will scan a file and produce a list of unused, reused, and certain other lexical variables of interest. To use it to analyze a file named testfile.pl enter:
perltidy -duv testfile.pl >tmp.txtThe information will be dumped to the standard output, tmp.txt in this example, and perltidy will exit without formatting the file. The lines of output identify four types of issues, namely
u: unused variables
r: reused variable name in same scope
s: sigil change but reused bareword, such as %file and $file
p: package-crossing variables: a variable with scope in multiple packagesThese issues, although not errors, can be worth reviewing, especially for new code. Other parameters which can be useful when reviewing code are --warn-missing-else and --dump-block-summary. The manual has further information.
Perltidy can switch between two different output modes. We have been discussing what might be called its "beautifier" mode, but it can also output in HTML. To do this, use the -html flag, like this:
perltidy -html testfile.plwhich will produce a file testfile.pl.html. There are many parameters available for adjusting the appearance of an HTML file, but a very easy way is to just write the HTML file with this simple command and then edit the stylesheet which is embedded at its top.
One important thing to know about the -html flag is that perltidy can either send its output to its beautifier or to its HTML writer, but not both in a single run. So the situation can be represented like this:
------------
| | --->beautifier--> testfile.pl.tdy
testfile.pl --> | perltidy | -->
| | --->HTML -------> testfile.pl.html
------------So if you would like to both beautify a script and write it to HTML, you need to do it in two steps.
That's enough to get started using perltidy. When you are ready to create a .perltidyrc file, you may find it helpful to use the stylekey page as a guide at http://perltidy.sourceforge.net/stylekey.html
We hope that perltidy makes perl programming a little more fun.
Further documentation can be found at the web site at GitHub or at Sourceforge or at metacpan
Issues can be reported at GitHub
Perl-Tidy-20250105/META.yml 0000664 0001750 0001750 00000001273 14735777217 014123 0 ustar steve steve --- abstract: 'indent and reformat perl scripts' author: - 'Steve Hancock. For
another example, let's write a program which checks for one of the
so-called I C<&`>, C<$&>, and C<$'>, which
can slow down processing. Here is a B, from the example
program B, which does that:
sub write_line {
# This is called back from perltidy line-by-line
# We're looking for $`, $&, and $'
my ( $self, $line_of_tokens ) = @_;
# pull out some stuff we might need
my $line_type = $line_of_tokens->{_line_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $input_line = $line_of_tokens->{_line_text};
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
chomp $input_line;
# skip comments, pod, etc
return if ( $line_type ne 'CODE' );
# loop over tokens looking for $`, $&, and $'
for ( my $j = 0 ; $j < @$rtoken_type ; $j++ ) {
# we only want to examine token types 'i' (identifier)
next unless $$rtoken_type[$j] eq 'i';
# pull out the actual token text
my $token = $$rtokens[$j];
# and check it
if ( $token =~ /^\$[\`\&\']$/ ) {
print STDERR
"$input_line_number: $token\n";
}
}
}
This example pulls out these tokenization variables from the $line_of_tokens
hash reference:
$rtoken_type = $line_of_tokens->{_rtoken_type};
$rtokens = $line_of_tokens->{_rtokens};
The variable C<$rtoken_type> is a reference to an array of token type codes,
and C<$rtokens> is a reference to a corresponding array of token text.
These are obviously only defined for lines of type B.
Perltidy classifies tokens into types, and has a brief code for each type.
You can get a complete list at any time by running perltidy from the
command line with
perltidy --dump-token-types
In the present example, we are only looking for tokens of type B
(identifiers), so the for loop skips past all other types. When an
identifier is found, its actual text is checked to see if it is one
being sought. If so, the above write_line prints the token and its
line number.
The B section of the source distribution has some examples of programs which use the B option.
For help with perltidy's peculiar way of breaking lines into tokens, you
might run, from the command line,
perltidy -D filename
where F is a short script of interest. This will produce
F with interleaved lines of text and their token types.
The B<-D> flag has been in perltidy from the beginning for this purpose.
If you want to see the code which creates this file, it is
C
=head1 EXPORT
&perltidy
=head1 INSTALLATION
The module 'Perl::Tidy' comes with a binary 'perltidy' which is installed when the module is installed. The module name is case-sensitive. For example, the basic command for installing with cpanm is 'cpanm Perl::Tidy'.
=head1 VERSION
This man page documents Perl::Tidy version 20250105
=head1 LICENSE
This package is free software; you can redistribute it and/or modify it
under the terms of the "GNU General Public License".
Please refer to the file "COPYING" for details.
=head1 BUG REPORTS
The source code repository is at L.
To report a new bug or problem, use the "issues" link on this page.
=head1 SEE ALSO
The perltidy(1) man page describes all of the features of perltidy. It
can be found at http://perltidy.sourceforge.net.
=cut
Perl-Tidy-20250105/lib/Perl/Tidy/ 0002755 0001750 0001750 00000000000 14735777217 015230 5 ustar steve steve Perl-Tidy-20250105/lib/Perl/Tidy/Logger.pm 0000644 0001750 0001750 00000041657 14735302777 017013 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Logger class writes any .LOG and .ERR files
# and supplies some basic run information for error handling.
#
#####################################################################
package Perl::Tidy::Logger;
use strict;
use warnings;
our $VERSION = '20250105';
use Carp;
use English qw( -no_match_vars );
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < 50;
sub new {
my ( $class, @arglist ) = @_;
if ( @arglist % 2 ) { croak "Odd number of items in arg hash list\n" }
my %defaults = (
rOpts => undef,
log_file => undef,
warning_file => undef,
fh_stderr => undef,
display_name => undef,
is_encoded_data => undef,
);
my %args = ( %defaults, @arglist );
my $rOpts = $args{rOpts};
my $log_file = $args{log_file};
my $warning_file = $args{warning_file};
my $fh_stderr = $args{fh_stderr};
my $display_name = $args{display_name};
my $is_encoded_data = $args{is_encoded_data};
my $fh_warnings = $rOpts->{'standard-error-output'} ? $fh_stderr : undef;
# remove any old error output file if we might write a new one
if ( !$fh_warnings && !ref($warning_file) ) {
if ( -e $warning_file ) {
unlink($warning_file)
or Perl::Tidy::Die(
"couldn't unlink warning file $warning_file: $OS_ERROR\n");
}
}
my $logfile_gap =
defined( $rOpts->{'logfile-gap'} )
? $rOpts->{'logfile-gap'}
: DEFAULT_LOGFILE_GAP;
if ( $logfile_gap == 0 ) { $logfile_gap = 1 }
my $filename_stamp = $display_name ? $display_name . ':' : "??";
my $input_stream_name = $display_name ? $display_name : "??";
return bless {
_log_file => $log_file,
_logfile_gap => $logfile_gap,
_rOpts => $rOpts,
_fh_warnings => $fh_warnings,
_last_input_line_written => 0,
_last_input_line_number => undef,
_at_end_of_file => 0,
_use_prefix => 1,
_block_log_output => 0,
_line_of_tokens => undef,
_output_line_number => undef,
_wrote_line_information_string => 0,
_wrote_column_headings => 0,
_warning_file => $warning_file,
_warning_count => 0,
_complaint_count => 0,
_is_encoded_data => $is_encoded_data,
_saw_code_bug => -1, # -1=no 0=maybe 1=for sure
_saw_brace_error => 0,
_output_array => [],
_input_stream_name => $input_stream_name,
_filename_stamp => $filename_stamp,
_save_logfile => $rOpts->{'logfile'},
}, $class;
} ## end sub new
sub get_input_stream_name {
my $self = shift;
return $self->{_input_stream_name};
}
sub set_last_input_line_number {
my ( $self, $lno ) = @_;
$self->{_last_input_line_number} = $lno;
return;
}
sub get_warning_count {
my $self = shift;
return $self->{_warning_count};
}
sub get_use_prefix {
my $self = shift;
return $self->{_use_prefix};
}
sub block_log_output {
my $self = shift;
$self->{_block_log_output} = 1;
return;
}
sub unblock_log_output {
my $self = shift;
$self->{_block_log_output} = 0;
return;
}
sub interrupt_logfile {
my $self = shift;
$self->{_use_prefix} = 0;
$self->warning("\n");
$self->write_logfile_entry( '#' x 24 . " WARNING " . '#' x 25 . "\n" );
return;
} ## end sub interrupt_logfile
sub resume_logfile {
my $self = shift;
$self->write_logfile_entry( '#' x 60 . "\n" );
$self->{_use_prefix} = 1;
return;
} ## end sub resume_logfile
sub we_are_at_the_last_line {
my $self = shift;
if ( !$self->{_wrote_line_information_string} ) {
$self->write_logfile_entry("Last line\n\n");
}
$self->{_at_end_of_file} = 1;
return;
} ## end sub we_are_at_the_last_line
# record some stuff in case we go down in flames
use constant MAX_PRINTED_CHARS => 35;
sub black_box {
my ( $self, $line_of_tokens, $output_line_number ) = @_;
# This routine saves information comparing the indentation of input
# and output lines when a detailed logfile is requested.
# This was very useful during the initial development of perltidy.
my $input_line = $line_of_tokens->{_line_text};
my $input_line_number = $line_of_tokens->{_line_number};
$self->{_line_of_tokens} = $line_of_tokens;
$self->{_output_line_number} = $output_line_number;
$self->{_wrote_line_information_string} = 0;
my $last_input_line_written = $self->{_last_input_line_written};
if (
(
( $input_line_number - $last_input_line_written ) >=
$self->{_logfile_gap}
)
|| ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ )
)
{
my $structural_indentation_level = $line_of_tokens->{_level_0};
$structural_indentation_level = 0
if ( $structural_indentation_level < 0 );
$self->{_last_input_line_written} = $input_line_number;
( my $out_str = $input_line ) =~ s/^\s+//;
chomp $out_str;
$out_str = ( '.' x $structural_indentation_level ) . $out_str;
if ( length($out_str) > MAX_PRINTED_CHARS ) {
$out_str = substr( $out_str, 0, MAX_PRINTED_CHARS ) . " ....";
}
$self->logfile_output( EMPTY_STRING, "$out_str\n" );
}
return;
} ## end sub black_box
sub write_logfile_entry {
my ( $self, @msg ) = @_;
# add leading >>> to avoid confusing error messages and code
$self->logfile_output( ">>>", "@msg" );
return;
} ## end sub write_logfile_entry
sub write_column_headings {
my $self = shift;
$self->{_wrote_column_headings} = 1;
my $routput_array = $self->{_output_array};
push @{$routput_array}, <>>)
lines levels i k (code begins with one '.' per indent level)
------ ----- - - -------- -------------------------------------------
EOM
return;
} ## end sub write_column_headings
sub make_line_information_string {
# make columns of information when a logfile message needs to go out
my $self = shift;
my $line_of_tokens = $self->{_line_of_tokens};
my $input_line_number = $line_of_tokens->{_line_number};
my $line_information_string = EMPTY_STRING;
if ($input_line_number) {
my $output_line_number = $self->{_output_line_number};
my $brace_depth = $line_of_tokens->{_curly_brace_depth};
my $paren_depth = $line_of_tokens->{_paren_depth};
my $square_bracket_depth = $line_of_tokens->{_square_bracket_depth};
my $guessed_indentation_level =
$line_of_tokens->{_guessed_indentation_level};
my $structural_indentation_level = $line_of_tokens->{_level_0};
$self->write_column_headings() unless $self->{_wrote_column_headings};
# keep logfile columns aligned for scripts up to 999 lines;
# for longer scripts it doesn't really matter
my $extra_space = EMPTY_STRING;
$extra_space .=
( $input_line_number < 10 ) ? SPACE x 2
: ( $input_line_number < 100 ) ? SPACE
: EMPTY_STRING;
$extra_space .=
( $output_line_number < 10 ) ? SPACE x 2
: ( $output_line_number < 100 ) ? SPACE
: EMPTY_STRING;
# there are 2 possible nesting strings:
# the original which looks like this: (0 [1 {2
# the new one, which looks like this: {{[
# the new one is easier to read, and shows the order, but
# could be arbitrarily long, so we use it unless it is too long
my $nesting_string =
"($paren_depth [$square_bracket_depth {$brace_depth";
my $nesting_string_new = $line_of_tokens->{_nesting_tokens_0};
my $ci_level = $line_of_tokens->{_ci_level_0};
if ( $ci_level > 9 ) { $ci_level = '*' }
my $bk = ( $line_of_tokens->{_nesting_blocks_0} =~ /1$/ ) ? '1' : '0';
if ( length($nesting_string_new) <= 8 ) {
$nesting_string =
$nesting_string_new . SPACE x ( 8 - length($nesting_string_new) );
}
$line_information_string =
"L$input_line_number:$output_line_number$extra_space i$guessed_indentation_level:$structural_indentation_level $ci_level $bk $nesting_string";
}
return $line_information_string;
} ## end sub make_line_information_string
sub logfile_output {
my ( $self, $prompt, $msg ) = @_;
return if ( $self->{_block_log_output} );
my $routput_array = $self->{_output_array};
if ( $self->{_at_end_of_file} || !$self->{_use_prefix} ) {
push @{$routput_array}, "$msg";
}
else {
my $line_information_string = $self->make_line_information_string();
$self->{_wrote_line_information_string} = 1;
if ($line_information_string) {
push @{$routput_array}, "$line_information_string $prompt$msg";
}
else {
push @{$routput_array}, "$msg";
}
}
return;
} ## end sub logfile_output
sub get_saw_brace_error {
my $self = shift;
return $self->{_saw_brace_error};
}
sub increment_brace_error {
my $self = shift;
$self->{_saw_brace_error}++;
return;
}
sub brace_warning {
my ( $self, $msg, $msg_line_number ) = @_;
use constant BRACE_WARNING_LIMIT => 10;
my $saw_brace_error = $self->{_saw_brace_error};
if ( $saw_brace_error < BRACE_WARNING_LIMIT ) {
$self->warning( $msg, $msg_line_number );
}
$saw_brace_error++;
$self->{_saw_brace_error} = $saw_brace_error;
if ( $saw_brace_error == BRACE_WARNING_LIMIT ) {
$self->warning("No further warnings of this type will be given\n");
}
return;
} ## end sub brace_warning
sub complain {
# handle non-critical warning messages based on input flag
my ( $self, $msg, $msg_line_number ) = @_;
my $rOpts = $self->{_rOpts};
# these appear in .ERR output only if -w flag is used
if ( $rOpts->{'warning-output'} ) {
$self->warning( $msg, $msg_line_number );
}
# otherwise, they go to the .LOG file
else {
$self->{_complaint_count}++;
if ($msg_line_number) {
# TODO: consider using same prefix as warning()
$msg = $msg_line_number . ':' . $msg;
}
$self->write_logfile_entry($msg);
}
return;
} ## end sub complain
sub warning {
my ( $self, $msg, ($msg_line_number) ) = @_;
# Report errors to .ERR file (or stdout)
# Given:
# $msg = a string with the warning message
# $msg_line_number = optional line number prefix
use constant WARNING_LIMIT => 50;
# Always bump the warn count, even if no message goes out
Perl::Tidy::Warn_count_bump();
my $rOpts = $self->{_rOpts};
if ( !$rOpts->{'quiet'} ) {
my $warning_count = $self->{_warning_count};
my $fh_warnings = $self->{_fh_warnings};
my $is_encoded_data = $self->{_is_encoded_data};
if ( !$fh_warnings ) {
my $warning_file = $self->{_warning_file};
$fh_warnings =
Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
if ( !$fh_warnings ) {
Perl::Tidy::Die("couldn't open warning file '$warning_file'\n");
}
Perl::Tidy::Warn_msg("## Please see file $warning_file\n")
unless ref($warning_file);
$self->{_fh_warnings} = $fh_warnings;
$fh_warnings->print("Perltidy version is $Perl::Tidy::VERSION\n");
}
my $filename_stamp = $self->{_filename_stamp};
if ( $warning_count < WARNING_LIMIT ) {
if ( !$warning_count ) {
# On first error always write a line with the filename. Note
# that the filename will be 'perltidy' if input is from stdin
# or from a data structure.
if ($filename_stamp) {
$fh_warnings->print(
"\n$filename_stamp Begin Error Output Stream\n");
}
# Turn off filename stamping unless error output is directed
# to the standard error output (with -se flag)
if ( !$rOpts->{'standard-error-output'} ) {
$filename_stamp = EMPTY_STRING;
$self->{_filename_stamp} = $filename_stamp;
}
}
if ( $self->get_use_prefix() > 0 && defined($msg_line_number) ) {
$self->write_logfile_entry("WARNING: $msg");
# add prefix 'filename:line_no: ' to message lines
my $pre_string = $filename_stamp . $msg_line_number . ': ';
chomp $msg;
$msg =~ s/\n/\n$pre_string/g;
$msg = $pre_string . $msg . "\n";
$fh_warnings->print($msg);
}
else {
$self->write_logfile_entry($msg);
# add prefix 'filename: ' to message lines
if ($filename_stamp) {
my $pre_string = $filename_stamp . SPACE;
chomp $msg;
$msg =~ s/\n/\n$pre_string/g;
$msg = $pre_string . $msg . "\n";
}
$fh_warnings->print($msg);
}
}
$warning_count++;
$self->{_warning_count} = $warning_count;
if ( $warning_count == WARNING_LIMIT ) {
$fh_warnings->print(
$filename_stamp . "No further warnings will be given\n" );
}
}
return;
} ## end sub warning
sub report_definite_bug {
my $self = shift;
$self->{_saw_code_bug} = 1;
return;
}
sub get_save_logfile {
my $self = shift;
return $self->{_save_logfile};
}
sub finish {
# called after all formatting to summarize errors
my ($self) = @_;
my $warning_count = $self->{_warning_count};
my $save_logfile = $self->{_save_logfile};
my $log_file = $self->{_log_file};
my $msg_line_number = $self->{_last_input_line_number};
if ($warning_count) {
if ($save_logfile) {
$self->block_log_output(); # avoid echoing this to the logfile
$self->warning(
"The logfile $log_file may contain useful information\n",
$msg_line_number );
$self->unblock_log_output();
}
if ( $self->{_complaint_count} > 0 ) {
$self->warning(
"To see $self->{_complaint_count} non-critical warnings rerun with -w\n",
$msg_line_number
);
}
if ( $self->{_saw_brace_error}
&& ( $self->{_logfile_gap} > 1 || !$save_logfile ) )
{
$self->warning( "To save a full .LOG file rerun with -g\n",
$msg_line_number );
}
}
if ($save_logfile) {
my $is_encoded_data = $self->{_is_encoded_data};
my $fh = Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
if ( !$fh ) {
Perl::Tidy::Warn("unable to open log file '$log_file'\n");
}
else {
my $routput_array = $self->{_output_array};
foreach my $line ( @{$routput_array} ) { $fh->print($line) }
if ( $fh->can('close')
&& !ref($log_file)
&& $log_file ne '-' )
{
$fh->close()
or Perl::Tidy::Warn(
"Error closing LOG file '$log_file': $OS_ERROR\n");
}
}
}
return;
} ## end sub finish
1;
Perl-Tidy-20250105/lib/Perl/Tidy/VerticalAligner/ 0002755 0001750 0001750 00000000000 14735777217 020303 5 ustar steve steve Perl-Tidy-20250105/lib/Perl/Tidy/VerticalAligner/Line.pm 0000644 0001750 0001750 00000005153 14735303002 021503 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::VerticalAligner::Line class supplies an object to
# contain a single output line. It allows manipulation of the
# alignment columns on that line.
#
#####################################################################
package Perl::Tidy::VerticalAligner::Line;
use strict;
use warnings;
our $VERSION = '20250105';
use English qw( -no_match_vars );
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} <{ralignments}->[$j];
return unless defined($alignment);
return $alignment->get_column();
} ## end sub get_column
sub current_field_width {
my ( $self, $j ) = @_;
# Return number of columns of space between alignments $j and $j-1
my $alignment_j = $self->{ralignments}->[$j];
my $col_j = defined($alignment_j) ? $alignment_j->get_column() : 0;
return $col_j if ( $j == 0 );
my $alignment_jm = $self->{ralignments}->[ $j - 1 ];
my $col_jm = defined($alignment_jm) ? $alignment_jm->get_column() : 0;
return $col_j - $col_jm;
} ## end sub current_field_width
sub increase_field_width {
my ( $self, $j, $pad ) = @_;
# Increase the width of alignment field $j by $pad spaces
my $jmax = $self->{jmax};
foreach ( $j .. $jmax ) {
my $alignment = $self->{ralignments}->[$_];
if ( defined($alignment) ) {
$alignment->increment_column($pad);
}
}
return;
} ## end sub increase_field_width
sub get_available_space_on_right {
my $self = shift;
my $jmax = $self->{jmax};
return $self->{maximum_line_length} - $self->get_column($jmax);
}
1;
Perl-Tidy-20250105/lib/Perl/Tidy/VerticalAligner/Alignment.pm 0000644 0001750 0001750 00000003232 14735303002 022526 0 ustar steve steve #####################################################################
#
# the Perl::Tidy::VerticalAligner::Alignment class holds information
# on a single column being aligned
#
#####################################################################
package Perl::Tidy::VerticalAligner::Alignment;
use strict;
use warnings;
our $VERSION = '20250105';
sub new {
my ( $class, $rarg ) = @_;
my $self = bless $rarg, $class;
return $self;
}
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} <{'column'};
}
sub increment_column {
my ( $self, $pad ) = @_;
$self->{'column'} += $pad;
return;
}
sub save_column {
my $self = shift;
$self->{'saved_column'} = $self->{'column'};
return;
}
sub restore_column {
my $self = shift;
$self->{'column'} = $self->{'saved_column'};
return;
}
1;
Perl-Tidy-20250105/lib/Perl/Tidy/FileWriter.pm 0000644 0001750 0001750 00000042155 14735302772 017635 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::FileWriter class writes the output file created
# by the formatter. It receives each output line and performs some
# important monitoring services. These include:
#
# - Verifying that lines do not go out with tokens in the wrong order
# - Checking for obvious iteration convergence when all output tokens
# match all input tokens
# - Keeping track of consecutive blank and non-blank lines
# - Looking for line lengths which exceed the maximum requested length
# - Reporting results to the log file
#
#####################################################################
package Perl::Tidy::FileWriter;
use strict;
use warnings;
our $VERSION = '20250105';
use Carp;
use constant DEVEL_MODE => 0;
use constant EMPTY_STRING => q{};
# A limit on message length when a fault is detected
use constant LONG_MESSAGE => 256;
# Maximum number of little messages; probably need not be changed.
use constant MAX_NAG_MESSAGES => 6;
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < $i++,
_rOpts_ => $i++,
_output_line_number_ => $i++,
_consecutive_blank_lines_ => $i++,
_consecutive_nonblank_lines_ => $i++,
_consecutive_new_blank_lines_ => $i++,
_first_line_length_error_ => $i++,
_max_line_length_error_ => $i++,
_last_line_length_error_ => $i++,
_first_line_length_error_at_ => $i++,
_max_line_length_error_at_ => $i++,
_last_line_length_error_at_ => $i++,
_line_length_error_count_ => $i++,
_max_output_line_length_ => $i++,
_max_output_line_length_at_ => $i++,
_rK_checklist_ => $i++,
_K_arrival_order_matches_ => $i++,
_K_sequence_error_msg_ => $i++,
_K_last_arrival_ => $i++,
_save_logfile_ => $i++,
_routput_string_ => $i++,
_input_stream_name_ => $i++,
};
} ## end BEGIN
sub Die {
my ($msg) = @_;
Perl::Tidy::Die($msg);
croak "unexpected return from Perl::Tidy::Die";
}
sub Fault {
my ( $self, $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.
# Please add comments at calls to Fault to explain why the call
# should not occur, and where to look to fix it.
my ( $package0_uu, $filename0_uu, $line0, $subroutine0_uu ) = caller(0);
my ( $package1_uu, $filename1, $line1, $subroutine1 ) = caller(1);
my ( $package2_uu, $filename2_uu, $line2_uu, $subroutine2 ) = caller(2);
my $pkg = __PACKAGE__;
# Catch potential error of Fault not called as a method
my $input_stream_name;
if ( !ref($self) ) {
$input_stream_name = "(UNKNOWN)";
$msg = "Fault not called as a method - please fix\n";
if ( $self && length($self) < LONG_MESSAGE ) { $msg .= $self }
$self = undef;
}
else {
$input_stream_name = $self->[_input_stream_name_];
}
Die(<[_logger_object_];
if ($logger_object) { $logger_object->warning($msg); }
return;
} ## end sub warning
sub write_logfile_entry {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
} ## end sub write_logfile_entry
sub new {
my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
my $self = [];
bless $self, $class;
$self->[_logger_object_] = $logger_object;
$self->[_rOpts_] = $rOpts;
$self->[_output_line_number_] = 1;
$self->[_consecutive_blank_lines_] = 0;
$self->[_consecutive_nonblank_lines_] = 0;
$self->[_consecutive_new_blank_lines_] = 0;
$self->[_first_line_length_error_] = 0;
$self->[_max_line_length_error_] = 0;
$self->[_last_line_length_error_] = 0;
$self->[_first_line_length_error_at_] = 0;
$self->[_max_line_length_error_at_] = 0;
$self->[_last_line_length_error_at_] = 0;
$self->[_line_length_error_count_] = 0;
$self->[_max_output_line_length_] = 0;
$self->[_max_output_line_length_at_] = 0;
$self->[_rK_checklist_] = [];
$self->[_K_arrival_order_matches_] = 0;
$self->[_K_sequence_error_msg_] = EMPTY_STRING;
$self->[_K_last_arrival_] = -1;
$self->[_save_logfile_] =
defined($logger_object) && $logger_object->get_save_logfile();
# '$line_sink_object' is a SCALAR ref which receives the lines.
my $ref = ref($line_sink_object);
if ( !$ref ) {
$self->Fault("FileWriter expects line_sink_object to be a ref\n");
}
elsif ( $ref eq 'SCALAR' ) {
$self->[_routput_string_] = $line_sink_object;
}
else {
my $str = $ref;
if ( length($str) > 63 ) { $str = substr( $str, 0, 60 ) . '...' }
$self->Fault(<get_input_stream_name();
}
$self->[_input_stream_name_] = $input_stream_name;
return $self;
} ## end sub new
sub setup_convergence_test {
my ( $self, $rlist ) = @_;
# Setup the convergence test,
# Given:
# $rlist = a reference to a list of line-ending token indexes 'K' of
# the input stream. We will compare these with the line-ending token
# indexes of the output stream. If they are identical, then we have
# convergence.
if ( @{$rlist} ) {
# We are going to destroy the list, so make a copy and put in
# reverse order so we can pop values as they arrive
my @list = @{$rlist};
if ( $list[0] < $list[-1] ) {
@list = reverse @list;
}
$self->[_rK_checklist_] = \@list;
}
# We will zero this flag on any error in arrival order:
$self->[_K_arrival_order_matches_] = 1;
$self->[_K_sequence_error_msg_] = EMPTY_STRING;
$self->[_K_last_arrival_] = -1;
return;
} ## end sub setup_convergence_test
sub get_convergence_check {
my ($self) = @_;
# converged if:
# - all expected indexes arrived
# - and in correct order
return !@{ $self->[_rK_checklist_] }
&& $self->[_K_arrival_order_matches_];
} ## end sub get_convergence_check
sub get_output_line_number {
my $self = shift;
return $self->[_output_line_number_];
}
sub decrement_output_line_number {
my $self = shift;
$self->[_output_line_number_]--;
return;
}
sub get_consecutive_nonblank_lines {
my $self = shift;
return $self->[_consecutive_nonblank_lines_];
}
sub get_consecutive_blank_lines {
my $self = shift;
return $self->[_consecutive_blank_lines_];
}
sub reset_consecutive_blank_lines {
my $self = shift;
$self->[_consecutive_blank_lines_] = 0;
return;
}
sub want_blank_line {
my $self = shift;
if ( !$self->[_consecutive_blank_lines_] ) {
$self->write_blank_code_line();
}
return;
} ## end sub want_blank_line
sub require_blank_code_lines {
my ( $self, $count ) = @_;
# Given:
# $count = number of blank lines to write
# Write out $count blank lines regardless of the value of -mbl
# unless -mbl=0. This allows extra blank lines to be written for subs and
# packages even with the default -mbl=1
my $need = $count - $self->[_consecutive_blank_lines_];
my $rOpts = $self->[_rOpts_];
my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
foreach ( 0 .. $need - 1 ) {
$self->write_blank_code_line($forced);
}
return;
} ## end sub require_blank_code_lines
sub write_blank_code_line {
my ( $self, ($forced) ) = @_;
# Write a blank line of code, given:
# $forced = optional flag which, if set, forces the blank line
# to be written. This allows the -mbl flag to be temporarily
# exceeded.
my $rOpts = $self->[_rOpts_];
return
if (!$forced
&& $self->[_consecutive_blank_lines_] >=
$rOpts->{'maximum-consecutive-blank-lines'} );
$self->[_consecutive_nonblank_lines_] = 0;
# Balance old blanks against new (forced) blanks instead of writing them.
# This fixes case b1073.
if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
$self->[_consecutive_new_blank_lines_]--;
return;
}
${ $self->[_routput_string_] } .= "\n";
$self->[_output_line_number_]++;
$self->[_consecutive_blank_lines_]++;
$self->[_consecutive_new_blank_lines_]++ if ($forced);
return;
} ## end sub write_blank_code_line
use constant MAX_PRINTED_CHARS => 80;
sub write_code_line {
my ( $self, $str, $K ) = @_;
# Write a line of code, given
# $str = the line of code
# $K = an optional check integer which, if if given, must
# increase monotonically. This was added to catch cache
# sequence errors in the vertical aligner.
$self->[_consecutive_blank_lines_] = 0;
$self->[_consecutive_new_blank_lines_] = 0;
$self->[_consecutive_nonblank_lines_]++;
$self->[_output_line_number_]++;
${ $self->[_routput_string_] } .= $str;
if ( $self->[_save_logfile_] ) { $self->check_line_lengths($str) }
#----------------------------
# Convergence and error check
#----------------------------
if ( defined($K) ) {
# Convergence check: we are checking if all defined K values arrive in
# the order which was defined by the caller. Quit checking if any
# unexpected K value arrives.
if ( $self->[_K_arrival_order_matches_] ) {
my $Kt = pop @{ $self->[_rK_checklist_] };
if ( !defined($Kt) || $Kt != $K ) {
$self->[_K_arrival_order_matches_] = 0;
}
}
# Check for out-of-order arrivals of index K. The K values are the
# token indexes of the last token of code lines, and they should come
# out in increasing order. Otherwise something is seriously wrong.
# Most likely a recent programming change to VerticalAligner.pm has
# caused lines to go out in the wrong order. This could happen if
# either the cache or buffer that it uses are emptied in the wrong
# order.
if ( $K < $self->[_K_last_arrival_]
&& !$self->[_K_sequence_error_msg_] )
{
my $K_prev = $self->[_K_last_arrival_];
chomp $str;
if ( length($str) > MAX_PRINTED_CHARS ) {
$str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
}
my $msg = <Fault($msg) }
# Otherwise warn if string is not empty (added for b1378)
$self->warning($msg) if ( length($str) );
# Only issue this warning once
$self->[_K_sequence_error_msg_] = $msg;
}
$self->[_K_last_arrival_] = $K;
}
return;
} ## end sub write_code_line
sub write_line {
my ( $self, $str ) = @_;
# Write a line directly to the output, without any counting of blank or
# non-blank lines.
# Given:
# $str = line of text to write
${ $self->[_routput_string_] } .= $str;
if ( chomp $str ) { $self->[_output_line_number_]++; }
if ( $self->[_save_logfile_] ) { $self->check_line_lengths($str) }
return;
} ## end sub write_line
sub check_line_lengths {
my ( $self, $str ) = @_;
# Collect info on line lengths for logfile
# Given:
# $str = line of text being written
# This calculation of excess line length ignores any internal tabs
my $rOpts = $self->[_rOpts_];
chomp $str;
my $len_str = length($str);
my $exceed = $len_str - $rOpts->{'maximum-line-length'};
if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) {
$exceed += pos($str) * $rOpts->{'indent-columns'};
}
# Note that we just incremented output line number to future value
# so we must subtract 1 for current line number
if ( $len_str > $self->[_max_output_line_length_] ) {
$self->[_max_output_line_length_] = $len_str;
$self->[_max_output_line_length_at_] =
$self->[_output_line_number_] - 1;
}
if ( $exceed > 0 ) {
my $output_line_number = $self->[_output_line_number_];
$self->[_last_line_length_error_] = $exceed;
$self->[_last_line_length_error_at_] = $output_line_number - 1;
if ( $self->[_line_length_error_count_] == 0 ) {
$self->[_first_line_length_error_] = $exceed;
$self->[_first_line_length_error_at_] = $output_line_number - 1;
}
if ( $self->[_last_line_length_error_] >
$self->[_max_line_length_error_] )
{
$self->[_max_line_length_error_] = $exceed;
$self->[_max_line_length_error_at_] = $output_line_number - 1;
}
if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) {
$self->write_logfile_entry(
"Line length exceeded by $exceed characters\n");
}
$self->[_line_length_error_count_]++;
}
return;
} ## end sub check_line_lengths
sub report_line_length_errors {
my $self = shift;
# Write summary info about line lengths to the log file
my $rOpts = $self->[_rOpts_];
my $line_length_error_count = $self->[_line_length_error_count_];
if ( $line_length_error_count == 0 ) {
$self->write_logfile_entry(
"No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
my $max_output_line_length = $self->[_max_output_line_length_];
my $max_output_line_length_at = $self->[_max_output_line_length_at_];
$self->write_logfile_entry(
" Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
);
}
else {
my $word = ( $line_length_error_count > 1 ) ? "s" : EMPTY_STRING;
$self->write_logfile_entry(
"$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
);
$word = ( $line_length_error_count > 1 ) ? "First" : EMPTY_STRING;
my $first_line_length_error = $self->[_first_line_length_error_];
my $first_line_length_error_at = $self->[_first_line_length_error_at_];
$self->write_logfile_entry(
" $word at line $first_line_length_error_at by $first_line_length_error characters\n"
);
if ( $line_length_error_count > 1 ) {
my $max_line_length_error = $self->[_max_line_length_error_];
my $max_line_length_error_at = $self->[_max_line_length_error_at_];
my $last_line_length_error = $self->[_last_line_length_error_];
my $last_line_length_error_at =
$self->[_last_line_length_error_at_];
$self->write_logfile_entry(
" Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
);
$self->write_logfile_entry(
" Last at line $last_line_length_error_at by $last_line_length_error characters\n"
);
}
}
return;
} ## end sub report_line_length_errors
1;
Perl-Tidy-20250105/lib/Perl/Tidy/VerticalAligner.pm 0000644 0001750 0001750 00001003615 14735303001 020615 0 ustar steve steve package Perl::Tidy::VerticalAligner;
use strict;
use warnings;
use Carp;
{ #<<< A non-indenting brace to contain all lexical variables
our $VERSION = '20250105';
use English qw( -no_match_vars );
use Scalar::Util 'refaddr'; # perl 5.8.1 and later
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
use constant DEVEL_MODE => 0;
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
# The Perl::Tidy::VerticalAligner package collects output lines and
# attempts to line up certain common tokens, such as => and #, which are
# identified by the calling routine.
#
# Usage:
# - Initiate an object with a call to new().
# - Write lines one-by-one with calls to valign_input().
# - Make a final call to flush() to empty the pipeline.
#
# The sub valign_input collects lines into groups. When a group reaches
# the maximum possible size it is processed for alignment and output.
# The maximum group size is reached whenever there is a change in indentation
# level, a blank line, a block comment, or an external flush call. The calling
# routine may also force a break in alignment at any time.
#
# If the calling routine needs to interrupt the output and send other text to
# the output, it must first call flush() to empty the output pipeline. This
# might occur for example if a block of pod text needs to be sent to the output
# between blocks of code.
# It is essential that a final call to flush() be made. Otherwise some
# final lines of text will be lost.
# Index...
# CODE SECTION 1: Preliminary code, global definitions and sub new
# sub new
# CODE SECTION 2: Some Basic Utilities
# CODE SECTION 3: Code to accept input and form groups
# sub valign_input
# CODE SECTION 4: Code to process comment lines
# sub _flush_comment_lines
# CODE SECTION 5: Code to process groups of code lines
# sub _flush_group_lines
# CODE SECTION 6: Pad Signed Number Columns
# sub pad_signed_number_columns
# CODE SECTION 7: Pad Wide Equals Columns
# sub pad_wide_equals_columns
# CODE SECTION 8: Output Step A
# sub valign_output_step_A
# CODE SECTION 9: Output Step B
# sub valign_output_step_B
# CODE SECTION 10: Output Step C
# sub valign_output_step_C
# CODE SECTION 11: Output Step D
# sub valign_output_step_D
# CODE SECTION 12: Summary
# sub report_anything_unusual
##################################################################
# CODE SECTION 1: Preliminary code, global definitions and sub new
##################################################################
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < $i++,
_logger_object_ => $i++,
_diagnostics_object_ => $i++,
_rOpts_ => $i++,
_last_level_written_ => $i++,
_last_side_comment_column_ => $i++,
_last_side_comment_line_number_ => $i++,
_last_side_comment_length_ => $i++,
_last_side_comment_level_ => $i++,
_outdented_line_count_ => $i++,
_first_outdented_line_at_ => $i++,
_last_outdented_line_at_ => $i++,
_consecutive_block_comments_ => $i++,
_rgroup_lines_ => $i++,
_group_level_ => $i++,
_group_type_ => $i++,
_group_maximum_line_length_ => $i++,
_zero_count_ => $i++,
_last_leading_space_count_ => $i++,
_comment_leading_space_count_ => $i++,
};
# Debug flag. This is a relic from the original program development
# looking for problems with tab characters. Caution: this debug flag can
# produce a lot of output It should be 0 except when debugging small
# scripts.
use constant DEBUG_TABS => 0;
my $debug_warning = sub {
my $msg = shift;
print {*STDOUT} "VALIGN_DEBUGGING with key $msg\n";
return;
};
DEBUG_TABS && $debug_warning->('TABS');
} ## end BEGIN
# GLOBAL variables
my (
%valign_control_hash,
$valign_control_default,
$rOpts_indent_columns,
$rOpts_tabs,
$rOpts_entab_leading_whitespace,
$rOpts_fixed_position_side_comment,
$rOpts_maximum_line_length,
$rOpts_minimum_space_to_comment,
$rOpts_valign_code,
$rOpts_valign_block_comments,
$rOpts_valign_side_comments,
$rOpts_valign_signed_numbers,
$rOpts_valign_signed_numbers_limit,
$rOpts_valign_wide_equals,
$require_tabs,
);
sub check_options {
# This routine is called to check the user-supplied run parameters
# and to configure the control hashes to them.
my ($rOpts) = @_;
# All alignments are done by default
%valign_control_hash = ();
$valign_control_default = 1;
# If -vil=s is entered without -vxl, assume -vxl='*'
if ( !$rOpts->{'valign-exclusion-list'}
&& $rOpts->{'valign-inclusion-list'} )
{
$rOpts->{'valign-exclusion-list'} = '*';
}
# See if the user wants to exclude any alignment types ...
if ( $rOpts->{'valign-exclusion-list'} ) {
# The inclusion list is only relevant if there is an exclusion list
if ( $rOpts->{'valign-inclusion-list'} ) {
my @vil = split /\s+/, $rOpts->{'valign-inclusion-list'};
@valign_control_hash{@vil} = (1) x scalar(@vil);
}
# Note that the -vxl list is done after -vil, so -vxl has priority
# in the event of duplicate entries.
my @vxl = split /\s+/, $rOpts->{'valign-exclusion-list'};
@valign_control_hash{@vxl} = (0) x scalar(@vxl);
# Optimization: revert to defaults if no exclusions.
# This could happen with -vxl=' ' and any -vil list
if ( !@vxl ) {
%valign_control_hash = ();
}
# '$valign_control_default' applies to types not in the hash:
# - If a '*' was entered then set it to be that default type
# - Otherwise, leave it set it to 1
if ( defined( $valign_control_hash{'*'} ) ) {
$valign_control_default = $valign_control_hash{'*'};
}
# Side comments are controlled separately and must be removed
# if given in a list.
if (%valign_control_hash) {
$valign_control_hash{'#'} = 1;
}
}
# Initialize some global options
$rOpts_indent_columns = $rOpts->{'indent-columns'};
$rOpts_tabs = $rOpts->{'tabs'};
$rOpts_entab_leading_whitespace = $rOpts->{'entab-leading-whitespace'};
$require_tabs = ( $rOpts_tabs || $rOpts_entab_leading_whitespace )
&& $rOpts_indent_columns > 0;
$rOpts_fixed_position_side_comment =
$rOpts->{'fixed-position-side-comment'};
$rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
$rOpts_minimum_space_to_comment = $rOpts->{'minimum-space-to-comment'};
$rOpts_valign_code = $rOpts->{'valign-code'};
$rOpts_valign_block_comments = $rOpts->{'valign-block-comments'};
$rOpts_valign_side_comments = $rOpts->{'valign-side-comments'};
$rOpts_valign_signed_numbers = $rOpts->{'valign-signed-numbers'};
$rOpts_valign_signed_numbers_limit =
$rOpts->{'valign-signed-numbers-limit'};
$rOpts_valign_wide_equals = $rOpts->{'valign-wide-equals'};
return;
} ## end sub check_options
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 $LIST_SEPARATOR = ')(';
my @expected_keys = sort keys %{$rvalid};
@unknown_keys = sort @unknown_keys;
Fault(< undef,
file_writer_object => undef,
logger_object => undef,
diagnostics_object => undef,
);
my %args = ( %defaults, @arglist );
# Initialize other caches and buffers
initialize_step_B_cache();
initialize_valign_buffer();
initialize_decode();
set_logger_object( $args{logger_object} );
# Initialize all variables in $self.
# To add an item to $self, first define a new constant index in the BEGIN
# section.
my $self = [];
# objects
$self->[_file_writer_object_] = $args{file_writer_object};
$self->[_logger_object_] = $args{logger_object};
$self->[_diagnostics_object_] = $args{diagnostics_object};
# shortcut to user options
my $rOpts = $args{rOpts};
$self->[_rOpts_] = $rOpts;
# Batch of lines being collected
$self->[_rgroup_lines_] = [];
$self->[_group_level_] = 0;
$self->[_group_type_] = EMPTY_STRING;
$self->[_group_maximum_line_length_] = undef;
$self->[_zero_count_] = 0;
$self->[_comment_leading_space_count_] = 0;
$self->[_last_leading_space_count_] = 0;
# Memory of what has been processed
$self->[_last_level_written_] = -1;
$self->[_last_side_comment_column_] = 0;
$self->[_last_side_comment_line_number_] = 0;
$self->[_last_side_comment_length_] = 0;
$self->[_last_side_comment_level_] = -1;
$self->[_outdented_line_count_] = 0;
$self->[_first_outdented_line_at_] = 0;
$self->[_last_outdented_line_at_] = 0;
$self->[_consecutive_block_comments_] = 0;
bless $self, $class;
return $self;
} ## end sub new
#################################
# CODE SECTION 2: Basic Utilities
#################################
sub flush {
# flush() is the external call to completely empty the pipeline.
my ($self) = @_;
# push things out the pipeline...
# push out any current group lines
$self->_flush_group_lines()
if ( @{ $self->[_rgroup_lines_] } );
# then anything left in the cache of step_B
$self->_flush_step_B_cache();
# then anything left in the buffer of step_C
$self->dump_valign_buffer();
return;
} ## end sub flush
sub initialize_for_new_group {
my ($self) = @_;
# initialize for a new group of lines to be aligned vertically
$self->[_rgroup_lines_] = [];
$self->[_group_type_] = EMPTY_STRING;
$self->[_zero_count_] = 0;
$self->[_comment_leading_space_count_] = 0;
$self->[_last_leading_space_count_] = 0;
$self->[_group_maximum_line_length_] = undef;
# Note that the value for _group_level_ is
# handled separately in sub valign_input
return;
} ## end sub initialize_for_new_group
sub group_line_count {
my $self = shift;
return +@{ $self->[_rgroup_lines_] };
}
# interface to Perl::Tidy::Diagnostics routines
# For debugging; not currently used
sub write_diagnostics {
my ( $self, $msg ) = @_;
my $diagnostics_object = $self->[_diagnostics_object_];
if ($diagnostics_object) {
$diagnostics_object->write_diagnostics($msg);
}
return;
} ## end sub write_diagnostics
{ ## begin closure for logger routines
my $logger_object;
# Called once per file to initialize the logger object
sub set_logger_object {
$logger_object = shift;
return;
}
sub get_input_stream_name {
my $input_stream_name = EMPTY_STRING;
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
return $input_stream_name;
} ## end sub get_input_stream_name
sub warning {
my ($msg) = @_;
if ($logger_object) {
$logger_object->warning($msg);
}
return;
} ## end sub warning
sub write_logfile_entry {
my ($msg) = @_;
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
} ## end sub write_logfile_entry
}
sub get_cached_line_count {
my $self = shift;
return $self->group_line_count() + ( get_cached_line_type() ? 1 : 0 );
}
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;
} ## end sub get_recoverable_spaces
######################################################
# CODE SECTION 3: Code to accept input and form groups
######################################################
use constant DEBUG_VALIGN => 0;
use constant SC_LONG_LINE_DIFF => 12;
my %is_opening_token;
my %is_closing_token;
my %is_digit_char;
my %is_plus_or_minus;
my %is_if_or;
my %is_assignment;
my %is_comma_token;
my %is_good_marginal_alignment;
BEGIN {
my @q = qw< { ( [ >;
@is_opening_token{@q} = (1) x scalar(@q);
@q = qw< } ) ] >;
@is_closing_token{@q} = (1) x scalar(@q);
@q = qw( 0 1 2 3 4 5 6 7 8 9 );
@is_digit_char{@q} = (1) x scalar(@q);
@q = qw( + - );
@is_plus_or_minus{@q} = (1) x scalar(@q);
@q = qw( if unless or || );
@is_if_or{@q} = (1) x scalar(@q);
@q = qw( = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x= );
@is_assignment{@q} = (1) x scalar(@q);
@q = qw( => );
push @q, ',';
@is_comma_token{@q} = (1) x scalar(@q);
# We can be less restrictive in marginal cases at certain "good" alignments
@q = qw( { ? => = );
push @q, (',');
@is_good_marginal_alignment{@q} = (1) x scalar(@q);
}
#--------------------------------------------
# VTFLAGS: Vertical tightness types and flags
#--------------------------------------------
# Vertical tightness is controlled by a 'type' and associated 'flags' for each
# line. These values are set by sub Formatter::set_vertical_tightness_flags.
# These are defined as follows:
# Vertical Tightness Line Type Codes:
# Type 0, no vertical tightness condition
# Type 1, last token of this line is a non-block opening token
# Type 2, first token of next line is a non-block closing
# Type 3, isolated opening block brace
# type 4, isolated closing block brace
# Opening token flag values are the vertical tightness flags
# 0 do not join with next line
# 1 just one join per line
# 2 any number of joins
# Closing token flag values indicate spacing:
# 0 = no space added before closing token
# 1 = single space added before closing token
sub valign_input {
#---------------------------------------------------------------------
# This is the front door of the vertical aligner. On each call
# we receive one line of specially marked text for vertical alignment.
# We compare the line with the current group, and either:
# - the line joins the current group if alignments match, or
# - the current group is flushed and a new group is started
#---------------------------------------------------------------------
#
# The key input parameters describing each line are:
# $level = indentation level of this line
# $rfields = ref to array of fields
# $rpatterns = ref to array of patterns, one per field
# $rtokens = ref to array of tokens starting fields 1,2,..
# $rfield_lengths = ref to array of field display widths
#
# Here is an example of what this package does. In this example,
# we are trying to line up both the '=>' and the '#'.
#
# '18' => 'grave', # \`
# '19' => 'acute', # `'
# '20' => 'caron', # \v
# <-tabs-><--field 2 ---><-f3->
# | | | |
# | | | |
# col1 col2 col3 col4
#
# The calling routine has already broken the entire line into 3 fields as
# indicated. (So the work of identifying promising common tokens has
# already been done).
#
# In this example, there will be 2 tokens being matched: '=>' and '#'.
# They are the leading parts of fields 2 and 3, but we do need to know
# what they are so that we can dump a group of lines when these tokens
# change.
#
# The fields contain the actual characters of each field. The patterns
# are like the fields, but they contain mainly token types instead
# of tokens, so they have fewer characters. They are used to be
# sure we are matching fields of similar type.
#
# In this example, there will be 4 column indexes being adjusted. The
# first one is always at zero. The interior columns are at the start of
# the matching tokens, and the last one tracks the maximum line length.
#
# Each time a new line comes in, it joins the current vertical
# group if possible. Otherwise it causes the current group to be flushed
# and a new group is started.
#
# For each new group member, the column locations are increased, as
# necessary, to make room for the new fields. When the group is finally
# output, these column numbers are used to compute the amount of spaces of
# padding needed for each field.
#
# Programming note: the fields are assumed not to have any tab characters.
# Tabs have been previously removed except for tabs in quoted strings and
# side comments. Tabs in these fields can mess up the column counting.
# The log file warns the user if there are any such tabs.
my ( $self, $rcall_hash ) = @_;
# Unpack the call args. This form is significantly faster than getting them
# one-by-one.
my (
$Kend,
$break_alignment_after,
$break_alignment_before,
$ci_level,
$forget_side_comment,
$indentation,
$is_terminal_ternary,
$level,
$level_end,
$list_seqno,
$maximum_line_length,
$outdent_long_lines,
$rline_alignment,
$rvertical_tightness_flags,
) =
@{$rcall_hash}{
qw(
Kend
break_alignment_after
break_alignment_before
ci_level
forget_side_comment
indentation
is_terminal_ternary
level
level_end
list_seqno
maximum_line_length
outdent_long_lines
rline_alignment
rvertical_tightness_flags
)
};
my ( $rtokens, $rfields, $rpatterns, $rfield_lengths ) =
@{$rline_alignment};
# The index '$Kend' is a value which passed along with the line text to sub
# 'write_code_line' for a convergence check.
# number of fields is $jmax
# number of tokens between fields is $jmax-1
my $jmax = @{$rfields} - 1;
my $leading_space_count =
ref($indentation) ? $indentation->get_spaces() : $indentation;
# set outdented flag to be sure we either align within statements or
# across statement boundaries, but not both.
my $is_outdented =
$self->[_last_leading_space_count_] > $leading_space_count;
$self->[_last_leading_space_count_] = $leading_space_count;
# Identify a hanging side comment. Hanging side comments have an empty
# initial field.
my $is_hanging_side_comment =
( $jmax == 1 && $rtokens->[0] eq '#' && $rfields->[0] =~ /^\s*$/ );
# Undo outdented flag for a hanging side comment
$is_outdented = 0 if $is_hanging_side_comment;
# Identify a block comment.
my $is_block_comment = $jmax == 0 && substr( $rfields->[0], 0, 1 ) eq '#';
# Block comment .. update count
if ($is_block_comment) {
$self->[_consecutive_block_comments_]++;
}
# Not a block comment ..
# Forget side comment column if we saw 2 or more block comments,
# and reset the count
else {
if ( $self->[_consecutive_block_comments_] > 1 ) {
$self->forget_side_comment();
}
$self->[_consecutive_block_comments_] = 0;
}
# Reset side comment location if we are entering a new block from level 0.
# This is intended to keep them from drifting too far to the right.
if ($forget_side_comment) {
$self->forget_side_comment();
}
my $is_balanced_line = $level_end == $level;
my $group_level = $self->[_group_level_];
my $group_maximum_line_length = $self->[_group_maximum_line_length_];
DEBUG_VALIGN && do {
my $nlines = $self->group_line_count();
print {*STDOUT}
"Entering valign_input: lines=$nlines new #fields= $jmax, leading_count=$leading_space_count, level=$level, group_level=$group_level, level_end=$level_end\n";
};
# Validate cached line if necessary: If we can produce a container
# with just 2 lines total by combining an existing cached opening
# token with the closing token to follow, then we will mark both
# cached flags as valid.
my $cached_line_type = get_cached_line_type();
if ($cached_line_type) {
my $cached_line_opening_flag = get_cached_line_opening_flag();
if ($rvertical_tightness_flags) {
my $cached_seqno = get_cached_seqno();
if ( $cached_seqno
&& $rvertical_tightness_flags->{_vt_seqno}
&& $rvertical_tightness_flags->{_vt_seqno} == $cached_seqno )
{
# Fix for b1187 and b1188: Normally this step is only done
# if the number of existing lines is 0 or 1. But to prevent
# blinking, this range can be controlled by the caller.
# If zero values are given we fall back on the range 0 to 1.
my $line_count = $self->group_line_count();
my $min_lines = $rvertical_tightness_flags->{_vt_min_lines};
my $max_lines = $rvertical_tightness_flags->{_vt_max_lines};
$min_lines = 0 if ( !$min_lines );
$max_lines = 1 if ( !$max_lines );
if ( ( $line_count >= $min_lines )
&& ( $line_count <= $max_lines ) )
{
$rvertical_tightness_flags->{_vt_valid_flag} ||= 1;
set_cached_line_valid(1);
}
}
}
# do not join an opening block brace (type 3, see VTFLAGS)
# with an unbalanced line unless requested with a flag value of 2
if ( $cached_line_type == 3
&& !$self->group_line_count()
&& $cached_line_opening_flag < 2
&& !$is_balanced_line )
{
set_cached_line_valid(0);
}
}
# shouldn't happen:
if ( $level < 0 ) { $level = 0 }
# do not align code across indentation level changes
# or changes in the maximum line length
# or if vertical alignment is turned off
if (
$level != $group_level
|| ( $group_maximum_line_length
&& $maximum_line_length != $group_maximum_line_length )
|| $is_outdented
|| ( $is_block_comment && !$rOpts_valign_block_comments )
|| ( !$is_block_comment
&& !$rOpts_valign_side_comments
&& !$rOpts_valign_code )
)
{
$self->_flush_group_lines( $level - $group_level )
if ( @{ $self->[_rgroup_lines_] } );
$group_level = $level;
$self->[_group_level_] = $group_level;
$self->[_group_maximum_line_length_] = $maximum_line_length;
# Update leading spaces after the above flush because the leading space
# count may have been changed if the -icp flag is in effect
$leading_space_count =
ref($indentation) ? $indentation->get_spaces() : $indentation;
}
# --------------------------------------------------------------------
# Collect outdentable block COMMENTS
# --------------------------------------------------------------------
if ( $self->[_group_type_] eq 'COMMENT' ) {
if ( $is_block_comment
&& $outdent_long_lines
&& $leading_space_count == $self->[_comment_leading_space_count_] )
{
# Note that for a comment group we are not storing a line
# but rather just the text and its length.
push @{ $self->[_rgroup_lines_] },
[ $rfields->[0], $rfield_lengths->[0], $Kend ];
return;
}
else {
$self->_flush_group_lines()
if ( @{ $self->[_rgroup_lines_] } );
}
}
my $rgroup_lines = $self->[_rgroup_lines_];
if ( $break_alignment_before && @{$rgroup_lines} ) {
$rgroup_lines->[-1]->{'end_group'} = 1;
}
# --------------------------------------------------------------------
# add dummy fields for terminal ternary
# --------------------------------------------------------------------
my $j_terminal_match;
if ( $is_terminal_ternary && @{$rgroup_lines} ) {
$j_terminal_match = fix_terminal_ternary(
{
old_line => $rgroup_lines->[-1],
rfields => $rfields,
rtokens => $rtokens,
rpatterns => $rpatterns,
rfield_lengths => $rfield_lengths,
group_level => $group_level,
}
);
$jmax = @{$rfields} - 1;
}
# --------------------------------------------------------------------
# add dummy fields for else statement
# --------------------------------------------------------------------
# Note the trailing space after 'else' here. If there were no space between
# the else and the next '{' then we would not be able to do vertical
# alignment of the '{'.
if ( $rfields->[0] eq 'else '
&& @{$rgroup_lines}
&& $is_balanced_line )
{
$j_terminal_match = fix_terminal_else(
{
old_line => $rgroup_lines->[-1],
rfields => $rfields,
rtokens => $rtokens,
rpatterns => $rpatterns,
rfield_lengths => $rfield_lengths,
}
);
$jmax = @{$rfields} - 1;
}
# --------------------------------------------------------------------
# Handle simple line of code with no fields to match.
# --------------------------------------------------------------------
if ( $jmax <= 0 ) {
$self->[_zero_count_]++;
# VSN PATCH for a single number, part 1.
my $is_numeric =
$rOpts_valign_signed_numbers && $rpatterns->[0] eq 'n,';
if ( !$is_numeric
&& @{$rgroup_lines}
&& !get_recoverable_spaces( $rgroup_lines->[0]->{'indentation'} ) )
{
# flush the current group if it has some aligned columns..
# or we haven't seen a comment lately
if ( $rgroup_lines->[0]->{'jmax'} > 1
|| $self->[_zero_count_] > 3 )
{
$self->_flush_group_lines()
if ( @{ $self->[_rgroup_lines_] } );
# Update '$rgroup_lines' - it will become a ref to empty array.
# This allows avoiding a call to get_group_line_count below.
$rgroup_lines = $self->[_rgroup_lines_];
}
}
# start new COMMENT group if this comment may be outdented
if ( $is_block_comment
&& $outdent_long_lines
&& !@{$rgroup_lines} )
{
$self->[_group_type_] = 'COMMENT';
$self->[_comment_leading_space_count_] = $leading_space_count;
$self->[_group_maximum_line_length_] = $maximum_line_length;
push @{$rgroup_lines},
[ $rfields->[0], $rfield_lengths->[0], $Kend ];
return;
}
# just write this line directly if no current group, no side comment,
# and no space recovery is needed,
# and not numeric - VSN PATCH for a single number, part 4.
if ( !@{$rgroup_lines}
&& !$is_numeric
&& !get_recoverable_spaces($indentation) )
{
$self->valign_output_step_B(
{
leading_space_count => $leading_space_count,
line => $rfields->[0],
line_length => $rfield_lengths->[0],
side_comment_length => 0,
outdent_long_lines => $outdent_long_lines,
rvertical_tightness_flags => $rvertical_tightness_flags,
level => $level,
level_end => $level_end,
Kend => $Kend,
maximum_line_length => $maximum_line_length,
}
);
return;
}
}
else {
$self->[_zero_count_] = 0;
}
# --------------------------------------------------------------------
# It simplifies things to create a zero length side comment
# if none exists.
# --------------------------------------------------------------------
if ( ( $jmax == 0 ) || ( $rtokens->[ $jmax - 1 ] ne '#' ) ) {
$jmax += 1;
$rtokens->[ $jmax - 1 ] = '#';
$rfields->[$jmax] = EMPTY_STRING;
$rfield_lengths->[$jmax] = 0;
$rpatterns->[$jmax] = '#';
}
# --------------------------------------------------------------------
# create an object to hold this line
# --------------------------------------------------------------------
# The hash keys below must match the list of keys in %valid_LINE_keys.
# Values in this hash are accessed directly, except for 'ralignments',
# rather than with get/set calls for efficiency.
my $new_line = Perl::Tidy::VerticalAligner::Line->new(
{
jmax => $jmax,
rtokens => $rtokens,
rfields => $rfields,
rpatterns => $rpatterns,
rfield_lengths => $rfield_lengths,
indentation => $indentation,
leading_space_count => $leading_space_count,
outdent_long_lines => $outdent_long_lines,
list_seqno => $list_seqno,
list_type => EMPTY_STRING,
is_hanging_side_comment => $is_hanging_side_comment,
rvertical_tightness_flags => $rvertical_tightness_flags,
is_terminal_ternary => $is_terminal_ternary,
j_terminal_match => $j_terminal_match,
end_group => $break_alignment_after,
Kend => $Kend,
ci_level => $ci_level,
level => $level,
level_end => $level_end,
imax_pair => -1,
maximum_line_length => $maximum_line_length,
ralignments => [],
}
);
DEVEL_MODE
&& check_keys( $new_line, \%valid_LINE_keys,
"Checking line keys at line definition", 1 );
# --------------------------------------------------------------------
# Decide if this is a simple list of items.
# We use this to be less restrictive in deciding what to align.
# --------------------------------------------------------------------
decide_if_list($new_line) if ($list_seqno);
# --------------------------------------------------------------------
# Append this line to the current group (or start new group)
# --------------------------------------------------------------------
push @{ $self->[_rgroup_lines_] }, $new_line;
$self->[_group_maximum_line_length_] = $maximum_line_length;
# output this group if it ends in a terminal else or ternary line
if ( defined($j_terminal_match) ) {
$self->_flush_group_lines()
if ( @{ $self->[_rgroup_lines_] } );
}
# Force break after jump to lower level
elsif ($level_end < $level
|| $is_closing_token{ substr( $rfields->[0], 0, 1 ) } )
{
$self->_flush_group_lines(-1)
if ( @{ $self->[_rgroup_lines_] } );
}
else {
##ok: no output needed
}
# --------------------------------------------------------------------
# Some old debugging stuff
# --------------------------------------------------------------------
DEBUG_VALIGN && do {
print {*STDOUT} "exiting valign_input fields:";
dump_array( @{$rfields} );
print {*STDOUT} "exiting valign_input tokens:";
dump_array( @{$rtokens} );
print {*STDOUT} "exiting valign_input patterns:";
dump_array( @{$rpatterns} );
};
return;
} ## end sub valign_input
sub join_hanging_comment {
my ( $new_line, $old_line ) = @_;
# Add dummy fields to a hanging side comment to make it look
# like the first line in its potential group. This simplifies
# the coding.
# Given:
# $new_line = ref to hash of the line to be possibly changed
# $old_line = ref to hash of the previous reference line
# Return:
# true if new line modified
# false otherwise
my $jmax = $new_line->{'jmax'};
# must be 2 fields
return 0 unless ( $jmax == 1 );
my $rtokens = $new_line->{'rtokens'};
# the second field must be a comment
return 0 unless ( $rtokens->[0] eq '#' );
my $rfields = $new_line->{'rfields'};
# the first field must be empty
return 0 if ( $rfields->[0] !~ /^\s*$/ );
# the current line must have fewer fields
my $maximum_field_index = $old_line->{'jmax'};
return 0
if ( $maximum_field_index <= $jmax );
# looks ok..
my $rpatterns = $new_line->{'rpatterns'};
my $rfield_lengths = $new_line->{'rfield_lengths'};
$new_line->{'is_hanging_side_comment'} = 1;
$jmax = $maximum_field_index;
$new_line->{'jmax'} = $jmax;
$rfields->[$jmax] = $rfields->[1];
$rfield_lengths->[$jmax] = $rfield_lengths->[1];
$rtokens->[ $jmax - 1 ] = $rtokens->[0];
$rpatterns->[ $jmax - 1 ] = $rpatterns->[0];
foreach my $j ( 1 .. $jmax - 1 ) {
$rfields->[$j] = EMPTY_STRING;
$rfield_lengths->[$j] = 0;
$rtokens->[ $j - 1 ] = EMPTY_STRING;
$rpatterns->[ $j - 1 ] = EMPTY_STRING;
}
return 1;
} ## end sub join_hanging_comment
sub decide_if_list {
my $line = shift;
# Given:
# $line = ref to hash of values for a line
# Task:
# Set 'list_type' property
# A list will be taken to be a line with a forced break in which all
# of the field separators are commas or comma-arrows (except for the
# trailing #)
my $rtokens = $line->{'rtokens'};
my $test_token = $rtokens->[0];
my ( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token($test_token);
if ( $is_comma_token{$raw_tok} ) {
my $list_type = $test_token;
my $jmax = $line->{'jmax'};
foreach ( 1 .. $jmax - 2 ) {
( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token( $rtokens->[$_] );
if ( !$is_comma_token{$raw_tok} ) {
$list_type = EMPTY_STRING;
last;
}
}
$line->{'list_type'} = $list_type;
}
return;
} ## end sub decide_if_list
sub fix_terminal_ternary {
# Add empty fields as necessary to align a ternary term
# like this:
#
# my $leapyear =
# $year % 4 ? 0
# : $year % 100 ? 1
# : $year % 400 ? 0
# : 1;
#
# returns the index of the terminal question token, if any
my ($rcall_hash) = @_;
my $old_line = $rcall_hash->{old_line};
my $rfields = $rcall_hash->{rfields};
my $rtokens = $rcall_hash->{rtokens};
my $rpatterns = $rcall_hash->{rpatterns};
my $rfield_lengths = $rcall_hash->{rfield_lengths};
my $group_level = $rcall_hash->{group_level};
return if ( !$old_line );
use constant EXPLAIN_TERNARY => 0;
if (%valign_control_hash) {
my $align_ok = $valign_control_hash{'?'};
$align_ok = $valign_control_default unless defined($align_ok);
return if ( !$align_ok );
}
my $jmax = @{$rfields} - 1;
my $rfields_old = $old_line->{'rfields'};
my $rpatterns_old = $old_line->{'rpatterns'};
my $rtokens_old = $old_line->{'rtokens'};
my $maximum_field_index = $old_line->{'jmax'};
# look for the question mark after the :
my ($jquestion);
my $depth_question;
my $pad = EMPTY_STRING;
my $pad_length = 0;
foreach my $j ( 0 .. $maximum_field_index - 1 ) {
my $tok = $rtokens_old->[$j];
my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
decode_alignment_token($tok);
if ( $raw_tok eq '?' ) {
$depth_question = $lev;
# depth must be correct
next if ( $depth_question ne $group_level );
$jquestion = $j;
if ( $rfields_old->[ $j + 1 ] =~ /^(\?\s*)/ ) {
$pad_length = length($1);
$pad = SPACE x $pad_length;
}
else {
return; # shouldn't happen
}
last;
}
}
return if ( !defined($jquestion) ); # shouldn't happen
# Now splice the tokens and patterns of the previous line
# into the else line to insure a match. Add empty fields
# as necessary.
my $jadd = $jquestion;
# Work on copies of the actual arrays in case we have
# to return due to an error
my @fields = @{$rfields};
my @patterns = @{$rpatterns};
my @tokens = @{$rtokens};
my @field_lengths = @{$rfield_lengths};
EXPLAIN_TERNARY && do {
local $LIST_SEPARATOR = '><';
print {*STDOUT} "CURRENT FIELDS=<@{$rfields_old}>\n";
print {*STDOUT} "CURRENT TOKENS=<@{$rtokens_old}>\n";
print {*STDOUT} "CURRENT PATTERNS=<@{$rpatterns_old}>\n";
print {*STDOUT} "UNMODIFIED FIELDS=<@{$rfields}>\n";
print {*STDOUT} "UNMODIFIED TOKENS=<@{$rtokens}>\n";
print {*STDOUT} "UNMODIFIED PATTERNS=<@{$rpatterns}>\n";
};
# handle cases of leading colon on this line
if ( $fields[0] =~ /^(:\s*)(.*)$/ ) {
my ( $colon, $therest ) = ( $1, $2 );
# Handle sub-case of first field with leading colon plus additional code
# This is the usual situation as at the '1' below:
# ...
# : $year % 400 ? 0
# : 1;
if ($therest) {
# Split the first field after the leading colon and insert padding.
# Note that this padding will remain even if the terminal value goes
# out on a separate line. This does not seem to look to bad, so no
# mechanism has been included to undo it.
my $field1_uu = shift @fields;
my $field_length1 = shift @field_lengths;
my $len_colon = length($colon);
unshift @fields, ( $colon, $pad . $therest );
unshift @field_lengths,
( $len_colon, $pad_length + $field_length1 - $len_colon );
# change the leading pattern from : to ?
return if ( $patterns[0] !~ s/^\:/?/ );
# install leading tokens and patterns of existing line
unshift( @tokens, @{$rtokens_old}[ 0 .. $jquestion ] );
unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
# insert appropriate number of empty fields
splice( @fields, 1, 0, (EMPTY_STRING) x $jadd ) if $jadd;
splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
}
# handle sub-case of first field just equal to leading colon.
# This can happen for example in the example below where
# the leading '(' would create a new alignment token
# : ( $name =~ /[]}]$/ ) ? ( $mname = $name )
# : ( $mname = $name . '->' );
else {
return if ( $jmax <= 0 || $tokens[0] eq '#' ); # shouldn't happen
# prepend a leading ? onto the second pattern
$patterns[1] = "?b" . $patterns[1];
# pad the second field
$fields[1] = $pad . $fields[1];
$field_lengths[1] = $pad_length + $field_lengths[1];
# install leading tokens and patterns of existing line, replacing
# leading token and inserting appropriate number of empty fields
splice( @tokens, 0, 1, @{$rtokens_old}[ 0 .. $jquestion ] );
splice( @patterns, 1, 0, @{$rpatterns_old}[ 1 .. $jquestion ] );
splice( @fields, 1, 0, (EMPTY_STRING) x $jadd ) if $jadd;
splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
}
}
# Handle case of no leading colon on this line. This will
# be the case when -wba=':' is used. For example,
# $year % 400 ? 0 :
# 1;
else {
# install leading tokens and patterns of existing line
$patterns[0] = '?' . 'b' . $patterns[0];
unshift( @tokens, @{$rtokens_old}[ 0 .. $jquestion ] );
unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
# insert appropriate number of empty fields
$jadd = $jquestion + 1;
$fields[0] = $pad . $fields[0];
$field_lengths[0] = $pad_length + $field_lengths[0];
splice( @fields, 0, 0, (EMPTY_STRING) x $jadd ) if $jadd;
splice( @field_lengths, 0, 0, (0) x $jadd ) if $jadd;
}
EXPLAIN_TERNARY && do {
local $LIST_SEPARATOR = '><';
print {*STDOUT} "MODIFIED TOKENS=<@tokens>\n";
print {*STDOUT} "MODIFIED PATTERNS=<@patterns>\n";
print {*STDOUT} "MODIFIED FIELDS=<@fields>\n";
};
# all ok .. update the arrays
@{$rfields} = @fields;
@{$rtokens} = @tokens;
@{$rpatterns} = @patterns;
@{$rfield_lengths} = @field_lengths;
# force a flush after this line
return $jquestion;
} ## end sub fix_terminal_ternary
sub fix_terminal_else {
# Add empty fields as necessary to align a balanced terminal
# else block to a previous if/elsif/unless block,
# like this:
#
# if ( 1 || $x ) { print "ok 13\n"; }
# else { print "not ok 13\n"; }
#
# returns a positive value if the else block should be indented
#
my ($rcall_hash) = @_;
my $old_line = $rcall_hash->{old_line};
my $rfields = $rcall_hash->{rfields};
my $rtokens = $rcall_hash->{rtokens};
my $rpatterns = $rcall_hash->{rpatterns};
my $rfield_lengths = $rcall_hash->{rfield_lengths};
return if ( !$old_line );
my $jmax = @{$rfields} - 1;
return if ( $jmax <= 0 );
if (%valign_control_hash) {
my $align_ok = $valign_control_hash{'{'};
$align_ok = $valign_control_default unless defined($align_ok);
return if ( !$align_ok );
}
# check for balanced else block following if/elsif/unless
my $rfields_old = $old_line->{'rfields'};
# TBD: add handling for 'case'
return if ( $rfields_old->[0] !~ /^(?:if|elsif|unless)\s*$/ );
# look for the opening brace after the else, and extract the depth
my $tok_brace = $rtokens->[0];
my $depth_brace;
if ( $tok_brace =~ /^\{(\d+)/ ) { $depth_brace = $1; }
# probably: "else # side_comment"
else { return }
my $rpatterns_old = $old_line->{'rpatterns'};
my $rtokens_old = $old_line->{'rtokens'};
my $maximum_field_index = $old_line->{'jmax'};
# be sure the previous if/elsif is followed by an opening paren
my $jparen = 0;
my $tok_paren = '(' . $depth_brace;
my $tok_test = $rtokens_old->[$jparen];
return if ( $tok_test ne $tok_paren ); # shouldn't happen
# Now find the opening block brace
my ($jbrace);
foreach my $j ( 1 .. $maximum_field_index - 1 ) {
my $tok = $rtokens_old->[$j];
if ( $tok eq $tok_brace ) {
$jbrace = $j;
last;
}
}
return if ( !defined($jbrace) ); # shouldn't happen
# Now splice the tokens and patterns of the previous line
# into the else line to insure a match. Add empty fields
# as necessary.
my $jadd = $jbrace - $jparen;
splice( @{$rtokens}, 0, 0, @{$rtokens_old}[ $jparen .. $jbrace - 1 ] );
splice( @{$rpatterns}, 1, 0, @{$rpatterns_old}[ $jparen + 1 .. $jbrace ] );
splice( @{$rfields}, 1, 0, (EMPTY_STRING) x $jadd );
splice( @{$rfield_lengths}, 1, 0, (0) x $jadd );
# force a flush after this line if it does not follow a case
if ( $rfields_old->[0] =~ /^case\s*$/ ) { return }
else { return $jbrace }
} ## end sub fix_terminal_else
my %is_closing_block_type;
BEGIN {
my @q = qw< } ] >;
@is_closing_block_type{@q} = (1) x scalar(@q);
}
# This is a flag for testing alignment by sub sweep_left_to_right only.
# This test can help find problems with the alignment logic.
# This flag should normally be zero.
use constant TEST_SWEEP_ONLY => 0;
use constant EXPLAIN_CHECK_MATCH => 0;
sub check_match {
# See if the current line matches the current vertical alignment group.
my ( $self, $new_line, $base_line, $prev_line, $group_line_count ) = @_;
# Given:
# $new_line = the line being considered for group inclusion
# $base_line = the first line of the current group
# $prev_line = the line just before $new_line
# $group_line_count = number of lines in the current group
# Returns: a flag and a value as follows:
# return (0, $imax_align) if the line does not match
# return (1, $imax_align) if the line matches but does not fit
# return (2, $imax_align) if the line matches and fits
use constant NO_MATCH => 0;
use constant MATCH_NO_FIT => 1;
use constant MATCH_AND_FIT => 2;
# Return value '$return_value' describes the match with 3 possible values
my $return_value;
# Return value '$imax_align' is the index of the maximum matching token.
# It will be used in the subsequent left-to-right sweep to align as many
# tokens as possible for lines which partially match.
my $imax_align = -1;
# variable $GoToMsg explains reason for no match, for debugging
my $GoToMsg = EMPTY_STRING;
my $jmax = $new_line->{'jmax'};
my $maximum_field_index = $base_line->{'jmax'};
my $jlimit = $jmax - 2;
if ( $jmax > $maximum_field_index ) {
$jlimit = $maximum_field_index - 2;
}
if ( $new_line->{'is_hanging_side_comment'} ) {
# HSC's can join the group if they fit
}
# Everything else
else {
# A group with hanging side comments ends with the first non hanging
# side comment.
if ( $base_line->{'is_hanging_side_comment'} ) {
$GoToMsg = "end of hanging side comments";
$return_value = NO_MATCH;
}
else {
# The number of tokens that this line shares with the previous
# line has been stored with the previous line. This value was
# calculated and stored by sub 'match_line_pair'.
$imax_align = $prev_line->{'imax_pair'};
# Only the following ci sequences are accepted (issue c225):
# 0 0 0 ... OK
# 0 1 1 ... OK but marginal*
# 1 1 1 ... OK
# This check is rarely activated, but for example we want
# to avoid something like this 'tail wag dog' situation:
# $tag =~ s/\b([a-z]+)/\L\u$1/gio;
# $tag =~ s/\b([b-df-hj-np-tv-z]+)\b/\U$1/gio
# if $tag =~ /-/;
# *Note: we could set a flag for the 0 1 marginal case and
# use it to prevent alignment of selected token types.
my $ci_prev = $prev_line->{'ci_level'};
my $ci_new = $new_line->{'ci_level'};
if ( $ci_prev != $ci_new
&& $imax_align >= 0
&& ( $ci_new == 0 || $group_line_count > 1 ) )
{
$imax_align = -1;
$GoToMsg =
"Rejected ci: ci_prev=$ci_prev ci_new=$ci_new num=$group_line_count\n";
$return_value = NO_MATCH;
}
elsif ( $imax_align != $jlimit ) {
$GoToMsg = "Not all tokens match: $imax_align != $jlimit\n";
$return_value = NO_MATCH;
}
else {
##ok: continue
}
}
}
if ( !defined($return_value) ) {
# The tokens match, but the lines must have identical number of
# tokens to join the group.
if ( $maximum_field_index != $jmax ) {
$GoToMsg = "token count differs";
$return_value = NO_MATCH;
}
# The tokens match. Now See if there is space for this line in the
# current group.
elsif ( $self->check_fit( $new_line, $base_line ) && !TEST_SWEEP_ONLY )
{
$GoToMsg = "match and fit, imax_align=$imax_align, jmax=$jmax\n";
$return_value = MATCH_AND_FIT;
$imax_align = $jlimit;
}
else {
$GoToMsg = "match but no fit, imax_align=$imax_align, jmax=$jmax\n";
$return_value = MATCH_NO_FIT;
$imax_align = $jlimit;
}
}
EXPLAIN_CHECK_MATCH
&& print
"returning $return_value because $GoToMsg, max match index =i $imax_align, jmax=$jmax\n";
return ( $return_value, $imax_align );
} ## end sub check_match
sub check_fit {
my ( $self, $new_line, $old_line ) = @_;
# The new line has alignments identical to the current group. Now we have
# to fit the new line into the group without causing a field to exceed the
# line length limit.
# Given:
# $new_line = ref to hash of the new line values
# $old_line = ref to hash of the previous line values
# Returns:
# true if the new line alignments fit the old line
# false otherwise
my $jmax = $new_line->{'jmax'};
my $leading_space_count = $new_line->{'leading_space_count'};
my $rfield_lengths = $new_line->{'rfield_lengths'};
my $padding_available = $old_line->get_available_space_on_right();
my $jmax_old = $old_line->{'jmax'};
# Safety check ... only lines with equal array sizes should arrive here
# from sub check_match. So if this error occurs, look at recent changes in
# sub check_match. It is only supposed to check the fit of lines with
# identical numbers of alignment tokens.
if ( $jmax_old ne $jmax ) {
warning(<{'ralignments'} };
foreach my $alignment (@alignments) {
$alignment->save_column();
}
# Loop over all alignments ...
for my $j ( 0 .. $jmax ) {
my $pad = $rfield_lengths->[$j] - $old_line->current_field_width($j);
if ( $j == 0 ) {
$pad += $leading_space_count;
}
# Keep going if this field does not need any space.
next if ( $pad < 0 );
# Revert to the starting state if does not fit
if ( $pad > $padding_available ) {
#----------------------------------------------
# Line does not fit -- revert to starting state
#----------------------------------------------
foreach my $alignment (@alignments) {
$alignment->restore_column();
}
return;
}
# make room for this field
$old_line->increase_field_width( $j, $pad );
$padding_available -= $pad;
}
#-------------------------------------
# The line fits, the match is accepted
#-------------------------------------
return 1;
} ## end sub check_fit
sub install_new_alignments {
my ($new_line) = @_;
# Given:
# $new_line = ref to hash of a line starting a new group
# Task:
# setup alignment fields for this line
my $jmax = $new_line->{'jmax'};
my $rfield_lengths = $new_line->{'rfield_lengths'};
my $col = $new_line->{'leading_space_count'};
my @alignments;
for my $j ( 0 .. $jmax ) {
$col += $rfield_lengths->[$j];
# create initial alignments for the new group
my $alignment =
Perl::Tidy::VerticalAligner::Alignment->new( { column => $col } );
push @alignments, $alignment;
}
$new_line->{'ralignments'} = \@alignments;
return;
} ## end sub install_new_alignments
sub copy_old_alignments {
my ( $new_line, $old_line ) = @_;
my @new_alignments = @{ $old_line->{'ralignments'} };
$new_line->{'ralignments'} = \@new_alignments;
return;
} ## end sub copy_old_alignments
sub dump_array {
# debug routine to dump array contents
local $LIST_SEPARATOR = ')(';
print {*STDOUT} "(@_)\n";
return;
} ## end sub dump_array
sub level_change {
my ( $self, $leading_space_count, $diff, $level ) = @_;
# compute decrease in level when we remove $diff spaces from the
# leading spaces
# Given:
# $leading_space_count = current leading line spaces
# $diff = number of spaces to remove
# $level = current indentation level
# Return:
# $level = updated level accounting for the loss of spaces
if ($rOpts_indent_columns) {
my $olev =
int( ( $leading_space_count + $diff ) / $rOpts_indent_columns );
my $nlev = int( $leading_space_count / $rOpts_indent_columns );
$level -= ( $olev - $nlev );
if ( $level < 0 ) { $level = 0 }
}
return $level;
} ## end sub level_change
###############################################
# CODE SECTION 4: Code to process comment lines
###############################################
sub _flush_comment_lines {
# Output a group consisting of COMMENT lines
my ($self) = @_;
my $rgroup_lines = $self->[_rgroup_lines_];
return if ( !@{$rgroup_lines} );
my $group_level = $self->[_group_level_];
my $group_maximum_line_length = $self->[_group_maximum_line_length_];
my $leading_space_count = $self->[_comment_leading_space_count_];
# look for excessively long lines
my $max_excess = 0;
foreach my $item ( @{$rgroup_lines} ) {
my ( $str_uu, $str_len ) = @{$item};
my $excess =
$str_len + $leading_space_count - $group_maximum_line_length;
if ( $excess > $max_excess ) {
$max_excess = $excess;
}
}
# zero leading space count if any lines are too long
if ( $max_excess > 0 ) {
$leading_space_count -= $max_excess;
if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
my $file_writer_object = $self->[_file_writer_object_];
my $last_outdented_line_at =
$file_writer_object->get_output_line_number();
my $nlines = @{$rgroup_lines};
$self->[_last_outdented_line_at_] =
$last_outdented_line_at + $nlines - 1;
my $outdented_line_count = $self->[_outdented_line_count_];
if ( !$outdented_line_count ) {
$self->[_first_outdented_line_at_] = $last_outdented_line_at;
}
$outdented_line_count += $nlines;
$self->[_outdented_line_count_] = $outdented_line_count;
}
# write the lines
my $outdent_long_lines = 0;
foreach my $item ( @{$rgroup_lines} ) {
my ( $str, $str_len, $Kend ) = @{$item};
$self->valign_output_step_B(
{
leading_space_count => $leading_space_count,
line => $str,
line_length => $str_len,
side_comment_length => 0,
outdent_long_lines => $outdent_long_lines,
rvertical_tightness_flags => undef,
level => $group_level,
level_end => $group_level,
Kend => $Kend,
maximum_line_length => $group_maximum_line_length,
}
);
}
$self->initialize_for_new_group();
return;
} ## end sub _flush_comment_lines
######################################################
# CODE SECTION 5: Code to process groups of code lines
######################################################
sub _flush_group_lines {
# This is the vertical aligner internal flush, which leaves the cache
# intact
my ( $self, ($level_jump) ) = @_;
# $level_jump = $next_level-$group_level, if known
# = undef if not known
# Note: only the sign of the jump is needed
my $rgroup_lines = $self->[_rgroup_lines_];
return if ( !@{$rgroup_lines} );
my $group_type = $self->[_group_type_];
my $group_level = $self->[_group_level_];
# Debug
0 && do {
my ( $a, $b, $c ) = caller();
my $nlines = @{$rgroup_lines};
print {*STDOUT}
"APPEND0: _flush_group_lines called from $a $b $c lines=$nlines, type=$group_type \n";
};
#-------------------------------------------
# Section 1: Handle a group of COMMENT lines
#-------------------------------------------
if ( $group_type eq 'COMMENT' ) {
$self->_flush_comment_lines();
return;
}
#------------------------------------------------------------------------
# Section 2: Handle line(s) of CODE. Most of the actual work of vertical
# aligning happens here in the following steps:
#------------------------------------------------------------------------
# STEP 1: Remove most unmatched tokens. They block good alignments.
my ( $max_lev_diff_uu, $saw_side_comment, $saw_signed_number ) =
delete_unmatched_tokens( $rgroup_lines, $group_level );
# STEP 2: Sweep top to bottom, forming subgroups of lines with exactly
# matching common alignments. The indexes of these subgroups are in the
# return variable.
my $rgroups = $self->sweep_top_down( $rgroup_lines, $group_level );
# STEP 3: Sweep left to right through the lines, looking for leading
# alignment tokens shared by groups.
sweep_left_to_right( $rgroup_lines, $rgroups, $group_level )
if ( @{$rgroups} > 1 );
# STEP 4: Move side comments to a common column if possible.
if ($saw_side_comment) {
$self->align_side_comments( $rgroup_lines, $rgroups );
}
# STEP 5: For the -lp option, increase the indentation of lists
# to the desired amount, but do not exceed the line length limit.
# We are allowed to shift a group of lines to the right if:
# (1) its level is greater than the level of the previous group, and
# (2) its level is greater than the level of the next line to be written.
my $extra_indent_ok;
if ( $group_level > $self->[_last_level_written_] ) {
# Use the level jump to next line to come, if given
if ( defined($level_jump) ) {
$extra_indent_ok = $level_jump < 0;
}
# Otherwise, assume the next line has the level of the end of last line.
# This fixes case c008.
else {
my $level_end = $rgroup_lines->[-1]->{'level_end'};
$extra_indent_ok = $group_level > $level_end;
}
}
my $extra_leading_spaces =
$extra_indent_ok
? get_extra_leading_spaces( $rgroup_lines, $rgroups )
: 0;
# STEP 6: add sign padding to columns numbers if needed
pad_signed_number_columns($rgroup_lines)
if ( $saw_signed_number && $rOpts_valign_signed_numbers );
# STEP 7: pad wide equals
pad_wide_equals_columns($rgroup_lines)
if ($rOpts_valign_wide_equals);
# STEP 8: Output the lines.
# All lines in this group have the same leading spacing and maximum line
# length
my $group_leader_length = $rgroup_lines->[0]->{'leading_space_count'};
my $group_maximum_line_length = $rgroup_lines->[0]->{'maximum_line_length'};
foreach my $line ( @{$rgroup_lines} ) {
$self->valign_output_step_A(
{
line => $line,
min_ci_gap => 0,
do_not_align => 0,
group_leader_length => $group_leader_length,
extra_leading_spaces => $extra_leading_spaces,
level => $group_level,
maximum_line_length => $group_maximum_line_length,
}
);
}
# Let the formatter know that this object has been processed and any
# recoverable spaces have been handled. This is needed for setting the
# closing paren location in -lp mode.
my $object = $rgroup_lines->[0]->{'indentation'};
if ( ref($object) ) { $object->set_recoverable_spaces(0) }
$self->initialize_for_new_group();
return;
} ## end sub _flush_group_lines
{ ## closure for sub sweep_top_down
my $rall_lines; # all of the lines
my $grp_level; # level of all lines
my $rgroups; # describes the partition of lines we will make here
my $group_line_count; # number of lines in current partition
BEGIN { $rgroups = [] }
sub initialize_for_new_rgroup {
$group_line_count = 0;
return;
}
sub add_to_rgroup {
my ($jend) = @_;
my $rline = $rall_lines->[$jend];
my $jbeg = $jend;
if ( $group_line_count == 0 ) {
install_new_alignments($rline);
}
else {
my $rvals = pop @{$rgroups};
$jbeg = $rvals->[0];
copy_old_alignments( $rline, $rall_lines->[$jbeg] );
}
push @{$rgroups}, [ $jbeg, $jend, undef ];
$group_line_count++;
return;
} ## end sub add_to_rgroup
sub get_rgroup_jrange {
return if ( !@{$rgroups} );
return if ( $group_line_count <= 0 );
my ( $jbeg, $jend ) = @{ $rgroups->[-1] };
return ( $jbeg, $jend );
} ## end sub get_rgroup_jrange
sub end_rgroup {
my ($imax_align) = @_;
return if ( !@{$rgroups} );
return if ( $group_line_count <= 0 );
my ( $jbeg, $jend ) = @{ pop @{$rgroups} };
push @{$rgroups}, [ $jbeg, $jend, $imax_align ];
# Undo some alignments of poor two-line combinations.
# We had to wait until now to know the line count.
if ( $jend - $jbeg == 1 ) {
my $line_0 = $rall_lines->[$jbeg];
my $line_1 = $rall_lines->[$jend];
my $imax_pair = $line_1->{'imax_pair'};
if ( $imax_pair > $imax_align ) { $imax_align = $imax_pair }
## flag for possible future use:
## my $is_isolated_pair = $imax_pair < 0
## && ( $jbeg == 0
## || $rall_lines->[ $jbeg - 1 ]->{'imax_pair'} < 0 );
my $imax_prev =
$jbeg > 0 ? $rall_lines->[ $jbeg - 1 ]->{'imax_pair'} : -1;
my ( $is_marginal, $imax_align_fix ) =
is_marginal_match( $line_0, $line_1, $grp_level, $imax_align,
$imax_prev );
if ($is_marginal) {
combine_fields( $line_0, $line_1, $imax_align_fix );
}
}
initialize_for_new_rgroup();
return;
} ## end sub end_rgroup
sub block_penultimate_match {
# emergency reset to prevent sweep_left_to_right from trying to match a
# failed terminal else match
return if ( @{$rgroups} <= 1 );
$rgroups->[-2]->[2] = -1;
return;
} ## end sub block_penultimate_match
sub sweep_top_down {
my ( $self, $rlines, $group_level ) = @_;
# This is the first of two major sweeps to find alignments.
# The other is sweep_left_to_right.
# Given:
# $rlines = ref to hash of lines in this main alignment group
# $group_level = common indentation level of these lines
# Return:
# $rgroups = ref to hash of subgroups created
# Partition the set of lines into final alignment subgroups
# and store the alignments with the lines.
# The alignment subgroups we are making here are groups of consecutive
# lines which have (1) identical alignment tokens and (2) do not
# exceed the allowable maximum line length. A later sweep from
# left-to-right ('sweep_lr') will handle additional alignments.
# transfer args to closure variables
$rall_lines = $rlines;
$grp_level = $group_level;
$rgroups = [];
initialize_for_new_rgroup();
return unless @{$rlines}; # shouldn't happen
# Unset the _end_group flag for the last line if it it set because it
# is not needed and can causes problems for -lp formatting
$rall_lines->[-1]->{'end_group'} = 0;
# Loop over all lines ...
my $jline = -1;
foreach my $new_line ( @{$rall_lines} ) {
$jline++;
# Start a new subgroup if necessary
if ( !$group_line_count ) {
add_to_rgroup($jline);
if ( $new_line->{'end_group'} ) {
end_rgroup(-1);
}
next;
}
my $j_terminal_match = $new_line->{'j_terminal_match'};
my ( $jbeg, $jend_uu ) = get_rgroup_jrange();
if ( !defined($jbeg) ) {
# safety check, shouldn't happen
warning(<[$jbeg];
# Initialize a global flag saying if the last line of the group
# should match end of group and also terminate the group. There
# should be no returns between here and where the flag is handled
# at the bottom.
my $col_matching_terminal = 0;
if ( defined($j_terminal_match) ) {
# remember the column of the terminal ? or { to match with
$col_matching_terminal =
$base_line->get_column($j_terminal_match);
# Ignore an undefined value as a defensive step; shouldn't
# normally happen.
$col_matching_terminal = 0
unless defined($col_matching_terminal);
}
# -------------------------------------------------------------
# Allow hanging side comment to join current group, if any. The
# only advantage is to keep the other tokens in the same group. For
# example, this would make the '=' align here:
# $ax = 1; # side comment
# # hanging side comment
# $boondoggle = 5; # side comment
# $beetle = 5; # side comment
# here is another example..
# _rtoc_name_count => {}, # hash to track ..
# _rpackage_stack => [], # stack to check ..
# # name changes
# _rlast_level => \$last_level, # brace indentation
#
#
# If this were not desired, the next step could be skipped.
# -------------------------------------------------------------
if ( $new_line->{'is_hanging_side_comment'} ) {
join_hanging_comment( $new_line, $base_line );
}
# If this line has no matching tokens, then flush out the lines
# BEFORE this line unless both it and the previous line have side
# comments. This prevents this line from pushing side comments out
# to the right.
elsif ( $new_line->{'jmax'} == 1 ) {
# There are no matching tokens, so now check side comments.
# Programming note: accessing arrays with index -1 is
# risky in Perl, but we have verified there is at least one
# line in the group and that there is at least one field,
my $prev_comment =
$rall_lines->[ $jline - 1 ]->{'rfields'}->[-1];
my $side_comment = $new_line->{'rfields'}->[-1];
# do not end group if both lines have side comments
if ( !$side_comment || !$prev_comment ) {
# Otherwise - VSN PATCH for a single number:
# - do not end group if numeric and no side comment, or
# - end if !numeric or side comment
my $pat = $new_line->{'rpatterns'}->[0];
my $is_numeric = $rOpts_valign_signed_numbers
&& ( $pat eq 'n,'
|| $pat eq 'n,b' );
end_rgroup(-1) if ( !$is_numeric || $side_comment );
}
}
else {
##ok: continue
}
# See if the new line matches and fits the current group,
# if it still exists. Flush the current group if not.
my $match_code;
if ($group_line_count) {
( $match_code, my $imax_align ) =
$self->check_match( $new_line, $base_line,
$rall_lines->[ $jline - 1 ],
$group_line_count );
if ( $match_code != 2 ) { end_rgroup($imax_align) }
}
# Store the new line
add_to_rgroup($jline);
if ( defined($j_terminal_match) ) {
# Decide if we should fix a terminal match. We can either:
# 1. fix it and prevent the sweep_lr from changing it, or
# 2. leave it alone and let sweep_lr try to fix it.
# The current logic is to fix it if:
# -it has not joined to previous lines,
# -and either the previous subgroup has just 1 line, or
# -this line matched but did not fit (so sweep won't work)
my $fixit;
if ( $group_line_count == 1 ) {
$fixit ||= $match_code;
if ( !$fixit ) {
if ( @{$rgroups} > 1 ) {
my ( $jbegx, $jendx ) = @{ $rgroups->[-2] };
my $nlines = $jendx - $jbegx + 1;
$fixit ||= $nlines <= 1;
}
}
}
if ($fixit) {
$base_line = $new_line;
my $col_now = $base_line->get_column($j_terminal_match);
# Ignore an undefined value as a defensive step; shouldn't
# normally happen.
$col_now = 0 unless defined($col_now);
my $pad = $col_matching_terminal - $col_now;
my $padding_available =
$base_line->get_available_space_on_right();
if ( $col_now && $pad > 0 && $pad <= $padding_available ) {
$base_line->increase_field_width( $j_terminal_match,
$pad );
}
# do not let sweep_left_to_right change an isolated 'else'
if ( !$new_line->{'is_terminal_ternary'} ) {
block_penultimate_match();
}
}
end_rgroup(-1);
}
# end the group if we know we cannot match next line.
elsif ( $new_line->{'end_group'} ) {
end_rgroup(-1);
}
else {
##ok: continue
}
} ## end loop over lines
end_rgroup(-1);
return ($rgroups);
} ## end sub sweep_top_down
}
sub two_line_pad {
my ( $line_m, $line, $imax_min ) = @_;
# Decide if two adjacent, isolated lines should be aligned
# Given:
# $line_m, $line = two isolated (list) lines
# imax_min = number of common alignment tokens
# Return:
# $pad_max = maximum suggested pad distance
# = 0 if alignment not recommended
# Allow alignment if the difference in the two unpadded line lengths
# is not more than either line length. The idea is to avoid
# aligning lines with very different field lengths, like these two:
# [
# 'VARCHAR', DBI::SQL_VARCHAR, undef, "'", "'", undef, 0, 1,
# 1, 0, 0, 0, undef, 0, 0
# ];
# Note that this is only for two lines which do not have alignment tokens
# in common with any other lines. It is intended for lists, but it might
# also be used for two non-list lines with a common leading '='.
my $rfield_lengths = $line->{'rfield_lengths'};
my $rfield_lengths_m = $line_m->{'rfield_lengths'};
# Safety check - shouldn't happen
return 0
if ( $imax_min >= @{$rfield_lengths}
|| $imax_min >= @{$rfield_lengths_m} );
my $lensum_m = 0;
my $lensum = 0;
foreach my $i ( 0 .. $imax_min ) {
$lensum_m += $rfield_lengths_m->[$i];
$lensum += $rfield_lengths->[$i];
}
my ( $lenmin, $lenmax ) =
$lensum >= $lensum_m ? ( $lensum_m, $lensum ) : ( $lensum, $lensum_m );
my $patterns_match;
if ( $line_m->{'list_type'} && $line->{'list_type'} ) {
$patterns_match = 1;
my $rpatterns_m = $line_m->{'rpatterns'};
my $rpatterns = $line->{'rpatterns'};
foreach my $i ( 0 .. $imax_min ) {
my $pat = $rpatterns->[$i];
my $pat_m = $rpatterns_m->[$i];
# VSN PATCH: allow numbers to match quotes
if ( $pat_m ne $pat && length($pat_m) eq length($pat) ) {
$pat =~ tr/n/Q/;
$pat_m =~ tr/n/Q/;
}
if ( $pat ne $pat_m ) { $patterns_match = 0; last; }
}
}
my $pad_max = $lenmax;
if ( !$patterns_match && $lenmax > 2 * $lenmin ) { $pad_max = 0 }
return $pad_max;
} ## end sub two_line_pad
sub sweep_left_to_right {
my ( $rlines, $rgroups, $group_level ) = @_;
# This is the second of two major sweeps to find alignments.
# The other is sweep_top_down.
# Given:
# $rlines = ref to hash of lines in this main alignment group
# $rgroups = ref to hash of subgroups
# $group_level = common indentation level of these lines
# Task:
# add leading alignments where possible
# So far we have divided the lines into groups having an equal number of
# identical alignments. Here we are going to look for common leading
# alignments between the different groups and align them when possible.
# For example, the three lines below are in three groups because each line
# has a different number of commas. In this routine we will sweep from
# left to right, aligning the leading commas as we go, but stopping if we
# hit the line length limit.
# my ( $num, $numi, $numj, $xyza, $ka, $xyzb, $kb, $aff, $error );
# my ( $i, $j, $error, $aff, $asum, $avec );
# my ( $km, $area, $varea );
# nothing to do if just one group
my $ng_max = @{$rgroups} - 1;
return if ( $ng_max <= 0 );
#---------------------------------------------------------------------
# Step 1: Loop over groups to find all common leading alignment tokens
#---------------------------------------------------------------------
my $line;
my $rtokens;
my $imax; # index of maximum non-side-comment alignment token
my $istop; # an optional stopping index
my $jbeg; # starting line index
my $jend; # ending line index
my $line_m;
my $rtokens_m;
my $imax_m;
my $istop_m;
my $jbeg_m;
my $jend_m;
my $istop_mm;
# Look at neighboring pairs of groups and form a simple list
# of all common leading alignment tokens. Foreach such match we
# store [$i, $ng], where
# $i = index of the token in the line (0,1,...)
# $ng is the second of the two groups with this common token
my @icommon;
# Hash to hold the maximum alignment change for any group
my %max_move;
# a small number of columns
my $short_pad = 4;
my $ng = -1;
foreach my $item ( @{$rgroups} ) {
$ng++;
$istop_mm = $istop_m;
# save _m values of previous group
$line_m = $line;
$rtokens_m = $rtokens;
$imax_m = $imax;
$istop_m = $istop;
$jbeg_m = $jbeg;
$jend_m = $jend;
# Get values for this group. Note that we just have to use values for
# one of the lines of the group since all members have the same
# alignments.
( $jbeg, $jend, $istop ) = @{$item};
$line = $rlines->[$jbeg];
$rtokens = $line->{'rtokens'};
$imax = $line->{'jmax'} - 2;
$istop = -1 if ( !defined($istop) );
$istop = $imax if ( $istop > $imax );
# Initialize on first group
next if ( $ng == 0 );
# Use the minimum index limit of the two groups
my $imax_min = $imax > $imax_m ? $imax_m : $imax;
# Also impose a limit if given.
if ( $istop_m < $imax_min ) {
$imax_min = $istop_m;
}
# Special treatment of two one-line groups isolated from other lines,
# unless they form a simple list or a terminal match. Otherwise the
# alignment can look strange in some cases.
my $list_type = $rlines->[$jbeg]->{'list_type'};
if (
$jend == $jbeg
&& $jend_m == $jbeg_m
&& ( $ng == 1 || $istop_mm < 0 )
&& ( $ng == $ng_max || $istop < 0 )
&& !$line->{'j_terminal_match'}
# Only do this for imperfect matches. This is normally true except
# when two perfect matches cannot form a group because the line
# length limit would be exceeded. In that case we can still try
# to match as many alignments as possible.
&& ( $imax != $imax_m || $istop_m != $imax_m )
)
{
# We will just align assignments and simple lists
next if ( $imax_min < 0 );
next
if ( $rtokens->[0] !~ /^=\d/
&& !$list_type );
# In this case we will limit padding to a short distance. This
# is a compromise to keep some vertical alignment but prevent large
# gaps, which do not look good for just two lines.
my $pad_max =
two_line_pad( $rlines->[$jbeg], $rlines->[$jbeg_m], $imax_min );
next if ( !$pad_max );
my $ng_m = $ng - 1;
$max_move{"$ng_m"} = $pad_max;
$max_move{"$ng"} = $pad_max;
}
# Loop to find all common leading tokens.
if ( $imax_min >= 0 ) {
foreach my $i ( 0 .. $imax_min ) {
my $tok = $rtokens->[$i];
my $tok_m = $rtokens_m->[$i];
last if ( $tok ne $tok_m );
push @icommon, [ $i, $ng, $tok ];
}
}
}
return unless @icommon;
#----------------------------------------------------------
# Step 2: Reorder and consolidate the list into a task list
#----------------------------------------------------------
# We have to work first from lowest token index to highest, then by group,
# sort our list first on token index then group number
@icommon = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @icommon;
# Make a task list of the form
# [$i, ng_beg, $ng_end, $tok], ..
# where
# $i is the index of the token to be aligned
# $ng_beg..$ng_end is the group range for this action
my @todo;
my ( $i, $ng_end, $tok );
foreach my $item (@icommon) {
my $ng_last = $ng_end;
my $i_last = $i;
( $i, $ng_end, $tok ) = @{$item};
my $ng_beg = $ng_end - 1;
if ( defined($ng_last) && $ng_beg == $ng_last && $i == $i_last ) {
my $var = pop(@todo);
$ng_beg = $var->[1];
}
my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
decode_alignment_token($tok);
push @todo, [ $i, $ng_beg, $ng_end, $raw_tok, $lev ];
}
#------------------------------
# Step 3: Execute the task list
#------------------------------
do_left_to_right_sweep(
{
rlines => $rlines,
rgroups => $rgroups,
rtodo => \@todo,
rmax_move => \%max_move,
short_pad => $short_pad,
group_level => $group_level,
}
);
return;
} ## end sub sweep_left_to_right
{ ## closure for sub do_left_to_right_sweep
my %is_good_alignment_token;
BEGIN {
# One of the most difficult aspects of vertical alignment is knowing
# when not to align. Alignment can go from looking very nice to very
# bad when overdone. In the sweep algorithm there are two special
# cases where we may need to limit padding to a '$short_pad' distance
# to avoid some very ugly formatting:
# 1. Two isolated lines with partial alignment
# 2. A 'tail-wag-dog' situation, in which a single terminal
# line with partial alignment could cause a significant pad
# increase in many previous lines if allowed to join the alignment.
# For most alignment tokens, we will allow only a small pad to be
# introduced (the hardwired $short_pad variable) . But for some 'good'
# alignments we can be less restrictive.
# These are 'good' alignments, which are allowed more padding:
my @q = qw( => = ? if unless or || { );
push @q, ',';
@is_good_alignment_token{@q} = (0) x scalar(@q);
# Promote a few of these to 'best', with essentially no pad limit:
$is_good_alignment_token{'='} = 1;
$is_good_alignment_token{'if'} = 1;
$is_good_alignment_token{'unless'} = 1;
$is_good_alignment_token{'=>'} = 1;
# Note the hash values are set so that:
# if ($is_good_alignment_token{$raw_tok}) => best
# if defined ($is_good_alignment_token{$raw_tok}) => good or best
} ## end BEGIN
sub move_to_common_column {
# This is a sub called by sub do_left_to_right_sweep to
# move the alignment column of token $itok to $col_want for a
# sequence of groups.
my ($rcall_hash) = @_;
my $rlines = $rcall_hash->{rlines};
my $rgroups = $rcall_hash->{rgroups};
my $rmax_move = $rcall_hash->{rmax_move};
my $ngb = $rcall_hash->{ngb};
my $nge = $rcall_hash->{nge};
my $itok = $rcall_hash->{itok};
my $col_want = $rcall_hash->{col_want};
my $raw_tok = $rcall_hash->{raw_tok};
return if ( !defined($ngb) || $nge <= $ngb );
foreach my $ng ( $ngb .. $nge ) {
my ( $jbeg, $jend_uu ) = @{ $rgroups->[$ng] };
my $line = $rlines->[$jbeg];
my $col = $line->get_column($itok);
my $move = $col_want - $col;
if ( $move > 0 ) {
# limit padding increase in isolated two lines
next
if ( defined( $rmax_move->{$ng} )
&& $move > $rmax_move->{$ng}
&& !$is_good_alignment_token{$raw_tok} );
$line->increase_field_width( $itok, $move );
}
elsif ( $move < 0 ) {
# spot to take special action on failure to move
}
else {
##ok: (move==0)
}
}
return;
} ## end sub move_to_common_column
sub do_left_to_right_sweep {
my ($rcall_hash) = @_;
# This is the worker routine for sub 'sweep_left_to_right'. Make
# vertical alignments by sweeping from left to right over groups
# of lines which have been located and prepared by the caller.
my $rlines = $rcall_hash->{rlines};
my $rgroups = $rcall_hash->{rgroups};
my $rtodo = $rcall_hash->{rtodo};
my $rmax_move = $rcall_hash->{rmax_move};
my $short_pad = $rcall_hash->{short_pad};
my $group_level = $rcall_hash->{group_level};
# $blocking_level[$nj is the level at a match failure between groups
# $ng-1 and $ng
my @blocking_level;
my $group_list_type = $rlines->[0]->{'list_type'};
foreach my $task ( @{$rtodo} ) {
my ( $itok, $ng_beg, $ng_end, $raw_tok, $lev ) = @{$task};
# Nothing to do for a single group
next if ( $ng_end <= $ng_beg );
my $ng_first; # index of the first group of a continuous sequence
my $col_want; # the common alignment column of a sequence of groups
my $col_limit; # maximum column before bumping into max line length
my $line_count_ng_m = 0;
my $jmax_m;
my $it_stop_m;
# Loop over the groups
# 'ix_' = index in the array of lines
# 'ng_' = index in the array of groups
# 'it_' = index in the array of tokens
my $ix_min = $rgroups->[$ng_beg]->[0];
my $ix_max = $rgroups->[$ng_end]->[1];
my $lines_total = $ix_max - $ix_min + 1;
foreach my $ng ( $ng_beg .. $ng_end ) {
my ( $ix_beg, $ix_end, $it_stop ) = @{ $rgroups->[$ng] };
my $line_count_ng = $ix_end - $ix_beg + 1;
# Important: note that since all lines in a group have a common
# alignments object, we just have to work on one of the lines
# (the first line). All of the rest will be changed
# automatically.
my $line = $rlines->[$ix_beg];
my $jmax = $line->{'jmax'};
# the maximum space without exceeding the line length:
my $avail = $line->get_available_space_on_right();
my $col = $line->get_column($itok);
my $col_max = $col + $avail;
# Initialize on first group
if ( !defined($col_want) ) {
$ng_first = $ng;
$col_want = $col;
$col_limit = $col_max;
$line_count_ng_m = $line_count_ng;
$jmax_m = $jmax;
$it_stop_m = $it_stop;
next;
}
# RULE: Throw a blocking flag upon encountering a token level
# different from the level of the first blocking token. For
# example, in the following example, if the = matches get
# blocked between two groups as shown, then we want to start
# blocking matches at the commas, which are at deeper level, so
# that we do not get the big gaps shown here:
# my $unknown3 = pack( "v", -2 );
# my $unknown4 = pack( "v", 0x09 );
# my $unknown5 = pack( "VVV", 0x06, 0x00, 0x00 );
# my $num_bbd_blocks = pack( "V", $num_lists );
# my $root_startblock = pack( "V", $root_start );
# my $unknown6 = pack( "VV", 0x00, 0x1000 );
# On the other hand, it is okay to keep matching at the same
# level such as in a simple list of commas and/or fat commas.
my $is_blocked = defined( $blocking_level[$ng] )
&& $lev > $blocking_level[$ng];
# TAIL-WAG-DOG RULE: prevent a 'tail-wag-dog' syndrome, meaning:
# Do not let one or two lines with a **different number of
# alignments** open up a big gap in a large block. For
# example, we will prevent something like this, where the first
# line pries open the rest:
# $worksheet->write( "B7", "http://www.perl.com", undef, $format );
# $worksheet->write( "C7", "", $format );
# $worksheet->write( "D7", "", $format );
# $worksheet->write( "D8", "", $format );
# $worksheet->write( "D8", "", $format );
# We should exclude from consideration two groups which are
# effectively the same but separated because one does not
# fit in the maximum allowed line length.
my $is_same_group =
$jmax == $jmax_m && $it_stop_m == $jmax_m - 2;
my $lines_above = $ix_beg - $ix_min;
my $lines_below = $lines_total - $lines_above;
# Increase the tolerable gap for certain favorable factors
my $factor = 1;
my $top_level = $lev == $group_level;
# Align best top level alignment tokens like '=', 'if', ...
# A factor of 10 allows a gap of up to 40 spaces
if ( $top_level && $is_good_alignment_token{$raw_tok} ) {
$factor = 10;
}
# Otherwise allow some minimal padding of good alignments
else {
if (
defined( $is_good_alignment_token{$raw_tok} )
# We have to be careful if there are just 2 lines.
# This two-line factor allows large gaps only for 2
# lines which are simple lists with fewer items on the
# second line. It gives results similar to previous
# versions of perltidy.
&& (
$lines_total > 2
|| ( $group_list_type
&& $jmax < $jmax_m
&& $top_level )
)
)
{
$factor += 1;
if ($top_level) {
$factor += 1;
}
}
}
my $is_big_gap;
if ( !$is_same_group ) {
$is_big_gap ||=
( $lines_above == 1
|| $lines_above == 2 && $lines_below >= 4 )
&& $col_want > $col + $short_pad * $factor;
$is_big_gap ||=
( $lines_below == 1
|| $lines_below == 2 && $lines_above >= 4 )
&& $col > $col_want + $short_pad * $factor;
}
# if match is limited by gap size, stop aligning at this level
if ($is_big_gap) {
$blocking_level[$ng] = $lev - 1;
}
# quit and restart if it cannot join this batch
if ( $col_want > $col_max
|| $col > $col_limit
|| $is_big_gap
|| $is_blocked )
{
# remember the level of the first blocking token
if ( !defined( $blocking_level[$ng] ) ) {
$blocking_level[$ng] = $lev;
}
move_to_common_column(
{
rlines => $rlines,
rgroups => $rgroups,
rmax_move => $rmax_move,
ngb => $ng_first,
nge => $ng - 1,
itok => $itok,
col_want => $col_want,
raw_tok => $raw_tok,
}
);
$ng_first = $ng;
$col_want = $col;
$col_limit = $col_max;
$line_count_ng_m = $line_count_ng;
$jmax_m = $jmax;
$it_stop_m = $it_stop;
next;
}
$line_count_ng_m += $line_count_ng;
# update the common column and limit
if ( $col > $col_want ) { $col_want = $col }
if ( $col_max < $col_limit ) { $col_limit = $col_max }
} ## end loop over groups
if ( $ng_end > $ng_first ) {
move_to_common_column(
{
rlines => $rlines,
rgroups => $rgroups,
rmax_move => $rmax_move,
ngb => $ng_first,
nge => $ng_end,
itok => $itok,
col_want => $col_want,
raw_tok => $raw_tok,
}
);
}
} ## end loop over tasks
return;
} ## end sub do_left_to_right_sweep
}
sub delete_selected_tokens {
my ( $line_obj, $ridel ) = @_;
# Given:
# $line_obj = the line to be modified
# $ridel = a ref to list of indexes to be deleted
# remove unused alignment token(s) to improve alignment chances
return if ( !defined($line_obj) || !defined($ridel) || !@{$ridel} );
my $jmax_old = $line_obj->{'jmax'};
my $rfields_old = $line_obj->{'rfields'};
my $rfield_lengths_old = $line_obj->{'rfield_lengths'};
my $rpatterns_old = $line_obj->{'rpatterns'};
my $rtokens_old = $line_obj->{'rtokens'};
my $j_terminal_match = $line_obj->{'j_terminal_match'};
use constant EXPLAIN_DELETE_SELECTED => 0;
local $LIST_SEPARATOR = '> <';
EXPLAIN_DELETE_SELECTED && print <
old jmax: $jmax_old
old tokens: <@{$rtokens_old}>
old patterns: <@{$rpatterns_old}>
old fields: <@{$rfields_old}>
old field_lengths: <@{$rfield_lengths_old}>
EOM
my $rfields_new = [];
my $rpatterns_new = [];
my $rtokens_new = [];
my $rfield_lengths_new = [];
# Convert deletion list to a hash to allow any order, multiple entries,
# and avoid problems with index values out of range
my %delete_me;
@delete_me{ @{$ridel} } = (1) x scalar( @{$ridel} );
my $pattern_0 = $rpatterns_old->[0];
my $field_0 = $rfields_old->[0];
my $field_length_0 = $rfield_lengths_old->[0];
push @{$rfields_new}, $field_0;
push @{$rfield_lengths_new}, $field_length_0;
push @{$rpatterns_new}, $pattern_0;
# Loop to either copy items or concatenate fields and patterns
my $jmin_del;
foreach my $j ( 0 .. $jmax_old - 1 ) {
my $token = $rtokens_old->[$j];
my $field = $rfields_old->[ $j + 1 ];
my $field_length = $rfield_lengths_old->[ $j + 1 ];
my $pattern = $rpatterns_old->[ $j + 1 ];
if ( !$delete_me{$j} ) {
push @{$rtokens_new}, $token;
push @{$rfields_new}, $field;
push @{$rpatterns_new}, $pattern;
push @{$rfield_lengths_new}, $field_length;
}
else {
if ( !defined($jmin_del) ) { $jmin_del = $j }
$rfields_new->[-1] .= $field;
$rfield_lengths_new->[-1] += $field_length;
$rpatterns_new->[-1] .= $pattern;
}
}
# ----- x ------ x ------ x ------
#t 0 1 2 <- token indexing
#f 0 1 2 3 <- field and pattern
my $jmax_new = @{$rfields_new} - 1;
$line_obj->{'rtokens'} = $rtokens_new;
$line_obj->{'rpatterns'} = $rpatterns_new;
$line_obj->{'rfields'} = $rfields_new;
$line_obj->{'rfield_lengths'} = $rfield_lengths_new;
$line_obj->{'jmax'} = $jmax_new;
# The value of j_terminal_match will be incorrect if we delete tokens prior
# to it. We will have to give up on aligning the terminal tokens if this
# happens.
if ( defined($j_terminal_match) && $jmin_del <= $j_terminal_match ) {
$line_obj->{'j_terminal_match'} = undef;
}
# update list type -
if ( $line_obj->{'list_seqno'} ) {
## This works, but for efficiency see if we need to make a change:
## decide_if_list($line_obj);
# An existing list will still be a list but with possibly different
# leading token
my $old_list_type = $line_obj->{'list_type'};
my $new_list_type = EMPTY_STRING;
if ( $rtokens_new->[0] =~ /^(=>|,)/ ) {
$new_list_type = $rtokens_new->[0];
}
if ( !$old_list_type || $old_list_type ne $new_list_type ) {
decide_if_list($line_obj);
}
}
EXPLAIN_DELETE_SELECTED && print <
new patterns: <@{$rpatterns_new}>
new fields: <@{$rfields_new}>
EOM
return;
} ## end sub delete_selected_tokens
{ ## closure for sub decode_alignment_token
# This routine is called repeatedly for each token, so it needs to be
# efficient. We can speed things up by remembering the inputs and outputs
# in a hash.
my %decoded_token;
sub initialize_decode {
# We will re-initialize the hash for each file. Otherwise, there is
# a danger that the hash can become arbitrarily large if a very large
# number of files is processed at once.
%decoded_token = ();
return;
} ## end sub initialize_decode
sub decode_alignment_token {
my ($tok) = @_;
# Unpack the values packed in an alignment token
# Given:
# $tok = an alignment token
# Returns:
# ( $raw_tok, $lev, $tag, $tok_count )
#
# Usage:
# my ( $raw_tok, $lev, $tag, $tok_count ) =
# decode_alignment_token($token);
# Alignment tokens have a trailing decimal level and optional tag (for
# commas):
# For example, the first comma in the following line
# sub banner { crlf; report( shift, '/', shift ); crlf }
# is decorated as follows:
# ,2+report-6 => (tok,lev,tag) =qw( , 2 +report-6)
# An optional token count may be appended with a leading dot.
# Currently this is only done for '=' tokens but this could change.
# For example, consider the following line:
# $nport = $port = shift || $name;
# The first '=' may either be '=0' or '=0.1' [level 0, first equals]
# The second '=' will be '=0.2' [level 0, second equals]
if ( defined( $decoded_token{$tok} ) ) {
return @{ $decoded_token{$tok} };
}
my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, EMPTY_STRING, 1 );
if ( $tok =~ /^(\D+)(\d+)([^\.]*)(\.(\d+))?$/ ) {
$raw_tok = $1;
$lev = $2;
$tag = $3 if ($3);
$tok_count = $5 if ($5);
}
my @vals = ( $raw_tok, $lev, $tag, $tok_count );
$decoded_token{$tok} = \@vals;
return @vals;
} ## end sub decode_alignment_token
}
sub delete_unmatched_tokens {
my ( $rlines, $group_level ) = @_;
# Remove as many obviously un-needed alignment tokens as possible.
# This will prevent them from interfering with the final alignment.
# Given:
# $rlines = ref to hash of all lines in this alignment group
# $group_level = their comment indentation level
# Return:
my $max_lev_diff = 0; # used to avoid a call to prune_tree
my $saw_side_comment = 0; # used to avoid a call for side comments
my $saw_signed_number = 0; # used to avoid a call for -vsn
# Handle no lines -- shouldn't happen
return unless @{$rlines};
# Handle a single line
if ( @{$rlines} == 1 ) {
my $line = $rlines->[0];
my $jmax = $line->{'jmax'};
my $length = $line->{'rfield_lengths'}->[$jmax];
$saw_side_comment = $length > 0;
return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
}
# ignore hanging side comments in these operations
my @filtered = grep { !$_->{'is_hanging_side_comment'} } @{$rlines};
my $rnew_lines = \@filtered;
$saw_side_comment = @filtered != @{$rlines};
$max_lev_diff = 0;
# nothing to do if all lines were hanging side comments
my $jmax = @{$rnew_lines} - 1;
return ( $max_lev_diff, $saw_side_comment, $saw_signed_number )
if ( $jmax < 0 );
#----------------------------------------------------
# Create a hash of alignment token info for each line
#----------------------------------------------------
( my $rline_hashes, my $requals_info, $saw_side_comment, $max_lev_diff ) =
make_alignment_info( $group_level, $rnew_lines, $saw_side_comment );
#------------------------------------------------------------
# Find independent subgroups of lines. Neighboring subgroups
# do not have a common alignment token.
#------------------------------------------------------------
my @subgroups;
push @subgroups, [ 0, $jmax ];
foreach my $jl ( 0 .. $jmax - 1 ) {
if ( $rnew_lines->[$jl]->{'end_group'} ) {
$subgroups[-1]->[1] = $jl;
push @subgroups, [ $jl + 1, $jmax ];
}
}
#-----------------------------------------------------------
# PASS 1 over subgroups to remove unmatched alignment tokens
#-----------------------------------------------------------
delete_unmatched_tokens_main_loop(
$group_level, $rnew_lines, \@subgroups,
$rline_hashes, $requals_info
);
#----------------------------------------------------------------
# PASS 2: Construct a tree of matched lines and delete some small
# deeper levels of tokens. They also block good alignments.
#----------------------------------------------------------------
prune_alignment_tree($rnew_lines) if ($max_lev_diff);
#--------------------------------------------
# PASS 3: compare all lines for common tokens
#--------------------------------------------
$saw_signed_number =
match_line_pairs( $rlines, $rnew_lines, \@subgroups, $group_level );
return ( $max_lev_diff, $saw_side_comment, $saw_signed_number );
} ## end sub delete_unmatched_tokens
sub make_alignment_info {
my ( $group_level, $rnew_lines, $saw_side_comment ) = @_;
# Create a hash of alignment token info for each line
# This info will be used to find common alignments
# Given:
# $group_level = common indentation level
# $rnew_lines = ref to hash of line info
# $saw_side_comment = true if there is a side comment
# Return:
# $rline_hashes = ref to hash with new line vars
# \@equals_info = ref to array with info on any '=' tokens
# $saw_side_comment = updated side comment flag
# $max_lev_diff = maximum level change seen
#----------------
# Loop over lines
#----------------
my $rline_hashes = [];
my @equals_info;
my @line_info; # no longer used
my $jmax = @{$rnew_lines} - 1;
my $max_lev_diff = 0;
foreach my $line ( @{$rnew_lines} ) {
my $rhash = {};
my $rtokens = $line->{'rtokens'};
my $rpatterns = $line->{'rpatterns'};
my $i = 0;
my ( $i_eq, $tok_eq, $pat_eq );
my ( $lev_min, $lev_max );
foreach my $tok ( @{$rtokens} ) {
my ( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token($tok);
if ( $tok ne '#' ) {
if ( !defined($lev_min) ) {
$lev_min = $lev;
$lev_max = $lev;
}
else {
if ( $lev < $lev_min ) { $lev_min = $lev }
if ( $lev > $lev_max ) { $lev_max = $lev }
}
}
else {
if ( !$saw_side_comment ) {
my $length = $line->{'rfield_lengths'}->[ $i + 1 ];
$saw_side_comment ||= $length;
}
}
# Possible future upgrade: for multiple matches,
# record [$i1, $i2, ..] instead of $i
$rhash->{$tok} =
[ $i, undef, undef, $raw_tok, $lev, $tag, $tok_count ];
# remember the first equals at line level
if ( !defined($i_eq) && $raw_tok eq '=' ) {
if ( $lev eq $group_level ) {
$i_eq = $i;
$tok_eq = $tok;
$pat_eq = $rpatterns->[$i];
}
}
$i++;
}
push @{$rline_hashes}, $rhash;
push @equals_info, [ $i_eq, $tok_eq, $pat_eq ];
push @line_info, [ $lev_min, $lev_max ];
if ( defined($lev_min) ) {
my $lev_diff = $lev_max - $lev_min;
if ( $lev_diff > $max_lev_diff ) { $max_lev_diff = $lev_diff }
}
}
#----------------------------------------------------
# Loop to compare each line pair and remember matches
#----------------------------------------------------
my $rtok_hash = {};
my $nr = 0;
foreach my $jl ( 0 .. $jmax - 1 ) {
my $nl = $nr;
$nr = 0;
my $jr = $jl + 1;
my $rhash_l = $rline_hashes->[$jl];
my $rhash_r = $rline_hashes->[$jr];
foreach my $tok ( keys %{$rhash_l} ) {
if ( defined( $rhash_r->{$tok} ) ) {
my $il = $rhash_l->{$tok}->[0];
my $ir = $rhash_r->{$tok}->[0];
$rhash_l->{$tok}->[2] = $ir;
$rhash_r->{$tok}->[1] = $il;
if ( $tok ne '#' ) {
push @{ $rtok_hash->{$tok} }, ( $jl, $jr );
$nr++;
}
}
}
# Set a line break if no matching tokens between these lines
# (this is not strictly necessary now but does not hurt)
if ( $nr == 0 && $nl > 0 ) {
$rnew_lines->[$jl]->{'end_group'} = 1;
}
# Also set a line break if both lines have simple equals but with
# different leading characters in patterns. This check is similar
# to one in sub check_match, and will prevent sub
# prune_alignment_tree from removing alignments which otherwise
# should be kept. This fix is rarely needed, but it can
# occasionally improve formatting.
# For example:
# my $name = $this->{Name};
# $type = $this->ctype($genlooptype) if defined $genlooptype;
# my $declini = ( $asgnonly ? "" : "\t$type *" );
# my $cast = ( $type ? "($type *)" : "" );
# The last two lines start with 'my' and will not match the
# previous line starting with $type, so we do not want
# prune_alignment tree to delete their ? : alignments at a deeper
# level.
my ( $i_eq_l, $tok_eq_l, $pat_eq_l ) = @{ $equals_info[$jl] };
my ( $i_eq_r, $tok_eq_r, $pat_eq_r ) = @{ $equals_info[$jr] };
if ( defined($i_eq_l) && defined($i_eq_r) ) {
# Also, do not align equals across a change in ci level
my $ci_jump = $rnew_lines->[$jl]->{'ci_level'} !=
$rnew_lines->[$jr]->{'ci_level'};
if (
$tok_eq_l eq $tok_eq_r
&& $i_eq_l == 0
&& $i_eq_r == 0
&& ( substr( $pat_eq_l, 0, 1 ) ne substr( $pat_eq_r, 0, 1 )
|| $ci_jump )
)
{
$rnew_lines->[$jl]->{'end_group'} = 1;
}
}
}
return ( $rline_hashes, \@equals_info, $saw_side_comment, $max_lev_diff );
} ## end sub make_alignment_info
sub delete_unmatched_tokens_main_loop {
my ( $group_level, $rnew_lines, $rsubgroups, $rline_hashes, $requals_info )
= @_;
#--------------------------------------------------------------
# Main loop over subgroups to remove unmatched alignment tokens
#--------------------------------------------------------------
# flag to allow skipping pass 2 - not currently used
my $saw_large_group;
my $has_terminal_match = $rnew_lines->[-1]->{'j_terminal_match'};
foreach my $item ( @{$rsubgroups} ) {
my ( $jbeg, $jend ) = @{$item};
my $nlines = $jend - $jbeg + 1;
#---------------------------------------------------
# Look for complete if/elsif/else and ternary blocks
#---------------------------------------------------
# We are looking for a common '$dividing_token' like these:
# if ( $b and $s ) { $p->{'type'} = 'a'; }
# elsif ($b) { $p->{'type'} = 'b'; }
# elsif ($s) { $p->{'type'} = 's'; }
# else { $p->{'type'} = ''; }
# ^----------- dividing_token
# my $severity =
# !$routine ? '[PFX]'
# : $routine =~ /warn.*_d\z/ ? '[DS]'
# : $routine =~ /ck_warn/ ? 'W'
# : $routine =~ /ckWARN\d*reg_d/ ? 'S'
# : $routine =~ /ckWARN\d*reg/ ? 'W'
# : $routine =~ /vWARN\d/ ? '[WDS]'
# : '[PFX]';
# ^----------- dividing_token
# Only look for groups which are more than 2 lines long. Two lines
# can get messed up doing this, probably due to the various
# two-line rules.
my $dividing_token;
my %token_line_count;
if ( $nlines > 2 ) {
foreach my $jj ( $jbeg .. $jend ) {
my %seen;
my $line = $rnew_lines->[$jj];
my $rtokens = $line->{'rtokens'};
foreach my $tok ( @{$rtokens} ) {
if ( !$seen{$tok} ) {
$seen{$tok}++;
$token_line_count{$tok}++;
}
}
}
foreach my $tok ( keys %token_line_count ) {
if ( $token_line_count{$tok} == $nlines ) {
if ( substr( $tok, 0, 1 ) eq '?'
|| substr( $tok, 0, 1 ) eq '{' && $tok =~ /^\{\d+if/ )
{
$dividing_token = $tok;
last;
}
}
}
}
#-------------------------------------------------------------
# Loop over subgroup lines to remove unwanted alignment tokens
#-------------------------------------------------------------
foreach my $jj ( $jbeg .. $jend ) {
my $line = $rnew_lines->[$jj];
my $rtokens = $line->{'rtokens'};
my $rhash = $rline_hashes->[$jj];
my $i_eq = $requals_info->[$jj]->[0];
my @idel;
my $imax = @{$rtokens} - 2;
my $delete_above_level;
my $deleted_assignment_token;
my $saw_dividing_token = EMPTY_STRING;
$saw_large_group ||= $nlines > 2 && $imax > 1;
# Loop over all alignment tokens
foreach my $i ( 0 .. $imax ) {
my $tok = $rtokens->[$i];
next if ( $tok eq '#' ); # shouldn't happen
my ( $iii_uu, $il, $ir, $raw_tok, $lev, $tag_uu, $tok_count ) =
@{ $rhash->{$tok} };
#------------------------------------------------------
# Here is the basic RULE: remove an unmatched alignment
# which does not occur in the surrounding lines.
#------------------------------------------------------
my $delete_me = !defined($il) && !defined($ir);
# Apply any user controls. Note that not all lines pass
# this way so they have to be applied elsewhere too.
my $align_ok = 1;
if (%valign_control_hash) {
$align_ok = $valign_control_hash{$raw_tok};
$align_ok = $valign_control_default
unless defined($align_ok);
$delete_me ||= !$align_ok;
}
# But now we modify this with exceptions...
# EXCEPTION 1: If we are in a complete ternary or
# if/elsif/else group, and this token is not on every line
# of the group, should we delete it to preserve overall
# alignment?
if ($dividing_token) {
if ( $token_line_count{$tok} >= $nlines ) {
$saw_dividing_token ||= $tok eq $dividing_token;
}
else {
# For shorter runs, delete toks to save alignment.
# For longer runs, keep toks after the '{' or '?'
# to allow sub-alignments within braces. The
# number 5 lines is arbitrary but seems to work ok.
$delete_me ||= ( $nlines < 5 || !$saw_dividing_token );
}
}
# EXCEPTION 2: Remove all tokens above a certain level
# following a previous deletion. For example, we have to
# remove tagged higher level alignment tokens following a
# '=>' deletion because the tags of higher level tokens
# will now be incorrect. For example, this will prevent
# aligning commas as follows after deleting the second '=>'
# $w->insert(
# ListBox => origin => [ 270, 160 ],
# size => [ 200, 55 ],
# );
if ( defined($delete_above_level) ) {
if ( $lev > $delete_above_level ) {
$delete_me ||= 1;
}
else { $delete_above_level = undef }
}
# EXCEPTION 3: Remove all but certain tokens after an
# assignment deletion.
if (
$deleted_assignment_token
&& ( $lev > $group_level
|| !$is_if_or{$raw_tok} )
)
{
$delete_me ||= 1;
}
# EXCEPTION 4: Do not touch the first line of a 2 line
# terminal match, such as below, because j_terminal has
# already been set.
# if ($tag) { $tago = "<$tag>"; $tagc = ""; }
# else { $tago = $tagc = ''; }
# But see snippets 'else1.t' and 'else2.t'
$delete_me = 0
if ( $jj == $jbeg
&& $has_terminal_match
&& $nlines == 2 );
# EXCEPTION 5: misc additional rules for commas and equals
if ( $delete_me && $tok_count == 1 ) {
# okay to delete second and higher copies of a token
# for a comma...
if ( $raw_tok eq ',' ) {
# Do not delete commas before an equals
$delete_me = 0
if ( defined($i_eq) && $i < $i_eq );
# Do not delete line-level commas
$delete_me = 0 if ( $lev <= $group_level );
}
# For an assignment at group level..
if ( $is_assignment{$raw_tok}
&& $lev == $group_level )
{
# Do not delete if it is the last alignment of
# multiple tokens; this will prevent some
# undesirable alignments
if ( $imax > 0 && $i == $imax ) {
$delete_me = 0;
}
# Otherwise, set a flag to delete most
# remaining tokens
else { $deleted_assignment_token = $raw_tok }
}
}
# Do not let a user exclusion be reactivated by above rules
$delete_me ||= !$align_ok;
#------------------------------------
# Add this token to the deletion list
#------------------------------------
if ($delete_me) {
push @idel, $i;
# update deletion propagation flags
if ( !defined($delete_above_level)
|| $lev < $delete_above_level )
{
# delete all following higher level alignments
$delete_above_level = $lev;
# but keep deleting after => to next lower level
# to avoid some bizarre alignments
if ( $raw_tok eq '=>' ) {
$delete_above_level = $lev - 1;
}
}
}
} # End loop over alignment tokens
# Process all deletion requests for this line
if (@idel) {
delete_selected_tokens( $line, \@idel );
}
} # End loop over lines
} ## end main loop over subgroups
return;
} ## end sub delete_unmatched_tokens_main_loop
sub match_line_pairs {
my ( $rlines, $rnew_lines, $rsubgroups, $group_level ) = @_;
# Compare each pair of lines and save information about common matches
# Given:
# $rlines = list of lines including hanging side comments
# $rnew_lines = list of lines without any hanging side comments
# $rsubgroups = list of subgroups of the new lines
# Return:
# $saw_signed_number = true if a field has a signed number
# (needed for --valign-signed-numbers)
# TODO:
# Maybe change: imax_pair => pair_match_info = ref to array
# = [$imax_align, $rMsg, ... ]
# This may eventually have multi-level match info
# Previous line vars
my ( $line_m, $rtokens_m, $rpatterns_m, $rfield_lengths_m, $imax_m,
$list_type_m, $ci_level_m );
# Current line vars
my ( $line, $rtokens, $rpatterns, $rfield_lengths, $imax, $list_type,
$ci_level );
# Return parameter to avoid calls to sub pad_signed_number_columns
my $saw_signed_number;
# loop over subgroups
foreach my $item ( @{$rsubgroups} ) {
my ( $jbeg, $jend ) = @{$item};
my $nlines = $jend - $jbeg + 1;
next if ( $nlines <= 1 );
# loop over lines in a subgroup
foreach my $jj ( $jbeg .. $jend ) {
$line_m = $line;
$rtokens_m = $rtokens;
$rpatterns_m = $rpatterns;
$rfield_lengths_m = $rfield_lengths;
$imax_m = $imax;
$list_type_m = $list_type;
$ci_level_m = $ci_level;
$line = $rnew_lines->[$jj];
$rtokens = $line->{'rtokens'};
$rpatterns = $line->{'rpatterns'};
$rfield_lengths = $line->{'rfield_lengths'};
$imax = @{$rtokens} - 2;
$list_type = $line->{'list_type'};
$ci_level = $line->{'ci_level'};
# Quick approximate check for signed numbers in this line.
# This speeds up large runs by about 0.5%
if ( !$saw_signed_number ) {
my $rfields = $line->{'rfields'};
foreach my $i ( 0 .. $imax + 1 ) {
next if ( index( $rpatterns->[$i], 'n' ) < 0 );
my $field = $rfields->[$i];
if ( index( $field, '-' ) >= 0
|| index( $field, '+' ) >= 0 )
{
$saw_signed_number = 1;
last;
}
}
}
# nothing to do for first line
next if ( $jj == $jbeg );
my $ci_jump = $ci_level - $ci_level_m;
my $imax_min = $imax_m < $imax ? $imax_m : $imax;
my $imax_align = -1;
# find number of leading common tokens
#---------------------------------
# No match to hanging side comment
#---------------------------------
if ( $line->{'is_hanging_side_comment'} ) {
# Should not get here; HSC's have been filtered out
$imax_align = -1;
}
#-----------------------------
# Handle comma-separated lists
#-----------------------------
elsif ( $list_type && $list_type eq $list_type_m ) {
# do not align lists across a ci jump with new list method
if ($ci_jump) { $imax_min = -1 }
my $i_nomatch = $imax_min + 1;
foreach my $i ( 0 .. $imax_min ) {
my $tok = $rtokens->[$i];
my $tok_m = $rtokens_m->[$i];
if ( $tok ne $tok_m ) {
$i_nomatch = $i;
last;
}
}
$imax_align = $i_nomatch - 1;
}
#-----------------
# Handle non-lists
#-----------------
else {
my $i_nomatch = $imax_min + 1;
foreach my $i ( 0 .. $imax_min ) {
my $tok = $rtokens->[$i];
my $tok_m = $rtokens_m->[$i];
if ( $tok ne $tok_m ) {
$i_nomatch = $i;
last;
}
my $pat = $rpatterns->[$i];
my $pat_m = $rpatterns_m->[$i];
# VSN PATCH: allow numbers to match quotes
if ( $pat_m ne $pat ) {
$pat =~ tr/n/Q/;
$pat_m =~ tr/n/Q/;
}
# If patterns don't match, we have to be careful...
if ( $pat_m ne $pat ) {
my $pad =
$rfield_lengths->[$i] - $rfield_lengths_m->[$i];
my $match_code = compare_patterns(
{
group_level => $group_level,
tok => $tok,
tok_m => $tok_m,
pat => $pat,
pat_m => $pat_m,
pad => $pad,
}
);
if ($match_code) {
if ( $match_code == 1 ) { $i_nomatch = $i }
elsif ( $match_code == 2 ) { $i_nomatch = 0 }
else { } ##ok
last;
}
}
}
$imax_align = $i_nomatch - 1;
}
$line_m->{'imax_pair'} = $imax_align;
} ## end loop over lines
# Put fence at end of subgroup
$line->{'imax_pair'} = -1;
} ## end loop over subgroups
# if there are hanging side comments, propagate the pair info down to them
# so that lines can just look back one line for their pair info.
if ( @{$rlines} > @{$rnew_lines} ) {
my $last_pair_info = -1;
foreach my $line_t ( @{$rlines} ) {
if ( $line_t->{'is_hanging_side_comment'} ) {
$line_t->{'imax_pair'} = $last_pair_info;
}
else {
$last_pair_info = $line_t->{'imax_pair'};
}
}
}
return $saw_signed_number;
} ## end sub match_line_pairs
sub compare_patterns {
my ($rcall_hash) = @_;
my $group_level = $rcall_hash->{group_level};
my $tok = $rcall_hash->{tok};
## my $tok_m = $rcall_hash->{tok_m};
my $pat = $rcall_hash->{pat};
my $pat_m = $rcall_hash->{pat_m};
my $pad = $rcall_hash->{pad};
# This is a helper routine for sub match_line_pairs to decide if patterns
# in two lines match well enough
# Given:
# $tok_m, $pat_m = token and pattern of first line
# $tok, $pat = token and pattern of second line
# $pad = 0 if no padding is needed, !=0 otherwise
# Return code:
# 0 = patterns match, continue
# 1 = no match
# 2 = no match, and lines do not match at all
my $GoToMsg = EMPTY_STRING;
my $return_code = 0;
use constant EXPLAIN_COMPARE_PATTERNS => 0;
my ( $alignment_token, $lev, $tag_uu, $tok_count_uu ) =
decode_alignment_token($tok);
# We have to be very careful about aligning commas
# when the pattern's don't match, because it can be
# worse to create an alignment where none is needed
# than to omit one. Here's an example where the ','s
# are not in named containers. The first line below
# should not match the next two:
# ( $a, $b ) = ( $b, $r );
# ( $x1, $x2 ) = ( $x2 - $q * $x1, $x1 );
# ( $y1, $y2 ) = ( $y2 - $q * $y1, $y1 );
if ( $alignment_token eq ',' ) {
# do not align commas unless they are in named
# containers
if ( $tok !~ /[A-Za-z]/ ) {
$return_code = 1;
$GoToMsg = "do not align commas in unnamed containers";
}
else {
$return_code = 0;
}
}
# do not align parens unless patterns match;
# large ugly spaces can occur in math expressions.
elsif ( $alignment_token eq '(' ) {
# But we can allow a match if the parens don't
# require any padding.
if ( $pad != 0 ) {
$return_code = 1;
$GoToMsg = "do not align '(' unless patterns match or pad=0";
}
else {
$return_code = 0;
}
}
# Handle an '=' alignment with different patterns to
# the left.
elsif ( $alignment_token eq '=' ) {
# It is best to be a little restrictive when
# aligning '=' tokens. Here is an example of
# two lines that we will not align:
# my $variable=6;
# $bb=4;
# The problem is that one is a 'my' declaration,
# and the other isn't, so they're not very similar.
# We will filter these out by comparing the first
# letter of the pattern. This is crude, but works
# well enough.
if ( substr( $pat_m, 0, 1 ) ne substr( $pat, 0, 1 ) ) {
$GoToMsg = "first character before equals differ";
$return_code = 1;
}
# The introduction of sub 'prune_alignment_tree'
# enabled alignment of lists left of the equals with
# other scalar variables. For example:
# my ( $D, $s, $e ) = @_;
# my $d = length $D;
# my $c = $e - $s - $d;
# But this would change formatting of a lot of scripts,
# so for now we prevent alignment of comma lists on the
# left with scalars on the left. We will also prevent
# any partial alignments.
# set return code 2 if the = is at line level, but
# set return code 1 if the = is below line level, i.e.
# sub new { my ( $p, $v ) = @_; bless \$v, $p }
# sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
elsif ( ( index( $pat_m, ',' ) >= 0 ) ne ( index( $pat, ',' ) >= 0 ) ) {
$GoToMsg = "mixed commas/no-commas before equals";
$return_code = 1;
if ( $lev eq $group_level ) {
$return_code = 2;
}
}
else {
$return_code = 0;
}
}
else {
$return_code = 0;
}
EXPLAIN_COMPARE_PATTERNS
&& $return_code
&& print {*STDOUT} "no match because $GoToMsg\n";
return $return_code;
} ## end sub compare_patterns
sub fat_comma_to_comma {
my ($str) = @_;
# Given:
# $str = a decorated fat comma alignment token
# Change '=>' to ','
# and remove any trailing decimal count because currently fat commas have a
# count and commas do not.
# For example, change '=>2+{-3.2' into ',2+{-3'
if ( $str =~ /^=>([^\.]*)/ ) { $str = ',' . $1 }
return $str;
} ## end sub fat_comma_to_comma
sub get_line_token_info {
my ($rlines) = @_;
# Given:
# $rlines = ref to array of lines in this group
# Scan lines of tokens and return summary information about the range of
# levels and patterns.
# First scan to check monotonicity. Here is an example of several
# lines which are monotonic. The = is the lowest level, and
# the commas are all one level deeper. So this is not nonmonotonic.
# $$d{"weeks"} = [ "w", "wk", "wks", "week", "weeks" ];
# $$d{"days"} = [ "d", "day", "days" ];
# $$d{"hours"} = [ "h", "hr", "hrs", "hour", "hours" ];
my @all_token_info;
my $all_monotonic = 1;
foreach my $jj ( 0 .. @{$rlines} - 1 ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->{'rtokens'};
my $last_lev;
my $is_monotonic = 1;
my $i = -1;
foreach my $tok ( @{$rtokens} ) {
$i++;
my ( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token($tok);
push @{ $all_token_info[$jj] },
[ $raw_tok, $lev, $tag, $tok_count ];
last if ( $tok eq '#' );
if ( $i > 0 && $lev < $last_lev ) { $is_monotonic = 0 }
$last_lev = $lev;
}
if ( !$is_monotonic ) { $all_monotonic = 0 }
}
my $rline_values = [];
foreach my $jj ( 0 .. @{$rlines} - 1 ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->{'rtokens'};
my $i = -1;
my ( $lev_min, $lev_max );
my $token_pattern_max = EMPTY_STRING;
my %saw_level;
my $is_monotonic = 1;
# find the index of the last token before the side comment
my $imax = @{$rtokens} - 2;
my $imax_true = $imax;
# If the entire group is monotonic, and the line ends in a comma list,
# walk it back to the first such comma. this will have the effect of
# making all trailing ragged comma lists match in the prune tree
# routine. these trailing comma lists can better be handled by later
# alignment rules.
# Treat fat commas the same as commas here by converting them to
# commas. This will improve the chance of aligning the leading parts
# of ragged lists.
my $tok_end = fat_comma_to_comma( $rtokens->[$imax] );
if ( $all_monotonic && $tok_end =~ /^,/ ) {
my $ii = $imax - 1;
while ( $ii >= 0
&& fat_comma_to_comma( $rtokens->[$ii] ) eq $tok_end )
{
$imax = $ii;
$ii--;
} ## end while ( $ii >= 0 && fat_comma_to_comma...)
}
# make a first pass to find level range
my $last_lev;
foreach my $tok ( @{$rtokens} ) {
$i++;
last if ( $i > $imax );
last if ( $tok eq '#' );
my ( $raw_tok_uu, $lev, $tag_uu, $tok_count_uu ) =
@{ $all_token_info[$jj]->[$i] };
last if ( $tok eq '#' );
$token_pattern_max .= $tok;
$saw_level{$lev}++;
if ( !defined($lev_min) ) {
$lev_min = $lev;
$lev_max = $lev;
}
else {
if ( $lev < $lev_min ) { $lev_min = $lev; }
if ( $lev > $lev_max ) { $lev_max = $lev; }
if ( $lev < $last_lev ) { $is_monotonic = 0 }
}
$last_lev = $lev;
}
# handle no levels
my $rtoken_patterns = {};
my $rtoken_indexes = {};
my @levs = sort { $a <=> $b } keys %saw_level;
if ( !defined($lev_min) ) {
$lev_min = -1;
$lev_max = -1;
$levs[0] = -1;
$rtoken_patterns->{$lev_min} = EMPTY_STRING;
$rtoken_indexes->{$lev_min} = [];
}
# handle one level
elsif ( $lev_max == $lev_min ) {
$rtoken_patterns->{$lev_max} = $token_pattern_max;
$rtoken_indexes->{$lev_max} = [ ( 0 .. $imax ) ];
}
# handle multiple levels
else {
$rtoken_patterns->{$lev_max} = $token_pattern_max;
$rtoken_indexes->{$lev_max} = [ ( 0 .. $imax ) ];
my $lev_top = pop @levs; # already did max level
my $itok = -1;
foreach my $tok ( @{$rtokens} ) {
$itok++;
last if ( $itok > $imax );
my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
@{ $all_token_info[$jj]->[$itok] };
last if ( $raw_tok eq '#' );
foreach my $lev_test (@levs) {
next if ( $lev > $lev_test );
$rtoken_patterns->{$lev_test} .= $tok;
push @{ $rtoken_indexes->{$lev_test} }, $itok;
}
}
push @levs, $lev_top;
}
push @{$rline_values},
[
$lev_min, $lev_max, $rtoken_patterns, \@levs,
$rtoken_indexes, $is_monotonic, $imax_true, $imax,
];
# debug
0 && do {
local $LIST_SEPARATOR = ')(';
print "lev_min=$lev_min, lev_max=$lev_max, levels=(@levs)\n";
foreach my $key ( sort keys %{$rtoken_patterns} ) {
print "$key => $rtoken_patterns->{$key}\n";
print "$key => @{$rtoken_indexes->{$key}}\n";
}
};
} ## end loop over lines
return ( $rline_values, $all_monotonic );
} ## end sub get_line_token_info
sub prune_alignment_tree {
my ($rlines) = @_;
# Given:
# $rlines = ref to array of lines in this group
# Prune the tree of alignments to limit depth of alignments
my $jmax = @{$rlines} - 1;
return if ( $jmax <= 0 );
# Vertical alignment in perltidy is done as an iterative process. The
# starting point is to mark all possible alignment tokens ('=', ',', '=>',
# etc) for vertical alignment. Then we have to delete all alignments
# which, if actually made, would detract from overall alignment. This
# is done in several phases of which this is one.
# In this routine we look at the alignments of a group of lines as a
# hierarchical tree. We will 'prune' the tree to limited depths if that
# will improve overall alignment at the lower depths.
# For each line we will be looking at its alignment patterns down to
# different fixed depths. For each depth, we include all lower depths and
# ignore all higher depths. We want to see if we can get alignment of a
# larger group of lines if we ignore alignments at some lower depth.
# Here is an # example:
# for (
# [ '$var', sub { join $_, "bar" }, 0, "bar" ],
# [ 'CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
# [ 'CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3" ],
# [ '$myvar', sub { my $var; join $var, "bar" }, 0, "bar" ],
# );
# In the above example, all lines have three commas at the lowest depth
# (zero), so if there were no other alignments, these lines would all
# align considering only the zero depth alignment token. But some lines
# have additional comma alignments at the next depth, so we need to decide
# if we should drop those to keep the top level alignments, or keep those
# for some additional low level alignments at the expense losing some top
# level alignments. In this case we will drop the deeper level commas to
# keep the entire collection aligned. But in some cases the decision could
# go the other way.
# The tree for this example at the zero depth has one node containing
# all four lines, since they are identical at zero level (three commas).
# At depth one, there are three 'children' nodes, namely:
# - lines 1 and 2, which have a single comma in the 'sub' at depth 1
# - line 3, which has 2 commas at depth 1
# - line4, which has a ';' and a ',' at depth 1
# There are no deeper alignments in this example.
# so the tree structure for this example is:
#
# depth 0 depth 1 depth 2
# [lines 1-4] -- [line 1-2] - (empty)
# | [line 3] - (empty)
# | [line 4] - (empty)
# We can carry this to any depth, but it is not really useful to go below
# depth 2. To cleanly stop there, we will consider depth 2 to contain all
# alignments at depth >=2.
use constant EXPLAIN_PRUNE => 0;
#-------------------------------------------------------------------
# Prune Tree Step 1. Start by scanning the lines and collecting info
#-------------------------------------------------------------------
# Note that the caller had this info but we have to redo this now because
# alignment tokens may have been deleted.
my ( $rline_values, $all_monotonic ) = get_line_token_info($rlines);
# If all the lines have levels which increase monotonically from left to
# right, then the sweep-left-to-right pass can do a better job of alignment
# than pruning, and without deleting alignments.
return if ($all_monotonic);
# Contents of $rline_values
# [
# $lev_min, $lev_max, $rtoken_patterns, \@levs,
# $rtoken_indexes, $is_monotonic, $imax_true, $imax,
# ];
# We can work to any depth, but there is little advantage to working
# to a a depth greater than 2
my $MAX_DEPTH = 2;
# This arrays will hold the tree of alignment tokens at different depths
# for these lines.
my @match_tree;
# Tree nodes contain these values:
# $match_tree[$depth] = [$jbeg, $jend, $n_parent, $level, $pattern,
# $nc_beg_p, $nc_end_p, $rindexes];
# where
# $depth = 0,1,2 = index of depth of the match
# $jbeg beginning index j of the range of lines in this match
# $jend ending index j of the range of lines in this match
# $n_parent = index of the containing group at $depth-1, if it exists
# $level = actual level of code being matched in this group
# $pattern = alignment pattern being matched
# $nc_beg_p = first child
# $nc_end_p = last child
# $rindexes = ref to token indexes
# the patterns and levels of the current group being formed at each depth
my ( @token_patterns_current, @levels_current, @token_indexes_current );
# the patterns and levels of the next line being tested at each depth
my ( @token_patterns_next, @levels_next, @token_indexes_next );
#-----------------------------------------------------------
# define a recursive worker subroutine for tree construction
#-----------------------------------------------------------
# This is a recursive routine which is called if a match condition changes
# at any depth when a new line is encountered. It ends the match node
# which changed plus all deeper nodes attached to it.
my $end_node;
$end_node = sub {
my ( $depth, $jl, $n_parent ) = @_;
# $depth is the tree depth
# $jl is the index of the line
# $n_parent is index of the parent node of this node
return if ( $depth > $MAX_DEPTH );
# end any current group at this depth
if ( $jl >= 0
&& defined( $match_tree[$depth] )
&& @{ $match_tree[$depth] }
&& defined( $levels_current[$depth] ) )
{
$match_tree[$depth]->[-1]->[1] = $jl;
}
# Define the index of the node we will create below
my $ng_self = 0;
if ( defined( $match_tree[$depth] ) ) {
$ng_self = @{ $match_tree[$depth] };
}
# end any next deeper child node(s)
$end_node->( $depth + 1, $jl, $ng_self );
# update the levels being matched
$token_patterns_current[$depth] = $token_patterns_next[$depth];
$token_indexes_current[$depth] = $token_indexes_next[$depth];
$levels_current[$depth] = $levels_next[$depth];
# Do not start a new group at this level if it is not being used
if ( !defined( $levels_next[$depth] )
|| $depth > 0
&& $levels_next[$depth] <= $levels_next[ $depth - 1 ] )
{
return;
}
# Create a node for the next group at this depth. We initially assume
# that it will continue to $jmax, and correct that later if the node
# ends earlier.
push @{ $match_tree[$depth] },
[
$jl + 1, $jmax, $n_parent, $levels_current[$depth],
$token_patterns_current[$depth],
undef, undef, $token_indexes_current[$depth],
];
return;
}; ## end $end_node = sub
#-----------------------------------------------------
# Prune Tree Step 2. Loop to form the tree of matches.
#-----------------------------------------------------
foreach my $jp ( 0 .. $jmax ) {
# working with two adjacent line indexes, 'm'=minus, 'p'=plus
my $jm = $jp - 1;
# Pull out needed values for the next line
my ( $lev_min_uu, $lev_max_uu, $rtoken_patterns, $rlevs,
$rtoken_indexes, $is_monotonic_uu, $imax_true_uu, $imax_uu )
= @{ $rline_values->[$jp] };
# Transfer levels and patterns for this line to the working arrays.
# If the number of levels differs from our chosen MAX_DEPTH ...
# if fewer than MAX_DEPTH: leave levels at missing depths undefined
# if more than MAX_DEPTH: set the MAX_DEPTH level to be the maximum
@levels_next = @{$rlevs}[ 0 .. $MAX_DEPTH ];
if ( @{$rlevs} > $MAX_DEPTH ) {
$levels_next[$MAX_DEPTH] = $rlevs->[-1];
}
my $depth = 0;
foreach my $item (@levels_next) {
$token_patterns_next[$depth] =
defined($item) ? $rtoken_patterns->{$item} : undef;
$token_indexes_next[$depth] =
defined($item) ? $rtoken_indexes->{$item} : undef;
$depth++;
}
# Look for a change in match groups...
# Initialize on the first line
if ( $jp == 0 ) {
my $n_parent;
$end_node->( 0, $jm, $n_parent );
}
# End groups if a hard flag has been set
elsif ( $rlines->[$jm]->{'end_group'} ) {
my $n_parent;
$end_node->( 0, $jm, $n_parent );
}
# Continue at hanging side comment
elsif ( $rlines->[$jp]->{'is_hanging_side_comment'} ) {
next;
}
# Otherwise see if anything changed and update the tree if so
else {
foreach my $dep ( 0 .. $MAX_DEPTH ) {
my $def_current = defined( $token_patterns_current[$dep] );
my $def_next = defined( $token_patterns_next[$dep] );
last if ( !$def_current && !$def_next );
if ( !$def_current
|| !$def_next
|| $token_patterns_current[$dep] ne
$token_patterns_next[$dep] )
{
my $n_parent;
if ( $dep > 0 && defined( $match_tree[ $dep - 1 ] ) ) {
$n_parent = @{ $match_tree[ $dep - 1 ] } - 1;
}
$end_node->( $dep, $jm, $n_parent );
last;
}
}
}
} ## end loop to form tree of matches
#---------------------------------------------------------
# Prune Tree Step 3. Make links from parent to child nodes
#---------------------------------------------------------
# It seemed cleaner to do this as a separate step rather than during tree
# construction. The children nodes have links up to the parent node which
# created them. Now make links in the opposite direction, so the parents
# can find the children. We store the range of children nodes ($nc_beg,
# $nc_end) of each parent with two additional indexes in the original array.
# These will be undef if no children.
foreach my $depth ( reverse( 1 .. $MAX_DEPTH ) ) {
next unless defined( $match_tree[$depth] );
my $nc_max = @{ $match_tree[$depth] } - 1;
my $np_now;
foreach my $nc ( 0 .. $nc_max ) {
my $np = $match_tree[$depth]->[$nc]->[2];
if ( !defined($np) ) {
# shouldn't happen
#print STDERR "lost child $np at depth $depth\n";
next;
}
if ( !defined($np_now) || $np != $np_now ) {
$np_now = $np;
$match_tree[ $depth - 1 ]->[$np]->[5] = $nc;
}
$match_tree[ $depth - 1 ]->[$np]->[6] = $nc;
}
} ## end loop to make links down to the child nodes
EXPLAIN_PRUNE > 0 && do {
print "Tree complete. Found these groups:\n";
foreach my $depth ( 0 .. $MAX_DEPTH ) {
Dump_tree_groups( \@{ $match_tree[$depth] }, "depth=$depth" );
}
};
#------------------------------------------------------
# Prune Tree Step 4. Make a list of nodes to be deleted
#------------------------------------------------------
# list of lines with tokens to be deleted:
# [$jbeg, $jend, $level_keep]
# $jbeg..$jend is the range of line indexes,
# $level_keep is the minimum level to keep
my @delete_list;
# We work with a list of nodes to visit at the next deeper depth.
my @todo_list;
if ( defined( $match_tree[0] ) ) {
@todo_list = ( 0 .. @{ $match_tree[0] } - 1 );
}
foreach my $depth ( 0 .. $MAX_DEPTH ) {
last if ( !@todo_list );
my @todo_next;
foreach my $np (@todo_list) {
my ( $jbeg_p, $jend_p, $np_p_uu, $lev_p, $pat_p_uu, $nc_beg_p,
$nc_end_p, $rindexes_p_uu )
= @{ $match_tree[$depth]->[$np] };
my $nlines_p = $jend_p - $jbeg_p + 1;
# nothing to do if no children
next unless defined($nc_beg_p);
# Define the number of lines to either keep or delete a child node.
# This is the key decision we have to make. We want to delete
# short runs of matched lines, and keep long runs. It seems easier
# for the eye to follow breaks in monotonic level changes than
# non-monotonic level changes. For example, the following looks
# best if we delete the lower level alignments:
# [1] ~~ [];
# [ ["foo"], ["bar"] ] ~~ [ qr/o/, qr/a/ ];
# [ qr/o/, qr/a/ ] ~~ [ ["foo"], ["bar"] ];
# [ "foo", "bar" ] ~~ [ qr/o/, qr/a/ ];
# [ qr/o/, qr/a/ ] ~~ [ "foo", "bar" ];
# $deep1 ~~ $deep1;
# So we will use two thresholds.
my $nmin_mono = $depth + 2;
my $nmin_non_mono = $depth + 6;
if ( $nmin_mono > $nlines_p - 1 ) {
$nmin_mono = $nlines_p - 1;
}
if ( $nmin_non_mono > $nlines_p - 1 ) {
$nmin_non_mono = $nlines_p - 1;
}
# loop to keep or delete each child node
foreach my $nc ( $nc_beg_p .. $nc_end_p ) {
my ( $jbeg_c, $jend_c, $np_c_uu, $lev_c_uu, $pat_c_uu,
$nc_beg_c_uu, $nc_end_c_uu )
= @{ $match_tree[ $depth + 1 ]->[$nc] };
my $nlines_c = $jend_c - $jbeg_c + 1;
my $is_monotonic = $rline_values->[$jbeg_c]->[5];
my $nmin = $is_monotonic ? $nmin_mono : $nmin_non_mono;
if ( $nlines_c < $nmin ) {
##print "deleting child, nlines=$nlines_c, nmin=$nmin\n";
push @delete_list, [ $jbeg_c, $jend_c, $lev_p ];
}
else {
##print "keeping child, nlines=$nlines_c, nmin=$nmin\n";
push @todo_next, $nc;
}
}
}
@todo_list = @todo_next;
} ## end loop to mark nodes to delete
#------------------------------------------------------------
# Prune Tree Step 5. Loop to delete selected alignment tokens
#------------------------------------------------------------
foreach my $item (@delete_list) {
my ( $jbeg, $jend, $level_keep ) = @{$item};
foreach my $jj ( $jbeg .. $jend ) {
my $line = $rlines->[$jj];
my @idel;
my $rtokens = $line->{'rtokens'};
my $imax = @{$rtokens} - 2;
foreach my $i ( 0 .. $imax ) {
my $tok = $rtokens->[$i];
my ( $raw_tok_uu, $lev, $tag_uu, $tok_count_uu ) =
decode_alignment_token($tok);
if ( $lev > $level_keep ) {
push @idel, $i;
}
}
if (@idel) {
delete_selected_tokens( $line, \@idel );
}
}
} ## end loop to delete selected alignment tokens
return;
} ## end sub prune_alignment_tree
sub Dump_tree_groups {
my ( $rgroup, $msg ) = @_;
# Debug routine
print "$msg\n";
local $LIST_SEPARATOR = ')(';
foreach my $item ( @{$rgroup} ) {
my @fix = @{$item};
foreach my $val (@fix) { $val = "undef" unless defined($val); }
$fix[4] = "...";
print "(@fix)\n";
}
return;
} ## end sub Dump_tree_groups
# This test did not give sufficiently better results to use as an update,
# but the flag is kept as a starting point for future testing.
use constant TEST_MARGINAL_EQ_ALIGNMENT => 0;
sub is_marginal_match {
my ( $line_0, $line_1, $group_level, $imax_align, $imax_prev ) = @_;
# Decide if we should undo some or all of the common alignments of a
# group of just two lines.
# Given:
# $line_0 and $line_1 - the two lines
# $group_level = the indentation level of the group being processed
# $imax_align = the maximum index of the common alignment tokens
# of the two lines
# $imax_prev = the maximum index of the common alignment tokens
# with the line before $line_0 (=-1 of does not exist)
# Return:
# $is_marginal = true if the two lines should NOT be fully aligned
# = false if the two lines can remain fully aligned
# $imax_align = the index of the highest alignment token shared by
# these two lines to keep if the match is marginal.
# When we have an alignment group of just two lines like this, we are
# working in the twilight zone of what looks good and what looks bad.
# This routine is a collection of rules which work have been found to
# work fairly well, but it will need to be updated from time to time.
my $is_marginal = 0;
#---------------------------------------
# Always align certain special cases ...
#---------------------------------------
if (
# always keep alignments of a terminal else or ternary
defined( $line_1->{'j_terminal_match'} )
# always align lists
|| $line_0->{'list_type'}
# always align hanging side comments
|| $line_1->{'is_hanging_side_comment'}
)
{
return ( $is_marginal, $imax_align );
}
my $jmax_0 = $line_0->{'jmax'};
my $jmax_1 = $line_1->{'jmax'};
my $rtokens_1 = $line_1->{'rtokens'};
## my $rtokens_0 = $line_0->{'rtokens'};
my $rfield_lengths_0 = $line_0->{'rfield_lengths'};
my $rfield_lengths_1 = $line_1->{'rfield_lengths'};
my $rpatterns_0 = $line_0->{'rpatterns'};
my $rpatterns_1 = $line_1->{'rpatterns'};
my $imax_next = $line_1->{'imax_pair'};
# We will scan the alignment tokens and set a flag '$is_marginal' if
# it seems that the an alignment would look bad.
my $max_pad = 0;
my $saw_good_alignment = 0;
my $saw_if_or; # if we saw an 'if' or 'or' at group level
my $raw_tokb = EMPTY_STRING; # first token seen at group level
my $jfirst_bad;
my $line_ending_fat_comma; # is last token just a '=>' ?
my $j0_eq_pad;
my $j0_max_pad = 0;
foreach my $j ( 0 .. $jmax_1 - 2 ) {
my ( $raw_tok, $lev, $tag_uu, $tok_count_uu ) =
decode_alignment_token( $rtokens_1->[$j] );
if ( $raw_tok && $lev == $group_level ) {
if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
$saw_if_or ||= $is_if_or{$raw_tok};
}
# When the first of the two lines ends in a bare '=>' this will
# probably be marginal match. (For a bare =>, the next field length
# will be 2 or 3, depending on side comment)
$line_ending_fat_comma =
$j == $jmax_1 - 2
&& $raw_tok eq '=>'
&& $rfield_lengths_0->[ $j + 1 ] <= 3;
my $pad = $rfield_lengths_1->[$j] - $rfield_lengths_0->[$j];
if ( $j == 0 ) {
$pad += $line_1->{'leading_space_count'} -
$line_0->{'leading_space_count'};
# Remember the pad at a leading equals
if ( $raw_tok eq '=' && $lev == $group_level ) {
$j0_eq_pad = $pad;
$j0_max_pad =
0.5 * ( $rfield_lengths_1->[0] + $rfield_lengths_0->[0] );
$j0_max_pad = 4 if ( $j0_max_pad < 4 );
}
}
if ( $pad < 0 ) { $pad = -$pad }
if ( $pad > $max_pad ) { $max_pad = $pad }
if ( $is_good_marginal_alignment{$raw_tok}
&& !$line_ending_fat_comma )
{
$saw_good_alignment = 1;
}
else {
$jfirst_bad = $j unless defined($jfirst_bad);
}
my $pat_0 = $rpatterns_0->[$j];
my $pat_1 = $rpatterns_1->[$j];
if ( $pat_0 ne $pat_1 && length($pat_0) eq length($pat_1) ) {
$pat_0 =~ tr/n/Q/;
$pat_1 =~ tr/n/Q/;
}
if ( $pat_0 ne $pat_1 ) {
# Flag this as a marginal match since patterns differ.
# Normally, we will not allow just two lines to match if
# marginal. But we can allow matching in some specific cases.
$jfirst_bad = $j if ( !defined($jfirst_bad) );
$is_marginal = 1 if ( $is_marginal == 0 );
if ( $raw_tok eq '=' ) {
# Here is an example of a marginal match:
# $done{$$op} = 1;
# $op = compile_bblock($op);
# The left tokens are both identifiers, but
# one accesses a hash and the other doesn't.
# We'll let this be a tentative match and undo
# it later if we don't find more than 2 lines
# in the group.
$is_marginal = 2;
}
}
}
$is_marginal = 1 if ( $is_marginal == 0 && $line_ending_fat_comma );
# Turn off the "marginal match" flag in some cases...
# A "marginal match" occurs when the alignment tokens agree
# but there are differences in the other tokens (patterns).
# If we leave the marginal match flag set, then the rule is that we
# will align only if there are more than two lines in the group.
# We will turn of the flag if we almost have a match
# and either we have seen a good alignment token or we
# just need a small pad (2 spaces) to fit. These rules are
# the result of experimentation. Tokens which misaligned by just
# one or two characters are annoying. On the other hand,
# large gaps to less important alignment tokens are also annoying.
if ( $is_marginal == 1
&& ( $saw_good_alignment || $max_pad < 3 ) )
{
$is_marginal = 0;
}
# We will use the line endings to help decide on alignments...
# See if the lines end with semicolons...
my $sc_term0;
my $sc_term1;
if ( $jmax_0 < 1 || $jmax_1 < 1 ) {
# shouldn't happen
}
else {
my $pat0 = $rpatterns_0->[ $jmax_0 - 1 ];
my $pat1 = $rpatterns_1->[ $jmax_1 - 1 ];
$sc_term0 = $pat0 =~ /;b?$/;
$sc_term1 = $pat1 =~ /;b?$/;
}
if ( !$is_marginal && !$sc_term0 ) {
# First line of assignment should be semicolon terminated.
# For example, do not align here:
# $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
# $$href{-NUM_DIRS} = 0;
if ( $is_assignment{$raw_tokb} ) {
$is_marginal = 1;
}
}
# Try to avoid some undesirable alignments of opening tokens
# for example, the space between grep and { here:
# return map { ( $_ => $_ ) }
# grep { /$handles/ } $self->_get_delegate_method_list;
$is_marginal ||=
( $raw_tokb eq '(' || $raw_tokb eq '{' )
&& $jmax_1 == 2
&& $sc_term0 ne $sc_term1;
#---------------------------------------
# return if this is not a marginal match
#---------------------------------------
if ( !$is_marginal ) {
return ( $is_marginal, $imax_align );
}
# Undo the marginal match flag in certain cases,
# Two lines with a leading equals-like operator are allowed to
# align if the patterns to the left of the equals are the same.
# For example the following two lines are a marginal match but have
# the same left side patterns, so we will align the equals.
# my $orig = my $format = "^<<<<< ~~\n";
# my $abc = "abc";
# But these have a different left pattern so they will not be
# aligned
# $xmldoc .= $`;
# $self->{'leftovers'} .= "[0];
my $pat1 = $rpatterns_1->[0];
#---------------------------------------------------------
# Turn off the marginal flag for some types of assignments
#---------------------------------------------------------
if ( $is_assignment{$raw_tokb} ) {
# undo marginal flag if first line is semicolon terminated
# and leading patters match
if ($sc_term0) { # && $sc_term1) {
$is_marginal = $pat0 ne $pat1;
}
}
elsif ( $raw_tokb eq '=>' ) {
# undo marginal flag if patterns match
$is_marginal = $pat0 ne $pat1 || $line_ending_fat_comma;
}
elsif ( $raw_tokb eq '=~' ) {
# undo marginal flag if both lines are semicolon terminated
# and leading patters match
if ( $sc_term1 && $sc_term0 ) {
$is_marginal = $pat0 ne $pat1;
}
}
else {
##ok: (none of the above)
}
#-----------------------------------------------------
# Turn off the marginal flag if we saw an 'if' or 'or'
#-----------------------------------------------------
# A trailing 'if' and 'or' often gives a good alignment
# For example, we can align these:
# return -1 if $_[0] =~ m/^CHAPT|APPENDIX/;
# return $1 + 0 if $_[0] =~ m/^SECT(\d*)$/;
# or
# $d_in_m[2] = 29 if ( &Date_LeapYear($y) );
# $d = $d_in_m[$m] if ( $d > $d_in_m[$m] );
if ($saw_if_or) {
# undo marginal flag if both lines are semicolon terminated
if ( $sc_term0 && $sc_term1 ) {
$is_marginal = 0;
}
}
# For a marginal match, only keep matches before the first 'bad' match
if ( $is_marginal
&& defined($jfirst_bad)
&& $imax_align > $jfirst_bad - 1 )
{
$imax_align = $jfirst_bad - 1;
}
#----------------------------------------------------------
# Allow sweep to match lines with leading '=' in some cases
#----------------------------------------------------------
if ( $imax_align < 0 && defined($j0_eq_pad) ) {
if (
# If there is a following line with leading equals, or
# preceding line with leading equals, then let the sweep align
# them without restriction. For example, the first two lines
# here are a marginal match, but they are followed by a line
# with leading equals, so the sweep-lr logic can align all of
# the lines:
# $date[1] = $month_to_num{ $date[1] }; # <--line_0
# @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
# $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
# $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
# Likewise, if we reverse the two pairs we want the same result
# $day = sprintf( "%04d/%02d/%02d", @date[ 2, 1, 0 ] );
# $time = sprintf( "%02d:%02d:%02d", @date[ 3 .. 5 ] );
# $date[1] = $month_to_num{ $date[1] }; # <--line_0
# @xdate = split( /[:\/\s]/, $log->field('t') ); # <--line_1
(
$imax_next >= 0
|| $imax_prev >= 0
|| TEST_MARGINAL_EQ_ALIGNMENT
)
&& $j0_eq_pad >= -$j0_max_pad
&& $j0_eq_pad <= $j0_max_pad
)
{
# But do not do this if there is a comma before the '='.
# For example, the first two lines below have commas and
# therefore are not allowed to align with lines 3 & 4:
# my ( $x, $y ) = $self->Size(); #<--line_0
# my ( $left, $top, $right, $bottom ) = $self->Window(); #<--l_1
# my $vx = $right - $left;
# my $vy = $bottom - $top;
if ( $rpatterns_0->[0] !~ /,/ && $rpatterns_1->[0] !~ /,/ ) {
$imax_align = 0;
}
}
}
return ( $is_marginal, $imax_align );
} ## end sub is_marginal_match
sub get_extra_leading_spaces {
my ( $rlines, $rgroups ) = @_;
#----------------------------------------------------------
# Define any extra indentation space (for the -lp option).
# Here is why:
# If a list has side comments, sub scan_list must dump the
# list before it sees everything. When this happens, it sets
# the indentation to the standard scheme, but notes how
# many spaces it would have liked to use. We may be able
# to recover that space here in the event that all of the
# lines of a list are back together again.
#----------------------------------------------------------
return 0 if ( !@{$rlines} || !@{$rgroups} );
my $object = $rlines->[0]->{'indentation'};
return 0 if ( !ref($object) );
my $extra_leading_spaces = 0;
my $extra_indentation_spaces_wanted = get_recoverable_spaces($object);
return ($extra_leading_spaces) if ( !$extra_indentation_spaces_wanted );
my $min_spaces = $extra_indentation_spaces_wanted;
if ( $min_spaces > 0 ) { $min_spaces = 0 }
# loop over all groups
my $ng = -1;
my $ngroups = @{$rgroups};
foreach my $item ( @{$rgroups} ) {
$ng++;
my ( $jbeg, $jend ) = @{$item};
foreach my $j ( $jbeg .. $jend ) {
next if ( $j == 0 );
# all indentation objects must be the same
if ( $object != $rlines->[$j]->{'indentation'} ) {
return 0;
}
}
# find the maximum space without exceeding the line length for this group
my $avail = $rlines->[$jbeg]->get_available_space_on_right();
my $spaces =
( $avail > $extra_indentation_spaces_wanted )
? $extra_indentation_spaces_wanted
: $avail;
#--------------------------------------------------------
# Note: min spaces can be negative; for example with -gnu
# f(
# do { 1; !!(my $x = bless []); }
# );
#--------------------------------------------------------
# The following rule is needed to match older formatting:
# For multiple groups, we will keep spaces non-negative.
# For a single group, we will allow a negative space.
if ( $ngroups > 1 && $spaces < 0 ) { $spaces = 0 }
# update the minimum spacing
if ( $ng == 0 || $spaces < $extra_leading_spaces ) {
$extra_leading_spaces = $spaces;
}
}
# update the indentation object because with -icp the terminal
# ');' will use the same adjustment.
$object->permanently_decrease_available_spaces( -$extra_leading_spaces );
return $extra_leading_spaces;
} ## end sub get_extra_leading_spaces
sub forget_side_comment {
my ($self) = @_;
$self->[_last_side_comment_column_] = 0;
return;
}
sub is_good_side_comment_column {
my ( $self, $line, $line_number, $level, $num5 ) = @_;
# Upon encountering the first side comment of a group, decide if
# a previous side comment should be forgotten. This involves
# checking several rules.
# Given:
# $line = ref to info hash for the line of interest
# $line_number = number of this line in the output stream
# $level = indentation level of this line
# $num5 = ..see comments below
# Return:
# true to KEEP old comment location
# false to FORGET old comment location
my $KEEP = 1;
my $FORGET = 0;
my $rfields = $line->{'rfields'};
my $is_hanging_side_comment = $line->{'is_hanging_side_comment'};
# RULE1: Never forget comment before a hanging side comment
return $KEEP if ($is_hanging_side_comment);
# RULE2: Forget a side comment after a short line difference,
# where 'short line difference' is computed from a formula.
# Using a smooth formula helps minimize sudden large changes.
my $line_diff = $line_number - $self->[_last_side_comment_line_number_];
my $alev_diff = abs( $level - $self->[_last_side_comment_level_] );
# '$num5' is the number of comments in the first 5 lines after the first
# comment. It is needed to keep a compact group of side comments from
# being influenced by a more distant side comment.
$num5 = 1 if ( !$num5 );
# Some values:
# $adiff $num5 $short_diff
# 0 * 12
# 1 1 6
# 1 2 4
# 1 3 3
# 1 4 2
# 2 1 4
# 2 2 2
# 2 3 1
# 3 1 3
# 3 2 1
my $short_diff = SC_LONG_LINE_DIFF / ( 1 + $alev_diff * $num5 );
return $FORGET
if ( $line_diff > $short_diff
|| !$rOpts_valign_side_comments );
# RULE3: Forget a side comment if this line is at lower level and
# ends a block
my $last_sc_level = $self->[_last_side_comment_level_];
return $FORGET
if ( $level < $last_sc_level
&& $is_closing_block_type{ substr( $rfields->[0], 0, 1 ) } );
# RULE 4: Forget the last side comment if this comment might join a cached
# line ...
if ( my $cached_line_type = get_cached_line_type() ) {
# ... otherwise side comment alignment will get messed up.
# For example, in the following test script
# with using 'perltidy -sct -act=2', the last comment would try to
# align with the previous and then be in the wrong column when
# the lines are combined:
# foreach $line (
# [0, 1, 2], [3, 4, 5], [6, 7, 8], # rows
# [0, 3, 6], [1, 4, 7], [2, 5, 8], # columns
# [0, 4, 8], [2, 4, 6]
# ) # diagonals
return $FORGET
if ( $cached_line_type == 2 || $cached_line_type == 4 );
}
# Otherwise, keep it alive
return $KEEP;
} ## end sub is_good_side_comment_column
sub align_side_comments {
my ( $self, $rlines, $rgroups ) = @_;
# Align any side comments in this batch of lines
# Given:
# $rlines - the lines
# $rgroups - the partition of the lines into groups
#
# We will be working group-by-group because all side comments
# (real or fake) in each group are already aligned. So we just have
# to make alignments between groups wherever possible.
# An unusual aspect is that within each group we have aligned both real
# and fake side comments. This has the consequence that the lengths of
# long lines without real side comments can cause 'push' all side comments
# to the right. This seems unusual, but testing with and without this
# feature shows that it is usually better this way. Otherwise, side
# comments can be hidden between long lines without side comments and
# thus be harder to read.
my $group_level = $self->[_group_level_];
my $continuing_sc_flow = $self->[_last_side_comment_length_] > 0
&& $group_level == $self->[_last_level_written_];
# Find groups with side comments, and remember the first nonblank comment
my $j_sc_beg;
my @todo;
my $ng = -1;
foreach my $item ( @{$rgroups} ) {
$ng++;
my ( $jbeg, $jend ) = @{$item};
foreach my $j ( $jbeg .. $jend ) {
my $line = $rlines->[$j];
my $jmax = $line->{'jmax'};
if ( $line->{'rfield_lengths'}->[$jmax] ) {
# this group has a line with a side comment
push @todo, $ng;
if ( !defined($j_sc_beg) ) {
$j_sc_beg = $j;
}
last;
}
}
}
# done if no groups with side comments
return unless @todo;
# Count $num5 = number of comments in the 5 lines after the first comment
# This is an important factor in a decision formula
my $num5 = 1;
foreach my $jj ( $j_sc_beg + 1 .. @{$rlines} - 1 ) {
my $ldiff = $jj - $j_sc_beg;
last if ( $ldiff > 5 );
my $line = $rlines->[$jj];
my $jmax = $line->{'jmax'};
my $sc_len = $line->{'rfield_lengths'}->[$jmax];
next if ( !$sc_len );
$num5++;
}
# Forget the old side comment location if necessary
my $line_0 = $rlines->[$j_sc_beg];
my $lnum =
$j_sc_beg + $self->[_file_writer_object_]->get_output_line_number();
my $keep_it =
$self->is_good_side_comment_column( $line_0, $lnum, $group_level, $num5 );
my $last_side_comment_column =
$keep_it ? $self->[_last_side_comment_column_] : 0;
# If there are multiple groups we will do two passes
# so that we can find a common alignment for all groups.
my $MAX_PASS = @todo > 1 ? 2 : 1;
# Loop over passes
my $max_comment_column = $last_side_comment_column;
foreach my $PASS ( 1 .. $MAX_PASS ) {
# If there are two passes, then on the last pass make the old column
# equal to the largest of the group. This will result in the comments
# being aligned if possible.
if ( $PASS == $MAX_PASS ) {
$last_side_comment_column = $max_comment_column;
}
# Loop over the groups with side comments
my $column_limit;
foreach my $ngr (@todo) {
my ( $jbeg, $jend_uu ) = @{ $rgroups->[$ngr] };
# Note that since all lines in a group have common alignments, we
# just have to work on one of the lines (the first line).
my $line = $rlines->[$jbeg];
my $jmax = $line->{'jmax'};
my $is_hanging_side_comment = $line->{'is_hanging_side_comment'};
last
if ( $PASS < $MAX_PASS && $is_hanging_side_comment );
# the maximum space without exceeding the line length:
my $avail = $line->get_available_space_on_right();
# try to use the previous comment column
my $side_comment_column = $line->get_column( $jmax - 1 );
my $move = $last_side_comment_column - $side_comment_column;
# Remember the maximum possible column of the first line with
# side comment
if ( !defined($column_limit) ) {
$column_limit = $side_comment_column + $avail;
}
next if ( $jmax <= 0 );
# but if this doesn't work, give up and use the minimum space
my $min_move = $rOpts_minimum_space_to_comment - 1;
if ( $move > $avail ) {
$move = $min_move;
}
# but we want some minimum space to the comment
if ( $move >= 0
&& $j_sc_beg == 0
&& $continuing_sc_flow )
{
$min_move = 0;
}
# remove constraints on hanging side comments
if ($is_hanging_side_comment) { $min_move = 0 }
if ( $move < $min_move ) {
$move = $min_move;
}
# don't exceed the available space
if ( $move > $avail ) { $move = $avail }
# We can only increase space, never decrease.
if ( $move < 0 ) { $move = 0 }
# Discover the largest column on the preliminary pass
if ( $PASS < $MAX_PASS ) {
my $col = $line->get_column( $jmax - 1 ) + $move;
# but ignore columns too large for the starting line
if ( $col > $max_comment_column && $col < $column_limit ) {
$max_comment_column = $col;
}
}
# Make the changes on the final pass
else {
$line->increase_field_width( $jmax - 1, $move );
# remember this column for the next group
$last_side_comment_column = $line->get_column( $jmax - 1 );
}
} ## end loop over groups
} ## end loop over passes
# Find the last side comment
my $j_sc_last;
my $ng_last = $todo[-1];
my ( $jbeg, $jend ) = @{ $rgroups->[$ng_last] };
foreach my $jj ( reverse( $jbeg .. $jend ) ) {
my $line = $rlines->[$jj];
my $jmax = $line->{'jmax'};
if ( $line->{'rfield_lengths'}->[$jmax] ) {
$j_sc_last = $jj;
last;
}
}
# Save final side comment info for possible use by the next batch
if ( defined($j_sc_last) ) {
my $line_number =
$self->[_file_writer_object_]->get_output_line_number() + $j_sc_last;
$self->[_last_side_comment_column_] = $last_side_comment_column;
$self->[_last_side_comment_line_number_] = $line_number;
$self->[_last_side_comment_level_] = $group_level;
}
return;
} ## end sub align_side_comments
###########################################
# CODE SECTION 6: Pad Signed Number Columns
###########################################
use constant DEBUG_VSN => 0;
my %is_leading_sign_pattern;
BEGIN {
# PATTERNS: A pattern is basically the concatenation of all token types in
# the field, with keywords converted to their actual text. The formatter
# has changed things like 'print' to 'priNt' so that all 'n's are numbers.
# The following patterns 'n' can match a signed number of interest.
# Thus 'n'=a signed or unsigned number, 'b'=a space, '}'=one of ) ] }
my @q = ( 'n,', 'n,b', 'nb', 'nb}', 'nb},', 'n},', 'n};' );
@is_leading_sign_pattern{@q} = (1) x scalar(@q);
}
sub min_max_median {
my ($rvalues) = @_;
# Given: $rvalues = ref to an array of numbers
# Return: the min, max, and median
my $num = @{$rvalues};
return unless ($num);
my @sorted = sort { $a <=> $b } @{$rvalues};
my $min = $sorted[0];
my $max = $sorted[-1];
my $imid = int( $num / 2 );
my $median =
@sorted % 2
? $sorted[$imid]
: ( $sorted[ $imid - 1 ] + $sorted[$imid] ) / 2;
return ( $min, $max, $median );
} ## end sub min_max_median
sub end_signed_number_column {
my ( $rgroup_lines, $rcol_hash, $ix_last ) = @_;
# Finish formatting a column of unsigned numbers
# Given:
# $rgroup_lines - the current vertical alignment group of lines
# $rcol_hash - a hash of information about this vertical column
# $ix_last - index of the last line of this vertical column
# Task:
# If this is a mixture of signed and unsigned numbers, then add a
# single space before the unsigned numbers to improve appearance.
return unless ($rcol_hash);
my $jcol = $rcol_hash->{jcol};
my $unsigned = $rcol_hash->{unsigned_count};
my $signed = $rcol_hash->{signed_count};
my $rsigned_lines = $rcol_hash->{rsigned_lines};
if ( !$signed && $unsigned ) {
DEVEL_MODE
&& Fault("avoid calling without mixed signed and unsigned\n");
return;
}
my $pos_start_number = $rcol_hash->{pos_start_number};
my $char_end_part1 = $rcol_hash->{char_end_part1};
my $ix_first = $rcol_hash->{ix_first};
my $nlines = $ix_last - $ix_first + 1;
# check for skipped lines, shouldn't happen
if ( $signed + $unsigned != $nlines ) {
my $line = $rgroup_lines->[$ix_last];
my $rfields = $line->{'rfields'};
my $text = join EMPTY_STRING, @{$rfields};
DEVEL_MODE && Fault(< 0 && $Nu <= $rOpts_valign_signed_numbers_limit ) {
push @unsigned_subgroups, [ $ix_last_negative + 1, $ix - 1 ];
}
$ix_last_negative = $ix;
}
# Exclude groups with more than about 20 consecutive numbers. Little
# visual improvement is gained by padding more than this, and this avoids
# large numbers of differences in a file when a single line is changed.
my $Nu = $ix_last - $ix_last_negative;
if ( $Nu > 0 && $Nu <= $rOpts_valign_signed_numbers_limit ) {
push @unsigned_subgroups, [ $ix_last_negative + 1, $ix_last ];
}
if ( !@unsigned_subgroups ) { return } # shouldn't happen
#--------------------------------------------
# Find number lengths for irregularity checks
#--------------------------------------------
# Padding signed numbers looks best when the numbers, excluding signs,
# all have about the same length. When the lengths are irregular, with
# mostly longer unsigned numbers, it doesn't look good to do this. So
# we need to filter out these bad-looking cases.
# The 'field_lengths' are unreliable because they may include some
# arbitrary trailing text; see 'substr.t' So we must look for the end of
# the number at a space, comma, or closing container token. Note that these
# lengths include the length of any signs.
my @len_unsigned;
my @len_signed;
my @lengths;
foreach my $ix ( $ix_first .. $ix_last ) {
my $line = $rgroup_lines->[$ix];
my $rfield = $line->{'rfields'};
my $str = substr( $rfield->[$jcol], $pos_start_number );
if ( $str =~ /^([^\s\,\)\]\}]*)/ ) { $str = $1 }
my $len = length($str);
if ( $is_signed{$ix} ) { push @len_signed, $len }
else { push @len_unsigned, $len }
push @lengths, [ $len, $ix ];
}
my ( $min_unsigned_length, $max_unsigned_length, $median_unsigned_length )
= min_max_median( \@len_unsigned );
my ( $min_signed_length_uu, $max_signed_length, $median_signed_length ) =
min_max_median( \@len_signed );
# Skip padding if no signed numbers exceed unsigned numbers in length
if ( $max_signed_length <= $min_unsigned_length ) {
return;
}
# If max signed length is greatest - all unsigned values can be padded
elsif ( $max_signed_length > $max_unsigned_length ) {
# Example:
# %wind_dir = (
# 'n' => [ 1, 0 ],
# 'ne' => [ 1, 1 ],
# 'e' => [ 0, 1 ],
# 'se' => [ -1, 1 ],
# 's' => [ -1, 0 ],
# 'sw' => [ -1, -1 ],
# 'w' => [ 0, -1 ],
# 'nw' => [ 1, -1 ],
# '' => [ 0, 0 ],
# );
# This is the ideal case - ok to continue and pad
}
# intermediate case: some signed numbers cannot be padded ...
else {
# We have to take a closer look.
# Here is an example which looks bad if we do padding like this:
# my %hash = (
# X0 => -12867.098241163,
# X1 => 2.31694338671684, # unsigned w/ excess>0
# X2 => 0.0597726714860419, # max length => excess=0
# Y0 => 30043.1335503155, # unsigned w/ excess>0
# Y1 => 0.0525784981597044, # max length => excess=0
# Y2 => -2.32447131600783,
# );
# To decide what looks okay, we count 'good' and 'bad' line interfaces:
# X0 - X1 = good (X0 is signed and X1 can move)
# X1 - X2 = bad (x1 can move but x2 cannot)
# X2 - Y0 = bad (x2 cannot move but Y0 can move)
# Y0 - Y1 = bad (Y0 can move but Y1 cannot move)
# Y1 - Y2 = bad (Y1 cannot move and Y2 is signed)
# Result: 4 bad interfaces and 1 good => so we will skip this
my $good_count = 0;
my $bad_count = 0;
foreach my $item (@lengths) {
$item->[0] = $max_unsigned_length - $item->[0];
}
my $item0 = shift @lengths;
my ( $excess, $ix ) = @{$item0};
my $immobile_count = $excess ? 0 : 1;
foreach my $item (@lengths) {
my $excess_m = $excess;
my $ix_m = $ix;
( $excess, $ix ) = @{$item};
if ( !$excess ) { $immobile_count++ }
if ( $is_signed{$ix_m} ) {
# signed-unsigned interface
if ( !$is_signed{$ix} ) {
if ($excess) { $good_count++ }
else { $bad_count++ }
}
# signed-signed: ok, not good or bad
}
else {
# unsigned-signed interface
if ( $is_signed{$ix} ) {
if ($excess_m) { $good_count++ }
else { $bad_count++ }
}
# unsigned-unsigned: bad if different
else {
if ( $excess_m xor $excess ) {
$bad_count++;
}
}
}
}
# Filter 1: skip if more interfaces are 'bad' than 'good'
if ( $bad_count > $good_count ) {
return;
}
# Filter 2: skip in a table with multiple 'bad' interfaces and where
# 'most' of the unsigned lengths are shorter than the signed lengths.
# Using the median value makes this insensitive to small changes.
if ( $median_unsigned_length >= $median_signed_length
&& $bad_count > 1
&& $immobile_count > 1 )
{
return;
}
# Anything that gets past these filters should look ok if padded
}
#---------------------------------------------
# Compute actual available space for each line
#---------------------------------------------
my %excess_space;
my $movable_count = 0;
foreach my $item (@unsigned_subgroups) {
my ( $ix_min, $ix_max ) = @{$item};
foreach my $ix ( $ix_min .. $ix_max ) {
my $line = $rgroup_lines->[$ix];
my $leading_space_count = $line->{'leading_space_count'};
my $jmax = $line->{'jmax'};
my $rfield_lengths = $line->{'rfield_lengths'};
if ( $jcol >= $jmax ) {
# shouldn't happen
DEVEL_MODE && Fault("jcol=$jcol >= jmax=$jmax\n");
return;
}
my @alignments = @{ $line->{'ralignments'} };
my $col = $alignments[$jcol]->{'column'};
my $col_start =
$jcol == 0
? $leading_space_count
: $alignments[ $jcol - 1 ]->{'column'};
my $avail = $col - $col_start;
my $field_length = $rfield_lengths->[$jcol];
my $excess = $avail - $field_length;
$excess_space{$ix} = $excess;
if ( $excess > 0 ) { $movable_count++ }
}
}
return unless ($movable_count);
# Count the number of signed-unsigned interfaces that would change
# if we do the padding
my $Nc = 0;
foreach my $item (@unsigned_subgroups) {
my ( $ix_min, $ix_max ) = @{$item};
$Nc++ if ( $excess_space{$ix_min} > 0 && $ix_min != $ix_first );
$Nc++ if ( $excess_space{$ix_max} > 0 && $ix_max != $ix_last );
}
#--------------------------------------------------------------------
# Sparsity check:
# Give up if the number of interface changes will be below the cutoff
#--------------------------------------------------------------------
if ( $unsigned > $Nc * $rOpts_valign_signed_numbers_limit ) {
return;
}
#------------------------------------------------------------------------
# Insert an extra space before the unsigned numbers if space is available
#------------------------------------------------------------------------
foreach my $item (@unsigned_subgroups) {
my ( $ix_min, $ix_max ) = @{$item};
foreach my $ix ( $ix_min .. $ix_max ) {
next if ( $excess_space{$ix} <= 0 );
my $line = $rgroup_lines->[$ix];
my $rfields = $line->{'rfields'};
my $rfield_lengths = $line->{'rfield_lengths'};
pad_signed_field(
\$rfields->[$jcol], \$rfield_lengths->[$jcol],
$pos_start_number, $char_end_part1
);
}
}
return;
} ## end sub end_signed_number_column
sub pad_signed_field {
my ( $rstr, $rstr_len, $pos_start_number, $char_end_part1 ) = @_;
# Insert an extra space before a number to highlight algebraic signs
# in a column of numbers.
# Given:
# $rstr = ref to string
# $rstr_len = ref to display width of string (could include wide chars)
# $pos_start_number = string position of the leading digit
# $char_end_part1 = character at $pos_start_number - 1
# Task: update $rstr and $rstr_len with a single space
# First partition the string into $part1 and $part2, so that the
# number starts at the beginning of part2.
my $part1 = EMPTY_STRING;
my $part2 = ${$rstr};
my $str = ${$rstr};
if ( $pos_start_number > 0 ) {
my $len = length($str);
if ( $pos_start_number >= $len ) {
DEVEL_MODE && Fault(< 1 ) {
return @fail;
}
# Same thing for commas
my $comma_count = ( $pattern =~ tr/,/,/ );
if ( $comma_count && $comma_count > 1 ) {
return @fail;
}
# Require 0 or 1 braces
my $len_field = length($field);
my $len_pat1 = length($pat1);
return @fail unless ( $len_pat1 && $len_field );
# Look at the pattern ending
my $ending_b = 0;
my $ch = substr( $pat1, -1, 1 );
if ( $ch eq 'b' ) {
$ending_b = 1;
$ch = substr( $pat1, -2, 1 );
$char_end_part1 = SPACE;
}
# handle either '{b' or '{'
if ( $ch eq '{' ) {
# Only one brace
my $brace_count = ( $pat1 =~ tr/\{/\{/ );
return @fail if ( $brace_count != 1 );
my $i_paren = index( $field, '(' );
my $i_bracket = index( $field, '[' );
my $i_brace = index( $field, '{' );
my $i_opening = length($field);
if ( $i_paren >= 0 ) {
$i_opening = $i_paren;
$ch_opening = '(';
}
if ( $i_bracket >= 0
&& $i_bracket < $i_opening )
{
$i_opening = $i_bracket;
$ch_opening = '[';
}
if ( $i_brace >= 0 && $i_brace < $i_opening ) {
$i_opening = $i_brace;
$ch_opening = '{';
}
if ( $i_opening >= 0
&& $i_opening < length($field) - 1 )
{
$pos_start_number = $i_opening + 1 + $ending_b;
$char_end_part1 = $ch_opening
if ( !$ending_b );
}
else {
# strange - could not find the opening token
}
}
# no braces: maybe '=>b'
else {
# looking for patterns ending in '=b' or '=>b'
if ( !$ending_b ) { return @fail }
# find the = in the text
my $pos_equals = index( $field, '=' );
return @fail if ( $pos_equals < 0 );
# be sure there are no other '=' in the pattern
my $equals_count = ( $pat1 =~ tr/=/=/ );
return @fail if ( $equals_count != 1 );
if ( $len_pat1 >= 2 && substr( $pat1, -2, 2 ) eq '=b' ) {
$pos_start_number = $pos_equals + 2;
}
elsif ( $len_pat1 >= 3 && substr( $pat1, -3, 3 ) eq '=>b' ) {
$pos_start_number = $pos_equals + 3;
}
else {
# cannot handle this pattern
return @fail;
}
}
if ( $pos_start_number <= 0 || $pos_start_number >= $len_field ) {
return @fail;
}
return ( $pos_start_number, $char_end_part1, $ch_opening );
} ## end sub split_field
sub field_matches_end_pattern {
my ( $field2, $pat2 ) = @_;
# Check that a possible numeric field matches the ending pattern
# Given:
# $field2 = the rest of the field after removing any sign
# $pat2 = the end pattern of this field
# Return:
# false if field is definitely non-numeric
# true otherwise
my $next_char = substr( $pat2, 1, 1 );
my $field2_trim = EMPTY_STRING;
# if pattern is one of: 'n,', 'n,b'
if ( $next_char eq ',' ) {
my $icomma = index( $field2, ',' );
if ( $icomma >= 0 ) {
$field2_trim = substr( $field2, 0, $icomma );
}
}
# if pattern is one of: 'nb', 'nb}', 'nb},'
elsif ( $next_char eq 'b' ) {
my $ispace = index( $field2, SPACE );
if ( $ispace >= 0 ) {
$field2_trim = substr( $field2, 0, $ispace );
}
}
# if pattern is one of 'n},', 'n};'
elsif ( $next_char eq '}' ) {
if ( $field2 =~ /^([^\)\}\]]+)/ ) {
$field2_trim = $1;
}
}
# unrecognized pattern
else {
DEVEL_MODE && Fault(<{'jmax'};
my $jmax_change = $jmax ne $jmax_last;
my @alignments = @{ $line->{'ralignments'} };
my $rfields = $line->{'rfields'};
my $rpatterns = $line->{'rpatterns'};
my $rtokens = $line->{'rtokens'};
#-----------------------------------------------
# Check for a reduction in the number of columns
#-----------------------------------------------
if ( $jmax < $jmax_last ) {
foreach my $jcol ( keys %column_info ) {
# end any stranded columns on the right
next if ( $jcol < $jmax );
my $rcol_hash = $column_info{$jcol};
next unless ($rcol_hash);
if ( $rcol_hash->{signed_count}
&& $rcol_hash->{unsigned_count} )
{
end_signed_number_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol};
}
# Try to keep the end data column running; test case 'rfc.in'
# The last item in a list will still need a trailing comma.
my $jcol = $jmax - 1;
if ( $jcol >= 0 && $column_info{$jcol} ) {
my $alignment = $alignments[$jcol];
my $old_col = $columns[$jcol];
my $col = $alignment->{column};
if (
$col < $old_col
# only do this if the text has a leading digit
&& $rfields->[$jcol] =~ /^([+-]?)\d/
# and a signed number has been seen - issue c375
&& ( $1 || $column_info{$jcol}->{signed_count} )
)
{
my $spaces_needed = $old_col - $col;
my $spaces_available =
$line->get_available_space_on_right();
if ( $spaces_available >= $spaces_needed ) {
$line->increase_field_width( $jcol, $spaces_needed );
}
}
}
}
#--------------------------------------------
# Loop over fields except last (side comment)
#--------------------------------------------
for my $jcol ( 0 .. $jmax - 1 ) {
#-----------------------------------------
# Decide if this is a new alignment column
#-----------------------------------------
my $alignment = $alignments[$jcol];
my $old_col = $columns[$jcol];
my $col = $alignment->{column};
$columns[$jcol] = $col;
if ( defined($old_col) && $old_col != $col ) {
foreach my $jcol_old ( keys %column_info ) {
next if ( $jcol_old < $jcol );
my $rcol_hash = $column_info{$jcol_old};
if ( $rcol_hash->{signed_count}
&& $rcol_hash->{unsigned_count} )
{
end_signed_number_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol_old};
}
}
# A new padded sign column can only start at an alignment change
my $rcol_hash = $column_info{$jcol};
#------------------------------------------------------------
# Examine this field, looking for signed and unsigned numbers
#------------------------------------------------------------
my $field = $rfields->[$jcol];
my $pattern = $rpatterns->[$jcol];
my $is_signed_number = 0;
my $is_unsigned_number = 0;
#--------------------------------------------------------
# set $pos_start_number = index in field of digit or sign
#--------------------------------------------------------
my $pos_start_number = 0;
my $char_end_part1 = EMPTY_STRING;
my $ch_opening = EMPTY_STRING;
# Set $field_ok to false on encountering any problem
# Do not pad signed and unsigned hash keys
my $field_ok = length($field) > 0
&& substr( $rtokens->[$jcol], 0, 2 ) ne '=>';
if ( $field_ok && $pattern ) {
# Split the pattern at the first 'n'
# $pat1 = pattern before the 'n' (if any)
# $pat2 = pattern starting at the 'n'
my ( $pat1, $pat2 );
my $posq = index( $pattern, 'n' );
if ( $posq < 0 ) {
$field_ok = 0;
}
else {
# Just look at up to 3 of the pattern characters
# We require $pat2 to have one of the known patterns
$pat1 = substr( $pattern, 0, $posq );
$pat2 = substr( $pattern, $posq, 3 );
$field_ok = $is_leading_sign_pattern{$pat2};
}
if ($field_ok) {
# If the number starts within the field then we must
# find its offset position.
if ($pat1) {
# Note: an optimization would be to remember previous
# calls for each column and use them if possible, but
# benchmarking shows that this is not necessary.
# See .ba54 for example coding.
( $pos_start_number, $char_end_part1, $ch_opening ) =
split_field( $pat1, $field, $pattern );
$field_ok ||= $pos_start_number;
}
if ($field_ok) {
# look for an optional + or - sign
my $test_char = substr( $field, $pos_start_number, 1 );
my $sign;
if ( $is_plus_or_minus{$test_char} ) {
$sign = $test_char;
$test_char =
substr( $field, $pos_start_number + 1, 1 );
}
# and a digit
if ( $is_digit_char{$test_char} ) {
my $field2;
if ($sign) {
$is_signed_number = 1;
$field2 =
substr( $field, $pos_start_number + 1 );
}
else {
$is_unsigned_number = 1;
$field2 =
$pos_start_number
? substr( $field, $pos_start_number )
: $field;
}
# Check for match to ending pattern
$field_ok =
field_matches_end_pattern( $field2, $pat2 );
}
else {
$field_ok = 0;
}
}
}
}
#----------------------
# Figure out what to do
#----------------------
# we require a signed or unsigned number field
# which is not a hash key
$field_ok &&= ( $is_signed_number || $is_unsigned_number );
# if a column has not started..
if ( !$rcol_hash ) {
# give up if this is cannot start a new column
next if ( !$field_ok );
# otherwise continue on to start a new column
}
# if a column has been started...
else {
# and this cannot be added to it
if ( !$field_ok
|| $rcol_hash->{pos_start_number} ne $pos_start_number
|| $rcol_hash->{char_end_part1} ne $char_end_part1
|| $rcol_hash->{col} ne $col )
{
# then end the current column and start over
if ( $rcol_hash->{signed_count}
&& $rcol_hash->{unsigned_count} )
{
end_signed_number_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol};
$rcol_hash = undef;
}
}
if (DEBUG_VSN) {
my $exists = defined($rcol_hash);
print
"VSN: line=$ix_line change=$jmax_change jcol=$jcol field=$field exists?=$exists unsigned?=$is_unsigned_number signed?=$is_signed_number\n";
}
#---------------------------------------
# Either start a new column, if possible
#---------------------------------------
if ( !defined($rcol_hash) ) {
next if ( !$field_ok );
my $rsigned_lines = $is_signed_number ? [$ix_line] : [];
$column_info{$jcol} = {
unsigned_count => $is_unsigned_number,
signed_count => $is_signed_number,
pos_start_number => $pos_start_number,
char_end_part1 => $char_end_part1,
ix_first => $ix_line,
col => $col,
jcol => $jcol,
rsigned_lines => $rsigned_lines,
};
}
#------------------------------
# or extend the existing column
#------------------------------
else {
$rcol_hash->{unsigned_count} += $is_unsigned_number;
$rcol_hash->{signed_count} += $is_signed_number;
if ($is_signed_number) {
push @{ $rcol_hash->{rsigned_lines} }, $ix_line;
}
}
}
}
#-------------------------------------
# Loop to finish any remaining columns
#-------------------------------------
foreach my $jcol ( keys %column_info ) {
my $rcol_hash = $column_info{$jcol};
if ( $rcol_hash->{signed_count} && $rcol_hash->{unsigned_count} ) {
end_signed_number_column( $rgroup_lines, $rcol_hash, $ix_line );
}
}
return;
} ## end sub pad_signed_number_columns
#########################################
# CODE SECTION 7: Pad Wide Equals Columns
#########################################
use constant DEBUG_WEC => 0;
sub end_wide_equals_column {
my ( $rgroup_lines, $rcol_hash, $ix_last ) = @_;
# Finish formatting a column of wide equals
# Given:
# $rgroup_lines - the current vertical alignment group of lines
# $rcol_hash - a hash of information about this vertical column
# $ix_last - index of the last line of this vertical column
return unless ($rcol_hash);
my $jcol = $rcol_hash->{jcol};
my $col = $rcol_hash->{col};
my $min_width = $rcol_hash->{min_width};
my $max_width = $rcol_hash->{max_width};
my $rwidths = $rcol_hash->{rwidths};
my $ix_first = $rcol_hash->{ix_first};
# check for skipped lines, shouldn't happen
my $nlines = $ix_last - $ix_first + 1;
my $num = @{$rwidths};
if ( $num != $nlines ) {
my $line = $rgroup_lines->[$ix_last];
my $rfields = $line->{'rfields'};
my $text = join EMPTY_STRING, @{$rfields};
DEVEL_MODE && Fault(<[$ix];
# add leading spaces to the shorter equality tokens to get
# vertical alignment of the '=' signs
my $jmax = $line->{'jmax'};
my $jcolp = $jcol + 1;
my @alignments = @{ $line->{'ralignments'} };
my $alignment = $alignments[$jcolp];
my $colp = $alignment->{column};
#------------------------------------------------------------
# Transfer column width changes between equivalent alignments
#------------------------------------------------------------
# This step keeps alignments to the right correct in case the
# alignment object changes but the actual alignment col does not.
# It is extremely rare for this to occur. Issue c353.
# nothing to do if no more real alignments on right
if ( $jcolp >= $jmax - 1 ) {
$current_alignment = undef;
$current_line = undef;
@previous_linked_lines = ();
}
# handle new rhs alignment
elsif ( !$current_alignment ) {
$current_alignment = $alignment;
$current_line = $line;
$starting_colp = $colp;
@previous_linked_lines = ();
}
# handle change in existing alignment
elsif ( refaddr($alignment) != refaddr($current_alignment) ) {
# change rhs alignment column - new vertical group on right
if ( $starting_colp != $colp ) {
$starting_colp = $colp;
@previous_linked_lines = ();
}
else {
# Same starting alignment col on right, but different alignment
# object. See if we must increase width of this new alignment
# object.
my $current_colp = $current_alignment->{column};
if ( $current_colp > $colp ) {
my $excess = $current_colp - $colp;
my $padding_available =
$line->get_available_space_on_right();
if ( $excess <= $padding_available ) {
$line->increase_field_width( $jcolp, $excess );
$colp = $alignment->{column};
}
}
# remember the previous line in case we have to go back and
# increasse its width
push @previous_linked_lines, $current_line;
}
$current_alignment = $alignment;
$current_line = $line;
}
else {
# continuing with same alignment
}
#-----------------------
# add any needed padding
#-----------------------
my $pad = $max_width - $width;
if ( $pad > 0 ) {
my $rfields = $line->{'rfields'};
my $rfield_lengths = $line->{'rfield_lengths'};
my $lenp = $rfield_lengths->[$jcolp];
my $avail = $colp - $col;
my $excess = $lenp + $pad - $avail;
if ( $excess > 0 ) {
my $padding_available = $line->get_available_space_on_right();
if ( $excess <= $padding_available ) {
$line->increase_field_width( $jcolp, $excess );
# Increase space of any previous linked lines
foreach my $line_prev (@previous_linked_lines) {
$padding_available =
$line_prev->get_available_space_on_right();
if ( $excess <= $padding_available ) {
$line_prev->increase_field_width( $jcolp, $excess );
}
else {
last;
}
}
}
else {
$pad = 0;
}
}
# Add spaces
$rfields->[$jcolp] = ( SPACE x $pad ) . $rfields->[$jcolp];
$rfield_lengths->[$jcolp] += $pad;
}
}
return;
} ## end sub end_wide_equals_column
sub pad_wide_equals_columns {
my ($rgroup_lines) = @_;
# Given:
# $rgroup_lines = the current vertical alignment group of lines
# Task:
# Look for columns of aligned equals tokens, some of which may be
# things like '-=', '&&=', etc. Increase the field length of the
# previous field by 1 or 2 spaces where necessary and possible so
# that alignment of all '=' occurs. For example, given
# $j /= 2;
# $pow2 = $pow2 * $pow2;
# In this case we want to add a leading space '=' term to get
# $j /= 2;
# $pow2 = $pow2 * $pow2;
# The logic here is somewhat similar to sub pad_signed_number_columns
return unless ($rOpts_valign_wide_equals);
my %column_info;
my @columns;
#----------------
# loop over lines
#----------------
my $ix_line = -1;
my $jmax = -1;
foreach my $line ( @{$rgroup_lines} ) {
$ix_line++;
my $jmax_last = $jmax;
$jmax = $line->{'jmax'};
my $jmax_change = $jmax ne $jmax_last;
my @alignments = @{ $line->{'ralignments'} };
my $rfields = $line->{'rfields'};
my $rtokens = $line->{'rtokens'};
#-----------------------------------------------
# Check for a reduction in the number of columns
#-----------------------------------------------
if ( $jmax < $jmax_last ) {
foreach my $jcol ( keys %column_info ) {
# end any stranded columns on the right
next if ( $jcol < $jmax );
my $rcol_hash = $column_info{$jcol};
next unless ($rcol_hash);
if ( $rcol_hash->{max_width} > $rcol_hash->{min_width} ) {
end_wide_equals_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol};
}
}
#--------------------------------------------------
# Loop over fields except last field (side comment)
#--------------------------------------------------
for my $jcol ( 0 .. $jmax - 1 ) {
#-----------------------------------------
# Decide if this is a new alignment column
#-----------------------------------------
my $alignment = $alignments[$jcol];
my $old_col = $columns[$jcol];
my $col = $alignment->{column};
$columns[$jcol] = $col;
if ( defined($old_col) && $old_col != $col ) {
foreach my $jcol_old ( keys %column_info ) {
next if ( $jcol_old < $jcol );
my $rcol_hash = $column_info{$jcol_old};
if ( $rcol_hash->{max_width} > $rcol_hash->{min_width} ) {
end_wide_equals_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol_old};
}
}
# A new wide equals column can only start at an alignment change
my $rcol_hash = $column_info{$jcol};
#------------------------------------------------------
# Examine this field, looking for equals or wide equals
#------------------------------------------------------
my $field_next = $rfields->[ $jcol + 1 ];
my $token = $rtokens->[$jcol];
# See if this is an equals alignment group;
# indicated by alignment token of '=' followed by a digit
my $len_equals_symbol = 0;
if ( length($token) > 1
&& substr( $token, 0, 1 ) eq '='
&& $is_digit_char{ substr( $token, 1, 1 ) } )
{
# find the actual equality symbol which starts the next field
# i.e. '=' or '**=' or '-=' etc. We just need its length.
my $pos = index( $field_next, '=' );
if ( $pos >= 0 && $pos <= 2 ) {
$len_equals_symbol = $pos + 1;
}
}
# if a column has not started..
if ( !$rcol_hash ) {
# give up if this is cannot start a new column
next if ( !$len_equals_symbol );
# otherwise continue on to start a new column
}
# if a column has been started...
else {
# and this cannot be added to it
if ( !$len_equals_symbol || $rcol_hash->{col} ne $col ) {
# then end the current column and start over
if ( $rcol_hash->{max_width} > $rcol_hash->{min_width} ) {
end_wide_equals_column( $rgroup_lines, $rcol_hash,
$ix_line - 1 );
}
delete $column_info{$jcol};
$rcol_hash = undef;
}
}
if (DEBUG_WEC) {
my $exists = defined($rcol_hash);
print
"WEA: line=$ix_line change=$jmax_change jcol=$jcol field=$field_next exists?=$exists equals?=$len_equals_symbol\n";
}
#---------------------------------------
# Either start a new column, if possible
#---------------------------------------
if ( !defined($rcol_hash) ) {
next if ( !$len_equals_symbol );
$column_info{$jcol} = {
ix_first => $ix_line,
col => $col,
jcol => $jcol,
min_width => $len_equals_symbol,
max_width => $len_equals_symbol,
rwidths => [ [ $ix_line, $len_equals_symbol ] ],
};
}
#------------------------------
# or extend the existing column
#------------------------------
else {
if ( $len_equals_symbol > $rcol_hash->{max_width} ) {
$rcol_hash->{max_width} = $len_equals_symbol;
}
if ( $len_equals_symbol < $rcol_hash->{min_width} ) {
$rcol_hash->{min_width} = $len_equals_symbol;
}
push @{ $rcol_hash->{rwidths} },
[ $ix_line, $len_equals_symbol ];
}
}
}
#-------------------------------------
# Loop to finish any remaining columns
#-------------------------------------
foreach my $jcol ( keys %column_info ) {
my $rcol_hash = $column_info{$jcol};
if ( $rcol_hash->{max_width} > $rcol_hash->{min_width} ) {
end_wide_equals_column( $rgroup_lines, $rcol_hash, $ix_line );
}
}
return;
} ## end sub pad_wide_equals_columns
###############################
# CODE SECTION 8: Output Step A
###############################
sub valign_output_step_A {
#------------------------------------------------------------
# This is Step A in writing vertically aligned lines.
# The line is prepared according to the alignments which have
# been found. Then it is shipped to the next step.
#------------------------------------------------------------
my ( $self, $rinput_hash ) = @_;
my $line = $rinput_hash->{line};
my $min_ci_gap = $rinput_hash->{min_ci_gap};
my $do_not_align = $rinput_hash->{do_not_align};
my $group_leader_length = $rinput_hash->{group_leader_length};
my $extra_leading_spaces = $rinput_hash->{extra_leading_spaces};
my $level = $rinput_hash->{level};
my $maximum_line_length = $rinput_hash->{maximum_line_length};
my $rfields = $line->{'rfields'};
my $rfield_lengths = $line->{'rfield_lengths'};
my $leading_space_count = $line->{'leading_space_count'};
my $outdent_long_lines = $line->{'outdent_long_lines'};
my $maximum_field_index = $line->{'jmax'};
my $rvertical_tightness_flags = $line->{'rvertical_tightness_flags'};
my $Kend = $line->{'Kend'};
my $level_end = $line->{'level_end'};
# Check for valid hash keys at end of lifetime of $line during development
DEVEL_MODE
&& check_keys( $line, \%valid_LINE_keys,
"Checking line keys at valign_output_step_A", 1 );
# add any extra spaces
if ( $leading_space_count > $group_leader_length ) {
$leading_space_count += $min_ci_gap;
}
my $str = $rfields->[0];
my $str_len = $rfield_lengths->[0];
my @alignments = @{ $line->{'ralignments'} };
if ( @alignments != $maximum_field_index + 1 ) {
# Shouldn't happen: sub install_new_alignments makes jmax alignments
my $jmax_alignments = @alignments - 1;
if (DEVEL_MODE) {
Fault(
"alignment jmax=$jmax_alignments should equal $maximum_field_index\n"
);
}
$do_not_align = 1;
}
# loop to concatenate all fields of this line and needed padding
my $total_pad_count = 0;
for my $j ( 1 .. $maximum_field_index ) {
# skip zero-length side comments
last
if (
( $j == $maximum_field_index )
&& ( !defined( $rfields->[$j] )
|| ( $rfield_lengths->[$j] == 0 ) )
);
# compute spaces of padding before this field
my $col = $alignments[ $j - 1 ]->{'column'};
my $pad = $col - ( $str_len + $leading_space_count );
if ($do_not_align) {
$pad =
( $j < $maximum_field_index )
? 0
: $rOpts_minimum_space_to_comment - 1;
}
# if the -fpsc flag is set, move the side comment to the selected
# column if and only if it is possible, ignoring constraints on
# line length and minimum space to comment
if ( $rOpts_fixed_position_side_comment
&& $j == $maximum_field_index )
{
my $newpad = $pad + $rOpts_fixed_position_side_comment - $col - 1;
if ( $newpad >= 0 ) { $pad = $newpad; }
}
# accumulate the padding
if ( $pad > 0 ) { $total_pad_count += $pad; }
# only add padding when we have a finite field;
# this avoids extra terminal spaces if we have empty fields
if ( $rfield_lengths->[$j] > 0 ) {
$str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
$str_len += $rfield_lengths->[$j];
}
else {
$total_pad_count = 0;
}
}
my $side_comment_length = $rfield_lengths->[$maximum_field_index];
# ship this line off
$self->valign_output_step_B(
{
leading_space_count => $leading_space_count + $extra_leading_spaces,
line => $str,
line_length => $str_len,
side_comment_length => $side_comment_length,
outdent_long_lines => $outdent_long_lines,
rvertical_tightness_flags => $rvertical_tightness_flags,
level => $level,
level_end => $level_end,
Kend => $Kend,
maximum_line_length => $maximum_line_length,
}
);
return;
} ## end sub valign_output_step_A
sub combine_fields {
my ( $line_0, $line_1, $imax_align ) = @_;
# Given:
# $line_0, $line_1 = two adjacent lines
# $imax_align = index of last alignment wanted
# Task:
# We have a group of two lines for which we do not want to align tokens
# between index $imax_align and the side comment. So we will delete fields
# between $imax_align and the side comment. Alignments have already
# been set so we have to adjust them.
if ( !defined($imax_align) ) { $imax_align = -1 }
# First delete the unwanted tokens
my $jmax_old = $line_0->{'jmax'};
my @idel = ( $imax_align + 1 .. $jmax_old - 2 );
return if ( !@idel );
# Get old alignments before any changes are made
my @old_alignments = @{ $line_0->{'ralignments'} };
foreach my $line ( $line_0, $line_1 ) {
delete_selected_tokens( $line, \@idel );
}
# Now adjust the alignments. Note that the side comment alignment
# is always at jmax-1, and there is an ending alignment at jmax.
my @new_alignments;
if ( $imax_align >= 0 ) {
@new_alignments[ 0 .. $imax_align ] =
@old_alignments[ 0 .. $imax_align ];
}
my $jmax_new = $line_0->{'jmax'};
$new_alignments[ $jmax_new - 1 ] = $old_alignments[ $jmax_old - 1 ];
$new_alignments[$jmax_new] = $old_alignments[$jmax_old];
$line_0->{'ralignments'} = \@new_alignments;
$line_1->{'ralignments'} = \@new_alignments;
return;
} ## end sub combine_fields
sub get_output_line_number {
# Return the output line number to external modules.
# The output line number reported to a caller =
# the number of items still in the buffer +
# the number of items written.
my $self = shift;
return $self->group_line_count() +
$self->[_file_writer_object_]->get_output_line_number();
} ## end sub get_output_line_number
###############################
# CODE SECTION 9: Output Step B
###############################
{ ## closure for sub valign_output_step_B
# These are values for a cache used by valign_output_step_B.
my $cached_line_text;
my $cached_line_text_length;
my $cached_line_type;
my $cached_line_opening_flag;
my $cached_line_closing_flag;
my $cached_seqno;
my $cached_line_valid;
my $cached_line_leading_space_count;
my $cached_seqno_string;
my $cached_line_Kend;
my $cached_line_maximum_length;
# These are passed to step_C:
my $seqno_string;
my $last_nonblank_seqno_string;
sub set_last_nonblank_seqno_string {
my ($val) = @_;
$last_nonblank_seqno_string = $val;
return;
}
sub get_cached_line_opening_flag {
return $cached_line_opening_flag;
}
sub get_cached_line_type {
return $cached_line_type;
}
sub set_cached_line_valid {
my ($val) = @_;
$cached_line_valid = $val;
return;
}
sub get_cached_seqno {
return $cached_seqno;
}
sub initialize_step_B_cache {
# valign_output_step_B cache:
$cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
$cached_line_type = 0;
$cached_line_opening_flag = 0;
$cached_line_closing_flag = 0;
$cached_seqno = 0;
$cached_line_valid = 0;
$cached_line_leading_space_count = 0;
$cached_seqno_string = EMPTY_STRING;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
# These vars hold a string of sequence numbers joined together used by
# the cache
$seqno_string = EMPTY_STRING;
$last_nonblank_seqno_string = EMPTY_STRING;
return;
} ## end sub initialize_step_B_cache
sub _flush_step_B_cache {
my ($self) = @_;
# Send any text in the step_B cache on to step_C
if ($cached_line_type) {
$seqno_string = $cached_seqno_string;
$self->valign_output_step_C(
$seqno_string,
$last_nonblank_seqno_string,
$cached_line_text,
$cached_line_leading_space_count,
$self->[_last_level_written_],
$cached_line_Kend,
);
$cached_line_type = 0;
$cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
$cached_seqno_string = EMPTY_STRING;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
}
return;
} ## end sub _flush_step_B_cache
sub handle_cached_line {
my ( $self, $rinput, $leading_string, $leading_string_length ) = @_;
# handle a cached line ..
# either append the current line to it or write it out
# The cached line will either be:
# - passed along to step_C, or
# - or combined with the current line
my $last_level_written = $self->[_last_level_written_];
my $leading_space_count = $rinput->{leading_space_count};
my $str = $rinput->{line};
my $str_length = $rinput->{line_length};
my $rvertical_tightness_flags = $rinput->{rvertical_tightness_flags};
my $level = $rinput->{level};
my $level_end = $rinput->{level_end};
my $maximum_line_length = $rinput->{maximum_line_length};
my ( $open_or_close, $seqno_beg );
if ($rvertical_tightness_flags) {
$open_or_close = $rvertical_tightness_flags->{_vt_type};
$seqno_beg = $rvertical_tightness_flags->{_vt_seqno_beg};
}
# Dump an invalid cached line
if ( !$cached_line_valid ) {
$self->valign_output_step_C(
$seqno_string,
$last_nonblank_seqno_string,
$cached_line_text,
$cached_line_leading_space_count,
$last_level_written,
$cached_line_Kend,
);
}
# Handle cached line ending in OPENING tokens
elsif ( $cached_line_type == 1 || $cached_line_type == 3 ) {
my $gap = $leading_space_count - $cached_line_text_length;
# handle option of just one tight opening per line:
if ( $cached_line_opening_flag == 1 ) {
if ( defined($open_or_close) && $open_or_close == 1 ) {
$gap = -1;
}
}
# Do not join the lines if this might produce a one-line
# container which exceeds the maximum line length. This is
# necessary prevent blinking, particularly with the combination
# -xci -pvt=2. In that case a one-line block alternately forms
# and breaks, causing -xci to alternately turn on and off (case
# b765).
# Patched to fix cases b656 b862 b971 b972: always do the check
# if the maximum line length changes (due to -vmll).
if (
$gap >= 0
&& ( $maximum_line_length != $cached_line_maximum_length
|| ( defined($level_end) && $level > $level_end ) )
)
{
my $test_line_length =
$cached_line_text_length + $gap + $str_length;
# Add a small tolerance in the length test (fixes case b862)
if ( $test_line_length > $cached_line_maximum_length - 2 ) {
$gap = -1;
}
}
if ( $gap >= 0 && defined($seqno_beg) ) {
$maximum_line_length = $cached_line_maximum_length;
$leading_string = $cached_line_text . SPACE x $gap;
$leading_string_length = $cached_line_text_length + $gap;
$leading_space_count = $cached_line_leading_space_count;
$seqno_string = $cached_seqno_string . ':' . $seqno_beg;
$level = $last_level_written;
}
else {
$self->valign_output_step_C(
$seqno_string,
$last_nonblank_seqno_string,
$cached_line_text,
$cached_line_leading_space_count,
$last_level_written,
$cached_line_Kend,
);
}
}
# Handle cached line ending in CLOSING tokens
else {
my $test_line =
$cached_line_text . SPACE x $cached_line_closing_flag . $str;
my $test_line_length =
$cached_line_text_length +
$cached_line_closing_flag +
$str_length;
if (
# The new line must start with container
$seqno_beg
# The container combination must be okay..
&& (
# okay to combine like types
( $open_or_close == $cached_line_type )
# closing block brace may append to non-block
|| ( $cached_line_type == 2 && $open_or_close == 4 )
# something like ');'
|| ( !$open_or_close && $cached_line_type == 2 )
)
# The combined line must fit
&& ( $test_line_length <= $cached_line_maximum_length )
)
{
$seqno_string = $cached_seqno_string . ':' . $seqno_beg;
# Patch to outdent closing tokens ending # in ');' If we
# are joining a line like ');' to a previous stacked set of
# closing tokens, then decide if we may outdent the
# combined stack to the indentation of the ');'. Since we
# should not normally outdent any of the other tokens more
# than the indentation of the lines that contained them, we
# will only do this if all of the corresponding opening
# tokens were on the same line. This can happen with -sot
# and -sct.
# For example, it is ok here:
# __PACKAGE__->load_components( qw(
# PK::Auto
# Core
# ));
#
# But, for example, we do not outdent in this example
# because that would put the closing sub brace out farther
# than the opening sub brace:
#
# perltidy -sot -sct
# $c->Tk::bind(
# '' => sub {
# my ($c) = @_;
# my $e = $c->XEvent;
# itemsUnderArea $c;
# } );
#
if ( $str =~ /^\);/
&& $cached_line_text =~ /^[\)\}\]\s]*$/ )
{
# The way to tell this is if the stacked sequence
# numbers of this output line are the reverse of the
# stacked sequence numbers of the previous non-blank
# line of sequence numbers. So we can join if the
# previous nonblank string of tokens is the mirror
# image. For example if stack )}] is 13:8:6 then we
# are looking for a leading stack like [{( which
# is 6:8:13. We only need to check the two ends,
# because the intermediate tokens must fall in order.
# Note on speed: having to split on colons and
# eliminate multiple colons might appear to be slow,
# but it's not an issue because we almost never come
# through here. In a typical file we don't.
$seqno_string =~ s/^:+//;
$last_nonblank_seqno_string =~ s/^:+//;
$seqno_string =~ s/:+/:/g;
$last_nonblank_seqno_string =~ s/:+/:/g;
# how many spaces can we outdent?
my $diff =
$cached_line_leading_space_count - $leading_space_count;
if ( $diff > 0
&& length($seqno_string)
&& length($last_nonblank_seqno_string) ==
length($seqno_string) )
{
my @seqno_last =
( split /:/, $last_nonblank_seqno_string );
my @seqno_now = ( split /:/, $seqno_string );
if ( @seqno_now
&& @seqno_last
&& $seqno_now[-1] == $seqno_last[0]
&& $seqno_now[0] == $seqno_last[-1] )
{
# OK to outdent ..
# for absolute safety, be sure we only remove
# whitespace
my $ws = substr( $test_line, 0, $diff );
if ( ( length($ws) == $diff )
&& $ws =~ /^\s+$/ )
{
$test_line = substr( $test_line, $diff );
$cached_line_leading_space_count -= $diff;
$last_level_written =
$self->level_change(
$cached_line_leading_space_count,
$diff, $last_level_written );
$self->reduce_valign_buffer_indentation($diff);
}
# shouldn't happen, but not critical:
##else {
## ERROR transferring indentation here
##}
}
}
}
# Change the args to look like we received the combined line
$str = $test_line;
$str_length = $test_line_length;
$leading_string = EMPTY_STRING;
$leading_string_length = 0;
$leading_space_count = $cached_line_leading_space_count;
$level = $last_level_written;
$maximum_line_length = $cached_line_maximum_length;
}
else {
$self->valign_output_step_C(
$seqno_string,
$last_nonblank_seqno_string,
$cached_line_text,
$cached_line_leading_space_count,
$last_level_written,
$cached_line_Kend,
);
}
}
return ( $str, $str_length, $leading_string, $leading_string_length,
$leading_space_count, $level, $maximum_line_length );
} ## end sub handle_cached_line
sub valign_output_step_B {
#---------------------------------------------------------
# This is Step B in writing vertically aligned lines.
# Vertical tightness is applied according to preset flags.
# In particular this routine handles stacking of opening
# and closing tokens.
#---------------------------------------------------------
my ( $self, $rinput ) = @_;
my $leading_space_count = $rinput->{leading_space_count};
my $str = $rinput->{line};
my $str_length = $rinput->{line_length};
my $side_comment_length = $rinput->{side_comment_length};
my $outdent_long_lines = $rinput->{outdent_long_lines};
my $rvertical_tightness_flags = $rinput->{rvertical_tightness_flags};
my $level = $rinput->{level};
## my $level_end = $rinput->{level_end};
my $Kend = $rinput->{Kend};
my $maximum_line_length = $rinput->{maximum_line_length};
# Useful -gcs test cases for wide characters are
# perl527/(method.t.2, reg_mesg.t, mime-header.t)
# handle outdenting of long lines:
my $is_outdented_line;
if ($outdent_long_lines) {
my $excess =
$str_length -
$side_comment_length +
$leading_space_count -
$maximum_line_length;
if ( $excess > 0 ) {
$leading_space_count = 0;
my $file_writer_object = $self->[_file_writer_object_];
my $last_outdented_line_at =
$file_writer_object->get_output_line_number();
$self->[_last_outdented_line_at_] = $last_outdented_line_at;
my $outdented_line_count = $self->[_outdented_line_count_];
if ( !$outdented_line_count ) {
$self->[_first_outdented_line_at_] =
$last_outdented_line_at;
}
$outdented_line_count++;
$self->[_outdented_line_count_] = $outdented_line_count;
$is_outdented_line = 1;
}
}
# Make preliminary leading whitespace. It could get changed
# later by entabbing, so we have to keep track of any changes
# to the leading_space_count from here on.
my $leading_string =
$leading_space_count > 0
? ( SPACE x $leading_space_count )
: EMPTY_STRING;
my $leading_string_length = length($leading_string);
# Unpack any recombination data; it was packed by
# sub 'Formatter::set_vertical_tightness_flags'
# old hash Meaning
# index key
#
# 0 _vt_type: 1=opening non-block 2=closing non-block
# 3=opening block brace 4=closing block brace
#
# 1a _vt_opening_flag: 1=no multiple steps, 2=multiple steps ok
# 1b _vt_closing_flag: spaces of padding to use if closing
# 2 _vt_seqno: sequence number of container
# 3 _vt_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
# 4 _vt_seqno_beg: sequence number of first token of line
# 5 _vt_seqno_end: sequence number of last token of line
# 6 _vt_min_lines: min number of lines for joining opening cache,
# 0=no constraint
# 7 _vt_max_lines: max number of lines for joining opening cache,
# 0=no constraint
my ( $open_or_close, $opening_flag, $closing_flag, $seqno, $valid,
$seqno_beg, $seqno_end );
if ($rvertical_tightness_flags) {
$open_or_close = $rvertical_tightness_flags->{_vt_type};
$opening_flag = $rvertical_tightness_flags->{_vt_opening_flag};
$closing_flag = $rvertical_tightness_flags->{_vt_closing_flag};
$seqno = $rvertical_tightness_flags->{_vt_seqno};
$valid = $rvertical_tightness_flags->{_vt_valid_flag};
$seqno_beg = $rvertical_tightness_flags->{_vt_seqno_beg};
$seqno_end = $rvertical_tightness_flags->{_vt_seqno_end};
}
$seqno_string = $seqno_end;
# handle any cached line ..
# either append this line to it or write it out
# Note: the function length() is used in this next test out of caution.
# All testing has shown that the variable $cached_line_text_length is
# correct, but its calculation is complex and a loss of cached text
# would be a disaster.
if ( length($cached_line_text) ) {
(
$str,
$str_length,
$leading_string,
$leading_string_length,
$leading_space_count,
$level,
$maximum_line_length
) = $self->handle_cached_line( $rinput, $leading_string,
$leading_string_length );
$cached_line_type = 0;
$cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
}
# make the line to be written
my $line = $leading_string . $str;
my $line_length = $leading_string_length + $str_length;
# Safety check: be sure that a line to be cached as a stacked block
# brace line ends in the appropriate opening or closing block brace.
# This should always be the case if the caller set flags correctly.
# Code '3' is for -sobb, code '4' is for -scbb.
if ($open_or_close) {
if ( $open_or_close == 3 && $line !~ /\{\s*$/
|| $open_or_close == 4 && $line !~ /\}\s*$/ )
{
$open_or_close = 0;
}
}
# write or cache this line ...
# fix for case b999: do not cache an outdented line
# fix for b1378: do not cache an empty line
if ( !$open_or_close
|| $side_comment_length > 0
|| $is_outdented_line
|| !$line_length )
{
$self->valign_output_step_C(
$seqno_string,
$last_nonblank_seqno_string,
$line,
$leading_space_count,
$level,
$Kend,
);
}
else {
$cached_line_text = $line;
$cached_line_text_length = $line_length;
$cached_line_type = $open_or_close;
$cached_line_opening_flag = $opening_flag;
$cached_line_closing_flag = $closing_flag;
$cached_seqno = $seqno;
$cached_line_valid = $valid;
$cached_line_leading_space_count = $leading_space_count;
$cached_seqno_string = $seqno_string;
$cached_line_Kend = $Kend;
$cached_line_maximum_length = $maximum_line_length;
}
$self->[_last_level_written_] = $level;
$self->[_last_side_comment_length_] = $side_comment_length;
return;
} ## end sub valign_output_step_B
}
################################
# CODE SECTION 10: Output Step C
################################
{ ## closure for sub valign_output_step_C
# Vertical alignment buffer used by valign_output_step_C
my $valign_buffer_filling;
my @valign_buffer;
sub initialize_valign_buffer {
@valign_buffer = ();
$valign_buffer_filling = EMPTY_STRING;
return;
}
sub dump_valign_buffer {
my ($self) = @_;
# Send all lines in the current buffer on to step_D
if (@valign_buffer) {
foreach (@valign_buffer) {
$self->valign_output_step_D( @{$_} );
}
@valign_buffer = ();
}
$valign_buffer_filling = EMPTY_STRING;
return;
} ## end sub dump_valign_buffer
sub reduce_valign_buffer_indentation {
my ( $self, $diff ) = @_;
# Reduce the leading indentation of lines in the current
# buffer by $diff spaces
if ( $valign_buffer_filling && $diff ) {
my $max_valign_buffer = @valign_buffer;
foreach my $i ( 0 .. $max_valign_buffer - 1 ) {
my ( $line, $leading_space_count, $level, $Kend ) =
@{ $valign_buffer[$i] };
my $ws = substr( $line, 0, $diff );
if ( ( length($ws) == $diff ) && $ws =~ /^\s+$/ ) {
$line = substr( $line, $diff );
}
if ( $leading_space_count >= $diff ) {
$leading_space_count -= $diff;
$level =
$self->level_change( $leading_space_count, $diff,
$level );
}
$valign_buffer[$i] =
[ $line, $leading_space_count, $level, $Kend ];
}
}
return;
} ## end sub reduce_valign_buffer_indentation
sub valign_output_step_C {
#-----------------------------------------------------------------------
# This is Step C in writing vertically aligned lines.
# Lines are either stored in a buffer or passed along to the next step.
# The reason for storing lines is that we may later want to reduce their
# indentation when -sot and -sct are both used.
#-----------------------------------------------------------------------
my (
$self,
$seqno_string,
$last_nonblank_seqno_string,
@args_to_D,
) = @_;
# Dump any saved lines if we see a line with an unbalanced opening or
# closing token.
$self->dump_valign_buffer()
if ( $seqno_string && $valign_buffer_filling );
# Either store or write this line
if ($valign_buffer_filling) {
push @valign_buffer, [@args_to_D];
}
else {
$self->valign_output_step_D(@args_to_D);
}
# For lines starting or ending with opening or closing tokens..
if ($seqno_string) {
$last_nonblank_seqno_string = $seqno_string;
set_last_nonblank_seqno_string($seqno_string);
# Start storing lines when we see a line with multiple stacked
# opening tokens.
# patch for RT #94354, requested by Colin Williams
if ( index( $seqno_string, ':' ) >= 0
&& $seqno_string =~ /^\d+(\:+\d+)+$/
&& $args_to_D[0] !~ /^[\}\)\]\:\?]/ )
{
# This test is efficient but a little subtle: The first test
# says that we have multiple sequence numbers and hence
# multiple opening or closing tokens in this line. The second
# part of the test rejects stacked closing and ternary tokens.
# So if we get here then we should have stacked unbalanced
# opening tokens.
# Here is a complex example:
# Foo($Bar[0], { # (side comment)
# baz => 1,
# });
# The first line has sequence 6::4. It does not begin with
# a closing token or ternary, so it passes the test and must be
# stacked opening tokens.
# The last line has sequence 4:6 but is a stack of closing
# tokens, so it gets rejected.
# Note that the sequence number of an opening token for a qw
# quote is a negative number and will be rejected. For
# example, for the following line: skip_symbols([qw(
# $seqno_string='10:5:-1'. It would be okay to accept it but I
# decided not to do this after testing.
$valign_buffer_filling = $seqno_string;
}
}
return;
} ## end sub valign_output_step_C
}
###############################
# CODE SECTION 11: Output Step D
###############################
sub add_leading_tabs {
my ( $line, $leading_space_count, $level ) = @_;
# Convert leading whitespace to use tabs if -et or -t are set
# Given:
# $line = the line of text to be written, without any tabs
# $leading_whitespace = expected number of leading blank spaces
# $level = indentation level (needed for -t)
# Return:
# $line = the line with possible leading tabs
my $trimmed_line = $line;
$trimmed_line =~ s/^ [^\S\n]+ //gxm;
# Check for discrepancy in actual leading white spaces with estimate
if ( length($line) != length($trimmed_line) + $leading_space_count ) {
# If $leading_space_count is zero, then this routine must not
# be called because we might be in a quote of some kind
if ( $leading_space_count <= 0 ) {
DEVEL_MODE && Fault(< 0 ) {
$line = add_leading_tabs( $line, $leading_space_count, $level );
}
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_code_line( $line . "\n", $Kend );
return;
} ## end sub valign_output_step_D
##########################
# CODE SECTION 12: Summary
##########################
sub report_anything_unusual {
my $self = shift;
my $outdented_line_count = $self->[_outdented_line_count_];
if ( $outdented_line_count > 0 ) {
write_logfile_entry(
"$outdented_line_count long lines were outdented:\n");
my $first_outdented_line_at = $self->[_first_outdented_line_at_];
write_logfile_entry(
" First at output line $first_outdented_line_at\n");
if ( $outdented_line_count > 1 ) {
my $last_outdented_line_at = $self->[_last_outdented_line_at_];
write_logfile_entry(
" Last at output line $last_outdented_line_at\n");
}
write_logfile_entry(
" use -noll to prevent outdenting, -l=n to increase line length\n"
);
write_logfile_entry("\n");
}
return;
} ## end sub report_anything_unusual
} ## end package Perl::Tidy::VerticalAligner
1;
Perl-Tidy-20250105/lib/Perl/Tidy/Debugger.pm 0000644 0001750 0001750 00000007265 14735302771 017307 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Debugger class shows line tokenization
#
#####################################################################
package Perl::Tidy::Debugger;
use strict;
use warnings;
use English qw( -no_match_vars );
our $VERSION = '20250105';
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
sub new {
my ( $class, $filename, $is_encoded_data ) = @_;
return bless {
_debug_file => $filename,
_debug_file_opened => 0,
_fh => undef,
_is_encoded_data => $is_encoded_data,
}, $class;
} ## end sub new
sub really_open_debug_file {
my $self = shift;
my $debug_file = $self->{_debug_file};
my $is_encoded_data = $self->{_is_encoded_data};
my $fh = Perl::Tidy::streamhandle( $debug_file, 'w', $is_encoded_data );
if ( !$fh ) {
Perl::Tidy::Warn("can't open debug file '$debug_file'\n");
}
$self->{_debug_file_opened} = 1;
$self->{_fh} = $fh;
$fh->print(
"Use -dump-token-types (-dtt) to get a list of token type codes\n");
return;
} ## end sub really_open_debug_file
sub close_debug_file {
my $self = shift;
if ( $self->{_debug_file_opened} ) {
my $fh = $self->{_fh};
my $debug_file = $self->{_debug_file};
if ( $fh
&& $fh->can('close')
&& $debug_file ne '-'
&& !ref($debug_file) )
{
$fh->close()
or Perl::Tidy::Warn(
"can't close DEBUG file '$debug_file': $OS_ERROR\n");
}
}
return;
} ## end sub close_debug_file
sub write_debug_entry {
# This is a debug dump routine which may be modified as necessary
# to dump tokens on a line-by-line basis. The output will be written
# to the .DEBUG file when the -D flag is entered.
my ( $self, $line_of_tokens ) = @_;
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
my $input_line_number = $line_of_tokens->{_line_number};
## uncomment if needed:
## my $input_line = $line_of_tokens->{_line_text};
## my $rlevels = $line_of_tokens->{_rlevels};
## my $line_type = $line_of_tokens->{_line_type};
my $token_str = "$input_line_number: ";
my $reconstructed_original = "$input_line_number: ";
my $pattern = EMPTY_STRING;
my @next_char = ( '"', '"' );
my $i_next = 0;
if ( !$self->{_debug_file_opened} ) {
$self->really_open_debug_file();
}
my $fh = $self->{_fh};
foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
# testing patterns
if ( $rtoken_type->[$j] eq 'k' ) {
$pattern .= $rtokens->[$j];
}
else {
$pattern .= $rtoken_type->[$j];
}
$reconstructed_original .= $rtokens->[$j];
my $num = length( $rtokens->[$j] );
my $type_str = $rtoken_type->[$j];
# be sure there are no blank tokens (shouldn't happen)
# This can only happen if a programming error has been made
# because all valid tokens are non-blank
if ( $type_str eq SPACE ) {
$fh->print("BLANK TOKEN on the next line\n");
$type_str = $next_char[$i_next];
$i_next = 1 - $i_next;
}
if ( length($type_str) == 1 ) {
$type_str = $type_str x $num;
}
$token_str .= $type_str;
}
# Write what you want here ...
# $fh->print "$input_line\n";
# $fh->print "$pattern\n";
$fh->print("$reconstructed_original\n");
$fh->print("$token_str\n");
return;
} ## end sub write_debug_entry
1;
Perl-Tidy-20250105/lib/Perl/Tidy/IOScalarArray.pm 0000644 0001750 0001750 00000006407 14735302776 020221 0 ustar steve steve #####################################################################
#
# This is a stripped down version of IO::ScalarArray
# Given a reference to an array, it supplies either:
# a getline method which reads lines (mode='r'), or
# a print method which reads lines (mode='w')
#
# NOTE: this routine assumes that there aren't any embedded
# newlines within any of the array elements. There are no checks
# for that.
#
#####################################################################
package Perl::Tidy::IOScalarArray;
use strict;
use warnings;
use Carp;
our $VERSION = '20250105';
use constant DEVEL_MODE => 0;
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
# Originally there was a dummy sub close. All calls to it should have been
# eliminated, but for safety we will check for them here.
return 1 if ( $AUTOLOAD =~ /\bclose$/ && !DEVEL_MODE );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} <[1];
if ( $mode ne 'r' ) {
confess <[2]++;
return $self->[0]->[$i];
} ## end sub getline
sub print {
my ( $self, $msg ) = @_;
my $mode = $self->[1];
if ( $mode ne 'w' ) {
confess <[0] }, $msg;
return;
} ## end sub print
1;
Perl-Tidy-20250105/lib/Perl/Tidy/Tokenizer.pm 0000644 0001750 0001750 00001426415 14735303000 017522 0 ustar steve steve #####################################################################
#
# Perl::Tidy::Tokenizer reads a source and breaks it into a stream of tokens
#
# Usage Outline:
#
# STEP 1: initialize or re-initialize Tokenizer with user options
# Perl::Tidy::Tokenizer::check_options($rOpts);
#
# STEP 2: create a tokenizer for a specific input source object
# my $tokenizer = Perl::Tidy::Tokenizer->new(
# source_object => $source,
# ...
# );
#
# STEP 3: get and process each tokenized 'line' (a hash ref of token info)
# while ( my $line = $tokenizer->get_line() ) {
# $formatter->write_line($line);
# }
#
# STEP 4: report errors
# my $severe_error = $tokenizer->report_tokenization_errors();
#
# The source object can be a STRING ref, an ARRAY ref, or an object with a
# get_line() method which supplies one line (a character string) perl call.
#
# NOTE: This is not a real class. Only one tokenizer my be used.
#
########################################################################
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
use English qw( -no_match_vars );
our $VERSION = '20250105';
use Carp;
use constant DEVEL_MODE => 0;
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
use constant BACKSLASH => q{\\};
{ #<<< A non-indenting brace to contain all lexical variables
# Parent sequence number of tree of containers; must be 1
use constant SEQ_ROOT => 1;
# Defaults for guessing old indentation
use constant INDENT_COLUMNS_DEFAULT => 4;
use constant TAB_SIZE_DEFAULT => 8;
# Decimal values of some ascii characters for quick checks
use constant ORD_TAB => 9;
use constant ORD_SPACE => 32;
use constant ORD_PRINTABLE_MIN => 33;
use constant ORD_PRINTABLE_MAX => 126;
# A limit on message length when problems are detected
use constant LONG_MESSAGE => 256;
# GLOBAL VARIABLES which change during tokenization:
# These could also be stored in $self but it is more convenient and
# efficient to make them global lexical variables.
# INITIALIZER: sub prepare_for_a_new_file
my (
$brace_depth,
$context,
$current_package,
$last_nonblank_block_type,
$last_nonblank_token,
$last_nonblank_type,
$next_sequence_number,
$paren_depth,
$rbrace_context,
$rbrace_package,
$rbrace_structural_type,
$rbrace_type,
$rcurrent_depth,
$rcurrent_sequence_number,
$rdepth_array,
$ris_block_function,
$ris_block_list_function,
$ris_constant,
$ris_user_function,
$rnested_statement_type,
$rnested_ternary_flag,
$rparen_semicolon_count,
$rparen_vars,
$rparen_type,
$rsaw_function_definition,
$rsaw_use_module,
$rsquare_bracket_structural_type,
$rsquare_bracket_type,
$rstarting_line_of_current_depth,
$rtotal_depth,
$ruser_function_prototype,
$square_bracket_depth,
$statement_type,
$total_depth,
);
my (
# GLOBAL CONSTANTS for routines in this package,
# INITIALIZER: BEGIN block.
%can_start_digraph,
%expecting_operator_token,
%expecting_operator_types,
%expecting_term_token,
%expecting_term_types,
%is_block_operator,
%is_digraph,
%is_file_test_operator,
%is_if_elsif_unless,
%is_if_elsif_unless_case_when,
%is_indirect_object_taker,
%is_keyword_rejecting_question_as_pattern_delimiter,
%is_keyword_rejecting_slash_as_pattern_delimiter,
%is_keyword_taking_list,
%is_keyword_taking_optional_arg,
%is_q_qq_qw_qx_qr_s_y_tr_m,
%is_q_qq_qx_qr_s_y_tr_m,
%quote_modifiers,
%is_semicolon_or_t,
%is_sort_map_grep,
%is_sort_map_grep_eval_do,
%is_tetragraph,
%is_trigraph,
%is_valid_token_type,
%other_line_endings,
%really_want_term,
@closing_brace_names,
@opening_brace_names,
# GLOBAL CONSTANT hash lookup table of operator expected values
# INITIALIZER: BEGIN block
%op_expected_table,
# GLOBAL VARIABLES which are constant after being configured.
# INITIALIZER: BEGIN block and modified by sub check_options
%is_code_block_token,
%is_keyword,
%is_my_our_state,
%is_package,
%matching_end_token,
# INITIALIZER: sub check_options
$code_skipping_pattern_begin,
$code_skipping_pattern_end,
$format_skipping_pattern_begin,
$format_skipping_pattern_end,
$rOpts_code_skipping,
$rOpts_code_skipping_begin,
$rOpts_format_skipping,
$rOpts_format_skipping_begin,
$rOpts_format_skipping_end,
$rOpts_starting_indentation_level,
$rOpts_indent_columns,
$rOpts_look_for_hash_bang,
$rOpts_look_for_autoloader,
$rOpts_look_for_selfloader,
$rOpts_trim_qw,
$rOpts_extended_syntax,
$rOpts_continuation_indentation,
$rOpts_outdent_labels,
$rOpts_maximum_level_errors,
$rOpts_maximum_unexpected_errors,
$rOpts_indent_closing_brace,
$rOpts_non_indenting_braces,
$rOpts_non_indenting_brace_prefix,
$rOpts_whitespace_cycle,
$tabsize,
%is_END_DATA_format_sub,
%is_grep_alias,
%is_sub,
$guess_if_method,
);
# possible values of operator_expected()
use constant TERM => -1;
use constant UNKNOWN => 0;
use constant OPERATOR => 1;
# possible values of context
use constant SCALAR_CONTEXT => -1;
use constant UNKNOWN_CONTEXT => 0;
use constant LIST_CONTEXT => 1;
# Maximum number of little messages; probably need not be changed.
use constant MAX_NAG_MESSAGES => 6;
BEGIN {
# Array index names for $self.
# Do not combine with other BEGIN blocks (c101).
my $i = 0;
use constant {
_rhere_target_list_ => $i++,
_in_here_doc_ => $i++,
_here_doc_target_ => $i++,
_here_quote_character_ => $i++,
_in_data_ => $i++,
_in_end_ => $i++,
_in_format_ => $i++,
_in_error_ => $i++,
_in_trouble_ => $i++,
_warning_count_ => $i++,
_html_tag_count_ => $i++,
_in_pod_ => $i++,
_in_code_skipping_ => $i++,
_in_format_skipping_ => $i++,
_in_attribute_list_ => $i++,
_in_quote_ => $i++,
_quote_target_ => $i++,
_line_start_quote_ => $i++,
_starting_level_ => $i++,
_know_starting_level_ => $i++,
_last_line_number_ => $i++,
_saw_perl_dash_P_ => $i++,
_saw_perl_dash_w_ => $i++,
_saw_use_strict_ => $i++,
_saw_brace_error_ => $i++,
_hit_bug_ => $i++,
_look_for_autoloader_ => $i++,
_look_for_selfloader_ => $i++,
_saw_autoloader_ => $i++,
_saw_selfloader_ => $i++,
_saw_hash_bang_ => $i++,
_saw_end_ => $i++,
_saw_data_ => $i++,
_saw_negative_indentation_ => $i++,
_started_tokenizing_ => $i++,
_debugger_object_ => $i++,
_diagnostics_object_ => $i++,
_logger_object_ => $i++,
_save_logfile_ => $i++,
_unexpected_error_count_ => $i++,
_started_looking_for_here_target_at_ => $i++,
_nearly_matched_here_target_at_ => $i++,
_line_of_text_ => $i++,
_rlower_case_labels_at_ => $i++,
_maximum_level_ => $i++,
_true_brace_error_count_ => $i++,
_rOpts_ => $i++,
_rinput_lines_ => $i++,
_input_line_index_next_ => $i++,
_rtrimmed_input_lines_ => $i++,
_rclosing_brace_indentation_hash_ => $i++,
_show_indentation_table_ => $i++,
_rnon_indenting_brace_stack_ => $i++,
_rbareword_info_ => $i++,
};
} ## end BEGIN
{ ## closure for subs to count instances
# methods to count instances
my $_count = 0;
sub get_count { return $_count; }
sub _increment_count { return ++$_count }
sub _decrement_count { return --$_count }
}
sub DESTROY {
my $self = shift;
_decrement_count();
return;
}
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} <get_input_stream_name();
}
Die(<{$opt_name};
if ( !$param ) { $param = $default }
$param =~ s/^\s+//;
if ( $param !~ /^#/ ) {
Die("ERROR: the $opt_name parameter '$param' must begin with '#'\n");
}
# Note that the ending \s will match a newline
my $pattern = '^\s*' . $param . '\s';
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the $opt_name parameter '$param' causes the invalid regex '$pattern'\n"
);
}
return $pattern;
} ## end sub make_skipping_pattern
sub check_options {
# Check and pre-process tokenizer parameters
my $rOpts = shift;
%is_sub = ();
$is_sub{'sub'} = 1;
%is_END_DATA_format_sub = (
'__END__' => 1,
'__DATA__' => 1,
'format' => 1,
'sub' => 1,
);
# Install any aliases to '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 = split /\s+/, $rOpts->{'sub-alias-list'};
foreach my $word (@sub_alias_list) {
$is_sub{$word} = 1;
$is_END_DATA_format_sub{$word} = 1;
}
}
# Set global flag to say if we have to guess if bareword 'method' is
# a sub when 'method' is in %is_sub. This will be true unless:
# (1) the user entered 'method' as sub alias, or
# (2) the user set --use-feature=class
# In these two cases we can assume that 'method' is a sub alias.
$guess_if_method = 1;
if ( $is_sub{'method'} ) { $guess_if_method = 0 }
#------------------------------------------------
# Update hash values for any -use-feature options
#------------------------------------------------
my $use_feature_class = 1;
if ( $rOpts->{'use-feature'} ) {
if ( $rOpts->{'use-feature'} =~ /\bnoclass\b/ ) {
$use_feature_class = 0;
}
elsif ( $rOpts->{'use-feature'} =~ /\bclass\b/ ) {
$guess_if_method = 0;
}
else {
## neither 'class' nor 'noclass' seen so use default
}
}
# These are the main updates for this option. There are additional
# changes elsewhere, usually indicated with a comment 'rt145706'
# Update hash values for use_feature=class, added for rt145706
# see 'perlclass.pod'
# IMPORTANT: We are changing global hash values initially set in a BEGIN
# block. Values must be defined (true or false) for each of these new
# words whether true or false. Otherwise, programs using the module which
# change options between runs (such as test code) will have
# incorrect settings and fail.
# There are 4 new keywords:
# 'class' - treated specially as generalization of 'package'
# Note: we must not set 'class' to be a keyword to avoid problems
# with older uses.
$is_package{'class'} = $use_feature_class;
# 'method' - treated like sub using the sub-alias-list option
# Note: we must not set 'method' to be a keyword to avoid problems
# with older uses.
if ($use_feature_class) {
$is_sub{'method'} = 1;
$is_END_DATA_format_sub{'method'} = 1;
}
# 'field' - added as a keyword, and works like 'my'
$is_keyword{'field'} = $use_feature_class;
$is_my_our_state{'field'} = $use_feature_class;
# 'ADJUST' - added as a keyword and works like 'BEGIN'
# TODO: if ADJUST gets a paren list, this will need to be updated
$is_keyword{'ADJUST'} = $use_feature_class;
$is_code_block_token{'ADJUST'} = $use_feature_class;
%is_grep_alias = ();
if ( $rOpts->{'grep-alias-list'} ) {
# Note that 'grep-alias-list' has been preprocessed to be a trimmed,
# space-separated list
my @q = split /\s+/, $rOpts->{'grep-alias-list'};
@is_grep_alias{@q} = (1) x scalar(@q);
}
$rOpts_starting_indentation_level = $rOpts->{'starting-indentation-level'};
$rOpts_indent_columns = $rOpts->{'indent-columns'};
$rOpts_look_for_hash_bang = $rOpts->{'look-for-hash-bang'};
$rOpts_look_for_autoloader = $rOpts->{'look-for-autoloader'};
$rOpts_look_for_selfloader = $rOpts->{'look-for-selfloader'};
$rOpts_trim_qw = $rOpts->{'trim-qw'};
$rOpts_extended_syntax = $rOpts->{'extended-syntax'};
$rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
$rOpts_outdent_labels = $rOpts->{'outdent-labels'};
$rOpts_maximum_level_errors = $rOpts->{'maximum-level-errors'};
$rOpts_maximum_unexpected_errors = $rOpts->{'maximum-unexpected-errors'};
$rOpts_code_skipping = $rOpts->{'code-skipping'};
$rOpts_code_skipping_begin = $rOpts->{'code-skipping-begin'};
$rOpts_format_skipping = $rOpts->{'format-skipping'};
$rOpts_format_skipping_begin = $rOpts->{'format-skipping-begin'};
$rOpts_format_skipping_end = $rOpts->{'format-skipping-end'};
$rOpts_indent_closing_brace = $rOpts->{'indent-closing-brace'};
$rOpts_non_indenting_braces = $rOpts->{'non-indenting-braces'};
$rOpts_non_indenting_brace_prefix = $rOpts->{'non-indenting-brace-prefix'};
$rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
# In the Tokenizer, --indent-columns is just used for guessing old
# indentation, and must be positive. If -i=0 is used for this run (which
# is possible) we'll just guess that the old run used 4 spaces per level.
if ( !$rOpts_indent_columns ) {
$rOpts_indent_columns = INDENT_COLUMNS_DEFAULT;
}
# Define $tabsize, the number of spaces per tab for use in
# guessing the indentation of source lines with leading tabs.
# Assume same as for this run if tabs are used, otherwise assume
# a default value, typically 8
$tabsize =
$rOpts->{'entab-leading-whitespace'}
? $rOpts->{'entab-leading-whitespace'}
: $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
: $rOpts->{'default-tabsize'};
if ( !$tabsize ) { $tabsize = TAB_SIZE_DEFAULT }
$code_skipping_pattern_begin =
make_skipping_pattern( $rOpts, 'code-skipping-begin', '#<>V' );
$format_skipping_pattern_begin =
make_skipping_pattern( $rOpts, 'format-skipping-begin', '#<<<' );
$format_skipping_pattern_end =
make_skipping_pattern( $rOpts, 'format-skipping-end', '#>>>' );
return;
} ## end sub check_options
sub new {
my ( $class, @arglist ) = @_;
if ( @arglist % 2 ) { croak "Odd number of items in arg hash list\n" }
my %defaults = (
source_object => undef,
debugger_object => undef,
diagnostics_object => undef,
logger_object => undef,
starting_level => undef,
starting_line_number => 1,
rOpts => {},
);
my %args = ( %defaults, @arglist );
# we are given an object with a get_line() method to supply source lines
my $source_object = $args{source_object};
my $rOpts = $args{rOpts};
# Check call args
if ( !defined($source_object) ) {
Die(
"Perl::Tidy::Tokenizer::new called without a 'source_object' parameter\n"
);
}
if ( !ref($source_object) ) {
Die(<[_rhere_target_list_] = [];
$self->[_in_here_doc_] = 0;
$self->[_here_doc_target_] = EMPTY_STRING;
$self->[_here_quote_character_] = EMPTY_STRING;
$self->[_in_data_] = 0;
$self->[_in_end_] = 0;
$self->[_in_format_] = 0;
$self->[_in_error_] = 0;
$self->[_in_trouble_] = 0;
$self->[_warning_count_] = 0;
$self->[_html_tag_count_] = 0;
$self->[_in_pod_] = 0;
$self->[_in_code_skipping_] = 0;
$self->[_in_format_skipping_] = 0;
$self->[_in_attribute_list_] = 0;
$self->[_in_quote_] = 0;
$self->[_quote_target_] = EMPTY_STRING;
$self->[_line_start_quote_] = -1;
$self->[_starting_level_] = $args{starting_level};
$self->[_know_starting_level_] = defined( $args{starting_level} );
$self->[_last_line_number_] = $args{starting_line_number} - 1;
$self->[_saw_perl_dash_P_] = 0;
$self->[_saw_perl_dash_w_] = 0;
$self->[_saw_use_strict_] = 0;
$self->[_saw_brace_error_] = 0;
$self->[_hit_bug_] = 0;
$self->[_look_for_autoloader_] = $rOpts_look_for_autoloader;
$self->[_look_for_selfloader_] = $rOpts_look_for_selfloader;
$self->[_saw_autoloader_] = 0;
$self->[_saw_selfloader_] = 0;
$self->[_saw_hash_bang_] = 0;
$self->[_saw_end_] = 0;
$self->[_saw_data_] = 0;
$self->[_saw_negative_indentation_] = 0;
$self->[_started_tokenizing_] = 0;
$self->[_debugger_object_] = $args{debugger_object};
$self->[_diagnostics_object_] = $args{diagnostics_object};
$self->[_logger_object_] = $logger_object;
$self->[_unexpected_error_count_] = 0;
$self->[_started_looking_for_here_target_at_] = 0;
$self->[_nearly_matched_here_target_at_] = undef;
$self->[_line_of_text_] = EMPTY_STRING;
$self->[_rlower_case_labels_at_] = undef;
$self->[_maximum_level_] = 0;
$self->[_true_brace_error_count_] = 0;
$self->[_rnon_indenting_brace_stack_] = [];
$self->[_show_indentation_table_] = 0;
$self->[_rbareword_info_] = {};
$self->[_rclosing_brace_indentation_hash_] = {
valid => undef,
rhistory_line_number => [0],
rhistory_level_diff => [0],
rhistory_anchor_point => [1],
};
$self->[_rOpts_] = $rOpts;
$self->[_save_logfile_] =
defined($logger_object) && $logger_object->get_save_logfile();
bless $self, $class;
$self->prepare_for_a_new_file($source_object);
$self->find_starting_indentation_level();
# This is not a full class yet, so die if an attempt is made to
# create more than one object.
if ( _increment_count() > 1 ) {
confess
"Attempt to create more than 1 object in $class, which is not a true class yet\n";
}
return $self;
} ## end sub new
# Called externally
sub get_unexpected_error_count {
my ($self) = @_;
return $self->[_unexpected_error_count_];
}
# Called externally
sub is_keyword {
my ($str) = @_;
return $is_keyword{$str};
}
#----------------------------------------------------------------
# Line input routines, previously handled by the LineBuffer class
#----------------------------------------------------------------
sub make_source_array {
my ( $self, $line_source_object ) = @_;
# Convert the source into an array of lines
# Given:
# $line_source_object = the input source stream
# Task:
# Convert the source to an array ref and store in $self
my $rinput_lines = [];
my $rsource = ref($line_source_object);
my $source_string;
if ( !$rsource ) {
# shouldn't happen: this should have been checked in sub new
$self->Fault(<get_line() ) ) {
push( @{$rinput_lines}, $line );
}
$source_string = join( EMPTY_STRING, @{$rinput_lines} );
}
# Get trimmed lines. It is much faster to strip leading whitespace from
# the whole input file at once than line-by-line.
# Add a terminal newline if needed to keep line count unchanged:
# - avoids problem of losing a last line which is just \r and no \n (c283)
# - but check input line count to avoid adding line to an empty file (c286)
if ( @{$rinput_lines} && $source_string !~ /\n$/ ) {
$source_string .= "\n";
}
# Remove leading whitespace except newlines
$source_string =~ s/^ [^\S\n]+ //gxm;
# Then break the string into lines
my @trimmed_lines = split /^/, $source_string;
# Safety check - a change in number of lines would be a disaster
if ( @trimmed_lines != @{$rinput_lines} ) {
# Shouldn't happen - die in DEVEL_MODE and fix
my $ntr = @trimmed_lines;
my $utr = @{$rinput_lines};
DEVEL_MODE
&& $self->Fault(
"trimmed / untrimmed line counts differ: $ntr / $utr\n");
# Otherwise we can safely continue with undefined trimmed lines. They
# will be detected and fixed later.
@trimmed_lines = ();
}
$self->[_rinput_lines_] = $rinput_lines;
$self->[_rtrimmed_input_lines_] = \@trimmed_lines;
$self->[_input_line_index_next_] = 0;
return;
} ## end sub make_source_array
sub peek_ahead {
my ( $self, $buffer_index ) = @_;
# look $buffer_index lines ahead of the current location in the input
# stream without disturbing the input
my $line;
my $rinput_lines = $self->[_rinput_lines_];
my $line_index = $buffer_index + $self->[_input_line_index_next_];
if ( $line_index < @{$rinput_lines} ) {
$line = $rinput_lines->[$line_index];
}
return $line;
} ## end sub peek_ahead
#-----------------------------------------
# interface to Perl::Tidy::Logger routines
#-----------------------------------------
sub warning {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
$self->[_warning_count_]++;
if ($logger_object) {
my $msg_line_number = $self->[_last_line_number_];
$logger_object->warning( $msg, $msg_line_number );
}
return;
} ## end sub warning
sub get_input_stream_name {
my $self = shift;
my $input_stream_name = EMPTY_STRING;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
return $input_stream_name;
} ## end sub get_input_stream_name
sub complain {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
my $input_line_number = $self->[_last_line_number_];
$logger_object->complain( $msg, $input_line_number );
}
return;
} ## end sub complain
sub write_logfile_entry {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
} ## end sub write_logfile_entry
sub interrupt_logfile {
my $self = shift;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->interrupt_logfile();
}
return;
} ## end sub interrupt_logfile
sub resume_logfile {
my $self = shift;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->resume_logfile();
}
return;
} ## end sub resume_logfile
sub brace_warning {
my ( $self, $msg ) = @_;
$self->[_saw_brace_error_]++;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
my $msg_line_number = $self->[_last_line_number_];
$logger_object->brace_warning( $msg, $msg_line_number );
}
return;
} ## end sub brace_warning
sub increment_brace_error {
# This is same as sub brace_warning but without a message
my $self = shift;
$self->[_saw_brace_error_]++;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->increment_brace_error();
}
return;
} ## end sub increment_brace_error
sub get_saw_brace_error {
my $self = shift;
return $self->[_saw_brace_error_];
}
sub report_definite_bug {
my $self = shift;
$self->[_hit_bug_] = 1;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->report_definite_bug();
}
return;
} ## end sub report_definite_bug
#-------------------------------------
# Interface to Perl::Tidy::Diagnostics
#-------------------------------------
sub write_diagnostics {
my ( $self, $msg ) = @_;
my $input_line_number = $self->[_last_line_number_];
my $diagnostics_object = $self->[_diagnostics_object_];
if ($diagnostics_object) {
$diagnostics_object->write_diagnostics( $msg, $input_line_number );
}
return;
} ## end sub write_diagnostics
sub report_tokenization_errors {
my ($self) = @_;
# Report any tokenization errors and return a flag '$severe_error'.
# Set $severe_error = 1 if the tokenization errors are so severe that
# the formatter should not attempt to format the file. Instead, it will
# just output the file verbatim.
# set severe error flag if tokenizer has encountered file reading problems
# (i.e. unexpected binary characters)
# or code which may not be formatted correctly (such as 'my sub q')
# The difference between _in_error_ and _in_trouble_ is that
# _in_error_ stops the tokenizer immediately whereas
# _in_trouble_ lets the tokenizer finish so that all errors are seen
# Both block formatting and cause the input stream to be output verbatim.
my $severe_error = $self->[_in_error_] || $self->[_in_trouble_];
# And do not format if it looks like an html file (c209)
$severe_error ||= $self->[_html_tag_count_] && $self->[_warning_count_];
# Inform the logger object on length of input stream
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
my $last_line_number = $self->[_last_line_number_];
$logger_object->set_last_input_line_number($last_line_number);
}
my $maxle = $rOpts_maximum_level_errors;
my $maxue = $rOpts_maximum_unexpected_errors;
$maxle = 1 unless defined($maxle);
$maxue = 0 unless defined($maxue);
my $level = get_indentation_level();
if ( $level != $self->[_starting_level_] ) {
$self->warning("final indentation level: $level\n");
$self->[_show_indentation_table_] = 1;
my $level_diff = $self->[_starting_level_] - $level;
if ( $level_diff < 0 ) { $level_diff = -$level_diff }
# Set severe error flag if the level error is greater than 1.
# The formatter can function for any level error but it is probably
# best not to attempt formatting for a high level error.
if ( $maxle >= 0 && $level_diff > $maxle ) {
$severe_error = 1;
$self->warning(<check_final_nesting_depths();
if ( $self->[_show_indentation_table_] ) {
$self->show_indentation_table();
}
# Likewise, large numbers of brace errors usually indicate non-perl
# scripts, so set the severe error flag at a low number. This is similar
# to the level check, but different because braces may balance but be
# incorrectly interlaced.
if ( $self->[_true_brace_error_count_] > 2 ) {
$severe_error = 1;
}
if ( $rOpts_look_for_hash_bang
&& !$self->[_saw_hash_bang_] )
{
$self->warning(
"hit EOF without seeing hash-bang line; maybe don't need -x?\n");
}
if ( $self->[_in_format_] ) {
$self->warning("hit EOF while in format description\n");
}
if ( $self->[_in_code_skipping_] ) {
$self->write_logfile_entry(
"hit EOF while in lines skipped with --code-skipping\n");
}
if ( $self->[_in_pod_] ) {
# Just write log entry if this is after __END__ or __DATA__
# because this happens to often, and it is not likely to be
# a parsing error.
if ( $self->[_saw_data_] || $self->[_saw_end_] ) {
$self->write_logfile_entry(
"hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
);
}
else {
$self->complain(
"hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
);
}
}
if ( $self->[_in_here_doc_] ) {
$severe_error = 1;
my $here_doc_target = $self->[_here_doc_target_];
my $started_looking_for_here_target_at =
$self->[_started_looking_for_here_target_at_];
if ($here_doc_target) {
$self->warning(
"hit EOF in here document starting at line $started_looking_for_here_target_at with target: $here_doc_target\n"
);
}
else {
$self->warning(<[_nearly_matched_here_target_at_];
if ($nearly_matched_here_target_at) {
$self->warning(
"NOTE: almost matched at input line $nearly_matched_here_target_at except for whitespace\n"
);
}
}
# Something is seriously wrong if we ended inside a quote
if ( $self->[_in_quote_] ) {
$severe_error = 1;
my $line_start_quote = $self->[_line_start_quote_];
my $quote_target = $self->[_quote_target_];
my $what =
( $self->[_in_attribute_list_] )
? "attribute list"
: "quote/pattern";
$self->warning(
"hit EOF seeking end of $what starting at line $line_start_quote ending in $quote_target\n"
);
}
if ( $self->[_hit_bug_] ) {
$severe_error = 1;
}
# Multiple "unexpected" type tokenization errors usually indicate parsing
# non-perl scripts, or that something is seriously wrong, so we should
# avoid formatting them. This can happen for example if we run perltidy on
# a shell script or an html file. But unfortunately this check can
# interfere with some extended syntaxes, such as RPerl, so it has to be off
# by default.
my $ue_count = $self->[_unexpected_error_count_];
if ( $maxue > 0 && $ue_count > $maxue ) {
$self->warning(< -maxue=$maxue; use -maxue=0 to force formatting
EOM
$severe_error = 1;
}
if ( !$self->[_saw_perl_dash_w_] ) {
$self->write_logfile_entry("Suggest including 'use warnings;'\n");
}
if ( $self->[_saw_perl_dash_P_] ) {
$self->write_logfile_entry(
"Use of -P parameter for defines is discouraged\n");
}
if ( !$self->[_saw_use_strict_] ) {
$self->write_logfile_entry("Suggest including 'use strict;'\n");
}
# it is suggested that labels have at least one upper case character
# for legibility and to avoid code breakage as new keywords are introduced
if ( $self->[_rlower_case_labels_at_] ) {
my @lower_case_labels_at = @{ $self->[_rlower_case_labels_at_] };
$self->write_logfile_entry(
"Suggest using upper case characters in label(s)\n");
local $LIST_SEPARATOR = ')(';
$self->write_logfile_entry(
" defined at line(s): (@lower_case_labels_at)\n");
}
return $severe_error;
} ## end sub report_tokenization_errors
sub show_indentation_table {
my ($self) = @_;
# Output indentation table made at closing braces. This can be helpful for
# the case of a missing brace in a previously formatted file.
# skip if -wc is used (rare); it is too complex to use
return if ($rOpts_whitespace_cycle);
# skip if non-indenting-brace-prefix (very rare, but could be fixed)
return if ($rOpts_non_indenting_brace_prefix);
# skip if starting level is not zero (probably in editor)
return if ($rOpts_starting_indentation_level);
# skip if indentation analysis is not valid
my $rhash = $self->[_rclosing_brace_indentation_hash_];
return if ( !$rhash->{valid} );
my $rhistory_line_number = $rhash->{rhistory_line_number};
my $rhistory_level_diff = $rhash->{rhistory_level_diff};
my $rhistory_anchor_point = $rhash->{rhistory_anchor_point};
# Remove the first artificial point from the table
shift @{$rhistory_line_number};
shift @{$rhistory_level_diff};
shift @{$rhistory_anchor_point};
# Remove dubious points at an anchor point = 2 and beyond
# These can occur when non-indenting braces are used
my $num_his = @{$rhistory_level_diff};
foreach my $i ( 0 .. $num_his - 1 ) {
if ( $rhistory_anchor_point->[$i] == 2 ) {
$num_his = $i;
last;
}
}
return if ( $num_his <= 1 );
# Ignore an ending non-anchor point
if ( !$rhistory_anchor_point->[-1] ) {
$num_his -= 1;
}
# Ignore an ending point which is the same as the previous point
if ( $num_his > 1 ) {
if ( $rhistory_level_diff->[ $num_his - 1 ] ==
$rhistory_level_diff->[ $num_his - 2 ] )
{
$num_his -= 1;
}
}
# skip if the table does not have at least 2 points to pinpoint an error
return if ( $num_his <= 1 );
# skip if first point shows a level error - the analysis may not be valid
return if ( $rhistory_level_diff->[0] );
# Since the table could be arbitrarily large, we will limit the table to N
# lines. If there are more lines than that, we will show N-3 lines, then
# ..., then the last 2 lines. Allow about 3 lines per error, so a table
# limit of 10 can localize up to about 3 errors in a file.
my $nlines_max = 10;
my @pre_indexes = ( 0 .. $num_his - 1 );
my @post_indexes = ();
if ( @pre_indexes > $nlines_max ) {
if ( $nlines_max >= 5 ) {
@pre_indexes = ( 0 .. $nlines_max - 4 );
@post_indexes = ( $num_his - 2, $num_his - 1 );
}
else {
@pre_indexes = ( 0 .. $nlines_max - 1 );
}
}
my @output_lines;
push @output_lines, <[$i];
my $diff = $rhistory_level_diff->[$i];
push @output_lines, <[$i];
my $diff = $rhistory_level_diff->[$i];
push @output_lines, <interrupt_logfile();
$self->warning($output_str);
$self->resume_logfile();
return;
} ## end sub show_indentation_table
sub report_v_string {
# warn if this version can't handle v-strings
my ( $self, $tok ) = @_;
if ( $] < 5.006 ) {
$self->warning(
"Found v-string '$tok' but v-strings are not implemented in your version of perl; see Camel 3 book ch 2\n"
);
}
return;
} ## end sub report_v_string
sub is_valid_token_type {
my ($type) = @_;
return $is_valid_token_type{$type};
}
sub log_numbered_msg {
my ( $self, $msg ) = @_;
# write input line number + message to logfile
my $input_line_number = $self->[_last_line_number_];
$self->write_logfile_entry("Line $input_line_number: $msg");
return;
} ## end sub log_numbered_msg
sub get_line {
my $self = shift;
# Read the next input line and tokenize it
# Returns:
# $line_of_tokens = ref to hash of info for the tokenized line
# USES GLOBAL VARIABLES:
# $brace_depth, $square_bracket_depth, $paren_depth
# get the next line from the input array
my $input_line;
my $trimmed_input_line;
my $line_index = $self->[_input_line_index_next_];
my $rinput_lines = $self->[_rinput_lines_];
if ( $line_index < @{$rinput_lines} ) {
$trimmed_input_line = $self->[_rtrimmed_input_lines_]->[$line_index];
$input_line = $rinput_lines->[ $line_index++ ];
$self->[_input_line_index_next_] = $line_index;
}
$self->[_line_of_text_] = $input_line;
return if ( !defined($input_line) );
my $input_line_number = ++$self->[_last_line_number_];
# Find and remove what characters terminate this line, including any
# control r
my $input_line_separator = EMPTY_STRING;
if ( chomp $input_line ) {
$input_line_separator = $INPUT_RECORD_SEPARATOR;
}
# The first test here very significantly speeds things up, but be sure to
# keep the regex and hash %other_line_endings the same.
if ( $other_line_endings{ substr( $input_line, -1 ) } ) {
if ( $input_line =~ s/([\r\035\032])+$// ) {
$input_line_separator = $1 . $input_line_separator;
# This could make the trimmed input line incorrect, so the
# safe thing to do is to make it undef to force it to be
# recomputed later.
$trimmed_input_line = undef;
}
}
# For backwards compatibility we keep the line text terminated with
# a newline character
$input_line .= "\n";
$self->[_line_of_text_] = $input_line;
# create a data structure describing this line which will be
# returned to the caller.
# _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, '.'
# SKIP - code skipping section
# SKIP_END - last line of code skipping section, '#>>V'
# 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
# Other variables:
# _curly_brace_depth - depth of curly braces at start of line
# _square_bracket_depth - depth of square brackets at start of line
# _paren_depth - depth of parens at start of line
# _starting_in_quote - this line continues a multi-line quote
# (so don't trim leading blanks!)
# _ending_in_quote - this line ends in a multi-line quote
# (so don't trim trailing blanks!)
my $line_of_tokens = {
_line_type => 'EOF',
_line_text => $input_line,
_line_number => $input_line_number,
_guessed_indentation_level => 0,
_curly_brace_depth => $brace_depth,
_square_bracket_depth => $square_bracket_depth,
_paren_depth => $paren_depth,
## Skip these needless initializations for efficiency:
## _rtoken_type => undef,
## _rtokens => undef,
## _rlevels => undef,
## _rblock_type => undef,
## _rtype_sequence => undef,
## _starting_in_quote => 0,
## _ending_in_quote => 0,
};
# must print line unchanged if we are in a here document
if ( $self->[_in_here_doc_] ) {
$line_of_tokens->{_line_type} = 'HERE';
my $here_doc_target = $self->[_here_doc_target_];
my $here_quote_character = $self->[_here_quote_character_];
my $candidate_target = $input_line;
chomp $candidate_target;
# Handle <<~ targets, which are indicated here by a leading space on
# the here quote character
if ( $here_quote_character =~ /^\s/ ) {
$candidate_target =~ s/^\s+//;
}
if ( $candidate_target eq $here_doc_target ) {
$self->[_nearly_matched_here_target_at_] = undef;
$line_of_tokens->{_line_type} = 'HERE_END';
$self->log_numbered_msg("Exiting HERE document $here_doc_target\n");
my $rhere_target_list = $self->[_rhere_target_list_];
if ( @{$rhere_target_list} ) { # there can be multiple here targets
( $here_doc_target, $here_quote_character ) =
@{ shift @{$rhere_target_list} };
$self->[_here_doc_target_] = $here_doc_target;
$self->[_here_quote_character_] = $here_quote_character;
$self->log_numbered_msg(
"Entering HERE document $here_doc_target\n");
$self->[_nearly_matched_here_target_at_] = undef;
$self->[_started_looking_for_here_target_at_] =
$input_line_number;
}
else {
$self->[_in_here_doc_] = 0;
$self->[_here_doc_target_] = EMPTY_STRING;
$self->[_here_quote_character_] = EMPTY_STRING;
}
}
# check for error of extra whitespace
# note for PERL6: leading whitespace is allowed
else {
$candidate_target =~ s/^ \s+ | \s+ $//gx; # trim both ends
if ( $candidate_target eq $here_doc_target ) {
$self->[_nearly_matched_here_target_at_] = $input_line_number;
}
}
return $line_of_tokens;
}
# Print line unchanged if we are in a format section
elsif ( $self->[_in_format_] ) {
if ( $input_line =~ /^\.[\s#]*$/ ) {
# Decrement format depth count at a '.' after a 'format'
$self->[_in_format_]--;
# This is the end when count reaches 0
if ( !$self->[_in_format_] ) {
$self->log_numbered_msg("Exiting format section\n");
$line_of_tokens->{_line_type} = 'FORMAT_END';
# Make the tokenizer mark an opening brace which follows
# as a code block. Fixes issue c202/t032.
$last_nonblank_token = ';';
$last_nonblank_type = ';';
}
}
else {
$line_of_tokens->{_line_type} = 'FORMAT';
if ( $input_line =~ /^\s*format\s+\w+/ ) {
# Increment format depth count at a 'format' within a 'format'
# This is a simple way to handle nested formats (issue c019).
$self->[_in_format_]++;
}
}
return $line_of_tokens;
}
# must print line unchanged if we are in pod documentation
elsif ( $self->[_in_pod_] ) {
$line_of_tokens->{_line_type} = 'POD';
if ( $input_line =~ /^=cut/ ) {
$line_of_tokens->{_line_type} = 'POD_END';
$self->log_numbered_msg("Exiting POD section\n");
$self->[_in_pod_] = 0;
}
if ( $input_line =~ /^\#\!.*perl\b/ && !$self->[_in_end_] ) {
$self->warning(
"Hash-bang in pod can cause older versions of perl to fail! \n"
);
}
return $line_of_tokens;
}
# print line unchanged if in skipped section
elsif ( $self->[_in_code_skipping_] ) {
$line_of_tokens->{_line_type} = 'SKIP';
if ( $input_line =~ /$code_skipping_pattern_end/ ) {
$line_of_tokens->{_line_type} = 'SKIP_END';
$self->log_numbered_msg("Exiting code-skipping section\n");
$self->[_in_code_skipping_] = 0;
}
elsif ( $input_line =~ /$code_skipping_pattern_begin/ ) {
# warn of duplicate starting comment lines, git #118
my $lno = $self->[_in_code_skipping_];
$self->warning(
"Already in code-skipping section which started at line $lno\n"
);
}
else {
# not a code-skipping control line
}
return $line_of_tokens;
}
# must print line unchanged if we have seen a severe error (i.e., we
# are seeing illegal tokens and cannot continue. Syntax errors do
# not pass this route). Calling routine can decide what to do, but
# the default can be to just pass all lines as if they were after __END__
elsif ( $self->[_in_error_] ) {
$line_of_tokens->{_line_type} = 'ERROR';
return $line_of_tokens;
}
# print line unchanged if we are __DATA__ section
elsif ( $self->[_in_data_] ) {
# ...but look for POD
# Note that the _in_data and _in_end flags remain set
# so that we return to that state after seeing the
# end of a pod section
if ( $input_line =~ /^=(\w+)\b/ && $1 ne 'cut' ) {
$line_of_tokens->{_line_type} = 'POD_START';
$self->log_numbered_msg("Entering POD section\n");
$self->[_in_pod_] = 1;
return $line_of_tokens;
}
else {
$line_of_tokens->{_line_type} = 'DATA';
return $line_of_tokens;
}
}
# print line unchanged if we are in __END__ section
elsif ( $self->[_in_end_] ) {
# ...but look for POD
# Note that the _in_data and _in_end flags remain set
# so that we return to that state after seeing the
# end of a pod section
if ( $input_line =~ /^=(\w+)\b/ && $1 ne 'cut' ) {
$line_of_tokens->{_line_type} = 'POD_START';
$self->log_numbered_msg("Entering POD section\n");
$self->[_in_pod_] = 1;
return $line_of_tokens;
}
else {
$line_of_tokens->{_line_type} = 'END';
return $line_of_tokens;
}
}
else {
# not a special control line
}
# check for a hash-bang line if we haven't seen one
if ( !$self->[_saw_hash_bang_]
&& substr( $input_line, 0, 2 ) eq '#!'
&& $input_line =~ /^\#\!.*perl\b/ )
{
$self->[_saw_hash_bang_] = $input_line_number;
# check for -w and -P flags
if ( $input_line =~ /^\#\!.*perl\s.*-.*P/ ) {
$self->[_saw_perl_dash_P_] = 1;
}
if ( $input_line =~ /^\#\!.*perl\s.*-.*w/ ) {
$self->[_saw_perl_dash_w_] = 1;
}
if (
$input_line_number > 1
# leave any hash bang in a BEGIN block alone
# i.e. see 'debugger-duck_type.t'
&& !(
$last_nonblank_block_type
&& $last_nonblank_block_type eq 'BEGIN'
)
&& !$rOpts_look_for_hash_bang
# Try to avoid giving a false alarm at a simple comment.
# These look like valid hash-bang lines:
#!/usr/bin/perl -w
#! /usr/bin/perl -w
#!c:\perl\bin\perl.exe
# These are comments:
#! I love perl
#! sunos does not yet provide a /usr/bin/perl
# Comments typically have multiple spaces, which suggests
# the filter
&& $input_line =~ /^\#\!(\s+)?(\S+)?perl/
)
{
# this is helpful for VMS systems; we may have accidentally
# tokenized some DCL commands
if ( $self->[_started_tokenizing_] ) {
$self->warning(
"There seems to be a hash-bang after line 1; do you need to run with -x ?\n"
);
}
else {
$self->complain("Useless hash-bang after line 1\n");
}
}
# Report the leading hash-bang as a system line
# This will prevent -dac from deleting it
else {
$line_of_tokens->{_line_type} = 'SYSTEM';
return $line_of_tokens;
}
}
# wait for a hash-bang before parsing if the user invoked us with -x
if ( $rOpts_look_for_hash_bang
&& !$self->[_saw_hash_bang_] )
{
$line_of_tokens->{_line_type} = 'SYSTEM';
return $line_of_tokens;
}
# a first line of the form ': #' will be marked as SYSTEM
# since lines of this form may be used by tcsh
if ( $input_line_number == 1 && $input_line =~ /^\s*\:\s*\#/ ) {
$line_of_tokens->{_line_type} = 'SYSTEM';
return $line_of_tokens;
}
# now we know that it is ok to tokenize the line...
# the line tokenizer will modify any of these private variables:
# _rhere_target_list_
# _in_data_
# _in_end_
# _in_format_
# _in_error_
# _in_code_skipping_
# _in_format_skipping_
# _in_pod_
# _in_quote_
$self->tokenize_this_line( $line_of_tokens, $trimmed_input_line );
# Now finish defining the return structure and return it
$line_of_tokens->{_ending_in_quote} = $self->[_in_quote_];
# handle severe error (binary data in script)
if ( $self->[_in_error_] ) {
$self->[_in_quote_] = 0; # to avoid any more messages
$self->warning("Giving up after error\n");
$line_of_tokens->{_line_type} = 'ERROR';
reset_indentation_level(0); # avoid error messages
return $line_of_tokens;
}
# handle start of pod documentation
if ( $self->[_in_pod_] ) {
# This gets tricky..above a __DATA__ or __END__ section, perl
# accepts '=cut' as the start of pod section. But afterwards,
# only pod utilities see it and they may ignore an =cut without
# leading =head. In any case, this isn't good.
if ( $input_line =~ /^=cut\b/ ) {
if ( $self->[_saw_data_] || $self->[_saw_end_] ) {
$self->complain("=cut while not in pod ignored\n");
$self->[_in_pod_] = 0;
$line_of_tokens->{_line_type} = 'POD_END';
}
else {
$line_of_tokens->{_line_type} = 'POD_START';
if ( !DEVEL_MODE ) {
$self->warning(
"=cut starts a pod section .. this can fool pod utilities.\n"
);
}
$self->log_numbered_msg("Entering POD section\n");
}
}
else {
$line_of_tokens->{_line_type} = 'POD_START';
$self->log_numbered_msg("Entering POD section\n");
}
return $line_of_tokens;
}
# handle start of skipped section
if ( $self->[_in_code_skipping_] ) {
$line_of_tokens->{_line_type} = 'SKIP';
$self->log_numbered_msg("Entering code-skipping section\n");
return $line_of_tokens;
}
# see if this line contains here doc targets
my $rhere_target_list = $self->[_rhere_target_list_];
if ( @{$rhere_target_list} ) {
my ( $here_doc_target, $here_quote_character ) =
@{ shift @{$rhere_target_list} };
$self->[_in_here_doc_] = 1;
$self->[_here_doc_target_] = $here_doc_target;
$self->[_here_quote_character_] = $here_quote_character;
$self->log_numbered_msg("Entering HERE document $here_doc_target\n");
$self->[_started_looking_for_here_target_at_] = $input_line_number;
}
# NOTE: __END__ and __DATA__ statements are written unformatted
# because they can theoretically contain additional characters
# which are not tokenized (and cannot be read with either!).
if ( $self->[_in_data_] ) {
$line_of_tokens->{_line_type} = 'DATA_START';
$self->log_numbered_msg("Starting __DATA__ section\n");
$self->[_saw_data_] = 1;
# keep parsing after __DATA__ if use SelfLoader was seen
if ( $self->[_saw_selfloader_] ) {
$self->[_in_data_] = 0;
$self->log_numbered_msg(
"SelfLoader seen, continuing; -nlsl deactivates\n");
}
return $line_of_tokens;
}
elsif ( $self->[_in_end_] ) {
$line_of_tokens->{_line_type} = 'END_START';
$self->log_numbered_msg("Starting __END__ section\n");
$self->[_saw_end_] = 1;
# keep parsing after __END__ if use AutoLoader was seen
if ( $self->[_saw_autoloader_] ) {
$self->[_in_end_] = 0;
$self->log_numbered_msg(
"AutoLoader seen, continuing; -nlal deactivates\n");
}
return $line_of_tokens;
}
else {
# not in __END__ or __DATA__
}
# now, finally, we know that this line is type 'CODE'
$line_of_tokens->{_line_type} = 'CODE';
# remember if we have seen any real code
if ( !$self->[_started_tokenizing_]
&& $input_line !~ /^\s*$/
&& $input_line !~ /^\s*#/ )
{
$self->[_started_tokenizing_] = 1;
}
if ( $self->[_debugger_object_] ) {
$self->[_debugger_object_]->write_debug_entry($line_of_tokens);
}
# Note: if keyword 'format' occurs in this line code, it is still CODE
# (keyword 'format' need not start a line)
if ( $self->[_in_format_] ) {
$self->log_numbered_msg("Entering format section\n");
}
if ( $self->[_in_quote_]
and ( $self->[_line_start_quote_] < 0 ) )
{
if ( ( my $quote_target = $self->[_quote_target_] ) !~ /^\s*$/ ) {
$self->[_line_start_quote_] = $input_line_number;
$self->log_numbered_msg(
"Start multi-line quote or pattern ending in $quote_target\n");
}
}
elsif ( ( $self->[_line_start_quote_] >= 0 )
&& !$self->[_in_quote_] )
{
$self->[_line_start_quote_] = -1;
$self->log_numbered_msg("End of multi-line quote or pattern\n");
}
else {
# not at the edge of a quote
}
# we are returning a line of CODE
return $line_of_tokens;
} ## end sub get_line
sub find_starting_indentation_level {
# We need to find the indentation level of the first line of the
# script being formatted. Often it will be zero for an entire file,
# but if we are formatting a local block of code (within an editor for
# example) it may not be zero. The user may specify this with the
# -sil=n parameter but normally doesn't so we have to guess.
#
my ($self) = @_;
my $starting_level = 0;
# use value if given as parameter
if ( $self->[_know_starting_level_] ) {
$starting_level = $self->[_starting_level_];
}
# if we know there is a hash_bang line, the level must be zero
elsif ($rOpts_look_for_hash_bang) {
$self->[_know_starting_level_] = 1;
}
# otherwise figure it out from the input file
else {
my $line;
my $i = 0;
# keep looking at lines until we find a hash bang or piece of code
# ( or, for now, an =pod line)
my $msg = EMPTY_STRING;
my $in_code_skipping;
my $line_for_guess;
while ( defined( $line = $self->peek_ahead( $i++ ) ) ) {
# if first line is #! then assume starting level is zero
if ( $i == 1 && $line =~ /^\#\!/ ) {
$starting_level = 0;
last;
}
# ignore lines fenced off with code-skipping comments
if ( $line =~ /^\s*#/ ) {
# use first comment for indentation guess in case of no code
if ( !defined($line_for_guess) ) { $line_for_guess = $line }
if ( !$in_code_skipping ) {
if ( $rOpts_code_skipping
&& $line =~ /$code_skipping_pattern_begin/ )
{
$in_code_skipping = 1;
next;
}
}
else {
if ( $line =~ /$code_skipping_pattern_end/ ) {
$in_code_skipping = 0;
}
next;
}
# Note that we could also ignore format-skipping lines here
# but it isn't clear if that would be best.
# See c326 for example code.
next;
}
next if ($in_code_skipping);
next if ( $line =~ /^\s*$/ ); # skip past blank lines
# use first line of code for indentation guess
$line_for_guess = $line;
last;
} ## end while ( defined( $line = ...))
if ( defined($line_for_guess) ) {
$starting_level =
$self->guess_old_indentation_level($line_for_guess);
}
$msg = "Line $i implies starting-indentation-level = $starting_level\n";
$self->write_logfile_entry("$msg");
}
$self->[_starting_level_] = $starting_level;
reset_indentation_level($starting_level);
return;
} ## end sub find_starting_indentation_level
sub guess_old_indentation_level {
my ( $self, $line ) = @_;
# Guess the indentation level of an input line.
#
# For the first line of code this result will define the starting
# indentation level. It will mainly be non-zero when perltidy is applied
# within an editor to a local block of code.
#
# This is an impossible task in general because we can't know what tabs
# meant for the old script and how many spaces were used for one
# indentation level in the given input script. For example it may have
# been previously formatted with -i=7 -et=3. But we can at least try to
# make sure that perltidy guesses correctly if it is applied repeatedly to
# a block of code within an editor, so that the block stays at the same
# level when perltidy is applied repeatedly.
#
# USES GLOBAL VARIABLES: (none)
my $level = 0;
# find leading tabs, spaces, and any statement label
my $spaces = 0;
if ( $line =~ /^(\t+)?(\s+)?(\w+:[^:])?/ ) {
# If there are leading tabs, we use the tab scheme for this run, if
# any, so that the code will remain stable when editing.
if ($1) { $spaces += length($1) * $tabsize }
if ($2) { $spaces += length($2) }
# correct for outdented labels
if ( $3
&& $rOpts_outdent_labels
&& $rOpts_continuation_indentation > 0 )
{
$spaces += $rOpts_continuation_indentation;
}
}
$level = int( $spaces / $rOpts_indent_columns );
return ($level);
} ## end sub guess_old_indentation_level
sub dump_functions {
# This is an unused debug routine, save for future use
my $fh = *STDOUT;
foreach my $pkg ( keys %{$ris_user_function} ) {
$fh->print("\nnon-constant subs in package $pkg\n");
foreach my $sub ( keys %{ $ris_user_function->{$pkg} } ) {
my $msg = EMPTY_STRING;
if ( $ris_block_list_function->{$pkg}{$sub} ) {
$msg = 'block_list';
}
if ( $ris_block_function->{$pkg}{$sub} ) {
$msg = 'block';
}
$fh->print("$sub $msg\n");
}
}
foreach my $pkg ( keys %{$ris_constant} ) {
$fh->print("\nconstants and constant subs in package $pkg\n");
foreach my $sub ( keys %{ $ris_constant->{$pkg} } ) {
$fh->print("$sub\n");
}
}
return;
} ## end sub dump_functions
sub prepare_for_a_new_file {
my ( $self, $source_object ) = @_;
# copy the source object lines to an array of lines
$self->make_source_array($source_object);
# previous tokens needed to determine what to expect next
$last_nonblank_token = ';'; # the only possible starting state which
$last_nonblank_type = ';'; # will make a leading brace a code block
$last_nonblank_block_type = EMPTY_STRING;
# scalars for remembering statement types across multiple lines
$statement_type = EMPTY_STRING; # '' or 'use' or 'sub..' or 'case..'
# scalars for remembering where we are in the file
$current_package = "main";
$context = UNKNOWN_CONTEXT;
# hashes used to remember function information
$ris_constant = {}; # user-defined constants
$ris_user_function = {}; # user-defined functions
$ruser_function_prototype = {}; # their prototypes
$ris_block_function = {};
$ris_block_list_function = {};
$rsaw_function_definition = {};
$rsaw_use_module = {};
# variables used to track depths of various containers
# and report nesting errors
$paren_depth = 0;
$brace_depth = 0;
$square_bracket_depth = 0;
$rcurrent_depth = [ (0) x scalar(@closing_brace_names) ];
$total_depth = 0;
$rtotal_depth = [];
$rcurrent_sequence_number = [];
$next_sequence_number = SEQ_ROOT + 1;
$rparen_type = [];
$rparen_semicolon_count = [];
$rparen_vars = [];
$rbrace_type = [];
$rbrace_structural_type = [];
$rbrace_context = [];
$rbrace_package = [];
$rsquare_bracket_type = [];
$rsquare_bracket_structural_type = [];
$rdepth_array = [];
$rnested_ternary_flag = [];
$rnested_statement_type = [];
$rstarting_line_of_current_depth = [];
$rparen_type->[$paren_depth] = EMPTY_STRING;
$rparen_semicolon_count->[$paren_depth] = 0;
$rparen_vars->[$paren_depth] = [];
$rbrace_type->[$brace_depth] = ';'; # identify opening brace as code block
$rbrace_structural_type->[$brace_depth] = EMPTY_STRING;
$rbrace_context->[$brace_depth] = UNKNOWN_CONTEXT;
$rbrace_package->[$paren_depth] = $current_package;
$rsquare_bracket_type->[$square_bracket_depth] = EMPTY_STRING;
$rsquare_bracket_structural_type->[$square_bracket_depth] = EMPTY_STRING;
initialize_tokenizer_state();
return;
} ## end sub prepare_for_a_new_file
{ ## closure for sub tokenize_this_line
use constant BRACE => 0;
use constant SQUARE_BRACKET => 1;
use constant PAREN => 2;
use constant QUESTION_COLON => 3;
# TV1: scalars for processing one LINE.
# Re-initialized on each entry to sub tokenize_this_line.
my (
$block_type, $container_type, $expecting,
$i, $i_tok, $input_line,
$input_line_number, $last_nonblank_i, $max_token_index,
$next_tok, $next_type, $peeked_ahead,
$prototype, $rhere_target_list, $rtoken_map,
$rtoken_type, $rtokens, $tok,
$type, $type_sequence, $indent_flag,
);
# TV2: refs to ARRAYS for processing one LINE
# Re-initialized on each call.
my $routput_token_list = []; # stack of output token indexes
my $routput_token_type = []; # token types
my $routput_block_type = []; # types of code block
my $routput_type_sequence = []; # nesting sequential number
my $routput_indent_flag = []; #
# TV3: SCALARS for quote variables. These are initialized with a
# subroutine call and continually updated as lines are processed.
my ( $in_quote, $quote_type, $quote_character, $quote_pos, $quote_depth,
$quoted_string_1, $quoted_string_2, $allowed_quote_modifiers );
# TV4: SCALARS for multi-line identifiers and
# statements. These are initialized with a subroutine call
# and continually updated as lines are processed.
my ( $id_scan_state, $identifier, $want_paren );
# TV5: SCALARS for tracking indentation level.
# Initialized once and continually updated as lines are
# processed.
my (
$nesting_token_string, $nesting_block_string,
$nesting_block_flag, $level_in_tokenizer,
);
# TV6: SCALARS for remembering several previous
# tokens. Initialized once and continually updated as
# lines are processed.
my (
$last_nonblank_container_type, $last_nonblank_type_sequence,
$last_last_nonblank_token, $last_last_nonblank_type,
$last_nonblank_prototype,
);
# ----------------------------------------------------------------
# beginning of tokenizer variable access and manipulation routines
# ----------------------------------------------------------------
sub initialize_tokenizer_state {
# GV1: initialized once
# TV1: initialized on each call
# TV2: initialized on each call
# TV3:
$in_quote = 0;
$quote_type = 'Q';
$quote_character = EMPTY_STRING;
$quote_pos = 0;
$quote_depth = 0;
$quoted_string_1 = EMPTY_STRING;
$quoted_string_2 = EMPTY_STRING;
$allowed_quote_modifiers = EMPTY_STRING;
# TV4:
$id_scan_state = EMPTY_STRING;
$identifier = EMPTY_STRING;
$want_paren = EMPTY_STRING;
# TV5:
$nesting_token_string = EMPTY_STRING;
$nesting_block_string = '1'; # initially in a block
$nesting_block_flag = 1;
$level_in_tokenizer = 0;
# TV6:
$last_nonblank_container_type = EMPTY_STRING;
$last_nonblank_type_sequence = EMPTY_STRING;
$last_last_nonblank_token = ';';
$last_last_nonblank_type = ';';
$last_nonblank_prototype = EMPTY_STRING;
return;
} ## end sub initialize_tokenizer_state
sub save_tokenizer_state {
# Global variables:
my $rGV1 = [
$brace_depth,
$context,
$current_package,
$last_nonblank_block_type,
$last_nonblank_token,
$last_nonblank_type,
$next_sequence_number,
$paren_depth,
$rbrace_context,
$rbrace_package,
$rbrace_structural_type,
$rbrace_type,
$rcurrent_depth,
$rcurrent_sequence_number,
$rdepth_array,
$ris_block_function,
$ris_block_list_function,
$ris_constant,
$ris_user_function,
$rnested_statement_type,
$rnested_ternary_flag,
$rparen_semicolon_count,
$rparen_vars,
$rparen_type,
$rsaw_function_definition,
$rsaw_use_module,
$rsquare_bracket_structural_type,
$rsquare_bracket_type,
$rstarting_line_of_current_depth,
$rtotal_depth,
$ruser_function_prototype,
$square_bracket_depth,
$statement_type,
$total_depth,
];
# Tokenizer closure variables:
my $rTV1 = [
$block_type, $container_type, $expecting,
$i, $i_tok, $input_line,
$input_line_number, $last_nonblank_i, $max_token_index,
$next_tok, $next_type, $peeked_ahead,
$prototype, $rhere_target_list, $rtoken_map,
$rtoken_type, $rtokens, $tok,
$type, $type_sequence, $indent_flag,
];
my $rTV2 = [
$routput_token_list, $routput_token_type,
$routput_block_type, $routput_type_sequence,
$routput_indent_flag,
];
my $rTV3 = [
$in_quote, $quote_type,
$quote_character, $quote_pos,
$quote_depth, $quoted_string_1,
$quoted_string_2, $allowed_quote_modifiers,
];
my $rTV4 = [ $id_scan_state, $identifier, $want_paren ];
my $rTV5 = [
$nesting_token_string, $nesting_block_string,
$nesting_block_flag, $level_in_tokenizer,
];
my $rTV6 = [
$last_nonblank_container_type, $last_nonblank_type_sequence,
$last_last_nonblank_token, $last_last_nonblank_type,
$last_nonblank_prototype,
];
return [ $rGV1, $rTV1, $rTV2, $rTV3, $rTV4, $rTV5, $rTV6 ];
} ## end sub save_tokenizer_state
sub restore_tokenizer_state {
my ($rstate) = @_;
my ( $rGV1, $rTV1, $rTV2, $rTV3, $rTV4, $rTV5, $rTV6 ) = @{$rstate};
(
$brace_depth,
$context,
$current_package,
$last_nonblank_block_type,
$last_nonblank_token,
$last_nonblank_type,
$next_sequence_number,
$paren_depth,
$rbrace_context,
$rbrace_package,
$rbrace_structural_type,
$rbrace_type,
$rcurrent_depth,
$rcurrent_sequence_number,
$rdepth_array,
$ris_block_function,
$ris_block_list_function,
$ris_constant,
$ris_user_function,
$rnested_statement_type,
$rnested_ternary_flag,
$rparen_semicolon_count,
$rparen_vars,
$rparen_type,
$rsaw_function_definition,
$rsaw_use_module,
$rsquare_bracket_structural_type,
$rsquare_bracket_type,
$rstarting_line_of_current_depth,
$rtotal_depth,
$ruser_function_prototype,
$square_bracket_depth,
$statement_type,
$total_depth,
) = @{$rGV1};
(
$block_type, $container_type, $expecting,
$i, $i_tok, $input_line,
$input_line_number, $last_nonblank_i, $max_token_index,
$next_tok, $next_type, $peeked_ahead,
$prototype, $rhere_target_list, $rtoken_map,
$rtoken_type, $rtokens, $tok,
$type, $type_sequence, $indent_flag,
) = @{$rTV1};
(
$routput_token_list, $routput_token_type,
$routput_block_type, $routput_type_sequence,
$routput_indent_flag,
) = @{$rTV2};
(
$in_quote, $quote_type, $quote_character, $quote_pos, $quote_depth,
$quoted_string_1, $quoted_string_2, $allowed_quote_modifiers,
) = @{$rTV3};
( $id_scan_state, $identifier, $want_paren ) = @{$rTV4};
(
$nesting_token_string, $nesting_block_string,
$nesting_block_flag, $level_in_tokenizer,
) = @{$rTV5};
(
$last_nonblank_container_type, $last_nonblank_type_sequence,
$last_last_nonblank_token, $last_last_nonblank_type,
$last_nonblank_prototype,
) = @{$rTV6};
return;
} ## end sub restore_tokenizer_state
sub split_pretoken {
my ( $self, $numc ) = @_;
# This provides a way to work around the limitations of the
# pre-tokenization scheme upon which perltidy is based. It is rarely
# needed.
# Split the leading $numc characters from the current token (at
# index=$i) which is pre-type 'w' and insert the remainder back into
# the pretoken stream with appropriate settings. Since we are
# splitting a pre-type 'w', there are three cases, depending on if the
# remainder starts with a digit:
# Case 1: remainder is type 'd', all digits
# Case 2: remainder is type 'd' and type 'w': digits & other characters
# Case 3: remainder is type 'w'
# Examples, for $numc=1:
# $tok => $tok_0 $tok_1 $tok_2
# 'x10' => 'x' '10' # case 1
# 'x10if' => 'x' '10' 'if' # case 2
# '0ne => 'O' 'ne' # case 3
# where:
# $tok_1 is a possible string of digits (pre-type 'd')
# $tok_2 is a possible word (pre-type 'w')
# return 1 if successful
# return undef if error (shouldn't happen)
# Calling routine should update '$type' and '$tok' if successful.
my $pretoken = $rtokens->[$i];
if ( $pretoken
&& length($pretoken) > $numc
&& substr( $pretoken, $numc ) =~ /^(\d*)(.*)$/ )
{
# Split $tok into up to 3 tokens:
my $tok_0 = substr( $pretoken, 0, $numc );
my $tok_1 = defined($1) ? $1 : EMPTY_STRING;
my $tok_2 = defined($2) ? $2 : EMPTY_STRING;
my $len_0 = length($tok_0);
my $len_1 = length($tok_1);
my $len_2 = length($tok_2);
##my $pre_type_0 = 'w';
my $pre_type_1 = 'd';
my $pre_type_2 = 'w';
my $pos_0 = $rtoken_map->[$i];
my $pos_1 = $pos_0 + $len_0;
my $pos_2 = $pos_1 + $len_1;
my $isplice = $i + 1;
# Splice in any digits
if ($len_1) {
splice @{$rtoken_map}, $isplice, 0, $pos_1;
splice @{$rtokens}, $isplice, 0, $tok_1;
splice @{$rtoken_type}, $isplice, 0, $pre_type_1;
$max_token_index++;
$isplice++;
}
# Splice in any trailing word
if ($len_2) {
splice @{$rtoken_map}, $isplice, 0, $pos_2;
splice @{$rtokens}, $isplice, 0, $tok_2;
splice @{$rtoken_type}, $isplice, 0, $pre_type_2;
$max_token_index++;
}
$rtokens->[$i] = $tok_0;
return 1;
}
# Shouldn't get here - bad call parameters
if (DEVEL_MODE) {
$self->Fault(< '{', ']' => '[', ')' => '(' );
# These block types terminate statements and do not need a trailing
# semicolon
# patched for SWITCH/CASE/
my %is_zero_continuation_block_type;
my @q;
@q = qw( } { BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue ;
if elsif else unless while until for foreach switch case given when );
@is_zero_continuation_block_type{@q} = (1) x scalar(@q);
my %is_logical_container;
@q = qw( if elsif unless while and or err not && ! || for foreach );
@is_logical_container{@q} = (1) x scalar(@q);
my %is_binary_type;
@q = qw( || && );
@is_binary_type{@q} = (1) x scalar(@q);
my %is_binary_keyword;
@q = qw( and or err eq ne cmp );
@is_binary_keyword{@q} = (1) x scalar(@q);
# 'L' is token for opening { at hash key
my %is_opening_type;
@q = qw< L { ( [ >;
@is_opening_type{@q} = (1) x scalar(@q);
my %is_opening_or_ternary_type;
push @q, '?';
@is_opening_or_ternary_type{@q} = (1) x scalar(@q);
# 'R' is token for closing } at hash key
my %is_closing_type;
@q = qw< R } ) ] >;
@is_closing_type{@q} = (1) x scalar(@q);
my %is_closing_or_ternary_type;
push @q, ':';
@is_closing_or_ternary_type{@q} = (1) x scalar(@q);
my %is_redo_last_next_goto;
@q = qw( redo last next goto );
@is_redo_last_next_goto{@q} = (1) x scalar(@q);
my %is_use_require;
@q = qw( use require );
@is_use_require{@q} = (1) x scalar(@q);
# This hash holds the array index in $self for these keywords:
# Fix for issue c035: removed 'format' from this hash
my %is_END_DATA = (
'__END__' => _in_end_,
'__DATA__' => _in_data_,
);
my %is_list_end_type;
@q = qw( ; { } );
push @q, ',';
@is_list_end_type{@q} = (1) x scalar(@q);
# table showing how many quoted things to look for after quote operator..
# s, y, tr have 2 (pattern and replacement)
# others have 1 (pattern only)
my %quote_items = (
's' => 2,
'y' => 2,
'tr' => 2,
'm' => 1,
'qr' => 1,
'q' => 1,
'qq' => 1,
'qw' => 1,
'qx' => 1,
);
my %is_for_foreach;
@q = qw( for foreach );
@is_for_foreach{@q} = (1) x scalar(@q);
# These keywords may introduce blocks after parenthesized expressions,
# in the form:
# keyword ( .... ) { BLOCK }
# patch for SWITCH/CASE: added 'switch' 'case' 'given' 'when'
# NOTE for --use-feature=class: if ADJUST blocks eventually take a
# parameter list, then ADJUST might need to be added to this list (see
# perlclass.pod)
my %is_blocktype_with_paren;
@q =
qw(if elsif unless while until for foreach switch case given when catch);
@is_blocktype_with_paren{@q} = (1) x scalar(@q);
my %is_case_default;
@q = qw( case default );
@is_case_default{@q} = (1) x scalar(@q);
#------------------------
# end of tokenizer hashes
#------------------------
# ------------------------------------------------------------
# beginning of various scanner interface routines
# ------------------------------------------------------------
sub scan_replacement_text {
# check for here-docs in replacement text invoked by
# a substitution operator with executable modifier 'e'.
#
# given:
# $replacement_text
# return:
# $rht = reference to any here-doc targets
my ( $self, $replacement_text ) = @_;
# quick check
return if ( $replacement_text !~ /<write_logfile_entry(
"scanning replacement text for here-doc targets\n");
# save the logger object for error messages
my $logger_object = $self->[_logger_object_];
# save all lexical variables
my $rstate = save_tokenizer_state();
_decrement_count(); # avoid error check for multiple tokenizers
# make a new tokenizer
my $tokenizer = Perl::Tidy::Tokenizer->new(
source_object => \$replacement_text,
logger_object => $logger_object,
starting_line_number => $input_line_number,
);
# scan the replacement text
while ( $tokenizer->get_line() ) { }
# remove any here doc targets
my $rht = undef;
if ( $tokenizer->[_in_here_doc_] ) {
$rht = [];
push @{$rht},
[
$tokenizer->[_here_doc_target_],
$tokenizer->[_here_quote_character_]
];
if ( $tokenizer->[_rhere_target_list_] ) {
push @{$rht}, @{ $tokenizer->[_rhere_target_list_] };
$tokenizer->[_rhere_target_list_] = undef;
}
$tokenizer->[_in_here_doc_] = undef;
}
# now its safe to report errors
my $severe_error_uu = $tokenizer->report_tokenization_errors();
# TODO: Could propagate a severe error up
# restore all tokenizer lexical variables
restore_tokenizer_state($rstate);
# return the here doc targets
return $rht;
} ## end sub scan_replacement_text
sub scan_bare_identifier {
my $self = shift;
( $i, $tok, $type, $prototype ) = $self->scan_bare_identifier_do(
$input_line,
$i,
$tok,
$type,
$prototype,
$rtoken_map,
$max_token_index
);
return;
} ## end sub scan_bare_identifier
sub scan_identifier {
my $self = shift;
(
$i,
$tok,
$type,
$id_scan_state,
$identifier,
my $split_pretoken_flag
) = $self->scan_complex_identifier(
$i,
$id_scan_state,
$identifier,
$rtokens,
$max_token_index,
$expecting,
$rparen_type->[$paren_depth]
);
# Check for signal to fix a special variable adjacent to a keyword,
# such as '$^One$0'.
if ($split_pretoken_flag) {
# Try to fix it by splitting the pretoken
if ( $i > 0
&& $rtokens->[ $i - 1 ] eq '^'
&& $self->split_pretoken(1) )
{
$identifier = substr( $identifier, 0, 3 );
$tok = $identifier;
}
else {
# This shouldn't happen ...
my $var = substr( $tok, 0, 3 );
my $excess = substr( $tok, 3 );
$self->interrupt_logfile();
$self->warning(<resume_logfile();
}
}
return;
} ## end sub scan_identifier
use constant VERIFY_FASTSCAN => 0;
my %fast_scan_context;
BEGIN {
%fast_scan_context = (
'$' => SCALAR_CONTEXT,
'*' => SCALAR_CONTEXT,
'@' => LIST_CONTEXT,
'%' => LIST_CONTEXT,
'&' => UNKNOWN_CONTEXT,
);
} ## end BEGIN
sub scan_simple_identifier {
my $self = shift;
# This is a wrapper for sub scan_identifier. It does a fast preliminary
# scan for certain common identifiers:
# '$var', '@var', %var, *var, &var, '@{...}', '%{...}'
# If it does not find one of these, or this is a restart, it calls the
# original scanner directly.
# This gives the same results as the full scanner in about 1/4 the
# total runtime for a typical input stream.
# Notation:
# $var * 2
# ^^ ^
# || |
# || ---- $i_next [= next nonblank pretoken ]
# |----$i_plus_1 [= a bareword ]
# ---$i_begin [= a sigil]
my $i_begin = $i;
my $tok_begin = $tok;
my $i_plus_1 = $i + 1;
my $fast_scan_type;
#-------------------------------------------------------
# Do full scan for anything following a pointer, such as
# $cref->&*; # a postderef
#-------------------------------------------------------
if ( $last_nonblank_token eq '->' ) {
}
#------------------------------
# quick scan with leading sigil
#------------------------------
elsif ( !$id_scan_state
&& $i_plus_1 <= $max_token_index
&& $fast_scan_context{$tok} )
{
$context = $fast_scan_context{$tok};
# look for $var, @var, ...
if ( $rtoken_type->[$i_plus_1] eq 'w' ) {
my $pretype_next = EMPTY_STRING;
if ( $i_plus_1 < $max_token_index ) {
my $i_next = $i_plus_1 + 1;
if ( $rtoken_type->[$i_next] eq 'b'
&& $i_next < $max_token_index )
{
$i_next += 1;
}
$pretype_next = $rtoken_type->[$i_next];
}
if ( $pretype_next ne ':' && $pretype_next ne "'" ) {
# Found type 'i' like '$var', '@var', or '%var'
$identifier = $tok . $rtokens->[$i_plus_1];
$tok = $identifier;
$type = 'i';
$i = $i_plus_1;
$fast_scan_type = $type;
}
}
# Look for @{ or %{ .
# But we must let the full scanner handle things ${ because it may
# keep going to get a complete identifier like '${#}' .
elsif (
$rtoken_type->[$i_plus_1] eq '{'
&& ( $tok_begin eq '@'
|| $tok_begin eq '%' )
)
{
$identifier = $tok;
$type = 't';
$fast_scan_type = $type;
}
else {
## out of tricks
}
}
#---------------------------
# Quick scan with leading ->
# Look for ->[ and ->{
#---------------------------
elsif (
$tok eq '->'
&& $i < $max_token_index
&& ( $rtokens->[$i_plus_1] eq '{'
|| $rtokens->[$i_plus_1] eq '[' )
)
{
$type = $tok;
$fast_scan_type = $type;
$identifier = $tok;
$context = UNKNOWN_CONTEXT;
}
else {
## out of tricks
}
#--------------------------------------
# Verify correctness during development
#--------------------------------------
if ( VERIFY_FASTSCAN && $fast_scan_type ) {
# We will call the full method
my $identifier_simple = $identifier;
my $tok_simple = $tok;
my $i_simple = $i;
my $context_simple = $context;
$tok = $tok_begin;
$i = $i_begin;
$self->scan_identifier();
if ( $tok ne $tok_simple
|| $type ne $fast_scan_type
|| $i != $i_simple
|| $identifier ne $identifier_simple
|| $id_scan_state
|| $context ne $context_simple )
{
print {*STDERR} <scan_identifier();
}
return;
} ## end sub scan_simple_identifier
sub method_ok_here {
my $self = shift;
# Return:
# false if this is definitely an invalid method declaration
# true otherwise (even if not sure)
# We are trying to avoid problems with old uses of 'method'
# when --use-feature=class is set (rt145706).
# For example, this should cause a return of 'false':
# method paint => sub {
# return;
# };
# from do_scan_sub:
my $i_beg = $i + 1;
my $pos_beg = $rtoken_map->[$i_beg];
pos($input_line) = $pos_beg;
# TEST 1: look a valid sub NAME
if (
$input_line =~ m{\G\s*
((?:\w*(?:'|::))*) # package - something that ends in :: or '
(\w+) # NAME - required
}gcx
)
{
# For possible future use..
##my $subname = $2;
##my $package = $1 ? $1 : EMPTY_STRING;
}
else {
return;
}
# TEST 2: look for invalid characters after name, such as here:
# method paint => sub {
# ...
# }
my $next_char = EMPTY_STRING;
if ( $input_line =~ m/\s*(\S)/gcx ) { $next_char = $1 }
if ( !$next_char || $next_char eq '#' ) {
( $next_char, my $i_next_uu ) =
$self->find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( !$next_char ) {
# out of characters - give up
return;
}
# Possibly valid next token types:
# '(' could start prototype or signature
# ':' could start ATTRIBUTE
# '{' cold start BLOCK
# ';' or '}' could end a statement
if ( $next_char !~ /^[\(\:\{\;\}]/ ) {
# This does not match use feature 'class' syntax
return;
}
# We will stop here and assume that this is valid syntax for
# use feature 'class'.
return 1;
} ## end sub method_ok_here
sub class_ok_here {
my $self = shift;
# Return:
# false if this is definitely an invalid class declaration
# true otherwise (even if not sure)
# We are trying to avoid problems with old uses of 'class'
# when --use-feature=class is set (rt145706). We look ahead
# see if this use of 'class' is obviously inconsistent with
# the syntax of use feature 'class'. This allows the default
# setting --use-feature=class to work for old syntax too.
# Valid class declarations look like
# class NAME ?ATTRS ?VERSION ?BLOCK
# where ATTRS VERSION and BLOCK are optional
# For example, this should produce a return of 'false':
#
# class ExtendsBasicAttributes is BasicAttributes{
# TEST 1: class stmt can only go where a new statement can start
if ( !new_statement_ok() ) { return }
my $i_beg = $i + 1;
my $pos_beg = $rtoken_map->[$i_beg];
pos($input_line) = $pos_beg;
# TEST 2: look for a valid NAME
if (
$input_line =~ m{\G\s*
((?:\w*(?:'|::))*) # package - something that ends in :: or '
(\w+) # NAME - required
}gcx
)
{
# For possible future use..
##my $subname = $2;
##my $package = $1 ? $1 : EMPTY_STRING;
}
else {
return;
}
# TEST 3: look for valid characters after NAME
my $next_char = EMPTY_STRING;
if ( $input_line =~ m/\s*(\S)/gcx ) { $next_char = $1 }
if ( !$next_char || $next_char eq '#' ) {
( $next_char, my $i_next_uu ) =
$self->find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( !$next_char ) {
# out of characters - give up
return;
}
# Must see one of: ATTRIBUTE, VERSION, BLOCK, or end stmt
# Possibly valid next token types:
# ':' could start ATTRIBUTE
# '\d' could start VERSION
# '{' cold start BLOCK
# ';' could end a statement
# '}' could end statement but would be strange
if ( $next_char !~ /^[\:\d\{\;\}]/ ) {
# This does not match use feature 'class' syntax
return;
}
# We will stop here and assume that this is valid syntax for
# use feature 'class'.
return 1;
} ## end sub class_ok_here
sub scan_id {
my $self = shift;
( $i, $tok, $type, $id_scan_state ) = $self->scan_id_do(
$input_line,
$i, $tok,
$rtokens,
$rtoken_map,
$id_scan_state,
$max_token_index
);
return;
} ## end sub scan_id
sub scan_number {
my $self = shift;
my $number;
( $i, $type, $number ) =
$self->scan_number_do( $input_line, $i, $rtoken_map, $type,
$max_token_index );
return $number;
} ## end sub scan_number
use constant VERIFY_FASTNUM => 0;
sub scan_number_fast {
my $self = shift;
# This is a wrapper for sub scan_number. It does a fast preliminary
# scan for a simple integer. It calls the original scan_number if it
# does not find one.
my $i_begin = $i;
my $tok_begin = $tok;
my $number;
#---------------------------------
# Quick check for (signed) integer
#---------------------------------
# This will be the string of digits:
my $i_d = $i;
my $tok_d = $tok;
my $typ_d = $rtoken_type->[$i_d];
# check for signed integer
my $sign = EMPTY_STRING;
if ( $typ_d ne 'd'
&& ( $typ_d eq '+' || $typ_d eq '-' )
&& $i_d < $max_token_index )
{
$sign = $tok_d;
$i_d++;
$tok_d = $rtokens->[$i_d];
$typ_d = $rtoken_type->[$i_d];
}
# Handle integers
if (
$typ_d eq 'd'
&& (
$i_d == $max_token_index
|| ( $i_d < $max_token_index
&& $rtoken_type->[ $i_d + 1 ] ne '.'
&& $rtoken_type->[ $i_d + 1 ] ne 'w' )
)
)
{
# Let let full scanner handle multi-digit integers beginning with
# '0' because there could be error messages. For example, '009' is
# not a valid number.
if ( $tok_d eq '0' || substr( $tok_d, 0, 1 ) ne '0' ) {
$number = $sign . $tok_d;
$type = 'n';
$i = $i_d;
}
}
#--------------------------------------
# Verify correctness during development
#--------------------------------------
if ( VERIFY_FASTNUM && defined($number) ) {
# We will call the full method
my $type_simple = $type;
my $i_simple = $i;
my $number_simple = $number;
$tok = $tok_begin;
$i = $i_begin;
$number = $self->scan_number();
if ( $type ne $type_simple
|| ( $i != $i_simple && $i <= $max_token_index )
|| $number ne $number_simple )
{
print {*STDERR} <scan_number();
}
return $number;
} ## end sub scan_number_fast
# a sub to warn if token found where term expected
sub error_if_expecting_TERM {
my $self = shift;
if ( $expecting == TERM ) {
if ( $really_want_term{$last_nonblank_type} ) {
$self->report_unexpected(
{
found => $tok,
expecting => "term",
i_tok => $i_tok,
last_nonblank_i => $last_nonblank_i,
rpretoken_map => $rtoken_map,
rpretoken_type => $rtoken_type,
input_line => $input_line,
}
);
return 1;
}
}
return;
} ## end sub error_if_expecting_TERM
# a sub to warn if token found where operator expected
sub error_if_expecting_OPERATOR {
my ( $self, ($thing) ) = @_;
# Issue warning on error if expecting operator
# Given:
# $thing = the unexpected token or issue
# = undef to use current pre-token
if ( $expecting == OPERATOR ) {
if ( !defined($thing) ) { $thing = $tok }
$self->report_unexpected(
{
found => $thing,
expecting => "operator",
i_tok => $i_tok,
last_nonblank_i => $last_nonblank_i,
rpretoken_map => $rtoken_map,
rpretoken_type => $rtoken_type,
input_line => $input_line,
}
);
if ( $i_tok == 0 ) {
$self->interrupt_logfile();
$self->warning("Missing ';' or ',' above?\n");
$self->resume_logfile();
}
return 1;
}
return;
} ## end sub error_if_expecting_OPERATOR
# ------------------------------------------------------------
# end scanner interfaces
# ------------------------------------------------------------
#------------------
# Tokenization subs
#------------------
sub do_GREATER_THAN_SIGN {
my $self = shift;
# '>'
$self->error_if_expecting_TERM()
if ( $expecting == TERM );
return;
} ## end sub do_GREATER_THAN_SIGN
sub do_VERTICAL_LINE {
my $self = shift;
# '|'
$self->error_if_expecting_TERM()
if ( $expecting == TERM );
return;
} ## end sub do_VERTICAL_LINE
# An identifier in possible indirect object location followed by any of
# these tokens: -> , ; } (plus others) is not an indirect object. Fix c257.
my %Z_test_hash;
BEGIN {
my @qZ = qw#
-> ; } ) ]
=> =~ = == !~ || >= != *= .. && |= .= -= += <= %=
^= &&= ||= //= <=>
#;
push @qZ, ',';
@Z_test_hash{@qZ} = (1) x scalar(@qZ);
}
sub do_DOLLAR_SIGN {
my $self = shift;
# '$'
# start looking for a scalar
$self->error_if_expecting_OPERATOR("Scalar")
if ( $expecting == OPERATOR );
$self->scan_simple_identifier();
if ( $identifier eq '$^W' ) {
$self->[_saw_perl_dash_w_] = 1;
}
# Check for identifier in indirect object slot
# (vorboard.pl, sort.t). Something like:
# /^(print|printf|sort|exec|system)$/
if (
$is_indirect_object_taker{$last_nonblank_token}
&& $last_nonblank_type eq 'k'
|| ( ( $last_nonblank_token eq '(' )
&& $is_indirect_object_taker{ $rparen_type->[$paren_depth] } )
|| ( $last_nonblank_type eq 'w'
|| $last_nonblank_type eq 'U' ) # possible object
)
{
# An identifier followed by '->' is not indirect object;
# fixes b1175, b1176. Fix c257: Likewise for other tokens like
# comma, semicolon, closing brace, and single space.
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_noncomment_token( $i, $rtokens,
$max_token_index );
$type = 'Z' if ( !$Z_test_hash{$next_nonblank_token} );
}
return;
} ## end sub do_DOLLAR_SIGN
sub do_LEFT_PARENTHESIS {
my $self = shift;
# '('
++$paren_depth;
# variable to enable check for brace after closing paren (c230)
my $want_brace = EMPTY_STRING;
if ($want_paren) {
$container_type = $want_paren;
$want_brace = $want_paren;
$want_paren = EMPTY_STRING;
}
elsif ( substr( $statement_type, 0, 3 ) eq 'sub'
&& $statement_type =~ /^sub\b/ )
{
$container_type = $statement_type;
}
else {
$container_type = $last_nonblank_token;
# We can check for a syntax error here of unexpected '(',
# but this is going to get messy...
if (
$expecting == OPERATOR
# Be sure this is not a method call of the form
# &method(...), $method->(..), &{method}(...),
# $ref[2](list) is ok & short for $ref[2]->(list)
# NOTE: at present, braces in something like &{ xxx }
# are not marked as a block, we might have a method call.
# Added ')' to fix case c017, something like ()()()
&& $last_nonblank_token !~ /^(?:[\]\}\)\&]|\-\>)/
)
{
# ref: camel 3 p 703.
if ( $last_last_nonblank_token eq 'do' ) {
$self->complain(
"do SUBROUTINE is deprecated; consider & or -> notation\n"
);
}
else {
# if this is an empty list, (), then it is not an
# error; for example, we might have a constant pi and
# invoke it with pi() or just pi;
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_nonblank_token( $i, $rtokens,
$max_token_index );
# Patch for c029: give up error check if
# a side comment follows
if ( $next_nonblank_token ne ')'
&& $next_nonblank_token ne '#' )
{
my $hint;
$self->error_if_expecting_OPERATOR('(');
if ( $last_nonblank_type eq 'C' ) {
$hint =
"$last_nonblank_token has a void prototype\n";
}
elsif ( $last_nonblank_type eq 'i' ) {
if ( $i_tok > 0
&& $last_nonblank_token =~ /^\$/ )
{
$hint =
"Do you mean '$last_nonblank_token->(' ?\n";
}
}
else {
## no hint
}
if ($hint) {
$self->interrupt_logfile();
$self->warning($hint);
$self->resume_logfile();
}
} ## end if ( $next_nonblank_token...
} ## end else [ if ( $last_last_nonblank_token...
} ## end if ( $expecting == OPERATOR...
}
( $type_sequence, $indent_flag ) =
$self->increase_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
# propagate types down through nested parens
# for example: the second paren in 'if ((' would be structural
# since the first is.
if ( $last_nonblank_token eq '(' ) {
$type = $last_nonblank_type;
}
# We exclude parens as structural after a ',' because it
# causes subtle problems with continuation indentation for
# something like this, where the first 'or' will not get
# indented.
#
# assert(
# __LINE__,
# ( not defined $check )
# or ref $check
# or $check eq "new"
# or $check eq "old",
# );
#
# Likewise, we exclude parens where a statement can start
# because of problems with continuation indentation, like
# these:
#
# ($firstline =~ /^#\!.*perl/)
# and (print $File::Find::name, "\n")
# and (return 1);
#
# (ref($usage_fref) =~ /CODE/)
# ? &$usage_fref
# : (&blast_usage, &blast_params, &blast_general_params);
else {
$type = '{';
}
if ( $last_nonblank_type eq ')' ) {
$self->warning(
"Syntax error? found token '$last_nonblank_type' then '('\n");
}
# git #105: Copy container type and want-brace flag at ') (';
# propagate the container type onward so that any subsequent brace gets
# correctly marked. I have implemented this as a general rule, which
# should be safe, but if necessary it could be restricted to certain
# container statement types such as 'for'.
if ( $last_nonblank_token eq ')' ) {
my $rvars = $rparen_vars->[$paren_depth];
if ( defined($rvars) ) {
$container_type = $rparen_type->[$paren_depth];
( my $type_lp_uu, $want_brace ) = @{$rvars};
}
}
$rparen_type->[$paren_depth] = $container_type;
$rparen_vars->[$paren_depth] = [ $type, $want_brace ];
$rparen_semicolon_count->[$paren_depth] = 0;
return;
} ## end sub do_LEFT_PARENTHESIS
sub do_RIGHT_PARENTHESIS {
my $self = shift;
# ')'
( $type_sequence, $indent_flag ) =
$self->decrease_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
my $rvars = $rparen_vars->[$paren_depth];
if ( defined($rvars) ) {
my ( $type_lp, $want_brace_uu ) = @{$rvars};
if ( $type_lp && $type_lp eq '{' ) {
$type = '}';
}
}
$container_type = $rparen_type->[$paren_depth];
# restore statement type as 'sub' at closing paren of a signature
# so that a subsequent ':' is identified as an attribute
if ( substr( $container_type, 0, 3 ) eq 'sub'
&& $container_type =~ /^sub\b/ )
{
$statement_type = $container_type;
}
if ( $is_for_foreach{ $rparen_type->[$paren_depth] } ) {
my $num_sc = $rparen_semicolon_count->[$paren_depth];
if ( $num_sc > 0 && $num_sc != 2 ) {
$self->warning("Expected 2 ';' in 'for(;;)' but saw $num_sc\n");
}
}
if ( $paren_depth > 0 ) { $paren_depth-- }
return;
} ## end sub do_RIGHT_PARENTHESIS
sub do_COMMA {
my $self = shift;
# ','
if ( $last_nonblank_type eq ',' ) {
$self->complain("Repeated ','s \n");
}
# Note that we have to check both token and type here because a
# comma following a qw list can have last token='(' but type = 'q'
elsif ( $last_nonblank_token eq '(' && $last_nonblank_type eq '{' ) {
$self->warning("Unexpected leading ',' after a '('\n");
}
else {
# no complaints about the comma
}
# patch for operator_expected: note if we are in the list (use.t)
if ( $statement_type eq 'use' ) { $statement_type = '_use' }
return;
} ## end sub do_COMMA
sub do_SEMICOLON {
my $self = shift;
# ';'
$context = UNKNOWN_CONTEXT;
$statement_type = EMPTY_STRING;
$want_paren = EMPTY_STRING;
if ( $is_for_foreach{ $rparen_type->[$paren_depth] } )
{ # mark ; in for loop
# Be careful: we do not want a semicolon such as the
# following to be included:
#
# for (sort {strcoll($a,$b);} keys %investments) {
if ( $brace_depth == $rdepth_array->[PAREN][BRACE][$paren_depth]
&& $square_bracket_depth ==
$rdepth_array->[PAREN][SQUARE_BRACKET][$paren_depth] )
{
$type = 'f';
$rparen_semicolon_count->[$paren_depth]++;
}
}
return;
} ## end sub do_SEMICOLON
sub do_QUOTATION_MARK {
my $self = shift;
# '"'
$self->error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = EMPTY_STRING;
return;
} ## end sub do_QUOTATION_MARK
sub do_APOSTROPHE {
my $self = shift;
# "'"
$self->error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = EMPTY_STRING;
return;
} ## end sub do_APOSTROPHE
sub do_BACKTICK {
my $self = shift;
# '`'
$self->error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = EMPTY_STRING;
return;
} ## end sub do_BACKTICK
sub do_SLASH {
my $self = shift;
# '/'
my $is_pattern;
# a pattern cannot follow certain keywords which take optional
# arguments, like 'shift' and 'pop'. See also '?'.
if (
$last_nonblank_type eq 'k'
&& $is_keyword_rejecting_slash_as_pattern_delimiter{
$last_nonblank_token}
)
{
$is_pattern = 0;
}
elsif ( $expecting == UNKNOWN ) { # indeterminate, must guess..
my $msg;
( $is_pattern, $msg ) =
$self->guess_if_pattern_or_division( $i, $rtokens, $rtoken_type,
$rtoken_map, $max_token_index );
if ($msg) {
$self->write_diagnostics("DIVIDE:$msg\n");
$self->write_logfile_entry($msg);
}
}
else { $is_pattern = ( $expecting == TERM ) }
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = $quote_modifiers{'m'};
}
else { # not a pattern; check for a /= token
if ( $rtokens->[ $i + 1 ] eq '=' ) { # form token /=
$i++;
$tok = '/=';
$type = $tok;
}
#DEBUG - collecting info on what tokens follow a divide
# for development of guessing algorithm
## if (
## $self->is_possible_numerator( $i, $rtokens,
## $max_token_index ) < 0
## )
## {
## $self->write_diagnostics("DIVIDE? $input_line\n");
## }
}
return;
} ## end sub do_SLASH
sub do_LEFT_CURLY_BRACKET {
my $self = shift;
# '{'
# if we just saw a ')', we will label this block with
# its type. We need to do this to allow sub
# code_block_type to determine if this brace starts a
# code block or anonymous hash. (The type of a paren
# pair is the preceding token, such as 'if', 'else',
# etc).
$container_type = EMPTY_STRING;
# ATTRS: for a '{' following an attribute list, reset
# things to look like we just saw a sub name
# Added 'package' (can be 'class') for --use-feature=class (rt145706)
if ( substr( $statement_type, 0, 3 ) eq 'sub' ) {
$last_nonblank_token = $statement_type;
$last_nonblank_type = 'S'; # c250 change
$statement_type = EMPTY_STRING;
}
elsif ( substr( $statement_type, 0, 7 ) eq 'package' ) {
$last_nonblank_token = $statement_type;
$last_nonblank_type = 'P'; # c250 change
$statement_type = EMPTY_STRING;
}
# patch for SWITCH/CASE: hide these keywords from an immediately
# following opening brace
elsif ( ( $statement_type eq 'case' || $statement_type eq 'when' )
&& $statement_type eq $last_nonblank_token )
{
$last_nonblank_token = ";";
}
elsif ( $last_nonblank_token eq ')' ) {
$last_nonblank_token = $rparen_type->[ $paren_depth + 1 ];
# defensive move in case of a nesting error (pbug.t)
# in which this ')' had no previous '('
# this nesting error will have been caught
if ( !defined($last_nonblank_token) ) {
$last_nonblank_token = 'if';
}
# Syntax check at '){'
if ( $is_blocktype_with_paren{$last_nonblank_token} ) {
my $rvars = $rparen_vars->[ $paren_depth + 1 ];
if ( defined($rvars) ) {
my ( $type_lp_uu, $want_brace ) = @{$rvars};
# OLD: Now verify that this is not a trailing form
# FIX for git #124: we have to skip this check because
# the 'gather' keyword of List::Gather can operate on
# a full statement, so it isn't possible to be sure
# this is a trailing form.
if ( 0 && !$want_brace ) {
$self->warning(
"syntax error at ') {', unexpected '{' after closing ')' of a trailing '$last_nonblank_token'\n"
);
}
}
}
else {
if ($rOpts_extended_syntax) {
# we append a trailing () to mark this as an unknown
# block type. This allows perltidy to format some
# common extensions of perl syntax.
# This is used by sub code_block_type
$last_nonblank_token .= '()';
}
else {
my $list =
join( SPACE, sort keys %is_blocktype_with_paren );
$self->warning(
"syntax error at ') {', didn't see one of: <<$list>>; If this code is okay try using the -xs flag\n"
);
}
}
}
# patch for paren-less for/foreach glitch, part 2.
# see note below under 'qw'
elsif ($last_nonblank_token eq 'qw'
&& $is_for_foreach{$want_paren} )
{
$last_nonblank_token = $want_paren;
if ( $last_last_nonblank_token eq $want_paren ) {
$self->warning(
"syntax error at '$want_paren .. {' -- missing \$ loop variable\n"
);
}
$want_paren = EMPTY_STRING;
}
else {
# not special
}
# now identify which of the three possible types of
# curly braces we have: hash index container, anonymous
# hash reference, or code block.
# non-structural (hash index) curly brace pair
# get marked 'L' and 'R'
if ( is_non_structural_brace() ) {
$type = 'L';
# patch for SWITCH/CASE:
# allow paren-less identifier after 'when'
# if the brace is preceded by a space
if ( $statement_type eq 'when'
&& $last_nonblank_type eq 'i'
&& $last_last_nonblank_type eq 'k'
&& ( $i_tok == 0 || $rtoken_type->[ $i_tok - 1 ] eq 'b' ) )
{
$type = '{';
$block_type = $statement_type;
}
}
# code and anonymous hash have the same type, '{', but are
# distinguished by 'block_type',
# which will be blank for an anonymous hash
else {
$block_type =
$self->code_block_type( $i_tok, $rtokens, $rtoken_type,
$max_token_index );
# patch to promote bareword type to function taking block
if ( $block_type
&& $last_nonblank_type eq 'w'
&& $last_nonblank_i >= 0 )
{
if ( $routput_token_type->[$last_nonblank_i] eq 'w' ) {
$routput_token_type->[$last_nonblank_i] =
$is_grep_alias{$block_type} ? 'k' : 'G';
}
}
# patch for SWITCH/CASE: if we find a stray opening block brace
# where we might accept a 'case' or 'when' block, then take it
if ( $statement_type eq 'case'
|| $statement_type eq 'when' )
{
if ( !$block_type || $block_type eq '}' ) {
$block_type = $statement_type;
}
}
}
$rbrace_type->[ ++$brace_depth ] = $block_type;
# Patch for CLASS BLOCK definitions: do not update the package for the
# current depth if this is a BLOCK type definition.
# TODO: should make 'class' separate from 'package' and only do
# this for 'class'
$rbrace_package->[$brace_depth] = $current_package
if ( substr( $block_type, 0, 8 ) ne 'package ' );
$rbrace_structural_type->[$brace_depth] = $type;
$rbrace_context->[$brace_depth] = $context;
( $type_sequence, $indent_flag ) =
$self->increase_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
return;
} ## end sub do_LEFT_CURLY_BRACKET
sub do_RIGHT_CURLY_BRACKET {
my $self = shift;
# '}'
$block_type = $rbrace_type->[$brace_depth];
if ($block_type) { $statement_type = EMPTY_STRING }
if ( defined( $rbrace_package->[$brace_depth] ) ) {
$current_package = $rbrace_package->[$brace_depth];
}
# can happen on brace error (caught elsewhere)
else {
}
( $type_sequence, $indent_flag ) =
$self->decrease_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
if ( $rbrace_structural_type->[$brace_depth] eq 'L' ) {
$type = 'R';
}
# propagate type information for 'do' and 'eval' blocks, and also
# for smartmatch operator. This is necessary to enable us to know
# if an operator or term is expected next.
if ( $is_block_operator{$block_type} ) {
$tok = $block_type;
}
# pop non-indenting brace stack if sequence number matches
if ( @{ $self->[_rnon_indenting_brace_stack_] }
&& $self->[_rnon_indenting_brace_stack_]->[-1] eq $type_sequence )
{
pop @{ $self->[_rnon_indenting_brace_stack_] };
}
$context = $rbrace_context->[$brace_depth];
if ( $brace_depth > 0 ) { $brace_depth--; }
return;
} ## end sub do_RIGHT_CURLY_BRACKET
sub do_AMPERSAND {
my $self = shift;
# '&' = maybe sub call? start looking
# We have to check for sub call unless we are sure we
# are expecting an operator. This example from s2p
# got mistaken as a q operator in an early version:
# print BODY &q(<<'EOT');
if ( $expecting != OPERATOR ) {
# But only look for a sub call if we are expecting a term or
# if there is no existing space after the &.
# For example we probably don't want & as sub call here:
# Fcntl::S_IRUSR & $mode;
if ( $expecting == TERM || $next_type ne 'b' ) {
$self->scan_simple_identifier();
}
}
else {
}
return;
} ## end sub do_AMPERSAND
sub do_LESS_THAN_SIGN {
my $self = shift;
# '<' - angle operator or less than?
if ( $expecting != OPERATOR ) {
( $i, $type ) =
$self->find_angle_operator_termination( $input_line, $i,
$rtoken_map, $expecting, $max_token_index );
}
else {
}
return;
} ## end sub do_LESS_THAN_SIGN
sub do_QUESTION_MARK {
my $self = shift;
# '?' = conditional or starting pattern?
my $is_pattern;
# Patch for rt #126965
# a pattern cannot follow certain keywords which take optional
# arguments, like 'shift' and 'pop'. See also '/'.
if (
$last_nonblank_type eq 'k'
&& $is_keyword_rejecting_question_as_pattern_delimiter{
$last_nonblank_token}
)
{
$is_pattern = 0;
}
# patch for RT#131288, user constant function without prototype
# last type is 'U' followed by ?.
elsif ( $last_nonblank_type =~ /^[FUY]$/ ) {
$is_pattern = 0;
}
elsif ( $expecting == UNKNOWN ) {
# In older versions of Perl, a bare ? can be a pattern
# delimiter. In perl version 5.22 this was
# dropped, but we have to support it in order to format
# older programs. See:
## https://perl.developpez.com/documentations/en/5.22.0/perl5211delta.html
# For example, the following line worked
# at one time:
# ?(.*)? && (print $1,"\n");
# In current versions it would have to be written with slashes:
# /(.*)/ && (print $1,"\n");
my $msg;
( $is_pattern, $msg ) =
$self->guess_if_pattern_or_conditional( $i, $rtokens,
$rtoken_type, $rtoken_map, $max_token_index );
if ($msg) { $self->write_logfile_entry($msg) }
}
else { $is_pattern = ( $expecting == TERM ) }
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = $quote_modifiers{'m'};
}
else {
( $type_sequence, $indent_flag ) =
$self->increase_nesting_depth( QUESTION_COLON,
$rtoken_map->[$i_tok] );
}
return;
} ## end sub do_QUESTION_MARK
sub do_STAR {
my $self = shift;
# '*' = typeglob, or multiply?
if ( $expecting == UNKNOWN ) {
if ( $last_nonblank_type eq 'Z'
&& $next_type ne 'b'
&& $next_type ne '('
&& $next_type ne '#' ) # Fix c036
{
$expecting = TERM;
}
}
if ( $expecting == TERM ) {
$self->scan_simple_identifier();
}
else {
if ( $rtokens->[ $i + 1 ] eq '=' ) {
$tok = '*=';
$type = $tok;
$i++;
}
elsif ( $rtokens->[ $i + 1 ] eq '*' ) {
$tok = '**';
$type = $tok;
$i++;
if ( $rtokens->[ $i + 1 ] eq '=' ) {
$tok = '**=';
$type = $tok;
$i++;
}
}
else {
## not multiple characters
}
}
return;
} ## end sub do_STAR
sub do_DOT {
my $self = shift;
# '.' = what kind of . ?
if ( $expecting != OPERATOR ) {
$self->scan_number();
if ( $type eq '.' ) {
$self->error_if_expecting_TERM()
if ( $expecting == TERM );
}
}
else {
}
return;
} ## end sub do_DOT
sub do_COLON {
my $self = shift;
# ':' = label, ternary, attribute, ?
# if this is the first nonblank character, call it a label
# since perl seems to just swallow it
if ( $input_line_number == 1 && $last_nonblank_i == -1 ) {
$type = 'J';
}
# ATTRS: check for a ':' which introduces an attribute list
# either after a 'sub' keyword or within a paren list
# Added 'package' (can be 'class') for --use-feature=class (rt145706)
elsif ( $statement_type =~ /^(sub|package)\b/ ) {
$type = 'A';
$self->[_in_attribute_list_] = 1;
}
# Within a signature, unless we are in a ternary. For example,
# from 't/filter_example.t':
# method foo4 ( $class: $bar ) { $class->bar($bar) }
elsif ( $rparen_type->[$paren_depth] =~ /^sub\b/
&& !is_balanced_closing_container(QUESTION_COLON) )
{
$type = 'A';
$self->[_in_attribute_list_] = 1;
}
# check for scalar attribute, such as
# my $foo : shared = 1;
elsif ($is_my_our_state{$statement_type}
&& $rcurrent_depth->[QUESTION_COLON] == 0 )
{
$type = 'A';
$self->[_in_attribute_list_] = 1;
}
# Look for Switch::Plain syntax if an error would otherwise occur
# here. Note that we do not need to check if the extended syntax
# flag is set because otherwise an error would occur, and we would
# then have to output a message telling the user to set the
# extended syntax flag to avoid the error.
# case 1: {
# default: {
# default:
# Note that the line 'default:' will be parsed as a label elsewhere.
elsif ( $is_case_default{$statement_type}
&& !is_balanced_closing_container(QUESTION_COLON) )
{
# mark it as a perltidy label type
$type = 'J';
}
# mark colon as attribute if an error would occur otherwise; git #162
elsif ( !$rcurrent_depth->[QUESTION_COLON] ) {
$type = 'A';
$self->[_in_attribute_list_] = 1;
}
# otherwise, it should be part of a ?/: operator
else {
( $type_sequence, $indent_flag ) =
$self->decrease_nesting_depth( QUESTION_COLON,
$rtoken_map->[$i_tok] );
if ( $last_nonblank_token eq '?' ) {
$self->warning("Syntax error near ? :\n");
}
}
return;
} ## end sub do_COLON
sub do_PLUS_SIGN {
my $self = shift;
# '+' = what kind of plus?
if ( $expecting == TERM ) {
my $number = $self->scan_number_fast();
# unary plus is safest assumption if not a number
if ( !defined($number) ) { $type = 'p'; }
}
elsif ( $expecting == OPERATOR ) {
}
else {
if ( $next_type eq 'w' ) { $type = 'p' }
}
return;
} ## end sub do_PLUS_SIGN
sub do_AT_SIGN {
my $self = shift;
# '@' = sigil for array?
$self->error_if_expecting_OPERATOR("Array")
if ( $expecting == OPERATOR );
$self->scan_simple_identifier();
return;
} ## end sub do_AT_SIGN
sub do_PERCENT_SIGN {
my $self = shift;
# '%' = hash or modulo?
# first guess is hash if no following blank or paren
if ( $expecting == UNKNOWN ) {
if ( $next_type ne 'b' && $next_type ne '(' ) {
$expecting = TERM;
}
}
if ( $expecting == TERM ) {
$self->scan_simple_identifier();
}
return;
} ## end sub do_PERCENT_SIGN
sub do_LEFT_SQUARE_BRACKET {
my $self = shift;
# '['
$rsquare_bracket_type->[ ++$square_bracket_depth ] =
$last_nonblank_token;
( $type_sequence, $indent_flag ) =
$self->increase_nesting_depth( SQUARE_BRACKET,
$rtoken_map->[$i_tok] );
# It may seem odd, but structural square brackets have
# type '{' and '}'. This simplifies the indentation logic.
if ( !is_non_structural_brace() ) {
$type = '{';
}
$rsquare_bracket_structural_type->[$square_bracket_depth] = $type;
return;
} ## end sub do_LEFT_SQUARE_BRACKET
sub do_RIGHT_SQUARE_BRACKET {
my $self = shift;
# ']'
( $type_sequence, $indent_flag ) =
$self->decrease_nesting_depth( SQUARE_BRACKET,
$rtoken_map->[$i_tok] );
if ( $rsquare_bracket_structural_type->[$square_bracket_depth] eq '{' )
{
$type = '}';
}
# propagate type information for smartmatch operator. This is
# necessary to enable us to know if an operator or term is expected
# next.
if ( $rsquare_bracket_type->[$square_bracket_depth] eq '~~' ) {
$tok = $rsquare_bracket_type->[$square_bracket_depth];
}
if ( $square_bracket_depth > 0 ) { $square_bracket_depth--; }
return;
} ## end sub do_RIGHT_SQUARE_BRACKET
sub do_MINUS_SIGN {
my $self = shift;
# '-' = what kind of minus?
if ( ( $expecting != OPERATOR )
&& $is_file_test_operator{$next_tok} )
{
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_nonblank_token( $i + 1, $rtokens,
$max_token_index );
# check for a quoted word like "-w=>xx";
# it is sufficient to just check for a following '='
if ( $next_nonblank_token eq '=' ) {
$type = 'm';
}
else {
$i++;
$tok .= $next_tok;
$type = 'F';
}
}
elsif ( $expecting == TERM ) {
my $number = $self->scan_number_fast();
# maybe part of bareword token? unary is safest
if ( !defined($number) ) { $type = 'm'; }
}
elsif ( $expecting == OPERATOR ) {
}
else {
if ( $next_type eq 'w' ) {
$type = 'm';
}
}
return;
} ## end sub do_MINUS_SIGN
sub do_CARAT_SIGN {
my $self = shift;
# '^'
# check for special variables like ${^WARNING_BITS}
if ( $expecting == TERM ) {
if ( $last_nonblank_token eq '{'
&& ( $next_tok !~ /^\d/ )
&& ( $next_tok =~ /^\w/ ) )
{
if ( $next_tok eq 'W' ) {
$self->[_saw_perl_dash_w_] = 1;
}
$tok = $tok . $next_tok;
$i = $i + 1;
$type = 'w';
# Optional coding to try to catch syntax errors. This can
# be removed if it ever causes incorrect warning messages.
# The '{^' should be preceded by either by a type or '$#'
# Examples:
# $#{^CAPTURE} ok
# *${^LAST_FH}{NAME} ok
# @{^HOWDY} ok
# $hash{^HOWDY} error
# Note that a type sigil '$' may be tokenized as 'Z'
# after something like 'print', so allow type 'Z'
if ( $last_last_nonblank_type ne 't'
&& $last_last_nonblank_type ne 'Z'
&& $last_last_nonblank_token ne '$#' )
{
$self->warning("Possible syntax error near '{^'\n");
}
}
else {
if ( !$self->error_if_expecting_TERM() ) {
# Something like this is valid but strange:
# undef ^I;
$self->complain("The '^' seems unusual here\n");
}
}
}
return;
} ## end sub do_CARAT_SIGN
sub do_DOUBLE_COLON {
my $self = shift;
# '::' = probably a sub call
$self->scan_bare_identifier();
return;
} ## end sub do_DOUBLE_COLON
sub do_LEFT_SHIFT {
my $self = shift;
# '<<' = maybe a here-doc?
if ( $expecting != OPERATOR ) {
my ( $found_target, $here_doc_target, $here_quote_character,
$saw_error );
(
$found_target, $here_doc_target, $here_quote_character, $i,
$saw_error
)
= $self->find_here_doc( $expecting, $i, $rtokens, $rtoken_type,
$rtoken_map, $max_token_index );
if ($found_target) {
push @{$rhere_target_list},
[ $here_doc_target, $here_quote_character ];
$type = 'h';
if ( length($here_doc_target) > 80 ) {
my $truncated = substr( $here_doc_target, 0, 80 );
$self->complain("Long here-target: '$truncated' ...\n");
}
elsif ( !$here_doc_target ) {
$self->warning(
'Use of bare << to mean <<"" is deprecated' . "\n" )
if ( !$here_quote_character );
}
elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
$self->complain(
"Unconventional here-target: '$here_doc_target'\n");
}
else {
# nothing to complain about
}
}
elsif ( $expecting == TERM ) {
if ( !$saw_error ) {
# shouldn't happen..arriving here implies an error in
# the logic in sub 'find_here_doc'
if (DEVEL_MODE) {
$self->Fault(<warning(
"Possible program error: didn't find here doc target\n"
);
$self->report_definite_bug();
}
}
# target not found, expecting == UNKNOWN
else {
# assume it is a shift
}
}
else {
}
return;
} ## end sub do_LEFT_SHIFT
sub do_NEW_HERE_DOC {
# '<<~' = a here-doc, new type added in v26
my $self = shift;
return
if ( $i >= $max_token_index ); # here-doc not possible if end of line
if ( $expecting != OPERATOR ) {
my ( $found_target, $here_doc_target, $here_quote_character,
$saw_error );
(
$found_target, $here_doc_target, $here_quote_character, $i,
$saw_error
)
= $self->find_here_doc( $expecting, $i, $rtokens, $rtoken_type,
$rtoken_map, $max_token_index );
if ($found_target) {
if ( length($here_doc_target) > 80 ) {
my $truncated = substr( $here_doc_target, 0, 80 );
$self->complain("Long here-target: '$truncated' ...\n");
}
elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
$self->complain(
"Unconventional here-target: '$here_doc_target'\n");
}
else {
# nothing to complain about
}
# Note that we put a leading space on the here quote
# character indicate that it may be preceded by spaces
$here_quote_character = SPACE . $here_quote_character;
push @{$rhere_target_list},
[ $here_doc_target, $here_quote_character ];
$type = 'h';
}
# target not found ..
elsif ( $expecting == TERM ) {
if ( !$saw_error ) {
# shouldn't happen..arriving here implies an error in
# the logic in sub 'find_here_doc'
if (DEVEL_MODE) {
$self->Fault(<warning(
"Possible program error: didn't find here doc target\n"
);
$self->report_definite_bug();
}
}
# Target not found, expecting==UNKNOWN
else {
$self->warning("didn't find here doc target after '<<~'\n");
}
}
else {
$self->error_if_expecting_OPERATOR();
}
return;
} ## end sub do_NEW_HERE_DOC
sub do_POINTER {
# '->'
return;
}
sub do_PLUS_PLUS {
my $self = shift;
# '++'
# type = 'pp' for pre-increment, '++' for post-increment
if ( $expecting == OPERATOR ) { $type = '++' }
elsif ( $expecting == TERM ) { $type = 'pp' }
# handle ( $expecting == UNKNOWN )
else {
# look ahead ..
my ( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
# Fix for c042: look past a side comment
if ( $next_nonblank_token eq '#' ) {
( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( $next_nonblank_token eq '$' ) { $type = 'pp' }
}
return;
} ## end sub do_PLUS_PLUS
sub do_FAT_COMMA {
my $self = shift;
# '=>'
if ( $last_nonblank_type eq $tok ) {
$self->complain("Repeated '=>'s \n");
}
# patch for operator_expected: note if we are in the list (use.t)
# TODO: make version numbers a new token type
if ( $statement_type eq 'use' ) { $statement_type = '_use' }
return;
} ## end sub do_FAT_COMMA
sub do_MINUS_MINUS {
my $self = shift;
# '--'
# type = 'mm' for pre-decrement, '--' for post-decrement
if ( $expecting == OPERATOR ) { $type = '--' }
elsif ( $expecting == TERM ) { $type = 'mm' }
# handle ( $expecting == UNKNOWN )
else {
# look ahead ..
my ( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
# Fix for c042: look past a side comment
if ( $next_nonblank_token eq '#' ) {
( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( $next_nonblank_token eq '$' ) { $type = 'mm' }
}
return;
} ## end sub do_MINUS_MINUS
sub do_LOGICAL_AND {
my $self = shift;
# '&&'
$self->error_if_expecting_TERM()
if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
return;
} ## end sub do_LOGICAL_AND
sub do_LOGICAL_OR {
my $self = shift;
# '||'
$self->error_if_expecting_TERM()
if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
return;
} ## end sub do_LOGICAL_OR
sub do_SLASH_SLASH {
my $self = shift;
# '//'
$self->error_if_expecting_TERM()
if ( $expecting == TERM );
return;
} ## end sub do_SLASH_SLASH
sub do_DIGITS {
my $self = shift;
# 'd' = string of digits
$self->error_if_expecting_OPERATOR("Number")
if ( $expecting == OPERATOR );
my $number = $self->scan_number_fast();
if ( !defined($number) ) {
# shouldn't happen - we should always get a number
if (DEVEL_MODE) {
$self->Fault(<warning(
"Unexpected error condition: non-number beginning with digit\n"
);
$self->report_definite_bug();
}
return;
} ## end sub do_DIGITS
sub do_ATTRIBUTE_LIST {
my ( $self, $next_nonblank_token ) = @_;
# Called at a bareword encountered while in an attribute list
# returns 'is_attribute':
# true if attribute found
# false if an attribute (continue parsing bareword)
# treat bare word followed by open paren like qw(
if ( $next_nonblank_token eq '(' ) {
# For something like:
# : prototype($$)
# we should let do_scan_sub see it so that it can see
# the prototype. All other attributes get parsed as a
# quoted string.
if ( $tok eq 'prototype' ) {
$id_scan_state = 'prototype';
# start just after the word 'prototype'
my $i_beg = $i + 1;
( $i, $tok, $type, $id_scan_state ) = $self->do_scan_sub(
{
input_line => $input_line,
i => $i,
i_beg => $i_beg,
tok => $tok,
type => $type,
rtokens => $rtokens,
rtoken_map => $rtoken_map,
id_scan_state => $id_scan_state,
max_token_index => $max_token_index,
}
);
# If successful, mark as type 'q' to be consistent
# with other attributes. Type 'w' would also work.
if ( $i > $i_beg ) {
$type = 'q';
return 1;
}
# If not successful, continue and parse as a quote.
}
# All other attribute lists must be parsed as quotes
# (see 'signatures.t' for good examples)
$in_quote = $quote_items{'q'};
$allowed_quote_modifiers = $quote_modifiers{'q'};
$type = 'q';
$quote_type = 'q';
return 1;
}
# handle bareword not followed by open paren
else {
$type = 'w';
return 1;
}
# attribute not found
return;
} ## end sub do_ATTRIBUTE_LIST
sub do_X_OPERATOR {
my $self = shift;
if ( $tok eq 'x' ) {
if ( $rtokens->[ $i + 1 ] eq '=' ) { # x=
$tok = 'x=';
$type = $tok;
$i++;
}
else {
$type = 'x';
}
}
else {
# Split a pretoken like 'x10' into 'x' and '10'.
# Note: In previous versions of perltidy it was marked
# as a number, $type = 'n', and fixed downstream by the
# Formatter.
$type = 'n';
if ( $self->split_pretoken(1) ) {
$type = 'x';
$tok = 'x';
}
}
return;
} ## end sub do_X_OPERATOR
sub do_USE_CONSTANT {
my $self = shift;
$self->scan_bare_identifier();
my ( $next_nonblank_tok2, $i_next2_uu ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
if ($next_nonblank_tok2) {
if ( $is_keyword{$next_nonblank_tok2} ) {
# Assume qw is used as a quote and okay, as in:
# use constant qw{ DEBUG 0 };
# Not worth trying to parse for just a warning
# NOTE: This warning is deactivated because recent
# versions of perl do not complain here, but
# the coding is retained for reference.
if ( 0 && $next_nonblank_tok2 ne 'qw' ) {
$self->warning(
"Attempting to define constant '$next_nonblank_tok2' which is a perl keyword\n"
);
}
}
else {
$ris_constant->{$current_package}{$next_nonblank_tok2} = 1;
}
}
return;
} ## end sub do_USE_CONSTANT
sub do_KEYWORD {
my $self = shift;
# found a keyword - set any associated flags
$type = 'k';
# Since for and foreach may not be followed immediately
# by an opening paren, we have to remember which keyword
# is associated with the next '('
# Previously, before update c230 : if ( $is_for_foreach{$tok} ) {
##(if elsif unless while until for foreach switch case given when catch)
if ( $is_blocktype_with_paren{$tok} ) {
if ( new_statement_ok() ) {
$want_paren = $tok;
}
}
# recognize 'use' statements, which are special
if ( $is_use_require{$tok} ) {
$statement_type = $tok;
$self->error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
}
# remember my and our to check for trailing ": shared"
elsif ( $is_my_our_state{$tok} ) {
$statement_type = $tok;
}
# Check for unexpected 'elsif'
elsif ( $tok eq 'elsif' ) {
if (
!$is_if_elsif_unless{$last_nonblank_block_type}
# Allow isolated blocks of any kind during editing
# by checking for a last noblank token of ';' and no
# sequence numbers having been issued (c272). The check
# on sequence number is not perfect but good enough.
&& !(
$last_nonblank_token eq ';'
&& $next_sequence_number == SEQ_ROOT + 1
)
)
{
$self->warning(
"expecting '$tok' to follow one of 'if|elsif|unless'\n");
}
}
# Check for unexpected 'else'
elsif ( $tok eq 'else' ) {
# patched for SWITCH/CASE
if (
!$is_if_elsif_unless_case_when{$last_nonblank_block_type}
# patch to avoid an unwanted error message for
# the case of a parenless 'case' (RT 105484):
# switch ( 1 ) { case x { 2 } else { } }
&& !$is_if_elsif_unless_case_when{$statement_type}
# Allow isolated blocks of any kind during editing (c272)
&& !(
$last_nonblank_token eq ';'
&& $next_sequence_number == SEQ_ROOT + 1
)
)
{
$self->warning(
"expecting '$tok' to follow one of 'if|elsif|unless|case|when'\n"
);
}
}
# patch for SWITCH/CASE if 'case' and 'when are
# treated as keywords. Also 'default' for Switch::Plain
elsif ($tok eq 'when'
|| $tok eq 'case'
|| $tok eq 'default' )
{
$statement_type = $tok; # next '{' is block
}
# feature 'err' was removed in Perl 5.10. So mark this as
# a bareword unless an operator is expected (see c158).
elsif ( $tok eq 'err' ) {
if ( $expecting != OPERATOR ) { $type = 'w' }
}
else {
## no special treatment needed
}
return;
} ## end sub do_KEYWORD
sub do_QUOTE_OPERATOR {
my $self = shift;
if ( $expecting == OPERATOR ) {
# Be careful not to call an error for a qw quote
# where a parenthesized list is allowed. For example,
# it could also be a for/foreach construct such as
#
# foreach my $key qw\Uno Due Tres Quadro\ {
# print "Set $key\n";
# }
#
# Or it could be a function call.
# NOTE: Braces in something like &{ xxx } are not
# marked as a block, we might have a method call.
# &method(...), $method->(..), &{method}(...),
# $ref[2](list) is ok & short for $ref[2]->(list)
#
# See notes in 'sub code_block_type' and
# 'sub is_non_structural_brace'
my $paren_list_possible = $tok eq 'qw'
&& ( $last_nonblank_token =~ /^([\]\}\&]|\-\>)/
|| $is_for_foreach{$want_paren} );
if ( !$paren_list_possible ) {
$self->error_if_expecting_OPERATOR();
}
}
$in_quote = $quote_items{$tok};
$allowed_quote_modifiers = $quote_modifiers{$tok};
# All quote types are 'Q' except possibly qw quotes.
# qw quotes are special in that they may generally be trimmed
# of leading and trailing whitespace. So they are given a
# separate type, 'q', unless requested otherwise.
$type =
( $tok eq 'qw' && $rOpts_trim_qw )
? 'q'
: 'Q';
$quote_type = $type;
return;
} ## end sub do_QUOTE_OPERATOR
sub do_UNKNOWN_BAREWORD {
my ( $self, $next_nonblank_token ) = @_;
$self->scan_bare_identifier();
if ( $statement_type eq 'use'
&& $last_nonblank_token eq 'use' )
{
$rsaw_use_module->{$current_package}->{$tok} = 1;
}
if ( $type eq 'w' ) {
if ( $expecting == OPERATOR ) {
# Patch to avoid error message for RPerl overloaded
# operator functions: use overload
# '+' => \&sse_add,
# '-' => \&sse_sub,
# '*' => \&sse_mul,
# '/' => \&sse_div;
# TODO: this could eventually be generalized
if ( $rsaw_use_module->{$current_package}->{'RPerl'}
&& $tok =~ /^sse_(mul|div|add|sub)$/ )
{
}
# patch for Syntax::Operator::In, git #162
elsif ( $tok eq 'in' && $next_nonblank_token eq ':' ) {
}
# Fix part 1 for git #63 in which a comment falls
# between an -> and the following word. An
# alternate fix would be to change operator_expected
# to return an UNKNOWN for this type.
elsif ( $last_nonblank_type eq '->' ) {
}
# don't complain about possible indirect object
# notation.
# For example:
# package main;
# sub new($) { ... }
# $b = new A::; # calls A::new
# $c = new A; # same thing but suspicious
# This will call A::new but we have a 'new' in
# main:: which looks like a constant.
#
elsif ( $last_nonblank_type eq 'C' ) {
if ( $tok !~ /::$/ ) {
$self->complain(<error_if_expecting_OPERATOR("bareword");
}
}
# mark bare words immediately followed by a paren as
# functions
$next_tok = $rtokens->[ $i + 1 ];
if ( $next_tok eq '(' ) {
# Patch for issue c151, where we are processing a snippet and
# have not seen that SPACE is a constant. In this case 'x' is
# probably an operator. The only disadvantage with an incorrect
# guess is that the space after it may be incorrect. For example
# $str .= SPACE x ( 16 - length($str) ); See also b1410.
if ( $tok eq 'x' && $last_nonblank_type eq 'w' ) { $type = 'x' }
# Fix part 2 for git #63. Leave type as 'w' to keep
# the type the same as if the -> were not separated
elsif ( $last_nonblank_type ne '->' ) { $type = 'U' }
# not a special case
else { }
}
# underscore after file test operator is file handle
if ( $tok eq '_' && $last_nonblank_type eq 'F' ) {
$type = 'Z';
}
# patch for SWITCH/CASE if 'case' and 'when are
# not treated as keywords:
if (
( $tok eq 'case' && $rbrace_type->[$brace_depth] eq 'switch' )
|| ( $tok eq 'when'
&& $rbrace_type->[$brace_depth] eq 'given' )
)
{
$statement_type = $tok; # next '{' is block
$type = 'k'; # for keyword syntax coloring
}
if ( $next_nonblank_token eq '(' ) {
# patch for SWITCH/CASE if switch and given not keywords
# Switch is not a perl 5 keyword, but we will gamble
# and mark switch followed by paren as a keyword. This
# is only necessary to get html syntax coloring nice,
# and does not commit this as being a switch/case.
if ( $tok eq 'switch' || $tok eq 'given' ) {
$type = 'k'; # for keyword syntax coloring
}
# mark 'x' as operator for something like this (see b1410)
# my $line = join( LD_X, map { LD_H x ( $_ + 2 ) } @$widths );
elsif ( $tok eq 'x' && $last_nonblank_type eq 'w' ) {
$type = 'x';
}
else {
## not a special case
}
}
}
return;
} ## end sub do_UNKNOWN_BAREWORD
sub sub_attribute_ok_here {
my ( $self, $tok_kw, $next_nonblank_token, $i_next ) = @_;
# Decide if a ':' can introduce an attribute. For example,
# something like 'sub :'
# Given:
# $tok_kw = a bareword token
# $next_nonblank_token = a following ':' being examined
# $i_next = the index of the following ':'
# We will decide based on if the colon is followed by a bareword
# which is not a keyword. Changed inext+1 to inext to fixed case
# b1190.
my $sub_attribute_ok_here;
if ( $is_sub{$tok_kw}
&& $expecting != OPERATOR
&& $next_nonblank_token eq ':' )
{
my ( $nn_nonblank_token, $i_nn_uu ) =
$self->find_next_nonblank_token( $i_next, $rtokens,
$max_token_index );
$sub_attribute_ok_here =
$nn_nonblank_token =~ /^\w/
&& $nn_nonblank_token !~ /^\d/
&& !$is_keyword{$nn_nonblank_token};
}
return $sub_attribute_ok_here;
} ## end sub sub_attribute_ok_here
use constant DEBUG_BAREWORD => 0;
sub saw_bareword_function {
my ( $self, $bareword ) = @_;
$self->[_rbareword_info_]->{$current_package}->{$bareword}
->{function_count}++;
return;
} ## end sub saw_bareword_function
sub saw_bareword_constant {
my ( $self, $bareword ) = @_;
$self->[_rbareword_info_]->{$current_package}->{$bareword}
->{constant_count}++;
return;
} ## end sub saw_bareword_constant
sub get_bareword_counts {
my ( $self, $bareword ) = @_;
# Given:
# $bareword = a bareword
# Return:
# $function_count = number of times seen as function taking >0 args
# $constant_count = number of times seen as function taking 0 args
# Note:
# $function_count > 0 implies that a TERM should come next
# $constant_count > 0 implies that an OPERATOR **may** come next,
# but this can be incorrect if $bareword can take 0 or more args.
# This is used to help guess tokenization around unknown barewords.
my $function_count;
my $constant_count;
my $rbareword_info_tok = $self->[_rbareword_info_]->{$current_package};
if ($rbareword_info_tok) {
$rbareword_info_tok = $rbareword_info_tok->{$bareword};
if ($rbareword_info_tok) {
$function_count = $rbareword_info_tok->{function_count};
$constant_count = $rbareword_info_tok->{constant_count};
# a positive function count overrides a constant count
if ($function_count) { $constant_count = 0 }
}
}
if ( !defined($function_count) ) { $function_count = 0 }
if ( !defined($constant_count) ) { $constant_count = 0 }
return ( $function_count, $constant_count );
} ## end sub get_bareword_counts
# hashes used to help determine a bareword type
my %is_wiUC;
my %is_function_follower;
my %is_constant_follower;
my %is_use_require_no;
BEGIN {
my @qz = qw( w i U C );
@is_wiUC{@qz} = (1) x scalar(@qz);
@qz = qw( use require no );
@is_use_require_no{@qz} = (1) x scalar(@qz);
# These pre-token types after a bareword imply that it
# is not a constant, except when '(' is followed by ')'.
@qz = qw# ( [ { $ @ " ' m #;
@is_function_follower{@qz} = (1) x scalar(@qz);
# These pre-token types after a bareword imply that it
# MIGHT be a constant, but it also might be a function taking
# 0 or more call args.
@qz = qw# ; ) ] } if unless #;
push @qz, ',';
@is_constant_follower{@qz} = (1) x scalar(@qz);
}
sub do_BAREWORD {
my ($self) = @_;
# handle a bareword token:
# returns
# true if this token ends the current line
# false otherwise
my $next_nonblank_token;
my $i_next = $i + 1;
if ( $i_next <= $max_token_index && $rtoken_type->[$i_next] eq 'b' ) {
$i_next++;
}
if ( $i_next <= $max_token_index ) {
$next_nonblank_token = $rtokens->[$i_next];
}
else {
( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
}
# a bare word immediately followed by :: is not a keyword;
# use $tok_kw when testing for keywords to avoid a mistake
my $tok_kw = $tok;
if ( $rtokens->[ $i + 1 ] eq ':'
&& $rtokens->[ $i + 2 ] eq ':' )
{
$tok_kw .= '::';
}
if ( $self->[_in_attribute_list_] ) {
my $is_attribute = $self->do_ATTRIBUTE_LIST($next_nonblank_token);
return if ($is_attribute);
}
#----------------------------------------
# Starting final if-elsif- chain of tests
#----------------------------------------
# This is the return flag:
# true => this is the last token on the line
# false => keep tokenizing the line
my $is_last;
# The following blocks of code must update these vars:
# $type - the final token type, must always be set
# In addition, if additional pretokens are added:
# $tok - the final token
# $i - the index of the last pretoken
# They may also need to check and set various flags
# Scan a bare word following a -> as an identifier; it could
# have a long package name. Fixes c037, c041.
if ( $last_nonblank_token eq '->' ) {
$self->scan_bare_identifier();
# a bareward after '->' gets type 'i'
$type = 'i';
}
# Quote a word followed by => operator
elsif (
( $next_nonblank_token eq '=' && $rtokens->[ $i_next + 1 ] eq '>' )
# unless the word is __END__ or __DATA__ and is the only word on
# the line.
&& ( !defined( $is_END_DATA{$tok_kw} )
|| $input_line !~ /^\s*__(?:END|DATA)__\s*$/ )
)
{
# Bareword followed by a fat comma - see 'git18.in'
# This code was previously sub do_QUOTED_BAREWORD: see c316, c317
# Older perl:
# 'v25=>1' is a v-string key!
# '-v25=>1' is also a v-string key!
# Deactivated: this is no longer true; see git #165
if ( 0 && $tok =~ /^v\d+$/ ) {
$type = 'v';
$self->complain("v-string used as hash key\n");
$self->report_v_string($tok);
}
# If tok is something like 'x17' then it could
# actually be operator x followed by number 17.
# For example, here:
# 123x17 => [ 792, 1224 ],
# (a key of 123 repeated 17 times, perhaps not
# what was intended). We will mark x17 as type
# 'n' and it will be split. If the previous token
# was also a bareword then it is not very clear is
# going on. In this case we will not be sure that
# an operator is expected, so we just mark it as a
# bareword. Perl is a little murky in what it does
# with stuff like this, and its behavior can change
# over time. Something like
# a x18 => [792, 1224], will compile as
# a key with 18 a's. But something like
# push @array, a x18;
# is a syntax error.
elsif (
$expecting == OPERATOR
&& substr( $tok, 0, 1 ) eq 'x'
&& ( length($tok) == 1
|| substr( $tok, 1, 1 ) =~ /^\d/ )
)
{
$type = 'n';
if ( $self->split_pretoken(1) ) {
$type = 'x';
$tok = 'x';
}
$self->complain("x operator in hash key\n");
}
else {
# git #18
$type = 'w';
$self->error_if_expecting_OPERATOR();
}
}
# quote a bare word within braces..like xxx->{s}; note that we
# must be sure this is not a structural brace, to avoid
# mistaking {s} in the following for a quoted bare word:
# for(@[){s}bla}BLA}
# Also treat q in something like var{-q} as a bare word, not
# a quote operator
elsif (
$next_nonblank_token eq '}'
&& (
$last_nonblank_type eq 'L'
|| ( $last_nonblank_type eq 'm'
&& $last_last_nonblank_type eq 'L' )
)
)
{
$type = 'w';
}
# handle operator x (now we know it isn't $x=)
elsif (
$expecting == OPERATOR
&& substr( $tok, 0, 1 ) eq 'x'
&& ( length($tok) == 1
|| substr( $tok, 1, 1 ) =~ /^\d/ )
)
{
$self->do_X_OPERATOR();
}
elsif ( $tok_kw eq 'CORE::' ) {
$type = $tok = $tok_kw;
$i += 2;
}
elsif ( ( $tok eq 'strict' )
and ( $last_nonblank_token eq 'use' ) )
{
$self->[_saw_use_strict_] = 1;
$self->scan_bare_identifier();
}
elsif ( ( $tok eq 'warnings' )
and ( $last_nonblank_token eq 'use' ) )
{
$self->[_saw_perl_dash_w_] = 1;
# scan as identifier, so that we pick up something like:
# use warnings::register
$self->scan_bare_identifier();
}
elsif (
$tok eq 'AutoLoader'
&& $self->[_look_for_autoloader_]
&& (
$last_nonblank_token eq 'use'
# these regexes are from AutoSplit.pm, which we want
# to mimic
|| $input_line =~ /^\s*(use|require)\s+AutoLoader\b/
|| $input_line =~ /\bISA\s*=.*\bAutoLoader\b/
)
)
{
$self->write_logfile_entry("AutoLoader seen, -nlal deactivates\n");
$self->[_saw_autoloader_] = 1;
$self->[_look_for_autoloader_] = 0;
$self->scan_bare_identifier();
}
elsif (
$tok eq 'SelfLoader'
&& $self->[_look_for_selfloader_]
&& ( $last_nonblank_token eq 'use'
|| $input_line =~ /^\s*(use|require)\s+SelfLoader\b/
|| $input_line =~ /\bISA\s*=.*\bSelfLoader\b/ )
)
{
$self->write_logfile_entry("SelfLoader seen, -nlsl deactivates\n");
$self->[_saw_selfloader_] = 1;
$self->[_look_for_selfloader_] = 0;
$self->scan_bare_identifier();
}
elsif ( ( $tok eq 'constant' )
and ( $last_nonblank_token eq 'use' ) )
{
$self->do_USE_CONSTANT();
}
# various quote operators
elsif ( $is_q_qq_qw_qx_qr_s_y_tr_m{$tok} ) {
$self->do_QUOTE_OPERATOR();
}
# check for a statement label
elsif (
( $next_nonblank_token eq ':' )
&& ( $rtokens->[ $i_next + 1 ] ne ':' )
&& ( $i_next <= $max_token_index ) # colon on same line
# like 'sub : lvalue' ?
&& !$self->sub_attribute_ok_here( $tok_kw, $next_nonblank_token,
$i_next )
&& new_statement_ok()
)
{
if ( $tok !~ /[A-Z]/ ) {
push @{ $self->[_rlower_case_labels_at_] }, $input_line_number;
}
$type = 'J';
$tok .= ':';
$i = $i_next;
}
# 'sub' or other sub alias
elsif ( $is_sub{$tok_kw} ) {
# Update for --use-feature=class (rt145706):
# We have to be extra careful to avoid misparsing other uses of
# 'method' in older scripts.
if ( $tok_kw eq 'method' && $guess_if_method ) {
if ( $expecting == OPERATOR
|| $next_nonblank_token !~ /^[\w\:]/
|| !$self->method_ok_here() )
{
$self->do_UNKNOWN_BAREWORD($next_nonblank_token);
}
else {
initialize_subname();
$self->scan_id();
}
}
else {
$self->error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
initialize_subname();
$self->scan_id();
}
}
# 'package'
elsif ( $is_package{$tok_kw} ) {
# Update for --use-feature=class (rt145706):
# We have to be extra careful because 'class' may be used for other
# purposes on older code; i.e.
# class($x) - valid sub call
# package($x) - error
if ( $tok_kw eq 'class' ) {
if ( $expecting == OPERATOR
|| $next_nonblank_token !~ /^[\w\:]/
|| !$self->class_ok_here() )
{
$self->do_UNKNOWN_BAREWORD($next_nonblank_token);
}
else { $self->scan_id() }
}
else {
$self->error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
$self->scan_id();
}
}
# Fix for c035: split 'format' from 'is_format_END_DATA' to be
# more restrictive. Require a new statement to be ok here.
elsif ( $tok_kw eq 'format' && new_statement_ok() ) {
$type = ';'; # make tokenizer look for TERM next
$self->[_in_format_] = 1;
$is_last = 1; ## is last token on this line
}
# Note on token types for format, __DATA__, __END__:
# It simplifies things to give these type ';', so that when we
# start rescanning we will be expecting a token of type TERM.
# We will switch to type 'k' before outputting the tokens.
elsif ( defined( $is_END_DATA{$tok_kw} ) ) {
$type = ';'; # make tokenizer look for TERM next
# Remember that we are in one of these three sections
$self->[ $is_END_DATA{$tok_kw} ] = 1;
$is_last = 1; ## is last token on this line
}
elsif ( $is_keyword{$tok_kw} ) {
$self->do_KEYWORD();
}
# check for inline label following
# /^(redo|last|next|goto)$/
elsif (( $last_nonblank_type eq 'k' )
&& ( $is_redo_last_next_goto{$last_nonblank_token} ) )
{
$type = 'j';
}
# something else --
else {
$self->do_UNKNOWN_BAREWORD($next_nonblank_token);
}
#----------------------------------------------------------------
# Save info for use in later guessing. Even for types 'i' and 'U'
# because those may be marked as type 'w' (barewords) elsewhere.
#----------------------------------------------------------------
if ( $is_wiUC{$type}
&& $statement_type ne 'use'
&& $statement_type ne '_use' )
{
my $result = "unknown";
# Words are marked 'function' if they appear in a role which
# is not consistent with a constant value. Typically they are
# function calls.
if ( $type eq 'U'
|| $is_function_follower{$next_nonblank_token} )
{
my $empty_parens = 0;
if ( $next_nonblank_token eq '(' && $i_next < $max_token_index )
{
my $tok_next_p1 = $rtokens->[ $i_next + 1 ];
if ( substr( $tok_next_p1, 0, 1 ) eq SPACE
&& $i_next + 2 <= $max_token_index )
{
$tok_next_p1 = $rtokens->[ $i_next + 2 ];
}
$empty_parens = $tok_next_p1 eq ')';
}
if ( !$empty_parens ) {
# not a constant term - probably a function
$result = "function";
$self->saw_bareword_function($tok);
}
}
# Words are marked 'constant' if they appear in a role
# consistent with a constant value. However, they may simply
# be functions which optionally take zero args. So if a word
# appears as both constant and function, it is not a constant.
elsif ($type eq 'C'
|| $is_constant_follower{$next_nonblank_token} )
{
my $is_hash_key = $next_nonblank_token eq '}'
&& (
$last_nonblank_type eq 'L'
|| ( $last_nonblank_type eq 'm'
&& $last_last_nonblank_type eq 'L' )
);
if (
# not a hash key like {bareword} or {-bareword}
!$is_hash_key
# not a package name, etc
&& ( $last_nonblank_type ne 'k'
|| !$is_use_require_no{$last_nonblank_token} )
# skip arrow calls, which can go either way
&& $last_nonblank_token ne '->'
)
{
# possibly a constant or constant function
$result = "constant";
$self->saw_bareword_constant($tok);
}
else {
$result = "other bareword";
}
}
else {
}
if ( DEBUG_BAREWORD && $result ne 'other bareword' ) {
print
"$input_line_number: $result: $tok: type=$type : last_tok=$last_nonblank_token : next_tok='$next_nonblank_token'\n";
}
}
return $is_last;
} ## end sub do_BAREWORD
sub do_FOLLOW_QUOTE {
my $self = shift;
# Continue following a quote on a new line
$type = $quote_type;
if ( !@{$routput_token_list} ) { # initialize if continuation line
push( @{$routput_token_list}, $i );
$routput_token_type->[$i] = $type;
}
# scan for the end of the quote or pattern
(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string_1,
$quoted_string_2,
) = $self->do_quote(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string_1,
$quoted_string_2,
$rtokens,
$rtoken_type,
$rtoken_map,
$max_token_index,
);
# all done if we didn't find it
if ($in_quote) { return }
# save pattern and replacement text for rescanning
my $qs1 = $quoted_string_1;
# re-initialize for next search
$quote_character = EMPTY_STRING;
$quote_pos = 0;
$quote_type = 'Q';
$quoted_string_1 = EMPTY_STRING;
$quoted_string_2 = EMPTY_STRING;
if ( ++$i > $max_token_index ) { return }
# look for any modifiers
if ($allowed_quote_modifiers) {
# check for exact quote modifiers
if ( $rtokens->[$i] =~ /^[A-Za-z_]/ ) {
my $str = $rtokens->[$i];
my $saw_modifier_e;
while ( $str =~ /\G$allowed_quote_modifiers/gc ) {
my $pos = pos($str);
my $char = substr( $str, $pos - 1, 1 );
$saw_modifier_e ||= ( $char eq 'e' );
}
# For an 'e' quote modifier we must scan the replacement
# text for here-doc targets...
# but if the modifier starts a new line we can skip
# this because either the here doc will be fully
# contained in the replacement text (so we can
# ignore it) or Perl will not find it.
# See test 'here2.in'.
if ( $saw_modifier_e && $i_tok >= 0 ) {
my $rht = $self->scan_replacement_text($qs1);
# Change type from 'Q' to 'h' for quotes with
# here-doc targets so that the formatter (see sub
# process_line_of_CODE) will not make any line
# breaks after this point.
if ($rht) {
push @{$rhere_target_list}, @{$rht};
$type = 'h';
if ( $i_tok < 0 ) {
my $ilast = $routput_token_list->[-1];
$routput_token_type->[$ilast] = $type;
}
}
}
if ( defined( pos($str) ) ) {
# matched
if ( pos($str) == length($str) ) {
if ( ++$i > $max_token_index ) { return }
}
# Looks like a joined quote modifier
# and keyword, maybe something like
# s/xxx/yyy/gefor @k=...
# Example is "galgen.pl". Would have to split
# the word and insert a new token in the
# pre-token list. This is so rare that I haven't
# done it. Will just issue a warning citation.
# This error might also be triggered if my quote
# modifier characters are incomplete
else {
$self->warning(<[$i]\n";
# my $num = length($str) - pos($str);
# $rtokens->[$i]=substr($rtokens->[$i],pos($str),$num);
# print "continuing with new token $rtokens->[$i]\n";
# skipping past this token does least damage
if ( ++$i > $max_token_index ) { return }
}
}
else {
# example file: rokicki4.pl
# This error might also be triggered if my quote
# modifier characters are incomplete
$self->write_logfile_entry(
"Note: found word $str at quote modifier location\n");
}
}
# re-initialize
$allowed_quote_modifiers = EMPTY_STRING;
}
return;
} ## end sub do_FOLLOW_QUOTE
# ------------------------------------------------------------
# begin hash of code for handling most token types
# ------------------------------------------------------------
my $tokenization_code = {
'>' => \&do_GREATER_THAN_SIGN,
'|' => \&do_VERTICAL_LINE,
'$' => \&do_DOLLAR_SIGN,
'(' => \&do_LEFT_PARENTHESIS,
')' => \&do_RIGHT_PARENTHESIS,
',' => \&do_COMMA,
';' => \&do_SEMICOLON,
'"' => \&do_QUOTATION_MARK,
"'" => \&do_APOSTROPHE,
'`' => \&do_BACKTICK,
'/' => \&do_SLASH,
'{' => \&do_LEFT_CURLY_BRACKET,
'}' => \&do_RIGHT_CURLY_BRACKET,
'&' => \&do_AMPERSAND,
'<' => \&do_LESS_THAN_SIGN,
'?' => \&do_QUESTION_MARK,
'*' => \&do_STAR,
'.' => \&do_DOT,
':' => \&do_COLON,
'+' => \&do_PLUS_SIGN,
'@' => \&do_AT_SIGN,
'%' => \&do_PERCENT_SIGN,
'[' => \&do_LEFT_SQUARE_BRACKET,
']' => \&do_RIGHT_SQUARE_BRACKET,
'-' => \&do_MINUS_SIGN,
'^' => \&do_CARAT_SIGN,
'::' => \&do_DOUBLE_COLON,
'<<' => \&do_LEFT_SHIFT,
'<<~' => \&do_NEW_HERE_DOC,
'->' => \&do_POINTER,
'++' => \&do_PLUS_PLUS,
'=>' => \&do_FAT_COMMA,
'--' => \&do_MINUS_MINUS,
'&&' => \&do_LOGICAL_AND,
'||' => \&do_LOGICAL_OR,
'//' => \&do_SLASH_SLASH,
# No special code for these types yet, but syntax checks
# could be added.
## '!' => undef,
## '!=' => undef,
## '!~' => undef,
## '%=' => undef,
## '&&=' => undef,
## '&=' => undef,
## '+=' => undef,
## '-=' => undef,
## '..' => undef,
## '..' => undef,
## '...' => undef,
## '.=' => undef,
## '<<=' => undef,
## '<=' => undef,
## '<=>' => undef,
## '<>' => undef,
## '=' => undef,
## '==' => undef,
## '=~' => undef,
## '>=' => undef,
## '>>' => undef,
## '>>=' => undef,
## '\\' => undef,
## '^=' => undef,
## '|=' => undef,
## '||=' => undef,
## '//=' => undef,
## '~' => undef,
## '~~' => undef,
## '!~~' => undef,
};
# ------------------------------------------------------------
# end hash of code for handling individual token types
# ------------------------------------------------------------
use constant DEBUG_TOKENIZE => 0;
my %is_arrow_or_Z;
BEGIN {
my @qZ = qw( -> Z );
@is_arrow_or_Z{@qZ} = (1) x scalar(@qZ);
}
sub tokenize_this_line {
my ( $self, $line_of_tokens, $trimmed_input_line ) = @_;
# This routine tokenizes one line. The results are stored in
# the hash ref '$line_of_tokens'.
# Given:
# $line_of_tokens = ref to hash of values being filled for this line
# $trimmed_input_line
# = the input line without leading whitespace, OR
# = undef if not available
# Returns:
# nothing
my $untrimmed_input_line = $line_of_tokens->{_line_text};
# Extract line number for use in error messages
$input_line_number = $line_of_tokens->{_line_number};
#-------------------------------------
# Check for start of pod documentation
#-------------------------------------
if ( substr( $untrimmed_input_line, 0, 1 ) eq '='
&& $untrimmed_input_line =~ /^=[A-Za-z_]/ )
{
# Must not be in multi-line quote
# and must not be in an equation
my $blank_after_Z = 1;
if (
!$in_quote
&& ( $self->operator_expected( '=', 'b', $blank_after_Z ) ==
TERM )
)
{
$self->[_in_pod_] = 1;
return;
}
}
#--------------------------
# Trim leading whitespace ?
#--------------------------
# Use untrimmed line if we are continuing in a type 'Q' quote
if ( $in_quote && $quote_type eq 'Q' ) {
$line_of_tokens->{_starting_in_quote} = 1;
$input_line = $untrimmed_input_line;
chomp $input_line;
}
# Trim start of this line if we are not continuing a quoted line.
# Do not trim end because we might end in a quote (test: deken4.pl)
# Perl::Tidy::Formatter will delete needless trailing blanks
else {
$line_of_tokens->{_starting_in_quote} = 0;
# Use the pre-computed trimmed line if defined (most efficient)
$input_line = $trimmed_input_line;
# otherwise trim the raw input line (much less efficient)
if ( !defined($input_line) ) {
$input_line = $untrimmed_input_line;
$input_line =~ s/^\s+//;
}
chomp $input_line;
# define 'guessed_indentation_level' if logfile will be saved
if ( $self->[_save_logfile_] && length($input_line) ) {
my $guess =
$self->guess_old_indentation_level($untrimmed_input_line);
$line_of_tokens->{_guessed_indentation_level} = $guess;
}
}
#------------
# Blank lines
#------------
if ( !length($input_line) ) {
$line_of_tokens->{_line_type} = 'CODE';
$line_of_tokens->{_rtokens} = [];
$line_of_tokens->{_rtoken_type} = [];
$line_of_tokens->{_rlevels} = [];
$line_of_tokens->{_rblock_type} = [];
$line_of_tokens->{_nesting_tokens_0} = $nesting_token_string;
$line_of_tokens->{_nesting_blocks_0} = $nesting_block_string;
return;
}
#---------
# Comments
#---------
if ( !$in_quote && substr( $input_line, 0, 1 ) eq '#' ) {
# and check for skipped section
if (
(
substr( $input_line, 0, 4 ) eq '#<[_in_code_skipping_] = $self->[_last_line_number_];
return;
}
if ( !$self->[_in_format_skipping_] ) {
if (
(
substr( $input_line, 0, 4 ) eq '#<<<'
|| $rOpts_format_skipping_begin
)
&& $rOpts_format_skipping
# note that the code_skipping_patterns require a newline
&& $input_line . "\n" =~ /$format_skipping_pattern_begin/
)
{
$self->[_in_format_skipping_] = $self->[_last_line_number_];
}
}
else {
if (
(
substr( $input_line, 0, 4 ) eq '#>>>'
|| $rOpts_format_skipping_end
)
# note that the code_skipping_patterns require a newline
&& $input_line . "\n" =~ /$format_skipping_pattern_end/
)
{
$self->[_in_format_skipping_] = 0;
}
}
# Optional fast processing of a block comment
$line_of_tokens->{_line_type} = 'CODE';
$line_of_tokens->{_rtokens} = [$input_line];
$line_of_tokens->{_rtoken_type} = ['#'];
$line_of_tokens->{_rlevels} = [$level_in_tokenizer];
$line_of_tokens->{_rblock_type} = [EMPTY_STRING];
$line_of_tokens->{_nesting_tokens_0} = $nesting_token_string;
$line_of_tokens->{_nesting_blocks_0} = $nesting_block_string;
return;
}
#-------------------------------------
# Loop to find all tokens on this line
#-------------------------------------
# Update the copy of the line for use in error messages
# This must be exactly what we give the pre_tokenizer
$self->[_line_of_text_] = $input_line;
# re-initialize for the main loop
$routput_token_list = []; # stack of output token indexes
$routput_token_type = []; # token types
$routput_block_type = []; # types of code block
$routput_type_sequence = []; # nesting sequential number
$rhere_target_list = [];
$tok = $last_nonblank_token;
$type = $last_nonblank_type;
$prototype = $last_nonblank_prototype;
$last_nonblank_i = -1;
$block_type = $last_nonblank_block_type;
$container_type = $last_nonblank_container_type;
$type_sequence = $last_nonblank_type_sequence;
$indent_flag = 0;
$peeked_ahead = 0;
$self->tokenizer_main_loop();
#-------------------------------------------------
# Done tokenizing this line ... package the result
#-------------------------------------------------
$self->tokenizer_wrapup_line($line_of_tokens);
return;
} ## end sub tokenize_this_line
sub tokenizer_main_loop {
my ($self) = @_;
# Break one input line into tokens
# We are working on closure variables.
# Start by breaking the line into pre-tokens
( $rtokens, $rtoken_map, $rtoken_type ) = pre_tokenize($input_line);
# Verify that all leading whitespace has been trimmed
# except for quotes of type 'Q' (c273).
if ( @{$rtokens}
&& $rtoken_type->[0] eq 'b'
&& !( $in_quote && $quote_type eq 'Q' ) )
{
# Shouldn't happen if calling sub did trim operation correctly.
DEVEL_MODE && $self->Fault(<[$ii] = EMPTY_STRING;
$routput_block_type->[$ii] = EMPTY_STRING;
$routput_type_sequence->[$ii] = EMPTY_STRING;
$routput_indent_flag->[$ii] = 0;
}
}
$i = -1;
$i_tok = -1;
#-----------------------
# main tokenization loop
#-----------------------
# we are looking at each pre-token of one line and combining them
# into tokens
while ( ++$i <= $max_token_index ) {
# continue looking for the end of a quote
if ($in_quote) {
$self->do_FOLLOW_QUOTE();
last if ( $in_quote || $i > $max_token_index );
}
if ( $type ne 'b' && $type ne 'CORE::' ) {
# try to catch some common errors
if ( ( $type eq 'n' ) && ( $tok ne '0' ) ) {
if ( $last_nonblank_token eq 'eq' ) {
$self->complain("Should 'eq' be '==' here ?\n");
}
elsif ( $last_nonblank_token eq 'ne' ) {
$self->complain("Should 'ne' be '!=' here ?\n");
}
else {
# that's all
}
}
# fix c090, only rotate vars if a new token will be stored
if ( $i_tok >= 0 ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_nonblank_prototype = $prototype;
$last_nonblank_block_type = $block_type;
$last_nonblank_container_type = $container_type;
$last_nonblank_type_sequence = $type_sequence;
$last_nonblank_i = $i_tok;
$last_nonblank_token = $tok;
$last_nonblank_type = $type;
}
# Check for patches
if ( $is_arrow_or_Z{$last_last_nonblank_type} ) {
# Patch for c030: Fix things in case a '->' got separated
# from the subsequent identifier by a side comment. We
# need the last_nonblank_token to have a leading -> to
# avoid triggering an operator expected error message at
# the next '('. See also fix for git #63.
if ( $last_last_nonblank_type eq '->' ) {
if ( $last_nonblank_type eq 'w'
|| $last_nonblank_type eq 'i' )
{
$last_nonblank_token = '->' . $last_nonblank_token;
$last_nonblank_type = 'i';
}
}
# Fix part #3 for git82: propagate type 'Z' though L-R pair
elsif ( $last_last_nonblank_type eq 'Z' ) {
if ( $last_nonblank_type eq 'R' ) {
$last_nonblank_type = $last_last_nonblank_type;
$last_nonblank_token = $last_last_nonblank_token;
}
}
else {
# No other patches
}
}
}
# store previous token type
if ( $i_tok >= 0 ) {
$routput_token_type->[$i_tok] = $type;
$routput_block_type->[$i_tok] = $block_type;
$routput_type_sequence->[$i_tok] = $type_sequence;
$routput_indent_flag->[$i_tok] = $indent_flag;
}
# get the next pre-token and type
# $tok and $type will be modified to make the output token
my $pre_tok = $tok = $rtokens->[$i]; # get the next pre-token
my $pre_type = $type = $rtoken_type->[$i]; # and type
# re-initialize various flags for the next output token
(
# remember the starting index of this token; we will update $i
$i_tok,
$block_type,
$container_type,
$type_sequence,
$indent_flag,
$prototype,
)
= (
$i,
EMPTY_STRING,
EMPTY_STRING,
EMPTY_STRING,
0,
EMPTY_STRING,
);
# this pre-token will start an output token
push( @{$routput_token_list}, $i_tok );
#---------------------------------------------------
# The token search leads to one of 5 main END NODES:
#---------------------------------------------------
#-----------------------
# END NODE 1: whitespace
#-----------------------
next if ( $pre_type eq 'b' );
#----------------------
# END NODE 2: a comment
#----------------------
if ( $pre_type eq '#' ) {
# push non-indenting brace stack Look for a possible
# non-indenting brace. This is only used to give a hint in
# case the file is unbalanced.
# Hardwired to '#<<<' for efficiency. We will not use the
# result later if the pattern has been changed (very unusual).
if ( $last_nonblank_token eq '{'
&& $last_nonblank_block_type
&& $last_nonblank_type_sequence
&& !$self->[_in_format_skipping_]
&& $rOpts_non_indenting_braces )
{
my $offset = $rtoken_map->[$i_tok];
my $text = substr( $input_line, $offset, 5 );
my $len = length($text);
if ( $len == 4 && $text eq '#<<<'
|| $len > 4 && $text eq '#<<< ' )
{
push @{ $self->[_rnon_indenting_brace_stack_] },
$last_nonblank_type_sequence;
}
}
last;
}
# continue gathering identifier if necessary
if ($id_scan_state) {
if ( $is_sub{$id_scan_state} || $is_package{$id_scan_state} ) {
$self->scan_id();
}
else {
$self->scan_identifier();
}
if ($id_scan_state) {
# Still scanning ...
# Check for side comment between sub and prototype (c061)
# done if nothing left to scan on this line
last if ( $i > $max_token_index );
my ( $next_nonblank_token_uu, $i_next ) =
find_next_nonblank_token_on_this_line( $i, $rtokens,
$max_token_index );
# done if it was just some trailing space
last if ( $i_next > $max_token_index );
# something remains on the line ... must be a side comment
next;
}
next if ( ( $i > 0 ) || $type );
# didn't find any token; start over
$type = $pre_type;
$tok = $pre_tok;
}
#-----------------------------------------------------------
# Combine pre-tokens into digraphs and trigraphs if possible
#-----------------------------------------------------------
# See if we can make a digraph...
# The following tokens are excluded and handled specially:
# '/=' is excluded because the / might start a pattern.
# 'x=' is excluded since it might be $x=, with $ on previous line
# '**' and *= might be typeglobs of punctuation variables
# I have allowed tokens starting with <, such as <=,
# because I don't think these could be valid angle operators.
# test file: storrs4.pl
if ( $can_start_digraph{$tok}
&& $i < $max_token_index
&& $is_digraph{ $tok . $rtokens->[ $i + 1 ] } )
{
my $combine_ok = 1;
my $test_tok = $tok . $rtokens->[ $i + 1 ];
# check for special cases which cannot be combined
# '//' must be defined_or operator if an operator is expected.
# TODO: Code for other ambiguous digraphs (/=, x=, **, *=)
# could be migrated here for clarity
# Patch for RT#102371, misparsing a // in the following snippet:
# state $b //= ccc();
# The solution is to always accept the digraph (or trigraph)
# after type 'Z' (possible file handle). The reason is that
# sub operator_expected gives TERM expected here, which is
# wrong in this case.
if ( $test_tok eq '//' && $last_nonblank_type ne 'Z' ) {
# note that here $tok = '/' and the next tok and type is '/'
my $blank_after_Z;
$expecting =
$self->operator_expected( $tok, '/', $blank_after_Z );
# Patched for RT#101547, was 'unless ($expecting==OPERATOR)'
$combine_ok = 0 if ( $expecting == TERM );
}
# Patch for RT #114359: mis-parsing of "print $x ** 0.5;
# Accept the digraphs '**' only after type 'Z'
# Otherwise postpone the decision.
if ( $test_tok eq '**' ) {
if ( $last_nonblank_type ne 'Z' ) { $combine_ok = 0 }
}
if (
# still ok to combine?
$combine_ok
&& ( $test_tok ne '/=' ) # might be pattern
&& ( $test_tok ne 'x=' ) # might be $x
&& ( $test_tok ne '*=' ) # typeglob?
# Moved above as part of fix for
# RT #114359: Missparsing of "print $x ** 0.5;
# && ( $test_tok ne '**' ) # typeglob?
)
{
$tok = $test_tok;
$i++;
# Now try to assemble trigraphs. Note that all possible
# perl trigraphs can be constructed by appending a character
# to a digraph.
$test_tok = $tok . $rtokens->[ $i + 1 ];
if ( $is_trigraph{$test_tok} ) {
$tok = $test_tok;
$i++;
}
# The only current tetragraph is the double diamond operator
# and its first three characters are NOT a trigraph, so
# we do can do a special test for it
else {
if ( $test_tok eq '<<>' ) {
$test_tok .= $rtokens->[ $i + 2 ];
if ( $is_tetragraph{$test_tok} ) {
$tok = $test_tok;
$i += 2;
}
}
}
}
}
$type = $tok;
$next_tok = $rtokens->[ $i + 1 ];
$next_type = $rtoken_type->[ $i + 1 ];
# expecting an operator here? first try table lookup, then function
$expecting = $op_expected_table{$last_nonblank_type};
if ( !defined($expecting) ) {
my $blank_after_Z = $last_nonblank_type eq 'Z'
&& ( $i == 0 || $rtoken_type->[ $i - 1 ] eq 'b' );
$expecting =
$self->operator_expected( $tok, $next_type, $blank_after_Z );
}
DEBUG_TOKENIZE && do {
local $LIST_SEPARATOR = ')(';
my @debug_list = (
$last_nonblank_token, $tok,
$next_tok, $brace_depth,
$rbrace_type->[$brace_depth], $paren_depth,
$rparen_type->[$paren_depth],
);
print {*STDOUT} "TOKENIZE:(@debug_list)\n";
};
# The next token is '$tok'.
# Now we have to define its '$type'
#------------------------
# END NODE 3: a bare word
#------------------------
if ( $pre_type eq 'w' ) {
my $is_last = $self->do_BAREWORD();
last if ($is_last);
next;
}
# Turn off attribute list on first non-blank, non-bareword,
# and non-comment (added to fix c038)
$self->[_in_attribute_list_] = 0;
#-------------------------------
# END NODE 4: a string of digits
#-------------------------------
if ( $pre_type eq 'd' ) {
$self->do_DIGITS();
next;
}
#------------------------------------------
# END NODE 5: everything else (punctuation)
#------------------------------------------
my $code = $tokenization_code->{$tok};
if ($code) {
$code->($self);
redo if $in_quote;
}
} ## End main tokenizer loop
# Store the final token
if ( $i_tok >= 0 ) {
$routput_token_type->[$i_tok] = $type;
$routput_block_type->[$i_tok] = $block_type;
$routput_type_sequence->[$i_tok] = $type_sequence;
$routput_indent_flag->[$i_tok] = $indent_flag;
}
# Remember last nonblank values
if ( $type ne 'b' && $type ne '#' ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_nonblank_prototype = $prototype;
$last_nonblank_block_type = $block_type;
$last_nonblank_container_type = $container_type;
$last_nonblank_type_sequence = $type_sequence;
$last_nonblank_token = $tok;
$last_nonblank_type = $type;
}
# reset indentation level if necessary at a sub or package
# in an attempt to recover from a nesting error
if ( $level_in_tokenizer < 0 ) {
if ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ ) {
reset_indentation_level(0);
$self->brace_warning("resetting level to 0 at $1 $2\n");
}
}
$self->[_in_quote_] = $in_quote;
$self->[_quote_target_] =
$in_quote
? $matching_end_token{$quote_character}
? $matching_end_token{$quote_character}
: $quote_character
: EMPTY_STRING;
$self->[_rhere_target_list_] = $rhere_target_list;
return;
} ## end sub tokenizer_main_loop
sub tokenizer_wrapup_line {
my ( $self, $line_of_tokens ) = @_;
#---------------------------------------------------------
# Package a line of tokens for shipping back to the caller
#---------------------------------------------------------
# Arrays to hold token values for this line:
my (
@output_levels, @output_block_type, @output_type_sequence,
@output_token_type, @output_tokens
);
$line_of_tokens->{_nesting_tokens_0} = $nesting_token_string;
# Remember starting nesting block string
my $nesting_block_string_0 = $nesting_block_string;
#-----------------
# Loop over tokens
#-----------------
# $i is the index of the pretoken which starts this full token
foreach my $ii ( @{$routput_token_list} ) {
my $type_i = $routput_token_type->[$ii];
#----------------------------------------
# Section 1. Handle a non-sequenced token
#----------------------------------------
if ( !$routput_type_sequence->[$ii] ) {
#-------------------------------
# Section 1.1. types ';' and 't'
#-------------------------------
# - output anonymous 'sub' as keyword (type 'k')
# - output __END__, __DATA__, and format as type 'k' instead
# of ';' to make html colors correct, etc.
if ( $is_semicolon_or_t{$type_i} ) {
my $tok_i = $rtokens->[$ii];
if ( $is_END_DATA_format_sub{$tok_i} ) {
$type_i = 'k';
}
}
#----------------------------------------------
# Section 1.2. Check for an invalid token type.
#----------------------------------------------
# This can happen by running perltidy on non-scripts although
# it could also be bug introduced by programming change. Perl
# silently accepts a 032 (^Z) and takes it as the end
elsif ( !$is_valid_token_type{$type_i} ) {
my $val = ord($type_i);
$self->warning(
"unexpected character decimal $val ($type_i) in script\n"
);
$self->[_in_error_] = 1;
}
else {
# valid token type other than ; and t
}
#----------------------------------------------------
# Section 1.3. Store values for a non-sequenced token
#----------------------------------------------------
push( @output_levels, $level_in_tokenizer );
push( @output_block_type, EMPTY_STRING );
push( @output_type_sequence, EMPTY_STRING );
push( @output_token_type, $type_i );
}
#------------------------------------
# Section 2. Handle a sequenced token
# One of { [ ( ? : ) ] }
#------------------------------------
else {
# $level_i is the level we will store. Levels of braces are
# set so that the leading braces have a HIGHER level than their
# CONTENTS, which is convenient for indentation.
my $level_i = $level_in_tokenizer;
# $tok_i is the PRE-token. It only equals the token for symbols
my $tok_i = $rtokens->[$ii];
# $routput_indent_flag->[$ii] indicates that we need a change
# in level at a nested ternary, as follows
# 1 => at a nested ternary ?
# -1 => at a nested ternary :
# 0 => otherwise
#--------------------------------------------
# Section 2.1 Handle a level-increasing token
#--------------------------------------------
if ( $is_opening_or_ternary_type{$type_i} ) {
if ( $type_i eq '?' ) {
if ( $routput_indent_flag->[$ii] > 0 ) {
$level_in_tokenizer++;
# break BEFORE '?' in a nested ternary
$level_i = $level_in_tokenizer;
$nesting_block_string .= "$nesting_block_flag";
}
}
else {
$nesting_token_string .= $tok_i;
if ( $type_i eq '{' || $type_i eq 'L' ) {
$level_in_tokenizer++;
if ( $routput_block_type->[$ii] ) {
$nesting_block_flag = 1;
$nesting_block_string .= '1';
}
else {
$nesting_block_flag = 0;
$nesting_block_string .= '0';
}
}
}
}
#---------------------------------------------
# Section 2.2. Handle a level-decreasing token
#---------------------------------------------
elsif ( $is_closing_or_ternary_type{$type_i} ) {
if ( $type_i ne ':' ) {
my $char = chop $nesting_token_string;
if ( $char ne $matching_start_token{$tok_i} ) {
$nesting_token_string .= $char . $tok_i;
}
}
if (
$type_i eq '}'
|| $type_i eq 'R'
# only the second and higher ? : have levels
|| $type_i eq ':' && $routput_indent_flag->[$ii] < 0
)
{
$level_i = --$level_in_tokenizer;
if ( $level_in_tokenizer < 0 ) {
if ( !$self->[_saw_negative_indentation_] ) {
$self->[_saw_negative_indentation_] = 1;
$self->warning(
"Starting negative indentation\n");
}
}
# restore previous level values
if ( length($nesting_block_string) > 1 )
{ # true for valid script
chop $nesting_block_string;
$nesting_block_flag =
substr( $nesting_block_string, -1 ) eq '1';
}
}
}
#-----------------------------------------------------
# Section 2.3. Unexpected sequenced token type - error
#-----------------------------------------------------
else {
# The tokenizer should only be assigning sequence numbers
# to types { [ ( ? ) ] } :
DEVEL_MODE && $self->Fault(<[$ii] );
push( @output_type_sequence, $routput_type_sequence->[$ii] );
push( @output_token_type, $type_i );
}
} ## End loop to over tokens
#---------------------
# Post-loop operations
#---------------------
$line_of_tokens->{_nesting_blocks_0} = $nesting_block_string_0;
# Form and store the tokens
if (@output_levels) {
my $im = shift @{$routput_token_list};
my $offset = $rtoken_map->[$im];
foreach my $ii ( @{$routput_token_list} ) {
my $numc = $rtoken_map->[$ii] - $offset;
push( @output_tokens, substr( $input_line, $offset, $numc ) );
$offset += $numc;
# programming note: it seems most efficient to 'next' out of
# a critical loop like this as early as possible. So instead
# of 'if ( DEVEL_MODE && $numc < 0 )' we write:
next unless DEVEL_MODE;
next if ( $numc > 0 );
# Should not happen unless @{$rtoken_map} is corrupted
$self->Fault(
"number of characters is '$numc' but should be >0\n");
}
# Form and store the final token of this line
my $numc = length($input_line) - $offset;
push( @output_tokens, substr( $input_line, $offset, $numc ) );
if (DEVEL_MODE) {
if ( $numc <= 0 ) {
# check '$rtoken_map' and '$routput_token_list'
$self->Fault(
"Number of Characters is '$numc' but should be >0\n");
}
# Make sure we didn't gain or lose any characters
my $test_line = join EMPTY_STRING, @output_tokens;
if ( $test_line ne $input_line ) {
my $len_input = length($input_line);
my $len_test = length($test_line);
# check '$rtoken_map' and '$routput_token_list'
$self->Fault(<{_rtoken_type} = \@output_token_type;
$line_of_tokens->{_rtokens} = \@output_tokens;
$line_of_tokens->{_rblock_type} = \@output_block_type;
$line_of_tokens->{_rtype_sequence} = \@output_type_sequence;
$line_of_tokens->{_rlevels} = \@output_levels;
#-----------------------------------------------------------------
# Compare input indentation with computed levels at closing braces
#-----------------------------------------------------------------
# This may provide a useful hint for error location if the file
# is not balanced in braces. Closing braces are used because they
# have a well-defined indentation and can be processed efficiently.
if ( $output_tokens[0] eq '}' ) {
my $blk = $output_block_type[0];
if (
(
# builtin block types without continuation indentation
$is_zero_continuation_block_type{$blk}
# or a named sub, but skip sub aliases for efficiency,
# since this is just for diagnostic info
|| substr( $blk, 0, 4 ) eq 'sub '
)
# and we are not in format skipping
&& !$self->[_in_format_skipping_]
)
{
# subtract 1 space for newline in untrimmed line
my $untrimmed_input_line = $line_of_tokens->{_line_text};
my $space_count =
length($untrimmed_input_line) - length($input_line) - 1;
# check for tabs
if ( $space_count
&& ord( substr( $untrimmed_input_line, 0, 1 ) ) == ORD_TAB )
{
if ( $untrimmed_input_line =~ /^(\t+)?(\s+)?/ ) {
if ($1) { $space_count += length($1) * $tabsize }
if ($2) { $space_count += length($2) }
}
}
# '$guess' = the level according to indentation
my $guess = int( $space_count / $rOpts_indent_columns );
# subtract 1 level from guess for --indent-closing-brace
$guess -= 1 if ($rOpts_indent_closing_brace);
# subtract 1 from $level for each non-indenting brace level
my $adjust = @{ $self->[_rnon_indenting_brace_stack_] };
my $level = $output_levels[0];
# find the difference between expected and indentation guess
my $level_diff = $level - $adjust - $guess;
my $rhash = $self->[_rclosing_brace_indentation_hash_];
# results are only valid if we guess correctly at the
# first spaced brace
if ( $space_count && !defined( $rhash->{valid} ) ) {
$rhash->{valid} = !$level_diff;
}
# save the result
my $rhistory_line_number = $rhash->{rhistory_line_number};
my $rhistory_level_diff = $rhash->{rhistory_level_diff};
my $rhistory_anchor_point = $rhash->{rhistory_anchor_point};
if ( $rhistory_level_diff->[-1] != $level_diff ) {
# Patch for non-indenting-braces: if we guess zero and
# match before all non-indenting braces have been found,
# it means that we would need negative indentation to
# match if/when the brace is found. So we have a problem
# from here on. We indicate this with a value 2 instead
# of 1 as a signal to stop outputting the table here.
my $anchor = 1;
if ( $guess == 0 && $adjust > 0 ) { $anchor = 2 }
# add an anchor point
push @{$rhistory_level_diff}, $level_diff;
push @{$rhistory_line_number}, $input_line_number;
push @{$rhistory_anchor_point}, $anchor;
}
else {
# add a movable point following an anchor point
if ( $rhistory_anchor_point->[-1] ) {
push @{$rhistory_level_diff}, $level_diff;
push @{$rhistory_line_number}, $input_line_number;
push @{$rhistory_anchor_point}, 0;
}
# extend a movable point
else {
$rhistory_line_number->[-1] = $input_line_number;
}
}
}
}
return;
} ## end sub tokenizer_wrapup_line
} ## end tokenize_this_line
#######################################################################
# Tokenizer routines which assist in identifying token types
#######################################################################
# Define Global '%op_expected_table'
# = hash table of operator expected values based on last nonblank token
# exceptions to perl's weird parsing rules after type 'Z'
my %is_weird_parsing_rule_exception;
my %is_paren_dollar;
my %is_n_v;
BEGIN {
# Always expecting TERM following these types:
# note: this is identical to '@value_requestor_type' defined later.
# Fix for c250: add new type 'P' for package (expecting VERSION or {}
# after package NAMESPACE, so expecting TERM)
# Fix for c250: add new type 'S' for sub (not expecting operator)
my @q = qw#
; ! + x & ? F J - p / Y : % f U ~ A G j L P S * . | ^ < = [ m { \ > t
|| >= != mm *= => .. !~ == && |= .= pp -= =~ += <= %= ^= x= ~~ ** << /=
&= // >> ~. &. |. ^.
... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~
#;
push @q, ',';
push @q, '('; # for completeness, not currently a token type
push @q, '->'; # was previously in UNKNOWN
@op_expected_table{@q} = (TERM) x scalar(@q);
# No UNKNOWN table types:
# removed '->' for c030, now always TERM
# removed 'w' for c392 to allow use of 'function_count' info in the sub
# Always expecting OPERATOR ...
# 'n' and 'v' are currently excluded because they might be VERSION numbers
# 'i' is currently excluded because it might be a package
# 'q' is currently excluded because it might be a prototype
# Fix for c030: removed '->' from this list:
# Fix for c250: added 'i' because new type 'P' was added
@q = qw( -- C h R ++ ] Q <> i );
push @q, ')';
@op_expected_table{@q} = (OPERATOR) x scalar(@q);
# Fix for git #62: added '*' and '%'
@q = qw( < ? * % );
@is_weird_parsing_rule_exception{@q} = (1) x scalar(@q);
@q = qw<) $>;
@is_paren_dollar{@q} = (1) x scalar(@q);
@q = qw( n v );
@is_n_v{@q} = (1) x scalar(@q);
} ## end BEGIN
use constant DEBUG_OPERATOR_EXPECTED => 0;
sub operator_expected {
my ( $self, $tok, $next_type, $blank_after_Z ) = @_;
# Returns a parameter indicating what types of tokens can occur next
# Call format:
# $op_expected =
# $self->operator_expected( $tok, $next_type, $blank_after_Z );
# where
# $tok is the current token
# $next_type is the type of the next token (blank or not)
# $blank_after_Z = flag for guessing after a type 'Z':
# true if $tok follows type 'Z' with intermediate blank
# false if $tok follows type 'Z' with no intermediate blank
# ignored if $tok does not follow type 'Z'
# Many perl symbols have two or more meanings. For example, '<<'
# can be a shift operator or a here-doc operator. The
# interpretation of these symbols depends on the current state of
# the tokenizer, which may either be expecting a term or an
# operator. For this example, a << would be a shift if an OPERATOR
# is expected, and a here-doc if a TERM is expected. This routine
# is called to make this decision for any current token. It returns
# one of three possible values:
#
# OPERATOR - operator expected (or at least, not a term)
# UNKNOWN - can't tell
# TERM - a term is expected (or at least, not an operator)
#
# The decision is based on what has been seen so far. This
# information is stored in the "$last_nonblank_type" and
# "$last_nonblank_token" variables. For example, if the
# $last_nonblank_type is '=~', then we are expecting a TERM, whereas
# if $last_nonblank_type is 'n' (numeric), we are expecting an
# OPERATOR.
#
# If a UNKNOWN is returned, the calling routine must guess. A major
# goal of this tokenizer is to minimize the possibility of returning
# UNKNOWN, because a wrong guess can spoil the formatting of a
# script.
#
# Adding NEW_TOKENS: it is critically important that this routine be
# updated to allow it to determine if an operator or term is to be
# expected after the new token. Doing this simply involves adding
# the new token character to one of the regexes in this routine or
# to one of the hash lists
# that it uses, which are initialized in the BEGIN section.
# USES GLOBAL VARIABLES: $last_nonblank_type, $last_nonblank_token,
# $statement_type
# When possible, token types should be selected such that we can determine
# the 'operator_expected' value by a simple hash lookup. If there are
# exceptions, that is an indication that a new type is needed.
#--------------------------------------------
# Section 1: Table lookup will get most cases
#--------------------------------------------
# Many types are can be obtained by a table lookup. This typically handles
# more than half of the calls. For speed, the caller may try table lookup
# first before calling this sub.
my $op_expected = $op_expected_table{$last_nonblank_type};
if ( defined($op_expected) ) {
DEBUG_OPERATOR_EXPECTED
&& print {*STDOUT}
"OPERATOR_EXPECTED: Table Lookup; returns $op_expected for last type $last_nonblank_type token $last_nonblank_token\n";
return $op_expected;
}
DEBUG_OPERATOR_EXPECTED
&& print {*STDOUT}
"OPERATOR_EXPECTED: in hardwired table for last type $last_nonblank_type token $last_nonblank_token\n";
#---------------------------------------------
# Section 2: Handle special cases if necessary
#---------------------------------------------
# Types 'k', '}' and 'Z' depend on context
# Types 'n', 'v', 'q' also depend on context.
# identifier...
# Fix for c250: removed coding for type 'i' because 'i' and new type 'P'
# are now done by hash table lookup
#--------------------
# Section 2A: keyword
#--------------------
if ( $last_nonblank_type eq 'k' ) {
# keywords expecting TERM:
if ( $expecting_term_token{$last_nonblank_token} ) {
# Exceptions from TERM:
# // may follow perl functions which may be unary operators
# see test file dor.t (defined or);
if (
$tok eq '/'
&& $next_type eq '/'
&& $is_keyword_rejecting_slash_as_pattern_delimiter{
$last_nonblank_token}
)
{
return OPERATOR;
}
# Patch to allow a ? following 'split' to be a deprecated pattern
# delimiter. This patch is coordinated with the omission of split
# from the list
# %is_keyword_rejecting_question_as_pattern_delimiter. This patch
# will force perltidy to guess.
if ( $tok eq '?'
&& $last_nonblank_token eq 'split' )
{
return UNKNOWN;
}
return TERM;
}
# keywords expecting OPERATOR:
if ( $expecting_operator_token{$last_nonblank_token} ) {
return OPERATOR;
}
return TERM;
} ## end type 'k'
#------------------------------------
# Section 2B: Closing container token
#------------------------------------
# Note that the actual token for type '}' may also be a ')'.
# Also note that $last_nonblank_token is not the token corresponding to
# $last_nonblank_type when the type is a closing container. In that
# case it is the token before the corresponding opening container token.
# So for example, for this snippet
# $a = do { BLOCK } / 2;
# the $last_nonblank_token is 'do' when $last_nonblank_type eq '}'.
if ( $last_nonblank_type eq '}' ) {
# handle something after 'do' and 'eval'
if ( $is_block_operator{$last_nonblank_token} ) {
# something like $a = do { BLOCK } / 2;
return OPERATOR; # block mode following }
}
# $last_nonblank_token =~ /^(\)|\$|\-\>)/
if ( $is_paren_dollar{ substr( $last_nonblank_token, 0, 1 ) }
|| substr( $last_nonblank_token, 0, 2 ) eq '->' )
{
if ( $last_nonblank_token eq '$' ) { return UNKNOWN }
return OPERATOR;
}
# Check for smartmatch operator before preceding brace or square
# bracket. For example, at the ? after the ] in the following
# expressions we are expecting an operator:
#
# qr/3/ ~~ ['1234'] ? 1 : 0;
# map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
if ( $last_nonblank_token eq '~~' ) {
return OPERATOR;
}
# A right brace here indicates the end of a simple block. All
# non-structural right braces have type 'R' all braces associated with
# block operator keywords have been given those keywords as
# "last_nonblank_token" and caught above. (This statement is order
# dependent, and must come after checking $last_nonblank_token).
# patch for dor.t (defined or).
if ( $tok eq '/'
&& $next_type eq '/'
&& $last_nonblank_token eq ']' )
{
return OPERATOR;
}
# Patch for RT #116344: misparse a ternary operator after an
# anonymous hash, like this:
# return ref {} ? 1 : 0;
# The right brace should really be marked type 'R' in this case,
# and it is safest to return an UNKNOWN here. Expecting a TERM will
# cause the '?' to always be interpreted as a pattern delimiter
# rather than introducing a ternary operator.
if ( $tok eq '?' ) {
return UNKNOWN;
}
return TERM;
} ## end type '}'
#-------------------------------
# Section 2C: number or v-string
#-------------------------------
# An exception is for VERSION numbers a 'use' statement. It has the format
# use Module VERSION LIST
# We could avoid this exception by writing a special sub to parse 'use'
# statements and perhaps mark these numbers with a new type V (for VERSION)
if ( $is_n_v{$last_nonblank_type} ) {
if ( $statement_type eq 'use' ) {
return UNKNOWN;
}
return OPERATOR;
}
#---------------------
# Section 2D: qw quote
#---------------------
# TODO: labeled prototype words would better be given type 'A' or maybe
# 'J'; not 'q'; or maybe mark as type 'Y'?
if ( $last_nonblank_type eq 'q' ) {
if ( $last_nonblank_token eq 'prototype' ) {
return TERM;
}
# update for --use-feature=class (rt145706):
# Look for class VERSION after possible attribute, as in
# class Example::Subclass : isa(Example::Base) 1.345 { ... }
if ( $statement_type =~ /^package\b/ ) {
return TERM;
}
# everything else
return OPERATOR;
}
# Section 2E: bareword
if ( $last_nonblank_type eq 'w' ) {
# see if this has been seen in the role of a function taking args
my $rinfo = $self->[_rbareword_info_]->{$current_package};
if ($rinfo) {
$rinfo = $rinfo->{$last_nonblank_token};
if ($rinfo) {
my $function_count = $rinfo->{function_count};
if ( $function_count && $function_count > 0 ) { return TERM }
}
}
return UNKNOWN;
}
#-----------------------------------
# Section 2F: file handle or similar
#-----------------------------------
if ( $last_nonblank_type eq 'Z' ) {
# angle.t
if ( $last_nonblank_token =~ /^\w/ ) {
return UNKNOWN;
}
# Exception to weird parsing rules for 'x(' ... see case b1205:
# In something like 'print $vv x(...' the x is an operator;
# Likewise in 'print $vv x$ww' the x is an operator (case b1207)
# otherwise x follows the weird parsing rules.
if ( $tok eq 'x' && $next_type =~ /^[\(\$\@\%]$/ ) {
return OPERATOR;
}
# The 'weird parsing rules' of next section do not work for '<' and '?'
# It is best to mark them as unknown. Test case:
# print $fh ;
if ( $is_weird_parsing_rule_exception{$tok} ) {
return UNKNOWN;
}
# For possible file handle like "$a", Perl uses weird parsing rules.
# For example:
# print $a/2,"/hi"; - division
# print $a / 2,"/hi"; - division
# print $a/ 2,"/hi"; - division
# print $a /2,"/hi"; - pattern (and error)!
# Some examples where this logic works okay, for '&','*','+':
# print $fh &xsi_protos(@mods);
# my $x = new $CompressClass *FH;
# print $OUT +( $count % 15 ? ", " : "\n\t" );
if ( $blank_after_Z
&& $next_type ne 'b' )
{
return TERM;
}
# Note that '?' and '<' have been moved above
# ( $tok =~ /^([x\/\+\-\*\%\&\.\?\<]|\>\>)$/ ) {
if ( $tok =~ /^([x\/\+\-\*\%\&\.]|\>\>)$/ ) {
# Do not complain in 'use' statements, which have special syntax.
# For example, from RT#130344:
# use lib $FindBin::Bin . '/lib';
if ( $statement_type ne 'use' ) {
$self->complain(
"operator in possible indirect object location not recommended\n"
);
}
return OPERATOR;
}
# all other cases
return UNKNOWN;
}
#--------------------------
# Section 2F: anything else
#--------------------------
return UNKNOWN;
} ## end sub operator_expected
sub new_statement_ok {
# Returns:
# true if a new statement can begin here
# false otherwise
# USES GLOBAL VARIABLES: $last_nonblank_token, $last_nonblank_type,
# $brace_depth, $rbrace_type
# Uses:
# - See if a 'class' statement can occur here
# - See if a keyword begins at a new statement; i.e. is an 'if' a
# block if or a trailing if? Also see if 'format' starts a statement.
# - Decide if a ':' is part of a statement label (not a ternary)
# Curly braces are tricky because some small blocks do not get marked as
# blocks..
# if it follows an opening curly brace..
if ( $last_nonblank_token eq '{' ) {
# The safe thing is to return true in all cases because:
# - a ternary ':' cannot occur here
# - an 'if' here, for example, cannot be a trailing if
# See test case c231 for an example.
# This works but could be improved, if necessary, by returning
# 'false' at obvious non-blocks.
return 1;
}
# if it follows a closing code block curly brace..
elsif ($last_nonblank_token eq '}'
&& $last_nonblank_type eq $last_nonblank_token )
{
# a new statement can follow certain closing block braces ...
# FIXME: The following has worked well but returns true in some cases
# where it really should not. We could fix this by either excluding
# certain blocks, like sort/map/grep/eval/asub or by just including
# certain blocks.
return $rbrace_type->[$brace_depth];
}
# otherwise, it is a label if and only if it follows a ';' (real or fake)
# or another label
else {
return ( $last_nonblank_type eq ';' || $last_nonblank_type eq 'J' );
}
} ## end sub new_statement_ok
sub code_block_type {
my ( $self, $i, $rtokens, $rtoken_type, $max_token_index ) = @_;
# Decide if this is a block of code, and its type.
# Must be called only when $type = $token = '{'
# The problem is to distinguish between the start of a block of code
# and the start of an anonymous hash reference
# Returns "" if not code block, otherwise returns 'last_nonblank_token'
# to indicate the type of code block. (For example, 'last_nonblank_token'
# might be 'if' for an if block, 'else' for an else block, etc).
# USES GLOBAL VARIABLES: $last_nonblank_token, $last_nonblank_type,
# $last_nonblank_block_type, $brace_depth, $rbrace_type
# handle case of multiple '{'s
# print "BLOCK_TYPE EXAMINING: type=$last_nonblank_type tok=$last_nonblank_token\n";
if ( $last_nonblank_token eq '{'
&& $last_nonblank_type eq $last_nonblank_token )
{
# opening brace where a statement may appear is probably
# a code block but might be and anonymous hash reference
if ( $rbrace_type->[$brace_depth] ) {
return $self->decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
}
# cannot start a code block within an anonymous hash
else {
return EMPTY_STRING;
}
}
elsif ( $last_nonblank_token eq ';' ) {
# an opening brace where a statement may appear is probably
# a code block but might be and anonymous hash reference
return $self->decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
}
# handle case of '}{'
elsif ($last_nonblank_token eq '}'
&& $last_nonblank_type eq $last_nonblank_token )
{
# a } { situation ...
# could be hash reference after code block..(blktype1.t)
if ($last_nonblank_block_type) {
return $self->decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
}
# must be a block if it follows a closing hash reference
else {
return $last_nonblank_token;
}
}
#--------------------------------------------------------------
# NOTE: braces after type characters start code blocks, but for
# simplicity these are not identified as such. See also
# sub is_non_structural_brace.
#--------------------------------------------------------------
## elsif ( $last_nonblank_type eq 't' ) {
## return $last_nonblank_token;
## }
# brace after label:
elsif ( $last_nonblank_type eq 'J' ) {
return $last_nonblank_token;
}
# otherwise, see if a block must follow the previous token (such as 'if'):
elsif ($is_code_block_token{$last_nonblank_token}
|| $is_grep_alias{$last_nonblank_token} )
{
# Bug Patch: Note that the opening brace after the 'if' in the following
# snippet is an anonymous hash ref and not a code block!
# print 'hi' if { x => 1, }->{x};
# We can identify this situation because the last nonblank type
# will be a keyword (instead of a closing paren)
if (
$last_nonblank_type eq 'k'
&& ( $last_nonblank_token eq 'if'
|| $last_nonblank_token eq 'unless' )
)
{
return EMPTY_STRING;
}
else {
return $last_nonblank_token;
}
}
# or a sub or package BLOCK
# Fixed for c250 to include new package type 'P', and change 'i' to 'S'
elsif (
$last_nonblank_type eq 'P'
|| $last_nonblank_type eq 'S'
|| ( $last_nonblank_type eq 't'
&& substr( $last_nonblank_token, 0, 3 ) eq 'sub' )
)
{
return $last_nonblank_token;
}
elsif ( $statement_type =~ /^(sub|package)\b/ ) {
return $statement_type;
}
# user-defined subs with block parameters (like grep/map/eval)
elsif ( $last_nonblank_type eq 'G' ) {
return $last_nonblank_token;
}
# check bareword
elsif ( $last_nonblank_type eq 'w' ) {
# check for syntax 'use MODULE LIST'
# This fixes b1022 b1025 b1027 b1028 b1029 b1030 b1031
return EMPTY_STRING if ( $statement_type eq 'use' );
return $self->decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
}
# Patch for bug # RT #94338 reported by Daniel Trizen
# for-loop in a parenthesized block-map triggering an error message:
# map( { foreach my $item ( '0', '1' ) { print $item} } qw(a b c) );
# Check for a code block within a parenthesized function call
elsif ( $last_nonblank_token eq '(' ) {
my $paren_type = $rparen_type->[$paren_depth];
# /^(map|grep|sort)$/
if ( $paren_type && $is_sort_map_grep{$paren_type} ) {
# We will mark this as a code block but use type 't' instead
# of the name of the containing function. This will allow for
# correct parsing but will usually produce better formatting.
# Braces with block type 't' are not broken open automatically
# in the formatter as are other code block types, and this usually
# works best.
return 't'; # (Not $paren_type)
}
else {
return EMPTY_STRING;
}
}
# handle unknown syntax ') {'
# we previously appended a '()' to mark this case
elsif ( $last_nonblank_token =~ /\(\)$/ ) {
return $last_nonblank_token;
}
# anything else must be anonymous hash reference
else {
return EMPTY_STRING;
}
} ## end sub code_block_type
sub decide_if_code_block {
# USES GLOBAL VARIABLES: $last_nonblank_token
my ( $self, $i, $rtokens, $rtoken_type, $max_token_index ) = @_;
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
# we are at a '{' where a statement may appear.
# We must decide if this brace starts an anonymous hash or a code
# block.
# return "" if anonymous hash, and $last_nonblank_token otherwise
# initialize to be code BLOCK
my $code_block_type = $last_nonblank_token;
# Check for the common case of an empty anonymous hash reference:
# Maybe something like sub { { } }
if ( $next_nonblank_token eq '}' ) {
$code_block_type = EMPTY_STRING;
}
else {
# To guess if this '{' is an anonymous hash reference, look ahead
# and test as follows:
#
# it is a hash reference if next come:
# - a string or digit followed by a comma or =>
# - bareword followed by =>
# otherwise it is a code block
#
# Examples of anonymous hash ref:
# {'aa',};
# {1,2}
#
# Examples of code blocks:
# {1; print "hello\n", 1;}
# {$a,1};
# We are only going to look ahead one more (nonblank/comment) line.
# Strange formatting could cause a bad guess, but that's unlikely.
my @pre_types;
my @pre_tokens;
# Ignore the rest of this line if it is a side comment
if ( $next_nonblank_token ne '#' ) {
@pre_types = @{$rtoken_type}[ $i + 1 .. $max_token_index ];
@pre_tokens = @{$rtokens}[ $i + 1 .. $max_token_index ];
}
# Here 20 is arbitrary but generous, and prevents wasting lots of time
# in mangled files
my ( $rpre_tokens, $rpre_types ) =
$self->peek_ahead_for_n_nonblank_pre_tokens(20);
if ( defined($rpre_types) && @{$rpre_types} ) {
push @pre_types, @{$rpre_types};
push @pre_tokens, @{$rpre_tokens};
}
# put a sentinel token to simplify stopping the search
push @pre_types, '}';
push @pre_types, '}';
my $jbeg = 0;
$jbeg = 1 if $pre_types[0] eq 'b';
# first look for one of these
# - bareword
# - bareword with leading -
# - digit
# - quoted string
my $j = $jbeg;
if ( $pre_types[$j] =~ /^[\'\"]/ ) {
# find the closing quote; don't worry about escapes
my $quote_mark = $pre_types[$j];
foreach my $k ( $j + 1 .. @pre_types - 2 ) {
if ( $pre_types[$k] eq $quote_mark ) {
$j = $k + 1;
last;
}
}
}
elsif ( $pre_types[$j] eq 'd' ) {
$j++;
}
elsif ( $pre_types[$j] eq 'w' ) {
$j++;
}
elsif ( $pre_types[$j] eq '-' && $pre_types[ ++$j ] eq 'w' ) {
$j++;
}
else {
# none of the above
}
if ( $j > $jbeg ) {
$j++ if $pre_types[$j] eq 'b';
# Patched for RT #95708
if (
# it is a comma which is not a pattern delimiter except for qw
(
$pre_types[$j] eq ','
&& !$is_q_qq_qx_qr_s_y_tr_m{ $pre_tokens[$jbeg] }
)
# or a =>
|| ( $pre_types[$j] eq '=' && $pre_types[ ++$j ] eq '>' )
)
{
$code_block_type = EMPTY_STRING;
}
}
if ($code_block_type) {
# Patch for cases b1085 b1128: It is uncertain if this is a block.
# If this brace follows a bareword, then append a space as a signal
# to the formatter that this may not be a block brace. To find the
# corresponding code in Formatter.pm search for 'b1085'.
$code_block_type .= SPACE if ( $code_block_type =~ /^\w/ );
}
}
return $code_block_type;
} ## end sub decide_if_code_block
sub report_unexpected {
# report unexpected token type and show where it is
# USES GLOBAL VARIABLES: (none)
my ( $self, $rcall_hash ) = @_;
my $found = $rcall_hash->{found};
my $expecting = $rcall_hash->{expecting};
my $i_tok = $rcall_hash->{i_tok};
my $last_nonblank_i = $rcall_hash->{last_nonblank_i};
my $rpretoken_map = $rcall_hash->{rpretoken_map};
my $rpretoken_type = $rcall_hash->{rpretoken_type};
my $input_line = $rcall_hash->{input_line};
if ( ++$self->[_unexpected_error_count_] <= MAX_NAG_MESSAGES ) {
my $msg = "found $found where $expecting expected";
my $pos = $rpretoken_map->[$i_tok];
$self->interrupt_logfile();
my $input_line_number = $self->[_last_line_number_];
my ( $offset, $numbered_line, $underline ) =
make_numbered_line( $input_line_number, $input_line, $pos );
$underline = write_on_underline( $underline, $pos - $offset, '^' );
my $trailer = EMPTY_STRING;
if ( ( $i_tok > 0 ) && ( $last_nonblank_i >= 0 ) ) {
my $pos_prev = $rpretoken_map->[$last_nonblank_i];
my $num;
if ( $rpretoken_type->[ $i_tok - 1 ] eq 'b' ) {
$num = $rpretoken_map->[ $i_tok - 1 ] - $pos_prev;
}
else {
$num = $pos - $pos_prev;
}
if ( $num > 40 ) { $num = 40; $pos_prev = $pos - 40; }
$underline =
write_on_underline( $underline, $pos_prev - $offset, '-' x $num );
$trailer = " (previous token underlined)";
}
$underline =~ s/\s+$//;
$self->warning( $numbered_line . "\n" );
$self->warning( $underline . "\n" );
$self->warning( $msg . $trailer . "\n" );
$self->resume_logfile();
}
return;
} ## end sub report_unexpected
my %is_sigil_or_paren;
my %is_R_closing_sb;
BEGIN {
my @q = qw< $ & % * @ ) >;
@is_sigil_or_paren{@q} = (1) x scalar(@q);
@q = qw( R ] );
@is_R_closing_sb{@q} = (1) x scalar(@q);
} ## end BEGIN
sub is_non_structural_brace {
# Decide if a brace or bracket is structural or non-structural
# by looking at the previous token and type
# USES GLOBAL VARIABLES: $last_nonblank_type, $last_nonblank_token
# EXPERIMENTAL: Mark slices as structural; idea was to improve formatting.
# Tentatively deactivated because it caused the wrong operator expectation
# for this code:
# $user = @vars[1] / 100;
# Must update sub operator_expected before re-implementing.
# if ( $last_nonblank_type eq 'i' && $last_nonblank_token =~ /^@/ ) {
# return 0;
# }
#--------------------------------------------------------------
# NOTE: braces after type characters start code blocks, but for
# simplicity these are not identified as such. See also
# sub code_block_type
#--------------------------------------------------------------
##if ($last_nonblank_type eq 't') {return 0}
# otherwise, it is non-structural if it is decorated
# by type information.
# For example, the '{' here is non-structural: ${xxx}
# Removed '::' to fix c074
## $last_nonblank_token =~ /^([\$\@\*\&\%\)]|->|::)/
return (
## $last_nonblank_token =~ /^([\$\@\*\&\%\)]|->)/
$is_sigil_or_paren{ substr( $last_nonblank_token, 0, 1 ) }
|| substr( $last_nonblank_token, 0, 2 ) eq '->'
# or if we follow a hash or array closing curly brace or bracket
# For example, the second '{' in this is non-structural: $a{'x'}{'y'}
# because the first '}' would have been given type 'R'
##|| $last_nonblank_type =~ /^([R\]])$/
|| $is_R_closing_sb{$last_nonblank_type}
);
} ## end sub is_non_structural_brace
#######################################################################
# Tokenizer routines for tracking container nesting depths
#######################################################################
# The following routines keep track of nesting depths of the nesting
# types, ( [ { and ?. This is necessary for determining the indentation
# level, and also for debugging programs. Not only do they keep track of
# nesting depths of the individual brace types, but they check that each
# of the other brace types is balanced within matching pairs. For
# example, if the program sees this sequence:
#
# { ( ( ) }
#
# then it can determine that there is an extra left paren somewhere
# between the { and the }. And so on with every other possible
# combination of outer and inner brace types. For another
# example:
#
# ( [ ..... ] ] )
#
# which has an extra ] within the parens.
#
# The brace types have indexes 0 .. 3 which are indexes into
# the matrices.
#
# The pair ? : are treated as just another nesting type, with ? acting
# as the opening brace and : acting as the closing brace.
#
# The matrix
#
# $rdepth_array->[$a][$b][ $rcurrent_depth->[$a] ] = $rcurrent_depth->[$b];
#
# saves the nesting depth of brace type $b (where $b is either of the other
# nesting types) when brace type $a enters a new depth. When this depth
# decreases, a check is made that the current depth of brace types $b is
# unchanged, or otherwise there must have been an error. This can
# be very useful for localizing errors, particularly when perl runs to
# the end of a large file (such as this one) and announces that there
# is a problem somewhere.
#
# A numerical sequence number is maintained for every nesting type,
# so that each matching pair can be uniquely identified in a simple
# way.
sub increase_nesting_depth {
my ( $self, $aa, $pos ) = @_;
# Given:
# $aa = integer code of container type, 0-3
# $pos = position of character, for error message
# USES GLOBAL VARIABLES: $rcurrent_depth,
# $rcurrent_sequence_number, $rdepth_array,
# $rstarting_line_of_current_depth, $statement_type
my $cd_aa = ++$rcurrent_depth->[$aa];
$total_depth++;
$rtotal_depth->[$aa][$cd_aa] = $total_depth;
my $input_line_number = $self->[_last_line_number_];
my $input_line = $self->[_line_of_text_];
# Sequence numbers increment by number of items. This keeps
# a unique set of numbers but still allows the relative location
# of any type to be determined.
# make a new unique sequence number
my $seqno = $next_sequence_number++;
$rcurrent_sequence_number->[$aa][$cd_aa] = $seqno;
$rstarting_line_of_current_depth->[$aa][$cd_aa] =
[ $input_line_number, $input_line, $pos ];
for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
$rdepth_array->[$aa][$bb][$cd_aa] = $rcurrent_depth->[$bb];
}
# set a flag for indenting a nested ternary statement
my $indent = 0;
if ( $aa == QUESTION_COLON ) {
$rnested_ternary_flag->[$cd_aa] = 0;
if ( $cd_aa > 1 ) {
if ( $rnested_ternary_flag->[ $cd_aa - 1 ] == 0 ) {
my $pdepth = $rtotal_depth->[$aa][ $cd_aa - 1 ];
if ( $pdepth == $total_depth - 1 ) {
$indent = 1;
$rnested_ternary_flag->[ $cd_aa - 1 ] = -1;
}
}
}
}
# Fix part #1 for git82: save last token type for propagation of type 'Z'
$rnested_statement_type->[$aa][$cd_aa] =
[ $statement_type, $last_nonblank_type, $last_nonblank_token ];
$statement_type = EMPTY_STRING;
return ( $seqno, $indent );
} ## end sub increase_nesting_depth
sub is_balanced_closing_container {
my ($aa) = @_;
# Return true if a closing container can go here without error
# Return false if not
# Given:
# $aa = integer code of container type, 0-3
# cannot close if there was no opening
my $cd_aa = $rcurrent_depth->[$aa];
return if ( $cd_aa <= 0 );
# check that any other brace types $bb contained within would be balanced
for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
return
if ( $rdepth_array->[$aa][$bb][$cd_aa] != $rcurrent_depth->[$bb] );
}
# OK, everything will be balanced
return 1;
} ## end sub is_balanced_closing_container
sub decrease_nesting_depth {
my ( $self, $aa, $pos ) = @_;
# Given:
# $aa = integer code of container type, 0-3
# $pos = position of character, for error message
# USES GLOBAL VARIABLES: $rcurrent_depth,
# $rcurrent_sequence_number, $rdepth_array, $rstarting_line_of_current_depth
# $statement_type
my $seqno = 0;
my $input_line_number = $self->[_last_line_number_];
my $input_line = $self->[_line_of_text_];
my $outdent = 0;
$total_depth--;
my $cd_aa = $rcurrent_depth->[$aa];
if ( $cd_aa > 0 ) {
# set a flag for un-indenting after seeing a nested ternary statement
$seqno = $rcurrent_sequence_number->[$aa][$cd_aa];
if ( $aa == QUESTION_COLON ) {
$outdent = $rnested_ternary_flag->[$cd_aa];
}
# Fix part #2 for git82: use saved type for propagation of type 'Z'
# through type L-R braces. Perl seems to allow ${bareword}
# as an indirect object, but nothing much more complex than that.
( $statement_type, my $saved_type, my $saved_token_uu ) =
@{ $rnested_statement_type->[$aa][ $rcurrent_depth->[$aa] ] };
if ( $aa == BRACE
&& $saved_type eq 'Z'
&& $last_nonblank_type eq 'w'
&& $rbrace_structural_type->[$brace_depth] eq 'L' )
{
$last_nonblank_type = $saved_type;
}
# check that any brace types $bb contained within are balanced
for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
if ( $rdepth_array->[$aa][$bb][$cd_aa] != $rcurrent_depth->[$bb] ) {
my $diff =
$rcurrent_depth->[$bb] - $rdepth_array->[$aa][$bb][$cd_aa];
# don't whine too many times
my $saw_brace_error = $self->get_saw_brace_error();
if (
$saw_brace_error <= MAX_NAG_MESSAGES
# if too many closing types have occurred, we probably
# already caught this error
&& ( ( $diff > 0 ) || ( $saw_brace_error <= 0 ) )
)
{
$self->interrupt_logfile();
my $rsl = $rstarting_line_of_current_depth->[$aa][$cd_aa];
my $sl = $rsl->[0];
my $rel = [ $input_line_number, $input_line, $pos ];
my $el = $rel->[0];
my ($ess);
if ( $diff == 1 || $diff == -1 ) {
$ess = EMPTY_STRING;
}
else {
$ess = 's';
}
my $bname =
( $diff > 0 )
? $opening_brace_names[$bb]
: $closing_brace_names[$bb];
$self->write_error_indicator_pair( @{$rsl}, '^' );
my $msg = <<"EOM";
Found $diff extra $bname$ess between $opening_brace_names[$aa] on line $sl and $closing_brace_names[$aa] on line $el
EOM
if ( $diff > 0 ) {
my $rml =
$rstarting_line_of_current_depth->[$bb]
[ $rcurrent_depth->[$bb] ];
my $ml = $rml->[0];
$msg .=
" The most recent un-matched $bname is on line $ml\n";
$self->write_error_indicator_pair( @{$rml}, '^' );
}
$self->write_error_indicator_pair( @{$rel}, '^' );
$self->warning($msg);
$self->resume_logfile();
}
$self->increment_brace_error();
if ( $bb eq BRACE ) { $self->[_show_indentation_table_] = 1 }
}
}
$rcurrent_depth->[$aa]--;
}
else {
my $saw_brace_error = $self->get_saw_brace_error();
if ( $saw_brace_error <= MAX_NAG_MESSAGES ) {
my $msg = <<"EOM";
There is no previous $opening_brace_names[$aa] to match a $closing_brace_names[$aa] on line $input_line_number
EOM
$self->indicate_error( $msg, $input_line_number, $input_line, $pos,
'^' );
}
$self->increment_brace_error();
if ( $aa eq BRACE ) { $self->[_show_indentation_table_] = 1 }
# keep track of errors in braces alone (ignoring ternary nesting errors)
$self->[_true_brace_error_count_]++
if ( $closing_brace_names[$aa] ne "':'" );
}
return ( $seqno, $outdent );
} ## end sub decrease_nesting_depth
sub check_final_nesting_depths {
# USES GLOBAL VARIABLES: $rcurrent_depth, $rstarting_line_of_current_depth
my $self = shift;
for my $aa ( 0 .. @closing_brace_names - 1 ) {
my $cd_aa = $rcurrent_depth->[$aa];
if ($cd_aa) {
my $rsl = $rstarting_line_of_current_depth->[$aa][$cd_aa];
my $sl = $rsl->[0];
my $msg = <<"EOM";
Final nesting depth of $opening_brace_names[$aa]s is $cd_aa
The most recent un-matched $opening_brace_names[$aa] is on line $sl
EOM
$self->indicate_error( $msg, @{$rsl}, '^' );
$self->increment_brace_error();
if ( $aa eq BRACE ) { $self->[_show_indentation_table_] = 1 }
}
}
return;
} ## end sub check_final_nesting_depths
#######################################################################
# Tokenizer routines for looking ahead in input stream
#######################################################################
sub peek_ahead_for_n_nonblank_pre_tokens {
my ( $self, $max_pretokens ) = @_;
# Given:
# $max_pretokens = number of pretokens wanted
# Return:
# next $max_pretokens pretokens if they exist
# undef's if hits eof without seeing any pretokens
# USES GLOBAL VARIABLES: (none)
my $line;
my $i = 0;
my ( $rpre_tokens, $rmap, $rpre_types );
while ( defined( $line = $self->peek_ahead( $i++ ) ) ) {
$line =~ s/^\s+//; # trim leading blanks
next if ( length($line) <= 0 ); # skip blank
next if ( $line =~ /^#/ ); # skip comment
( $rpre_tokens, $rmap, $rpre_types ) =
pre_tokenize( $line, $max_pretokens );
last;
} ## end while ( defined( $line = ...))
return ( $rpre_tokens, $rpre_types );
} ## end sub peek_ahead_for_n_nonblank_pre_tokens
# look ahead for next non-blank, non-comment line of code
sub peek_ahead_for_nonblank_token {
my ( $self, $rtokens, $max_token_index ) = @_;
# Given:
# $rtokens = ref to token array
# $max_token_index = index of last token in $rtokens
# Task:
# Update $rtokens with next nonblank token
# USES GLOBAL VARIABLES: (none)
my $line;
my $i = 0;
while ( defined( $line = $self->peek_ahead( $i++ ) ) ) {
$line =~ s/^\s+//; # trim leading blanks
next if ( length($line) <= 0 ); # skip blank
next if ( $line =~ /^#/ ); # skip comment
# Updated from 2 to 3 to get trigraphs, added for case b1175
my ( $rtok, $rmap_uu, $rtype_uu ) = pre_tokenize( $line, 3 );
my $j = $max_token_index + 1;
foreach my $tok ( @{$rtok} ) {
last if ( $tok =~ "\n" );
$rtokens->[ ++$j ] = $tok;
}
last;
} ## end while ( defined( $line = ...))
return;
} ## end sub peek_ahead_for_nonblank_token
#######################################################################
# Tokenizer guessing routines for ambiguous situations
#######################################################################
sub guess_if_pattern_or_conditional {
my ( $self, $i, $rtokens, $rtoken_type, $rtoken_map_uu, $max_token_index )
= @_;
# This routine is called when we have encountered a ? following an
# unknown bareword, and we must decide if it starts a pattern or not
# Given:
# $i - token index of the ? starting possible pattern
# $rtokens ... = the token arrays
# Return:
# $is_pattern = 0 if probably not pattern, =1 if probably a pattern
# msg = a warning or diagnostic message
# USES GLOBAL VARIABLES: $last_nonblank_token
my $is_pattern = 0;
my $msg = "guessing that ? after '$last_nonblank_token' starts a ";
if ( $i >= $max_token_index ) {
$msg .= "conditional (no end to pattern found on the line)\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
my $ibeg = $i;
$i = $ibeg + 1;
##my $next_token = $rtokens->[$i]; # first token after ?
# look for a possible ending ? on this line..
my $in_quote = 1;
my $quote_depth = 0;
my $quote_character = EMPTY_STRING;
my $quote_pos = 0;
my $quoted_string;
(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string,
) = $self->follow_quoted_string(
$ibeg,
$in_quote,
$rtokens,
$rtoken_type,
$quote_character,
$quote_pos,
$quote_depth,
$max_token_index,
);
if ($in_quote) {
# we didn't find an ending ? on this line,
# so we bias towards conditional
$is_pattern = 0;
$msg .= "conditional (no ending ? on this line)\n";
return ( $is_pattern, $msg );
}
# we found an ending ?, so we bias towards a pattern
# Watch out for an ending ? in quotes, like this
# my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
my $s_quote = 0;
my $d_quote = 0;
my $colons = 0;
foreach my $ii ( $ibeg + 1 .. $i - 1 ) {
my $tok = $rtokens->[$ii];
if ( $tok eq ":" ) { $colons++ }
if ( $tok eq "'" ) { $s_quote++ }
if ( $tok eq '"' ) { $d_quote++ }
}
if ( $s_quote % 2 || $d_quote % 2 || $colons ) {
$is_pattern = 0;
$msg .= "found ending ? but unbalanced quote chars\n";
return ( $is_pattern, $msg );
}
if ( $self->pattern_expected( $i, $rtokens, $max_token_index ) >= 0 ) {
$is_pattern = 1;
$msg .= "pattern (found ending ? and pattern expected)\n";
return ( $is_pattern, $msg );
}
$msg .= "pattern (uncertain, but found ending ?)\n";
return ( $is_pattern, $msg );
} ## end sub guess_if_pattern_or_conditional
my %is_known_constant;
my %is_known_function;
BEGIN {
# Constants like 'pi' in Trig.pm are common
my @q = qw( pi pi2 pi4 pip2 pip4 );
@is_known_constant{@q} = (1) x scalar(@q);
# parenless calls of 'ok' are common
@q = qw( ok );
@is_known_function{@q} = (1) x scalar(@q);
} ## end BEGIN
sub guess_if_pattern_or_division {
my ( $self, $i, $rtokens, $rtoken_type, $rtoken_map, $max_token_index ) =
@_;
# This routine is called when we have encountered a / following an
# unknown bareword, and we must decide if it starts a pattern or is a
# division.
# Given:
# $i - token index of the / starting possible pattern
# $rtokens ... = the token arrays
# Return:
# $is_pattern = 0 if probably division, =1 if probably a pattern
# msg = a warning or diagnostic message
# USES GLOBAL VARIABLES: $last_nonblank_token
my $msg = "guessing that / after '$last_nonblank_token' starts a ";
my $ibeg = $i;
my $is_pattern = 0;
my $divide_possible =
$self->is_possible_numerator( $i, $rtokens, $max_token_index );
if ( $divide_possible < 0 ) {
$msg .= "pattern (division not possible here)\n";
$is_pattern = 1;
$self->saw_bareword_function($last_nonblank_token);
return ( $is_pattern, $msg );
}
if ( $divide_possible == 4 ) {
$msg .= "division (pattern not possible here)\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
# anything left on line?
if ( $i >= $max_token_index ) {
$msg .= "division (line ends with this /)\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
# quick check for no pattern-ending slash on this line
my $pos_beg = $rtoken_map->[$ibeg];
my $input_line = $self->[_line_of_text_];
if ( index( $input_line, '/', $pos_beg + 1 ) < 0 ) {
$msg .= "division (no ending / on this line)\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
# Setup spacing rule before we change $i below..
$i = $ibeg + 1;
my $next_token = $rtokens->[$i]; # first token after slash
# There are four possible spacings around the first slash:
#
# return pi/two;#/; -/-
# return pi/ two;#/; -/+
# return pi / two;#/; +/+
# return pi /two;#/; +/- <-- possible pattern
#
# Spacing rule: a space before the slash but not after the slash
# usually indicates a pattern. We can use this to break ties.
# Note: perl seems to take a newline as a space in this rule (c243)
my $space_before = $i < 2 || $rtokens->[ $i - 2 ] =~ m/^\s/;
my $space_after = $next_token =~ m/^\s/;
my $is_pattern_by_spacing = $space_before && !$space_after;
# Make an accurate search for a possible terminating / on this line..
my $in_quote = 1;
my $quote_depth = 0;
my $quote_character = EMPTY_STRING;
my $quote_pos = 0;
my $quoted_string;
(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string
)
= $self->follow_quoted_string(
$ibeg,
$in_quote,
$rtokens,
$rtoken_type,
$quote_character,
$quote_pos,
$quote_depth,
$max_token_index
);
# if we didn't find an ending / on this line ..
if ($in_quote) {
$is_pattern = 0;
$msg .= "division (no ending / on this line)\n";
return ( $is_pattern, $msg );
}
# we found an ending /, see if it might terminate a pattern
my $pattern_expected =
$self->pattern_expected( $i, $rtokens, $max_token_index );
if ( $pattern_expected < 0 ) {
$is_pattern = 0;
$msg .= "division (pattern not possible)\n";
return ( $is_pattern, $msg );
}
# Both pattern and divide can work here...
# Check for known constants in the numerator, like 'pi'
if ( $is_known_constant{$last_nonblank_token} ) {
$msg .=
"division (pattern works too but saw known constant '$last_nonblank_token')\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
# Check for known functions like 'ok'
if ( $is_known_function{$last_nonblank_token} ) {
$msg .= "pattern (division works too but saw '$last_nonblank_token')\n";
$is_pattern = 1;
return ( $is_pattern, $msg );
}
# If one rule is more probable, use it
if ( $divide_possible > $pattern_expected ) {
$msg .= "division (more likely based on following tokens)\n";
$is_pattern = 0;
return ( $is_pattern, $msg );
}
# finally, we have to use the spacing rule
if ($is_pattern_by_spacing) {
$msg .= "pattern (guess on spacing, but division possible too)\n";
$is_pattern = 1;
}
else {
$msg .= "division (guess on spacing, but pattern is possible too)\n";
$is_pattern = 0;
}
return ( $is_pattern, $msg );
} ## end sub guess_if_pattern_or_division
sub guess_if_here_doc {
my ( $self, $next_token ) = @_;
# Try to resolve here-doc vs. shift by looking ahead for
# non-code or the end token (currently only looks for end token)
# Given:
# $next_token = the next token after '<<'
# Return:
# 1 if it is probably a here doc
# 0 if not
# USES GLOBAL VARIABLES: $current_package $ris_constant,
# This is how many lines we will search for a target as part of the
# guessing strategy. There is probably little reason to change it.
my $HERE_DOC_WINDOW = 40;
my $here_doc_expected = 0;
my $line;
my $k = 0;
my $msg = "checking <<";
while ( defined( $line = $self->peek_ahead( $k++ ) ) ) {
chomp $line;
if ( $line eq $next_token ) {
$msg .= " -- found target $next_token ahead $k lines\n";
$here_doc_expected = 1; # got it
last;
}
last if ( $k >= $HERE_DOC_WINDOW );
} ## end while ( defined( $line = ...))
if ( !$here_doc_expected ) {
if ( !defined($line) ) {
$here_doc_expected = -1; # hit eof without seeing target
$msg .= " -- must be shift; target $next_token not in file\n";
}
else { # still unsure..taking a wild guess
if ( !$ris_constant->{$current_package}{$next_token} ) {
$here_doc_expected = 1;
$msg .=
" -- guessing it's a here-doc ($next_token not a constant)\n";
}
else {
$msg .=
" -- guessing it's a shift ($next_token is a constant)\n";
}
}
}
$self->write_logfile_entry($msg);
return $here_doc_expected;
} ## end sub guess_if_here_doc
#######################################################################
# Tokenizer Routines for scanning identifiers and related items
#######################################################################
sub scan_bare_identifier_do {
my (
$self,
$input_line,
$i,
$tok,
$type,
$prototype,
$rtoken_map,
$max_token_index
) = @_;
# This routine is called to scan a token starting with an alphanumeric
# variable or package separator, :: or '.
# Given:
# current scan state variables
# USES GLOBAL VARIABLES: $current_package, $last_nonblank_token,
# $last_nonblank_type, $rparen_type, $paren_depth
my $package = undef;
my $i_beg = $i;
# we have to back up one pretoken at a :: since each : is one pretoken
if ( $tok eq '::' ) { $i_beg-- }
my $pos_beg = $rtoken_map->[$i_beg];
pos($input_line) = $pos_beg;
# Examples:
# A::B::C
# A::
# ::A
# A'B
if (
$input_line =~ m{
\G\s* # start at pos
( (?:\w*(?:'|::))* ) # $1 = maybe package name like A:: A::B:: or A'
(\w+)? # $2 = maybe followed by sub name
}gcx
)
{
my $pos = pos($input_line);
my $numc = $pos - $pos_beg;
$tok = substr( $input_line, $pos_beg, $numc );
# type 'w' includes anything without leading type info
# ($,%,@,*) including something like abc::def::ghi
$type = 'w';
my $sub_name = EMPTY_STRING;
if ( defined($2) ) { $sub_name = $2; }
if ( defined($1) && length($1) ) {
$package = $1;
# patch: check for package call A::B::C->
# in this case, C is part of the package name
if ($sub_name) {
if ( $input_line =~ m{ \G\s*(?:->) }gcx ) {
$package .= $sub_name;
$sub_name = EMPTY_STRING;
}
pos($input_line) = $pos;
}
# patch: don't allow isolated package name which just ends
# in the old style package separator (single quote). Example:
# use CGI':all';
if ( !($sub_name) && substr( $package, -1, 1 ) eq '\'' ) {
$pos--;
}
$package =~ s/\'/::/g;
if ( $package =~ /^\:/ ) { $package = 'main' . $package }
$package =~ s/::$//;
}
else {
$package = $current_package;
# patched for c043, part 1: keyword does not follow '->'
if ( $is_keyword{$tok} && $last_nonblank_type ne '->' ) {
$type = 'k';
}
}
# if it is a bareword.. patched for c043, part 2: not following '->'
if ( $type eq 'w' && $last_nonblank_type ne '->' ) {
# check for v-string with leading 'v' type character
# (This seems to have precedence over filehandle, type 'Y')
if ( substr( $tok, 0, 1 ) eq 'v' && $tok =~ /^v\d[_\d]*$/ ) {
# we only have the first part - something like 'v101' -
# look for more
if ( $input_line =~ m/\G(\.\d[_\d]*)+/gc ) {
$pos = pos($input_line);
$numc = $pos - $pos_beg;
$tok = substr( $input_line, $pos_beg, $numc );
}
$type = 'v';
$self->report_v_string($tok);
}
# bareword after sort has implied empty prototype; for example:
# @sorted = sort numerically ( 53, 29, 11, 32, 7 );
# This has priority over whatever the user has specified.
elsif ($last_nonblank_token eq 'sort'
&& $last_nonblank_type eq 'k' )
{
$type = 'Z';
}
# issue c382: this elsif statement moved from above because
# previous check for type 'Z' after sort has priority.
elsif ( $ris_constant->{$package}{$sub_name} ) {
$type = 'C';
}
# Note: strangely, perl does not seem to really let you create
# functions which act like eval and do, in the sense that eval
# and do may have operators following the final }, but any operators
# that you create with prototype (&) apparently do not allow
# trailing operators, only terms. This seems strange.
# If this ever changes, here is the update
# to make perltidy behave accordingly:
# elsif ( $ris_block_function->{$package}{$tok} ) {
# $tok='eval'; # patch to do braces like eval - doesn't work
# $type = 'k';
#}
# TODO: This could become a separate type to allow for different
# future behavior:
elsif ( $ris_block_function->{$package}{$sub_name} ) {
$type = 'G';
}
elsif ( $ris_block_list_function->{$package}{$sub_name} ) {
$type = 'G';
}
elsif ( $ris_user_function->{$package}{$sub_name} ) {
$type = 'U';
$prototype = $ruser_function_prototype->{$package}{$sub_name};
}
# check for indirect object
elsif (
# added 2001-03-27: must not be followed immediately by '('
# see fhandle.t
( $input_line !~ m/\G\(/gc )
# and
&& (
# preceded by keyword like 'print', 'printf' and friends
$is_indirect_object_taker{$last_nonblank_token}
# or preceded by something like 'print(' or 'printf('
|| (
( $last_nonblank_token eq '(' )
&& $is_indirect_object_taker{
$rparen_type->[$paren_depth]
}
)
)
)
{
# may not be indirect object unless followed by a space;
# updated 2021-01-16 to consider newline to be a space.
# updated for case b990 to look for either ';' or space
if ( pos($input_line) == length($input_line)
|| $input_line =~ m/\G[;\s]/gc )
{
$type = 'Y';
# Abandon Hope ...
# Perl's indirect object notation is a very bad
# thing and can cause subtle bugs, especially for
# beginning programmers. And I haven't even been
# able to figure out a sane warning scheme which
# doesn't get in the way of good scripts.
# Complain if a filehandle has any lower case
# letters. This is suggested good practice.
# Use 'sub_name' because something like
# main::MYHANDLE is ok for filehandle
if ( $sub_name =~ /[a-z]/ ) {
# could be bug caused by older perltidy if
# followed by '('
if ( $input_line =~ m/\G\s*\(/gc ) {
$self->complain(
"Caution: unknown word '$tok' in indirect object slot\n"
);
}
}
}
# bareword not followed by a space -- may not be filehandle
# (may be function call defined in a 'use' statement)
else {
$type = 'Z';
}
}
# none of the above special types
else {
}
}
# Now we must convert back from character position
# to pre_token index.
# I don't think an error flag can occur here ..but who knows
my $error;
( $i, $error ) =
inverse_pretoken_map( $i, $pos, $rtoken_map, $max_token_index );
if ($error) {
$self->warning(
"scan_bare_identifier: Possibly invalid tokenization\n");
}
}
# no match but line not blank - could be syntax error
# perl will take '::' alone without complaint
else {
$type = 'w';
# change this warning to log message if it becomes annoying
$self->warning("didn't find identifier after leading ::\n");
}
return ( $i, $tok, $type, $prototype );
} ## end sub scan_bare_identifier_do
sub scan_id_do {
my (
$self,
$input_line,
$i,
$tok,
$rtokens,
$rtoken_map,
$id_scan_state,
$max_token_index
) = @_;
# Scan identifier following a type token.
# Given:
# current scan state variables
# This is the new scanner and may eventually replace scan_identifier.
# Only type 'sub' and 'package' are implemented.
# Token types $ * % @ & -> are not yet implemented.
#
# The type of call depends on $id_scan_state: $id_scan_state = ''
# for starting call, in which case $tok must be the token defining
# the type.
#
# If the type token is the last nonblank token on the line, a value
# of $id_scan_state = $tok is returned, indicating that further
# calls must be made to get the identifier. If the type token is
# not the last nonblank token on the line, the identifier is
# scanned and handled and a value of '' is returned.
use constant DEBUG_NSCAN => 0;
my $type = EMPTY_STRING;
my $i_beg;
#print "NSCAN:entering i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
#my ($a,$b,$c) = caller;
#print "NSCAN: scan_id called with tok=$tok $a $b $c\n";
# on re-entry, start scanning at first token on the line
if ($id_scan_state) {
$i_beg = $i;
$type = EMPTY_STRING;
}
# on initial entry, start scanning just after type token
else {
$i_beg = $i + 1;
$id_scan_state = $tok;
$type = 't';
}
# find $i_beg = index of next nonblank token,
# and handle empty lines
my $blank_line = 0;
my $next_nonblank_token = $rtokens->[$i_beg];
if ( $i_beg > $max_token_index ) {
$blank_line = 1;
}
else {
# only a '#' immediately after a '$' is not a comment
if ( $next_nonblank_token eq '#' ) {
if ( $tok ne '$' ) {
$blank_line = 1;
}
}
if ( $next_nonblank_token =~ /^\s/ ) {
( $next_nonblank_token, $i_beg ) =
find_next_nonblank_token_on_this_line( $i_beg, $rtokens,
$max_token_index );
if ( $next_nonblank_token =~ /(^#|^\s*$)/ ) {
$blank_line = 1;
}
}
}
# handle non-blank line; identifier, if any, must follow
if ( !$blank_line ) {
if ( $is_sub{$id_scan_state} ) {
( $i, $tok, $type, $id_scan_state ) = $self->do_scan_sub(
{
input_line => $input_line,
i => $i,
i_beg => $i_beg,
tok => $tok,
type => $type,
rtokens => $rtokens,
rtoken_map => $rtoken_map,
id_scan_state => $id_scan_state,
max_token_index => $max_token_index,
}
);
}
elsif ( $is_package{$id_scan_state} ) {
( $i, $tok, $type ) = $self->do_scan_package(
{
input_line => $input_line,
i => $i,
i_beg => $i_beg,
tok => $tok,
type => $type,
rtokens => $rtokens,
rtoken_map => $rtoken_map,
max_token_index => $max_token_index,
}
);
$id_scan_state = EMPTY_STRING;
}
else {
$self->warning("invalid token in scan_id: $tok\n");
$id_scan_state = EMPTY_STRING;
}
}
if ( $id_scan_state && ( !defined($type) || !$type ) ) {
# shouldn't happen:
if (DEVEL_MODE) {
$self->Fault(<warning(
"Possible program bug in sub scan_id: undefined type but scan_state=$id_scan_state\n"
);
$self->report_definite_bug();
}
DEBUG_NSCAN && do {
print {*STDOUT}
"NSCAN: returns i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
};
return ( $i, $tok, $type, $id_scan_state );
} ## end sub scan_id_do
sub check_prototype {
my ( $proto, $package, $subname ) = @_;
# Classify a sub based on its prototype
return if ( !defined($package) );
return if ( !defined($subname) );
if ( defined($proto) ) {
$proto =~ s/^\s*\(\s*//;
$proto =~ s/\s*\)$//;
if ($proto) {
$ris_user_function->{$package}{$subname} = 1;
$ruser_function_prototype->{$package}{$subname} = "($proto)";
# prototypes containing '&' must be treated specially..
if ( $proto =~ /\&/ ) {
# right curly braces of prototypes ending in
# '&' may be followed by an operator
if ( $proto =~ /\&$/ ) {
$ris_block_function->{$package}{$subname} = 1;
}
# right curly braces of prototypes NOT ending in
# '&' may NOT be followed by an operator
else {
$ris_block_list_function->{$package}{$subname} = 1;
}
}
}
else {
$ris_constant->{$package}{$subname} = 1;
}
}
else {
$ris_user_function->{$package}{$subname} = 1;
}
return;
} ## end sub check_prototype
sub do_scan_package {
my ( $self, $rcall_hash ) = @_;
my $input_line = $rcall_hash->{input_line};
my $i = $rcall_hash->{i};
my $i_beg = $rcall_hash->{i_beg};
my $tok = $rcall_hash->{tok};
my $type = $rcall_hash->{type};
my $rtokens = $rcall_hash->{rtokens};
my $rtoken_map = $rcall_hash->{rtoken_map};
my $max_token_index = $rcall_hash->{max_token_index};
# Parse a package name.
# This is called with $i_beg equal to the index of the first nonblank
# token following a 'package' token.
# USES GLOBAL VARIABLES: $current_package,
# package NAMESPACE
# package NAMESPACE VERSION
# package NAMESPACE BLOCK
# package NAMESPACE VERSION BLOCK
#
# If VERSION is provided, package sets the $VERSION variable in the given
# namespace to a version object with the VERSION provided. VERSION must be
# a "strict" style version number as defined by the version module: a
# positive decimal number (integer or decimal-fraction) without
# exponentiation or else a dotted-decimal v-string with a leading 'v'
# character and at least three components.
# reference http://perldoc.perl.org/functions/package.html
my $package = undef;
my $pos_beg = $rtoken_map->[$i_beg];
pos($input_line) = $pos_beg;
# handle non-blank line; package name, if any, must follow
if ( $input_line =~ m/\G\s*((?:\w*(?:'|::))*\w*)/gc ) {
$package = $1;
$package = ( defined($1) && $1 ) ? $1 : 'main';
$package =~ s/\'/::/g;
if ( $package =~ /^\:/ ) { $package = 'main' . $package }
$package =~ s/::$//;
my $pos = pos($input_line);
my $numc = $pos - $pos_beg;
$tok = 'package ' . substr( $input_line, $pos_beg, $numc );
$type = 'P'; # Fix for c250, previously 'i'
# Now we must convert back from character position
# to pre_token index.
# I don't think an error flag can occur here ..but ?
my $error;
( $i, $error ) =
inverse_pretoken_map( $i, $pos, $rtoken_map, $max_token_index );
if ($error) { $self->warning("Possibly invalid package\n") }
$current_package = $package;
# we should now have package NAMESPACE
# now expecting VERSION, BLOCK, or ; to follow ...
# package NAMESPACE VERSION
# package NAMESPACE BLOCK
# package NAMESPACE VERSION BLOCK
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
# check that something recognizable follows, but do not parse.
# A VERSION number will be parsed later as a number or v-string in the
# normal way. What is important is to set the statement type if
# everything looks okay so that the operator_expected() routine
# knows that the number is in a package statement.
# Examples of valid primitive tokens that might follow are:
# 1235 . ; { } v3 v
# FIX: added a '#' since a side comment may also follow
# Added ':' for class attributes (for --use-feature=class, rt145706)
if ( $next_nonblank_token =~ /^([v\.\d;\{\}\#\:])|v\d|\d+$/ ) {
$statement_type = $tok;
}
else {
$self->warning(
"Unexpected '$next_nonblank_token' after package name '$tok'\n"
);
}
}
# no match but line not blank --
# could be a label with name package, like package: , for example.
else {
$type = 'k';
}
return ( $i, $tok, $type );
} ## end sub do_scan_package
{ ## begin closure for sub scan_complex_identifier
use constant DEBUG_SCAN_ID => 0;
# Constant hash:
my %is_special_variable_char;
BEGIN {
# These are the only characters which can (currently) form special
# variables, like $^W: (issue c066).
my @q =
qw{ ? A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \ ] ^ _ };
@is_special_variable_char{@q} = (1) x scalar(@q);
} ## end BEGIN
# These are the possible states for this scanner:
my $scan_state_SIGIL = '$';
my $scan_state_ALPHA = 'A';
my $scan_state_COLON = ':';
my $scan_state_LPAREN = '(';
my $scan_state_RPAREN = ')';
my $scan_state_AMPERSAND = '&';
my $scan_state_SPLIT = '^';
# Only these non-blank states may be returned to caller:
my %is_returnable_scan_state = (
$scan_state_SIGIL => 1,
$scan_state_AMPERSAND => 1,
);
# USES GLOBAL VARIABLES:
# $context, $last_nonblank_token, $last_nonblank_type
#-----------
# call args:
#-----------
my ( $i, $id_scan_state, $identifier, $rtokens, $max_token_index,
$expecting, $container_type );
#-------------------------------------------
# my variables, re-initialized on each call:
#-------------------------------------------
my $i_begin; # starting index $i
my $type; # returned identifier type
my $tok_begin; # starting token
my $tok; # returned token
my $id_scan_state_begin; # starting scan state
my $identifier_begin; # starting identifier
my $i_save; # a last good index, in case of error
my $message; # hold error message for log file
my $tok_is_blank;
my $last_tok_is_blank;
my $in_prototype_or_signature;
my $saw_alpha;
my $saw_type;
my $allow_tick;
sub initialize_my_scan_id_vars {
# Initialize all 'my' vars on entry
$i_begin = $i;
$type = EMPTY_STRING;
$tok_begin = $rtokens->[$i_begin];
$tok = $tok_begin;
if ( $tok_begin eq ':' ) { $tok_begin = '::' }
$id_scan_state_begin = $id_scan_state;
$identifier_begin = $identifier;
$i_save = undef;
$message = EMPTY_STRING;
$tok_is_blank = undef; # a flag to speed things up
$last_tok_is_blank = undef;
$in_prototype_or_signature =
$container_type && $container_type =~ /^sub\b/;
# these flags will be used to help figure out the type:
$saw_alpha = undef;
$saw_type = undef;
# allow old package separator (') except in 'use' statement
$allow_tick = ( $last_nonblank_token ne 'use' );
return;
} ## end sub initialize_my_scan_id_vars
#----------------------------------
# Routines for handling scan states
#----------------------------------
sub do_id_scan_state_dollar {
my $self = shift;
# We saw a sigil, now looking to start a variable name
if ( $tok eq '$' ) {
$identifier .= $tok;
# we've got a punctuation variable if end of line (punct.t)
if ( $i == $max_token_index ) {
$type = 'i';
$id_scan_state = EMPTY_STRING;
}
}
elsif ( $tok =~ /^\w/ ) { # alphanumeric ..
$saw_alpha = 1;
$identifier .= $tok;
# now need :: except for special digit vars like '$1' (c208)
$id_scan_state = $tok =~ /^\d/ ? EMPTY_STRING : $scan_state_COLON;
}
elsif ( $tok eq '::' ) {
$id_scan_state = $scan_state_ALPHA;
$identifier .= $tok;
}
# POSTDEFREF ->@ ->% ->& ->*
elsif ( ( $tok =~ /^[\@\%\&\*]$/ ) && $identifier =~ /\-\>$/ ) {
$identifier .= $tok;
}
elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
$saw_alpha = 1;
$id_scan_state = $scan_state_COLON; # now need ::
$identifier .= $tok;
# Perl will accept leading digits in identifiers,
# although they may not always produce useful results.
# Something like $main::0 is ok. But this also works:
#
# sub howdy::123::bubba{ print "bubba $54321!\n" }
# howdy::123::bubba();
#
}
elsif ( $tok eq '#' ) {
my $is_punct_var = $identifier eq '$$';
# side comment or identifier?
if (
# A '#' starts a comment if it follows a space. For example,
# the following is equivalent to $ans=40.
# my $ #
# ans = 40;
!$last_tok_is_blank
# a # inside a prototype or signature can only start a
# comment
&& !$in_prototype_or_signature
# these are valid punctuation vars: *# %# @# $#
# May also be '$#array' or POSTDEFREF ->$#
&& ( $identifier =~ /^[\%\@\$\*]$/
|| $identifier =~ /\$$/ )
# but a '#' after '$$' is a side comment; see c147
&& !$is_punct_var
)
{
$identifier .= $tok; # keep same state, a $ could follow
}
else {
# otherwise it is a side comment
if ( $identifier eq '->' ) { }
elsif ($is_punct_var) { $type = 'i' }
elsif ( $id_scan_state eq $scan_state_SIGIL ) { $type = 't' }
else { $type = 'i' }
$i = $i_save;
$id_scan_state = EMPTY_STRING;
}
}
elsif ( $tok eq '{' ) {
# check for something like ${#} or ${?}, where ? is a special char
if (
(
$identifier eq '$'
|| $identifier eq '@'
|| $identifier eq '$#'
)
&& $i + 2 <= $max_token_index
&& $rtokens->[ $i + 2 ] eq '}'
&& $rtokens->[ $i + 1 ] !~ /[\s\w]/
)
{
my $next2 = $rtokens->[ $i + 2 ];
my $next1 = $rtokens->[ $i + 1 ];
$identifier .= $tok . $next1 . $next2;
$i += 2;
$id_scan_state = EMPTY_STRING;
}
else {
# skip something like ${xxx} or ->{
$id_scan_state = EMPTY_STRING;
# if this is the first token of a line, any tokens for this
# identifier have already been accumulated
if ( $identifier eq '$' || $i == 0 ) {
$identifier = EMPTY_STRING;
}
$i = $i_save;
}
}
# space ok after leading $ % * & @
elsif ( $tok =~ /^\s*$/ ) {
$tok_is_blank = 1;
# note: an id with a leading '&' does not actually come this way
if ( $identifier =~ /^[\$\%\*\&\@]/ ) {
if ( length($identifier) > 1 ) {
$id_scan_state = EMPTY_STRING;
$i = $i_save;
$type = 'i'; # probably punctuation variable
}
else {
# fix c139: trim line-ending type 't'
if ( $i == $max_token_index ) {
$i = $i_save;
$type = 't';
}
# spaces after $'s are common, and space after @
# is harmless, so only complain about space
# after other type characters. Space after $ and
# @ will be removed in formatting. Report space
# after % and * because they might indicate a
# parsing error. In other words '% ' might be a
# modulo operator. Delete this warning if it
# gets annoying.
elsif ( $identifier !~ /^[\@\$]$/ ) {
$message =
"Space in identifier, following $identifier\n";
}
else {
# silently accept space after '$' and '@' sigils
}
}
}
elsif ( $identifier eq '->' ) {
# space after '->' is ok except at line end ..
# so trim line-ending in type '->' (fixes c139)
if ( $i == $max_token_index ) {
$i = $i_save;
$type = '->';
}
}
# stop at space after something other than -> or sigil
# Example of what can arrive here:
# eval { $MyClass->$$ };
else {
$id_scan_state = EMPTY_STRING;
$i = $i_save;
$type = 'i';
}
}
elsif ( $tok eq '^' ) {
# check for some special variables like $^ $^W
if ( $identifier =~ /^[\$\*\@\%]$/ ) {
$identifier .= $tok;
$type = 'i';
# There may be one more character, not a space, after the ^
my $next1 = $rtokens->[ $i + 1 ];
my $chr = substr( $next1, 0, 1 );
if ( $is_special_variable_char{$chr} ) {
# It is something like $^W
# Test case (c066) : $^Oeq'linux'
$i++;
$identifier .= $next1;
# If pretoken $next1 is more than one character long,
# set a flag indicating that it needs to be split.
$id_scan_state =
( length($next1) > 1 ) ? $scan_state_SPLIT : EMPTY_STRING;
}
else {
# it is just $^
# Simple test case (c065): '$aa=$^if($bb)';
$id_scan_state = EMPTY_STRING;
}
}
else {
$id_scan_state = EMPTY_STRING;
$i = $i_save;
}
}
else { # something else
if ( $in_prototype_or_signature && $tok =~ /^[\),=#]/ ) {
# We might be in an extrusion of
# sub foo2 ( $first, $, $third ) {
# looking at a line starting with a comma, like
# $
# ,
# in this case the comma ends the signature variable
# '$' which will have been previously marked type 't'
# rather than 'i'.
if ( $i == $i_begin ) {
$identifier = EMPTY_STRING;
$type = EMPTY_STRING;
}
# at a # we have to mark as type 't' because more may
# follow, otherwise, in a signature we can let '$' be an
# identifier here for better formatting.
# See 'mangle4.in' for a test case.
else {
$type = 'i';
if ( $id_scan_state eq $scan_state_SIGIL && $tok eq '#' ) {
$type = 't';
}
$i = $i_save;
}
$id_scan_state = EMPTY_STRING;
}
# check for various punctuation variables
elsif ( $identifier =~ /^[\$\*\@\%]$/ ) {
$identifier .= $tok;
}
# POSTDEFREF: Postfix reference ->$* ->%* ->@* ->** ->&* ->$#*
elsif ($tok eq '*'
&& $identifier =~ /\-\>([\@\%\$\*\&]|\$\#)$/ )
{
$identifier .= $tok;
}
elsif ( $identifier eq '$#' ) {
if ( $tok eq '{' ) { $type = 'i'; $i = $i_save }
# perl seems to allow just these: $#: $#- $#+
elsif ( $tok =~ /^[\:\-\+]$/ ) {
$type = 'i';
$identifier .= $tok;
}
else {
$i = $i_save;
$self->write_logfile_entry(
'Use of $# is deprecated' . "\n" );
}
}
elsif ( $identifier eq '$$' ) {
# perl does not allow references to punctuation
# variables without braces. For example, this
# won't work:
# $:=\4;
# $a = $$:;
# You would have to use
# $a = ${$:};
# '$$' alone is punctuation variable for PID
$i = $i_save;
if ( $tok eq '{' ) { $type = 't' }
else { $type = 'i' }
}
elsif ( $identifier eq '->' ) {
$i = $i_save;
}
else {
$i = $i_save;
if ( length($identifier) == 1 ) {
$identifier = EMPTY_STRING;
}
}
$id_scan_state = EMPTY_STRING;
}
return;
} ## end sub do_id_scan_state_dollar
sub do_id_scan_state_alpha {
my $self = shift;
# looking for alphanumeric after ::
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok =~ /^\w/ ) { # found it
$identifier .= $tok;
$id_scan_state = $scan_state_COLON; # now need ::
$saw_alpha = 1;
}
elsif ( $tok eq "'" && $allow_tick ) {
$identifier .= $tok;
$id_scan_state = $scan_state_COLON; # now need ::
$saw_alpha = 1;
}
elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
$id_scan_state = $scan_state_LPAREN;
$identifier .= $tok;
}
elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
$id_scan_state = $scan_state_RPAREN;
$identifier .= $tok;
}
else {
$id_scan_state = EMPTY_STRING;
$i = $i_save;
}
return;
} ## end sub do_id_scan_state_alpha
sub do_id_scan_state_colon {
my $self = shift;
# looking for possible :: after alphanumeric
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok eq '::' ) { # got it
$identifier .= $tok;
$id_scan_state = $scan_state_ALPHA; # now require alpha
}
elsif ( $tok =~ /^\w/ ) { # more alphanumeric is ok here
$identifier .= $tok;
$id_scan_state = $scan_state_COLON; # now need ::
$saw_alpha = 1;
}
elsif ( $tok eq "'" && $allow_tick ) { # tick
if ( $is_keyword{$identifier} ) {
$id_scan_state = EMPTY_STRING; # that's all
$i = $i_save;
}
else {
$identifier .= $tok;
}
}
elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
$id_scan_state = $scan_state_LPAREN;
$identifier .= $tok;
}
elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
$id_scan_state = $scan_state_RPAREN;
$identifier .= $tok;
}
else {
$id_scan_state = EMPTY_STRING; # that's all
$i = $i_save;
}
return;
} ## end sub do_id_scan_state_colon
sub do_id_scan_state_left_paren {
my $self = shift;
# looking for possible '(' of a prototype
if ( $tok eq '(' ) { # got it
$identifier .= $tok;
$id_scan_state = $scan_state_RPAREN; # now find the end of it
}
elsif ( $tok =~ /^\s*$/ ) { # blank - keep going
$identifier .= $tok;
$tok_is_blank = 1;
}
else {
$id_scan_state = EMPTY_STRING; # that's all - no prototype
$i = $i_save;
}
return;
} ## end sub do_id_scan_state_left_paren
sub do_id_scan_state_right_paren {
my $self = shift;
# looking for a ')' of prototype to close a '('
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok eq ')' ) { # got it
$identifier .= $tok;
$id_scan_state = EMPTY_STRING; # all done
}
elsif ( $tok =~ /^[\s\$\%\\\*\@\&\;]/ ) {
$identifier .= $tok;
}
else { # probable error in script, but keep going
$self->warning(
"Unexpected '$tok' while seeking end of prototype\n");
$identifier .= $tok;
}
return;
} ## end sub do_id_scan_state_right_paren
sub do_id_scan_state_ampersand {
my $self = shift;
# Starting sub call after seeing an '&'
if ( $tok =~ /^[\$\w]/ ) { # alphanumeric ..
$id_scan_state = $scan_state_COLON; # now need ::
$saw_alpha = 1;
$identifier .= $tok;
}
elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
$id_scan_state = $scan_state_COLON; # now need ::
$saw_alpha = 1;
$identifier .= $tok;
}
elsif ( $tok =~ /^\s*$/ ) { # allow space
$tok_is_blank = 1;
# fix c139: trim line-ending type 't'
if ( length($identifier) == 1 && $i == $max_token_index ) {
$i = $i_save;
$type = 't';
}
}
elsif ( $tok eq '::' ) { # leading ::
$id_scan_state = $scan_state_ALPHA; # accept alpha next
$identifier .= $tok;
}
elsif ( $tok eq '{' ) {
if ( $identifier eq '&' || $i == 0 ) {
$identifier = EMPTY_STRING;
}
$i = $i_save;
$id_scan_state = EMPTY_STRING;
}
elsif ( $tok eq '^' ) {
if ( $identifier eq '&' ) {
# Special variable (c066)
$identifier .= $tok;
$type = 'i';
# To be a special $^ variable, there may be one more character,
# not a space, after the ^
my $next1 = $rtokens->[ $i + 1 ];
my $chr = substr( $next1, 0, 1 );
if ( $is_special_variable_char{$chr} ) {
# It is something like &^O
$i++;
$identifier .= $next1;
# If pretoken $next1 is more than one character long,
# set a flag indicating that it needs to be split.
$id_scan_state =
( length($next1) > 1 ) ? $scan_state_SPLIT : EMPTY_STRING;
}
else {
# It is &^. This is parsed by perl as a call to sub '^',
# even though it would be difficult to create a sub '^'.
# So we mark it as an identifier (c068).
$id_scan_state = EMPTY_STRING;
}
}
else {
$identifier = EMPTY_STRING;
$i = $i_save;
}
}
else {
# punctuation variable?
# testfile: cunningham4.pl
#
# We have to be careful here. If we are in an unknown state,
# we will reject the punctuation variable. In the following
# example the '&' is a binary operator but we are in an unknown
# state because there is no sigil on 'Prima', so we don't
# know what it is. But it is a bad guess that
# '&~' is a function variable.
# $self->{text}->{colorMap}->[
# Prima::PodView::COLOR_CODE_FOREGROUND
# & ~tb::COLOR_INDEX ] =
# $sec->{ColorCode}
# Fix for case c033: a '#' here starts a side comment
if ( $identifier eq '&' && $expecting && $tok ne '#' ) {
$identifier .= $tok;
}
else {
$identifier = EMPTY_STRING;
$i = $i_save;
$type = '&';
}
$id_scan_state = EMPTY_STRING;
}
return;
} ## end sub do_id_scan_state_ampersand
#-------------------
# hash of scanner subs
#-------------------
my $scan_identifier_code = {
$scan_state_SIGIL => \&do_id_scan_state_dollar,
$scan_state_ALPHA => \&do_id_scan_state_alpha,
$scan_state_COLON => \&do_id_scan_state_colon,
$scan_state_LPAREN => \&do_id_scan_state_left_paren,
$scan_state_RPAREN => \&do_id_scan_state_right_paren,
$scan_state_AMPERSAND => \&do_id_scan_state_ampersand,
};
sub scan_complex_identifier {
(
my $self,
$i,
$id_scan_state,
$identifier,
$rtokens,
$max_token_index,
$expecting,
$container_type
) = @_;
# This routine assembles tokens into identifiers. It maintains a
# scan state, id_scan_state. It updates id_scan_state based upon
# current id_scan_state and token, and returns an updated
# id_scan_state and the next index after the identifier.
# This routine now serves a a backup for sub scan_simple_identifier
# which handles most identifiers.
# Note that $self must be a 'my' variable and not be a closure
# variables like the other args. Otherwise it will not get
# deleted by a DESTROY call at the end of a file. Then an
# attempt to create multiple tokenizers can occur when multiple
# files are processed, causing an error.
# return flag telling caller to split the pretoken
my $split_pretoken_flag;
#-------------------
# Initialize my vars
#-------------------
initialize_my_scan_id_vars();
#--------------------------------------------------------
# get started by defining a type and a state if necessary
#--------------------------------------------------------
if ( !$id_scan_state ) {
$context = UNKNOWN_CONTEXT;
# fixup for digraph
if ( $tok eq '>' ) {
$tok = '->';
$tok_begin = $tok;
}
$identifier = $tok;
if ( $last_nonblank_token eq '->' ) {
$identifier = '->' . $identifier;
$id_scan_state = $scan_state_SIGIL;
}
elsif ( $tok eq '$' || $tok eq '*' ) {
$id_scan_state = $scan_state_SIGIL;
$context = SCALAR_CONTEXT;
}
elsif ( $tok eq '%' || $tok eq '@' ) {
$id_scan_state = $scan_state_SIGIL;
$context = LIST_CONTEXT;
}
elsif ( $tok eq '&' ) {
$id_scan_state = $scan_state_AMPERSAND;
}
elsif ( $tok eq 'sub' or $tok eq 'package' ) {
$saw_alpha = 0; # 'sub' is considered type info here
$id_scan_state = $scan_state_SIGIL;
$identifier .=
SPACE; # need a space to separate sub from sub name
}
elsif ( $tok eq '::' ) {
$id_scan_state = $scan_state_ALPHA;
}
elsif ( $tok =~ /^\w/ ) {
$id_scan_state = $scan_state_COLON;
$saw_alpha = 1;
}
elsif ( $tok eq '->' ) {
$id_scan_state = $scan_state_SIGIL;
}
else {
# shouldn't happen: bad call parameter
my $msg =
"Program bug detected: scan_complex_identifier received bad starting token = '$tok'\n";
if (DEVEL_MODE) { $self->Fault($msg) }
if ( !$self->[_in_error_] ) {
$self->warning($msg);
$self->[_in_error_] = 1;
}
$id_scan_state = EMPTY_STRING;
# emergency return
goto RETURN;
}
$saw_type = !$saw_alpha;
}
else {
$i--;
$saw_alpha = ( $tok =~ /^\w/ );
$saw_type = ( $tok =~ /([\$\%\@\*\&])/ );
# check for a valid starting state
if ( DEVEL_MODE && !$is_returnable_scan_state{$id_scan_state} ) {
$self->Fault(<{$id_scan_state};
if ( !$code ) {
if ( $id_scan_state eq $scan_state_SPLIT ) {
## OK: this is the signal to exit and split the pretoken
}
# unknown state - should not happen
else {
if (DEVEL_MODE) {
$self->Fault(<[ ++$i ];
# patch to make digraph :: if necessary
if ( ( $tok eq ':' ) && ( $rtokens->[ $i + 1 ] eq ':' ) ) {
$tok = '::';
$i++;
}
$code->($self);
# check for forward progress: a decrease in the index $i
# implies that scanning has finished
last if ( $i <= $i_start_loop );
} ## end while ( $i < $max_token_index...)
#-------------
# Check result
#-------------
# Be sure a valid state is returned
if ($id_scan_state) {
if ( !$is_returnable_scan_state{$id_scan_state} ) {
if ( $id_scan_state eq $scan_state_SPLIT ) {
$split_pretoken_flag = 1;
}
if ( $id_scan_state eq $scan_state_RPAREN ) {
$self->warning(
"Hit end of line while seeking ) to end prototype\n");
}
$id_scan_state = EMPTY_STRING;
}
# Patch: the deprecated variable $# does not combine with anything
# on the next line.
if ( $identifier eq '$#' ) { $id_scan_state = EMPTY_STRING }
}
# Be sure the token index is valid
if ( $i < 0 ) { $i = 0 }
# Be sure a token type is defined
if ( !$type ) {
if ($saw_type) {
if ($saw_alpha) {
# The type without the -> should be the same as with the -> so
# that if they get separated we get the same bond strengths,
# etc. See b1234
if ( $identifier =~ /^->/
&& $last_nonblank_type eq 'w'
&& substr( $identifier, 2, 1 ) =~ /^\w/ )
{
$type = 'w';
}
else { $type = 'i' }
}
elsif ( $identifier eq '->' ) {
$type = '->';
}
elsif (
( length($identifier) > 1 )
# In something like '@$=' we have an identifier '@$'
# In something like '$${' we have type '$$' (and only
# part of an identifier)
&& !( $identifier =~ /\$$/ && $tok eq '{' )
&& $identifier ne 'sub '
&& $identifier ne 'package '
)
{
$type = 'i';
}
else { $type = 't' }
}
elsif ($saw_alpha) {
# type 'w' includes anything without leading type info
# ($,%,@,*) including something like abc::def::ghi
$type = 'w';
# Fix for b1337, if restarting scan after line break between
# '->' or sigil and identifier name, use type 'i'
if ( $id_scan_state_begin
&& $identifier =~ /^([\$\%\@\*\&]|->)/ )
{
$type = 'i';
}
}
else {
$type = EMPTY_STRING;
} # this can happen on a restart
}
# See if we formed an identifier...
if ($identifier) {
$tok = $identifier;
if ($message) { $self->write_logfile_entry($message) }
}
# did not find an identifier, back up
else {
$tok = $tok_begin;
$i = $i_begin;
}
RETURN:
DEBUG_SCAN_ID && do {
my ( $a, $b, $c ) = caller();
print {*STDOUT}
"SCANID: called from $a $b $c with tok, i, state, identifier =$tok_begin, $i_begin, $id_scan_state_begin, $identifier_begin\n";
print {*STDOUT}
"SCANID: returned with tok, i, state, identifier =$tok, $i, $id_scan_state, $identifier\n";
};
return (
$i,
$tok,
$type,
$id_scan_state,
$identifier,
$split_pretoken_flag
);
} ## end sub scan_complex_identifier
} ## end closure for sub scan_complex_identifier
{ ## closure for sub do_scan_sub
my %warn_if_lexical;
BEGIN {
# lexical subs with these names can cause parsing errors in this version
my @q = qw( m q qq qr qw qx s tr y );
@warn_if_lexical{@q} = (1) x scalar(@q);
} ## end BEGIN
# saved package and subnames in case prototype is on separate line
my ( $package_saved, $subname_saved );
# initialize subname each time a new 'sub' keyword is encountered
sub initialize_subname {
$package_saved = EMPTY_STRING;
$subname_saved = EMPTY_STRING;
return;
}
use constant {
SUB_CALL => 1,
PAREN_CALL => 2,
PROTOTYPE_CALL => 3,
};
sub do_scan_sub {
my ( $self, $rcall_hash ) = @_;
my $input_line = $rcall_hash->{input_line};
my $i = $rcall_hash->{i};
my $i_beg = $rcall_hash->{i_beg};
my $tok = $rcall_hash->{tok};
my $type = $rcall_hash->{type};
my $rtokens = $rcall_hash->{rtokens};
my $rtoken_map = $rcall_hash->{rtoken_map};
my $id_scan_state = $rcall_hash->{id_scan_state};
my $max_token_index = $rcall_hash->{max_token_index};
# Parse a sub name and prototype.
# At present there are three basic CALL TYPES which are
# distinguished by the starting value of '$tok':
# 1. $tok='sub', id_scan_state='sub'
# it is called with $i_beg equal to the index of the first nonblank
# token following a 'sub' token.
# 2. $tok='(', id_scan_state='sub',
# it is called with $i_beg equal to the index of a '(' which may
# start a prototype.
# 3. $tok='prototype', id_scan_state='prototype'
# it is called with $i_beg equal to the index of a '(' which is
# preceded by ': prototype' and has $id_scan_state eq 'prototype'
# Examples:
# A single type 1 call will get both the sub and prototype
# sub foo1 ( $$ ) { }
# ^
# The subname will be obtained with a 'sub' call
# The prototype on line 2 will be obtained with a '(' call
# sub foo1
# ^ <---call type 1
# ( $$ ) { }
# ^ <---call type 2
# The subname will be obtained with a 'sub' call
# The prototype will be obtained with a 'prototype' call
# sub foo1 ( $x, $y ) : prototype ( $$ ) { }
# ^ <---type 1 ^ <---type 3
# TODO: add future error checks to be sure we have a valid
# sub name. For example, 'sub &doit' is wrong. Also, be sure
# a name is given if and only if a non-anonymous sub is
# appropriate.
# USES GLOBAL VARS: $current_package, $last_nonblank_token,
# $rsaw_function_definition,
# $statement_type
my $i_entry = $i;
# Determine the CALL TYPE
# 1=sub
# 2=(
# 3=prototype
my $call_type =
$tok eq 'prototype' ? PROTOTYPE_CALL
: $tok eq '(' ? PAREN_CALL
: SUB_CALL;
$id_scan_state = EMPTY_STRING; # normally we get everything in one call
my $subname = $subname_saved;
my $package = $package_saved;
my $proto = undef;
my $attrs = undef;
my $match;
my $pos_beg = $rtoken_map->[$i_beg];
pos($input_line) = $pos_beg;
# Look for the sub NAME if this is a SUB call
if (
$call_type == SUB_CALL
&& $input_line =~ m{\G\s*
((?:\w*(?:'|::))*) # package - something that ends in :: or '
(\w+) # NAME - required
}gcx
)
{
$match = 1;
$subname = $2;
my $is_lexical_sub =
$last_nonblank_type eq 'k' && $last_nonblank_token eq 'my';
if ( $is_lexical_sub && $1 ) {
$self->warning("'my' sub $subname cannot be in package '$1'\n");
$is_lexical_sub = 0;
}
if ($is_lexical_sub) {
# lexical subs use the block sequence number as a package name
my $seqno =
$rcurrent_sequence_number->[BRACE]
[ $rcurrent_depth->[BRACE] ];
$seqno = 1 if ( !defined($seqno) );
$package = $seqno;
if ( $warn_if_lexical{$subname} ) {
$self->warning(
"'my' sub '$subname' matches a builtin name and may not be handled correctly in this perltidy version.\n"
);
# This may end badly, it is safest to block formatting
# For an example, see perl527/lexsub.t (issue c203)
$self->[_in_trouble_] = 1;
}
}
else {
$package = ( defined($1) && $1 ) ? $1 : $current_package;
$package =~ s/\'/::/g;
if ( $package =~ /^\:/ ) { $package = 'main' . $package }
$package =~ s/::$//;
}
my $pos = pos($input_line);
my $numc = $pos - $pos_beg;
$tok = 'sub ' . substr( $input_line, $pos_beg, $numc );
$type = 'S'; ## Fix for c250, was 'i';
# remember the sub name in case another call is needed to
# get the prototype
$package_saved = $package;
$subname_saved = $subname;
}
# Now look for PROTO ATTRS for all call types
# Look for prototype/attributes which are usually on the same
# line as the sub name but which might be on a separate line.
# For example, we might have an anonymous sub with attributes,
# or a prototype on a separate line from its sub name
# NOTE: We only want to parse PROTOTYPES here. If we see anything that
# does not look like a prototype, we assume it is a SIGNATURE and we
# will stop and let the the standard tokenizer handle it. In
# particular, we stop if we see any nested parens, braces, or commas.
# Also note, a valid prototype cannot contain any alphabetic character
# -- see https://perldoc.perl.org/perlsub
# But it appears that an underscore is valid in a prototype, so the
# regex below uses [A-Za-z] rather than \w
# This is the old regex which has been replaced:
# $input_line =~ m/\G(\s*\([^\)\(\}\{\,#]*\))? # PROTO
# Added '=' for issue c362
my $saw_opening_paren = $input_line =~ /\G\s*\(/;
if (
$input_line =~ m{\G(\s*\([^\)\(\}\{\,#A-Za-z=]*\))? # PROTO
(\s*:)? # ATTRS leading ':'
}gcx
&& ( $1 || $2 )
)
{
$proto = $1;
$attrs = $2;
# Append the prototype to the starting token if it is 'sub' or
# 'prototype'. This is not necessary but for compatibility with
# previous versions when the -csc flag is used:
if ( $proto && ( $match || $call_type == PROTOTYPE_CALL ) ) {
$tok .= $proto;
}
# If we just entered the sub at an opening paren on this call, not
# a following :prototype, label it with the previous token. This is
# necessary to propagate the sub name to its opening block.
elsif ( $call_type == PAREN_CALL ) {
$tok = $last_nonblank_token;
}
else {
}
$match ||= 1;
# Patch part #1 to fixes cases b994 and b1053:
# Mark an anonymous sub keyword without prototype as type 'k', i.e.
# 'sub : lvalue { ...'
$type = 'S'; ## C250, was 'i';
if ( $tok eq 'sub' && !$proto ) { $type = 'k' }
}
if ($match) {
# ATTRS: if there are attributes, back up and let the ':' be
# found later by the scanner.
my $pos = pos($input_line);
if ($attrs) {
$pos -= length($attrs);
}
my $next_nonblank_token = $tok;
# catch case of line with leading ATTR ':' after anonymous sub
if ( $pos == $pos_beg && $tok eq ':' ) {
$type = 'A';
$self->[_in_attribute_list_] = 1;
}
# Otherwise, if we found a match we must convert back from
# string position to the pre_token index for continued parsing.
else {
# I don't think an error flag can occur here ..but ?
my $error;
( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map,
$max_token_index );
if ($error) { $self->warning("Possibly invalid sub\n") }
# Patch part #2 to fixes cases b994 and b1053:
# Do not let spaces be part of the token of an anonymous sub
# keyword which we marked as type 'k' above...i.e. for
# something like:
# 'sub : lvalue { ...'
# Back up and let it be parsed as a blank
if ( $type eq 'k'
&& $attrs
&& $i > $i_entry
&& substr( $rtokens->[$i], 0, 1 ) =~ m/\s/ )
{
$i--;
}
# check for multiple definitions of a sub
( $next_nonblank_token, my $i_next_uu ) =
find_next_nonblank_token_on_this_line( $i, $rtokens,
$max_token_index );
}
if ( $next_nonblank_token =~ /^(\s*|#)$/ )
{ # skip blank or side comment
my ( $rpre_tokens, $rpre_types_uu ) =
$self->peek_ahead_for_n_nonblank_pre_tokens(1);
if ( defined($rpre_tokens) && @{$rpre_tokens} ) {
$next_nonblank_token = $rpre_tokens->[0];
}
else {
$next_nonblank_token = '}';
}
}
# See what's next...
if ( $next_nonblank_token eq '{' ) {
if ($subname) {
# Check for multiple definitions of a sub, but
# it is ok to have multiple sub BEGIN, etc,
# so we do not complain if name is all caps
if ( $rsaw_function_definition->{$subname}{$package}
&& $subname !~ /^[A-Z]+$/ )
{
my $lno =
$rsaw_function_definition->{$subname}{$package};
if ( $package =~ /^\d/ ) {
$self->warning(
"already saw definition of lexical 'sub $subname' at line $lno\n"
);
}
else {
if ( !DEVEL_MODE ) {
$self->warning(
"already saw definition of 'sub $subname' in package '$package' at line $lno\n"
);
}
}
}
$rsaw_function_definition->{$subname}{$package} =
$self->[_last_line_number_];
}
}
elsif ( $next_nonblank_token eq ';' ) {
}
elsif ( $next_nonblank_token eq '}' ) {
}
# ATTRS - if an attribute list follows, remember the name
# of the sub so the next opening brace can be labeled.
# Setting 'statement_type' causes any ':'s to introduce
# attributes.
elsif ( $next_nonblank_token eq ':' ) {
if ( $call_type == SUB_CALL ) {
$statement_type =
substr( $tok, 0, 3 ) eq 'sub' ? $tok : 'sub';
}
}
# if we stopped before an open paren ...
elsif ( $next_nonblank_token eq '(' ) {
# If we DID NOT see this paren above then it must be on the
# next line so we will set a flag to come back here and see if
# it is a PROTOTYPE
# Otherwise, we assume it is a SIGNATURE rather than a
# PROTOTYPE and let the normal tokenizer handle it as a list
if ( !$saw_opening_paren ) {
$id_scan_state = 'sub'; # we must come back to get proto
}
if ( $call_type == SUB_CALL ) {
$statement_type =
substr( $tok, 0, 3 ) eq 'sub' ? $tok : 'sub';
}
}
# something else..
elsif ($next_nonblank_token) {
if ( $rcall_hash->{tok} eq 'method' && $call_type == SUB_CALL )
{
# For a method call, silently ignore this error (rt145706)
# to avoid needless warnings. Example which can produce it:
# test(method Pack (), "method");
# TODO: scan for use feature 'class' and:
# - if we saw 'use feature 'class' then issue the warning.
# - if we did not see use feature 'class' then issue the
# warning and suggest turning off --use-feature=class
}
else {
$subname = EMPTY_STRING unless defined($subname);
$self->warning(
"expecting ':' or ';' or '{' after definition or declaration of sub '$subname' but saw '$next_nonblank_token'\n"
);
}
}
# EOF technically ok
else {
}
check_prototype( $proto, $package, $subname );
}
# no match to either sub name or prototype, but line not blank
else {
}
return ( $i, $tok, $type, $id_scan_state );
} ## end sub do_scan_sub
}
#########################################################################
# Tokenizer utility routines which may use CONSTANTS but no other GLOBALS
#########################################################################
sub find_next_nonblank_token {
my ( $self, $i, $rtokens, $max_token_index ) = @_;
# Returns the next nonblank token after the token at index $i
# To skip past a side comment, and any subsequent block comments
# and blank lines, call with i=$max_token_index
# Skip any ending blank (fix c258). It would be cleaner if caller passed
# $rtoken_map, so we could check for type 'b', and avoid a regex test, but
# benchmarking shows that this test does not take significant time. So
# that would be a nice update but not essential. Also note that ending
# blanks will not occur for text previously processed by perltidy.
if ( $i == $max_token_index - 1
&& $rtokens->[$max_token_index] =~ /^\s+$/ )
{
$i++;
}
if ( $i >= $max_token_index ) {
if ( !peeked_ahead() ) {
peeked_ahead(1);
$self->peek_ahead_for_nonblank_token( $rtokens, $max_token_index );
}
}
my $next_nonblank_token = $rtokens->[ ++$i ];
# Any more tokens?
return ( SPACE, $i )
if ( !defined($next_nonblank_token) || !length($next_nonblank_token) );
# Skip over whitespace
my $ord = ord( substr( $next_nonblank_token, 0, 1 ) );
if (
( $ord <= ORD_PRINTABLE_MIN || $ord >= ORD_PRINTABLE_MAX )
# Quick test for ascii space or tab
&& (
( $ord == ORD_SPACE || $ord == ORD_TAB )
# Slow test to for something else identified as whitespace
|| $next_nonblank_token =~ /^\s+$/
)
)
{
$next_nonblank_token = $rtokens->[ ++$i ];
return ( SPACE, $i ) unless defined($next_nonblank_token);
}
# We should be at a nonblank now
return ( $next_nonblank_token, $i );
} ## end sub find_next_nonblank_token
sub find_next_noncomment_token {
my ( $self, $i, $rtokens, $max_token_index ) = @_;
# Given the current character position, look ahead past any comments
# and blank lines and return the next token, including digraphs and
# trigraphs.
my ( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
# skip past any side comment
if ( $next_nonblank_token eq '#' ) {
( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i_next, $rtokens,
$max_token_index );
}
# check for a digraph
if ( $next_nonblank_token
&& $next_nonblank_token ne SPACE
&& defined( $rtokens->[ $i_next + 1 ] ) )
{
my $test2 = $next_nonblank_token . $rtokens->[ $i_next + 1 ];
if ( $is_digraph{$test2} ) {
$next_nonblank_token = $test2;
$i_next = $i_next + 1;
# check for a trigraph
if ( defined( $rtokens->[ $i_next + 1 ] ) ) {
my $test3 = $next_nonblank_token . $rtokens->[ $i_next + 1 ];
if ( $is_trigraph{$test3} ) {
$next_nonblank_token = $test3;
$i_next = $i_next + 1;
}
}
}
}
return ( $next_nonblank_token, $i_next );
} ## end sub find_next_noncomment_token
sub is_possible_numerator {
my ( $self, $i, $rtokens, $max_token_index ) = @_;
# Look at the next non-comment character and decide if it could be a
# numerator. Returns the following code:
# -1 - division not possible
# 0 - can't tell if division possible
# 1 - division possible
# 2 - division probable: number follows
# 3 - division very probable: number and one of ; ] } follow
# 4 - is division, not pattern: number and ) follow
my $divide_possible_code = 0;
my $next_token = $rtokens->[ $i + 1 ];
if ( $next_token eq '=' ) { $i++; } # handle /=
my ( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
if ( $next_nonblank_token eq '#' ) {
( $next_nonblank_token, $i_next ) =
$self->find_next_nonblank_token( $max_token_index, $rtokens,
$max_token_index );
}
if ( $next_nonblank_token =~ / [ \( \$ \w \. \@ ] /x ) {
$divide_possible_code = 1;
# look ahead one more token for some common patterns, such as
# pi/2) pi/2; pi/2}
if ( $next_nonblank_token =~ /^\d/ ) {
my ( $next_next_nonblank_token, $i_next_next_uu ) =
$self->find_next_nonblank_token( $i_next, $rtokens,
$max_token_index );
if ( $next_next_nonblank_token eq ')' ) {
$divide_possible_code = 4;
}
elsif ($next_next_nonblank_token eq ';'
|| $next_next_nonblank_token eq ']'
|| $next_next_nonblank_token eq '}' )
{
$divide_possible_code = 3;
}
else {
$divide_possible_code = 2;
}
}
}
elsif ( $next_nonblank_token =~ /^\s*$/ ) {
$divide_possible_code = 0;
}
else {
$divide_possible_code = -1;
}
return $divide_possible_code;
} ## end sub is_possible_numerator
{ ## closure for sub pattern_expected
my %pattern_test;
BEGIN {
# List of tokens which may follow a pattern. Note that we will not
# have formed digraphs at this point, so we will see '&' instead of
# '&&' and '|' instead of '||'
# /(\)|\}|\;|\&\&|\|\||and|or|while|if|unless)/
my @q = qw( & && | || ? : + - * and or while if unless );
push @q, ')', '}', ']', '>', ',', ';';
@pattern_test{@q} = (1) x scalar(@q);
} ## end BEGIN
sub pattern_expected {
my ( $self, $i, $rtokens, $max_token_index ) = @_;
# This a filter for a possible pattern.
# It looks at the token after a possible pattern and tries to
# determine if that token could end a pattern.
# returns -
# 1 - yes
# 0 - can't tell
# -1 - no
my $is_pattern = 0;
my $next_token = $rtokens->[ $i + 1 ];
# skip a possible quote modifier
my $possible_modifiers = $quote_modifiers{'m'};
if ( $next_token =~ /^$possible_modifiers/ ) {
$i++;
}
my ( $next_nonblank_token, $i_next_uu ) =
$self->find_next_nonblank_token( $i, $rtokens, $max_token_index );
if ( $pattern_test{$next_nonblank_token} ) {
$is_pattern = 1;
}
else {
# Added '#' to fix issue c044
if ( $next_nonblank_token =~ /^\s*$/
|| $next_nonblank_token eq '#' )
{
$is_pattern = 0;
}
else {
$is_pattern = -1;
}
}
return $is_pattern;
} ## end sub pattern_expected
}
sub find_next_nonblank_token_on_this_line {
my ( $i, $rtokens, $max_token_index ) = @_;
my $next_nonblank_token;
if ( $i < $max_token_index ) {
$next_nonblank_token = $rtokens->[ ++$i ];
if ( $next_nonblank_token =~ /^\s*$/ ) {
if ( $i < $max_token_index ) {
$next_nonblank_token = $rtokens->[ ++$i ];
}
}
}
else {
$next_nonblank_token = EMPTY_STRING;
}
return ( $next_nonblank_token, $i );
} ## end sub find_next_nonblank_token_on_this_line
sub find_angle_operator_termination {
my ( $self, $input_line, $i_beg, $rtoken_map, $expecting, $max_token_index )
= @_;
# We are looking at a '<' and want to know if it is an angle operator.
# Return:
# $i = pretoken index of ending '>' if found, current $i otherwise
# $type = 'Q' if found, '>' otherwise
my $i = $i_beg;
my $type = '<';
pos($input_line) = 1 + $rtoken_map->[$i];
my $filter;
my $expecting_TERM = $expecting == TERM;
# we just have to find the next '>' if a term is expected
if ($expecting_TERM) { $filter = '[\>]' }
# we have to guess if we don't know what is expected
elsif ( $expecting == UNKNOWN ) { $filter = '[\>\;\=\#\|\<]' }
# shouldn't happen - we shouldn't be here if operator is expected
else {
if (DEVEL_MODE) {
$self->Fault(<
#
# <$fh>
# <*.c *.h>
# <_>
# ( glob.t)
# <${PREFIX}*img*.$IMAGE_TYPE>
#
#
# <$LATEX2HTMLVERSIONS${dd}html[1-9].[0-9].pl>
#
# Here are some examples of lines which do not have angle operators:
# return unless $self->[2]++ < $#{$self->[1]};
# < 2 || @$t >
#
# the following line from dlister.pl caused trouble:
# print'~'x79,"\n",$D<1024?"0.$D":$D>>10,"K, $C files\n\n\n";
#
# If the '<' starts an angle operator, it must end on this line and
# it must not have certain characters like ';' and '=' in it. I use
# this to limit the testing. This filter should be improved if
# possible.
if ( $input_line =~ /($filter)/g ) {
if ( $1 eq '>' ) {
# We MAY have found an angle operator termination if we get
# here, but we need to do more to be sure we haven't been
# fooled.
my $pos = pos($input_line);
my $pos_beg = $rtoken_map->[$i];
my $str = substr( $input_line, $pos_beg, ( $pos - $pos_beg ) );
# Test for '<' after possible filehandle, issue c103
# print $fh <>; # syntax error
# print $fh ; # ok
# print $fh < DATA>; # syntax error at '>'
# print STDERR < DATA>; # ok, prints word 'DATA'
# print BLABLA ; # ok; does nothing unless BLABLA is defined
if ( $last_nonblank_type eq 'Z' ) {
# $str includes brackets; something like ''
if ( substr( $last_nonblank_token, 0, 1 ) !~ /[A-Za-z_]/
&& substr( $str, 1, 1 ) !~ /[A-Za-z_]/ )
{
return ( $i, $type );
}
}
# Reject if the closing '>' follows a '-' as in:
# if ( VERSION < 5.009 && $op-> name eq 'assign' ) { }
if ( $expecting eq UNKNOWN ) {
my $check = substr( $input_line, $pos - 2, 1 );
if ( $check eq '-' ) {
return ( $i, $type );
}
}
######################################debug#####
#$self->write_diagnostics( "ANGLE? :$str\n");
#print "ANGLE: found $1 at pos=$pos str=$str check=$check\n";
######################################debug#####
$type = 'Q';
my $error;
( $i, $error ) =
inverse_pretoken_map( $i, $pos, $rtoken_map, $max_token_index );
# It may be possible that a quote ends midway in a pretoken.
# If this happens, it may be necessary to split the pretoken.
if ($error) {
if (DEVEL_MODE) {
$self->Fault(<warning(
"Possible tokinization error..please check this line\n");
}
# Check for accidental formatting of a markup language doc...
# Formatting will be skipped if we set _html_tag_count_ and
# also set a warning of any kind.
my $is_html_tag;
my $is_first_string =
$i_beg == 0 && $self->[_last_line_number_] == 1;
# html comment 'warning(
"looks like a markup language, continuing error checks\n"
);
}
}
# html end tag, something like
elsif ( $str =~ /^<\s*\/\w+\s*>$/ ) {
$is_html_tag = 1;
}
# xml prolog?
elsif ( $str =~ /^<\?xml\s.*\?>$/i && $is_first_string ) {
$is_html_tag = 1;
$self->warning(
"looks like a markup language, continuing error checks\n");
}
else {
## doesn't look like a markup tag
}
if ($is_html_tag) {
$self->[_html_tag_count_]++;
}
# count blanks on inside of brackets
my $blank_count = 0;
$blank_count++ if ( $str =~ /<\s+/ );
$blank_count++ if ( $str =~ /\s+>/ );
# Now let's see where we stand....
# OK if math op not possible
if ($expecting_TERM) {
}
elsif ($is_html_tag) {
}
# OK if there are no more than 2 non-blank pre-tokens inside
# (not possible to write 2 token math between < and >)
# This catches most common cases
elsif ( $i <= $i_beg + 3 + $blank_count ) {
# No longer any need to document this common case
## $self->write_diagnostics("ANGLE(1 or 2 tokens): $str\n");
}
# OK if there is some kind of identifier inside
# print $fh ;
elsif ( $str =~ /^<\s*\$?(\w|::|\s)+\s*>$/ ) {
$self->write_diagnostics("ANGLE (contains identifier): $str\n");
}
# Not sure..
else {
# Let's try a Brace Test: any braces inside must balance
my $br = $str =~ tr/\{/{/ - $str =~ tr/\}/}/;
my $sb = $str =~ tr/\[/[/ - $str =~ tr/\]/]/;
my $pr = $str =~ tr/\(/(/ - $str =~ tr/\)/)/;
# if braces do not balance - not angle operator
if ( $br || $sb || $pr ) {
$i = $i_beg;
$type = '<';
$self->write_diagnostics(
"NOT ANGLE (BRACE={$br ($pr [$sb ):$str\n");
}
# we should keep doing more checks here...to be continued
# Tentatively accepting this as a valid angle operator.
# There are lots more things that can be checked.
else {
$self->write_diagnostics(
"ANGLE-Guessing yes: $str expecting=$expecting\n");
$self->write_logfile_entry(
"Guessing angle operator here: $str\n");
}
}
}
# didn't find ending >
else {
if ($expecting_TERM) {
$self->warning("No ending > for angle operator\n");
}
}
}
return ( $i, $type );
} ## end sub find_angle_operator_termination
sub scan_number_do {
my ( $self, $input_line, $i, $rtoken_map, $input_type, $max_token_index ) =
@_;
# Scan a number in any of the formats that Perl accepts
# Underbars (_) are allowed in decimal numbers.
# Given:
# $input_line - the string to scan
# $i - pre_token index to start scanning
# $rtoken_map - reference to the pre_token map giving starting
# character position in $input_line of token $i
# Return:
# $i - last pre_token index of the number just scanned
# $type - the token type ('v' or 'n')
# number - the number (characters); or undef if not a number
my $pos_beg = $rtoken_map->[$i];
my $pos;
##my $i_begin = $i;
my $number = undef;
my $type = $input_type;
my $first_char = substr( $input_line, $pos_beg, 1 );
# Look for bad starting characters; Shouldn't happen..
if ( $first_char !~ /[\d\.\+\-Ee]/ ) {
if (DEVEL_MODE) {
$self->Fault(<warning("Possibly invalid number\n") }
return ( $i, $type, $number );
} ## end sub scan_number_do
sub inverse_pretoken_map {
# Starting with the current pre_token index $i, scan forward until
# finding the index of the next pre_token whose position is $pos.
my ( $i, $pos, $rtoken_map, $max_token_index ) = @_;
my $error = 0;
while ( ++$i <= $max_token_index ) {
if ( $pos <= $rtoken_map->[$i] ) {
# Let the calling routine handle errors in which we do not
# land on a pre-token boundary. It can happen by running
# perltidy on some non-perl scripts, for example.
if ( $pos < $rtoken_map->[$i] ) { $error = 1 }
$i--;
last;
}
} ## end while ( ++$i <= $max_token_index)
return ( $i, $error );
} ## end sub inverse_pretoken_map
sub find_here_doc {
my (
$self,
$expecting,
$i,
$rtokens,
$rtoken_type,
$rtoken_map_uu,
$max_token_index
) = @_;
# Find the target of a here document, if any
# Given:
# $i - token index of the second < of <<
# ($i must be less than the last token index if this is called)
# Return:
# $found_target = 0 didn't find target; =1 found target
# HERE_TARGET - the target string (may be empty string)
# $i - unchanged if not here doc,
# or index of the last token of the here target
# $saw_error - flag noting unbalanced quote on here target
my $ibeg = $i;
my $found_target = 0;
my $here_doc_target = EMPTY_STRING;
my $here_quote_character = EMPTY_STRING;
my $saw_error = 0;
my ( $next_nonblank_token, $i_next_nonblank, $next_token );
$next_token = $rtokens->[ $i + 1 ];
# perl allows a backslash before the target string (heredoc.t)
my $backslash = 0;
if ( $next_token eq BACKSLASH ) {
$backslash = 1;
$next_token = $rtokens->[ $i + 2 ];
}
( $next_nonblank_token, $i_next_nonblank ) =
find_next_nonblank_token_on_this_line( $i, $rtokens, $max_token_index );
if ( $next_nonblank_token =~ /[\'\"\`]/ ) {
my $in_quote = 1;
my $quote_depth = 0;
my $quote_pos = 0;
my $quoted_string;
(
$i,
$in_quote,
$here_quote_character,
$quote_pos,
$quote_depth,
$quoted_string
)
= $self->follow_quoted_string(
$i_next_nonblank,
$in_quote,
$rtokens,
$rtoken_type,
$here_quote_character,
$quote_pos,
$quote_depth,
$max_token_index
);
if ($in_quote) { # didn't find end of quote, so no target found
$i = $ibeg;
if ( $expecting == TERM ) {
$self->warning(
"Did not find here-doc string terminator ($here_quote_character) before end of line \n"
);
$saw_error = 1;
}
}
else { # found ending quote
$found_target = 1;
my $tokj;
foreach my $j ( $i_next_nonblank + 1 .. $i - 1 ) {
$tokj = $rtokens->[$j];
# we have to remove any backslash before the quote character
# so that the here-doc-target exactly matches this string
next
if ( $tokj eq "\\"
&& $j < $i - 1
&& $rtokens->[ $j + 1 ] eq $here_quote_character );
$here_doc_target .= $tokj;
}
}
}
elsif ( ( $next_token =~ /^\s*$/ ) and ( $expecting == TERM ) ) {
$found_target = 1;
$self->write_logfile_entry(
"found blank here-target after <<; suggest using \"\"\n");
$i = $ibeg;
}
elsif ( $next_token =~ /^\w/ ) { # simple bareword or integer after <<
my $here_doc_expected;
if ( $expecting == UNKNOWN ) {
$here_doc_expected = $self->guess_if_here_doc($next_token);
}
else {
$here_doc_expected = 1;
}
if ($here_doc_expected) {
$found_target = 1;
$here_doc_target = $next_token;
$i = $ibeg + 1;
}
}
else {
if ( $expecting == TERM ) {
$found_target = 1;
$self->write_logfile_entry("Note: bare here-doc operator <<\n");
}
else {
$i = $ibeg;
}
}
# patch to neglect any prepended backslash
if ( $found_target && $backslash ) { $i++ }
return ( $found_target, $here_doc_target, $here_quote_character, $i,
$saw_error );
} ## end sub find_here_doc
sub do_quote {
my (
$self,
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string_1,
$quoted_string_2,
$rtokens,
$rtoken_type,
$rtoken_map_uu,
$max_token_index,
) = @_;
# Follow (or continue following) quoted string(s)
# $in_quote = return code:
# 0 - ok, found end
# 1 - still must find end of quote whose target is $quote_character
# 2 - still looking for end of first of two quotes
#
# Returns updated strings:
# $quoted_string_1 = quoted string seen while in_quote=1
# $quoted_string_2 = quoted string seen while in_quote=2
my $quoted_string;
if ( $in_quote == 2 ) { # two quotes/quoted_string_1s to follow
my $ibeg = $i;
(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string
)
= $self->follow_quoted_string(
$ibeg,
$in_quote,
$rtokens,
$rtoken_type,
$quote_character,
$quote_pos,
$quote_depth,
$max_token_index
);
$quoted_string_2 .= $quoted_string;
if ( $in_quote == 1 ) {
if ( $quote_character =~ /[\{\[\<\(]/ ) { $i++; }
$quote_character = EMPTY_STRING;
}
else {
$quoted_string_2 .= "\n";
}
}
if ( $in_quote == 1 ) { # one (more) quote to follow
my $ibeg = $i;
(
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string
)
= $self->follow_quoted_string(
$ibeg,
$in_quote,
$rtokens,
$rtoken_type,
$quote_character,
$quote_pos,
$quote_depth,
$max_token_index
);
$quoted_string_1 .= $quoted_string;
if ( $in_quote == 1 ) {
$quoted_string_1 .= "\n";
}
}
return (
$i,
$in_quote,
$quote_character,
$quote_pos,
$quote_depth,
$quoted_string_1,
$quoted_string_2,
);
} ## end sub do_quote
# Some possible non-word quote delimiters, for preliminary checking
my %is_punct_char;
BEGIN {
my @q = qw# / " ' { } ( ) [ ] < > ; + - * | % ! x ~ = ? : . ^ & #;
push @q, '#';
push @q, ',';
@is_punct_char{@q} = (1) x scalar(@q);
}
sub follow_quoted_string {
my (
$self,
$i_beg,
$in_quote,
$rtokens,
$rtoken_type,
$beginning_tok,
$quote_pos,
$quote_depth,
$max_token_index,
) = @_;
# Scan for a specific token, skipping escaped characters.
# If the quote character is blank, use the first non-blank character.
# Given:
# $rtokens = reference to the array of tokens
# $i = the token index of the first character to search
# $in_quote = number of quoted strings being followed
# $beginning_tok = the starting quote character
# $quote_pos = index to check next for alphanumeric delimiter
# Return:
# $i = the token index of the ending quote character
# $in_quote = decremented if found end, unchanged if not
# $beginning_tok = the starting quote character
# $quote_pos = index to check next for alphanumeric delimiter
# $quote_depth = nesting depth, since delimiters '{ ( [ <' can be nested.
# $quoted_string = the text of the quote (without quotation tokens)
my ( $tok, $end_tok );
my $i = $i_beg - 1;
my $quoted_string = EMPTY_STRING;
0 && do {
print {*STDOUT}
"QUOTE entering with quote_pos = $quote_pos i=$i beginning_tok =$beginning_tok\n";
};
# for a non-blank token, get the corresponding end token
if (
$is_punct_char{$beginning_tok}
|| ( length($beginning_tok)
&& $beginning_tok !~ /^\s+$/ )
)
{
$end_tok =
$matching_end_token{$beginning_tok}
? $matching_end_token{$beginning_tok}
: $beginning_tok;
}
# for a blank token, find and use the first non-blank one
else {
my $allow_quote_comments = ( $i < 0 ) ? 1 : 0; # i<0 means we saw a
while ( $i < $max_token_index ) {
$tok = $rtokens->[ ++$i ];
if ( $rtoken_type->[$i] ne 'b' ) {
if ( ( $tok eq '#' ) && ($allow_quote_comments) ) {
$i = $max_token_index;
}
else {
if ( length($tok) > 1 ) {
if ( $quote_pos <= 0 ) { $quote_pos = 1 }
$beginning_tok = substr( $tok, $quote_pos - 1, 1 );
}
else {
$beginning_tok = $tok;
$quote_pos = 0;
}
$end_tok =
$matching_end_token{$beginning_tok}
? $matching_end_token{$beginning_tok}
: $beginning_tok;
$quote_depth = 1;
last;
}
}
else {
$allow_quote_comments = 1;
}
} ## end while ( $i < $max_token_index)
}
# There are two different loops which search for the ending quote
# character. In the rare case of an alphanumeric quote delimiter, we
# have to look through alphanumeric tokens character-by-character, since
# the pre-tokenization process combines multiple alphanumeric
# characters, whereas for a non-alphanumeric delimiter, only tokens of
# length 1 can match.
#----------------------------------------------------------------
# Case 1 (rare): loop for case of alphanumeric quote delimiter..
# "quote_pos" is the position the current word to begin searching
#----------------------------------------------------------------
if ( !$is_punct_char{$beginning_tok} && $beginning_tok =~ /\w/ ) {
# Note this because it is not recommended practice except
# for obfuscated perl contests
if ( $in_quote == 1 ) {
$self->write_logfile_entry(
"Note: alphanumeric quote delimiter ($beginning_tok) \n");
}
# Note: changed < to <= here to fix c109. Relying on extra end blanks.
while ( $i <= $max_token_index ) {
if ( $quote_pos == 0 || ( $i < 0 ) ) {
$tok = $rtokens->[ ++$i ];
if ( $tok eq BACKSLASH ) {
# retain backslash unless it hides the end token
$quoted_string .= $tok
unless ( $rtokens->[ $i + 1 ] eq $end_tok );
$quote_pos++;
last if ( $i >= $max_token_index );
$tok = $rtokens->[ ++$i ];
}
}
my $old_pos = $quote_pos;
$quote_pos = 1 + index( $tok, $end_tok, $quote_pos );
if ( $quote_pos > 0 ) {
$quoted_string .=
substr( $tok, $old_pos, $quote_pos - $old_pos - 1 );
# NOTE: any quote modifiers will be at the end of '$tok'. If we
# wanted to check them, this is the place to get them. But
# this quote form is rarely used in practice, so it isn't
# worthwhile.
$quote_depth--;
if ( $quote_depth == 0 ) {
$in_quote--;
last;
}
}
else {
if ( $old_pos <= length($tok) ) {
$quoted_string .= substr( $tok, $old_pos );
}
}
} ## end while ( $i <= $max_token_index)
}
#-----------------------------------------------------------------------
# Case 2 (normal): loop for case of a non-alphanumeric quote delimiter..
#-----------------------------------------------------------------------
else {
while ( $i < $max_token_index ) {
$tok = $rtokens->[ ++$i ];
if ( $tok eq $end_tok ) {
$quote_depth--;
if ( $quote_depth == 0 ) {
$in_quote--;
last;
}
}
elsif ( $tok eq $beginning_tok ) {
$quote_depth++;
}
elsif ( $tok eq BACKSLASH ) {
# retain backslash unless it hides the beginning or end token
$tok = $rtokens->[ ++$i ];
$quoted_string .= BACKSLASH
if ( $tok ne $end_tok && $tok ne $beginning_tok );
}
else {
## nothing special
}
$quoted_string .= $tok;
} ## end while ( $i < $max_token_index)
}
if ( $i > $max_token_index ) { $i = $max_token_index }
return (
$i,
$in_quote,
$beginning_tok,
$quote_pos,
$quote_depth,
$quoted_string,
);
} ## end sub follow_quoted_string
sub indicate_error {
my ( $self, $msg, $line_number, $input_line, $pos, $caret ) = @_;
# write input line and line with carat's showing where error was detected
$self->interrupt_logfile();
$self->warning($msg);
$self->write_error_indicator_pair( $line_number, $input_line, $pos,
$caret );
$self->resume_logfile();
return;
} ## end sub indicate_error
sub write_error_indicator_pair {
my ( $self, $line_number, $input_line, $pos, $caret ) = @_;
my ( $offset, $numbered_line, $underline ) =
make_numbered_line( $line_number, $input_line, $pos );
$underline = write_on_underline( $underline, $pos - $offset, $caret );
$self->warning( $numbered_line . "\n" );
$underline =~ s/\s+$//;
$self->warning( $underline . "\n" );
return;
} ## end sub write_error_indicator_pair
sub make_numbered_line {
my ( $lineno, $str, $pos ) = @_;
# Given:
# $lineno=line number
# $str = an input line
# $pos = character position of interest
# Create a string not longer than 80 characters of the form:
# $lineno: sub_string
# such that the sub_string of $str contains the position of interest
#
# Here is an example of what we want, in this case we add trailing
# '...' because the line is long.
#
# 2: (One of QAML 2.0's authors is a member of the World Wide Web Con ...
#
# Here is another example, this time in which we used leading '...'
# because of excessive length:
#
# 2: ... er of the World Wide Web Consortium's
#
# input parameters are:
# $lineno = line number
# $str = the text of the line
# $pos = position of interest (the error) : 0 = first character
#
# We return :
# - $offset = an offset which corrects the position in case we only
# display part of a line, such that $pos-$offset is the effective
# position from the start of the displayed line.
# - $numbered_line = the numbered line as above,
# - $underline = a blank 'underline' which is all spaces with the same
# number of characters as the numbered line.
my $offset = ( $pos < 60 ) ? 0 : $pos - 40;
my $excess = length($str) - $offset - 68;
my $numc = ( $excess > 0 ) ? 68 : undef;
if ( defined($numc) ) {
if ( $offset == 0 ) {
$str = substr( $str, $offset, $numc - 4 ) . " ...";
}
else {
$str = "... " . substr( $str, $offset + 4, $numc - 4 ) . " ...";
}
}
else {
if ( $offset == 0 ) {
}
else {
$str = "... " . substr( $str, $offset + 4 );
}
}
my $numbered_line = sprintf( "%d: ", $lineno );
$offset -= length($numbered_line);
$numbered_line .= $str;
my $underline = SPACE x length($numbered_line);
return ( $offset, $numbered_line, $underline );
} ## end sub make_numbered_line
sub write_on_underline {
my ( $underline, $pos, $pos_chr ) = @_;
# The "underline" is a string that shows where an error is; it starts
# out as a string of blanks with the same length as the numbered line of
# code above it, and we have to add marking to show where an error is.
# In the example below, we want to write the string '--^' just below
# the line of bad code:
#
# 2: (One of QAML 2.0's authors is a member of the World Wide Web Con ...
# ---^
# We are given the current underline string, plus a position and a
# string to write on it.
#
# In the above example, there will be 2 calls to do this:
# First call: $pos=19, pos_chr=^
# Second call: $pos=16, pos_chr=---
#
# This is a trivial thing to do with substr, but there is some
# checking to do.
# check for error..shouldn't happen
if ( $pos < 0 || $pos > length($underline) ) {
return $underline;
}
my $excess = length($pos_chr) + $pos - length($underline);
if ( $excess > 0 ) {
$pos_chr = substr( $pos_chr, 0, length($pos_chr) - $excess );
}
substr( $underline, $pos, length($pos_chr), $pos_chr );
return ($underline);
} ## end sub write_on_underline
sub pre_tokenize {
my ( $str, ($max_tokens_wanted) ) = @_;
# Input parameters:
# $str = string to be parsed
# $max_tokens_wanted > 0 to stop on reaching this many tokens.
# = undef or 0 means get all tokens
# Break a string, $str, into a sequence of preliminary tokens (pre-tokens).
# We look for these types of tokens:
# words (type='w'), example: 'max_tokens_wanted'
# digits (type = 'd'), example: '0755'
# whitespace (type = 'b'), example: ' '
# single character punct (type = char) example: '='
# Later operations will combine one or more of these pre-tokens into final
# tokens. We cannot do better than this yet because we might be in a
# quoted string or pattern.
# An advantage of doing this pre-tokenization step is that it keeps almost
# all of the regex parsing very simple and localized right here. A
# disadvantage is that in some extremely rare instances we will have to go
# back and split a pre-token.
# Return parameters:
my @tokens = (); # array of the tokens themselves
my @token_map = (0); # string position of start of each token
my @type = (); # 'b'=whitespace, 'd'=digits, 'w'=alpha, or punct
if ( !$max_tokens_wanted ) { $max_tokens_wanted = -1 }
while ( $max_tokens_wanted-- ) {
if (
$str =~ m{
\G(
(\s+) # type 'b' = whitespace - this must come before \W
| (\W) # or type=char = single-character, non-whitespace punct
| (\d+) # or type 'd' = sequence of digits - must come before \w
| (\w+) # or type 'w' = words not starting with a digit
)
}gcx
)
{
push @tokens, $1;
push @type,
defined($2) ? 'b' : defined($3) ? $1 : defined($4) ? 'd' : 'w';
push @token_map, pos($str);
}
# that's all..
else {
return ( \@tokens, \@token_map, \@type );
}
} ## end while ( $max_tokens_wanted...)
return ( \@tokens, \@token_map, \@type );
} ## end sub pre_tokenize
sub show_tokens {
# This is an uncalled debug routine, saved for reference
my ( $rtokens, $rtoken_map ) = @_;
my $num = scalar( @{$rtokens} );
foreach my $i ( 0 .. $num - 1 ) {
my $len = length( $rtokens->[$i] );
print {*STDOUT} "$i:$len:$rtoken_map->[$i]:$rtokens->[$i]:\n";
}
return;
} ## end sub show_tokens
sub dump_token_types {
my ( $class, $fh ) = @_;
# This should be the latest list of token types in use
# adding NEW_TOKENS: add a comment here
$fh->print(<<'END_OF_LIST');
Here is a list of the token types currently used for lines of type 'CODE'.
For the following tokens, the "type" of a token is just the token itself.
.. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
( ) <= >= == =~ !~ != ++ -- /= x=
... **= <<= >>= &&= ||= //= <=>
, + - / * | % ! x ~ = \ ? : . < > ^ & ^^
The following additional token types are defined:
type meaning
b blank (white space)
{ indent: opening structural curly brace or square bracket or paren
(code block, anonymous hash reference, or anonymous array reference)
} outdent: right structural curly brace or square bracket or paren
[ left non-structural square bracket (enclosing an array index)
] right non-structural square bracket
( left non-structural paren (all but a list right of an =)
) right non-structural paren
L left non-structural curly brace (enclosing a key)
R right non-structural curly brace
; terminal semicolon
f indicates a semicolon in a "for" statement
h here_doc operator <<
# a comment
Q indicates a quote or pattern
q indicates a qw quote block
k a perl keyword
C user-defined constant or constant function (with void prototype = ())
U user-defined function taking parameters
G user-defined function taking block parameter (like grep/map/eval)
S sub definition (reported as type 'i' in older versions)
P package definition (reported as type 'i' in older versions)
t type indicator such as %,$,@,*,&,sub
w bare word (perhaps a subroutine call)
i identifier of some type (with leading %, $, @, *, &, sub, -> )
n a number
v a v-string
F a file test operator (like -e)
Y File handle
Z identifier in indirect object slot: may be file handle, object
J LABEL: code block label
j LABEL after next, last, redo, goto
p unary +
m unary -
pp pre-increment operator ++
mm pre-decrement operator --
A : used as attribute separator
Here are the '_line_type' codes used internally:
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, '.'
SKIP - code skipping section
SKIP_END - last line of code skipping section, '#>>V'
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
END_OF_LIST
return;
} ## end sub dump_token_types
#------------------
# About Token Types
#------------------
# The array "valid_token_types" in the BEGIN section has an up-to-date list
# of token types. Sub 'dump_token_types' should be kept up to date with
# token types.
# Ideally, tokens are the smallest pieces of text
# such that a newline may be inserted between any pair of tokens without
# changing or invalidating the program. This version comes close to this,
# although there are necessarily a few exceptions which must be caught by
# the formatter. Many of these involve the treatment of bare words.
#
# To simplify things, token types are either a single character, or they
# are identical to the tokens themselves.
#
# As a debugging aid, the -D flag creates a file containing a side-by-side
# comparison of the input string and its tokenization for each line of a file.
# This is an invaluable debugging aid.
#
# In addition to tokens, and some associated quantities, the tokenizer
# also returns flags indication any special line types. These include
# quotes, here_docs, formats.
#
#------------------
# Adding NEW_TOKENS
#------------------
#
# Here are some notes on the minimal steps. I wrote these notes while
# adding the 'v' token type for v-strings, which are things like version
# numbers 5.6.0, and ip addresses, and will use that as an example. ( You
# can use your editor to search for the string "NEW_TOKENS" to find the
# appropriate sections to change):
# *. For another example, search for the smartmatch operator '~~'
# with your editor to see where updates were made for it.
# *. For another example, search for the string 'c250', which shows
# locations where changes for new types 'P' and 'S' were made.
# *. Think of a new, unused character for the token type, and add to
# the array @valid_token_types in the BEGIN section of this package.
# For example, I used 'v' for v-strings.
#
# *. Implement coding to recognize the $type of the token in this routine.
# This is the hardest part, and is best done by imitating or modifying
# some of the existing coding. For example, to recognize v-strings, I
# patched 'sub scan_bare_identifier' to recognize v-strings beginning with
# 'v' and 'sub scan_number' to recognize v-strings without the leading 'v'.
#
# *. Update sub operator_expected. This update is critically important but
# the coding is trivial. Look at the comments in that routine for help.
# For v-strings, which should behave like numbers, I just added 'v' to the
# regex used to handle numbers and strings (types 'n' and 'Q').
#
# *. Implement a 'bond strength' rule in sub set_bond_strengths in
# Perl::Tidy::Formatter for breaking lines around this token type. You can
# skip this step and take the default at first, then adjust later to get
# desired results. For adding type 'v', I looked at sub bond_strength and
# saw that number type 'n' was using default strengths, so I didn't do
# anything. I may tune it up someday if I don't like the way line
# breaks with v-strings look.
#
# *. Implement a 'whitespace' rule in sub set_whitespace_flags in
# Perl::Tidy::Formatter. For adding type 'v', I looked at this routine
# and saw that type 'n' used spaces on both sides, so I just added 'v'
# to the array @spaces_both_sides.
#
# *. Update HtmlWriter package so that users can colorize the token as
# desired. This is quite easy; see comments identified by 'NEW_TOKENS' in
# that package. For v-strings, I initially chose to use a default color
# equal to the default for numbers, but it might be nice to change that
# eventually.
#
# *. Update comments in Perl::Tidy::Tokenizer::dump_token_types.
#
# *. Run lots and lots of debug tests. Start with special files designed
# to test the new token type. Run with the -D flag to create a .DEBUG
# file which shows the tokenization. When these work ok, test as many old
# scripts as possible. Start with all of the '.t' files in the 'test'
# directory of the distribution file. Compare .tdy output with previous
# version and updated version to see the differences. Then include as
# many more files as possible. My own technique has been to collect a huge
# number of perl scripts (thousands!) into one directory and run perltidy
# *, then run diff between the output of the previous version and the
# current version.
BEGIN {
# These names are used in error messages
@opening_brace_names = qw# '{' '[' '(' '?' #;
@closing_brace_names = qw# '}' ']' ')' ':' #;
my @q;
my @digraphs = qw#
.. :: << >> ** && || // -> => += -= .= %= &= |= ^= *= <>
<= >= == =~ !~ != ++ -- /= x= ~~ ~. |. &. ^. ^^
#;
@is_digraph{@digraphs} = (1) x scalar(@digraphs);
@q = qw(
. : < > * & | / - = + - % ^ ! x ~
);
@can_start_digraph{@q} = (1) x scalar(@q);
my @trigraphs = qw( ... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~ );
@is_trigraph{@trigraphs} = (1) x scalar(@trigraphs);
my @tetragraphs = qw( <<>> );
@is_tetragraph{@tetragraphs} = (1) x scalar(@tetragraphs);
# make a hash of all valid token types for self-checking the tokenizer
# (adding NEW_TOKENS : select a new character and add to this list)
# fix for c250: added new token type 'P' and 'S'
my @valid_token_types = qw#
A b C G L R f h Q k t w i q n p m F pp mm U j J Y Z v P S
{ } ( ) [ ] ; + - / * | % ! x ~ = \ ? : . < > ^ &
#;
push( @valid_token_types, @digraphs );
push( @valid_token_types, @trigraphs );
push( @valid_token_types, @tetragraphs );
push( @valid_token_types, ( '#', ',', 'CORE::' ) );
@is_valid_token_type{@valid_token_types} = (1) x scalar(@valid_token_types);
# a list of file test letters, as in -e (Table 3-4 of 'camel 3')
my @file_test_operators =
qw( A B C M O R S T W X b c d e f g k l o p r s t u w x z );
@is_file_test_operator{@file_test_operators} =
(1) x scalar(@file_test_operators);
# these functions have prototypes of the form (&), so when they are
# followed by a block, that block MAY BE followed by an operator.
# Smartmatch operator ~~ may be followed by anonymous hash or array ref
@q = qw( do eval );
@is_block_operator{@q} = (1) x scalar(@q);
# these functions allow an identifier in the indirect object slot
@q = qw( print printf sort exec system say );
@is_indirect_object_taker{@q} = (1) x scalar(@q);
# Note: 'field' will be added by sub check_options if --use-feature=class
@q = qw( my our state );
@is_my_our_state{@q} = (1) x scalar(@q);
# These tokens may precede a code block
# patched for SWITCH/CASE/CATCH. Actually these could be removed
# now and we could let the extended-syntax coding handle them.
# Added 'default' for Switch::Plain.
# Note: 'ADJUST' will be added by sub check_options if --use-feature=class
@q = qw(
BEGIN END CHECK INIT AUTOLOAD DESTROY
UNITCHECK continue if elsif else unless
do while until eval for foreach
map grep sort switch case given
when default catch try finally
);
@is_code_block_token{@q} = (1) x scalar(@q);
# Note: this hash was formerly named '%is_not_zero_continuation_block_type'
# to contrast it with the block types in '%is_zero_continuation_block_type'
@q = qw( sort map grep eval do );
@is_sort_map_grep_eval_do{@q} = (1) x scalar(@q);
@q = qw( sort map grep );
@is_sort_map_grep{@q} = (1) x scalar(@q);
%is_grep_alias = ();
# I'll build the list of keywords incrementally
my @Keywords = ();
# keywords and tokens after which a value or pattern is expected,
# but not an operator. In other words, these should consume terms
# to their right, or at least they are not expected to be followed
# immediately by operators.
my @value_requestor = qw(
AUTOLOAD BEGIN CHECK DESTROY
END EQ GE GT
INIT LE LT NE
UNITCHECK abs accept alarm
and atan2 bind binmode
bless break caller chdir
chmod chomp chop chown
chr chroot close closedir
cmp connect continue cos
crypt dbmclose dbmopen defined
delete die dump each
else elsif eof eq
evalbytes exec exists exit
exp fc fcntl fileno
flock for foreach formline
ge getc getgrgid getgrnam
gethostbyaddr gethostbyname getnetbyaddr getnetbyname
getpeername getpgrp getpriority getprotobyname
getprotobynumber getpwnam getpwuid getservbyname
getservbyport getsockname getsockopt glob
gmtime goto grep gt
hex if index int
ioctl join keys kill
last lc lcfirst le
length link listen local
localtime lock log lstat
lt map mkdir msgctl
msgget msgrcv msgsnd my
ne next no not
oct open opendir or
ord our pack pipe
pop pos print printf
prototype push quotemeta rand
read readdir readlink readline
readpipe recv redo ref
rename require reset return
reverse rewinddir rindex rmdir
scalar seek seekdir select
semctl semget semop send
sethostent setnetent setpgrp setpriority
setprotoent setservent setsockopt shift
shmctl shmget shmread shmwrite
shutdown sin sleep socket
socketpair sort splice split
sprintf sqrt srand stat
state study substr symlink
syscall sysopen sysread sysseek
system syswrite tell telldir
tie tied truncate uc
ucfirst umask undef unless
unlink unpack unshift untie
until use utime values
vec waitpid warn while
write xor case catch
default err given isa
say switch when
);
# Note: 'ADJUST', 'field' are added by sub check_options
# if --use-feature=class
# patched above for SWITCH/CASE given/when err say
# 'err' is a fairly safe addition.
# Added 'default' for Switch::Plain. Note that we could also have
# a separate set of keywords to include if we see 'use Switch::Plain'
push( @Keywords, @value_requestor );
# These are treated the same but are not keywords:
my @extra_vr = qw( constant vars );
push( @value_requestor, @extra_vr );
@expecting_term_token{@value_requestor} = (1) x scalar(@value_requestor);
# this list contains keywords which do not look for arguments,
# so that they might be followed by an operator, or at least
# not a term.
my @operator_requestor = qw(
endgrent endhostent endnetent endprotoent
endpwent endservent fork getgrent
gethostent getlogin getnetent getppid
getprotoent getpwent getservent setgrent
setpwent time times wait
wantarray
);
push( @Keywords, @operator_requestor );
# These are treated the same but are not considered keywords:
my @extra_or = qw( STDERR STDIN STDOUT );
push( @operator_requestor, @extra_or );
@expecting_operator_token{@operator_requestor} =
(1) x scalar(@operator_requestor);
# these token TYPES expect trailing operator but not a term
# note: ++ and -- are post-increment and decrement, 'C' = constant
my @operator_requestor_types = qw( ++ -- C <> q );
# NOTE: This hash is available but not currently used
@expecting_operator_types{@operator_requestor_types} =
(1) x scalar(@operator_requestor_types);
# these token TYPES consume values (terms)
# note: pp and mm are pre-increment and decrement
# f=semicolon in for, F=file test operator
my @value_requestor_type = qw#
L { ( [ ~ !~ =~ ; . .. ... A : && ! || // = + - x
**= += -= .= /= *= %= x= &= |= ^= <<= >>= &&= ||= //=
<= >= == != => \ > < % * / ? & | ** <=> ~~ !~~ <<~
f F pp mm Y p m U J G j >> << ^ t
~. ^. |. &. ^.= |.= &.= ^^
#;
push( @value_requestor_type, ',' )
; # (perl doesn't like a ',' in a qw block)
# NOTE: This hash is available but not currently used
@expecting_term_types{@value_requestor_type} =
(1) x scalar(@value_requestor_type);
# Note: the following valid token types are not assigned here to
# hashes requesting to be followed by values or terms, but are
# instead currently hard-coded into sub operator_expected:
# ) -> :: Q R Z ] b h i k n v w } #
# For simple syntax checking, it is nice to have a list of operators which
# will really be unhappy if not followed by a term. This includes most
# of the above...
@really_want_term{@value_requestor_type} =
(1) x scalar(@value_requestor_type);
# with these exceptions...
delete $really_want_term{'U'}; # user sub, depends on prototype
delete $really_want_term{'F'}; # file test works on $_ if no following term
delete $really_want_term{'Y'}; # indirect object, too risky to check syntax;
# let perl do it
@q = qw( q qq qx qr s y tr m );
@is_q_qq_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
# Note added 'qw' here
@q = qw( q qq qw qx qr s y tr m );
@is_q_qq_qw_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
# Quote modifiers:
# original ref: camel 3 p 147,
# but perl may accept undocumented flags
# perl 5.10 adds 'p' (preserve)
# Perl version 5.22 added 'n'
# From http://perldoc.perl.org/perlop.html we have
# /PATTERN/msixpodualngc or m?PATTERN?msixpodualngc
# s/PATTERN/REPLACEMENT/msixpodualngcer
# y/SEARCHLIST/REPLACEMENTLIST/cdsr
# tr/SEARCHLIST/REPLACEMENTLIST/cdsr
# qr/STRING/msixpodualn
%quote_modifiers = (
's' => '[msixpodualngcer]',
'y' => '[cdsr]',
'tr' => '[cdsr]',
'm' => '[msixpodualngc]',
'qr' => '[msixpodualn]',
'q' => EMPTY_STRING,
'qq' => EMPTY_STRING,
'qw' => EMPTY_STRING,
'qx' => EMPTY_STRING,
);
# Note: 'class' will be added by sub check_options if -use-feature=class
@q = qw( package );
@is_package{@q} = (1) x scalar(@q);
@q = qw( if elsif unless );
@is_if_elsif_unless{@q} = (1) x scalar(@q);
@q = qw( ; t );
@is_semicolon_or_t{@q} = (1) x scalar(@q);
@q = qw( if elsif unless case when );
@is_if_elsif_unless_case_when{@q} = (1) x scalar(@q);
# Hash of other possible line endings which may occur.
# Keep these coordinated with the regex where this is used.
# Note: chr(13) = chr(015)="\r".
@q = ( chr(13), chr(29), chr(26) );
@other_line_endings{@q} = (1) x scalar(@q);
# These keywords are handled specially in the tokenizer code:
my @special_keywords =
qw( do eval format m package q qq qr qw qx s sub tr y );
push( @Keywords, @special_keywords );
# Keywords after which list formatting may be used
# WARNING: do not include |map|grep|eval or perl may die on
# syntax errors (map1.t).
my @keyword_taking_list = qw(
and chmod chomp chop
chown dbmopen die elsif
exec fcntl for foreach
formline getsockopt given if
index ioctl join kill
local msgctl msgrcv msgsnd
my open or our
pack print printf push
read readpipe recv return
reverse rindex seek select
semctl semget send setpriority
setsockopt shmctl shmget shmread
shmwrite socket socketpair sort
splice split sprintf state
substr syscall sysopen sysread
sysseek system syswrite tie
unless unlink unpack unshift
until vec warn when
while
);
# NOTE: This hash is available but not currently used
@is_keyword_taking_list{@keyword_taking_list} =
(1) x scalar(@keyword_taking_list);
# perl functions which may be unary operators.
# This list is used to decide if a pattern delimited by slashes, /pattern/,
# can follow one of these keywords.
@q = qw( chomp eof eval fc lc pop shift uc undef );
@is_keyword_rejecting_slash_as_pattern_delimiter{@q} =
(1) x scalar(@q);
# These are keywords for which an arg may optionally be omitted. They are
# currently only used to disambiguate a ? used as a ternary from one used
# as a (deprecated) pattern delimiter. In the future, they might be used
# to give a warning about ambiguous syntax before a /.
# Note: split has been omitted (see note below).
my @keywords_taking_optional_arg = qw(
abs alarm caller chdir chomp chop
chr chroot close cos defined die
eof eval evalbytes exit exp fc
getc glob gmtime hex int last
lc lcfirst length localtime log lstat
mkdir next oct ord pop pos
print printf prototype quotemeta rand readline
readlink readpipe redo ref require reset
reverse rmdir say select shift sin
sleep sqrt srand stat study tell
uc ucfirst umask undef unlink warn
write
);
@is_keyword_taking_optional_arg{@keywords_taking_optional_arg} =
(1) x scalar(@keywords_taking_optional_arg);
# This list is used to decide if a pattern delimited by question marks,
# ?pattern?, can follow one of these keywords. Note that from perl 5.22
# on, a ?pattern? is not recognized, so we can be much more strict than
# with a /pattern/. Note that 'split' is not in this list. In current
# versions of perl a question following split must be a ternary, but
# in older versions it could be a pattern. The guessing algorithm will
# decide. We are combining two lists here to simplify the test.
@q = ( @keywords_taking_optional_arg, @operator_requestor );
@is_keyword_rejecting_question_as_pattern_delimiter{@q} =
(1) x scalar(@q);
# These are not used in any way yet
# my @unused_keywords = qw(
# __FILE__
# __LINE__
# __PACKAGE__
# );
# The list of keywords was originally extracted from function 'keyword' in
# perl file toke.c version 5.005.03, using this utility, plus a
# little editing: (file getkwd.pl):
# while (<>) { while (/\"(.*)\"/g) { print "$1\n"; } }
# Add 'get' prefix where necessary, then split into the above lists.
# This list should be updated as necessary.
# The list should not contain these special variables:
# ARGV DATA ENV SIG STDERR STDIN STDOUT
# __DATA__ __END__
@is_keyword{@Keywords} = (1) x scalar(@Keywords);
%matching_end_token = (
'{' => '}',
'(' => ')',
'[' => ']',
'<' => '>',
);
} ## end BEGIN
} ## end package Perl::Tidy::Tokenizer
1;
Perl-Tidy-20250105/lib/Perl/Tidy/Diagnostics.pm 0000644 0001750 0001750 00000005634 14735302772 020031 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Diagnostics class writes the DIAGNOSTICS file, which is
# useful for program development.
#
# Only one such file is created regardless of the number of input
# files processed. This allows the results of processing many files
# to be summarized in a single file.
# Output messages go to a file named DIAGNOSTICS, where
# they are labeled by file and line. This allows many files to be
# scanned at once for some particular condition of interest. It was
# particularly useful for developing guessing strategies.
#
#####################################################################
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
use English qw( -no_match_vars );
our $VERSION = '20250105';
use constant EMPTY_STRING => q{};
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < 0,
_last_diagnostic_file => EMPTY_STRING,
_input_file => EMPTY_STRING,
_fh => undef,
}, $class;
} ## end sub new
sub set_input_file {
my ( $self, $input_file ) = @_;
$self->{_input_file} = $input_file;
return;
}
sub write_diagnostics {
my ( $self, $msg, $line_number ) = @_;
# Write a message to the diagnostics file
# Input parameters:
# $msg = string describing the event
# $line_number = optional line number
if ( !$self->{_write_diagnostics_count} ) {
open( $self->{_fh}, ">", "DIAGNOSTICS" )
or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $OS_ERROR\n");
}
if ( defined($line_number) ) {
$msg = "$line_number:\t$msg";
}
my $fh = $self->{_fh};
my $last_diagnostic_file = $self->{_last_diagnostic_file};
my $input_file = $self->{_input_file};
if ( $last_diagnostic_file ne $input_file ) {
$fh->print("\nFILE:$input_file\n");
}
$self->{_last_diagnostic_file} = $input_file;
$fh->print($msg);
$self->{_write_diagnostics_count}++;
return;
} ## end sub write_diagnostics
1;
Perl-Tidy-20250105/lib/Perl/Tidy/IndentationItem.pm 0000644 0001750 0001750 00000021006 14735302776 020650 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::IndentationItem class supplies items which contain
# how much whitespace should be used at the start of a line
#
#####################################################################
package Perl::Tidy::IndentationItem;
use strict;
use warnings;
our $VERSION = '20250105';
BEGIN {
# Array index names
# Do not combine with other BEGIN blocks (c101).
my $i = 0;
use constant {
_spaces_ => $i++,
_level_ => $i++,
_ci_level_ => $i++,
_available_spaces_ => $i++,
_closed_ => $i++,
_comma_count_ => $i++,
_lp_item_index_ => $i++,
_have_child_ => $i++,
_recoverable_spaces_ => $i++,
_align_seqno_ => $i++,
_marked_ => $i++,
_K_begin_line_ => $i++,
_arrow_count_ => $i++,
_standard_spaces_ => $i++,
_K_extra_space_ => $i++,
};
} ## end BEGIN
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < # total leading white spaces
# level => # the indentation 'level'
# ci_level => # the 'continuation level'
# available_spaces => # how many left spaces available
# # for this level
# closed => # index where we saw closing '}'
# comma_count => # how many commas at this level?
# lp_item_index => # index in output batch list
# have_child => # any dependents?
# recoverable_spaces => # how many spaces to the right
# # we would like to move to get
# # alignment (negative if left)
# align_seqno => # if we are aligning with an opening structure,
# # this is its seqno
# marked => # if visited by corrector logic
# K_begin_line => # first token index K of this level
# arrow_count => # how many =>'s
my $self = [];
bless $self, $class;
$self->[_spaces_] = $input_hash{spaces};
$self->[_level_] = $input_hash{level};
$self->[_ci_level_] = $input_hash{ci_level};
$self->[_available_spaces_] = $input_hash{available_spaces};
$self->[_closed_] = -1;
$self->[_comma_count_] = 0;
$self->[_lp_item_index_] = $input_hash{lp_item_index};
$self->[_have_child_] = 0;
$self->[_recoverable_spaces_] = 0;
$self->[_align_seqno_] = $input_hash{align_seqno};
$self->[_marked_] = 0;
$self->[_K_begin_line_] = $input_hash{K_begin_line};
$self->[_arrow_count_] = 0;
$self->[_standard_spaces_] = $input_hash{standard_spaces};
$self->[_K_extra_space_] = $input_hash{K_extra_space};
return $self;
} ## end sub new
sub permanently_decrease_available_spaces {
# make a permanent reduction in the available indentation spaces
# at one indentation item. NOTE: if there are child nodes, their
# total SPACES must be reduced by the caller.
my ( $self, $spaces_needed ) = @_;
my $available_spaces = $self->get_available_spaces();
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
# Fixed for c085; a zero value must remain unchanged unless the closed
# flag has been set.
my $closed = $self->get_closed();
$self->decrease_available_spaces($deleted_spaces)
if ( $available_spaces != 0 || $closed >= 0 );
$self->decrease_SPACES($deleted_spaces);
$self->set_recoverable_spaces(0);
return $deleted_spaces;
} ## end sub permanently_decrease_available_spaces
sub tentatively_decrease_available_spaces {
# We are asked to tentatively delete $spaces_needed of indentation
# for an indentation item. We may want to undo this later. NOTE: if
# there are child nodes, their total SPACES must be reduced by the
# caller.
my ( $self, $spaces_needed ) = @_;
my $available_spaces = $self->get_available_spaces();
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
$self->decrease_available_spaces($deleted_spaces);
$self->decrease_SPACES($deleted_spaces);
$self->increase_recoverable_spaces($deleted_spaces);
return $deleted_spaces;
} ## end sub tentatively_decrease_available_spaces
# time-critical sub
sub get_spaces {
return $_[0]->[_spaces_];
}
sub get_standard_spaces {
my $self = shift;
return $self->[_standard_spaces_];
}
# time-critical sub
sub get_marked {
return $_[0]->[_marked_];
}
sub set_marked {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_marked_] = $value;
}
return $self->[_marked_];
} ## end sub set_marked
sub get_available_spaces {
my $self = shift;
return $self->[_available_spaces_];
}
sub decrease_SPACES {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_spaces_] -= $value;
}
return $self->[_spaces_];
} ## end sub decrease_SPACES
sub decrease_available_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_available_spaces_] -= $value;
}
return $self->[_available_spaces_];
} ## end sub decrease_available_spaces
sub get_align_seqno {
my $self = shift;
return $self->[_align_seqno_];
}
sub get_recoverable_spaces {
my $self = shift;
return $self->[_recoverable_spaces_];
}
sub set_recoverable_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_recoverable_spaces_] = $value;
}
return $self->[_recoverable_spaces_];
} ## end sub set_recoverable_spaces
sub increase_recoverable_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_recoverable_spaces_] += $value;
}
return $self->[_recoverable_spaces_];
} ## end sub increase_recoverable_spaces
sub get_ci_level {
my $self = shift;
return $self->[_ci_level_];
}
sub get_level {
my $self = shift;
return $self->[_level_];
}
sub get_spaces_level_ci {
my $self = shift;
return [ $self->[_spaces_], $self->[_level_], $self->[_ci_level_] ];
}
sub get_lp_item_index {
my $self = shift;
return $self->[_lp_item_index_];
}
sub get_K_begin_line {
my $self = shift;
return $self->[_K_begin_line_];
}
sub get_K_extra_space {
my $self = shift;
return $self->[_K_extra_space_];
}
sub set_have_child {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_have_child_] = $value;
}
return $self->[_have_child_];
} ## end sub set_have_child
sub get_have_child {
my $self = shift;
return $self->[_have_child_];
}
sub set_arrow_count {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_arrow_count_] = $value;
}
return $self->[_arrow_count_];
} ## end sub set_arrow_count
sub get_arrow_count {
my $self = shift;
return $self->[_arrow_count_];
}
sub set_comma_count {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_comma_count_] = $value;
}
return $self->[_comma_count_];
} ## end sub set_comma_count
sub get_comma_count {
my $self = shift;
return $self->[_comma_count_];
}
sub set_closed {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_closed_] = $value;
}
return $self->[_closed_];
} ## end sub set_closed
sub get_closed {
my $self = shift;
return $self->[_closed_];
}
1;
Perl-Tidy-20250105/lib/Perl/Tidy/HtmlWriter.pm 0000644 0001750 0001750 00000150126 14735302774 017662 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::HtmlWriter class writes a copy of the input stream in html
#
#####################################################################
package Perl::Tidy::HtmlWriter;
use strict;
use warnings;
our $VERSION = '20250105';
use Carp;
use English qw( -no_match_vars );
use File::Basename;
use File::Temp qw();
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
{ #<<< A non-indenting brace to contain all lexical variables
# class variables
my (
# INITIALIZER: BEGIN block
$missing_html_entities,
$missing_pod_html,
# INITIALIZER: BEGIN block
%short_to_long_names,
%token_short_names,
# INITIALIZER: sub check_options
$rOpts,
$rOpts_html_entities,
$css_linkname,
%html_bold,
%html_color,
%html_italic,
);
# replace unsafe characters with HTML entity representation if HTML::Entities
# is available
#{ eval "use HTML::Entities"; $missing_html_entities = $@; }
BEGIN {
$missing_html_entities = EMPTY_STRING;
if ( !eval { require HTML::Entities; 1 } ) {
$missing_html_entities = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
$missing_pod_html = EMPTY_STRING;
if ( !eval { require Pod::Html; 1 } ) {
$missing_pod_html = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
} ## end BEGIN
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < undef,
html_file => undef,
extension => undef,
html_toc_extension => undef,
html_src_extension => undef,
);
my %args = ( %defaults, @arglist );
my $input_file = $args{input_file};
my $html_file = $args{html_file};
my $extension = $args{extension};
my $html_toc_extension = $args{html_toc_extension};
my $html_src_extension = $args{html_src_extension};
my $html_fh = Perl::Tidy::streamhandle( $html_file, 'w' );
if ( !$html_fh ) {
Perl::Tidy::Warn("can't open html file '$html_file'\n");
return;
}
my $html_file_opened = 1;
if ( !$input_file || $input_file eq '-' || ref($input_file) ) {
$input_file = "NONAME";
}
# write the table of contents to a string
my $toc_string;
my $html_toc_fh = Perl::Tidy::IOScalar->new( \$toc_string, 'w' );
my $html_pre_fh;
my @pre_string_stack;
if ( $rOpts->{'html-pre-only'} ) {
# pre section goes directly to the output stream
$html_pre_fh = $html_fh;
$html_pre_fh->print(<<"PRE_END");
PRE_END
}
else {
# pre section go out to a temporary string
my $pre_string;
$html_pre_fh = Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
push @pre_string_stack, \$pre_string;
}
# pod text gets diverted if the 'pod2html' is used
my $html_pod_fh;
my $pod_string;
if ( $rOpts->{'pod2html'} ) {
if ( $rOpts->{'html-pre-only'} ) {
undef $rOpts->{'pod2html'};
}
else {
if ($missing_pod_html) {
Perl::Tidy::Warn(
"unable to find Pod::Html; cannot use pod2html\n-npod disables this message\n"
);
undef $rOpts->{'pod2html'};
}
else {
$html_pod_fh = Perl::Tidy::IOScalar->new( \$pod_string, 'w' );
}
}
}
my $toc_filename;
my $src_filename;
if ( $rOpts->{'frames'} ) {
if ( !$extension ) {
Perl::Tidy::Warn(
"cannot use frames without a specified output extension; ignoring -frm\n"
);
undef $rOpts->{'frames'};
}
else {
$toc_filename = $input_file . $html_toc_extension . $extension;
$src_filename = $input_file . $html_src_extension . $extension;
}
}
# ----------------------------------------------------------
# Output is now directed as follows:
# html_toc_fh <-- table of contents items
# html_pre_fh <-- the section of formatted code, except:
# html_pod_fh <-- pod goes here with the pod2html option
# ----------------------------------------------------------
my $title = $rOpts->{'title'};
if ( !$title ) {
( $title, my $path_uu ) = fileparse($input_file);
}
my $toc_item_count = 0;
my $in_toc_package = EMPTY_STRING;
my $last_level = 0;
return bless {
_input_file => $input_file, # name of input file
_title => $title, # title, unescaped
_html_file => $html_file, # name of .html output file
_toc_filename => $toc_filename, # for frames option
_src_filename => $src_filename, # for frames option
_html_file_opened => $html_file_opened, # a flag
_html_fh => $html_fh, # the output stream
_html_pre_fh => $html_pre_fh, # pre section goes here
_rpre_string_stack => \@pre_string_stack, # stack of pre sections
_html_pod_fh => $html_pod_fh, # pod goes here if pod2html
_rpod_string => \$pod_string, # string holding pod
_pod_cut_count => 0, # how many =cut's?
_html_toc_fh => $html_toc_fh, # fh for table of contents
_rtoc_string => \$toc_string, # string holding toc
_rtoc_item_count => \$toc_item_count, # how many toc items
_rin_toc_package => \$in_toc_package, # package name
_rtoc_name_count => {}, # hash to track unique names
_rpackage_stack => [], # stack to check for package
# name changes
_rlast_level => \$last_level, # brace indentation level
}, $class;
} ## end sub new
sub add_toc_item {
# Add an item to the html table of contents.
# This is called even if no table of contents is written,
# because we still want to put the anchors in the text.
# We are given an anchor name and its type; types are:
# 'package', 'sub', '__END__', '__DATA__', 'EOF'
# There must be an 'EOF' call at the end to wrap things up.
my ( $self, $name, $type ) = @_;
my $html_toc_fh = $self->{_html_toc_fh};
my $html_pre_fh = $self->{_html_pre_fh};
my $rtoc_name_count = $self->{_rtoc_name_count};
my $rtoc_item_count = $self->{_rtoc_item_count};
my $rlast_level = $self->{_rlast_level};
my $rin_toc_package = $self->{_rin_toc_package};
my $rpackage_stack = $self->{_rpackage_stack};
# packages contain sublists of subs, so to avoid errors all package
# items are written and finished with the following routines
my $end_package_list = sub {
if ( ${$rin_toc_package} ) {
$html_toc_fh->print("\n\n");
${$rin_toc_package} = EMPTY_STRING;
}
return;
}; ## end $end_package_list = sub
my $start_package_list = sub {
my ( $unique_name, $package ) = @_;
if ( ${$rin_toc_package} ) { $end_package_list->() }
$html_toc_fh->print(<package $package
EOM
${$rin_toc_package} = $package;
return;
}; ## end $start_package_list = sub
# start the table of contents on the first item
if ( !${$rtoc_item_count} ) {
# but just quit if we hit EOF without any other entries
# in this case, there will be no toc
return if ( $type eq 'EOF' );
$html_toc_fh->print(<<"TOC_END");
TOC_END
}
${$rtoc_item_count}++;
# make a unique anchor name for this location:
# - packages get a 'package-' prefix
# - subs use their names
my $unique_name = $name;
if ( $type eq 'package' ) { $unique_name = "package-$name" }
# append '-1', '-2', etc if necessary to make unique; this will
# be unique because subs and packages cannot have a '-'
if ( my $count = $rtoc_name_count->{ lc $unique_name }++ ) {
$unique_name .= "-$count";
}
# - all names get terminal '-' if pod2html is used, to avoid
# conflicts with anchor names created by pod2html
if ( $rOpts->{'pod2html'} ) { $unique_name .= '-' }
# start/stop lists of subs
if ( $type eq 'sub' ) {
my $package = $rpackage_stack->[ ${$rlast_level} ];
if ( !$package ) { $package = 'main' }
# if we're already in a package/sub list, be sure its the right
# package or else close it
if ( ${$rin_toc_package} && ${$rin_toc_package} ne $package ) {
$end_package_list->();
}
# start a package/sub list if necessary
if ( !${$rin_toc_package} ) {
$start_package_list->( $unique_name, $package );
}
}
# now write an entry in the toc for this item
if ( $type eq 'package' ) {
$start_package_list->( $unique_name, $name );
}
elsif ( $type eq 'sub' ) {
$html_toc_fh->print("- $name
\n");
}
else {
$end_package_list->();
$html_toc_fh->print("- $name
\n");
}
# write the anchor in the
section
$html_pre_fh->print("");
# end the table of contents, if any, on the end of file
if ( $type eq 'EOF' ) {
$html_toc_fh->print(<<"TOC_END");
TOC_END
}
return;
} ## end sub add_toc_item
BEGIN {
# This is the official list of tokens which may be identified by the
# user. Long names are used as getopt keys. Short names are
# convenient short abbreviations for specifying input. Short names
# somewhat resemble token type characters, but are often different
# because they may only be alphanumeric, to allow command line
# input. Also, note that because of case insensitivity of html,
# this table must be in a single case only (I've chosen to use all
# lower case).
# When adding NEW_TOKENS: update this hash table
# short names => long names
%short_to_long_names = (
'n' => 'numeric',
'p' => 'paren',
'q' => 'quote',
's' => 'structure',
'c' => 'comment',
'v' => 'v-string',
'cm' => 'comma',
'w' => 'bareword',
'co' => 'colon',
'pu' => 'punctuation',
'i' => 'identifier',
'j' => 'label',
'h' => 'here-doc-target',
'hh' => 'here-doc-text',
'k' => 'keyword',
'sc' => 'semicolon',
'm' => 'subroutine',
'pd' => 'pod-text',
);
# Now we have to map actual token types into one of the above short
# names; any token types not mapped will get 'punctuation'
# properties.
# The values of this hash table correspond to the keys of the
# previous hash table.
# The keys of this hash table are token types and can be seen
# by running with --dump-token-types (-dtt).
# When adding NEW_TOKENS: update this hash table
# $type => $short_name
# c250: changed 'M' to 'S'
%token_short_names = (
'#' => 'c',
'n' => 'n',
'v' => 'v',
'k' => 'k',
'F' => 'k',
'Q' => 'q',
'q' => 'q',
'J' => 'j',
'j' => 'j',
'h' => 'h',
'H' => 'hh',
'w' => 'w',
',' => 'cm',
'=>' => 'cm',
';' => 'sc',
':' => 'co',
'f' => 'sc',
'(' => 'p',
')' => 'p',
'S' => 'm',
'pd' => 'pd',
'A' => 'co',
);
# These token types will all be called identifiers for now
# Fix for c250: added new type 'P', formerly 'i'
# ( but package statements will eventually be split into 'k' and 'i')
my @identifier = qw< i t U C Y Z G P :: CORE::>;
@token_short_names{@identifier} = ('i') x scalar(@identifier);
# These token types will be called 'structure'
my @structure = qw< { } >;
@token_short_names{@structure} = ('s') x scalar(@structure);
# OLD NOTES: save for reference
# Any of these could be added later if it would be useful.
# For now, they will by default become punctuation
# my @list = qw< L R [ ] >;
# @token_long_names{@list} = ('non-structure') x scalar(@list);
#
# my @list = qw"
# / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
# ";
# @token_long_names{@list} = ('math') x scalar(@list);
#
# my @list = qw" & &= ~ ~= ^ ^= | |= ";
# @token_long_names{@list} = ('bit') x scalar(@list);
#
# my @list = qw" == != < > <= <=> ";
# @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
#
# my @list = qw" && || ! &&= ||= //= ";
# @token_long_names{@list} = ('logical') x scalar(@list);
#
# my @list = qw" . .= =~ !~ x x= ";
# @token_long_names{@list} = ('string-operators') x scalar(@list);
#
# # Incomplete..
# my @list = qw" .. -> <> ... \ ? ";
# @token_long_names{@list} = ('misc-operators') x scalar(@list);
} ## end BEGIN
sub make_getopt_long_names {
my ( $class, $rgetopt_names ) = @_;
foreach my $short_name ( keys %short_to_long_names ) {
my $long_name = $short_to_long_names{$short_name};
push @{$rgetopt_names}, "html-color-$long_name=s";
push @{$rgetopt_names}, "html-italic-$long_name!";
push @{$rgetopt_names}, "html-bold-$long_name!";
}
push @{$rgetopt_names}, "html-color-background=s";
push @{$rgetopt_names}, "html-linked-style-sheet=s";
push @{$rgetopt_names}, "nohtml-style-sheets";
push @{$rgetopt_names}, "html-pre-only";
push @{$rgetopt_names}, "html-line-numbers";
push @{$rgetopt_names}, "html-entities!";
push @{$rgetopt_names}, "stylesheet";
push @{$rgetopt_names}, "html-table-of-contents!";
push @{$rgetopt_names}, "pod2html!";
push @{$rgetopt_names}, "frames!";
push @{$rgetopt_names}, "html-toc-extension=s";
push @{$rgetopt_names}, "html-src-extension=s";
# Pod::Html parameters:
push @{$rgetopt_names}, "backlink=s";
push @{$rgetopt_names}, "cachedir=s";
push @{$rgetopt_names}, "htmlroot=s";
push @{$rgetopt_names}, "libpods=s";
push @{$rgetopt_names}, "podpath=s";
push @{$rgetopt_names}, "podroot=s";
push @{$rgetopt_names}, "title=s";
# Pod::Html parameters with leading 'pod' which will be removed
# before the call to Pod::Html
push @{$rgetopt_names}, "podquiet!";
push @{$rgetopt_names}, "podverbose!";
push @{$rgetopt_names}, "podrecurse!";
push @{$rgetopt_names}, "podflush";
push @{$rgetopt_names}, "podheader!";
push @{$rgetopt_names}, "podindex!";
return;
} ## end sub make_getopt_long_names
sub make_abbreviated_names {
# We're appending things like this to the expansion list:
# 'hcc' => [qw(html-color-comment)],
# 'hck' => [qw(html-color-keyword)],
# etc
my ( $class, $rexpansion ) = @_;
# abbreviations for color/bold/italic properties
foreach my $short_name ( keys %short_to_long_names ) {
my $long_name = $short_to_long_names{$short_name};
${$rexpansion}{"hc$short_name"} = ["html-color-$long_name"];
${$rexpansion}{"hb$short_name"} = ["html-bold-$long_name"];
${$rexpansion}{"hi$short_name"} = ["html-italic-$long_name"];
${$rexpansion}{"nhb$short_name"} = ["nohtml-bold-$long_name"];
${$rexpansion}{"nhi$short_name"} = ["nohtml-italic-$long_name"];
}
# abbreviations for all other html options
${$rexpansion}{"hcbg"} = ["html-color-background"];
${$rexpansion}{"pre"} = ["html-pre-only"];
${$rexpansion}{"toc"} = ["html-table-of-contents"];
${$rexpansion}{"ntoc"} = ["nohtml-table-of-contents"];
${$rexpansion}{"nnn"} = ["html-line-numbers"];
${$rexpansion}{"hent"} = ["html-entities"];
${$rexpansion}{"nhent"} = ["nohtml-entities"];
${$rexpansion}{"css"} = ["html-linked-style-sheet"];
${$rexpansion}{"nss"} = ["nohtml-style-sheets"];
${$rexpansion}{"ss"} = ["stylesheet"];
${$rexpansion}{"pod"} = ["pod2html"];
${$rexpansion}{"npod"} = ["nopod2html"];
${$rexpansion}{"frm"} = ["frames"];
${$rexpansion}{"nfrm"} = ["noframes"];
${$rexpansion}{"text"} = ["html-toc-extension"];
${$rexpansion}{"sext"} = ["html-src-extension"];
return;
} ## end sub make_abbreviated_names
sub check_options {
# This will be called once after options have been parsed
# Note that we are defining the package variable $rOpts here:
( my $class, $rOpts ) = @_;
# X11 color names for default settings that seemed to look ok
# (these color names are only used for programming clarity; the hex
# numbers are actually written)
## use constant SaddleBrown => "#8B4513";
use constant ForestGreen => "#228B22";
use constant magenta4 => "#8B008B";
use constant IndianRed3 => "#CD5555";
use constant DeepSkyBlue4 => "#00688B";
use constant MediumOrchid3 => "#B452CD";
use constant black => "#000000";
use constant white => "#FFFFFF";
use constant red => "#FF0000";
# set default color, bold, italic properties
# anything not listed here will be given the default (punctuation) color --
# these types currently not listed and get default: ws pu s sc cm co p
# When adding NEW_TOKENS: add an entry here if you don't want defaults
# set_default_properties( $short_name, default_color, bold?, italic? );
set_default_properties( 'c', ForestGreen, 0, 0 );
set_default_properties( 'pd', ForestGreen, 0, 1 );
set_default_properties( 'k', magenta4, 1, 0 ); # was SaddleBrown
set_default_properties( 'q', IndianRed3, 0, 0 );
set_default_properties( 'hh', IndianRed3, 0, 1 );
set_default_properties( 'h', IndianRed3, 1, 0 );
set_default_properties( 'i', DeepSkyBlue4, 0, 0 );
set_default_properties( 'w', black, 0, 0 );
set_default_properties( 'n', MediumOrchid3, 0, 0 );
set_default_properties( 'v', MediumOrchid3, 0, 0 );
set_default_properties( 'j', IndianRed3, 1, 0 );
set_default_properties( 'm', red, 1, 0 );
set_default_color( 'html-color-background', white );
set_default_color( 'html-color-punctuation', black );
# setup property lookup tables for tokens based on their short names
# every token type has a short name, and will use these tables
# to do the html markup
foreach my $short_name ( keys %short_to_long_names ) {
my $long_name = $short_to_long_names{$short_name};
$html_color{$short_name} = $rOpts->{"html-color-$long_name"};
$html_bold{$short_name} = $rOpts->{"html-bold-$long_name"};
$html_italic{$short_name} = $rOpts->{"html-italic-$long_name"};
}
# write style sheet to STDOUT and die if requested
if ( defined( $rOpts->{'stylesheet'} ) ) {
write_style_sheet_file('-');
Perl::Tidy::Exit(0);
}
# make sure user gives a file name after -css
$css_linkname = EMPTY_STRING;
if ( defined( $rOpts->{'html-linked-style-sheet'} ) ) {
$css_linkname = $rOpts->{'html-linked-style-sheet'};
if ( $css_linkname =~ /^-/ ) {
Perl::Tidy::Die("You must specify a valid filename after -css\n");
}
}
# check for conflict
if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
$rOpts->{'nohtml-style-sheets'} = 0;
Perl::Tidy::Warn(
"You can't specify both -css and -nss; -nss ignored\n");
}
# write a style sheet file if necessary
if ($css_linkname) {
# if the selected filename exists, don't write, because user may
# have done some work by hand to create it; use backup name instead
# Also, this will avoid a potential disaster in which the user
# forgets to specify the style sheet, like this:
# perltidy -html -css myfile1.pl myfile2.pl
# This would cause myfile1.pl to parsed as the style sheet by GetOpts
if ( !-e $css_linkname ) {
write_style_sheet_file($css_linkname);
}
}
$rOpts_html_entities = $rOpts->{'html-entities'};
return;
} ## end sub check_options
sub write_style_sheet_file {
my $filename = shift;
my $fh = IO::File->new("> $filename");
if ( !$fh ) {
Perl::Tidy::Die("can't open $filename: $OS_ERROR\n");
}
write_style_sheet_data($fh);
if ( $fh->can('close') && $filename ne '-' && !ref($filename) ) {
$fh->close()
or
Perl::Tidy::Warn("can't close style sheet '$filename' : $OS_ERROR\n");
}
return;
} ## end sub write_style_sheet_file
sub write_style_sheet_data {
# write the style sheet data to an open file handle
my $fh = shift;
my $bg_color = $rOpts->{'html-color-background'};
my $text_color = $rOpts->{'html-color-punctuation'};
# pre-bgcolor is new, and may not be defined
my $pre_bg_color = $rOpts->{'html-pre-color-background'};
$pre_bg_color = $bg_color unless $pre_bg_color;
$fh->print(<<"EOM");
/* default style sheet generated by perltidy */
body {background: $bg_color; color: $text_color}
pre { color: $text_color;
background: $pre_bg_color;
font-family: courier;
}
EOM
foreach my $short_name ( sort keys %short_to_long_names ) {
my $long_name = $short_to_long_names{$short_name};
my $abbrev = '.' . $short_name;
if ( length($short_name) == 1 ) { $abbrev .= SPACE } # for alignment
my $color = $html_color{$short_name};
if ( !defined($color) ) { $color = $text_color }
$fh->print("$abbrev \{ color: $color;");
if ( $html_bold{$short_name} ) {
$fh->print(" font-weight:bold;");
}
if ( $html_italic{$short_name} ) {
$fh->print(" font-style:italic;");
}
$fh->print("} /* $long_name */\n");
}
return;
} ## end sub write_style_sheet_data
sub set_default_color {
# make sure that options hash $rOpts->{$key} contains a valid color
my ( $key, $color ) = @_;
if ( $rOpts->{$key} ) { $color = $rOpts->{$key} }
$rOpts->{$key} = check_RGB($color);
return;
} ## end sub set_default_color
sub check_RGB {
# if color is a 6 digit hex RGB value, prepend a #, otherwise
# assume that it is a valid ascii color name
my ($color) = @_;
if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
return $color;
} ## end sub check_RGB
sub set_default_properties {
my ( $short_name, $color, $bold, $italic ) = @_;
set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
my $key;
$key = "html-bold-$short_to_long_names{$short_name}";
$rOpts->{$key} = defined( $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
$key = "html-italic-$short_to_long_names{$short_name}";
$rOpts->{$key} = defined( $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
return;
} ## end sub set_default_properties
sub pod_to_html {
# Use Pod::Html to process the pod and make the page
# then merge the perltidy code sections into it.
# return 1 if success, 0 otherwise
my ( $self, $pod_string, $css_string, $toc_string, $rpre_string_stack ) =
@_;
my $title = $self->{_title};
my $success_flag = 0;
# don't try to use pod2html if no pod
if ( !$pod_string ) {
return $success_flag;
}
# Pod::Html requires a real temporary filename
my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile();
if ( !$fh_tmp ) {
Perl::Tidy::Warn(
"unable to open temporary file $tmpfile; cannot use pod2html\n");
return $success_flag;
}
#------------------------------------------------------------------
# Warning: a temporary file is open; we have to clean up if
# things go bad. From here on all returns should be by going to
# RETURN so that the temporary file gets unlinked.
#------------------------------------------------------------------
# write the pod text to the temporary file
$fh_tmp->print($pod_string);
if ( !$fh_tmp->close() ) {
Perl::Tidy::Warn(
"unable to close temporary file $tmpfile; cannot use pod2html\n");
return $success_flag;
}
# Hand off the pod to pod2html.
# Note that we can use the same temporary filename for input and output
# because of the way pod2html works.
{
my @args;
push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";
# Flags with string args:
# "backlink=s", "cachedir=s", "htmlroot=s", "libpods=s",
# "podpath=s", "podroot=s"
# Note: -css=s is handled by perltidy itself
foreach
my $kw (qw( backlink cachedir htmlroot libpods podpath podroot ))
{
if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
}
# Toggle switches; these have extra leading 'pod'
# "header!", "index!", "recurse!", "quiet!", "verbose!"
foreach
my $kw (qw( podheader podindex podrecurse podquiet podverbose ))
{
my $kwd = $kw; # allows us to strip 'pod'
if ( $rOpts->{$kw} ) { $kwd =~ s/^pod//; push @args, "--$kwd" }
elsif ( defined( $rOpts->{$kw} ) ) {
$kwd =~ s/^pod//;
push @args, "--no$kwd";
}
else {
# user did not set this keyword
}
}
# "flush",
my $kw = 'podflush';
if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }
# Must clean up if pod2html dies (it can);
# Be careful not to overwrite callers __DIE__ routine
local $SIG{__DIE__} = sub {
unlink($tmpfile) if -e $tmpfile;
Perl::Tidy::Die( $_[0] );
};
Pod::Html::pod2html(@args);
}
$fh_tmp = IO::File->new( $tmpfile, 'r' );
if ( !$fh_tmp ) {
# this error shouldn't happen ... we just used this filename
Perl::Tidy::Warn(
"unable to open temporary file $tmpfile; cannot use pod2html\n");
return $success_flag;
}
my $html_fh = $self->{_html_fh};
my @toc;
my $in_toc;
my $ul_level = 0;
my $no_print;
# This routine will write the html selectively and store the toc
my $html_print = sub {
foreach my $line (@_) {
$html_fh->print($line) unless ($no_print);
if ($in_toc) { push @toc, $line }
}
return;
}; ## end $html_print = sub
# loop over lines of html output from pod2html and merge in
# the necessary perltidy html sections
my ( $saw_body, $saw_index, $saw_body_end );
my $timestamp = EMPTY_STRING;
if ( $rOpts->{'timestamp'} ) {
my $date = localtime;
$timestamp = "on $date";
}
while ( defined( my $line = $fh_tmp->getline() ) ) {
if ( $line =~ /^\s*\s*$/i ) {
$html_print->("\n");
$html_print->($line);
}
# Copy the perltidy css, if any, after tag
elsif ( $line =~ /^\s*\s*$/i ) {
$saw_body = 1;
$html_print->($css_string) if $css_string;
$html_print->($line);
# add a top anchor and heading
$html_print->("\n");
$title = escape_html($title);
$html_print->("$title
\n");
}
# check for start of index, old pod2html
# before Pod::Html VERSION 1.15_02 it is delimited by comments as:
#
#
# ...
#
#
#
elsif ( $line =~ /^\s*\s*$/i ) {
$in_toc = 'INDEX';
# when frames are used, an extra table of contents in the
# contents panel is confusing, so don't print it
$no_print = $rOpts->{'frames'}
|| !$rOpts->{'html-table-of-contents'};
$html_print->("Doc Index:
\n") if $rOpts->{'frames'};
$html_print->($line);
}
# check for start of index, new pod2html
# After Pod::Html VERSION 1.15_02 it is delimited as:
#
# ...
#
elsif ( $line =~ /^\s*/i ) {
$in_toc = 'UL';
$ul_level = 1;
# when frames are used, an extra table of contents in the
# contents panel is confusing, so don't print it
$no_print = $rOpts->{'frames'}
|| !$rOpts->{'html-table-of-contents'};
$html_print->("Doc Index:
\n") if $rOpts->{'frames'};
$html_print->($line);
}
# Check for end of index, old pod2html
elsif ( $line =~ /^\s*\s*$/i ) {
$saw_index = 1;
$html_print->($line);
# Copy the perltidy toc, if any, after the Pod::Html toc
if ($toc_string) {
$html_print->("
\n") if $rOpts->{'frames'};
$html_print->("Code Index:
\n");
my @toc_st = split /^/, $toc_string;
$html_print->(@toc_st);
}
$in_toc = EMPTY_STRING;
$no_print = 0;
}
# must track depth level for new pod2html
elsif ( $line =~ /\s*\s*$/i && $in_toc eq 'UL' ) {
$ul_level++;
$html_print->($line);
}
# Check for end of index, for new pod2html
elsif ( $line =~ /\s*<\/ul>/i && $in_toc eq 'UL' ) {
$ul_level--;
$html_print->($line);
# Copy the perltidy toc, if any, after the Pod::Html toc
if ( $ul_level <= 0 ) {
$saw_index = 1;
if ($toc_string) {
$html_print->("
\n") if $rOpts->{'frames'};
$html_print->("Code Index:
\n");
my @toc_st = split /^/, $toc_string;
$html_print->(@toc_st);
}
$in_toc = EMPTY_STRING;
$ul_level = 0;
$no_print = 0;
}
}
# Copy one perltidy section after each marker
elsif ( $line =~ /^(.*)(.*)$/ ) {
$line = $2;
$html_print->($1) if $1;
# Intermingle code and pod sections if we saw multiple =cut's.
if ( $self->{_pod_cut_count} > 1 ) {
my $rpre_string = shift @{$rpre_string_stack};
if ( ${$rpre_string} ) {
$html_print->('
');
$html_print->( ${$rpre_string} );
$html_print->('');
}
else {
# shouldn't happen: we stored a string before writing
# each marker.
Perl::Tidy::Warn(
"Problem merging html stream with pod2html; order may be wrong\n"
);
}
$html_print->($line);
}
# If didn't see multiple =cut lines, we'll put the pod out first
# and then the code, because it's less confusing.
else {
# since we are not intermixing code and pod, we don't need
# or want any
lines which separated pod and code
$html_print->($line) unless ( $line =~ /^\s*
\s*$/i );
}
}
# Copy any remaining code section before the tag
elsif ( $line =~ /^\s*<\/body>\s*$/i ) {
$saw_body_end = 1;
if ( @{$rpre_string_stack} ) {
if ( $self->{_pod_cut_count} <= 1 ) {
$html_print->('
');
}
while ( @{$rpre_string_stack} ) {
my $rpre_string = shift @{$rpre_string_stack};
$html_print->('');
$html_print->( ${$rpre_string} );
$html_print->('');
} ## end while ( @{$rpre_string_stack...})
}
$html_print->($line);
}
else {
$html_print->($line);
}
} ## end while ( defined( my $line...))
$success_flag = 1;
if ( !$saw_body ) {
Perl::Tidy::Warn("Did not see in pod2html output\n");
$success_flag = 0;
}
if ( !$saw_body_end ) {
Perl::Tidy::Warn("Did not see in pod2html output\n");
$success_flag = 0;
}
if ( !$saw_index ) {
Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
$success_flag = 0;
}
if ( $html_fh->can('close') ) {
$html_fh->close();
}
# note that we have to unlink tmpfile before making frames
# because the tmpfile may be one of the names used for frames
if ( -e $tmpfile ) {
if ( !unlink($tmpfile) ) {
Perl::Tidy::Warn(
"couldn't unlink temporary file $tmpfile: $OS_ERROR\n");
$success_flag = 0;
}
}
if ( $success_flag && $rOpts->{'frames'} ) {
$self->make_frame( \@toc );
}
return $success_flag;
} ## end sub pod_to_html
sub make_frame {
# Make a frame with table of contents in the left panel
# and the text in the right panel.
# On entry:
# $html_filename contains the no-frames html output
# $rtoc is a reference to an array with the table of contents
my ( $self, $rtoc ) = @_;
my $html_filename = $self->{_html_file};
my $toc_filename = $self->{_toc_filename};
my $src_filename = $self->{_src_filename};
my $title = $self->{_title};
$title = escape_html($title);
# FUTURE input parameter:
my $top_basename = EMPTY_STRING;
# We need to produce 3 html files:
# 1. - the table of contents
# 2. - the contents (source code) itself
# 3. - the frame which contains them
# get basenames for relative links
my ( $toc_basename, $toc_path_uu ) = fileparse($toc_filename);
my ( $src_basename, $src_path_uu ) = fileparse($src_filename);
# 1. Make the table of contents panel, with appropriate changes
# to the anchor names
my $src_frame_name = 'SRC';
my $first_anchor_uu = write_toc_html(
{
title => $title,
toc_filename => $toc_filename,
src_basename => $src_basename,
rtoc => $rtoc,
src_frame_name => $src_frame_name,
}
);
# 2. The current .html filename is renamed to be the contents panel
rename( $html_filename, $src_filename )
or Perl::Tidy::Die(
"Cannot rename $html_filename to $src_filename: $OS_ERROR\n");
# 3. Then use the original html filename for the frame
write_frame_html(
{
title => $title,
frame_filename => $html_filename,
top_basename => $top_basename,
toc_basename => $toc_basename,
src_basename => $src_basename,
src_frame_name => $src_frame_name,
}
);
return;
} ## end sub make_frame
sub write_toc_html {
# write a separate html table of contents file for frames
my ($rarg_hash) = @_;
my $title = $rarg_hash->{title};
my $toc_filename = $rarg_hash->{toc_filename};
my $src_basename = $rarg_hash->{src_basename};
my $rtoc = $rarg_hash->{rtoc};
my $src_frame_name = $rarg_hash->{src_frame_name};
my $fh = IO::File->new( $toc_filename, 'w' )
or Perl::Tidy::Die("Cannot open $toc_filename: $OS_ERROR\n");
$fh->print(<
$title
$title
EOM
my $first_anchor_uu =
change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
$fh->print( join EMPTY_STRING, @{$rtoc} );
$fh->print(<
EOM
return;
} ## end sub write_toc_html
sub write_frame_html {
# write an html file to be the table of contents frame
my ($rarg_hash) = @_;
my $title = $rarg_hash->{title};
my $frame_filename = $rarg_hash->{frame_filename};
my $top_basename = $rarg_hash->{top_basename};
my $toc_basename = $rarg_hash->{toc_basename};
my $src_basename = $rarg_hash->{src_basename};
my $src_frame_name = $rarg_hash->{src_frame_name};
my $fh = IO::File->new( $frame_filename, 'w' )
or Perl::Tidy::Die("Cannot open $toc_basename: $OS_ERROR\n");
$fh->print(<
$title
EOM
# two left panels, one right, if master index file
if ($top_basename) {
$fh->print(<
EOM
}
# one left panels, one right, if no master index file
else {
$fh->print(<
EOM
}
$fh->print(<
<body>
<p>If you see this message, you are using a non-frame-capable web client.</p>
<p>This document contains:</p>
<ul>
<li><a href="$toc_basename">A table of contents</a></li>
<li><a href="$src_basename">The source code</a></li>
</ul>
</body>
EOM
return;
} ## end sub write_frame_html
sub change_anchor_names {
# add a filename and target to anchors
# also return the first anchor
my ( $rlines, $filename, $target ) = @_;
my $first_anchor;
foreach my $line ( @{$rlines} ) {
# We're looking for lines like this:
# SYNOPSIS
# ---- - -------- -----------------
# $1 $4 $5
if ( $line =~ /^(.*)]*>(.*)$/i ) {
my $pre = $1;
my $name = $4;
my $post = $5;
my $href = "$filename#$name";
$line = "$pre$post\n";
if ( !$first_anchor ) { $first_anchor = $href }
}
}
return $first_anchor;
} ## end sub change_anchor_names
sub close_html_file {
my $self = shift;
return unless $self->{_html_file_opened};
my $html_fh = $self->{_html_fh};
my $rtoc_string = $self->{_rtoc_string};
# There are 3 basic paths to html output...
# ---------------------------------
# Path 1: finish up if in -pre mode
# ---------------------------------
if ( $rOpts->{'html-pre-only'} ) {
$html_fh->print(<<"PRE_END");
PRE_END
$html_fh->close()
if ( $html_fh->can('close') );
return;
}
# Finish the index
$self->add_toc_item( 'EOF', 'EOF' );
my $rpre_string_stack = $self->{_rpre_string_stack};
# Patch to darken the background color in case of pod2html and
# interleaved code/documentation. Otherwise, the distinction
# between code and documentation is blurred.
if ( $rOpts->{pod2html}
&& $self->{_pod_cut_count} >= 1
&& $rOpts->{'html-color-background'} eq '#FFFFFF' )
{
$rOpts->{'html-pre-color-background'} = '#F0F0F0';
}
# put the css or its link into a string, if used
my $css_string;
my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );
# use css linked to another file,
if ( $rOpts->{'html-linked-style-sheet'} ) {
$fh_css->print(
qq());
}
# or no css,
elsif ( $rOpts->{'nohtml-style-sheets'} ) {
}
# or use css embedded in this file
else {
$fh_css->print(<<'ENDCSS');
ENDCSS
}
# -----------------------------------------------------------
# path 2: use pod2html if requested
# If we fail for some reason, continue on to path 3
# -----------------------------------------------------------
if ( $rOpts->{'pod2html'} ) {
my $rpod_string = $self->{_rpod_string};
$self->pod_to_html(
${$rpod_string}, $css_string,
${$rtoc_string}, $rpre_string_stack
) && return;
}
# --------------------------------------------------
# path 3: write code in html, with pod only in italics
# --------------------------------------------------
my $input_file = $self->{_input_file};
my $title = escape_html($input_file);
my $timestamp = EMPTY_STRING;
if ( $rOpts->{'timestamp'} ) {
my $date = localtime;
$timestamp = "on $date";
}
$html_fh->print(<<"HTML_START");
$title
HTML_START
# output the css, if used
if ($css_string) {
$html_fh->print($css_string);
$html_fh->print(<<"ENDCSS");
ENDCSS
}
else {
$html_fh->print(<<"HTML_START");
{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
HTML_START
}
$html_fh->print("\n");
$html_fh->print(<<"EOM");
$title
EOM
# copy the table of contents
if ( ${$rtoc_string}
&& !$rOpts->{'frames'}
&& $rOpts->{'html-table-of-contents'} )
{
$html_fh->print( ${$rtoc_string} );
}
# copy the pre section(s)
my $fname_comment = $input_file;
$fname_comment =~ s/--+/-/g; # protect HTML comment tags
$html_fh->print(<<"END_PRE");
END_PRE
foreach my $rpre_string ( @{$rpre_string_stack} ) {
$html_fh->print( ${$rpre_string} );
}
# and finish the html page
$html_fh->print(<<"HTML_END");
HTML_END
$html_fh->close()
if ( $html_fh->can('close') );
if ( $rOpts->{'frames'} ) {
my @toc = split /^/, ${$rtoc_string};
$self->make_frame( \@toc );
}
return;
} ## end sub close_html_file
sub markup_tokens {
my ( $self, $rtokens, $rtoken_type, $rlevels ) = @_;
my ( @colored_tokens, $type, $token, $level );
my $rlast_level = $self->{_rlast_level};
my $rpackage_stack = $self->{_rpackage_stack};
foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
$type = $rtoken_type->[$j];
$token = $rtokens->[$j];
$level = $rlevels->[$j];
$level = 0 if ( $level < 0 );
#-------------------------------------------------------
# Update the package stack. The package stack is needed to keep
# the toc correct because some packages may be declared within
# blocks and go out of scope when we leave the block.
#-------------------------------------------------------
if ( $level > ${$rlast_level} ) {
if ( !$rpackage_stack->[ $level - 1 ] ) {
$rpackage_stack->[ $level - 1 ] = 'main';
}
$rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
}
elsif ( $level < ${$rlast_level} ) {
my $package = $rpackage_stack->[$level];
if ( !$package ) { $package = 'main' }
# if we change packages due to a nesting change, we
# have to make an entry in the toc
if ( $package ne $rpackage_stack->[ $level + 1 ] ) {
$self->add_toc_item( $package, 'package' );
}
}
else {
## level unchanged
}
${$rlast_level} = $level;
#-------------------------------------------------------
# Intercept a sub name here; split it
# into keyword 'sub' and sub name; and add an
# entry in the toc
# Fix for c250: switch from 'i' to 'S'
#-------------------------------------------------------
if ( $type eq 'S' && $token =~ /^(\w+\s+)(\w.*)$/ ) {
$token = $self->markup_html_element( $1, 'k' );
push @colored_tokens, $token;
$token = $2;
$type = 'S';
# but don't include sub declarations in the toc;
# these will have leading token types 'i;'
my $signature = join EMPTY_STRING, @{$rtoken_type};
if ( $signature !~ /^i;/ ) {
my $subname = $token;
$subname =~ s/[\s\(].*$//; # remove any attributes and prototype
$self->add_toc_item( $subname, 'sub' );
}
}
#-------------------------------------------------------
# Intercept a package name here; split it
# into keyword 'package' and name; add to the toc,
# and update the package stack
#-------------------------------------------------------
# Fix for c250: switch from 'i' to 'P' and allow 'class' or 'package'
if ( $type eq 'P' && $token =~ /^(\w+\s+)(\w.*)$/ ) {
$token = $self->markup_html_element( $1, 'k' );
push @colored_tokens, $token;
$token = $2;
$type = 'i';
$self->add_toc_item( "$token", 'package' );
$rpackage_stack->[$level] = $token;
}
$token = $self->markup_html_element( $token, $type );
push @colored_tokens, $token;
}
return ( \@colored_tokens );
} ## end sub markup_tokens
sub markup_html_element {
my ( $self, $token, $type ) = @_;
return $token if ( $type eq 'b' ); # skip a blank token
return $token if ( $token =~ /^\s*$/ ); # skip a blank line
$token = escape_html($token);
# get the short abbreviation for this token type
my $short_name = $token_short_names{$type};
if ( !defined($short_name) ) {
$short_name = "pu"; # punctuation is default
}
# handle style sheets..
if ( !$rOpts->{'nohtml-style-sheets'} ) {
if ( $short_name ne 'pu' ) {
$token = qq() . $token . "";
}
}
# handle no style sheets..
else {
my $color = $html_color{$short_name};
if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
$token = qq() . $token . "";
}
if ( $html_italic{$short_name} ) { $token = "$token" }
if ( $html_bold{$short_name} ) { $token = "$token" }
}
return $token;
} ## end sub markup_html_element
sub escape_html {
my $token = shift;
if ( $missing_html_entities || !$rOpts_html_entities ) {
$token =~ s/\&/&/g;
$token =~ s/\/>/g;
$token =~ s/\"/"/g;
}
else {
HTML::Entities::encode_entities($token);
}
return $token;
} ## end sub escape_html
sub finish_formatting {
# called after last line
my $self = shift;
$self->close_html_file();
return;
} ## end sub finish_formatting
sub write_line {
my ( $self, $line_of_tokens ) = @_;
return unless $self->{_html_file_opened};
my $html_pre_fh = $self->{_html_pre_fh};
my $line_type = $line_of_tokens->{_line_type};
my $input_line = $line_of_tokens->{_line_text};
my $line_number = $line_of_tokens->{_line_number};
chomp $input_line;
# markup line of code..
my $html_line;
if ( $line_type eq 'CODE' ) {
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
my $rlevels = $line_of_tokens->{_rlevels};
if ( $input_line =~ /(^\s*)/ ) {
$html_line = $1;
}
else {
$html_line = EMPTY_STRING;
}
my ($rcolored_tokens) =
$self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
$html_line .= join EMPTY_STRING, @{$rcolored_tokens};
}
# markup line of non-code..
else {
my $line_character;
if ( $line_type eq 'HERE' ) { $line_character = 'H' }
elsif ( $line_type eq 'HERE_END' ) { $line_character = 'h' }
elsif ( $line_type eq 'FORMAT' ) { $line_character = 'H' }
elsif ( $line_type eq 'FORMAT_END' ) { $line_character = 'h' }
elsif ( $line_type eq 'SKIP' ) { $line_character = 'H' }
elsif ( $line_type eq 'SKIP_END' ) { $line_character = 'h' }
elsif ( $line_type eq 'SYSTEM' ) { $line_character = 'c' }
elsif ( $line_type eq 'END_START' ) {
$line_character = 'k';
$self->add_toc_item( '__END__', '__END__' );
}
elsif ( $line_type eq 'DATA_START' ) {
$line_character = 'k';
$self->add_toc_item( '__DATA__', '__DATA__' );
}
elsif ( $line_type =~ /^POD/ ) {
# fix for c250: changed 'P' to 'pd' here and in %token_short_names
# to allow use of 'P' as new package token type
$line_character = 'pd';
if ( $rOpts->{'pod2html'} ) {
my $html_pod_fh = $self->{_html_pod_fh};
if ( $line_type eq 'POD_START' ) {
my $rpre_string_stack = $self->{_rpre_string_stack};
my $rpre_string = $rpre_string_stack->[-1];
# if we have written any non-blank lines to the
# current pre section, start writing to a new output
# string
if ( ${$rpre_string} =~ /\S/ ) {
my $pre_string;
$html_pre_fh =
Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
$self->{_html_pre_fh} = $html_pre_fh;
push @{$rpre_string_stack}, \$pre_string;
# leave a marker in the pod stream so we know
# where to put the pre section we just
# finished.
my $for_html = '=for html'; # don't confuse pod utils
$html_pod_fh->print(<
EOM
}
# otherwise, just clear the current string and start
# over
else {
${$rpre_string} = EMPTY_STRING;
$html_pod_fh->print("\n");
}
}
$html_pod_fh->print( $input_line . "\n" );
if ( $line_type eq 'POD_END' ) {
$self->{_pod_cut_count}++;
$html_pod_fh->print("\n");
}
return;
}
}
else { $line_character = 'Q' }
$html_line = $self->markup_html_element( $input_line, $line_character );
}
# add the line number if requested
if ( $rOpts->{'html-line-numbers'} ) {
my $extra_space =
( $line_number < 10 ) ? SPACE x 3
: ( $line_number < 100 ) ? SPACE x 2
: ( $line_number < 1000 ) ? SPACE
: EMPTY_STRING;
$html_line = $extra_space . $line_number . SPACE . $html_line;
}
# write the line
$html_pre_fh->print("$html_line\n");
return;
} ## end sub write_line
} ## end package Perl::Tidy::HtmlWriter
1;
Perl-Tidy-20250105/lib/Perl/Tidy/Formatter.pm 0000644 0001750 0001750 00006002613 14735563566 017537 0 ustar steve steve ####################################################################
#
# The Perl::Tidy::Formatter package adds indentation, whitespace, and
# line breaks to the token stream
# Usage Outline:
#
# STEP 1: initialize or re-initialize Formatter with user options
# Perl::Tidy::Formatter::check_options($rOpts);
#
# STEP 2: crate a tokenizer for the source stream
#
# STEP 3: create a formatter for the destination stream
# my $formatter = Perl::Tidy::Formatter->new(
# ...
# sink_object => $destination,
# ...
# );
#
# STEP 4: process each input line (see sub Perl::Tidy::process_single_case)
# while ( my $line = $tokenizer->get_line() ) {
# $formatter->write_line($line);
# }
#
# STEP 4: finish formatting
# $formatter->finish_formatting($severe_error);
#
#####################################################################
# Index...
# CODE SECTION 1: Preliminary code, global definitions and sub new
# sub new
# CODE SECTION 2: Some Basic Utilities
# CODE SECTION 3: Check and process options
# sub check_options
# CODE SECTION 4: Receive lines from the tokenizer
# sub write_line
# CODE SECTION 5: Pre-process the entire file
# sub finish_formatting
# CODE SECTION 6: Process line-by-line
# sub process_all_lines
# CODE SECTION 7: Process lines of code
# process_line_of_CODE
# CODE SECTION 8: Utilities for setting breakpoints
# sub set_forced_breakpoint
# CODE SECTION 9: Process batches of code
# sub grind_batch_of_CODE
# CODE SECTION 10: Code to break long statements
# sub break_long_lines
# CODE SECTION 11: Code to break long lists
# sub break_lists
# CODE SECTION 12: Code for setting indentation
# CODE SECTION 13: Preparing batch of lines for vertical alignment
# sub convey_batch_to_vertical_aligner
# CODE SECTION 14: Code for creating closing side comments
# sub add_closing_side_comment
# CODE SECTION 15: Summarize
# sub wrapup
#######################################################################
# CODE SECTION 1: Preliminary code and global definitions up to sub new
#######################################################################
package Perl::Tidy::Formatter;
use strict;
use warnings;
# DEVEL_MODE gets switched on during automated testing for extra checking
use constant DEVEL_MODE => 0;
use constant EMPTY_STRING => q{};
use constant SPACE => q{ };
use constant BACKSLASH => q{\\};
{ #<<< A non-indenting brace to contain all lexical variables
use Carp;
use English qw( -no_match_vars );
use List::Util qw( min max first ); # min, max first are in Perl 5.8
our $VERSION = '20250105';
# The Tokenizer will be loaded with the Formatter
##use Perl::Tidy::Tokenizer; # for is_keyword()
sub AUTOLOAD {
# Catch any undefined sub calls so that we are sure to get
# some diagnostic information. This sub should never be called
# except for a programming error.
our $AUTOLOAD;
return if ( $AUTOLOAD =~ /\bDESTROY$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print {*STDERR} < $i++,
_CUMULATIVE_LENGTH_ => $i++,
_LINE_INDEX_ => $i++,
_LEVEL_ => $i++,
_TOKEN_ => $i++,
_TOKEN_LENGTH_ => $i++,
_TYPE_ => $i++,
_TYPE_SEQUENCE_ => $i++,
# Number of token variables; must be last in list:
_NVARS => $i++,
};
} ## end BEGIN
BEGIN {
# Index names for $self variables.
# Do not combine with other BEGIN blocks (c101).
my $i = 0;
use constant {
_rlines_ => $i++,
_rLL_ => $i++,
_Klimit_ => $i++,
_rdepth_of_opening_seqno_ => $i++,
_rSS_ => $i++,
_rI_opening_ => $i++,
_rI_closing_ => $i++,
_rK_next_seqno_by_K_ => $i++,
_rblock_type_of_seqno_ => $i++,
_ris_asub_block_ => $i++,
_ris_sub_block_ => $i++,
_K_opening_container_ => $i++,
_K_closing_container_ => $i++,
_K_opening_ternary_ => $i++,
_K_closing_ternary_ => $i++,
_rK_sequenced_token_list_ => $i++,
_rtype_count_by_seqno_ => $i++,
_ris_function_call_paren_ => $i++,
_rlec_count_by_seqno_ => $i++,
_ris_broken_container_ => $i++,
_ris_permanently_broken_ => $i++,
_rblank_and_comment_count_ => $i++,
_rhas_list_ => $i++,
_rhas_broken_list_ => $i++,
_rhas_broken_list_with_lec_ => $i++,
_rfirst_comma_line_index_ => $i++,
_rhas_code_block_ => $i++,
_rhas_broken_code_block_ => $i++,
_rhas_ternary_ => $i++,
_ris_excluded_lp_container_ => $i++,
_rlp_object_by_seqno_ => $i++,
_rwant_reduced_ci_ => $i++,
_rno_xci_by_seqno_ => $i++,
_rbrace_left_ => $i++,
_ris_bli_container_ => $i++,
_rparent_of_seqno_ => $i++,
_rchildren_of_seqno_ => $i++,
_ris_list_by_seqno_ => $i++,
_ris_cuddled_closing_brace_ => $i++,
_rbreak_container_ => $i++,
_rshort_nested_ => $i++,
_length_function_ => $i++,
_is_encoded_data_ => $i++,
_fh_tee_ => $i++,
_sink_object_ => $i++,
_file_writer_object_ => $i++,
_vertical_aligner_object_ => $i++,
_logger_object_ => $i++,
_radjusted_levels_ => $i++,
_ris_special_identifier_token_ => $i++,
_last_output_short_opening_token_ => $i++,
_last_line_leading_type_ => $i++,
_last_line_leading_level_ => $i++,
_added_semicolon_count_ => $i++,
_first_added_semicolon_at_ => $i++,
_last_added_semicolon_at_ => $i++,
_deleted_semicolon_count_ => $i++,
_first_deleted_semicolon_at_ => $i++,
_last_deleted_semicolon_at_ => $i++,
_embedded_tab_count_ => $i++,
_first_embedded_tab_at_ => $i++,
_last_embedded_tab_at_ => $i++,
_first_tabbing_disagreement_ => $i++,
_last_tabbing_disagreement_ => $i++,
_tabbing_disagreement_count_ => $i++,
_in_tabbing_disagreement_ => $i++,
_first_brace_tabbing_disagreement_ => $i++,
_in_brace_tabbing_disagreement_ => $i++,
_saw_VERSION_in_this_file_ => $i++,
_saw_use_strict_ => $i++,
_saw_END_or_DATA_ => $i++,
_rK_weld_left_ => $i++,
_rK_weld_right_ => $i++,
_rweld_len_right_at_K_ => $i++,
_rspecial_side_comment_type_ => $i++,
_rseqno_controlling_my_ci_ => $i++,
_ris_seqno_controlling_ci_ => $i++,
_save_logfile_ => $i++,
_maximum_level_ => $i++,
_maximum_level_at_line_ => $i++,
_maximum_BLOCK_level_ => $i++,
_maximum_BLOCK_level_at_line_ => $i++,
_rKrange_code_without_comments_ => $i++,
_rbreak_before_Kfirst_ => $i++,
_rbreak_after_Klast_ => $i++,
_converged_ => $i++,
_want_second_iteration_ => $i++,
_rstarting_multiline_qw_seqno_by_K_ => $i++,
_rending_multiline_qw_seqno_by_K_ => $i++,
_rKrange_multiline_qw_by_seqno_ => $i++,
_rmultiline_qw_has_extra_level_ => $i++,
_rcollapsed_length_by_seqno_ => $i++,
_rbreak_before_container_by_seqno_ => $i++,
_roverride_cab3_ => $i++,
_ris_assigned_structure_ => $i++,
_ris_short_broken_eval_block_ => $i++,
_ris_bare_trailing_comma_by_seqno_ => $i++,
_rseqno_non_indenting_brace_by_ix_ => $i++,
_rmax_vertical_tightness_ => $i++,
_no_vertical_tightness_flags_ => $i++,
_last_vt_type_ => $i++,
_rwant_arrow_before_seqno_ => $i++,
_rseqno_arrow_call_chain_start_ => $i++,
_rarrow_call_chain_ => $i++,
# these vars are defined after call to respace tokens:
_rK_package_list_ => $i++,
_rK_AT_underscore_by_sub_seqno_ => $i++,
_rK_first_self_by_sub_seqno_ => $i++,
_rK_bless_by_sub_seqno_ => $i++,
_rK_return_by_sub_seqno_ => $i++,
_rK_wantarray_by_sub_seqno_ => $i++,
_rK_sub_by_seqno_ => $i++,
_ris_my_sub_by_seqno_ => $i++,
_rsub_call_paren_info_by_seqno_ => $i++,
_rDOLLAR_underscore_by_sub_seqno_ => $i++,
_this_batch_ => $i++,
_LAST_SELF_INDEX_ => $i - 1,
};
} ## end BEGIN
BEGIN {
# Index names for variables stored in _this_batch_.
# Do not combine with other BEGIN blocks (c101).
my $i = 0;
use constant {
_starting_in_quote_ => $i++,
_ending_in_quote_ => $i++,
_is_static_block_comment_ => $i++,
_ri_first_ => $i++,
_ri_last_ => $i++,
_do_not_pad_ => $i++,
_peak_batch_size_ => $i++,
_batch_count_ => $i++,
_rix_seqno_controlling_ci_ => $i++,
_batch_CODE_type_ => $i++,
_ri_starting_one_line_block_ => $i++,
_runmatched_opening_indexes_ => $i++,
};
} ## end BEGIN
BEGIN {
# Sequence number assigned to the root of sequence tree.
# The minimum of the actual sequences numbers is 4, so we can use 1
use constant SEQ_ROOT => 1;
# Codes for insertion and deletion of blanks
use constant DELETE => 0;
use constant STABLE => 1;
use constant INSERT => 2;
# whitespace codes
use constant WS_YES => 1;
use constant WS_OPTIONAL => 0;
use constant WS_NO => -1;
# Token bond strengths.
use constant NO_BREAK => 10_000;
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;
# This is the decimal range of printable characters in ASCII. It is used to
# make quick preliminary checks before resorting to using a regex.
use constant ORD_PRINTABLE_MIN => 33;
use constant ORD_PRINTABLE_MAX => 126;
# Initialize constant hashes ...
my @q;
@q = qw( = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x= );
@is_assignment{@q} = (1) x scalar(@q);
# a hash needed by break_lists for efficiency:
push @q, qw{ ; < > ~ f };
@is_non_list_type{@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);
# 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'
@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);
# These can either have the BLOCK form or trailing modifier form:
@q = qw( if unless while until for foreach );
@is_if_unless_while_until_for_foreach{@q} =
(1) x scalar(@q);
# These can have several forms
@q = qw( for foreach );
@is_for_foreach{@q} = (1) x scalar(@q);
@q = qw( last next redo return );
@is_last_next_redo_return{@q} = (1) x scalar(@q);
# Map related block names into a common name to allow vertical alignment
# used by sub make_alignment_patterns. Note: this is normally unchanged,
# but it contains 'grep' and can be re-initialized in
# sub initialize_grep_and_friends in a testing mode.
%block_type_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'if',
'default' => 'if',
'case' => 'if',
'sort' => 'map',
'grep' => 'map',
);
@q = qw( if unless );
@is_if_unless{@q} = (1) x scalar(@q);
@q = qw( if elsif );
@is_if_elsif{@q} = (1) x scalar(@q);
@q = qw( if unless elsif );
@is_if_unless_elsif{@q} = (1) x scalar(@q);
@q = qw( if unless elsif else );
@is_if_unless_elsif_else{@q} = (1) x scalar(@q);
@q = qw( elsif else );
@is_elsif_else{@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);
# Operators that the user can request break before or after.
# Note that some are keywords
@all_operators = qw{
% + - * / x != == >= <= =~ !~ < > | &
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
. : ? && || and or err xor
};
# 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);
@q = qw( ? : );
@is_ternary{@q} = (1) x scalar(@q);
@q = qw< { ( [ ? >;
@is_opening_sequence_token{@q} = (1) x scalar(@q);
@q = qw< } ) ] : >;
@is_closing_sequence_token{@q} = (1) x scalar(@q);
%matching_token = (
'{' => '}',
'(' => ')',
'[' => ']',
'?' => ':',
'}' => '{',
')' => '(',
']' => '[',
':' => '?',
);
# a hash needed by sub break_lists for labeling containers
@q = qw( k => && || ? : . );
@is_container_label_type{@q} = (1) x scalar(@q);
@q = qw( die confess croak warn );
@is_die_confess_croak_warn{@q} = (1) x scalar(@q);
@q = qw( my our local );
@is_my_our_local{@q} = (1) x scalar(@q);
# Braces -bbht etc must follow these. Note: experimentation with
# including a simple comma shows that it adds little and can lead
# to poor formatting in complex lists.
@q = qw( = => );
@is_equal_or_fat_comma{@q} = (1) x scalar(@q);
@q = qw( => ; h f );
push @q, ',';
@is_counted_type{@q} = (1) x scalar(@q);
# Tokens where --keep-old-break-xxx flags make soft breaks instead
# of hard breaks. See b1433 and b1436.
# NOTE: $type is used as the hash key for now; if other container tokens
# are added it might be necessary to use a token/type mixture.
@q = qw# -> ? : && || + - / * #;
@is_soft_keep_break_type{@q} = (1) x scalar(@q);
# these functions allow an identifier in the indirect object slot
@q = qw( print printf sort exec system say );
@is_indirect_object_taker{@q} = (1) x scalar(@q);
# 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 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);
# 'k'=builtin keyword, 'U'=user defined sub, 'w'=unknown bareword
@q = qw( k w U );
@is_kwU{@q} = (1) x scalar(@q);
# regular expression match operators
@q = qw( =~ !~);
@is_re_match_op{@q} = (1) x scalar(@q);
@q = qw ( my state our );
@is_my_state_our{@q} = (1) x scalar(@q);
# These keywords have prototypes which allow a special leading item
# followed by a list
@q =
qw( chmod formline grep join kill map pack printf push sprintf unshift );
@is_keyword_with_special_leading_term{@q} = (1) x scalar(@q);
} ## end BEGIN
{ ## begin closure to count instances
# methods to count instances
my $_count = 0;
sub _increment_count { return ++$_count }
sub _decrement_count { return --$_count }
} ## end closure to count instances
sub new {
my ( $class, @arglist ) = @_;
if ( @arglist % 2 ) { croak "Odd number of items in arg hash list\n" }
# 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 => undef,
is_encoded_data => EMPTY_STRING,
fh_tee => undef,
);
my %args = ( %defaults, @arglist );
my $length_function = $args{length_function};
my $is_encoded_data = $args{is_encoded_data};
my $fh_tee = $args{fh_tee};
my $logger_object = $args{logger_object};
my $diagnostics_object = $args{diagnostics_object};
# we create another object with a get_line() and peek_ahead() method
my $sink_object = $args{sink_object};
my $file_writer_object =
Perl::Tidy::FileWriter->new( $sink_object, $rOpts, $logger_object );
# initialize closure variables...
set_logger_object($logger_object);
set_diagnostics_object($diagnostics_object);
initialize_lp_vars();
initialize_csc_vars();
initialize_break_lists();
initialize_undo_ci();
initialize_process_line_of_CODE();
initialize_grind_batch_of_CODE();
initialize_get_final_indentation();
initialize_postponed_breakpoint();
initialize_batch_variables();
initialize_write_line();
my $vertical_aligner_object = Perl::Tidy::VerticalAligner->new(
rOpts => $rOpts,
file_writer_object => $file_writer_object,
logger_object => $logger_object,
diagnostics_object => $diagnostics_object,
);
write_logfile_entry("\nStarting tokenization pass...\n");
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");
}
# Initialize the $self array reference.
# To add an item, first add a constant index in the BEGIN block above.
my $self = [];
bless $self, $class;
# Basic data structures...
$self->[_rlines_] = []; # = ref to array of lines of the file
# 'rLL' = reference to the continuous liner array of all tokens in a file.
# 'LL' stands for 'Linked List'. Using a linked list was a disaster, but
# 'LL' stuck because it is easy to type. The 'rLL' array is updated
# by sub 'respace_tokens' during reformatting. The indexes in 'rLL' begin
# with '$K' by convention.
$self->[_rLL_] = [];
$self->[_Klimit_] = undef; # = maximum K index for rLL.
# Indexes into the rLL list
$self->[_K_opening_container_] = {};
$self->[_K_closing_container_] = {};
$self->[_K_opening_ternary_] = {};
$self->[_K_closing_ternary_] = {};
# A list of index K of sequenced tokens to allow loops over them all
$self->[_rK_sequenced_token_list_] = [];
# 'rSS' is the 'Signed Sequence' list, a continuous list of all sequence
# numbers with + or - indicating opening or closing. This list represents
# the entire container tree and is invariant under reformatting. It can be
# used to quickly travel through the tree. Indexes in the rSS array begin
# with '$I' by convention.
$self->[_rSS_] = [];
$self->[_rI_opening_] = [];
$self->[_rI_closing_] = [];
$self->[_rK_next_seqno_by_K_] = [];
# Arrays to help traverse the tree
$self->[_rdepth_of_opening_seqno_] = [];
$self->[_rblock_type_of_seqno_] = {};
$self->[_ris_asub_block_] = {};
$self->[_ris_sub_block_] = {};
# Variables for --warn-mismatched-args and
# --dump-mismatched-args
# --dump-mismatched-returns
# --warn-mismatched-returns
$self->[_rK_package_list_] = [];
$self->[_rK_AT_underscore_by_sub_seqno_] = {};
$self->[_rK_first_self_by_sub_seqno_] = {};
$self->[_rK_bless_by_sub_seqno_] = {};
$self->[_rK_return_by_sub_seqno_] = {};
$self->[_rK_wantarray_by_sub_seqno_] = {};
$self->[_rsub_call_paren_info_by_seqno_] = {};
$self->[_rDOLLAR_underscore_by_sub_seqno_] = {};
$self->[_rK_sub_by_seqno_] = {};
$self->[_ris_my_sub_by_seqno_] = {};
$self->[_this_batch_] = [];
# Mostly list characteristics and processing flags
$self->[_rtype_count_by_seqno_] = {};
$self->[_ris_function_call_paren_] = {};
$self->[_rlec_count_by_seqno_] = {};
$self->[_ris_broken_container_] = {};
$self->[_ris_permanently_broken_] = {};
$self->[_rblank_and_comment_count_] = {};
$self->[_rhas_list_] = {};
$self->[_rhas_broken_list_] = {};
$self->[_rhas_broken_list_with_lec_] = {};
$self->[_rfirst_comma_line_index_] = {};
$self->[_rhas_code_block_] = {};
$self->[_rhas_broken_code_block_] = {};
$self->[_rhas_ternary_] = {};
$self->[_ris_excluded_lp_container_] = {};
$self->[_rlp_object_by_seqno_] = {};
$self->[_rwant_reduced_ci_] = {};
$self->[_rno_xci_by_seqno_] = {};
$self->[_rbrace_left_] = {};
$self->[_ris_bli_container_] = {};
$self->[_rparent_of_seqno_] = {};
$self->[_rchildren_of_seqno_] = {};
$self->[_ris_list_by_seqno_] = {};
$self->[_ris_cuddled_closing_brace_] = {};
$self->[_rbreak_container_] = {}; # prevent one-line blocks
$self->[_rshort_nested_] = {}; # blocks not forced open
$self->[_length_function_] = $length_function;
$self->[_is_encoded_data_] = $is_encoded_data;
# Some objects...
$self->[_fh_tee_] = $fh_tee;
$self->[_sink_object_] = $sink_object;
$self->[_file_writer_object_] = $file_writer_object;
$self->[_vertical_aligner_object_] = $vertical_aligner_object;
$self->[_logger_object_] = $logger_object;
# Memory of processed text...
$self->[_ris_special_identifier_token_] = {};
$self->[_last_line_leading_level_] = 0;
$self->[_last_line_leading_type_] = '#';
$self->[_last_output_short_opening_token_] = 0;
$self->[_added_semicolon_count_] = 0;
$self->[_first_added_semicolon_at_] = 0;
$self->[_last_added_semicolon_at_] = 0;
$self->[_deleted_semicolon_count_] = 0;
$self->[_first_deleted_semicolon_at_] = 0;
$self->[_last_deleted_semicolon_at_] = 0;
$self->[_embedded_tab_count_] = 0;
$self->[_first_embedded_tab_at_] = 0;
$self->[_last_embedded_tab_at_] = 0;
$self->[_first_tabbing_disagreement_] = 0;
$self->[_last_tabbing_disagreement_] = 0;
$self->[_tabbing_disagreement_count_] = 0;
$self->[_in_tabbing_disagreement_] = 0;
$self->[_saw_VERSION_in_this_file_] = !$rOpts->{'pass-version-line'};
$self->[_saw_use_strict_] = 0;
$self->[_saw_END_or_DATA_] = 0;
$self->[_first_brace_tabbing_disagreement_] = undef;
$self->[_in_brace_tabbing_disagreement_] = undef;
# Hashes related to container welding...
$self->[_radjusted_levels_] = [];
# Weld data structures
$self->[_rK_weld_left_] = {};
$self->[_rK_weld_right_] = {};
$self->[_rweld_len_right_at_K_] = {};
# -xci stuff
$self->[_rseqno_controlling_my_ci_] = {};
$self->[_ris_seqno_controlling_ci_] = {};
$self->[_rspecial_side_comment_type_] = {};
$self->[_maximum_level_] = 0;
$self->[_maximum_level_at_line_] = 0;
$self->[_maximum_BLOCK_level_] = 0;
$self->[_maximum_BLOCK_level_at_line_] = 0;
$self->[_rKrange_code_without_comments_] = [];
$self->[_rbreak_before_Kfirst_] = {};
$self->[_rbreak_after_Klast_] = {};
$self->[_converged_] = 0;
$self->[_want_second_iteration_] = 0;
# qw stuff
$self->[_rstarting_multiline_qw_seqno_by_K_] = {};
$self->[_rending_multiline_qw_seqno_by_K_] = {};
$self->[_rKrange_multiline_qw_by_seqno_] = {};
$self->[_rmultiline_qw_has_extra_level_] = {};
$self->[_rcollapsed_length_by_seqno_] = {};
$self->[_rbreak_before_container_by_seqno_] = {};
$self->[_roverride_cab3_] = {};
$self->[_ris_assigned_structure_] = {};
$self->[_ris_short_broken_eval_block_] = {};
$self->[_ris_bare_trailing_comma_by_seqno_] = {};
$self->[_rseqno_non_indenting_brace_by_ix_] = {};
$self->[_rmax_vertical_tightness_] = {};
$self->[_no_vertical_tightness_flags_] = 0;
$self->[_last_vt_type_] = 0;
$self->[_rwant_arrow_before_seqno_] = {};
$self->[_rseqno_arrow_call_chain_start_] = {};
$self->[_rarrow_call_chain_] = {};
$self->[_save_logfile_] =
defined($logger_object) && $logger_object->get_save_logfile();
# Be sure all variables in $self have been initialized above. To find the
# correspondence of index numbers and array names, copy a list to a file
# and use the unix 'nl' command to number lines 1..
if (DEVEL_MODE) {
my @non_existant;
foreach ( 0 .. _LAST_SELF_INDEX_ ) {
if ( !exists $self->[$_] ) {
push @non_existant, $_;
}
}
if (@non_existant) {
Fault("These indexes in self not initialized: (@non_existant)\n");
}
}
# 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 $self;
} ## end sub new
######################################
# CODE SECTION 2: Some Basic Utilities
######################################
sub check_rLL {
# Verify that the rLL array has not been auto-vivified
my ( $self, $msg ) = @_;
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my $num = @{$rLL};
if ( ( defined($Klimit) && $Klimit != $num - 1 )
|| ( !defined($Klimit) && $num > 0 ) )
{
# This fault can occur if the array has been accessed for an index
# greater than $Klimit, which is the last token index. Just accessing
# the array above index $Klimit, not setting a value, can cause @rLL to
# increase beyond $Klimit. If this occurs, the problem can be located
# by making calls to this routine at different locations in
# sub 'finish_formatting'.
$Klimit = 'undef' if ( !defined($Klimit) );
$msg = EMPTY_STRING unless $msg;
Fault("$msg ERROR: rLL has num=$num but Klimit='$Klimit'\n");
}
return;
} ## end sub check_rLL
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 $LIST_SEPARATOR = ')(';
my @expected_keys = sort keys %{$rvalid};
@unknown_keys = sort @unknown_keys;
Fault(<[_rLL_];
foreach my $KK ( 0 .. @{$rLL} - 1 ) {
my $nvars = @{ $rLL->[$KK] };
if ( $nvars != _NVARS ) {
my $NVARS = _NVARS;
my $type = $rLL->[$KK]->[_TYPE_];
$type = '*' unless defined($type);
# The number of variables per token node is _NVARS and was set when
# the array indexes were generated. So if the number of variables
# is different we have done something wrong, like not store all of
# them in sub 'write_line' when they were received from the
# tokenizer.
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_];
# This is a simple check that each token has some basic
# variables. In other words, that there are no holes in the
# array of tokens. Sub 'write_line' pushes tokens into the
# $rLL array, so this should guarantee no gaps.
Fault("Undefined variable $var for K=$KK, line=$iline\n");
}
}
}
#---------------------------------
# Check $rK_next_seqno_by_K->[$KK]
#---------------------------------
my $Klimit = @{$rLL} - 1;
my $K_last_seqno;
my $rK_next_seqno_by_K = $self->[_rK_next_seqno_by_K_];
foreach my $KK ( 0 .. $Klimit ) {
my $K_next_seqno = $rK_next_seqno_by_K->[$KK];
if ( !defined($K_next_seqno) ) { $K_last_seqno = $KK; last }
if ( $K_next_seqno <= $KK || $K_next_seqno > $Klimit ) {
Fault(<[$K_next_seqno]->[_TYPE_SEQUENCE_] ) {
Fault(<[$KK];
next if ( !defined($Ktest) );
Fault(<[_rparent_of_seqno_];
foreach my $seqno ( keys %{$rparent_of_seqno} ) {
# parent sequence numbers must always be less
my $seqno_parent = $rparent_of_seqno->{$seqno};
if ( $seqno_parent >= $seqno ) {
Fault(<[_rlines_];
# Note that the keys ending in _0 are only required when a logfile
# is being saved, so we will just check for unknown keys, but not
# require an exact match.
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", 0 );
}
return;
} ## end sub check_line_hashes
} ## end closure check_line_hashes
{ ## begin closure for logger routines
my $logger_object;
# Called once per file to initialize the logger object
sub set_logger_object {
$logger_object = shift;
return;
}
sub get_input_stream_name {
my $input_stream_name = EMPTY_STRING;
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
return $input_stream_name;
} ## end sub get_input_stream_name
# interface to Perl::Tidy::Logger routines
sub warning {
my ( $msg, ($msg_line_number) ) = @_;
# Issue a warning message
# Given:
# $msg = text of warning
# $msg_line_number = optional line number prefix
if ($logger_object) {
$logger_object->warning( $msg, $msg_line_number );
}
return;
} ## end sub warning
sub complain {
my ( $msg, ($msg_line_number) ) = @_;
# Issue a complaint message
# Given:
# $msg = text of complaint
# $msg_line_number = optional line number prefix
if ($logger_object) {
$logger_object->complain( $msg, $msg_line_number );
}
return;
} ## end sub complain
sub write_logfile_entry {
my @msg = @_;
if ($logger_object) {
$logger_object->write_logfile_entry(@msg);
}
return;
} ## end sub write_logfile_entry
sub get_saw_brace_error {
if ($logger_object) {
return $logger_object->get_saw_brace_error();
}
return;
} ## end sub get_saw_brace_error
sub we_are_at_the_last_line {
if ($logger_object) {
$logger_object->we_are_at_the_last_line();
}
return;
} ## end sub we_are_at_the_last_line
} ## end closure for logger routines
{ ## begin closure for diagnostics routines
my $diagnostics_object;
# Called once per file to initialize the diagnostics object
sub set_diagnostics_object {
$diagnostics_object = shift;
return;
}
# Available for debugging but not currently used:
sub write_diagnostics {
my ( $msg, $line_number ) = @_;
if ($diagnostics_object) {
$diagnostics_object->write_diagnostics( $msg, $line_number );
}
return;
} ## end sub write_diagnostics
} ## end closure for diagnostics routines
sub get_convergence_check {
my ($self) = @_;
return $self->[_converged_];
}
sub want_second_iteration {
my ($self) = @_;
return $self->[_want_second_iteration_];
}
sub get_output_line_number {
my ($self) = @_;
my $vao = $self->[_vertical_aligner_object_];
return $vao->get_output_line_number();
}
sub want_blank_line {
my $self = shift;
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->want_blank_line();
return;
} ## end sub want_blank_line
sub write_unindented_line {
my ( $self, $line ) = @_;
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_line($line);
return;
} ## end sub write_unindented_line
sub dump_verbatim {
my $self = shift;
# Dump the input file to the output verbatim. This is called when
# there is a severe error and formatted output cannot be made.
my $rlines = $self->[_rlines_];
foreach my $line ( @{$rlines} ) {
my $input_line = $line->{_line_text};
$self->write_unindented_line($input_line);
}
return;
} ## end sub dump_verbatim
sub consecutive_nonblank_lines {
my ($self) = @_;
my $file_writer_object = $self->[_file_writer_object_];
my $vao = $self->[_vertical_aligner_object_];
return $file_writer_object->get_consecutive_nonblank_lines() +
$vao->get_cached_line_count();
} ## end sub consecutive_nonblank_lines
sub split_words {
# Given: a string containing words separated by whitespace,
# Return: the corresponding list of words
my ($str) = @_;
return unless defined($str);
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return unless length($str);
return split /\s+/, $str;
} ## end sub split_words
sub K_next_code {
my ( $self, $KK, ($rLL) ) = @_;
# Given:
# $KK = index of a token in $rLL
# $rLL = optional token array to use (default is $self->[_rLL_])
# Return:
# The index of the next nonblank, non-comment token after $KK, or
# undef if none
return if ( !defined($KK) );
return if ( $KK < 0 );
# The optional third arg is useful when we are copying tokens from an old
# $rLL to a new $rLL array.
$rLL = $self->[_rLL_] if ( !defined($rLL) );
my $Num = @{$rLL};
while ( ++$KK < $Num ) {
my $type = $rLL->[$KK]->[_TYPE_];
if ( $type ne 'b' && $type ne '#' ) {
return $KK;
}
} ## end while ( ++$KK < $Num )
return;
} ## end sub K_next_code
sub K_next_nonblank {
my ( $self, $KK, ($rLL) ) = @_;
# Given:
# $KK = index of a token in $rLL
# $rLL = optional token array to use (default is $self->[_rLL_])
# Return:
# The index of the next nonblank token after $KK, or
# undef if none
# NOTE: does not skip over the leading type 'q' of a hanging side comment
# (use K_next_code)
return if ( !defined($KK) );
return if ( $KK < 0 );
# use the standard array unless given otherwise
$rLL = $self->[_rLL_] if ( !defined($rLL) );
# Normally, consecutive blanks do not occur. We could test for that
# here, but there are checks in the 'store_token' subs.
my $Num = @{$rLL};
while ( ++$KK < $Num ) {
if ( $rLL->[$KK]->[_TYPE_] ne 'b' ) { return $KK }
}
return;
} ## end sub K_next_nonblank
sub K_previous_code {
my ( $self, $KK, ($rLL) ) = @_;
# Given:
# $KK = index of a token in $rLL
# $rLL = optional token array to use (default is $self->[_rLL_])
# Return:
# The index of the previous nonblank, non-comment token after $KK, or
# undef if none
# Call with $KK=undef to start search at the top of the array
# The optional third arg is useful when we are copying tokens from an old
# $rLL to a new $rLL array.
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
if ( $KK > $Num ) {
# This fault can be caused by a programming error in which a bad $KK is
# given. The caller should make the first call with KK_new=undef to
# avoid this error.
if (DEVEL_MODE) {
Fault(<= 0 ) {
my $type = $rLL->[$KK]->[_TYPE_];
if ( $type ne 'b' && $type ne '#' ) { return $KK }
}
return;
} ## end sub K_previous_code
sub K_previous_nonblank {
my ( $self, $KK, ($rLL) ) = @_;
# Given:
# $KK = index of a token in $rLL
# $rLL = optional token array to use (default is $self->[_rLL_])
# Return:
# The index of the previous nonblank token after $KK, or
# undef if none
# Call with $KK=undef to start search at the top of the array
# NOTE: does not skip over the leading type 'q' of a hanging side comment
# (use K_previous_code)
# use the standard array unless given otherwise
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
if ( $KK > $Num ) {
# This fault can be caused by a programming error in which a bad $KK is
# given. The caller should make the first call with KK_new=undef to
# avoid this error.
if (DEVEL_MODE) {
Fault(<= 0 ) {
if ( $rLL->[$KK]->[_TYPE_] ne 'b' ) { return $KK }
}
return;
} ## end sub K_previous_nonblank
sub K_first_code {
my ( $self, ($rLL) ) = @_;
# Given:
# $rLL = optional token array to override default
# Return:
# index $K of first non-blank, non-comment code token, or
# undef if none (no tokens in the file)
$rLL = $self->[_rLL_] unless ( defined($rLL) );
return unless @{$rLL};
my $KK = 0;
my $type = $rLL->[$KK]->[_TYPE_];
if ( $type ne 'b' && $type ne '#' ) { return $KK }
return $self->K_next_code($KK);
} ## end sub K_first_code
sub K_last_code {
my ( $self, ($rLL) ) = @_;
# Given:
# $rLL = optional token array to override default
# Return:
# index of last non-blank, non-comment code token, or
# undef if none (no tokens in the file)
$rLL = $self->[_rLL_] unless ( defined($rLL) );
return unless @{$rLL};
my $KK = @{$rLL} - 1;
my $type = $rLL->[$KK]->[_TYPE_];
if ( $type ne 'b' && $type ne '#' ) { return $KK }
return $self->K_previous_code($KK);
} ## end sub K_last_code
sub get_parent_containers {
my ( $self, $seqno ) = @_;
# Given:
# $seqno = sequence number of a container
# Return:
# ref to a list of parent container sequence numbers
my @list;
if ($seqno) {
my $rparent_of_seqno = $self->[_rparent_of_seqno_];
my $seqno_last = $seqno;
while ( $seqno = $rparent_of_seqno->{$seqno} ) {
last if ( $seqno == SEQ_ROOT );
if ( $seqno >= $seqno_last ) {
## shouldn't happen - parent containers have lower seq numbers
DEVEL_MODE && Fault(<{$seqno}=$value for all parent containers
# but not for $seqno itself
# Given:
# $seqno = sequence number of a container
# $rhash = ref to a hash with seqno as key
# $value = value for setting $rhash->{$seqno}=$value
# default = 1
return unless ($seqno);
if ( !defined($value) ) { $value = 1 }
my $rparent_of_seqno = $self->[_rparent_of_seqno_];
my $seqno_last = $seqno;
while ( $seqno = $rparent_of_seqno->{$seqno} ) {
last if ( $seqno == SEQ_ROOT );
if ( $seqno >= $seqno_last ) {
## shouldn't happen - parent containers have lower sequence numbers
DEVEL_MODE && Fault(<{$seqno} = $value;
} ## end while ( $seqno = $rparent_of_seqno...)
return;
} ## end sub mark_parent_containers
sub copy_token_as_type {
# This provides a quick way to create a new token by
# slightly modifying an existing token.
my ( $rold_token, $type, $token ) = @_;
my @rnew_token = @{$rold_token};
$rnew_token[_TYPE_] = $type;
$rnew_token[_TOKEN_] = $token;
$rnew_token[_TYPE_SEQUENCE_] = EMPTY_STRING;
return \@rnew_token;
} ## end sub copy_token_as_type
sub parent_seqno_by_K {
# Return the sequence number of the parent container of token K, if any.
my ( $self, $KK ) = @_;
my $rLL = $self->[_rLL_];
# The task is to jump forward to the next container token
# and use the sequence number of either it or its parent.
# For example, consider the following with seqno=5 of the '[' and ']'
# being called with index K of the first token of each line:
# # result
# push @tests, # -
# [ # -
# sub { 99 }, 'do {&{%s} for 1,2}', # 5
# '(&{})(&{})', undef, # 5
# [ 2, 2, 0 ], 0 # 5
# ]; # -
# NOTE: The ending parent will be SEQ_ROOT for a balanced file. For
# unbalanced files, last sequence number will either be undefined or it may
# be at a deeper level. In either case we will just return SEQ_ROOT to
# have a defined value and allow formatting to proceed.
my $parent_seqno = SEQ_ROOT;
return $parent_seqno if ( !defined($KK) );
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($type_sequence) {
$parent_seqno = $self->[_rparent_of_seqno_]->{$type_sequence};
}
else {
my $Kt = $self->[_rK_next_seqno_by_K_]->[$KK];
if ( defined($Kt) ) {
$type_sequence = $rLL->[$Kt]->[_TYPE_SEQUENCE_];
my $type = $rLL->[$Kt]->[_TYPE_];
# if next container token is closing, it is the parent seqno
if ( $is_closing_type{$type} ) {
$parent_seqno = $type_sequence;
}
# otherwise we want its parent container
else {
$parent_seqno = $self->[_rparent_of_seqno_]->{$type_sequence};
}
}
}
$parent_seqno = SEQ_ROOT if ( !defined($parent_seqno) );
return $parent_seqno;
} ## end sub parent_seqno_by_K
sub parent_sub_seqno {
my ( $self, $seqno_paren ) = @_;
# Find sequence number of the named sub (not asub) which contains a given
# sequenced item
# Given:
# $seqno_paren = sequence number of a token within the sub
# Returns:
# $seqno of the sub, or
# nothing if no sub found
return unless defined($seqno_paren);
# Search upward
my $seqno = $seqno_paren;
my $seqno_last = $seqno_paren;
while ( $seqno = $self->[_rparent_of_seqno_]->{$seqno} ) {
last if ( $seqno == SEQ_ROOT );
if ( $self->[_ris_sub_block_]->{$seqno} ) {
return $seqno;
}
if ( $seqno >= $seqno_last ) {
## shouldn't happen - parent containers have lower sequence numbers
DEVEL_MODE && Fault(<[...])
return;
} ## end sub parent_sub_seqno
sub parent_sub_seqno_by_K {
my ( $self, $KK ) = @_;
#--------------------------------------------------------------------
# NOTE: not currently called but keep for possible future development
#--------------------------------------------------------------------
# Find sequence number of the named sub which contains a given token
# Given:
# $K = index K of a token
# Returns:
# $seqno of the sub, or
# nothing if no sub found
return unless defined($KK);
my $seqno_sub;
my $parent_seqno = $self->parent_seqno_by_K($KK);
if ( $self->[_ris_sub_block_]->{$parent_seqno} ) {
$seqno_sub = $parent_seqno;
}
else {
$seqno_sub = $self->parent_sub_seqno($parent_seqno);
}
return $seqno_sub;
} ## end sub parent_sub_seqno_by_K
sub is_in_block_by_i {
my ( $self, $i ) = @_;
# Return true if
# token at i is contained in a BLOCK
# or is at root level
# or there is some kind of error (i.e. unbalanced file)
# Return false otherwise
if ( $i < 0 ) {
DEVEL_MODE && Fault("Bad call, i='$i'\n");
return 1;
}
my $seqno = $parent_seqno_to_go[$i];
return 1 if ( !$seqno || $seqno == SEQ_ROOT );
return 1 if ( $self->[_rblock_type_of_seqno_]->{$seqno} );
return;
} ## end sub is_in_block_by_i
sub is_in_block_by_K {
my ( $self, $KK ) = @_;
# Return true if
# token at $KK is contained in a BLOCK
# or is at root level
# or there is some kind of error (i.e. unbalanced file)
# Return false otherwise
my $parent_seqno = $self->parent_seqno_by_K($KK);
return SEQ_ROOT if ( !$parent_seqno || $parent_seqno == SEQ_ROOT );
return $self->[_rblock_type_of_seqno_]->{$parent_seqno};
} ## end sub is_in_block_by_K
sub is_in_list_by_i {
my ( $self, $i ) = @_;
# Return true if token at i is contained in a LIST
# Return false otherwise
my $seqno = $parent_seqno_to_go[$i];
return if ( !$seqno );
return if ( $seqno == SEQ_ROOT );
if ( $self->[_ris_list_by_seqno_]->{$seqno} ) {
return 1;
}
return;
} ## end sub is_in_list_by_i
sub is_list_by_seqno {
# Return true if the immediate contents of a container appears to be a
# list.
my ( $self, $seqno ) = @_;
return unless defined($seqno);
return $self->[_ris_list_by_seqno_]->{$seqno};
} ## end sub is_list_by_seqno
sub is_interpolated_here_doc {
my ($token) = @_;
# Given:
# $token = the token text of a type 'h' token
# Return:
# true if the here doc is interpolated
# false if not
# Examples:
# <[_rlines_];
# Loop to collect the here doc text
my $ix_max = @{$rlines} - 1;
my $ix = $ix_HERE_BEG;
my $ix_HERE_END;
my $here_text = EMPTY_STRING;
while ( ++$ix <= $ix_max ) {
my $lhash = $rlines->[$ix];
my $ltype = $lhash->{_line_type};
if ( $ltype eq 'HERE' ) {
$here_text .= $lhash->{_line_text};
next;
}
elsif ( $ltype eq 'HERE_END' ) {
$ix_HERE_END = $ix;
last;
}
else {
DEVEL_MODE
&& Fault("line_type=$ltype should be HERE..\n");
$ix_HERE_END = $ix;
last;
}
} ## end while ( ++$ix <= $ix_max )
return ( $ix_HERE_END, $here_text );
} ## end sub get_here_text
sub is_trailing_comma {
my ( $self, $KK ) = @_;
# Given:
# $KK - index of a comma in token list
# Return:
# true if the comma at index $KK is a trailing comma
# false if not
my $rLL = $self->[_rLL_];
my $type_KK = $rLL->[$KK]->[_TYPE_];
if ( $type_KK ne ',' ) {
DEVEL_MODE
&& Fault("Bad call: expected type ',' but received '$type_KK'\n");
return;
}
my $Knnb = $self->K_next_nonblank($KK);
if ( defined($Knnb) ) {
my $type_sequence = $rLL->[$Knnb]->[_TYPE_SEQUENCE_];
my $type_Knnb = $rLL->[$Knnb]->[_TYPE_];
if ( $type_sequence && $is_closing_type{$type_Knnb} ) {
return 1;
}
}
return;
} ## end sub is_trailing_comma
sub cumulative_length_before_K {
my ( $self, $KK ) = @_;
# Returns the cumulative character length from the first token to
# token before the token at index $KK.
my $rLL = $self->[_rLL_];
return ( $KK <= 0 ) ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
} ## end sub cumulative_length_before_K
###########################################
# CODE SECTION 3: Check and process options
###########################################
sub check_options {
# This routine is called to check the user-supplied run parameters
# and to configure the control hashes to them.
( $rOpts, my $wvt_in_args, my $num_files, my $line_range_clipped ) = @_;
initialize_whitespace_hashes();
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);
}
initialize_bond_strength_hashes();
# This function must be called early to get hashes with grep initialized
initialize_grep_and_friends();
# Make needed regex patterns for matching text.
# NOTE: sub_matching_patterns must be made first because later patterns use
# them; see RT #133130.
make_sub_matching_pattern(); # MUST BE FIRST pattern made
make_static_block_comment_pattern();
make_static_side_comment_pattern();
$format_skipping_pattern_begin =
make_format_skipping_pattern( 'format-skipping-begin', '#<<<' );
$format_skipping_pattern_end =
make_format_skipping_pattern( 'format-skipping-end', '#>>>' );
make_non_indenting_brace_pattern();
initialize_closing_side_comments();
initialize_missing_else_comment();
initialize_call_paren_style();
initialize_warn_variable_types( $wvt_in_args, $num_files,
$line_range_clipped );
initialize_warn_mismatched();
make_bli_pattern();
make_bl_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
make_keyword_group_list_pattern();
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
dump_cuddled_block_list(*STDOUT);
Exit(0);
}
# --indent-only skips the call to sub respace_tokens, which defines
# some essential data structures needed by some dump routines,
# or might be in the future. Since there is an immediate exit after a
# dump, we can turn off indent-only to get these structures for a -dump.
if ( $rOpts->{'indent-only'} ) {
if ( $rOpts->{'dump-mismatched-args'}
|| $rOpts->{'dump-mismatched-returns'} )
{
$rOpts->{'indent-only'} = 0;
}
if ( $rOpts->{'dump-block-summary'} ) {
$rOpts->{'indent-only'} = 0;
}
}
initialize_line_up_parentheses();
check_tabs();
# We should put an upper bound on any -sil=n value. Otherwise enormous
# files could be created by mistake.
for ( $rOpts->{'starting-indentation-level'} ) {
if ( $_ && $_ > 100 ) {
Warn(< 0 to avoid future parsing problems (issue c147)
for ( $rOpts->{'minimum-space-to-comment'} ) {
if ( !$_ || $_ <= 0 ) { $_ = 1 }
}
initialize_outdent_keyword();
initialize_keyword_paren_inner_tightness();
initialize_space_after_keyword();
initialize_extended_block_tightness_list();
# The flag '$controlled_comma_style' will be set if the user
# entered any of -wbb=',' -wba=',' -kbb=',' -kba=','
# see sub 'initialize_token_break_preferences',
# and sub 'initialize_old_breakpoint_controls'
$controlled_comma_style = 0;
initialize_token_break_preferences();
initialize_old_breakpoint_controls();
initialize_container_indentation_options();
# make -l=0 equal to -l=infinite
if ( !$rOpts->{'maximum-line-length'} ) {
$rOpts->{'maximum-line-length'} = 1_000_000;
}
# make -lbl=0 equal to -lbl=infinite
if ( !$rOpts->{'long-block-line-count'} ) {
$rOpts->{'long-block-line-count'} = 1_000_000;
}
initialize_tightness_vars();
initialize_multiple_token_tightness();
initialize_global_option_vars();
initialize_line_length_vars(); # after 'initialize_global_option_vars'
initialize_trailing_comma_break_rules();
initialize_trailing_comma_rules(); # after 'initialize_line_length_vars'
# and '_trailing_comma_break_rules'
initialize_interbracket_arrow_style();
initialize_weld_nested_exclusion_rules();
initialize_weld_fat_comma_rules();
initialize_lpxl_lpil();
return;
} ## end sub check_options
use constant ALIGN_GREP_ALIASES => 0;
sub initialize_grep_and_friends {
# Initialize or re-initialize hashes with 'grep' and grep aliases. This
# must be done after each set of options because new grep aliases may be
# used.
# re-initialize the hashes ... this is critical!
%is_sort_map_grep = ();
my @q = qw( sort map grep );
@is_sort_map_grep{@q} = (1) x scalar(@q);
my $olbxl = $rOpts->{'one-line-block-exclusion-list'};
my %is_olb_exclusion_word;
if ( defined($olbxl) ) {
my @list = split_words($olbxl);
if (@list) {
@is_olb_exclusion_word{@list} = (1) x scalar(@list);
}
}
# Make the list of block types which may be re-formed into one line.
# They will be modified with the grep-alias-list below and
# by sub 'prepare_cuddled_block_types'.
# Note that it is essential to always re-initialize the hash here:
%want_one_line_block = ();
if ( !$is_olb_exclusion_word{'*'} ) {
foreach (qw( sort map grep eval )) {
if ( !$is_olb_exclusion_word{$_} ) { $want_one_line_block{$_} = 1 }
}
}
# Note that any 'grep-alias-list' string has been preprocessed to be a
# trimmed, space-separated list.
my $str = $rOpts->{'grep-alias-list'};
my @grep_aliases = split /\s+/, $str;
if (@grep_aliases) {
@is_sort_map_grep{@grep_aliases} = (1) x scalar(@grep_aliases);
if ( $want_one_line_block{'grep'} ) {
@want_one_line_block{@grep_aliases} = (1) x scalar(@grep_aliases);
}
}
%is_sort_map_grep_eval = %is_sort_map_grep;
$is_sort_map_grep_eval{'eval'} = 1;
%is_sort_map_grep_eval_do = %is_sort_map_grep_eval;
$is_sort_map_grep_eval_do{'do'} = 1;
# These block types can take ci. This is used by the -xci option.
# Note that the 'sub' in this list is an anonymous sub. To be more correct
# we could remove sub and use ASUB pattern to also handle a
# prototype/signature. But that would slow things down and would probably
# never be useful.
%is_block_with_ci = %is_sort_map_grep_eval_do;
$is_block_with_ci{'sub'} = 1;
@q = qw( grep keys map reverse sort split );
push @q, @grep_aliases;
%is_keyword_returning_list = ();
@is_keyword_returning_list{@q} = (1) x scalar(@q);
# This code enables vertical alignment of grep aliases for testing. It has
# not been found to be beneficial, so it is off by default. But it is
# useful for precise testing of the grep alias coding.
if (ALIGN_GREP_ALIASES) {
%block_type_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'if',
'default' => 'if',
'case' => 'if',
'sort' => 'map',
'grep' => 'map',
);
foreach (@q) {
$block_type_map{$_} = 'map' unless ( $_ eq 'map' );
}
}
return;
} ## end sub initialize_grep_and_friends
sub initialize_weld_nested_exclusion_rules {
%weld_nested_exclusion_rules = ();
my $opt_name = 'weld-nested-exclusion-list';
my $str = $rOpts->{$opt_name};
# let a '0' be the same as not defined
return unless ($str);
$str =~ s/^\s+//;
$str =~ s/\s+$//;
return unless ($str);
# There are four container tokens.
my %token_keys = (
'(' => '(',
'[' => '[',
'{' => '{',
'q' => 'q',
);
# We are parsing an exclusion list for nested welds. The list is a string
# with spaces separating any number of items. Each item consists of three
# pieces of information:
#
# < ^ or . > < k or K > < ( [ { >
# The last character is the required container type and must be one of:
# ( = paren
# [ = square bracket
# { = brace
# An optional leading position indicator:
# ^ means the leading token position in the weld
# . means a secondary token position in the weld
# no position indicator means all positions match
# An optional alphanumeric character between the position and container
# token selects to which the rule applies:
# k = any keyword
# K = any non-keyword
# f = function call
# F = not a function call
# w = function or keyword
# W = not a function or keyword
# no letter means any preceding type matches
# Examples:
# ^( - the weld must not start with a paren
# .( - the second and later tokens may not be parens
# ( - no parens in weld
# ^K( - exclude a leading paren not preceded by a keyword
# .k( - exclude a secondary paren preceded by a keyword
# [ { - exclude all brackets and braces
my @items = split /\s+/, $str;
my $msg1;
my $msg2;
foreach my $item (@items) {
my $item_save = $item;
my $tok = chop $item;
my $key = $token_keys{$tok};
if ( !defined($key) ) {
$msg1 .= " '$item_save'";
next;
}
if ( !defined( $weld_nested_exclusion_rules{$key} ) ) {
$weld_nested_exclusion_rules{$key} = [];
}
my $rflags = $weld_nested_exclusion_rules{$key};
# A 'q' means do not weld quotes
if ( $tok eq 'q' ) {
$rflags->[0] = '*';
$rflags->[1] = '*';
next;
}
my $pos = '*';
my $select = '*';
if ($item) {
if ( $item =~ /^([\^\.])?([kKfFwW])?$/ ) {
$pos = $1 if ($1);
$select = $2 if ($2);
}
else {
$msg1 .= " '$item_save'";
next;
}
}
my $err;
if ( $pos eq '^' || $pos eq '*' ) {
if ( defined( $rflags->[0] ) && $rflags->[0] ne $select ) {
$err = 1;
}
$rflags->[0] = $select;
}
if ( $pos eq '.' || $pos eq '*' ) {
if ( defined( $rflags->[1] ) && $rflags->[1] ne $select ) {
$err = 1;
}
$rflags->[1] = $select;
}
if ($err) { $msg2 .= " '$item_save'"; }
}
if ($msg1) {
Warn(<' after an opening paren
if ( $rOpts->{'weld-fat-comma'} ) { $weld_fat_comma_rules{'('} = 1 }
# This could be generalized in the future by introducing a parameter
# -weld-fat-comma-after=str (-wfca=str), where str contains any of:
# * { [ (
# to indicate which opening parens may weld to a subsequent '=>'
# The flag -wfc would then be equivalent to -wfca='('
# This has not been done because it is not yet clear how useful
# this generalization would be.
return;
} ## end sub initialize_weld_fat_comma_rules
sub initialize_lpxl_lpil {
%line_up_parentheses_control_hash = ();
$line_up_parentheses_control_is_lpxl = 1;
my $lpxl = $rOpts->{'line-up-parentheses-exclusion-list'};
my $lpil = $rOpts->{'line-up-parentheses-inclusion-list'};
if ( $lpxl && $lpil ) {
Warn(<{'line-up-parentheses-exclusion-list'}, 'lpxl' );
}
elsif ($lpil) {
$line_up_parentheses_control_is_lpxl = 0;
initialize_line_up_parentheses_control_hash(
$rOpts->{'line-up-parentheses-inclusion-list'}, 'lpil' );
}
else {
# neither -lpxl nor -lpil specified
}
return;
} ## end sub initialize_lpxl_lpil
sub initialize_line_up_parentheses_control_hash {
my ( $str, $opt_name ) = @_;
# let a 0 be the same as not defined
return unless ($str);
$str =~ s/^\s+//;
$str =~ s/\s+$//;
return unless ($str);
# The format is space separated items, where each item must consist of a
# string with a token type preceded by an optional text token and followed
# by an integer:
# For example:
# W(1
# = (flag1)(key)(flag2), where
# flag1 = 'W'
# key = '('
# flag2 = '1'
my @items = split /\s+/, $str;
my $msg1;
my $msg2;
foreach my $item (@items) {
my $item_save = $item;
my ( $flag1, $key, $flag2 );
if ( $item =~ /^ ([^\(\[\{]*)? ([\(\{\[]) (\d)? $/x ) {
## $flag1 $key $flag2
$flag1 = $1 if $1;
$key = $2 if $2;
$flag2 = $3 if defined($3);
}
else {
$msg1 .= " '$item_save'";
next;
}
if ( !defined($key) ) {
$msg1 .= " '$item_save'";
next;
}
# Check for valid flag1
if ( !defined($flag1) ) { $flag1 = '*' }
if ( $flag1 !~ /^[kKfFwW\*]$/ ) {
$msg1 .= " '$item_save'";
next;
}
# Check for valid flag2
# 0 or blank: ignore container contents
# 1 all containers with sublists match
# 2 all containers with sublists, code blocks or ternary operators match
# ... this could be extended in the future
if ( !defined($flag2) ) { $flag2 = 0 }
if ( $flag2 !~ /^[012]$/ ) {
$msg1 .= " '$item_save'";
next;
}
if ( !defined( $line_up_parentheses_control_hash{$key} ) ) {
$line_up_parentheses_control_hash{$key} = [ $flag1, $flag2 ];
next;
}
# check for multiple conflicting specifications
my $rflags = $line_up_parentheses_control_hash{$key};
my $err;
if ( defined( $rflags->[0] ) && $rflags->[0] ne $flag1 ) {
$err = 1;
$rflags->[0] = $flag1;
}
if ( defined( $rflags->[1] ) && $rflags->[1] ne $flag2 ) {
$err = 1;
$rflags->[1] = $flag2;
}
$msg2 .= " '$item_save'" if ($err);
next;
}
if ($msg1) {
Warn(<{'line-up-parentheses'} = EMPTY_STRING;
}
}
return;
} ## end sub initialize_line_up_parentheses_control_hash
sub initialize_space_after_keyword {
# 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 state 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);
}
return;
} ## end sub initialize_space_after_keyword
sub initialize_outdent_keyword {
# Implement outdenting preferences for keywords
%outdent_keyword = ();
my @okw = split_words( $rOpts->{'outdent-keyword-list'} );
if ( !@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");
}
}
return;
} ## end sub initialize_outdent_keyword
sub initialize_keyword_paren_inner_tightness {
# 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'} );
if ( !@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;
}
}
return;
} ## end sub initialize_keyword_paren_inner_tightness
sub initialize_extended_block_tightness_list {
# Setup the control hash for --extended-block-tightness
# keywords taking indirect objects:
my @k_list = keys %is_indirect_object_taker;
# type symbols which may precede an opening block brace
my @t_list = qw( $ @ % & * );
push @t_list, '$#';
my @all = ( @k_list, @t_list );
# We will build the selection in %hash
# By default the option is 'on' for keywords only (-xbtl='k')
my %hash;
@hash{@k_list} = (1) x scalar(@k_list);
@hash{@t_list} = (0) x scalar(@t_list);
# This can be overridden with -xbtl="..."
my $long_name = 'extended-block-tightness-list';
if ( $rOpts->{$long_name} ) {
my @words = split_words( $rOpts->{$long_name} );
my @unknown;
# Turn everything off
@hash{@all} = (0) x scalar(@all);
# Then turn on selections
foreach my $word (@words) {
# 'print' etc turns on a specific word or symbol
if ( defined( $hash{$word} ) ) { $hash{$word} = 1; }
# 'k' turns on all keywords
elsif ( $word eq 'k' ) {
@hash{@k_list} = (1) x scalar(@k_list);
}
# 't' turns on all symbols
elsif ( $word eq 't' ) {
@hash{@t_list} = (1) x scalar(@t_list);
}
# 'kt' same as 'k' and 't' for convenience
elsif ( $word eq 'kt' ) {
@hash{@all} = (1) x scalar(@all);
}
# Anything else is an error
else { push @unknown, $word }
}
if (@unknown) {
my $num = @unknown;
local $LIST_SEPARATOR = SPACE;
Warn(<(@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
# Added '->' for git #171.
%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
# The small strength 0.01 which is added is 1% of the strength of one
# indentation level and seems to work okay.
if ( !$want_break_before{':'} ) {
$want_break_before{'?'} = $want_break_before{':'};
$right_bond_strength{'?'} = $right_bond_strength{':'} + 0.01;
$left_bond_strength{'?'} = NO_BREAK;
}
# Only make a hash entry for the next parameters if values are defined.
# That allows a quick check to be made later.
%break_before_container_types = ();
for ( $rOpts->{'break-before-hash-brace'} ) {
$break_before_container_types{'{'} = $_ if $_ && $_ > 0;
}
for ( $rOpts->{'break-before-square-bracket'} ) {
$break_before_container_types{'['} = $_ if $_ && $_ > 0;
}
for ( $rOpts->{'break-before-paren'} ) {
$break_before_container_types{'('} = $_ if $_ && $_ > 0;
}
# Note: a fix for b1266 previously here is now covered by the
# updates for b1470, b1474, so it has been removed.
return;
} ## end sub initialize_token_break_preferences
sub initialize_line_up_parentheses {
# -xlp implies -lp
if ( $rOpts->{'extended-line-up-parentheses'} ) {
$rOpts->{'line-up-parentheses'} ||= 1;
}
if ( $rOpts->{'line-up-parentheses'} ) {
if ( $rOpts->{'indent-only'}
|| !$rOpts->{'add-newlines'}
|| !$rOpts->{'delete-old-newlines'} )
{
Warn(<{'line-up-parentheses'} = 0;
$rOpts->{'extended-line-up-parentheses'} = 0;
}
if ( $rOpts->{'whitespace-cycle'} ) {
Warn(<{'whitespace-cycle'} = 0;
}
}
#-----------------------------------------------------------
# The combination -lp -vmll can be unstable if -ci<2 (b1267)
#-----------------------------------------------------------
# The -vmll and -lp parameters do not really work well together.
# This is a very crude fix for an unusual parameter combination.
if ( $rOpts->{'variable-maximum-line-length'}
&& $rOpts->{'line-up-parentheses'}
&& $rOpts->{'continuation-indentation'} < 2 )
{
$rOpts->{'continuation-indentation'} = 2;
##Warn("Increased -ci=n to n=2 for stability with -lp and -vmll\n");
}
#-----------------------------------------------------------
# The combination -lp -vmll -atc -dtc can be unstable
#-----------------------------------------------------------
# This fixes b1386 b1387 b1388 which had -wtc='b'
# Updated to to include any -wtc to fix b1426
if ( $rOpts->{'variable-maximum-line-length'}
&& $rOpts->{'line-up-parentheses'}
&& $rOpts->{'add-trailing-commas'}
&& $rOpts->{'delete-trailing-commas'}
&& $rOpts->{'want-trailing-commas'} )
{
$rOpts->{'delete-trailing-commas'} = 0;
## Issuing a warning message causes trouble with test cases, and this combo is
## so rare that it is unlikely to not occur in practice. So skip warning.
## Warn(
##"The combination -vmll -lp -atc -dtc can be unstable; turning off -dtc\n"
## );
}
#-----------------------------------------------------------
# The combination -xlp -xci and ci>i can be unstable (b1466)
#-----------------------------------------------------------
# Deactivated: the fix for b1501 also fixed b1466 in a simpler way.
# So this block can eventually be removed.
if ( 0
&& $rOpts->{'extended-line-up-parentheses'}
&& $rOpts->{'extended-continuation-indentation'}
&& $rOpts->{'continuation-indentation'} > $rOpts->{'indent-columns'}
&& $rOpts->{'indent-columns'} > 1 )
{
$rOpts->{'continuation-indentation'} = $rOpts->{'indent-columns'};
## This combination is only likely to occur during random testing, so
## skip the warning.
##Warn("The combination -xlp -xci -ci>-i can be unstable; reducing ci\n");
}
return;
} ## end sub initialize_line_up_parentheses
sub check_tabs {
# 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(<{'tabs'} = 0;
}
# tabs are not compatible with outdenting..
if ( $rOpts->{'outdent-keywords'} && $rOpts->{'tabs'} ) {
Warn(<{'tabs'} = 0;
}
if ( $rOpts->{'outdent-labels'} && $rOpts->{'tabs'} ) {
Warn(<{'tabs'} = 0;
}
return;
} ## end sub check_tabs
sub initialize_container_indentation_options {
%container_indentation_options = ();
foreach my $pair (
[ 'break-before-hash-brace-and-indent', '{' ],
[ 'break-before-square-bracket-and-indent', '[' ],
[ 'break-before-paren-and-indent', '(' ],
)
{
my ( $key, $tok ) = @{$pair};
my $opt = $rOpts->{$key};
if ( defined($opt) && $opt > 0 && $break_before_container_types{$tok} )
{
# (1) -lp is not compatible with opt=2, silently set to opt=0
# (2) opt=0 and 2 give same result if -i=-ci; but opt=0 is faster
# (3) set opt=0 if -i < -ci (can be unstable, case b1355)
if ( $opt == 2 ) {
if (
$rOpts->{'line-up-parentheses'}
|| ( $rOpts->{'indent-columns'} <=
$rOpts->{'continuation-indentation'} )
)
{
$opt = 0;
}
}
$container_indentation_options{$tok} = $opt;
}
}
return;
} ## end sub initialize_container_indentation_options
sub initialize_old_breakpoint_controls {
if ( $rOpts->{'ignore-old-breakpoints'} ) {
my @conflicts;
if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
$rOpts->{'break-at-old-method-breakpoints'} = 0;
push @conflicts, '--break-at-old-method-breakpoints (-bom)';
}
if ( $rOpts->{'break-at-old-comma-breakpoints'} ) {
$rOpts->{'break-at-old-comma-breakpoints'} = 0;
push @conflicts, '--break-at-old-comma-breakpoints (-boc)';
}
if ( $rOpts->{'break-at-old-semicolon-breakpoints'} ) {
$rOpts->{'break-at-old-semicolon-breakpoints'} = 0;
push @conflicts, '--break-at-old-semicolon-breakpoints (-bos)';
}
if ( $rOpts->{'keep-old-breakpoints-before'} ) {
$rOpts->{'keep-old-breakpoints-before'} = EMPTY_STRING;
push @conflicts, '--keep-old-breakpoints-before (-kbb)';
}
if ( $rOpts->{'keep-old-breakpoints-after'} ) {
$rOpts->{'keep-old-breakpoints-after'} = EMPTY_STRING;
push @conflicts, '--keep-old-breakpoints-after (-kba)';
}
if (@conflicts) {
my $msg = join( "\n ",
" Conflict: These conflicts with --ignore-old-breakponts (-iob) will be turned off:",
@conflicts ) . "\n";
Warn($msg);
}
# Note: These additional parameters are made inactive by -iob.
# They are silently turned off here because they are on by default.
# We would generate unexpected warnings if we issued a warning.
$rOpts->{'break-at-old-keyword-breakpoints'} = 0;
$rOpts->{'break-at-old-logical-breakpoints'} = 0;
$rOpts->{'break-at-old-ternary-breakpoints'} = 0;
$rOpts->{'break-at-old-attribute-breakpoints'} = 0;
}
%keep_break_before_type = ();
initialize_keep_old_breakpoints( $rOpts->{'keep-old-breakpoints-before'},
'kbb', \%keep_break_before_type );
%keep_break_after_type = ();
initialize_keep_old_breakpoints( $rOpts->{'keep-old-breakpoints-after'},
'kba', \%keep_break_after_type );
# Modify %keep_break_before and %keep_break_after to avoid conflicts
# with %want_break_before; fixes b1436.
# This became necessary after breaks for some tokens were converted
# from hard to soft (see b1433).
# We could do this for all tokens, but to minimize changes to existing
# code we currently only do this for the soft break tokens.
foreach my $key ( keys %keep_break_before_type ) {
if ( defined( $want_break_before{$key} )
&& !$want_break_before{$key}
&& $is_soft_keep_break_type{$key} )
{
$keep_break_after_type{$key} = $keep_break_before_type{$key};
delete $keep_break_before_type{$key};
}
}
foreach my $key ( keys %keep_break_after_type ) {
if ( defined( $want_break_before{$key} )
&& $want_break_before{$key}
&& $is_soft_keep_break_type{$key} )
{
$keep_break_before_type{$key} = $keep_break_after_type{$key};
delete $keep_break_after_type{$key};
}
}
$controlled_comma_style ||= $keep_break_before_type{','};
$controlled_comma_style ||= $keep_break_after_type{','};
return;
} ## end sub initialize_old_breakpoint_controls
use constant DEBUG_KB => 0;
sub initialize_keep_old_breakpoints {
my ( $str, $short_name, $rkeep_break_hash ) = @_;
# 0 will be treated same as not defined
return unless $str;
my %flags = ();
my @list = split_words($str);
if ( DEBUG_KB && @list ) {
local $LIST_SEPARATOR = SPACE;
print < 'f'
foreach my $item (@list) {
if ( $item =~ /^( [ \w\* ] )( [ \{\(\[\}\)\] ] )$/x ) {
$item = $2;
$flags{$2} = $1;
}
}
my @unknown_types;
foreach my $type (@list) {
if ( !Perl::Tidy::Tokenizer::is_valid_token_type($type) ) {
push @unknown_types, $type;
}
}
if (@unknown_types) {
my $num = @unknown_types;
local $LIST_SEPARATOR = SPACE;
Warn(<{$key} = $flag;
}
if ( DEBUG_KB && @list ) {
my @tmp = %flags;
local $LIST_SEPARATOR = SPACE;
print < $rOpts->{'brace-tightness'},
'}' => $rOpts->{'brace-tightness'},
'(' => $rOpts->{'paren-tightness'},
')' => $rOpts->{'paren-tightness'},
'[' => $rOpts->{'square-bracket-tightness'},
']' => $rOpts->{'square-bracket-tightness'},
);
return;
} ## end sub initialize_tightness_vars
sub initialize_multiple_token_tightness {
# Initialization for --multiple-token-tightness
%multiple_token_tightness = ();
my $opt_name = 'multiple-token-tightness';
my $opt = $rOpts->{$opt_name};
# The default is to add spaces for the double diamond
if ( !$opt ) {
$multiple_token_tightness{'<<>>'} = 1;
return;
}
# These are valid input words for perltidy token types
# Note that 'qw' will be translated into the actual token type 'q'
my %is_type_option;
my @type_options = qw( <<>> qw Q h );
@is_type_option{@type_options} = (1) x scalar(@type_options);
# These are valid input words subtypes of token type 'Q'.
# Note qw must be treated specially and is in the previous list.
my %is_Q_subtype_option;
my @Q_subtype_options = qw( q qq qx qr s y tr m );
@is_Q_subtype_option{@Q_subtype_options} =
(1) x scalar(@Q_subtype_options);
my %is_valid_term = ( %is_type_option, %is_Q_subtype_option );
# Words can be negated by prefixing with the following character:
my $neg_char = '^';
# Scan the input
my %positive_input;
my %negative_input;
my $error_string = EMPTY_STRING;
if ( defined($opt) ) {
my @list = split_words($opt);
foreach my $word (@list) {
# The special word 'q*' means all of the Q_subtypes plus 'qw'
if ( $word eq 'q*' ) {
foreach (@Q_subtype_options) { $positive_input{$_} = 1 }
$positive_input{'qw'} = 1;
}
elsif ( $word eq $neg_char . 'q*' ) {
foreach (@Q_subtype_options) { $negative_input{$_} = 1 }
$negative_input{'qw'} = 1;
}
elsif ( $is_valid_term{$word} ) {
$positive_input{$word} = 1;
}
elsif ( substr( $word, 0, 1 ) eq $neg_char
&& $is_valid_term{ substr( $word, 1 ) } )
{
$negative_input{ substr( $word, 1 ) } = 1;
}
else {
$error_string .= "$word ";
}
}
}
if ($error_string) {
$error_string =~ s/\s+$//;
Warn(<>' is always a default unless rejected
if ( !$negative_input{'<<>>'} ) {
$positive_input{'<<>>'} = 1;
}
# Now construct the control hash
my @Q_subtype_list;
foreach my $word ( keys %positive_input ) {
# negative has priority over positive
next if ( $negative_input{$word} );
if ( $is_type_option{$word} ) {
if ( $word eq 'qw' ) { $word = 'q' }
$multiple_token_tightness{$word} = 1;
}
elsif ( $is_Q_subtype_option{$word} ) {
push @Q_subtype_list, $word;
}
else {
# something is wrong; previous checks should prevent arriving here
DEVEL_MODE
&& Fault(
"unexpected word '$word' while initializing -mutt=$opt\n");
%multiple_token_tightness = ();
return;
}
}
# Construct a regex for the selected Q subtypes, in the form
# ^(?:qq|qx|qr|q|s|y|tr|m)\b
if (@Q_subtype_list) {
my $regex = q{^(?:} . join( '|', @Q_subtype_list ) . q{)\b};
if ( bad_pattern($regex) ) {
# shouldn't happen; there must be a coding error
my $msg =
"ERROR: the --$opt_name input caused an invalid regex '$regex'\n";
DEVEL_MODE && Fault($msg);
Warn($msg);
%multiple_token_tightness = ();
return;
}
$multiple_token_tightness{'Q'} = $regex;
}
return;
} ## end sub initialize_multiple_token_tightness
sub initialize_global_option_vars {
#------------------------------------------------------------
# Make global vars for frequently used options for efficiency
#------------------------------------------------------------
$rOpts_add_newlines = $rOpts->{'add-newlines'};
$rOpts_add_trailing_commas = $rOpts->{'add-trailing-commas'};
$rOpts_add_lone_trailing_commas = $rOpts->{'add-lone-trailing-commas'};
$rOpts_add_whitespace = $rOpts->{'add-whitespace'};
$rOpts_blank_lines_after_opening_block =
$rOpts->{'blank-lines-after-opening-block'};
$rOpts_block_brace_tightness = $rOpts->{'block-brace-tightness'};
$rOpts_block_brace_vertical_tightness =
$rOpts->{'block-brace-vertical-tightness'};
$rOpts_brace_follower_vertical_tightness =
$rOpts->{'brace-follower-vertical-tightness'};
$rOpts_break_after_labels = $rOpts->{'break-after-labels'};
$rOpts_break_at_old_attribute_breakpoints =
$rOpts->{'break-at-old-attribute-breakpoints'};
$rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
$rOpts_break_at_old_keyword_breakpoints =
$rOpts->{'break-at-old-keyword-breakpoints'};
$rOpts_break_at_old_logical_breakpoints =
$rOpts->{'break-at-old-logical-breakpoints'};
$rOpts_break_at_old_semicolon_breakpoints =
$rOpts->{'break-at-old-semicolon-breakpoints'};
$rOpts_break_at_old_ternary_breakpoints =
$rOpts->{'break-at-old-ternary-breakpoints'};
$rOpts_break_open_compact_parens = $rOpts->{'break-open-compact-parens'};
$rOpts_closing_side_comments = $rOpts->{'closing-side-comments'};
$rOpts_closing_side_comment_else_flag =
$rOpts->{'closing-side-comment-else-flag'};
$rOpts_closing_side_comment_maximum_text =
$rOpts->{'closing-side-comment-maximum-text'};
$rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
$rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
$rOpts_cuddled_paren_brace = $rOpts->{'cuddled-paren-brace'};
$rOpts_delete_closing_side_comments =
$rOpts->{'delete-closing-side-comments'};
$rOpts_delete_old_whitespace = $rOpts->{'delete-old-whitespace'};
$rOpts_extended_continuation_indentation =
$rOpts->{'extended-continuation-indentation'};
$rOpts_delete_side_comments = $rOpts->{'delete-side-comments'};
$rOpts_delete_trailing_commas = $rOpts->{'delete-trailing-commas'};
$rOpts_delete_lone_trailing_commas =
$rOpts->{'delete-lone-trailing-commas'};
$rOpts_delete_weld_interfering_commas =
$rOpts->{'delete-weld-interfering-commas'};
$rOpts_format_skipping = $rOpts->{'format-skipping'};
$rOpts_freeze_whitespace = $rOpts->{'freeze-whitespace'};
$rOpts_function_paren_vertical_alignment =
$rOpts->{'function-paren-vertical-alignment'};
$rOpts_fuzzy_line_length = $rOpts->{'fuzzy-line-length'};
$rOpts_ignore_old_breakpoints = $rOpts->{'ignore-old-breakpoints'};
$rOpts_ignore_side_comment_lengths =
$rOpts->{'ignore-side-comment-lengths'};
$rOpts_ignore_perlcritic_comments = $rOpts->{'ignore-perlcritic-comments'};
$rOpts_indent_closing_brace = $rOpts->{'indent-closing-brace'};
$rOpts_indent_columns = $rOpts->{'indent-columns'};
$rOpts_indent_leading_semicolon = $rOpts->{'indent-leading-semicolon'};
$rOpts_indent_only = $rOpts->{'indent-only'};
$rOpts_keep_interior_semicolons = $rOpts->{'keep-interior-semicolons'};
$rOpts_line_up_parentheses = $rOpts->{'line-up-parentheses'};
$rOpts_extended_block_tightness = $rOpts->{'extended-block-tightness'};
$rOpts_extended_line_up_parentheses =
$rOpts->{'extended-line-up-parentheses'};
$rOpts_logical_padding = $rOpts->{'logical-padding'};
$rOpts_maximum_consecutive_blank_lines =
$rOpts->{'maximum-consecutive-blank-lines'};
$rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
$rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
$rOpts_minimize_continuation_indentation =
$rOpts->{'minimize-continuation-indentation'};
$rOpts_one_line_block_semicolons = $rOpts->{'one-line-block-semicolons'};
$rOpts_opening_brace_always_on_right =
$rOpts->{'opening-brace-always-on-right'};
$rOpts_outdent_keywords = $rOpts->{'outdent-keywords'};
$rOpts_outdent_labels = $rOpts->{'outdent-labels'};
$rOpts_outdent_long_comments = $rOpts->{'outdent-long-comments'};
$rOpts_outdent_long_quotes = $rOpts->{'outdent-long-quotes'};
$rOpts_outdent_static_block_comments =
$rOpts->{'outdent-static-block-comments'};
$rOpts_recombine = $rOpts->{'recombine'};
$rOpts_qw_as_function = $rOpts->{'qw-as-function'};
$rOpts_short_concatenation_item_length =
$rOpts->{'short-concatenation-item-length'};
$rOpts_space_prototype_paren = $rOpts->{'space-prototype-paren'};
$rOpts_space_signature_paren = $rOpts->{'space-signature-paren'};
$rOpts_stack_closing_block_brace = $rOpts->{'stack-closing-block-brace'};
$rOpts_static_block_comments = $rOpts->{'static-block-comments'};
$rOpts_add_missing_else = $rOpts->{'add-missing-else'};
$rOpts_warn_missing_else = $rOpts->{'warn-missing-else'};
$rOpts_tee_block_comments = $rOpts->{'tee-block-comments'};
$rOpts_tee_pod = $rOpts->{'tee-pod'};
$rOpts_tee_side_comments = $rOpts->{'tee-side-comments'};
$rOpts_valign_code = $rOpts->{'valign-code'};
$rOpts_valign_side_comments = $rOpts->{'valign-side-comments'};
$rOpts_valign_if_unless = $rOpts->{'valign-if-unless'};
$rOpts_valign_wide_equals = $rOpts->{'valign-wide-equals'};
$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;
} ## end sub initialize_global_option_vars
sub initialize_line_length_vars {
# Create a table of maximum line length vs level for later efficient use.
# We will make the tables very long to be sure it will not be exceeded.
# But we have to choose a fixed length. A check will be made at the start
# of sub 'finish_formatting' to be sure it is not exceeded. Note, some of
# my standard test problems have indentation levels of about 150, so this
# should be fairly large. If the choice of a maximum level ever becomes
# an issue then these table values could be returned in a sub with a simple
# memoization scheme.
# Also create a table of the maximum spaces available for text due to the
# level only. If a line has continuation indentation, then that space must
# be subtracted from the table value. This table is used for preliminary
# estimates in welding, extended_ci, BBX, and marking short blocks.
use constant LEVEL_TABLE_MAX => 1000;
# The basic scheme:
foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
my $indent = $level * $rOpts_indent_columns;
$maximum_line_length_at_level[$level] = $rOpts_maximum_line_length;
$maximum_text_length_at_level[$level] =
$rOpts_maximum_line_length - $indent;
}
# Correct the maximum_text_length table if the -wc=n flag is used
$rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
if ($rOpts_whitespace_cycle) {
if ( $rOpts_whitespace_cycle > 0 ) {
foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
my $level_mod = $level % $rOpts_whitespace_cycle;
my $indent = $level_mod * $rOpts_indent_columns;
$maximum_text_length_at_level[$level] =
$rOpts_maximum_line_length - $indent;
}
}
else {
$rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'} = 0;
}
}
# Correct the tables if the -vmll flag is used. These values override the
# previous values.
if ($rOpts_variable_maximum_line_length) {
foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
$maximum_text_length_at_level[$level] = $rOpts_maximum_line_length;
$maximum_line_length_at_level[$level] =
$rOpts_maximum_line_length + $level * $rOpts_indent_columns;
}
}
# Define two measures of indentation level, alpha and beta, at which some
# formatting features come under stress and need to start shutting down.
# Some combination of the two will be used to shut down different
# formatting features.
# Put a reasonable upper limit on stress level (say 100) in case the
# whitespace-cycle variable is used.
my $stress_level_limit = min( 100, LEVEL_TABLE_MAX );
# Find stress_level_alpha, targeted at very short maximum line lengths.
$stress_level_alpha = $stress_level_limit + 1;
foreach my $level_test ( 0 .. $stress_level_limit ) {
my $max_len = $maximum_text_length_at_level[ $level_test + 1 ];
my $excess_inside_space =
$max_len -
$rOpts_continuation_indentation -
$rOpts_indent_columns - 8;
if ( $excess_inside_space <= 0 ) {
$stress_level_alpha = $level_test;
last;
}
}
# Find stress level beta, a stress level targeted at formatting
# at deep levels near the maximum line length. We start increasing
# from zero and stop at the first level which shows no more space.
# 'const' is a fixed number of spaces for a typical variable.
# Cases b1197-b1204 work ok with const=12 but not with const=8
my $const = 16;
my $denom = max( 1, $rOpts_indent_columns );
$stress_level_beta = 0;
foreach my $level ( 0 .. $stress_level_limit ) {
my $remaining_cycles = max(
0,
(
$maximum_text_length_at_level[$level] -
$rOpts_continuation_indentation - $const
) / $denom
);
last if ( $remaining_cycles <= 3 ); # 2 does not work
$stress_level_beta = $level;
}
# This is a combined level which works well for turning off formatting
# features in most cases:
$high_stress_level = min( $stress_level_alpha, $stress_level_beta + 2 );
return;
} ## end sub initialize_line_length_vars
sub initialize_trailing_comma_break_rules {
# Setup control hash for making trailing comma breaks. Update c416.
# This sub is similar to 'sub initialize_trailing_comma_rules' but
# simpler.
# -btct=s, where s
#
# =" " none
# =0 : none
# =1 or * : all
# =m : break at trailing commas in multiline lists
# =b : break at bare trailing commas
%trailing_comma_break_rules = ();
my $rvalid_flags = [qw( 0 1 * m b )];
# Note that the hash keys are the CLOSING tokens but the input
# uses OPENING tokens.
my @all_keys = qw< ) ] } >;
my $option = $rOpts->{'break-at-trailing-comma-types'};
if ($option) {
$option =~ s/^\s+//;
$option =~ s/\s+$//;
}
# We need to use length() here because '0' is a possible option
if ( defined($option) && length($option) ) {
my $error_message;
my %rule_hash;
my @q = @{$rvalid_flags};
my %is_valid_flag;
@is_valid_flag{@q} = (1) x scalar(@q);
# handle the common case of a single control character, like -btct='b'
if ( length($option) == 1 ) {
# skip 0
if ($option) {
foreach my $key (@all_keys) {
$rule_hash{$key} = [ $option, EMPTY_STRING ];
}
}
}
# handle multi-character control(s), such as -btct='[m' or -btct='k(m'
else {
my @parts = split /\s+/, $option;
foreach my $part (@parts) {
my $part_input = $part;
# examples: b -b [b 0 * +f(b
# the letter value is the rightmost character
my $val = substr( $part, -1, 1 );
# skip 0
next unless ($val);
$part = substr( $part, 0, -1 );
if ( $val && !$is_valid_flag{$val} ) {
my $valid_str = join( SPACE, @{$rvalid_flags} );
$error_message .=
"In '$part_input': unexpected value '$val'; must be one of: $valid_str\n";
next;
}
# set defaults for this item
my @keys = @all_keys;
my $paren_flag = EMPTY_STRING;
# look for opening container bracket
my $is_paren;
if ( length($part) ) {
my $token = substr( $part, -1, 1 );
if ( $is_opening_token{$token} ) {
# note that the hash key is the closing token
my $key = $matching_token{$token};
@keys = ($key);
$part = substr( $part, 0, -1 );
$is_paren = $token eq '(';
}
}
# anything left must be a paren modifier
if ( length($part) ) {
$paren_flag = substr( $part, -1, 1 );
$part = substr( $part, 0, -1 );
if ( $paren_flag !~ /^[kKfFwW]$/ ) {
$error_message .=
"In '$part_input': Unexpected paren flag '$paren_flag'; must be one of: k K f F w W\n";
next;
}
if ( !$is_paren ) {
$error_message .=
"In '$part_input': paren flag '$paren_flag' is only allowed before a '('\n";
next;
}
}
if ( length($part) ) {
$error_message .= "Unrecognized term: '$part_input'\n";
next;
}
my $duplicate;
foreach my $key (@keys) {
if ( defined( $rule_hash{$key} ) ) {
$duplicate = 1;
}
$rule_hash{$key} = [ $val, $paren_flag ];
}
if ($duplicate) {
$error_message .=
"This term overlaps a previous term: '$part_input'\n";
}
}
}
# check for conflicting signed options
if ($error_message) {
Warn(< will add missing multiline trailing commas
# if -dtc set => will delete trailing single line commas
# =b or 'bare' (multiline) lists require trailing comma
# if -atc set => will add missing bare trailing commas
# if -dtc set => will delete non-bare trailing commas
# =h or 'hash': single column stable bare lists require trailing comma
# if -atc set will add these
# if -dtc set will delete other trailing commas
#-------------------------------------------------------------------
# Important:
# - This routine must be called after the alpha and beta stress levels
# have been defined in sub 'initialize_line_length_vars'.
# - and it must be called after sub 'initialize_trailing_comma_break_rules'
#-------------------------------------------------------------------
%trailing_comma_rules = ();
my $rvalid_flags = [qw( 0 1 * m b h i )];
# This hash shows i.e. that 'm' includes all 'b' includes all 'i' ...etc
# It is used to check for overlap when both + and - signs are used to
# cause adding and deleting of different types of trailing commas.
my %match_order = (
'1' => 0,
'*' => 0,
'm' => 1,
'b' => 2,
'i' => 3,
'h' => 4,
'0' => 5,
);
# Note that the hash keys are the CLOSING tokens but the input
# uses OPENING tokens.
my @all_keys = qw< ) ] } >;
my $option = $rOpts->{'want-trailing-commas'};
if ($option) {
$option =~ s/^\s+//;
$option =~ s/\s+$//;
}
# Pull out -btct paren flag for use in checking stability in marginal cases
my ( $tc_letter, $tc_paren_flag );
my $tc_paren_rule = $trailing_comma_break_rules{')'};
if ( defined($tc_paren_rule) ) {
( $tc_letter, $tc_paren_flag ) = @{$tc_paren_rule};
}
# We need to use length() here because '0' is a possible option
if ( defined($option) && length($option) ) {
my $error_message;
my %rule_hash;
my @q = @{$rvalid_flags};
my %is_valid_flag;
@is_valid_flag{@q} = (1) x scalar(@q);
# handle the common case of a single control character, like -wtc='b'
if ( length($option) == 1 ) {
foreach my $key (@all_keys) {
my $paren_flag = EMPTY_STRING;
my $stable = defined( $trailing_comma_break_rules{$key} );
if ( $key eq ')' ) { $stable &&= $paren_flag eq $tc_paren_flag }
$rule_hash{add}->{$key} = [ $option, $paren_flag, $stable ];
$rule_hash{delete}->{$key} = [ $option, $paren_flag, $stable ];
}
}
# handle multi-character control(s), such as -wtc='[m' or -wtc='k(m'
else {
my @parts = split /\s+/, $option;
foreach my $part (@parts) {
my $part_input = $part;
# examples: b -b [b 0 * +f(b
# the letter value is the rightmost character
my $val = substr( $part, -1, 1 );
$part = substr( $part, 0, -1 );
if ( $val && !$is_valid_flag{$val} ) {
my $valid_str = join( SPACE, @{$rvalid_flags} );
$error_message .=
"In '$part_input': unexpected value '$val'; must be one of: $valid_str\n";
next;
}
# set defaults for this item
my @signs = qw( add delete );
my @keys = @all_keys;
my $paren_flag = EMPTY_STRING;
# look for opening container bracket
my $is_paren;
if ( length($part) ) {
my $token = substr( $part, -1, 1 );
if ( $is_opening_token{$token} ) {
# note that the hash key is the closing token
my $key = $matching_token{$token};
@keys = ($key);
$part = substr( $part, 0, -1 );
$is_paren = $token eq '(';
}
}
# look for a leading sign, + or -
if ( length($part) ) {
my $sign = substr( $part, 0, 1 );
if ( $sign eq '+' ) {
@signs = qw(add);
$part = substr( $part, 1 );
}
elsif ( $sign eq '-' ) {
@signs = qw(delete);
$part = substr( $part, 1 );
}
else {
## keep defaults
}
}
# anything left must be a paren modifier
if ( length($part) ) {
$paren_flag = substr( $part, -1, 1 );
$part = substr( $part, 0, -1 );
if ( $paren_flag !~ /^[kKfFwW]$/ ) {
$error_message .=
"In '$part_input': Unexpected paren flag '$paren_flag'; must be one of: k K f F w W\n";
next;
}
if ( !$is_paren ) {
$error_message .=
"In '$part_input': paren flag '$paren_flag' is only allowed before a '('\n";
next;
}
}
if ( length($part) ) {
$error_message .= "Unrecognized term: '$part_input'\n";
next;
}
my $duplicate;
foreach my $sign (@signs) {
foreach my $key (@keys) {
# New bare commas are stable if -bctc is set, and
# also paren flags do not disagree
my $stable =
defined( $trailing_comma_break_rules{$key} );
if ( $key eq ')' ) {
$stable &&= $paren_flag eq $tc_paren_flag;
}
if ( defined( $rule_hash{$sign}->{$key} ) ) {
$duplicate &&= 1;
}
$rule_hash{$sign}->{$key} =
[ $val, $paren_flag, $stable ];
}
}
if ($duplicate) {
$error_message .=
"This term overlaps a previous term: '$part_input'\n";
}
}
}
# check for conflicting signed options
if ( !$error_message ) {
my $radd = $rule_hash{add};
my $rdelete = $rule_hash{delete};
if ( defined($radd) && defined($rdelete) ) {
foreach my $key (@all_keys) {
my $radd_info = $radd->{$key};
my $rdelete_info = $rdelete->{$key};
if ( defined($radd_info) && defined($rdelete_info) ) {
my $add_val = $radd_info->[0];
my $delete_val = $rdelete_info->[0];
next if ( $add_val eq $delete_val );
my $add_order = $match_order{$add_val};
my $delete_order = $match_order{$delete_val};
if ( !defined($add_order) ) {
## should have been caught earlier
DEVEL_MODE
&& Fault("unexpected + value $add_val\n");
next;
}
if ( !defined($delete_order) ) {
## should have been caught earlier
DEVEL_MODE
&& Fault("unexpected - value $delete_val\n");
next;
}
if ( $add_order <= $delete_order ) {
my $token = $matching_token{$key};
$error_message .=
"For token '$token': the range for '+$add_val' overlaps the range for '-$delete_val'\n";
}
}
}
}
}
if ($error_message) {
Warn(<{$name_add};
my $opt_delete = $rOpts->{$name_delete};
my $opt_style = $rOpts->{$name_style};
if ( $opt_add && $opt_delete && !$opt_style ) {
Die(<{ or }->[ or }{
# The two bracket characters are the hash key and the hash value
# is 1 for an arrow and -1 for no arrow.
# $ch1 will hold most recent closing bracket
# $ch2 will hold a '->' if seen
my %rule_hash;
my ( $ch1, $ch2 );
my $err_msg;
my $pos_last;
while (1) {
$pos_last = pos($opt_style);
if (
$opt_style =~ m{
\G(?: # fix git #142
(\s+) # 1. whitespace
| ([\}\]]) # 2. closing bracket
| (->) # 3. arrow
| ([\[\{]) # 4. opening bracket
| (.*) # 5. something else, error
)
}gcx
)
{
if ($1) { next }
if ($2) {
if ( !$ch1 ) { $ch1 = $2 }
else { $err_msg = "unexpected '$2'"; last }
next;
}
if ($3) {
if ($ch1) { $ch2 = $3 }
else { $err_msg = "unexpected '$3'"; last }
next;
}
if ($4) {
if ( $ch1 || $ch2 ) {
my $key = $ch1 . $4;
if ( !defined( $rule_hash{$key} ) ) {
$rule_hash{$key} = $ch2 ? 1 : -1;
}
else { $err_msg = "multiple copies for '$key'"; last; }
$ch1 = $ch2 = undef;
}
else { $err_msg = "unexpected '$4'"; last }
next;
}
if ($5) {
my $bad = $5;
if ( length($bad) > 10 ) {
$bad = substr( $bad, 0, 10 ) . '...';
}
$err_msg = "confused at: '$bad'\n";
last;
}
}
# that's all..
else {
last;
}
} ## end while (1)
if ($err_msg) {
my $msg;
if ( $pos_last && length($opt_style) < 20 ) {
$msg = $opt_style . "\n" . SPACE x $pos_last . '^' . "\n";
}
$msg .= "Error parsing --$name_style: $err_msg";
Die($msg);
}
# Copy the rule hash, converting braces to token types
foreach my $key ( keys %rule_hash ) {
my $key_fix = $key;
$key_fix =~ tr/{}/LR/;
$interbracket_arrow_style{$key_fix} = $rule_hash{$key};
}
return;
} ## end sub initialize_interbracket_arrow_style
sub initialize_whitespace_hashes {
# This is called once before formatting begins to 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.
# fix for c250: added space rules new package type 'P' and sub type 'S'
my @spaces_both_sides = qw#
+ - * / % ? = . : x < > | & ^ .. << >> ** && .. || // => += -=
.= %= x= &= |= ^= *= <> <= >= == =~ !~ /= != ... <<= >>= ~~ !~~
**= &&= ||= //= <=> A k f w F n C Y U G v P S ^^
#;
my @spaces_left_side = qw< t ! ~ m p { \ h pp mm Z j >;
push( @spaces_left_side, '#' ); # avoids warning message
# c349: moved **= from @spaces_right_side to @spaces_both_sides
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{'t'}{'='} = WS_OPTIONAL; # for signatures; fixes b1123
$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 ()'
$binary_ws_rules{'i'}{'('} = WS_NO;
$binary_ws_rules{'w'}{'('} = WS_NO;
$binary_ws_rules{'w'}{'{'} = WS_YES;
# user controls
if ( !$rOpts->{'space-for-semicolon'} ) {
$want_left_space{'f'} = -1;
}
if ( $rOpts->{'space-terminal-semicolon'} ) {
$want_left_space{';'} = 1;
}
# 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);
}
return;
} ## end sub initialize_whitespace_hashes
{ #<<< begin closure set_whitespace_flags
my %is_special_ws_type;
my %is_wCUG;
my %is_wi;
BEGIN {
# The following hash is used to skip over needless if tests.
# Be sure to update it when adding new checks in its block.
my @q = qw( k w C m - Q );
push @q, '#';
@is_special_ws_type{@q} = (1) x scalar(@q);
# These hashes replace slower regex tests
@q = qw( w C U G );
@is_wCUG{@q} = (1) x scalar(@q);
@q = qw( w i );
@is_wi{@q} = (1) x scalar(@q);
} ## end BEGIN
use constant DEBUG_WHITE => 0;
# 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;
sub set_whitespace_flags {
my $self = shift;
# This routine is called once per file to set whitespace flags for that
# file. This routine examines each pair of nonblank tokens and sets a flag
# indicating if they should be separated by white space.
#
# $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 $j_tight_closing_paren = -1;
my $rLL = $self->[_rLL_];
my $K_closing_container = $self->[_K_closing_container_];
my $jmax = @{$rLL} - 1;
%opening_container_inside_ws = ();
%closing_container_inside_ws = ();
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
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 $ris_function_call_paren = {};
return $rwhitespace_flags if ( $jmax < 0 );
# function to return $ws for a signature paren following a sub
my $ws_signature_paren = sub {
my ($jj) = @_;
my $ws;
if ( $rOpts_space_signature_paren == 1 ) {
# is the previous token a blank?
my $have_blank = $rLL->[ $jj - 1 ]->[_TYPE_] eq 'b';
# or a newline?
$have_blank ||=
$rLL->[$jj]->[_LINE_INDEX_] != $rLL->[ $jj - 1 ]->[_LINE_INDEX_];
$ws = $have_blank ? WS_YES : WS_NO;
}
else {
$ws = $rOpts_space_signature_paren == 0 ? WS_NO : WS_YES;
}
return $ws;
}; ## end $ws_signature_paren = sub
my $last_token = SPACE;
my $last_type = 'b';
my $last_token_dbg = SPACE;
my $last_type_dbg = 'b';
my $rtokh_last = [ @{ $rLL->[0] } ];
$rtokh_last->[_TOKEN_] = $last_token;
$rtokh_last->[_TYPE_] = $last_type;
$rtokh_last->[_TYPE_SEQUENCE_] = EMPTY_STRING;
$rtokh_last->[_LINE_INDEX_] = 0;
my $rtokh_last_last = $rtokh_last;
# This will identify braces to be treated as blocks for the -xbt flag
my %block_type_for_tightness;
my ( $ws_1, $ws_2, $ws_3, $ws_4 );
# main loop over all tokens to define the whitespace flags
my $last_type_is_opening;
my $j = -1;
my $type;
foreach my $rtokh ( @{$rLL} ) {
$j++;
if ( ( $type = $rtokh->[_TYPE_] ) eq 'b' ) {
$rwhitespace_flags->[$j] = WS_OPTIONAL;
next;
}
my $token = $rtokh->[_TOKEN_];
my $ws;
#---------------------------------------------------------------
# Whitespace Rules Section 1:
# Handle space on the inside of opening braces.
#---------------------------------------------------------------
if ($last_type_is_opening) {
$last_type_is_opening = 0;
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
my $block_type = $rblock_type_of_seqno->{$seqno};
my $last_seqno = $rtokh_last->[_TYPE_SEQUENCE_];
my $last_block_type = $rblock_type_of_seqno->{$last_seqno}
|| $block_type_for_tightness{$last_seqno};
$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_here;
if ( $last_block_type && $last_token eq '{' ) {
$tightness_here = $rOpts_block_brace_tightness;
}
else { $tightness_here = $tightness{$last_token} }
#=============================================================
# Patch for test problem <>
# 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' && substr( $token, 0, 1 ) eq '^' ) {
$tightness_here = 1;
}
#=============================================================
if ( $tightness_here <= 0 ) {
$ws = WS_YES;
}
elsif ( $tightness_here > 1 ) {
$ws = WS_NO;
}
# Default (tightness = 1) depends on the container token count
else {
# Find the index of the closing token
my $j_closing = $K_closing_container->{$last_seqno};
# Certain token types can be counted as multiple tokens for
# the default tightness. The meaning of hash values is:
# 1 => match this token type
# otherwise it is a regex; match if token matches regex
my $regex = $multiple_token_tightness{$type};
if ( $regex
&& ( length($regex) == 1 || $token =~ /$regex/ ) )
{
$ws = WS_YES;
}
# If the closing token is less than five characters ahead
# we must take a closer look
elsif ( defined($j_closing)
&& $j_closing - $j < 5
&& $rLL->[$j_closing]->[_TYPE_SEQUENCE_] eq
$last_seqno )
{
# quick check
if ( $j + 1 >= $j_closing ) {
$ws = WS_NO;
$j_tight_closing_paren = $j_closing;
}
# slow check
else {
$ws =
ws_in_container( $j, $j_closing, $rLL, $type,
$token, $last_token );
if ( $ws == WS_NO ) {
$j_tight_closing_paren = $j_closing;
}
}
}
else {
$ws = WS_YES;
}
}
}
# check for special cases which override the above rules
if ( %opening_container_inside_ws && $last_seqno ) {
my $ws_override = $opening_container_inside_ws{$last_seqno};
if ($ws_override) { $ws = $ws_override }
}
$ws_4 = $ws_3 = $ws_2 = $ws_1 = $ws
if DEBUG_WHITE;
} ## end setting space flag inside opening tokens
#---------------------------------------------------------------
# Whitespace Rules Section 2:
# Special checks for certain types ...
#---------------------------------------------------------------
# The hash '%is_special_ws_type' significantly speeds up this routine,
# but be sure to update it if a new check is added.
# Currently has types: qw(k w C m - Q #)
if ( $is_special_ws_type{$type} ) {
if ( $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. Added the level check
# to fix b1236.
if ( $is_for_foreach{$token}
&& %keyword_paren_inner_tightness
&& defined( $keyword_paren_inner_tightness{$token} )
&& $j < $jmax )
{
my $level = $rLL->[$j]->[_LEVEL_];
## NOTE: we might use the KNEXT variable to avoid this loop
## but profiling shows that little would be saved
foreach my $jp ( $j + 1 .. $j + 9 ) {
last if ( $jp > $jmax );
last if ( $rLL->[$jp]->[_LEVEL_] != $level ); # b1236
next unless ( $rLL->[$jp]->[_TOKEN_] eq '(' );
my $seqno_p = $rLL->[$jp]->[_TYPE_SEQUENCE_];
set_container_ws_by_keyword( $token, $seqno_p );
last;
}
}
}
# handle a comment
elsif ( $type eq '#' ) {
# newline before block comment ($j==0), and
# space before side comment ($j>0), so ..
$ws = WS_YES;
#---------------------------------
# Nothing more to do for a comment
#---------------------------------
$rwhitespace_flags->[$j] = $ws;
next;
}
# space_backslash_quote; RT #123774 <>
# allow a space between a backslash and single or double quote
# to avoid fooling html formatters
elsif ( $type eq 'Q' ) {
if ( $last_type eq '\\' && $token =~ /^[\"\']/ ) {
$ws =
!$rOpts_space_backslash_quote ? WS_NO
: $rOpts_space_backslash_quote == 1 ? WS_OPTIONAL
: $rOpts_space_backslash_quote == 2 ? WS_YES
: WS_YES;
}
}
# retain any space between '-' and bare word
elsif ( $type eq 'w' || $type eq 'C' ) {
$ws = WS_OPTIONAL if $last_type eq '-';
}
# retain any space between '-' and bare word; for example
# avoid space between 'USER' and '-' here: <>
# $myhash{USER-NAME}='steve';
elsif ( $type eq 'm' || $type eq '-' ) {
$ws = WS_OPTIONAL if ( $last_type eq 'w' );
}
else {
# A type $type was entered in %is_special_ws_type but
# there is no code block to handle it. Either remove it
# from the hash or add a code block to handle it.
DEVEL_MODE && Fault("no code to handle type $type\n");
}
} ## end elsif ( $is_special_ws_type{$type} ...
#---------------------------------------------------------------
# Whitespace Rules Section 3:
# Handle space on inside of closing brace pairs.
#---------------------------------------------------------------
# /[\}\)\]R]/
elsif ( $is_closing_type{$type} ) {
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
if ( $j == $j_tight_closing_paren ) {
$j_tight_closing_paren = -1;
$ws = WS_NO;
}
else {
if ( !defined($ws) ) {
my $tightness_here;
my $block_type = $rblock_type_of_seqno->{$seqno}
|| $block_type_for_tightness{$seqno};
if ( $block_type && $token eq '}' ) {
$tightness_here = $rOpts_block_brace_tightness;
}
else { $tightness_here = $tightness{$token} }
$ws = ( $tightness_here > 1 ) ? WS_NO : WS_YES;
}
}
# check for special cases which override the above rules
if ( %closing_container_inside_ws && $seqno ) {
my $ws_override = $closing_container_inside_ws{$seqno};
if ($ws_override) { $ws = $ws_override }
}
$ws_4 = $ws_3 = $ws_2 = $ws
if DEBUG_WHITE;
} ## end setting space flag inside closing tokens
#---------------------------------------------------------------
# Whitespace Rules Section 4:
#---------------------------------------------------------------
elsif ( $is_opening_type{$type} ) {
$last_type_is_opening = 1;
if ( $token eq '(' ) {
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
# This will have to be tweaked as tokenization changes.
# We usually want a space at '} (', for example:
# <>
# 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 '}' && $last_token ne ')' ) { $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' ) {
if ( $last_token eq 'sub' ) {
$ws = $ws_signature_paren->($j);
}
else {
$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(
# -----------------------------------------------------
# Note that at this point an identifier may still have a
# leading arrow, but the arrow will be split off during token
# respacing. After that, the token may become a bare word
# without leading arrow. The point is, it is best to mark
# function call parens right here before that happens.
# Patch: added 'C' to prevent blinker, case b934, i.e. 'pi()'
# NOTE: this would be the place to allow spaces between
# repeated parens, like () () (), as in case c017, but I
# decided that would not be a good idea.
# Updated to allow detached '->' from tokenizer (issue c140)
elsif (
# /^[wCUG]$/
$is_wCUG{$last_type}
|| (
# /^[wi]$/
$is_wi{$last_type}
&& (
# with prefix '->' or '&'
$last_token =~ /^([\&]|->)/
# or preceding token '->' (see b1337; c140)
|| $rtokh_last_last->[_TYPE_] eq '->'
# or preceding sub call operator token '&'
|| ( $rtokh_last_last->[_TYPE_] eq 't'
&& $rtokh_last_last->[_TOKEN_] =~ /^\&\s*$/ )
)
)
)
{
$ws =
$rOpts_space_function_paren
? $self->ws_space_function_paren( $rtokh_last,
$rtokh_last_last )
: WS_NO;
# Note that this does not include functions called
# with '->(', so that case has to be handled separately
set_container_ws_by_keyword( $last_token, $seqno );
$ris_function_call_paren->{$seqno} = 1;
}
# space between something like $i and ( in 'snippets/space2.in'
# for $i ( 0 .. 20 ) {
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;
}
# a paren after a sub definition starts signature
elsif ( $last_type eq 'S' ) {
$ws = $ws_signature_paren->($j);
}
else {
# no special rule for this opening paren type
}
}
# 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;
}
else {
# opening type not covered by a special rule
}
# keep space between 'sub' and '{' for anonymous sub definition,
# be sure type = 'k' (added for c140)
if ( $type eq '{' ) {
if ( $last_token eq 'sub'
&& $last_type eq 'k'
&& $token ne '(' )
{
$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;
}
}
# The --extended-block-tightness option allows certain braces
# to be treated as blocks just for setting inner whitespace
if ( $rOpts_extended_block_tightness && $token eq '{' ) {
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
if ( !$rblock_type_of_seqno->{$seqno}
&& $extended_block_tightness_list{$last_token} )
{
# Ok - make this brace a block type for tightness only
$block_type_for_tightness{$seqno} = $last_token;
}
}
} ## end elsif ( $is_opening_type{$type} ) {
else {
# $type not opening, closing, or covered by a special rule
}
# always preserve whatever space was used after a possible
# filehandle (except _)
if ( $last_type eq 'Z' && $last_token ne '_' ) {
# no space for '$ {' even if '$' is marked as type 'Z', issue c221
# note: redundant check on type 'h' here removed for c419 part 2b
if ( $last_type eq 'Z' && $last_token eq '$' && $token eq '{' ) {
$ws = WS_NO;
}
else {
$ws = WS_OPTIONAL;
}
}
$ws_4 = $ws_3 = $ws
if DEBUG_WHITE;
if ( !defined($ws) ) {
#---------------------------------------------------------------
# Whitespace Rules Section 4:
# Use the binary rule table.
#---------------------------------------------------------------
if ( defined( $binary_ws_rules{$last_type}{$type} ) ) {
$ws = $binary_ws_rules{$last_type}{$type};
$ws_4 = $ws if DEBUG_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
else {
my $wl = $want_left_space{$type};
my $wr = $want_right_space{$last_type};
if ( !defined($wl) ) {
$ws = defined($wr) ? $wr : 0;
}
elsif ( !defined($wr) ) {
$ws = $wl;
}
else {
$ws =
( ( $wl == $wr ) || ( $wl == -1 ) || !$wr ) ? $wl : $wr;
}
}
}
# Treat newline as a whitespace. Otherwise, we might combine
# 'Send' and '-recipients' here according to the above rules:
# <>
# my $msg = new Fax::Send
# -recipients => $to,
# -data => $data;
if ( !$ws
&& $rtokh->[_LINE_INDEX_] != $rtokh_last->[_LINE_INDEX_] )
{
$ws = WS_YES;
}
# -qwaf phantom commas require space before type 'Q'
# See similar patch in sub is_essential_whitespace
if ( !$last_token
&& $last_type eq ','
&& $type eq 'Q'
&& $rOpts_qw_as_function )
{
$ws = 1;
}
$rwhitespace_flags->[$j] = $ws;
# remember non-blank, non-comment tokens
$last_token = $token;
$last_type = $type;
$rtokh_last_last = $rtokh_last;
$rtokh_last = $rtokh;
# Programming note: for some reason, it is very much faster to 'next'
# out of this loop here than to put the DEBUG coding in a block.
# But note that the debug code must then update its own copies
# of $last_token and $last_type.
next if ( !DEBUG_WHITE );
my $str = substr( $last_token_dbg, 0, 15 );
$str .= SPACE 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_dbg $type $ws_1 : $ws_2 : $ws_3 : $ws_4 : $ws \n";
# reset for next pass
$ws_1 = $ws_2 = $ws_3 = $ws_4 = undef;
$last_token_dbg = $token;
$last_type_dbg = $type;
} ## end main loop
if ( $rOpts->{'tight-secret-operators'} ) {
$self->new_secret_operator_whitespace($rwhitespace_flags);
}
$self->[_ris_function_call_paren_] = $ris_function_call_paren;
return $rwhitespace_flags;
} ## end sub set_whitespace_flags
sub set_container_ws_by_keyword {
my ( $word, $sequence_number ) = @_;
return unless (%keyword_paren_inner_tightness);
# 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_here = $keyword_paren_inner_tightness{$word};
if ( defined($tightness_here) && $tightness_here != 1 ) {
my $ws_flag = $tightness_here == 0 ? WS_YES : WS_NO;
$opening_container_inside_ws{$sequence_number} = $ws_flag;
$closing_container_inside_ws{$sequence_number} = $ws_flag;
}
}
else {
DEVEL_MODE
&& Fault("unexpected token='$word' and seqno='$sequence_number'\n");
}
return;
} ## end sub set_container_ws_by_keyword
sub ws_in_container {
my ( $j, $j_closing, $rLL, $type, $token, $last_token ) = @_;
# Given:
# $j = index of token following an opening container token
# $type, $token = the type and token at index $j
# $j_closing = closing token of the container
# $last_token = the opening token of the container
# Return:
# WS_NO if there is just one token in the container (with exceptions)
# WS_YES otherwise
# quick check
if ( $j + 1 >= $j_closing ) { return WS_NO }
# special cases...
# 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' );
# Count a sign separated from a number as a single token, as in the
# following line. Otherwise, it takes two steps to converge:
# deg2rad(- 0.5)
if ( ( $type eq 'm' || $type eq 'p' )
&& $j < $j_closing + 1
&& $rLL->[ $j + 1 ]->[_TYPE_] eq 'b'
&& $rLL->[ $j + 2 ]->[_TYPE_] eq 'n'
&& $rLL->[ $j + 2 ]->[_TOKEN_] =~ /^\d/ )
{
$j_here = $j + 2;
}
# recheck..
if ( $j_here + 1 >= $j_closing ) { return WS_NO }
# check for a blank after the first token
my $j_next =
( $rLL->[ $j_here + 1 ]->[_TYPE_] eq 'b' )
? $j_here + 2
: $j_here + 1;
return $j_next == $j_closing ? WS_NO : WS_YES;
} ## end sub ws_in_container
sub ws_space_function_paren {
my ( $self, $rtokh_last, $rtokh_last_last ) = @_;
# Called if --space-function-paren is set to see if it might cause
# a problem. The manual warns the user about potential problems with
# this flag. Here we just try to catch one common problem.
# Given:
# $j = index of '(' after function name
# Return:
# WS_NO if no space
# WS_YES otherwise
# This was added to fix for issue c166. Ignore -sfp at a possible indirect
# object location. For example, do not convert this:
# print header() ...
# to this:
# print header () ...
# because in this latter form, header may be taken to be a file handle
# instead of a function call.
# Start with the normal value for -sfp:
my $ws = WS_YES;
# now check to be sure we don't cause a problem:
my $type_ll = $rtokh_last_last->[_TYPE_];
my $tok_ll = $rtokh_last_last->[_TOKEN_];
# NOTE: this is just a minimal check. For example, we might also check
# for something like this:
# print ( header ( ..
if ( $type_ll eq 'k' && $is_indirect_object_taker{$tok_ll} ) {
$ws = WS_NO;
}
# do not let -sfp add space for qw's converted to functions by -qwaf
if ( $rOpts_qw_as_function
&& $rtokh_last->[_TYPE_] eq 'U'
&& $rtokh_last->[_TOKEN_] eq 'qw' )
{
$ws = WS_NO;
}
return $ws;
} ## end sub ws_space_function_paren
} ## end closure set_whitespace_flags
sub dump_want_left_space {
my $fh = shift;
local $LIST_SEPARATOR = "\n";
$fh->print(<print("$key\t$want_left_space{$key}\n");
}
return;
} ## end sub dump_want_left_space
sub dump_want_right_space {
my $fh = shift;
local $LIST_SEPARATOR = "\n";
$fh->print(<print("$key\t$want_right_space{$key}\n");
}
return;
} ## end sub dump_want_right_space
{ ## begin closure is_essential_whitespace
my %is_sort_grep_map;
my %is_digraph;
my %is_trigraph;
my %essential_whitespace_filter_l1;
my %essential_whitespace_filter_r1;
my %essential_whitespace_filter_l2;
my %essential_whitespace_filter_r2;
my %is_type_with_space_before_bareword;
my %is_special_variable_char;
my %is_digit_char;
BEGIN {
my @q;
# NOTE: This hash is like the global %is_sort_map_grep, but it ignores
# grep aliases on purpose, since here we are looking parens, not braces
@q = qw( sort grep map );
@is_sort_grep_map{@q} = (1) x scalar(@q);
@q = qw{
.. :: << >> ** && || // -> => += -=
.= %= &= |= ^= *= <> <= >= == =~ !~
!= ++ -- /= x= ~~ ~. |. &. ^. ^^
};
@is_digraph{@q} = (1) x scalar(@q);
@q = qw( ... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~ );
@is_trigraph{@q} = (1) x scalar(@q);
# These are used as a speedup filters for sub is_essential_whitespace.
# Filter 1:
# These left side token types USUALLY do not require a space:
@q = qw( ; { } [ ] L R );
push @q, ',';
push @q, ')';
push @q, '(';
@essential_whitespace_filter_l1{@q} = (1) x scalar(@q);
# BUT some might if followed by these right token types
@q = qw( pp mm << <<= h );
@essential_whitespace_filter_r1{@q} = (1) x scalar(@q);
# Filter 2:
# These right side filters usually do not require a space
@q = qw( ; ] R } );
push @q, ',';
push @q, ')';
@essential_whitespace_filter_r2{@q} = (1) x scalar(@q);
# BUT some might if followed by these left token types
@q = qw( h Z );
@essential_whitespace_filter_l2{@q} = (1) x scalar(@q);
# Keep a space between certain types and any bareword:
# Q: keep a space between a quote and a bareword to prevent the
# bareword from becoming a quote modifier.
# &: 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);
@q = qw( Q & );
@is_type_with_space_before_bareword{@q} = (1) x scalar(@q);
# These are the only characters which can (currently) form special
# variables, like $^W: (issue c066, c068).
@q =
qw{ ? A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \ ] ^ _ };
@is_special_variable_char{@q} = (1) x scalar(@q);
@q = qw( 0 1 2 3 4 5 6 7 8 9 );
@is_digit_char{@q} = (1) x scalar(@q);
} ## end BEGIN
sub is_essential_whitespace {
my ( $tokenll, $typell, $tokenl, $typel, $tokenr, $typer ) = @_;
# Essential whitespace means whitespace which cannot be safely deleted
# without risking the introduction of a syntax error.
# Given: three tokens and their types:
# ($tokenll, $typell) = previous nonblank token to the left of $tokenl
# ($tokenl, $typel) = the token to the left of the space in question
# ($tokenr, $typer) = the token to the right of the space in question
# Return:
# true if whitespace is needed
# false if whitespace may be deleted
#
# Note1: This routine should almost never need to be changed. It is
# for avoiding syntax problems rather than for formatting.
# Note2: The -mangle option causes large numbers of calls to this
# routine and therefore is a good test. So if a change is made, be sure
# to use nytprof to profile with both old and revised coding using the
# -mangle option and check differences.
# This is potentially a very slow routine but the following quick
# filters typically catch and handle over 90% of the calls.
# -qwaf phantom commas require space before type 'Q'
# See similar patch in sub set_whitespace_flags
if ( !$tokenl
&& $typel eq ','
&& $typer eq 'Q'
&& $rOpts_qw_as_function )
{
return 1;
}
# Filter 1: usually no space required after common types ; , [ ] { } ( )
return
if ( $essential_whitespace_filter_l1{$typel}
&& !$essential_whitespace_filter_r1{$typer} );
# Filter 2: usually no space before common types ; ,
return
if ( $essential_whitespace_filter_r2{$typer}
&& !$essential_whitespace_filter_l2{$typel} );
# Filter 3: Handle side comments: a space is only essential if the left
# token ends in '$' For example, we do not want to create $#foo below:
# sub t086
# ( #foo)))
# $ #foo)))
# a #foo)))
# ) #foo)))
# { ... }
# Also, I prefer not to put a ? and # together because ? used to be
# a pattern delimiter and spacing was used if guessing was needed.
if ( $typer eq '#' ) {
return 1
if ( $tokenl
&& ( $typel eq '?' || substr( $tokenl, -1 ) eq '$' ) );
return;
}
my $tokenr_leading_ch = substr( $tokenr, 0, 1 );
my $tokenr_leading_ch2 = substr( $tokenr, 0, 2 );
my $tokenr_is_open_paren = $tokenr eq '(';
my $token_joined = $tokenl . $tokenr;
my $tokenl_is_dash = $tokenl eq '-';
my $tokenr_is_bareword = ord($tokenr_leading_ch) > ORD_PRINTABLE_MAX
# always correct but slow
? $tokenr =~ /^[^\d\W]/
# fast but ascii only
: ( $tokenr_leading_ch =~ tr/a-zA-Z_/a-zA-Z_/ );
#-------------------
# Must do full check
#-------------------
# This long logical expression gives the result
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
(
(
## ( $tokenr =~ /^([\'\w]|\:\:)/ )
$tokenr_is_bareword
|| $is_digit_char{$tokenr_leading_ch}
|| $tokenr_leading_ch eq "'"
|| $tokenr_leading_ch2 eq '::'
)
&& ( $tokenl =~ /([\'\w]|\:\:)$/ && $typel ne 'CORE::' )
)
# 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 space between types Q & and a bareword
|| $is_type_with_space_before_bareword{$typel}
# +-: binary plus and minus before a bareword could get
# converted into unary plus and minus on next pass through the
# tokenizer. This can lead to blinkers: cases b660 b670 b780
# b781 b787 b788 b790 So we keep a space unless the +/- clearly
# follows an operator
|| ( ( $typel eq '+' || $typel eq '-' )
&& $typell !~ /^[niC\)\}\]R]$/ )
# keep a space between a token ending in '$' and any word;
# this caused trouble: "die @$ if $@"
|| $typel eq 'i' && substr( $tokenl, -1, 1 ) eq '$'
# don't combine $$ or $# with any alphanumeric
# (testfile mangle.t with --mangle)
|| $tokenl eq '$$'
|| $tokenl eq '$#'
)
) ## 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 <>
# 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.
#
# And do not combine a bareword and a quote, like this:
# oops "Your login, $Bad_Login, is not valid";
# It can cause a syntax error if oops is a sub
|| $typel eq 'w' && ( $tokenr eq '-' || $typer eq 'Q' )
# perl is very fussy about spaces before <<; c419 part 1
|| $tokenr_leading_ch2 eq '<<' && $typel ne '{' && $typel ne ','
# 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 . $tokenr_leading_ch }
# retain any space after possible filehandle
# (testfiles prnterr1.t with --extrude and mangle.t with --mangle)
# but no space for '$ {' even if '$' is marked as type 'Z', issue c221
|| ( $typel eq 'Z' && !( $tokenl eq '$' && $tokenr eq '{' ) )
# Added 'Y' here 16 Jan 2021 to prevent -mangle option from removing
# space after type Y. Otherwise, it will get parsed as type 'Z' later
# and any space would have to be added back manually if desired.
|| $typel eq 'Y'
# 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' )
# OLD: keep any space between filehandle and paren:
# file mangle.t with --mangle:
# NEW: this test is no longer necessary here (moved above)
## || $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 ( see hereerr.t)
# c419, part 2a: unless followed by '}' or ','. See also part 2b.
# or ; (git174)
|| $typel eq 'h' && $typer ne '}' && $typer ne ',' && $typer ne ';'
# Be careful with a space around ++ and --, to avoid ambiguity as to
# which token it applies
|| ( $typer eq 'pp' || $typer eq 'mm' ) && $tokenl !~ /^[\;\{\(\[]/
|| ( $typel eq '++' || $typel eq '--' )
&& $tokenr !~ /^[\;\}\)\]]/
# Need space after 'for my' or 'foreach my';
# for example, this will fail in older versions of Perl:
# foreach my$ft(@filetypes)...
|| ( $tokenl eq 'my'
&& $tokenr_leading_ch eq '$'
&& $is_for_foreach{$tokenll} )
# Keep space after $^ if needed to avoid forming a different
# special variable (issue c068). For example:
# my $aa = $^ ? "none" : "ok";
# The problem is that '$^?' is a valid special variable
|| ( $typel eq 'i'
&& length($tokenl) == 2
&& substr( $tokenl, 1, 1 ) eq '^'
&& $is_special_variable_char{$tokenr_leading_ch} )
# 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...
# Not really required: Perl seems to accept non-spaced labels.
## || $typel eq 'J' && $typer eq 'J'
; # the value of this long logic sequence is the result we want
return $result;
} ## end sub is_essential_whitespace
} ## end closure is_essential_whitespace
{ ## begin closure new_secret_operator_whitespace
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;
}
} ## end BEGIN
sub new_secret_operator_whitespace {
my ( $self, $rwhitespace_flags ) = @_;
# Implement --tight-secret-operators
# Given:
# $rwhitespace_flags = whitespase flags, to be updated
# Loop over all tokens in this line
my $rLL = $self->[_rLL_];
my $jmax = @{$rLL} - 1;
foreach my $j ( 0 .. $jmax ) {
# Skip unless this token might start a secret operator
my $type = $rLL->[$j]->[_TYPE_];
next if ( $type eq 'b' );
my $token = $rLL->[$j]->[_TOKEN_];
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
&& $rLL->[$jend]->[_TYPE_] eq 'b' );
if ( $jend > $jmax
|| $tok ne $rLL->[$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 new_secret_operator_whitespace
} ## end closure new_secret_operator_whitespace
{ ## begin closure set_bond_strengths
# These routines and variables are involved in deciding where to break very
# long lines.
# NEW_TOKENS must add bond strength rules
my %is_good_keyword_breakpoint;
my %is_container_token;
my %binary_bond_strength_nospace;
my %binary_bond_strength;
my %nobreak_lhs;
my %nobreak_rhs;
my @bias_tokens;
my %bias_hash;
my %bias;
my $delta_bias;
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/ ( [ { } ] ) /;
@is_container_token{@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_nospace = ();
%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 exponentiation
@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;
# Fix for c250: added strengths for new type 'P'
# Note: these are working okay, but may eventually need to be
# adjusted or even removed.
$left_bond_strength{'P'} = NOMINAL;
$right_bond_strength{'P'} = NOMINAL;
# 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);
# Define left strength of unary plus and minus (fixes case b511)
$left_bond_strength{p} = $left_bond_strength{'+'};
$left_bond_strength{m} = $left_bond_strength{'-'};
# And make right strength of unary plus and minus very high.
# Fixes cases b670 b790
$right_bond_strength{p} = NO_BREAK;
$right_bond_strength{m} = NO_BREAK;
# 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;
# set strength of ^^ between && and ||. See git157.
# "1 || 0 ^^ 0 || 1" = true, so ^^ is stronger than ||
# "1 ^^ 1 && 0" = true, so && is stronger than ^^
$right_bond_strength{'^^'} = NOMINAL;
$left_bond_strength{'^^'} = $left_bond_strength{'||'} + 0.05;
$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;
@q = qw( ne eq );
@left_bond_strength{@q} = (NOMINAL) x scalar(@q);
@q = qw( lt gt le ge );
@left_bond_strength{@q} = ( 0.9 * NOMINAL + 0.1 * STRONG ) x scalar(@q);
@q = qw( and or err xor ne eq );
@right_bond_strength{@q} = (NOMINAL) x scalar(@q);
$right_bond_strength{'{'} = WEAK;
$left_bond_strength{'{'} = VERY_STRONG;
#---------------------------------------------------------------
# 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;
# Added for c140 to make 'w ->' and 'i ->' behave the same
$binary_bond_strength{'w'}{'->'} = 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;
# The following two rules prevent a syntax error caused by breaking up
# a construction like '{-y}'. The '-' quotes the 'y' and prevents
# it from being taken as a transliteration. We have to keep
# token types 'L m w' together to prevent this error.
$binary_bond_strength{'L{'}{'m'} = NO_BREAK;
$binary_bond_strength_nospace{'m'}{'w'} = NO_BREAK;
# keep 'bareword-' together, but only if there is no space between
# the word and dash. Do not keep together if there is a space.
# example 'use perl6-alpha'
$binary_bond_strength_nospace{'w'}{'m'} = 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;
# Fix for c250: set strength for new 'S' to be same as 'i'
# testfile is test11/Hub.pm
$binary_bond_strength{'S'}{'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;
# To prevent the tokenizer from switching between types 'w' and 'G' we
# need to avoid breaking between type 'G' and the following code block
# brace. Fixes case b929.
$nobreak_rhs{G} = 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
%bias_hash = map { $_ => 0 } @bias_tokens;
$delta_bias = 0.0001; # a very small strength level
return;
} ## end sub initialize_bond_strength_hashes
use constant DEBUG_BOND => 0;
sub set_bond_strengths {
my ($self) = @_;
# Define a 'bond strength' for each token pair in an output batch.
# See comments above for definition of bond strength.
my $rbond_strength_to_go = [];
my $rLL = $self->[_rLL_];
my $rK_weld_right = $self->[_rK_weld_right_];
my $rK_weld_left = $self->[_rK_weld_left_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
# patch-its always ok to break at end of line
$nobreak_to_go[$max_index_to_go] = 0;
# we start a new set of bias values for each line
%bias = %bias_hash;
my $code_bias = -.01; # bias for closing block braces
my $type = 'b';
my $token = SPACE;
my $token_length = 1;
my $last_type;
my $last_nonblank_type = $type;
my $last_nonblank_token = $token;
my $list_str = $left_bond_strength{'?'};
my ( $bond_str_1, $bond_str_2, $bond_str_3, $bond_str_4 );
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' ) {
$rbond_strength_to_go->[$i] = $rbond_strength_to_go->[ $i - 1 ];
$nobreak_to_go[$i] ||= $nobreak_to_go[ $i - 1 ]; # fix for b1257
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];
my $seqno = $type_sequence_to_go[$i];
my $next_nonblank_seqno = $type_sequence_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' ) {
if ( defined( $right_bond_strength{$token} ) ) {
$bsr = $right_bond_strength{$token};
}
}
# 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;
# But weaken the bond at a 'missing terminal comma'. If an
# optional comma is missing at the end of a broken list, use
# the strength of a comma anyway to make formatting the same as
# if it were there. Fixes issue c133.
if ( !defined($bsr) || $bsr > VERY_WEAK ) {
my $seqno_px = $parent_seqno_to_go[$max_index_to_go];
if ( $ris_list_by_seqno->{$seqno_px} ) {
my $KK = $K_to_go[$max_index_to_go];
my $Kn = $self->K_next_nonblank($KK);
my $seqno_n = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
if ( $seqno_n && $seqno_n eq $seqno_px ) {
$bsl = VERY_WEAK;
}
}
}
}
# define left bond strengths of certain keywords
if ( $next_nonblank_type eq 'k' ) {
if ( defined( $left_bond_strength{$next_nonblank_token} ) ) {
$bsl = $left_bond_strength{$next_nonblank_token};
}
}
# 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;
$bond_str_1 = $bond_str if (DEBUG_BOND);
#---------------------------------------------------------------
# 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' ) {
# /^(die|confess|croak|warn)$/
if ( $is_die_confess_croak_warn{$next_nonblank_token} ) {
if ( $want_break_before{$token} && $i > 0 ) {
$rbond_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 ) {
$rbond_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;
}
}
if ( $next_nonblank_type eq 'k' && $type ne 'CORE::' ) {
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 }
}
else {
# no applicable hardwired change
}
#---------------------------------------------------------------
# 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;
}
# OLD COMMENT: 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;
# NEW COMMENT: Third fix for b1213:
# This option does not seem to be needed any longer, and it can
# cause instabilities. It can be turned off, but to minimize
# changes to existing formatting it is retained only in the case
# where the previous token was 'open' and there was no line break.
# Even this could eventually be removed if it causes instability.
if ( $type eq '{' ) {
if ( $token eq '('
&& $next_nonblank_type eq 'w'
&& $last_nonblank_type eq 'k'
&& $last_nonblank_token eq 'open'
&& !$old_breakpoint_to_go[$i] )
{
$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,
# and this is not an existing breakpoint; fixes c039.
|| !$old_breakpoint_to_go[$i]
&& substr( $next_nonblank_token, 0, 1 ) eq '/'
)
{
$bond_str = NO_BREAK;
}
}
# Fix for c039
elsif ( $type eq 'w' ) {
$bond_str = NO_BREAK
if ( !$old_breakpoint_to_go[$i]
&& substr( $next_nonblank_token, 0, 1 ) eq '/'
&& $next_nonblank_type ne '//' );
}
else {
# no hardwired rule applies
}
# 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' );
}
# Do not break before a phantom comma because it will confuse
# the convergence test (STRANGE message is emitted)
elsif ( $next_nonblank_type eq ',' ) {
if ( !length($next_nonblank_token) ) {
$bond_str = NO_BREAK;
}
}
else {
# no special NO_BREAK rule applies
}
$bond_str_2 = $bond_str if (DEBUG_BOND);
#---------------------------------------------------------------
# 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 ( $seqno && $is_container_token{$token} ) {
$ltype = $type . $token;
}
if ( $next_nonblank_seqno
&& $is_container_token{$next_nonblank_token} )
{
$rtype = $next_nonblank_type . $next_nonblank_token;
# Alternate Fix #1 for issue b1299. This version makes the
# decision as soon as possible. See Alternate Fix #2 also.
# Do not separate a bareword identifier from its paren: b1299
# This is currently needed for stability because if the bareword
# gets separated from a preceding '->' and following '(' then
# the tokenizer may switch from type 'i' to type 'w'. This
# patch will prevent this by keeping it adjacent to its '('.
## if ( $next_nonblank_token eq '('
## && $ltype eq 'i'
## && substr( $token, 0, 1 ) =~ /^\w$/ )
## {
## $ltype = 'w';
## }
}
# apply binary rules which apply regardless of space between tokens
if ( $binary_bond_strength{$ltype}{$rtype} ) {
$bond_str = $binary_bond_strength{$ltype}{$rtype};
$tabulated_bond_str = $bond_str;
}
# apply binary rules which apply only if no space between tokens
if ( $binary_bond_strength_nospace{$ltype}{$next_type} ) {
$bond_str = $binary_bond_strength{$ltype}{$next_type};
$tabulated_bond_str = $bond_str;
}
if ( $nobreak_rhs{$ltype} || $nobreak_lhs{$rtype} ) {
$bond_str = NO_BREAK;
$tabulated_bond_str = $bond_str;
}
$bond_str_3 = $bond_str if (DEBUG_BOND);
# If the hardwired rules conflict with the tabulated bond
# strength then there is an inconsistency that should be fixed
DEBUG_BOND
&& $tabulated_bond_str
&& $bond_str_1
&& $bond_str_1 != $bond_str_2
&& $bond_str_2 != $tabulated_bond_str
&& do {
print {*STDOUT}
"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:
# $type - if not keyword
# $token - if keyword, but map some keywords together
my $left_key =
$type eq 'k' ? $token eq 'err' ? 'or' : $token : $type;
my $right_key =
$next_nonblank_type eq 'k'
? $next_nonblank_token eq 'err'
? 'or'
: $next_nonblank_token
: $next_nonblank_type;
# bias left token
if ( 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 '.' ) {
my $is_short_quote = $last_nonblank_type eq '.'
&& ( $token_length <=
$rOpts_short_concatenation_item_length )
&& !$is_closing_token{$token};
if ( !$is_short_quote ) {
$bias{$right_key} += $delta_bias;
}
}
else {
$bias{$right_key} += $delta_bias;
}
$bond_str += $bias{$right_key};
}
}
$bond_str_4 = $bond_str if (DEBUG_BOND);
#---------------------------------------------------------------
# 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;
# For critical code such as lines with here targets we must
# be absolutely sure that we do not allow a break. So for
# these the nobreak flag exceeds 1 as a signal. Otherwise we
# can run into trouble when small tolerances are added.
$strength += 1
if ( $nobreak_to_go[$i] && $nobreak_to_go[$i] > 1 );
}
#---------------------------------------------------------------
# Bond Strength Section 6:
# Sixth Approximation. Welds.
#---------------------------------------------------------------
# Do not allow a break within welds
if ( $total_weld_count && $seqno ) {
my $KK = $K_to_go[$i];
if ( $rK_weld_right->{$KK} ) {
$strength = NO_BREAK;
}
# But encourage breaking after opening welded tokens
elsif ($rK_weld_left->{$KK}
&& $is_opening_token{$token} )
{
$strength -= 1;
}
else {
# not welded left or right
}
}
# always break after side comment
if ( $type eq '#' ) { $strength = 0 }
$rbond_strength_to_go->[$i] = $strength;
# Fix for case c001: be sure NO_BREAK's are enforced by later
# routines, except at a '?' because '?' as quote delimiter is
# deprecated.
if ( $strength >= NO_BREAK && $next_nonblank_type ne '?' ) {
$nobreak_to_go[$i] ||= 1;
}
DEBUG_BOND && do {
my $str = substr( $token, 0, 15 );
$str .= SPACE 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";
# reset for next pass
$bond_str_1 = $bond_str_2 = $bond_str_3 = $bond_str_4 = undef;
};
} ## end main loop
return $rbond_strength_to_go;
} ## end sub set_bond_strengths
} ## end closure set_bond_strengths
sub bad_pattern {
my ($pattern) = @_;
# Return true if a regex pattern has an error
# Note: Tokenizer.pm also has a copy of this
my $regex_uu = eval { qr/$pattern/ };
return $EVAL_ERROR;
} ## end sub bad_pattern
{ ## begin closure prepare_cuddled_block_types
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 {
# Construct a hash needed by the cuddled-else style
my $cuddled_string = EMPTY_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 .= SPACE . $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 if ( @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;
} ## end sub prepare_cuddled_block_types
} ## end closure prepare_cuddled_block_types
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
# },
# };
# SIMPLIFIED 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 = EMPTY_STRING unless $cuddled_string;
my $flags = EMPTY_STRING;
$flags .= "-ce" if ( $rOpts->{'cuddled-else'} );
$flags .= " -cbl='$cuddled_string'";
if ( !$rOpts->{'cuddled-else'} ) {
$flags .= "\nNote: You must specify -ce to generate a cuddled hash";
}
$fh->print(<print( Dumper($rcuddled_block_types) );
$fh->print(<{'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;
} ## end sub make_static_block_comment_pattern
sub make_format_skipping_pattern {
my ( $opt_name, $default ) = @_;
my $param = $rOpts->{$opt_name};
if ( !$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;
} ## end sub make_format_skipping_pattern
sub make_non_indenting_brace_pattern {
# Create the pattern used to identify static side comments.
# Note that we are ending the pattern in a \s. This will allow
# the pattern to be followed by a space and some text, or a newline.
# The pattern is used in sub 'non_indenting_braces'
$non_indenting_brace_pattern = '^#<<<\s';
# allow the user to change it
if ( $rOpts->{'non-indenting-brace-prefix'} ) {
my $prefix = $rOpts->{'non-indenting-brace-prefix'};
$prefix =~ s/^\s+//;
if ( $prefix !~ /^#/ ) {
Die("ERROR: the -nibp parameter '$prefix' must begin with '#'\n");
}
my $pattern = '^' . $prefix . '\s';
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the -nibp prefix '$prefix' causes the invalid regex '$pattern'\n"
);
}
$non_indenting_brace_pattern = $pattern;
}
return;
} ## end sub make_non_indenting_brace_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+';
# '1' is an impossible block name
$closing_side_comment_exclusion_pattern = '^1';
# Need a separate flag for anonymous subs because they are the only
# types where the side comment might follow a ';'
$closing_side_comment_want_asub = 1;
my $cscl = $rOpts->{'closing-side-comment-list'};
if ( defined($cscl) && $cscl ) {
$closing_side_comment_list_pattern =
make_block_pattern( '-cscl', $cscl );
$closing_side_comment_want_asub = $cscl =~ /\basub\b/;
}
my $cscxl = $rOpts->{'closing-side-comment-exclusion-list'};
if ( defined($cscxl) && $cscxl ) {
$closing_side_comment_exclusion_pattern =
make_block_pattern( '-cscxl', $cscxl );
if ( $cscxl =~ /\basub\b/ ) {
$closing_side_comment_want_asub = 0;
}
}
return;
} ## end sub make_closing_side_comment_list_pattern
sub initialize_closing_side_comments {
make_closing_side_comment_prefix();
make_closing_side_comment_list_pattern();
# 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. And we cannot do this
# with -io because -csc will be skipped altogether.
if ( $rOpts->{'closing-side-comments'} ) {
if ( !$rOpts->{'closing-side-comment-warnings'}
&& !$rOpts->{'indent-only'} )
{
$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'} = 100_000_000;
}
}
else {
# no -csc flags
}
return;
} ## end sub initialize_closing_side_comments
sub initialize_missing_else_comment {
my $comment = $rOpts->{'add-missing-else-comment'};
if ( !$comment ) {
$comment = '##FIX' . 'ME - added with perltidy -ame';
}
else {
$comment = substr( $comment, 0, 60 );
$comment =~ s/^\s+//;
$comment =~ s/\s+$//;
$comment =~ s/\n/ /g;
if ( substr( $comment, 0, 1 ) ne '#' ) {
$comment = '#' . $comment;
}
}
$rOpts->{'add-missing-else-comment'} = $comment;
return;
} ## end sub initialize_missing_else_comment
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
# 'sub :' is a label, not a sub ( block type will be )
# sub'_ is a named sub ( block type will be )
# 'substr' is a keyword
# So note that named subs always have a space after 'sub'
$SUB_PATTERN = '^sub\s'; # match normal sub
$ASUB_PATTERN = '^sub$'; # match anonymous sub
%matches_ASUB = ( 'sub' => 1 );
# Fix the patterns to include any sub aliases:
# 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 @words;
my $sub_alias_list = $rOpts->{'sub-alias-list'};
if ($sub_alias_list) {
@words = split /\s+/, $sub_alias_list;
}
else {
push @words, 'sub';
}
# add 'method' unless use-feature='noclass' is set.
if ( !defined( $rOpts->{'use-feature'} )
|| $rOpts->{'use-feature'} !~ /\bnoclass\b/ )
{
push @words, 'method';
}
# Note (see also RT #133130): These patterns are used by
# sub make_block_pattern, which is used for making most patterns.
# So this sub needs to be called before other pattern-making routines.
if ( @words > 1 ) {
# Two ways are provided to match an anonymous sub:
# $ASUB_PATTERN - with a regex (old method, slow)
# %matches_ASUB - with a hash lookup (new method, faster)
@matches_ASUB{@words} = (1) x scalar(@words);
my $alias_list = join '|', keys %matches_ASUB;
$SUB_PATTERN =~ s/sub/\($alias_list\)/;
$ASUB_PATTERN =~ s/sub/\($alias_list\)/;
}
return;
} ## end sub make_sub_matching_pattern
sub make_bl_pattern {
# Set defaults lists to retain historical default behavior for -bl:
my $bl_list_string = '*';
my $bl_exclusion_list_string = 'sort map grep eval asub';
my $bl_long_name = 'opening-brace-on-new-line';
my $bll_long_name = 'brace-left-list';
my $blxl_long_name = 'brace-left-exclusion-list';
my $sbl_long_name = 'opening-sub-brace-on-new-line';
my $asbl_long_name = 'opening-anonymous-sub-brace-on-new-line';
if ( defined( $rOpts->{$bll_long_name} ) && $rOpts->{$bll_long_name} ) {
$bl_list_string = $rOpts->{$bll_long_name};
}
if ( $bl_list_string =~ /\bsub\b/ ) {
$rOpts->{$sbl_long_name} ||= $rOpts->{$bl_long_name};
}
if ( $bl_list_string =~ /\basub\b/ ) {
$rOpts->{$asbl_long_name} ||= $rOpts->{$bl_long_name};
}
$bl_pattern = make_block_pattern( '-bll', $bl_list_string );
# for -bl, a list with '*' turns on -sbl and -asbl
if ( $bl_pattern =~ /\.\*/ ) {
if ( !defined( $rOpts->{$sbl_long_name} ) ) {
$rOpts->{$sbl_long_name} = $rOpts->{$bl_long_name};
}
if ( !defined( $rOpts->{$asbl_long_name} )
&& defined( $rOpts->{$bll_long_name} ) )
{
$rOpts->{$asbl_long_name} = $rOpts->{$bl_long_name};
}
}
if ( defined( $rOpts->{$blxl_long_name} )
&& $rOpts->{$blxl_long_name} )
{
$bl_exclusion_list_string = $rOpts->{$blxl_long_name};
if ( $bl_exclusion_list_string =~ /\bsub\b/ ) {
$rOpts->{$sbl_long_name} = 0;
}
if ( $bl_exclusion_list_string =~ /\basub\b/ ) {
$rOpts->{$asbl_long_name} = 0;
}
}
$bl_exclusion_pattern =
make_block_pattern( '-blxl', $bl_exclusion_list_string );
return;
} ## end sub make_bl_pattern
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';
my $bli_exclusion_list_string = SPACE;
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 );
if ( defined( $rOpts->{'brace-left-and-indent-exclusion-list'} )
&& $rOpts->{'brace-left-and-indent-exclusion-list'} )
{
$bli_exclusion_list_string =
$rOpts->{'brace-left-and-indent-exclusion-list'};
}
$bli_exclusion_pattern =
make_block_pattern( '-blixl', $bli_exclusion_list_string );
return;
} ## end sub make_bli_pattern
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 = EMPTY_STRING;
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 eq 'BC' || $word eq '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( SPACE, @comment_list ) );
}
return;
} ## end sub make_keyword_group_list_pattern
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;
} ## end sub make_block_brace_vertical_tightness_pattern
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;
} ## end sub make_blank_line_pattern
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");
}
}
# Fix 2 for c091, prevent the pattern from matching an empty string
# '1 ' is an impossible block name.
if ( !@words ) { push @words, "1 " }
my $pattern = '(' . join( '|', @words ) . ')$';
my $sub_patterns = EMPTY_STRING;
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;
} ## end sub make_block_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;
} ## end sub make_static_side_comment_pattern
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
if (DEVEL_MODE) {
Fault(<{'closing-side-comment-prefix'} = $csc_prefix;
$closing_side_comment_prefix_pattern = $csc_prefix_pattern;
return;
} ## end sub make_closing_side_comment_prefix
##################################################
# CODE SECTION 4: receive lines from the tokenizer
##################################################
{ ## begin closure write_line
my $nesting_depth;
# Variables used by sub check_sequence_numbers:
my $initial_seqno;
my $last_seqno;
my %saw_opening_seqno;
my %saw_closing_seqno;
# variables for the -qwaf option
my $in_qw_seqno;
my $in_qw_comma_count;
my $last_new_seqno;
my %new_seqno_from_old_seqno;
my $last_ending_in_quote;
my $added_seqno_count;
sub initialize_write_line {
$nesting_depth = undef;
$initial_seqno = undef;
$last_seqno = SEQ_ROOT;
$last_new_seqno = SEQ_ROOT;
%saw_opening_seqno = ();
%saw_closing_seqno = ();
$in_qw_seqno = 0;
$in_qw_comma_count = 0; # b1491
%new_seqno_from_old_seqno = ();
$last_ending_in_quote = 0;
$added_seqno_count = 0;
return;
} ## end sub initialize_write_line
sub check_sequence_numbers {
# Routine for checking sequence numbers. This only needs to be
# done occasionally in DEVEL_MODE to be sure everything is working
# correctly.
my ( $rtokens, $rtoken_type, $rtype_sequence, $input_line_no ) = @_;
my $jmax = @{$rtokens} - 1;
return if ( $jmax < 0 );
foreach my $j ( 0 .. $jmax ) {
my $seqno = $rtype_sequence->[$j];
my $token = $rtokens->[$j];
my $type = $rtoken_type->[$j];
$seqno = EMPTY_STRING unless ( defined($seqno) );
my $err_msg =
"Error at j=$j, line number $input_line_no, seqno='$seqno', type='$type', tok='$token':\n";
if ( !$seqno ) {
# Sequence numbers are generated for opening tokens, so every opening
# token should be sequenced. Closing tokens will be unsequenced
# if they do not have a matching opening token.
if ( $is_opening_sequence_token{$token}
&& $type ne 'q'
&& $type ne 'Q' )
{
Fault(
<2 and may have gaps
if ( !defined($initial_seqno) ) {
$initial_seqno = $seqno;
# Be sure that sequence numbers start with 2. If not,
# there is a programming error in the tokenizer.
if ( $initial_seqno != 2 ) {
Fault(<[_rLL_];
my $line_of_tokens = {};
# copy common hash key values
@{$line_of_tokens}{@common_keys} =
@{$line_of_tokens_input}{@common_keys};
my $line_type = $line_of_tokens_input->{_line_type};
my $tee_output;
my $Klimit = $self->[_Klimit_];
my ( $Kfirst, $Klast );
# Handle line of non-code
if ( $line_type ne 'CODE' ) {
$tee_output ||= $rOpts_tee_pod
&& substr( $line_type, 0, 3 ) eq 'POD';
$line_of_tokens->{_level_0} = 0;
$line_of_tokens->{_ci_level_0} = 0;
$line_of_tokens->{_nesting_blocks_0} = EMPTY_STRING;
$line_of_tokens->{_nesting_tokens_0} = EMPTY_STRING;
$line_of_tokens->{_ended_in_blank_token} = undef;
}
# Handle line of code
else {
my $rtokens = $line_of_tokens_input->{_rtokens};
my $jmax = @{$rtokens} - 1;
if ( $jmax >= 0 ) {
$Kfirst = defined($Klimit) ? $Klimit + 1 : 0;
#----------------------------
# get the tokens on this line
#----------------------------
$self->write_line_inner_loop( $line_of_tokens_input,
$line_of_tokens );
# update Klimit for added tokens
$Klimit = @{$rLL} - 1;
$Klast = $Klimit;
} ## end if ( $jmax >= 0 )
else {
# blank line
$line_of_tokens->{_level_0} = 0;
$line_of_tokens->{_ci_level_0} = 0;
$line_of_tokens->{_nesting_blocks_0} = EMPTY_STRING;
$line_of_tokens->{_nesting_tokens_0} = EMPTY_STRING;
$line_of_tokens->{_ended_in_blank_token} = undef;
}
$tee_output ||=
$rOpts_tee_block_comments
&& $jmax == 0
&& $rLL->[$Kfirst]->[_TYPE_] eq '#';
$tee_output ||=
$rOpts_tee_side_comments
&& defined($Kfirst)
&& $Klimit > $Kfirst
&& $rLL->[$Klimit]->[_TYPE_] eq '#';
} ## end if ( $line_type eq 'CODE')
# Finish storing line variables
$line_of_tokens->{_rK_range} = [ $Kfirst, $Klast ];
$self->[_Klimit_] = $Klimit;
my $rlines = $self->[_rlines_];
push @{$rlines}, $line_of_tokens;
if ($tee_output) {
my $fh_tee = $self->[_fh_tee_];
my $line_text = $line_of_tokens_input->{_line_text};
$fh_tee->print($line_text) if ($fh_tee);
}
# We must use the old line because the qw logic may change this flag
$last_ending_in_quote = $line_of_tokens_input->{_ending_in_quote};
return;
} ## end sub write_line
sub qw_to_function {
my ( $self, $line_of_tokens, $is_ending_token ) = @_;
# This sub implements the -qwaf option:
# It is called for every type 'q' token which is part of a 'qw(' list.
# Essentially all of the coding for the '-qwaf' option is in this sub.
# Input parameters:
# $line_of_tokens = information hash for this line from the tokenizer,
# $is_ending_token = true if this qw does not extend to the next line
# Method:
# This qw token has already been pushed onto the output token stack, so
# we will pop it off and push on a sequence of tokens created by
# breaking it into an opening, a sequence of comma-separated quote
# items, and a closing paren. For multi-line qw quotes, there will be
# one call per input line until the end of the qw text is reached
# and processed.
# Note 1: A critical issue is to correctly generate and insert a new
# sequence number for the new parens into the sequence number stream.
# The new sequence number is the closure variable '$in_qw_seqno'. It
# is defined when the leading 'qw(' is seen, and is undefined when the
# closing ')' is output.
# Note 2: So far, no reason has been found to coordinate this logic
# with the logic which adds and deletes commas. We are adding trailing
# phantom commas here, except for a single list item, so no additional
# trailing comma should be added. And if a phantom trailing comma gets
# deleted, it should not matter because it does not get displayed.
my $rLL = $self->[_rLL_];
my $rSS = $self->[_rSS_];
my $rdepth_of_opening_seqno = $self->[_rdepth_of_opening_seqno_];
# Does this qw text spill over onto another line?
my $is_continued =
( $is_ending_token && $line_of_tokens->{_ending_in_quote} );
my $qw_text = $rLL->[-1]->[_TOKEN_];
my $qw_type = $rLL->[-1]->[_TYPE_];
my $qw_level = $rLL->[-1]->[_LEVEL_];
my $qw_text_start = $qw_text;
my $opening = EMPTY_STRING;
my $closing = EMPTY_STRING;
my $has_opening_space;
my $has_closing_space;
# the new word tokens are 1 level deeper than the original 'q' token
my $level_words = $qw_level + 1;
if ( $qw_type ne 'q' ) {
# This should never happen because the calling sub should have just
# pushed a token of type 'q' onto the token list.
my $lno = $line_of_tokens->{_line_number};
Fault("$lno: expecting type 'q' but got $qw_type");
return;
}
if ( !length($qw_text) ) {
# This seems to be an empty type 'q' token. A blank line within a
# qw quote is marked as a blank line rather than a blank 'q' token.
# So this should never happen.
my $lno = $line_of_tokens->{_line_number};
DEVEL_MODE && Fault("$lno: received empty type 'q' text\n");
return;
}
# remove leading 'qw(' if we are starting a new qw
if ( !$in_qw_seqno ) {
$opening = substr( $qw_text, 0, 3 );
if ( $opening ne 'qw(' ) {
# Caller should have checked this before calling
my $lno = $line_of_tokens->{_line_number};
DEVEL_MODE && Fault("$lno: unexpected qw opening: $opening\n");
return;
}
$qw_text = substr( $qw_text, 3 );
$has_opening_space = $qw_text =~ s/^\s+//;
# Do not use -qwaf under high stress (b1482,b1483,b1484,b1485,1486)
# Note: so far all known cases of stress instability have had -naws
# set, so this is included for now. It may eventually need to be
# removed.
# NOTE: The update for b1491 also fixes cases b1482-6 in a
# more general way, so this test can be deactivated.
if ( 0
&& !$rOpts_add_whitespace
&& $level_words >= $high_stress_level )
{
return;
}
}
# Look for and remove any closing ')'
if ( !$is_continued ) {
if ( length($qw_text) > 0 && substr( $qw_text, -1, 1 ) eq ')' ) {
$closing = substr( $qw_text, -1, 1 );
$qw_text = substr( $qw_text, 0, -1 );
$qw_text =~ s/\s+$//;
$has_closing_space = $qw_text =~ s/^\s+//;
}
else {
# We are at the end of a 'qw(' quote according to the
# tokenizer flag '_ending_in_quote', but there is no
# ending ')'. The '$is_continued' flag seems to be wrong.
my $lno = $line_of_tokens->{_line_number};
Fault(<{_line_number};
DEVEL_MODE && Fault(<[_K_opening_container_]->{$seqno} = @{$rLL};
$rdepth_of_opening_seqno->[$seqno] = $nesting_depth;
$nesting_depth++;
$self->[_rI_opening_]->[$seqno] = @{$rSS};
if ( $level_words > $self->[_maximum_level_] ) {
my $input_line_no = $line_of_tokens->{_line_number};
$self->[_maximum_level_] = $level_words;
$self->[_maximum_level_at_line_] = $input_line_no;
}
push @{$rSS}, $seqno;
# make and push the 'qw' token
my $rtoken_qw = copy_token_as_type( $rtoken_q, 'U', 'qw' );
push @{$rLL}, $rtoken_qw;
# make and push the '(' with the new sequence number
my $rtoken_opening = copy_token_as_type( $rtoken_q, '{', '(' );
$rtoken_opening->[_TYPE_SEQUENCE_] = $seqno;
push @{$rLL}, $rtoken_opening;
}
# All words must be followed by a comma except for an intact
# structure with a single word, like 'qw(hello)'
my $commas_needed =
!( ( $opening || !$in_qw_comma_count ) && $closing && @words == 1 );
# Make and push each word as a type 'Q' quote followed by a phantom
# comma. The phantom comma is type ',' and is processed
# exactly like any other comma, but it has an empty string as the token
# text, so the line will display as a regular qw quote.
if (@words) {
foreach my $word (@words) {
# always space after a comma; follow input spacing after '('
if ( $comma_count || $has_opening_space ) {
my $rtoken_space =
copy_token_as_type( $rtoken_q, 'b', SPACE );
$rtoken_space->[_LEVEL_] = $level_words;
push @{$rLL}, $rtoken_space;
}
# this quoted text
my $rtoken_word = copy_token_as_type( $rtoken_q, 'Q', $word );
$rtoken_word->[_LEVEL_] = $level_words;
push @{$rLL}, $rtoken_word;
# Add a comma if needed. NOTE on trailing commas:
# - For multiple words: Trailing commas must be added.
# Otherwise, -atc might put a comma in a qw list.
# - For single words: Trailing commas are not required, and
# are best avoided. This is because:
# - atc will not add commas to a list which has no commas
# - This will make the single-item spacing rule work as
# expected.
# - This will reduce the chance of instability (b1491)
if ($commas_needed) {
my $rtoken_comma =
copy_token_as_type( $rtoken_q, ',', EMPTY_STRING );
$rtoken_comma->[_LEVEL_] = $level_words;
push @{$rLL}, $rtoken_comma;
$comma_count++;
}
}
}
# make and push closing sequenced item ')'
if ($closing) {
# OPTIONAL: remove a previous comma if it is the only one. This can
# happen if this closing paren starts a new line and there was just
# one word in the qw list. The reason for doing this would be
# to avoid possible instability, but none is currently known. b1491.
# This has been tested but is currently inactive because it has not
# been found to be necessary.
if ( 0
&& !@words
&& $in_qw_comma_count == 1
&& $rLL->[-1]->[_TYPE_] eq ',' )
{
# It is simpler to convert it to a blank; otherwise it would
# be necessary to change the range [Kfirst,Klast] of the
# previous line and the current line.
$rLL->[-1]->[_TYPE_] = 'b';
}
# follow input spacing before ')'
if ($has_closing_space) {
my $rtoken_space = copy_token_as_type( $rtoken_q, 'b', SPACE );
$rtoken_space->[_LEVEL_] = $level_words;
push @{$rLL}, $rtoken_space;
}
my $seqno = $in_qw_seqno;
$self->[_K_closing_container_]->{$seqno} = @{$rLL};
$nesting_depth = $rdepth_of_opening_seqno->[$seqno];
$self->[_rI_closing_]->[$seqno] = @{$rSS};
push @{$rSS}, -1 * $seqno;
# make the ')'
my $rtoken_closing = copy_token_as_type( $rtoken_q, '}', ')' );
$rtoken_closing->[_TYPE_SEQUENCE_] = $in_qw_seqno;
push @{$rLL}, $rtoken_closing;
# all done with this qw list
$in_qw_seqno = 0;
$in_qw_comma_count = 0;
}
else {
$in_qw_comma_count += $comma_count;
}
# The '_ending_in_quote' flag for this line is no longer needed
if ($is_continued) { $line_of_tokens->{_ending_in_quote} = 0 }
return;
} ## end sub qw_to_function
sub write_line_inner_loop {
my ( $self, $line_of_tokens_old, $line_of_tokens ) = @_;
# Copy the tokens on one line received from the tokenizer to their new
# storage locations.
# Input parameters:
# $line_of_tokens_old = line received from tokenizer
# $line_of_tokens = line of tokens being formed for formatter
my $rtokens = $line_of_tokens_old->{_rtokens};
my $jmax = @{$rtokens} - 1;
if ( $jmax < 0 ) {
# safety check; shouldn't happen
my $lno = $line_of_tokens->{_line_number};
DEVEL_MODE && Fault("$lno: unexpected jmax=$jmax\n");
return;
}
my $line_index = $line_of_tokens_old->{_line_number} - 1;
my $rtoken_type = $line_of_tokens_old->{_rtoken_type};
my $rblock_type = $line_of_tokens_old->{_rblock_type};
my $rtype_sequence = $line_of_tokens_old->{_rtype_sequence};
my $rlevels = $line_of_tokens_old->{_rlevels};
my $rLL = $self->[_rLL_];
my $rSS = $self->[_rSS_];
my $rdepth_of_opening_seqno = $self->[_rdepth_of_opening_seqno_];
DEVEL_MODE
&& check_sequence_numbers( $rtokens, $rtoken_type,
$rtype_sequence, $line_index + 1 );
# Find the starting nesting depth ...
# It must be the value of variable 'level' of the first token
# because the nesting depth is used as a token tag in the
# vertical aligner and is compared to actual levels.
# So vertical alignment problems will occur with any other
# starting value.
if ( !defined($nesting_depth) ) {
$nesting_depth = $rlevels->[0];
$nesting_depth = 0 if ( $nesting_depth < 0 );
$rdepth_of_opening_seqno->[SEQ_ROOT] = $nesting_depth - 1;
}
# error check for -qwaf:
if ($in_qw_seqno) {
if ( $rtoken_type->[0] ne 'q' ) {
# -qwaf is expecting another 'q' token for multiline -qw
# based on the {_ending_in_quote} flag from the tokenizer
# of the previous line, but a 'q' didn't arrive.
my $lno = $line_index + 1;
Fault(
"$lno: -qwaf expecting qw continuation line but saw type '$rtoken_type->[0]'\n"
);
}
}
my $j = -1;
# NOTE: coding efficiency is critical in this loop over all tokens
foreach my $token ( @{$rtokens} ) {
# NOTE: Do not clip the 'level' variable yet if it is negative. We
# will do that 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. (A recent update will probably not even allow negative
# levels to arrive here any longer).
my @tokary;
# Handle tokens with sequence numbers ...
# note the ++ increment hidden here for efficiency
if ( $rtype_sequence->[ ++$j ] ) {
my $seqno_old = $rtype_sequence->[$j];
my $seqno = $seqno_old;
my $sign = 1;
if ( $is_opening_token{$token} ) {
if ($added_seqno_count) {
$seqno += $added_seqno_count;
$new_seqno_from_old_seqno{$seqno_old} = $seqno;
}
if ( DEVEL_MODE && $seqno != $last_new_seqno + 1 ) {
my $lno = $line_index + 1;
Fault("$lno: seqno=$seqno last=$last_new_seqno\n");
}
$last_new_seqno = $seqno;
$self->[_K_opening_container_]->{$seqno} = @{$rLL};
$rdepth_of_opening_seqno->[$seqno] = $nesting_depth;
$nesting_depth++;
# Save a sequenced block type at its opening token.
# Note that unsequenced block types can occur in
# unbalanced code with errors but are ignored here.
if ( $rblock_type->[$j] ) {
my $block_type = $rblock_type->[$j];
# Store the block type with sequence number as hash key
$self->[_rblock_type_of_seqno_]->{$seqno} = $block_type;
# and save anynymous subs and named subs in separate
# hashes to avoid future pattern tests
if ( $matches_ASUB{$block_type} ) {
$self->[_ris_asub_block_]->{$seqno} = 1;
}
# The pre-check on space speeds up this test:
elsif ($block_type =~ /\s/
&& $block_type =~ /$SUB_PATTERN/ )
{
$self->[_ris_sub_block_]->{$seqno} = 1;
}
else {
# not a sub type
}
}
}
elsif ( $is_closing_token{$token} ) {
if ($added_seqno_count) {
$seqno =
$new_seqno_from_old_seqno{$seqno_old} || $seqno_old;
}
# The opening depth should always be defined, and
# it should equal $nesting_depth-1. To protect
# against unforeseen error conditions, however, we
# will check this and fix things if necessary. For
# a test case see issue c055.
my $opening_depth = $rdepth_of_opening_seqno->[$seqno];
if ( !defined($opening_depth) ) {
$opening_depth = $nesting_depth - 1;
$opening_depth = 0 if ( $opening_depth < 0 );
$rdepth_of_opening_seqno->[$seqno] = $opening_depth;
# This is not fatal but should not happen. The
# tokenizer generates sequence numbers
# incrementally upon encountering each new
# opening token, so every positive sequence
# number should correspond to an opening token.
my $lno = $line_index + 1;
DEVEL_MODE && Fault(<[_K_closing_container_]->{$seqno} = @{$rLL};
$nesting_depth = $opening_depth;
$sign = -1;
}
elsif ( $token eq '?' ) {
if ($added_seqno_count) {
$seqno += $added_seqno_count;
$new_seqno_from_old_seqno{$seqno_old} = $seqno;
}
if ( DEVEL_MODE && $seqno != $last_new_seqno + 1 ) {
my $lno = $line_index + 1;
Fault("$lno: seqno=$seqno last=$last_new_seqno\n");
}
$last_new_seqno = $seqno;
$self->[_K_opening_ternary_]->{$seqno} = @{$rLL};
}
elsif ( $token eq ':' ) {
if ($added_seqno_count) {
$seqno =
$new_seqno_from_old_seqno{$seqno_old} || $seqno_old;
}
$sign = -1;
$self->[_K_closing_ternary_]->{$seqno} = @{$rLL};
}
# The only sequenced types output by the tokenizer are
# the opening & closing containers and the ternary
# types. So we would only get here if the tokenizer has
# been changed to mark some other tokens with sequence
# numbers, or if an error has been introduced in a
# hash such as %is_opening_container
else {
my $lno = $line_index + 1;
DEVEL_MODE && Fault(<[$j]', sequence=$seqno arrived from tokenizer.
Expecting only opening or closing container tokens or ternary tokens with sequence numbers.
EOM
}
if ( $sign > 0 ) {
$self->[_rI_opening_]->[$seqno] = @{$rSS};
# For efficiency, we find the maximum level of
# opening tokens of any type. The actual maximum
# level will be that of their contents which is 1
# greater. That will be fixed in sub
# 'finish_formatting'.
my $level = $rlevels->[$j];
if ( $level > $self->[_maximum_level_] ) {
$self->[_maximum_level_] = $level;
$self->[_maximum_level_at_line_] = $line_index + 1;
}
}
else { $self->[_rI_closing_]->[$seqno] = @{$rSS} }
push @{$rSS}, $sign * $seqno;
$tokary[_TYPE_SEQUENCE_] = $seqno;
}
else {
$tokary[_TYPE_SEQUENCE_] = EMPTY_STRING;
}
# Here we are storing the first five variables per token. The
# remaining token variables will be added later as follows:
# _TOKEN_LENGTH_ is added by sub store_token
# _CUMULATIVE_LENGTH_ is added by sub store_token
# _CI_LEVEL_ is added by sub set_ci
# So all token variables are available for use after sub set_ci.
$tokary[_TOKEN_] = $token;
$tokary[_TYPE_] = $rtoken_type->[$j];
$tokary[_LEVEL_] = $rlevels->[$j];
$tokary[_LINE_INDEX_] = $line_index;
push @{$rLL}, \@tokary;
# handle -qwaf option for converting a qw quote (type = 'q') to
# function call
if (
$rOpts_qw_as_function
&& $rtoken_type->[$j] eq 'q'
&& (
# continuing in a qw?
$in_qw_seqno
# starting a new qw?
|| ( ( $j > 0 || !$last_ending_in_quote )
&& substr( $token, 0, 3 ) eq 'qw(' )
)
)
{
$self->qw_to_function( $line_of_tokens, $j == $jmax );
}
} ## end token loop
# Need to remember if we can trim the input line
$line_of_tokens->{_ended_in_blank_token} = $rtoken_type->[$jmax] eq 'b';
# Values needed by Logger if a logfile is saved:
if ( $self->[_save_logfile_] ) {
$line_of_tokens->{_level_0} = $rlevels->[0];
$line_of_tokens->{_ci_level_0} = 0; # fix later
$line_of_tokens->{_nesting_blocks_0} =
$line_of_tokens_old->{_nesting_blocks_0};
$line_of_tokens->{_nesting_tokens_0} =
$line_of_tokens_old->{_nesting_tokens_0};
}
return;
} ## end sub write_line_inner_loop
} ## end closure write_line
#############################################
# CODE SECTION 5: Pre-process the entire file
#############################################
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.
# Given:
# $severe_error = true if a severe error was encountered
# Returns:
# true if input file was copied verbatim due to errors
# false otherwise
# Some of the code in sub break_lists is not robust enough to process code
# with arbitrary brace errors. The simplest fix is to just return the file
# verbatim if there are brace errors. This fixes issue c160.
$severe_error ||= get_saw_brace_error();
# Check the maximum level. If it is extremely large we will give up and
# output the file verbatim. Note that the actual maximum level is 1
# greater than the saved value, so we fix that here.
$self->[_maximum_level_] += 1;
my $maximum_level = $self->[_maximum_level_];
my $maximum_table_index = $#maximum_line_length_at_level;
if ( !$severe_error && $maximum_level >= $maximum_table_index ) {
$severe_error ||= 1;
Warn(<{notidy} ) {
$self->dump_verbatim();
$self->wrapup($severe_error);
return 1;
}
{
my $rix_side_comments = $self->set_CODE_type();
$self->find_non_indenting_braces($rix_side_comments);
# Handle any requested side comment deletions. It is easier to get
# this done here rather than farther down the pipeline because IO
# lines take a different route, and because lines with deleted HSC
# become BL lines. We have already handled any tee requests in sub
# getline, so it is safe to delete side comments now.
$self->delete_side_comments($rix_side_comments)
if ( $rOpts_delete_side_comments
|| $rOpts_delete_closing_side_comments );
}
# Verify that the line hash does not have any unknown keys.
$self->check_line_hashes() if (DEVEL_MODE);
$self->interbracket_arrow_check();
{
# 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.
my ( $error, $rqw_lines ) = $self->respace_tokens();
if ($error) {
$self->dump_verbatim();
$self->wrapup();
return 1;
}
# sub 'set_ci' is called after sub respace to allow use of type counts
# Token variable _CI_LEVEL_ is only defined after this call
$self->set_ci();
$self->find_multiline_qw($rqw_lines);
}
# Dump unique hash keys
if ( $rOpts->{'dump-unique-keys'} ) {
$self->dump_unique_keys();
Exit(0);
}
# Dump any requested block summary data
if ( $rOpts->{'dump-block-summary'} ) {
$self->dump_block_summary();
Exit(0);
}
# Dump variable usage info if requested
if ( $rOpts->{'dump-unusual-variables'} ) {
$self->dump_unusual_variables();
Exit(0);
}
# Act on -warn-variable-types if requested and the logger is available
# (the logger is deactivated during iterations)
$self->warn_variable_types()
if ( %{$rwarn_variable_types}
&& $self->[_logger_object_] );
if ( $rOpts->{'warn-mismatched-args'}
|| $rOpts->{'warn-mismatched-returns'} )
{
$self->warn_mismatched()
if ( $self->[_logger_object_] );
}
if ( $rOpts->{'dump-mismatched-args'} ) {
$self->dump_mismatched_args();
Exit(0);
}
if ( $rOpts->{'dump-mismatched-returns'} ) {
$self->dump_mismatched_returns();
Exit(0);
}
if ( $rOpts->{'dump-mixed-call-parens'} ) {
$self->dump_mixed_call_parens();
Exit(0);
}
# Act on -want-call-parens and --nowant-call-parens requested and the
# logger is available (the logger is deactivated during iterations)
$self->scan_call_parens()
if ( %call_paren_style
&& $self->[_logger_object_] );
$self->examine_vertical_tightness_flags();
$self->set_excluded_lp_containers();
$self->keep_old_line_breaks();
# Implement any welding needed for the -wn or -cb options
$self->weld_containers();
# Collect info needed to implement the -xlp style
$self->xlp_collapsed_lengths()
if ( $rOpts_line_up_parentheses && $rOpts_extended_line_up_parentheses );
# Locate small nested blocks which should not be broken
$self->mark_short_nested_blocks();
$self->special_indentation_adjustments();
# Verify that the main token array looks OK. If this ever causes a fault
# then place similar checks before the sub calls above to localize the
# problem.
$self->check_rLL("Before 'process_all_lines'") if (DEVEL_MODE);
# 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 final routine to tie up any loose ends
$self->wrapup();
return;
} ## end sub finish_formatting
my %is_loop_type;
BEGIN {
my @q = qw( for foreach while do until );
@is_loop_type{@q} = (1) x scalar(@q);
}
sub find_level_info {
my ($self) = @_;
# Find level ranges and total variations of all code blocks in this file.
# Returns:
# ref to hash with block info, with seqno as key (see below)
# The array _rSS_ has the complete container tree for this file.
my $rSS = $self->[_rSS_];
# We will be ignoring everything except code block containers
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my @stack;
my %level_info;
# TREE_LOOP:
foreach my $sseq ( @{$rSS} ) {
my $stack_depth = @stack;
my $seq_next = $sseq > 0 ? $sseq : -$sseq;
next if ( !$rblock_type_of_seqno->{$seq_next} );
if ( $sseq > 0 ) {
# STACK_LOOP:
my $item;
foreach my $seq (@stack) {
$item = $level_info{$seq};
if ( $item->{maximum_depth} < $stack_depth ) {
$item->{maximum_depth} = $stack_depth;
}
$item->{block_count}++;
} ## end STACK LOOP
push @stack, $seq_next;
my $block_type = $rblock_type_of_seqno->{$seq_next};
# If this block is a loop nested within a loop, then we
# will mark it as an 'inner_loop'. This is a useful
# complexity measure.
my $is_inner_loop = 0;
if ( $is_loop_type{$block_type} && defined($item) ) {
$is_inner_loop = $is_loop_type{ $item->{block_type} };
}
$level_info{$seq_next} = {
starting_depth => $stack_depth,
maximum_depth => $stack_depth,
block_count => 1,
block_type => $block_type,
is_inner_loop => $is_inner_loop,
};
}
else {
my $seq_test = pop @stack;
# error check
if ( $seq_test != $seq_next ) {
# Shouldn't happen - the $rSS array must have an error
DEVEL_MODE && Fault("stack error finding total depths\n");
%level_info = ();
last;
}
}
} ## end TREE_LOOP
return \%level_info;
} ## end sub find_level_info
sub find_loop_label {
my ( $self, $seqno ) = @_;
# Given:
# $seqno = sequence number of a block of code for a loop
# Return:
# $label = the loop label text, if any, or an empty string
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $K_opening_container = $self->[_K_opening_container_];
my $label = EMPTY_STRING;
my $K_opening = $K_opening_container->{$seqno};
# backup to the line with the opening paren, if any, in case the
# keyword is on a different line
my $Kp = $self->K_previous_code($K_opening);
return $label unless ( defined($Kp) );
if ( $rLL->[$Kp]->[_TOKEN_] eq ')' ) {
$seqno = $rLL->[$Kp]->[_TYPE_SEQUENCE_];
$K_opening = $K_opening_container->{$seqno};
}
return $label unless ( defined($K_opening) );
my $lx_open = $rLL->[$K_opening]->[_LINE_INDEX_];
# look for a label within a few lines; allow a couple of blank lines
foreach my $lx ( reverse( $lx_open - 3 .. $lx_open ) ) {
last if ( $lx < 0 );
my $line_of_tokens = $rlines->[$lx];
my $line_type = $line_of_tokens->{_line_type};
# stop search on a non-code line
last if ( $line_type ne 'CODE' );
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast_uu ) = @{$rK_range};
# skip a blank line
next if ( !defined($Kfirst) );
# check for a label
if ( $rLL->[$Kfirst]->[_TYPE_] eq 'J' ) {
$label = $rLL->[$Kfirst]->[_TOKEN_];
last;
}
# quit the search if we are above the starting line
last if ( $lx < $lx_open );
}
return $label;
} ## end sub find_loop_label
{ ## closure find_mccabe_count
my %is_mccabe_logic_keyword;
my %is_mccabe_logic_operator;
BEGIN {
my @q = (qw( && || ||= &&= ? <<= >>= ));
@is_mccabe_logic_operator{@q} = (1) x scalar(@q);
@q = (qw( and or xor if else elsif unless until while for foreach ));
@is_mccabe_logic_keyword{@q} = (1) x scalar(@q);
} ## end BEGIN
sub find_mccabe_count {
my ($self) = @_;
# Find the cumulative mccabe count to each token
# Return '$rmccabe_count_sum' = ref to array with cumulative
# mccabe count to each token $K
# NOTE: This sub currently follows the definitions in Perl::Critic
my $rmccabe_count_sum;
my $rLL = $self->[_rLL_];
my $count = 0;
my $Klimit = $self->[_Klimit_];
foreach my $KK ( 0 .. $Klimit ) {
$rmccabe_count_sum->{$KK} = $count;
my $type = $rLL->[$KK]->[_TYPE_];
if ( $type eq 'k' ) {
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $is_mccabe_logic_keyword{$token} ) { $count++ }
}
else {
if ( $is_mccabe_logic_operator{$type} ) {
$count++;
}
}
}
$rmccabe_count_sum->{ $Klimit + 1 } = $count;
return $rmccabe_count_sum;
} ## end sub find_mccabe_count
} ## end closure find_mccabe_count
sub find_code_line_count {
my ($self) = @_;
# Find the cumulative number of lines of code, excluding blanks,
# comments and pod.
# Return '$rcode_line_count' = ref to array with cumulative
# code line count for each input line number.
my $rcode_line_count;
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $ix_line = -1;
my $code_line_count = 0;
# loop over all lines
foreach my $line_of_tokens ( @{$rlines} ) {
$ix_line++;
# what type of line?
my $line_type = $line_of_tokens->{_line_type};
# if 'CODE' it must be non-blank and non-comment
if ( $line_type eq 'CODE' ) {
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
if ( defined($Kfirst) ) {
# it is non-blank
my $jmax = defined($Kfirst) ? $Klast - $Kfirst : -1;
if ( $jmax > 0 || $rLL->[$Klast]->[_TYPE_] ne '#' ) {
# ok, it is a non-comment
$code_line_count++;
}
}
}
# Count all other special line types except pod;
# For a list of line types see sub 'process_all_lines'
else {
if ( $line_type !~ /^POD/ ) { $code_line_count++ }
}
# Store the cumulative count using the input line index
$rcode_line_count->[$ix_line] = $code_line_count;
}
return $rcode_line_count;
} ## end sub find_code_line_count
sub find_selected_packages {
my ( $self, $rdump_block_types ) = @_;
# Returns a list of all selected package statements in a file for use
# in dumping block information.
if ( !$rdump_block_types->{'*'}
&& !$rdump_block_types->{'package'}
&& !$rdump_block_types->{'class'} )
{
return [];
}
# Find all 'package' tokens in the file
my $rLL = $self->[_rLL_];
my @K_package_list;
foreach my $KK ( 0 .. @{$rLL} - 1 ) {
next if ( $rLL->[$KK]->[_TYPE_] ne 'P' );
push @K_package_list, $KK;
}
# Get the information needed for the block dump
my $rpackage_lists = $self->package_info_maker( \@K_package_list );
my $rpackage_info_list = $rpackage_lists->{'rpackage_info_list'};
# Remove the first item in the info list, which is a dummy package main
shift @{$rpackage_info_list};
# Remove BLOCK format packages since they get reported as blocks separately
my @filtered_list = grep { !$_->{is_block} } @{$rpackage_info_list};
return \@filtered_list;
} ## end sub find_selected_packages
sub find_selected_blocks {
my ( $self, $rdump_block_types, $rlevel_info ) = @_;
# Find blocks needed for --dump-block-summary
# Given:
# $rdump_block_types = hash of user selected block types
# $rlevel_info = info on max depth of blocks
# Returns:
# $rslected_blocks = ref to a list of information on the selected blocks
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $ris_asub_block = $self->[_ris_asub_block_];
my $ris_sub_block = $self->[_ris_sub_block_];
my $dump_all_types = $rdump_block_types->{'*'};
my @selected_blocks;
#---------------------------------------------------
# BEGIN loop over all blocks to find selected blocks
#---------------------------------------------------
foreach my $seqno ( keys %{$rblock_type_of_seqno} ) {
my $type;
my $name = EMPTY_STRING;
my $block_type = $rblock_type_of_seqno->{$seqno};
my $K_opening = $K_opening_container->{$seqno};
my $K_closing = $K_closing_container->{$seqno};
my $level = $rLL->[$K_opening]->[_LEVEL_];
my $lx_open = $rLL->[$K_opening]->[_LINE_INDEX_];
my $line_of_tokens = $rlines->[$lx_open];
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
if ( !defined($Kfirst) || !defined($Klast) || $Kfirst > $K_opening ) {
my $line_type = $line_of_tokens->{_line_type};
# shouldn't happen
my $CODE_type = $line_of_tokens->{_code_type};
DEVEL_MODE && Fault(<{$seqno};
if ( defined($item) ) {
my $starting_depth = $item->{starting_depth};
my $maximum_depth = $item->{maximum_depth};
$block_count = $item->{block_count};
$max_change = $maximum_depth - $starting_depth + 1;
# this is a '+' character if this block is an inner loops
$inner_loop_plus = $item->{is_inner_loop} ? '+' : EMPTY_STRING;
}
# Skip closures unless type 'closure' is explicitly requested
if ( ( $block_type eq '}' || $block_type eq ';' )
&& $rdump_block_types->{'closure'} )
{
$type = 'closure';
}
# Both 'sub' and 'asub' select an anonymous sub.
# This allows anonymous subs to be explicitly selected
elsif (
$ris_asub_block->{$seqno}
&& ( $dump_all_types
|| $rdump_block_types->{'sub'}
|| $rdump_block_types->{'asub'} )
)
{
$type = 'asub';
# Look back to try to find some kind of name, such as
# my $var = sub { - var is type 'i'
# var => sub { - var is type 'w'
# -var => sub { - var is type 'w'
# 'var' => sub { - var is type 'Q'
my ( $saw_equals, $saw_fat_comma, $blank_count );
foreach my $KK ( reverse( $Kfirst .. $K_opening - 1 ) ) {
my $token_type = $rLL->[$KK]->[_TYPE_];
if ( $token_type eq 'b' ) { $blank_count++; next }
if ( $token_type eq '=>' ) { $saw_fat_comma++; next }
if ( $token_type eq '=' ) { $saw_equals++; next }
if ( $token_type eq 'i' && $saw_equals
|| ( $token_type eq 'w' || $token_type eq 'Q' )
&& $saw_fat_comma )
{
$name = $rLL->[$KK]->[_TOKEN_];
last;
}
}
my $rarg = { seqno => $seqno };
$self->count_sub_input_args($rarg);
my $count = $rarg->{shift_count_min};
if ( !defined($count) ) { $count = '*' }
$type .= '(' . $count . ')';
}
elsif ( $ris_sub_block->{$seqno}
&& ( $dump_all_types || $rdump_block_types->{'sub'} ) )
{
$type = 'sub';
# what we want:
# $block_type $name
# 'sub setidentifier($)' => 'setidentifier'
# 'method setidentifier($)' => 'setidentifier'
my @parts = split /\s+/, $block_type;
$name = $parts[1];
$name =~ s/\(.*$//;
my $rarg = { seqno => $seqno };
$self->count_sub_input_args($rarg);
my $count = $rarg->{shift_count_min};
if ( !defined($count) ) { $count = '*' }
$type .= '(' . $count . ')';
}
elsif (
$block_type =~ /^(package|class)\b/
&& ( $dump_all_types
|| $rdump_block_types->{'package'}
|| $rdump_block_types->{'class'} )
)
{
$type = 'class';
my @parts = split /\s+/, $block_type;
$name = $parts[1];
$name =~ s/\(.*$//;
}
elsif (
$is_loop_type{$block_type}
&& ( $dump_all_types
|| $rdump_block_types->{$block_type}
|| $rdump_block_types->{ $block_type . $inner_loop_plus }
|| $rdump_block_types->{$inner_loop_plus} )
)
{
$type = $block_type . $inner_loop_plus;
}
elsif ( $dump_all_types || $rdump_block_types->{$block_type} ) {
if ( $is_loop_type{$block_type} ) {
$name = $self->find_loop_label($seqno);
}
$type = $block_type;
}
else {
next;
}
push @selected_blocks,
{
K_opening => $K_opening,
K_closing => $K_closing,
line_start => $lx_open + 1,
name => $name,
type => $type,
level => $level,
max_change => $max_change,
block_count => $block_count,
};
} ## END loop to get info for selected blocks
return \@selected_blocks;
} ## end sub find_selected_blocks
sub find_if_chains {
my ( $self, $rdump_block_types, $rlevel_info ) = @_;
# Find if-chains for --dump-block-summary
# Given:
# $rdump_block_types = ref to hash with user block type selections
# $rlevel_info = info on max depth of blocks
# Returns:
# $rslected_blocks = ref to a list of information on the selected blocks
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
# For example, 'elsif4' means all if-chains with 4 or more 'elsif's
my @selected_blocks;
# See if user requested any if-chains
# allow 'elsif3' or 'elsif+3'
my @elsif_d = grep { /^elsif\+?\d+$/ } keys %{$rdump_block_types};
if ( !@elsif_d ) { return \@selected_blocks }
# In case of multiple selections, use the minimum
my $elsif_count_min;
foreach my $word (@elsif_d) {
if ( $word =~ /(\d+)$/ ) {
my $num = $1;
if ( !defined($elsif_count_min) || $elsif_count_min > $num ) {
$elsif_count_min = $num;
}
}
}
# Loop over blocks
foreach my $seqno ( keys %{$rblock_type_of_seqno} ) {
my $block_type = $rblock_type_of_seqno->{$seqno};
# Must be 'if' or 'unless'
next unless ( $block_type eq 'if' || $block_type eq 'unless' );
# Collect info for this if-chain
my $rif_chain =
$self->follow_if_chain( $seqno, $rlevel_info, $elsif_count_min );
next unless ($rif_chain);
push @selected_blocks, $rif_chain;
}
return \@selected_blocks;
} ## end sub find_if_chains
sub follow_if_chain {
my ( $self, $seqno_if, $rlevel_info, $elsif_count_min ) = @_;
# Follow a chain of if-elsif-elsif-...-else blocks.
# Given:
# $seqno_if = sequence number of an 'if' block
# $rlevel_info = hash of block level information
# $elsif_min_count = minimum number of 'elsif' blocks wanted
# Return:
# nothing if number of 'elsif' blocks is less than $elsif_count_min
# ref to block info hash otherwise
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
# Verify that seqno is an 'if' or 'unless'
my $block_type = $rblock_type_of_seqno->{$seqno_if};
if ( $block_type ne 'if' && $block_type ne 'unless' ) {
Fault(
"Bad call: expecting block type 'if' or 'unless' but got '$block_type' for seqno=$seqno_if\n"
);
return;
}
# save sequence numbers in the chain for debugging
my @seqno_list;
# Loop to follow the chain
my $max_change = 0;
my $block_count = 0;
my $elsif_count = 0;
# we are tracing the sequence numbers of consecutive if/elsif/else blocks
my $seqno = $seqno_if;
while ($seqno) {
push @seqno_list, $seqno;
# Update info for this block
$block_type = $rblock_type_of_seqno->{$seqno};
if ( $block_type eq 'elsif' ) { $elsif_count++ }
my $item = $rlevel_info->{$seqno};
if ( defined($item) ) {
my $starting_depth = $item->{starting_depth};
my $maximum_depth = $item->{maximum_depth};
$block_count += $item->{block_count};
my $mxc = $maximum_depth - $starting_depth + 1;
if ( $mxc > $max_change ) { $max_change = $mxc }
}
# Chain ends if this is an 'else' block
last if ( $block_type eq 'else' );
# Look at the token following the closing brace
my $Kc = $K_closing_container->{$seqno};
my $K_k = $self->K_next_code($Kc);
last unless defined($K_k);
my $type_k = $rLL->[$K_k]->[_TYPE_];
my $token_k = $rLL->[$K_k]->[_TOKEN_];
# Chain ends unless we arrive at keyword 'elsif' or 'else'
last
unless ( $type_k eq 'k'
&& ( $token_k eq 'elsif' || $token_k eq 'else' ) );
# Handle keyword 'else' : next token be the opening block brace
if ( $token_k eq 'else' ) {
# } else {
# ^ ^ ^
# Kc | |
# K_k Ko
my $Ko = $self->K_next_code($K_k);
last unless defined($Ko);
$seqno = $rLL->[$Ko]->[_TYPE_SEQUENCE_];
if ( $seqno && $rblock_type_of_seqno->{$seqno} eq 'else' ) {
next;
}
# Shouldn't happen unless file has an error
last;
}
# Handle keyword 'elsif':
# } elsif ( $something ) {
# ^ ^ ^ ^ ^
# Kc | | | |
# K_k Kpo Kpc Ko
# hop over the elsif parens
my $kpo = $self->K_next_code($K_k);
last unless defined($kpo);
my $seqno_p = $rLL->[$kpo]->[_TYPE_SEQUENCE_];
last unless ( $seqno_p && $rLL->[$kpo]->[_TOKEN_] eq '(' );
my $Kpc = $K_closing_container->{$seqno_p};
last unless defined($Kpc);
# should be at the opening elsif brace
my $Ko = $self->K_next_code($Kpc);
last unless defined($Ko);
$seqno = $rLL->[$Ko]->[_TYPE_SEQUENCE_];
if ( $seqno && $rblock_type_of_seqno->{$seqno} eq 'elsif' ) {
next;
}
# Shouldn't happen unless file has an error
last;
} ## end while ($seqno)
# check count
return if ( $elsif_count < $elsif_count_min );
# Store the chain
my $K_opening = $K_opening_container->{$seqno_if};
my $K_closing = $K_closing_container->{$seqno};
my $lx_open = $rLL->[$K_opening]->[_LINE_INDEX_];
my $level = $rLL->[$K_opening]->[_LEVEL_];
my $rchain = {
K_opening => $K_opening,
K_closing => $K_closing,
line_start => $lx_open + 1,
name => "elsif+$elsif_count",
type => "if-chain",
level => $level,
max_change => $max_change,
block_count => $block_count,
};
return $rchain;
} ## end sub follow_if_chain
sub dump_unique_keys {
my ($self) = @_;
# Implement --dump-unique-keys, -duk
# Dump a list of hash keys used just one time
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
# stack holds [$seqno, $KK, $KK_last_nb]
my @stack;
my $KK = -1;
my $KK_last_nb;
my $KK_this_nb = 0;
my $K_end_skip = -1;
#----------------------------------------------
# Main loop to examine all hash keys and quotes
#----------------------------------------------
my @Q_list;
my @K_start_qw_list;
my $rwords = {};
# Table of some known keys
my %is_known_key = (
ALRM => { '$SIG' => 1 },
TERM => { '$SIG' => 1 },
INT => { '$SIG' => 1 },
__DIE__ => { '$SIG' => 1 },
__WARN__ => { '$SIG' => 1 },
HOME => { '$ENV' => 1 },
USER => { '$ENV' => 1 },
LOGNAME => { '$ENV' => 1 },
PATH => { '$ENV' => 1 },
SHELL => { '$ENV' => 1 },
PERL5LIB => { '$ENV' => 1 },
PERLLIB => { '$ENV' => 1 },
);
my $add_known_keys = sub {
my ( $rhash, $name ) = @_;
foreach my $key ( keys %{$rhash} ) {
if ( !defined( $is_known_key{$key} ) ) {
$is_known_key{$key} = { $name => 1 };
}
else {
$is_known_key{$key}->{$name} = 1;
}
}
}; ## end $add_known_keys = sub
# Add keys which may be unique to this environment.
$add_known_keys->( \%SIG, '$SIG' );
$add_known_keys->( \%ENV, '$ENV' );
$add_known_keys->( \%ERRNO, '$!' );
my $is_known_hash = sub {
my ($key) = @_;
# Given a hash key '$key',
# Return:
# true if it is known and should be excluded
# false if it is not known
my $rhash_names = $is_known_key{$key};
return if ( !$rhash_names );
# The key is known, now see if its hash name is known
return if ( !@stack );
my $Kbrace = $stack[-1]->[1];
my $Khash = $stack[-1]->[2];
return if ( !defined($Kbrace) );
return if ( !defined($Khash) );
return if ( $rLL->[$Kbrace]->[_TYPE_] ne 'L' );
my $hash_name = $rLL->[$Khash]->[_TOKEN_];
return if ( !$rhash_names->{$hash_name} );
return 1;
}; ## end $is_known_hash = sub
my $push_KK_last_nb = sub {
# if the previous nonblank token was a hash key of type
# 'Q' or 'w', then update its count
# We are ignoring constant definitions
if ( $KK < $K_end_skip ) { return }
my $type_last = $rLL->[$KK_last_nb]->[_TYPE_];
my $token_last = $rLL->[$KK_last_nb]->[_TOKEN_];
my $word;
if ( $type_last eq 'w' ) {
$word = $token_last;
}
elsif ( $type_last eq 'Q' ) {
$word = substr( $token_last, 1, -1 );
# Ignore text with interpolated values
my $ch0 = substr( $token_last, 0, 1 );
if ( $ch0 eq '"' ) {
foreach my $sigil ( '$', '@' ) {
my $pos = index( $word, $sigil );
next if ( $pos < 0 );
return if ( $pos == 0 );
my $ch_test = substr( $word, $pos - 1, 1 );
return if ( $ch_test ne '\\' );
}
}
pop @Q_list;
}
else {
# not a quote - possibly identifier
return;
}
return unless ($word);
# Bump count of known keys by 1 so that they will not appear as unique
my $one = 1;
if ( $is_known_key{$word} && $is_known_hash->($word) ) { $one++ }
if ( !defined( $rwords->{$word} ) ) {
$rwords->{$word} = [ $one, $KK_last_nb ];
}
else {
$rwords->{$word}->[0]++;
}
return;
}; ## end $push_KK_last_nb = sub
#--------------------------
# Main loop over all tokens
#--------------------------
while ( ++$KK <= $Klimit ) {
my $type = $rLL->[$KK]->[_TYPE_];
next if ( $type eq 'b' );
next if ( $type eq '#' );
$KK_last_nb = $KK_this_nb;
$KK_this_nb = $KK;
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($seqno) {
if ( $is_opening_type{$type} ) {
if ( $type eq 'L' ) {
# Skip past something like ${word}
if ( $KK_last_nb && $rLL->[$KK_last_nb]->[_TYPE_] eq 't' ) {
my $Kc = $K_closing_container->{$seqno};
my $Kn = $self->K_next_code($KK);
$Kn = $self->K_next_code($Kn);
if ( $Kn && $Kc && $Kn == $Kc && $Kc > $K_end_skip ) {
$K_end_skip = $Kc;
}
}
}
push @stack, [ $seqno, $KK, $KK_last_nb ];
}
elsif ( $is_closing_type{$type} ) {
if ( $type eq 'R' ) {
# require a single item within the hash braces
my $Ko = $K_opening_container->{$seqno};
my $Kn = $self->K_next_code($Ko);
if ( defined($Kn) && $Kn == $KK_last_nb ) {
$push_KK_last_nb->();
}
}
my $item = pop @stack;
if ( !$item || $item->[0] != $seqno ) {
if (DEVEL_MODE) {
# shouldn't happen for a balanced file
my $num = @stack;
my $got = $num ? $item->[0] : 'undef';
my $lno = $rLL->[$KK]->[_LINE_INDEX_];
Fault <' ) {
my $parent_seqno = $self->parent_seqno_by_K($KK);
if ( $parent_seqno && $ris_list_by_seqno->{$parent_seqno} ) {
$push_KK_last_nb->();
}
}
elsif ( $type eq 'Q' ) {
push @Q_list, $KK;
}
elsif ( $type eq 'q' ) {
if ( !defined($KK_last_nb)
|| $rLL->[$KK_last_nb]->[_TYPE_] ne 'q' )
{
push @K_start_qw_list, $KK;
}
}
elsif ( $type eq 'k' ) {
# Look for 'use constant' and define its ending token
if ( $rLL->[$KK]->[_TOKEN_] eq 'use' ) {
my $Kn = $self->K_next_code($KK);
next if ( !defined($Kn) );
next if ( $rLL->[$Kn]->[_TOKEN_] ne 'constant' );
$Kn = $self->K_next_code($Kn);
next if ( !defined($Kn) );
my $seqno_n = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
if ($seqno_n) {
# skip a block of constant definitions
my $token_n = $rLL->[$Kn]->[_TOKEN_];
if ( $token_n eq '{' ) {
$K_end_skip = $K_closing_container->{$seqno_n};
}
else {
## unexpected format, skip
}
}
else {
# skip a single constant definition
$K_end_skip = $Kn + 1;
}
}
}
else {
# continue search
}
}
} ## end while ( ++$KK <= $Klimit )
# find hash keys seen just one time
my %unique_words;
foreach my $key ( keys %{$rwords} ) {
my ( $count, $K ) = @{ $rwords->{$key} };
next if ( $count != 1 );
$unique_words{$key} = $K;
}
return if ( !%unique_words );
# check each unique word against the list of type Q tokens
if (@Q_list) {
my $imax = $#Q_list;
foreach my $i ( 0 .. $imax ) {
# Ignore multiline quotes
my $K = $Q_list[$i];
if ( ( $i == 0 || $Q_list[ $i - 1 ] + 1 != $K )
&& ( $i == $imax || $Q_list[ $i + 1 ] != $K + 1 ) )
{
# remove quotes
my $word = substr( $rLL->[$K]->[_TOKEN_], 1, -1 );
if ( $unique_words{$word} ) {
delete $unique_words{$word};
}
}
}
}
return if ( !%unique_words );
# Remove any keys which are also in a qw list
foreach my $Kqw (@K_start_qw_list) {
my ( $K_last_q_uu, $rlist ) = $self->get_qw_list($Kqw);
foreach my $word ( @{$rlist} ) {
if ( $unique_words{$word} ) {
delete $unique_words{$word};
}
}
}
return if ( !%unique_words );
# report unique words
my $output_string = EMPTY_STRING;
my @list;
foreach my $word ( keys %unique_words ) {
my $K = $unique_words{$word};
my $lno = $rLL->[$K]->[_LINE_INDEX_] + 1;
push @list, [ $word, $lno ];
}
@list = sort { $a->[1] <=> $b->[1] || $a->[0] cmp $b->[0] } @list;
foreach my $item (@list) {
my ( $word, $lno ) = @{$item};
$output_string .= "$word,$lno\n";
}
if ($output_string) {
my $input_stream_name = get_input_stream_name();
chomp $output_string;
print {*STDOUT} < $input_stream_name <==
$output_string
EOM
}
return;
} ## end sub dump_unique_keys
sub dump_block_summary {
my ($self) = @_;
# Dump information about selected code blocks to STDOUT
# This sub is called when
# --dump-block-summary (-dbs) is set.
# The following controls are available:
# --dump-block-types=s (-dbt=s), where s is a list of block types
# (if else elsif for foreach while do ... sub) ; default is 'sub'
# --dump-block-minimum-lines=n (-dbml=n), where n is the minimum
# number of lines for a block to be included; default is 20.
my $rOpts_dump_block_types = $rOpts->{'dump-block-types'};
if ( !defined($rOpts_dump_block_types) ) { $rOpts_dump_block_types = 'sub' }
$rOpts_dump_block_types =~ s/^\s+//;
$rOpts_dump_block_types =~ s/\s+$//;
my @list = split /\s+/, $rOpts_dump_block_types;
my %dump_block_types;
@dump_block_types{@list} = (1) x scalar(@list);
# Get level variation info for code blocks
my $rlevel_info = $self->find_level_info();
# Get block info
my $rselected_blocks =
$self->find_selected_blocks( \%dump_block_types, $rlevel_info );
# Get if-chains
my $rselected_if_chains =
$self->find_if_chains( \%dump_block_types, $rlevel_info );
# Get package info
my $rpackages = $self->find_selected_packages( \%dump_block_types );
# merge
my @all_blocks =
( @{$rselected_blocks}, @{$rselected_if_chains}, @{$rpackages} );
return unless (@all_blocks);
my $input_stream_name = get_input_stream_name();
# Get code line count
my $rcode_line_count = $self->find_code_line_count();
# Get mccabe count
my $rmccabe_count_sum = $self->find_mccabe_count();
my $rOpts_dump_block_minimum_lines = $rOpts->{'dump-block-minimum-lines'};
if ( !defined($rOpts_dump_block_minimum_lines) ) {
$rOpts_dump_block_minimum_lines = 20;
}
my $rLL = $self->[_rLL_];
# add various counts, filter and print to STDOUT
my $routput_lines = [];
foreach my $item (@all_blocks) {
my $K_opening = $item->{K_opening};
my $K_closing = $item->{K_closing};
# define total number of lines
my $lx_open = $rLL->[$K_opening]->[_LINE_INDEX_];
my $lx_close = $rLL->[$K_closing]->[_LINE_INDEX_];
my $line_count = $lx_close - $lx_open + 1;
# define total number of lines of code excluding blanks, comments, pod
my $code_lines_open = $rcode_line_count->[$lx_open];
my $code_lines_close = $rcode_line_count->[$lx_close];
my $code_lines = 0;
if ( defined($code_lines_open) && defined($code_lines_close) ) {
$code_lines = $code_lines_close - $code_lines_open + 1;
}
# filter out blocks below the selected code line limit
if ( $code_lines < $rOpts_dump_block_minimum_lines ) {
next;
}
# add mccabe_count for this block
my $mccabe_closing = $rmccabe_count_sum->{ $K_closing + 1 };
my $mccabe_opening = $rmccabe_count_sum->{$K_opening};
my $mccabe_count = 1; # add 1 to match Perl::Critic
if ( defined($mccabe_opening) && defined($mccabe_closing) ) {
$mccabe_count += $mccabe_closing - $mccabe_opening;
}
# Store the final set of print variables
# Note: K_opening is added for sorting but deleted before printing
push @{$routput_lines}, [
$input_stream_name,
$item->{line_start},
$line_count,
$code_lines,
$item->{type},
$item->{name},
$item->{level},
$item->{max_change},
$item->{block_count},
$mccabe_count,
$K_opening,
];
}
return unless @{$routput_lines};
# Sort blocks and packages on starting line number
my @sorted_lines = sort { $a->[-1] <=> $b->[-1] } @{$routput_lines};
print {*STDOUT}
"file,line,line_count,code_lines,type,name,level,max_change,block_count,mccabe_count\n";
foreach my $rline_vars (@sorted_lines) {
# remove K_opening which was added for stable sorting
pop @{$rline_vars};
my $line = join( ",", @{$rline_vars} ) . "\n";
print {*STDOUT} $line;
}
return;
} ## end sub dump_block_summary
sub set_ci {
my ($self) = @_;
# Set the basic continuation indentation (ci) for all tokens.
# This is a replacement for the values previously computed in
# sub Perl::Tidy::Tokenizer::tokenizer_wrapup. In most cases it
# produces identical results, but in a few cases it is an improvement.
use constant DEBUG_SET_CI => 0;
# This turns on an optional piece of logic which makes the new and
# old computations of ci agree. It has almost no effect on actual
# programs but is useful for testing.
use constant SET_CI_OPTION_0 => 1;
# This is slightly different from the hash in in break_lists
# with a similar name (removed '?' and ':' to fix t007 and others)
my %is_logical_container_for_ci;
my @q = qw# if elsif unless while and or err not && | || ! #;
@is_logical_container_for_ci{@q} = (1) x scalar(@q);
# This is slightly different from a tokenizer hash with a similar name:
my %is_container_label_type_for_ci;
@q = qw# k && | || ? : ! #;
@is_container_label_type_for_ci{@q} = (1) x scalar(@q);
# Undo ci of closing list paren followed by these binary operators:
# - initially defined for issue t027, then
# - added '=' for t015
# - added '=~' for 'locale.in'
# - added '<=>' for 'corelist.in'
# Note:
# See @value_requestor_type for more that might be included
# See also @is_binary_type
my %bin_op_type;
@q = qw# . ** -> + - / * = != ^ < > % >= <= =~ !~ <=> x #;
@bin_op_type{@q} = (1) x scalar(@q);
my %is_list_end_type;
@q = qw( ; { } );
push @q, ',';
@is_list_end_type{@q} = (1) x scalar(@q);
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
return unless defined($Klimit);
my $token = ';';
my $type = ';';
my $last_token = $token;
my $last_type = $type;
my $ci_last = 0;
my $ci_next = 0;
my $ci_next_next = 1;
my $rstack = [];
my $seq_root = SEQ_ROOT;
my $rparent = {
_seqno => $seq_root,
_ci_open => 0,
_ci_open_next => 0,
_ci_close => 0,
_ci_close_next => 0,
_container_type => 'Block',
_ci_next_next => $ci_next_next,
_comma_count => 0,
_semicolon_count => 0,
_Kc => undef,
};
# Debug stuff
my @debug_lines;
my %saw_ci_diff;
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_sub_block = $self->[_ris_sub_block_];
my $ris_asub_block = $self->[_ris_asub_block_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $K_closing_ternary = $self->[_K_closing_ternary_];
my $rlines = $self->[_rlines_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $want_break_before_comma = $want_break_before{','};
my $map_block_follows = sub {
# return true if a sort/map/etc block follows the closing brace
# of container $seqno
my ($seqno) = @_;
my $Kc = $K_closing_container->{$seqno};
return unless defined($Kc);
# Skip past keyword
my $Kcn = $self->K_next_code($Kc);
return unless defined($Kcn);
my $seqno_n = $rLL->[$Kcn]->[_TYPE_SEQUENCE_];
return if ($seqno_n);
# Look for opening block brace
my $Knn = $self->K_next_code($Kcn);
return unless defined($Knn);
my $seqno_nn = $rLL->[$Knn]->[_TYPE_SEQUENCE_];
return unless ($seqno_nn);
my $K_nno = $K_opening_container->{$seqno_nn};
return unless ( $K_nno && $K_nno == $Knn );
my $block_type = $rblock_type_of_seqno->{$seqno_nn};
if ($block_type) {
return $is_block_with_ci{$block_type};
}
return;
}; ## end $map_block_follows = sub
my $redo_preceding_comment_ci = sub {
# We need to reset the ci of the previous comment(s)
my ( $K, $ci ) = @_;
my $Km = $self->K_previous_code($K);
return if ( !defined($Km) );
foreach my $Kt ( $Km + 1 .. $K - 1 ) {
if ( $rLL->[$Kt]->[_TYPE_] eq '#' ) {
$rLL->[$Kt]->[_CI_LEVEL_] = $ci;
}
}
return;
}; ## end $redo_preceding_comment_ci = sub
# Definitions of the sequence of ci_values being maintained:
# $ci_last = the ci value of the previous non-blank, non-comment token
# $ci_this = the ci value to be stored for this token at index $KK
# $ci_next = the normal ci for the next token, set by the previous tok
# $ci_next_next = the normal next value of $ci_next in this container
#--------------------------
# Main loop over all tokens
#--------------------------
my $KK = -1;
foreach my $rtoken_K ( @{$rLL} ) {
$KK++;
#------------------
# Section 1. Blanks
#------------------
if ( ( $type = $rtoken_K->[_TYPE_] ) eq 'b' ) {
$rtoken_K->[_CI_LEVEL_] = $ci_next;
# 'next' to avoid saving last_ values for blanks and commas
next;
}
#--------------------
# Section 2. Comments
#--------------------
if ( $type eq '#' ) {
my $ci_this = $ci_next;
# If at '#' in ternary before a ? or :, use that level to make
# the comment line up with the next ? or : line. (see c202/t052)
# i.e. if a nested ? follows, we increase the '#' level by 1, and
# if a nested : follows, we decrease the '#' level by 1.
# This is the only place where this sub changes a _LEVEL_ value.
my $Kn;
my $parent_container_type = $rparent->{_container_type};
if ( $parent_container_type eq 'Ternary' ) {
$Kn = $self->K_next_code($KK);
if ($Kn) {
my $type_kn = $rLL->[$Kn]->[_TYPE_];
if ( $is_ternary{$type_kn} ) {
$rLL->[$KK]->[_LEVEL_] = $rLL->[$Kn]->[_LEVEL_];
# and use the ci of a terminating ':'
if ( $Kn == $rparent->{_Kc} ) {
$ci_this = $rparent->{_ci_close};
}
}
}
}
# Undo ci for a block comment followed by a closing token or , or ;
# provided that the parent container:
# - ends without ci, or
# - starts ci=0 and is a comma list or this follows a closing type
# - has a level jump
if (
$ci_this
&& (
!$rparent->{_ci_close}
|| (
!$rparent->{_ci_open_next}
&& ( ( $rparent->{_comma_count} || $last_type eq ',' )
|| $is_closing_type{$last_type} )
)
)
)
{
# Be sure this is a block comment
my $lx = $rtoken_K->[_LINE_INDEX_];
my $rK_range = $rlines->[$lx]->{_rK_range};
my $Kfirst;
if ($rK_range) { $Kfirst = $rK_range->[0] }
if ( defined($Kfirst) && $Kfirst == $KK ) {
# Look for trailing closing token
# [ and possibly ',' or ';' ]
$Kn = $self->K_next_code($KK) if ( !$Kn );
my $Kc = $rparent->{_Kc};
if (
$Kn
&& $Kc
&& (
$Kn == $Kc
# only look for comma if -wbb=',' is set
# to minimize changes to existing formatting
|| ( $rLL->[$Kn]->[_TYPE_] eq ','
&& $want_break_before_comma
&& $parent_container_type eq 'List' )
# do not look ahead for a bare ';' because
# it changes old formatting with little benefit.
## || ( $rLL->[$Kn]->[_TYPE_] eq ';'
## && $parent_container_type eq 'Block' )
)
)
{
# Be sure container has a level jump
my $level_KK = $rLL->[$KK]->[_LEVEL_];
my $level_Kc = $rLL->[$Kc]->[_LEVEL_];
# And be sure this is not a hanging side comment
my $CODE_type = $rlines->[$lx]->{_code_type};
my $is_HSC = $CODE_type && $CODE_type eq 'HSC';
if ( $level_Kc < $level_KK && !$is_HSC ) {
$ci_this = 0;
}
}
}
}
$ci_next = $ci_this;
$rtoken_K->[_CI_LEVEL_] = $ci_this;
# 'next' to avoid saving last_ values for blanks and commas
next;
}
#------------------------------------------------------------
# Section 3. Continuing with non-blank and non-comment tokens
#------------------------------------------------------------
$token = $rtoken_K->[_TOKEN_];
# Set ci values appropriate for most tokens:
my $ci_this = $ci_next;
$ci_next = $ci_next_next;
# Now change these ci values as necessary for special cases...
#----------------------------
# Section 4. Container tokens
#----------------------------
if ( $rtoken_K->[_TYPE_SEQUENCE_] ) {
my $seqno = $rtoken_K->[_TYPE_SEQUENCE_];
#-------------------------------------
# Section 4.1 Opening container tokens
#-------------------------------------
if ( $is_opening_sequence_token{$token} ) {
my $level = $rtoken_K->[_LEVEL_];
# Default ci values for the closing token, to be modified
# as necessary:
my $ci_close = $ci_next;
my $ci_close_next = $ci_next_next;
my $Kc =
$type eq '?'
? $K_closing_ternary->{$seqno}
: $K_closing_container->{$seqno};
# $Kn = $self->K_next_nonblank($KK);
my $Kn;
if ( $KK < $Klimit ) {
$Kn = $KK + 1;
if ( $rLL->[$Kn]->[_TYPE_] eq 'b' && $Kn < $Klimit ) {
$Kn += 1;
}
}
# $Kcn = $self->K_next_code($Kc);
my $Kcn;
if ( $Kc && $Kc < $Klimit ) {
$Kcn = $Kc + 1;
if ( $rLL->[$Kcn]->[_TYPE_] eq 'b' && $Kcn < $Klimit ) {
$Kcn += 1;
}
if ( $rLL->[$Kcn]->[_TYPE_] eq '#' ) {
$Kcn = $self->K_next_code($Kcn);
}
}
my $opening_level_jump =
$Kn ? $rLL->[$Kn]->[_LEVEL_] - $level : 0;
# initialize ci_next_next to its standard value
$ci_next_next = 1;
# Default: ci of first item of list with level jump is same as
# ci of first item of container
if ( $opening_level_jump > 0 ) {
$ci_next = $rparent->{_ci_open_next};
}
my ( $comma_count, $semicolon_count );
my $rtype_count = $rtype_count_by_seqno->{$seqno};
if ($rtype_count) {
$comma_count = $rtype_count->{','};
$semicolon_count = $rtype_count->{';'};
# Do not include a terminal semicolon in the count (the
# comma_count has already been corrected by respace_tokens)
# We only need to know if there are semicolons or not, so
# for speed we can just do this test if the count is 1.
if ( $semicolon_count && $semicolon_count == 1 ) {
my $Kcm = $self->K_previous_code($Kc);
if ( $rLL->[$Kcm]->[_TYPE_] eq ';' ) {
$semicolon_count--;
}
}
}
my $container_type;
#-------------------------
# Section 4.1.1 Code Block
#-------------------------
my $block_type = $rblock_type_of_seqno->{$seqno};
if ($block_type) {
$container_type = 'Block';
# set default depending on block type
$ci_close = 0;
my $no_semicolon =
$is_block_without_semicolon{$block_type}
|| $ris_sub_block->{$seqno}
|| $last_type eq 'J';
if ( !$no_semicolon ) {
# Optional fix for block types sort/map/etc which use
# zero ci at terminal brace if previous keyword had
# zero ci. This will cause sort/map/grep filter blocks
# to line up. Note that sub 'undo_ci' will also try to
# do this, so this is not a critical operation.
if ( $is_block_with_ci{$block_type} ) {
my $parent_seqno = $rparent->{_seqno};
if (
# only do this within containers
$parent_seqno != SEQ_ROOT
# only in containers without ',' and ';'
&& !$rparent->{_comma_count}
&& !$rparent->{_semicolon_count}
&& $map_block_follows->($seqno)
)
{
if ($ci_last) {
$ci_close = $ci_this;
}
}
else {
$ci_close = $ci_this;
}
}
# keep ci if certain operators follow (fix c202/t024)
if ( !$ci_close && $Kcn ) {
my $type_kcn = $rLL->[$Kcn]->[_TYPE_];
my $token_kcn = $rLL->[$Kcn]->[_TOKEN_];
if ( $type_kcn =~ /^(\.|\&\&|\|\|)$/
|| $type_kcn eq 'k' && $is_and_or{$token_kcn} )
{
$ci_close = $ci_this;
}
}
}
if ( $rparent->{_container_type} ne 'Ternary' ) {
$ci_this = 0;
}
$ci_next = 0;
$ci_close_next = $ci_close;
}
#----------------------
# Section 4.1.2 Ternary
#----------------------
elsif ( $type eq '?' ) {
$container_type = 'Ternary';
if ( $rparent->{_container_type} eq 'List'
&& !$rparent->{_ci_open_next} )
{
$ci_this = 0;
$ci_close = 0;
}
# redo ci of any preceding comments if necessary
# at an outermost ? (which has no level jump)
if ( !$opening_level_jump ) {
$redo_preceding_comment_ci->( $KK, $ci_this );
}
}
#-------------------------------
# Section 4.1.3 Logical or List?
#-------------------------------
else {
my $is_logical = $is_container_label_type_for_ci{$last_type}
&& $is_logical_container_for_ci{$last_token}
# Part 1 of optional patch to get agreement with previous
# ci This makes almost no difference in a typical program
# because we will seldom break within an array index.
|| $type eq '[' && SET_CI_OPTION_0;
if ( !$is_logical && $token eq '(' ) {
# 'foreach' and 'for' paren contents are treated as
# logical except for C-style 'for'
if ( $last_type eq 'k' ) {
$is_logical ||= $last_token eq 'foreach';
# C-style 'for' container will be type 'List'
if ( $last_token eq 'for' ) {
$is_logical =
!( $rtype_count && $rtype_count->{'f'} );
}
}
# Check for 'for' and 'foreach' loops with iterators
elsif ( $last_type eq 'i' && defined($Kcn) ) {
my $seqno_kcn = $rLL->[$Kcn]->[_TYPE_SEQUENCE_];
my $type_kcn = $rLL->[$Kcn]->[_TOKEN_];
if ( $seqno_kcn && $type_kcn eq '{' ) {
my $block_type_kcn =
$rblock_type_of_seqno->{$seqno_kcn};
$is_logical ||= $block_type_kcn
&& ( $block_type_kcn eq 'for'
|| $block_type_kcn eq 'foreach' );
}
# Search backwards for 'for'/'foreach' with
# iterator in case user is running from an editor
# and did not include the block (fixes case
# 'xci.in').
my $Km = $self->K_previous_code($KK);
foreach ( 0 .. 2 ) {
$Km = $self->K_previous_code($Km);
last unless defined($Km);
last unless ( $rLL->[$Km]->[_TYPE_] eq 'k' );
my $tok = $rLL->[$Km]->[_TOKEN_];
next if ( $tok eq 'my' );
$is_logical ||=
( $tok eq 'for' || $tok eq 'foreach' );
last;
}
}
elsif ( $last_token eq '(' ) {
$is_logical ||=
$rparent->{_container_type} eq 'Logical';
}
else {
# does not look like a logical paren
}
}
#------------------------
# Section 4.1.3.1 Logical
#------------------------
if ($is_logical) {
$container_type = 'Logical';
# Pass ci though an '!'
if ( $last_type eq '!' ) { $ci_this = $ci_last }
$ci_next_next = 0;
$ci_close_next = $ci_this;
# Part 2 of optional patch to get agreement with
# previous ci
if ( $type eq '[' && SET_CI_OPTION_0 ) {
$ci_next_next = $ci_this;
# Undo ci at a chain of indexes or hash keys
if ( $last_type eq '}' ) {
$ci_this = $ci_last;
}
}
if ($opening_level_jump) {
$ci_next = 0;
}
}
#---------------------
# Section 4.1.3.2 List
#---------------------
else {
# Here 'List' is a catchall for none of the above types
$container_type = 'List';
# lists in blocks ...
if ( $rparent->{_container_type} eq 'Block' ) {
# undo ci if another closing token follows
if ( defined($Kcn) ) {
my $closing_level_jump =
$rLL->[$Kcn]->[_LEVEL_] - $level;
if ( $closing_level_jump < 0 ) {
$ci_close = $ci_this;
}
}
}
# lists not in blocks ...
else {
if ( !$rparent->{_comma_count} ) {
$ci_close = $ci_this;
# undo ci at binary op after right paren if no
# commas in container; fixes t027, t028
if ( $ci_close_next != $ci_close
&& defined($Kcn)
&& $bin_op_type{ $rLL->[$Kcn]->[_TYPE_] } )
{
$ci_close_next = $ci_close;
}
}
if ( $rparent->{_container_type} eq 'Ternary' ) {
$ci_next = 0;
}
}
# Undo ci at a chain of indexes or hash keys
if ( $token ne '(' && $last_type eq '}' ) {
$ci_this = $ci_close = $ci_last;
}
}
}
#---------------------------------------
# Section 4.1.4 Store opening token info
#---------------------------------------
# Most closing tokens should align with their opening tokens.
if (
$type eq '{'
&& $token ne '('
&& $is_list_end_type{$last_type}
# avoid asub blocks, which may have prototypes ending in '}'
&& !$ris_asub_block->{$seqno}
)
{
$ci_close = $ci_this;
}
# Closing ci must never be less than opening
if ( $ci_close < $ci_this ) { $ci_close = $ci_this }
push @{$rstack}, $rparent;
$rparent = {
_seqno => $seqno,
_container_type => $container_type,
_ci_next_next => $ci_next_next,
_ci_open => $ci_this,
_ci_open_next => $ci_next,
_ci_close => $ci_close,
_ci_close_next => $ci_close_next,
_comma_count => $comma_count,
_semicolon_count => $semicolon_count,
_Kc => $Kc,
};
}
#-------------------------------------
# Section 4.2 Closing container tokens
#-------------------------------------
else {
my $seqno_test = $rparent->{_seqno};
if ( $seqno_test ne $seqno ) {
# Shouldn't happen if we are processing balanced text.
# (Unbalanced text should go out verbatim)
DEVEL_MODE
&& Fault("stack error: $seqno_test != $seqno\n");
}
# Use ci_this, ci_next values set by the matching opening token:
$ci_this = $rparent->{_ci_close};
$ci_next = $rparent->{_ci_close_next};
my $ci_open_old = $rparent->{_ci_open};
# Then pop the stack and use the parent ci_next_next value:
if ( @{$rstack} ) {
$rparent = pop @{$rstack};
$ci_next_next = $rparent->{_ci_next_next};
}
else {
# Shouldn't happen if we are processing balanced text.
DEVEL_MODE && Fault("empty stack - shouldn't happen\n");
}
# Fix: undo ci at a closing token followed by a closing token.
# Goal is to keep formatting independent of the existence of a
# trailing comma or semicolon.
if ( $ci_this > 0 && !$ci_open_old && !$rparent->{_ci_close} ) {
my $Kc = $rparent->{_Kc};
my $Kn = $self->K_next_code($KK);
if ( $Kc && $Kn && $Kc == $Kn ) {
$ci_this = $ci_next = 0;
}
}
}
}
#---------------------------------
# Section 5. Semicolons and Labels
#---------------------------------
# The next token after a ';' and label (type 'J') starts a new stmt
# The ci after a C-style for ';' (type 'f') is handled similarly.
elsif ( $type eq ';' || $type eq 'J' || $type eq 'f' ) {
$ci_next = 0;
if ( $is_closing_type{$last_type} ) { $ci_this = $ci_last }
}
#--------------------
# Section 6. Keywords
#--------------------
# Undo ci after a format statement
elsif ( $type eq 'k' ) {
if ( substr( $token, 0, 6 ) eq 'format' ) {
$ci_next = 0;
}
}
#------------------
# Section 7. Commas
#------------------
# A comma and the subsequent item normally have ci undone
# unless ci has been set at a lower level
elsif ( $type eq ',' ) {
if ( $rparent->{_container_type} eq 'List' ) {
$ci_this = $ci_next = $rparent->{_ci_open_next};
}
}
else {
# not a special ci type
}
# Save debug info if requested
DEBUG_SET_CI && do {
my $seqno = $rtoken_K->[_TYPE_SEQUENCE_];
my $level = $rtoken_K->[_LEVEL_];
my $ci = $rtoken_K->[_CI_LEVEL_];
if ( $ci > 1 ) { $ci = 1 }
my $tok = $token;
my $last_tok = $last_token;
$tok =~ s/\t//g;
$last_tok =~ s/\t//g;
$tok = length($tok) > 3 ? substr( $tok, 0, 8 ) : $tok;
$last_tok =
length($last_tok) > 3 ? substr( $last_tok, 0, 8 ) : $last_tok;
$tok =~ s/["']//g;
$last_tok =~ s/["']//g;
my $block_type;
$block_type = $rblock_type_of_seqno->{$seqno} if ($seqno);
$block_type = EMPTY_STRING unless ($block_type);
my $ptype = $rparent->{_container_type};
my $pname = $ptype;
my $error =
$ci_this == $ci ? EMPTY_STRING : $type eq 'b' ? "error" : "ERROR";
if ($error) { $saw_ci_diff{$KK} = 1 }
my $lno = $rtoken_K->[_LINE_INDEX_] + 1;
$debug_lines[$KK] = <[_CI_LEVEL_] = $ci_this;
# Remember last nonblank, non-comment token info for the next pass
$ci_last = $ci_this;
$last_token = $token;
$last_type = $type;
} ## End main loop over tokens
#----------------------
# Post-loop operations:
#----------------------
if (DEBUG_SET_CI) {
my @output_lines;
foreach my $Kd ( 0 .. $Klimit ) {
my $line = $debug_lines[$Kd];
if ($line) {
my $Kp = $self->K_previous_code($Kd);
my $Kn = $self->K_next_code($Kd);
if ( DEBUG_SET_CI > 1
|| $Kp && $saw_ci_diff{$Kp}
|| $saw_ci_diff{$Kd}
|| $Kn && $saw_ci_diff{$Kn} )
{
push @output_lines, $line;
}
}
}
if (@output_lines) {
unshift @output_lines, <[_rLL_];
my $rlines = $self->[_rlines_];
my $rOpts_format_skipping_begin = $rOpts->{'format-skipping-begin'};
my $rOpts_format_skipping_end = $rOpts->{'format-skipping-end'};
my $rOpts_static_block_comment_prefix =
$rOpts->{'static-block-comment-prefix'};
# Remember indexes of lines with side comments
my @ix_side_comments;
my $In_format_skipping_section = 0;
my $Saw_VERSION_in_this_file = 0;
my $has_side_comment = 0;
my $last_line_had_side_comment = 0;
my ( $Kfirst, $Klast );
my $CODE_type;
# Loop to set CODE_type
# Possible CODE_types
# 'VB' = Verbatim - line goes out verbatim (a quote)
# 'FS' = Format Skipping - line goes out verbatim
# 'BL' = Blank Line
# 'HSC' = Hanging Side Comment - fix this hanging side comment
# 'SBCX'= Static Block Comment Without Leading Space
# 'SBC' = Static Block Comment
# 'BC' = Block Comment - an ordinary full line comment
# 'IO' = Indent Only - line goes out unchanged except for indentation
# 'NIN' = No Internal Newlines - line does not get broken
# 'VER' = VERSION statement
# '' = ordinary line of code with no restrictions
#--------------------
# Loop over all lines
#--------------------
my $ix_line = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$ix_line++;
my $line_type = $line_of_tokens->{_line_type};
my $last_CODE_type = $CODE_type;
# Set default to be ordinary code
$CODE_type = EMPTY_STRING;
#-------------------------------------
# This is only for lines marked 'CODE'
#-------------------------------------
if ( $line_type ne 'CODE' ) {
next;
}
my $input_line = $line_of_tokens->{_line_text};
my $Klast_prev = $Klast;
( $Kfirst, $Klast ) = @{ $line_of_tokens->{_rK_range} };
my $jmax = defined($Kfirst) ? $Klast - $Kfirst : -1;
my $is_block_comment;
if ( $jmax >= 0 && $rLL->[$Klast]->[_TYPE_] eq '#' ) {
if ( $jmax == 0 ) { $is_block_comment = 1; }
else { $has_side_comment = 1 }
}
#-----------------------------------------------------------
# Write line verbatim if we are in a formatting skip section
#-----------------------------------------------------------
if ($In_format_skipping_section) {
# Note: extra space appended to comment simplifies pattern matching
if (
$is_block_comment
# optional fast pre-check
&& ( substr( $rLL->[$Kfirst]->[_TOKEN_], 0, 4 ) eq '#>>>'
|| $rOpts_format_skipping_end )
&& ( $rLL->[$Kfirst]->[_TOKEN_] . SPACE ) =~
/$format_skipping_pattern_end/
)
{
$In_format_skipping_section = 0;
my $input_line_no = $line_of_tokens->{_line_number};
write_logfile_entry(
"Line $input_line_no: Exiting format-skipping section\n");
}
elsif (
$is_block_comment
# optional fast pre-check
&& ( substr( $rLL->[$Kfirst]->[_TOKEN_], 0, 4 ) eq '#<<<'
|| $rOpts_format_skipping_begin )
&& $rOpts_format_skipping
&& ( $rLL->[$Kfirst]->[_TOKEN_] . SPACE ) =~
/$format_skipping_pattern_begin/
)
{
# warn of duplicate starting comment lines, git #118
my $input_line_no = $line_of_tokens->{_line_number};
warning(
"Already in format-skipping section which started at line $In_format_skipping_section\n",
$input_line_no
);
}
else {
# not at a format skipping control line
}
$CODE_type = 'FS';
next;
}
#----------------------------
# Check for 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 ( $self->[_save_logfile_] && $input_line =~ /\t/ ) {
my $input_line_number = $line_of_tokens->{_line_number};
$self->note_embedded_tab($input_line_number);
}
$CODE_type = 'VB';
next;
}
}
#-------------------------------------------------
# See if we are entering a formatting skip section
#-------------------------------------------------
if (
$is_block_comment
# optional fast pre-check
&& ( substr( $rLL->[$Kfirst]->[_TOKEN_], 0, 4 ) eq '#<<<'
|| $rOpts_format_skipping_begin )
&& $rOpts_format_skipping
&& ( $rLL->[$Kfirst]->[_TOKEN_] . SPACE ) =~
/$format_skipping_pattern_begin/
)
{
my $input_line_no = $line_of_tokens->{_line_number};
$In_format_skipping_section = $input_line_no;
write_logfile_entry(
"Line $input_line_no: Entering format-skipping section\n");
$CODE_type = 'FS';
next;
}
# ignore trailing blank tokens (they will get deleted later)
if ( $jmax > 0 && $rLL->[$Klast]->[_TYPE_] eq 'b' ) {
$jmax--;
}
#-----------
# Blank line
#-----------
if ( $jmax < 0 ) {
$CODE_type = 'BL';
next;
}
#---------
# Comments
#---------
if ($is_block_comment) {
# see if this is a static block comment (starts with ## by default)
my $is_static_block_comment = 0;
my $no_leading_space = substr( $input_line, 0, 1 ) eq '#';
if (
# optional fast pre-check
(
substr( $rLL->[$Kfirst]->[_TOKEN_], 0, 2 ) eq '##'
|| $rOpts_static_block_comment_prefix
)
&& $rOpts_static_block_comments
&& $input_line =~ /$static_block_comment_pattern/
)
{
$is_static_block_comment = 1;
}
# 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 (
$no_leading_space
&& $input_line =~ m{^\# \s*
line \s+ (\d+) \s*
(?:\s("?)([^"]+)\2)? \s*
$}x
)
{
$is_static_block_comment = 1;
}
# look for hanging side comment ...
if (
$last_line_had_side_comment # this follows as side comment
&& !$no_leading_space # with some leading space, and
&& !$is_static_block_comment # this is not a static comment
)
{
# continuing an existing HSC chain?
if ( $last_CODE_type eq 'HSC' ) {
$has_side_comment = 1;
$CODE_type = 'HSC';
next;
}
# starting a new HSC chain?
if (
$rOpts->{'hanging-side-comments'} # user is allowing
# hanging side comments
# like this
&& ( defined($Klast_prev) && $Klast_prev > 1 )
# and the previous side comment was not static (issue c070)
&& !(
$rOpts->{'static-side-comments'}
&& $rLL->[$Klast_prev]->[_TOKEN_] =~
/$static_side_comment_pattern/
)
)
{
# and it is not a closing side comment (issue c070).
my $K_penult = $Klast_prev - 1;
$K_penult -= 1 if ( $rLL->[$K_penult]->[_TYPE_] eq 'b' );
my $follows_csc =
( $rLL->[$K_penult]->[_TOKEN_] eq '}'
&& $rLL->[$K_penult]->[_TYPE_] eq '}'
&& $rLL->[$Klast_prev]->[_TOKEN_] =~
/$closing_side_comment_prefix_pattern/ );
if ( !$follows_csc ) {
$has_side_comment = 1;
$CODE_type = 'HSC';
next;
}
}
}
if ($is_static_block_comment) {
$CODE_type = $no_leading_space ? 'SBCX' : 'SBC';
next;
}
elsif ( $last_line_had_side_comment
&& !$rOpts_maximum_consecutive_blank_lines
&& $rLL->[$Kfirst]->[_LEVEL_] > 0 )
{
# Emergency fix to keep a block comment from becoming a hanging
# side comment. This fix is for the case that blank lines
# cannot be inserted. There is related code in sub
# 'process_line_of_CODE'
$CODE_type = 'SBCX';
next;
}
else {
$CODE_type = 'BC';
next;
}
}
#-------------------------
# Other special code types
#-------------------------
if ($rOpts_indent_only) {
$CODE_type = 'IO';
next;
}
if ( !$rOpts_add_newlines ) {
$CODE_type = 'NIN';
next;
}
# 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
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");
# This code type has lower priority than others
$CODE_type = 'VER';
next;
}
}
continue {
$line_of_tokens->{_code_type} = $CODE_type;
$last_line_had_side_comment = $has_side_comment;
if ($has_side_comment) {
push @ix_side_comments, $ix_line;
$has_side_comment = 0;
}
}
return \@ix_side_comments;
} ## end sub set_CODE_type
sub block_seqno_of_paren_keyword {
my ( $self, $KK ) = @_;
# Find brace at '){' after keyword such as for, foreach, ...
# SEE ALSO: sub block_seqno_of_paren_seqno
# Given:
# $KK = index of a keyword followed by parens and block '... ( ) {'
# such as 'for', 'foreach', 'while', 'if', 'elsif' ..
# Return:
# $seqno of the opening block brace for this keyword, if any
# $K_end_iterator = index of the last token of an iterator, if any
# or
# nothing if not found
# 'for my $var (..) { ... }'
# ^ ^
# | |
# --$KK --$seqno of brace that we want
my $rLL = $self->[_rLL_];
# look ahead for an opening paren
my $K_paren = $self->[_rK_next_seqno_by_K_]->[$KK];
return unless defined($K_paren);
my $token_paren = $rLL->[$K_paren]->[_TOKEN_];
return unless ( $token_paren eq '(' );
# found a paren, but does it belong to this keyword?
my $seqno_paren = $rLL->[$K_paren]->[_TYPE_SEQUENCE_];
# see if this opening paren immediately follows the keyword
my $K_n = $self->K_next_code($KK);
return unless $K_n;
# is it the next token? this is the common case
my $K_end_iterator;
my $saw_my;
my $token_KK = $rLL->[$KK]->[_TOKEN_];
if ( $K_n != $K_paren ) {
# look for 'for $var (', 'for my $var (', 'for my (', 'for $var ('
if ( $is_for_foreach{$token_KK} ) {
my $type_K_n = $rLL->[$K_n]->[_TYPE_];
my $token_K_n = $rLL->[$K_n]->[_TOKEN_];
# skip past a 'my'
if ( $type_K_n eq 'k' ) {
if ( $is_my_state_our{$token_K_n} ) {
$K_n = $self->K_next_code($K_n);
$saw_my = 1;
}
else { return }
}
# skip an identifier
if ( $K_n && $K_n != $K_paren && $rLL->[$K_n]->[_TYPE_] eq 'i' ) {
$K_n = $self->K_next_code($K_n);
# force this iterator to be entered as new lexical
$K_end_iterator = $K_paren;
}
}
}
# we must be at the paren
return unless ( $K_n && $K_n == $K_paren );
# now jump to the closing paren
$K_paren = $self->[_K_closing_container_]->{$seqno_paren};
# then look for the opening brace immediately after it
my $K_brace = $self->K_next_code($K_paren);
return unless ($K_brace);
# check for experimental 'for list': for my ( $a, $b) (@list) {
# ^
if ( $rLL->[$K_brace]->[_TOKEN_] eq '('
&& !$K_end_iterator
&& $is_for_foreach{$token_KK} )
{
if ( !$saw_my ) { $K_end_iterator = $K_brace }
my $seqno_test = $rLL->[$K_brace]->[_TYPE_SEQUENCE_];
my $K_test = $self->[_K_closing_container_]->{$seqno_test};
return unless $K_test;
$K_brace = $self->K_next_code($K_test);
return unless ($K_brace);
}
return unless ( $rLL->[$K_brace]->[_TOKEN_] eq '{' );
my $seqno_brace = $rLL->[$K_brace]->[_TYPE_SEQUENCE_];
return unless ($seqno_brace);
my $block_type = $self->[_rblock_type_of_seqno_]->{$seqno_brace};
# Verify that this is the correct brace
if ( $block_type ne $token_KK ) {
# If not, this is unexpected and should be investigated
# (the block type may have been mis-marked)
my $lno = $rLL->[$KK]->[_LINE_INDEX_] + 1;
DEVEL_MODE && Fault(<K_last_code();
return unless defined($Klast);
my $rLL = $self->[_rLL_];
my $rK_package_list = $self->[_rK_package_list_];
return unless ( defined($rK_package_list) && @{$rK_package_list} );
# look for a file like this:
# package A::B
# ...
# 1;
my $KK = $rK_package_list->[0];
my $item = $rLL->[$KK];
my $type = $item->[_TYPE_];
# Stored K values may be off by 1 due to an added blank
if ( $type eq 'b' ) {
$KK += 1;
$item = $rLL->[$KK];
$type = $item->[_TYPE_];
}
# safety check - shouldn't happen
if ( $type ne 'P' ) {
DEVEL_MODE && Fault("Expecting type 'P' but found '$type'");
return;
}
my $level = $item->[_LEVEL_];
return unless ( $level == 0 );
# Look for '1;' at next package, if any, and at end of file
my @K_semicolon_test = ($Klast);
if ( @{$rK_package_list} > 1 ) {
my $K_package = $rK_package_list->[1];
my $Ktest = $self->K_previous_code($K_package);
push @K_semicolon_test, $Ktest;
}
foreach my $Ktest (@K_semicolon_test) {
if ( $rLL->[$Ktest]->[_TYPE_] eq 'b' ) { $Ktest -= 1 }
if ( $Ktest > $KK && $Ktest && $rLL->[$Ktest]->[_TYPE_] eq ';' ) {
my $K1 = $self->K_previous_code($Ktest);
if ( $K1 && $rLL->[$K1]->[_TOKEN_] eq '1' ) {
return 1;
}
}
}
return;
} ## end sub has_complete_package
sub is_complete_script {
my ( $self, $rline_type_count, $rkeyword_count ) = @_;
# Guess if we are formatting a complete script
# Given:
# $rline_type_count = hash ref of count of line types
# $rkeyword_count = hash ref of count of keywords
# Return: true or false
# Goal: help decide if we should skip certain warning checks when
# operating on just part of a script (such as from an editor).
#----------------------------------------------------------------
# TEST 1: Assume a file with known extension is a complete script
#----------------------------------------------------------------
my %is_standard_file_extension = (
'pm' => 1,
'pl' => 1,
'plx' => 1,
't' => 1,
);
my $input_stream_name = get_input_stream_name();
# look for a file extension
my $pos_dot = rindex( $input_stream_name, '.' );
my $file_extension = EMPTY_STRING;
if ( $pos_dot > 0 ) {
$file_extension = substr( $input_stream_name, $pos_dot + 1 );
# allow additional digits, like .pm.0, .pm.1 etc
if ( defined($file_extension)
&& length($file_extension)
&& $file_extension =~ /^\d+$/ )
{
my $str = substr( $input_stream_name, 0, $pos_dot );
$pos_dot = rindex( $str, '.' );
if ( $pos_dot > 0 ) {
$file_extension = substr( $str, $pos_dot + 1 );
}
}
return 1 if $is_standard_file_extension{ lc($file_extension) };
}
#-------------------------------------------------------------
# TEST 2: a positive starting level implies an incomplete script
#-------------------------------------------------------------
my $rLL = $self->[_rLL_];
return unless ( @{$rLL} );
my $sil = $rLL->[0]->[_LEVEL_];
return if ($sil);
#------------------------------------
# TEST 3: look for a complete package
#------------------------------------
return 1 if $self->has_complete_package();
#----------------------------
# TEST 4: examine other clues
#----------------------------
my $rlines = $self->[_rlines_];
my $line_count = @{$rlines};
return unless ($line_count);
my $input_line = $rlines->[0]->{_line_text};
my $saw_hash_bang = substr( $input_line, 0, 2 ) eq '#!'
&& $input_line =~ /^\#\!.*perl\b/;
my $rK_package_list = $self->[_rK_package_list_];
my $saw_package = defined($rK_package_list) && @{$rK_package_list};
my $sub_count = +keys %{ $self->[_ris_sub_block_] };
my $use_count = 0;
$use_count += $rkeyword_count->{use} if $rkeyword_count->{use};
$use_count += $rkeyword_count->{require} if $rkeyword_count->{require};
# Make a guess using the available clues. No single clue is conclusive.
my $score = 0;
# starting indicators
$score += 50
if ( $saw_hash_bang
|| $self->[_saw_use_strict_]
|| $saw_package );
$score +=
$use_count > 1 ? 50
: $use_count > 0 ? 25
: 0;
# interior indicators
$score +=
$line_count > 50 ? 50
: $line_count > 25 ? 25
: 0;
$score +=
$sub_count > 1 ? 50
: $sub_count > 0 ? 25
: 0;
# common filter keywords
foreach (qw( exit print printf open system exec die )) {
if ( $rkeyword_count->{$_} ) { $score += 50; last; }
}
$score += 50 if $rline_type_count->{POD};
# ending indicator
$score += 50 if $self->[_saw_END_or_DATA_];
if ( $score >= 100 ) { return 1 }
return;
} ## end sub is_complete_script
use constant DEBUG_USE_CONSTANT => 0;
sub get_qw_list {
my ( $self, $Kn ) = @_;
# Given:
# $Kn = index of start of a qw quote
# Return:
# ($K_last_q, \@list) to list of words, or
# nothing if error
my $rLL = $self->[_rLL_];
return unless defined($Kn);
my $type_n = $rLL->[$Kn]->[_TYPE_];
return unless ( $type_n eq 'q' );
my $token_n = $rLL->[$Kn]->[_TOKEN_];
my $K_last_q = $Kn;
# collect a multi-line qw
my $string = $token_n;
foreach my $Knn ( $Kn + 1 .. @{$rLL} - 1 ) {
my $type_nn = $rLL->[$Knn]->[_TYPE_];
next if ( $type_nn eq 'b' );
last if ( $type_nn ne 'q' );
$string .= SPACE . $rLL->[$Knn]->[_TOKEN_];
$K_last_q = $Knn;
}
$string = substr( $string, 2 ); # remove qw
$string =~ s/^\s*//; # trim left
$string = substr( $string, 1 ); # remove opening mark char
$string = substr( $string, 0, -1 ); # remove closing mark char
$string =~ s/^\s*//; # trim left
$string =~ s/\s*$//; # trim right
my @list = split /\s+/, $string;
return ( $K_last_q, \@list );
} ## end sub get_qw_list
sub expand_quoted_word_list {
my ( $self, $Kbeg ) = @_;
# Expand a list quoted words
# Given:
# $Kbeg = index of the start of a list of quoted words
# Returns:
# ref to list if found words
# undef if not successful, or non-constant list item encountered
my $rLL = $self->[_rLL_];
return unless defined($Kbeg);
my $Klimit = @{$rLL} - 1;
my @list;
my $Kn = $Kbeg - 1;
while ( ++$Kn <= $Klimit ) {
my $type = $rLL->[$Kn]->[_TYPE_];
my $token = $rLL->[$Kn]->[_TOKEN_];
next if ( $type eq 'b' );
next if ( $type eq '#' );
next if ( $token eq '(' );
next if ( $token eq ')' );
next if ( $token eq ',' );
last if ( $type eq ';' );
last if ( $token eq '}' );
if ( $type eq 'q' ) {
# qw list
my ( $K_last_q, $rlist ) = $self->get_qw_list($Kn);
return if ( !defined($K_last_q) );
if ( $K_last_q > $Kn ) { $Kn = $K_last_q }
push @list, @{$rlist};
}
elsif ( $type eq 'Q' ) {
# single quoted word
next if ( length($token) < 3 );
my $name = substr( $token, 1, -1 );
push @list, $name;
}
else {
# Give up on anything else..
# some examples where we have to quit:
# @EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
# @EXPORT = ( @CONSTANTS, qw( %ALL_CODESETS));
# @EXPORT = ( @{$EXPORT_TAGS{standard}}, ..
return;
}
} ## end while ( ++$Kn <= $Klimit )
return \@list;
} ## end sub expand_quoted_word_list
sub expand_EXPORT_list {
my ( $self, $KK, $rhash ) = @_;
# Given:
# $KK = index of variable @EXPORT or @EXPORT_OK
# $rhash = a hash to fill
# Task:
# Update $rhash with any quoted words which follow any subsequent '='
my $rLL = $self->[_rLL_];
my $Kn = $self->K_next_code($KK);
# Require a following '='
return unless ( $Kn && $rLL->[$Kn]->[_TYPE_] eq '=' );
# Move to the next token
$Kn = $self->K_next_code($Kn);
return unless ($Kn);
# Get any list
my $rlist = $self->expand_quoted_word_list($Kn);
return unless ($rlist);
# Include the listed words in the hash
foreach ( @{$rlist} ) { $rhash->{$_} = 1 }
return;
} ## end sub expand_EXPORT_list
sub scan_variable_usage {
my ( $self, ($roption) ) = @_;
# Scan for unused and reused lexical variables in a single sweep.
# Given:
# $roption = an optional set of types of checks,
# all checks are made if not given
# Return:
# - nothing if no errors found
# - ref to a list of 'warnings', one per variable, in line order.
# Each list item is a hash of values describing the issue. These
# are stored in a list of hash refs, as follows:
# push @warnings,
# {
# name => $name, # name, such as '$var', '%data'
# line_number => $line_number, # line number where defined
# K => $KK, # index of token $name
# keyword => $keyword, # 'my', 'state', 'for', 'foreach'
# letter => $letter, # one of: r s p u
# note => $note, # additional text info
# see_line => $see_line, # line referenced in note
# };
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_sub_block = $self->[_ris_sub_block_];
my $K_closing_container = $self->[_K_closing_container_];
# check for file without code (could be all pod or comments)
return unless defined( $self->K_first_code() );
# issues are indicated by these names:
my %unusual_variable_issue_note = (
c => "unused constant",
p => "package crossing",
r => "reused",
s => "multi-sigil",
u => "unused lexical",
);
# Default is to do all checks if no control hash received (dump mode)
if ( !defined($roption) ) {
foreach my $key ( keys %unusual_variable_issue_note ) {
$roption->{$key} = 1;
}
}
my $issue_type_string = "Issue types are";
foreach my $letter ( reverse sort keys %unusual_variable_issue_note ) {
next if ( !$roption->{$letter} );
my $txt = $unusual_variable_issue_note{$letter};
$issue_type_string .= " '$letter'=$txt";
}
# Unpack the control hash
my $check_sigil = $roption->{'s'};
my $check_cross_package = $roption->{'p'};
my $check_unused = $roption->{'u'};
my $check_reused = $roption->{'r'};
my $check_constant = $roption->{'c'};
my %is_valid_sigil = ( '$' => 1, '@' => 1, '%' => 1 );
# Variables defining current state:
my $current_package = 'main';
# The basic idea of this routine is straightforward:
# - We create a stack of block braces
# - We walk through the tokens in the file
# - At an opening block brace, we push a new stack entry
# - At a closing block brace, we pop the stack,
# and check the count of any 'my' vars (issue 'u')
# - At an identifier, like '$var':
# - if it follows a 'my' we enter it on the stack with starting count 0
# check conflicts with any other vars on the stack (issues 'r' and 's')
# - otherwise, we see if the variable is in the stack, and if so,
# update the count
# - At a package, we see if it has access to existing 'my' vars (issue 'p')
# There are lots of details, but that's the main idea. A difficulty is
# when 'my' vars are created in the control section of blocks such as
# for, foreach, if, unless, .. these follow special rules. The
# way it is done here is to propagate such vars in a special control
# layer stack entry which is pushed on just before these blocks.
my $rblock_stack = [];
my $rconstant_hash = {};
my $ruse_vars_hash = {};
my $rEXPORT_hash = {};
#---------------------------------------
# sub to push a block brace on the stack
#---------------------------------------
my $push_block_stack = sub {
my ( $seqno, $rvars ) = @_;
# push an entry for a new block onto the block stack:
# Given:
# $seqno = the sequence number of the code block
# $rvars = hash of initial identifiers for the block, if given
# will be empty hash ref if not given
if ( !defined($rvars) ) { $rvars = {} }
push @{$rblock_stack},
{ seqno => $seqno, package => $current_package, rvars => $rvars };
return;
}; ## end $push_block_stack = sub
$push_block_stack->(SEQ_ROOT);
# $rhash holds all lexecal variables defined within a given block:
# $rhash->{
# $name => {
# count => $count,
# line_index => $line_index,
# keyword => $keyword,
# package => $package,
# K => $KK
# }
# };
# $name = the variable name, such as '$data', '@list', '%vars',
# $count = number of uses
# $line_index = index of the line where it is defined
# $keyword = 'my' or 'state' or 'for' or 'foreach'
# $package = what package was in effect when it was defined
# $KK = token index (for sorting)
# Variables for a batch of lexical vars being collected:
my $my_keyword; # 'state' or 'my' keyword for this set
my $K_end_my = -1; # max token index of this set
my $in_signature_seqno = 0; # true while scanning a signature
my $my_starting_count = 0; # the initial token count for this set
# Variables for warning messages:
my @warnings; # array of warning messages
my %package_warnings; # warning messages for package cross-over
my %sub_count_by_package; # how many subs defined in a package
# Variables for scanning interpolated quotes:
my $ix_HERE_END = -1; # the line index of the last here target read
my $in_interpolated_quote; # in multiline quote with interpolation?
#-------------------------------------------------------
# sub to check for overlapping usage, issues 'r' and 's'
#-------------------------------------------------------
my $check_for_overlapping_variables = sub {
my ( $name, $KK ) = @_;
# Given:
# $name = a variable with sigil, such as '$var', '%var', '@var';
# $KK = index associated with this variable
# $line_index = index of line where this name first appears
# Task:
# Create a warning if this overlaps a previously defined variable
# Returns:
# true if error, variable is not of expected form with sigil
# false if no error
my $sigil = EMPTY_STRING;
my $word = EMPTY_STRING;
if ( $name =~ /^(\W+)(\w+)$/ ) {
$sigil = $1;
$word = $2;
}
else {
# give up, flag as error
# could be something like '$' or '@' in a signature, or
# for $Storable::downgrade_restricted (0, 1, ...
return 1;
}
# Perform checks for reused names
my @sigils_to_test;
if ($check_sigil) {
if ($check_reused) {
@sigils_to_test = (qw( $ @ % ));
}
else {
foreach my $sig (qw( $ @ % )) {
if ( $sig ne $sigil ) { push @sigils_to_test, $sig; }
}
}
}
elsif ($check_reused) {
push @sigils_to_test, $sigil;
}
else {
# neither
}
# See if this name has been seen, possibly with a different sigil
if (@sigils_to_test) {
# Look at stack and 'use vars' hash
foreach
my $item ( @{$rblock_stack}, $ruse_vars_hash->{$current_package} )
{
# distinguish between stack item and use vars item
my $rhash = defined( $item->{seqno} ) ? $item->{rvars} : $item;
foreach my $sig (@sigils_to_test) {
my $test_name = $sig . $word;
next unless ( $rhash->{$test_name} );
my $first_line = $rhash->{$test_name}->{line_index} + 1;
my $letter;
my $note;
my $see_line = 0;
if ( $sig eq $sigil ) {
my $as_iterator =
defined($my_keyword)
&& ( $my_keyword eq 'for'
|| $my_keyword eq 'foreach' )
? ' as iterator'
: EMPTY_STRING;
$note = "reused$as_iterator - see line $first_line";
$letter = 'r';
}
else {
$see_line = $first_line;
$note =
"overlaps $test_name in scope - see line $see_line";
$letter = 's';
}
my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
push @warnings,
{
name => $name,
keyword => $my_keyword,
note => $note,
see_line => $see_line,
line_number => $line_index + 1,
letter => $letter,
K => $KK,
};
last;
}
}
}
return;
}; ## end $check_for_overlapping_variables = sub
#--------------------------------
# sub to checkin a new identifier
#--------------------------------
my $checkin_new_lexical = sub {
my ($KK) = @_;
# Store the new identifier at index $KK
my $name = $rLL->[$KK]->[_TOKEN_];
my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
# Special checks for signature variables
if ($in_signature_seqno) {
# must be in top signature layer
my $parent = $self->parent_seqno_by_K($KK);
return if ( $parent != $in_signature_seqno );
# must be preceded by a comma or opening paren
my $Kp = $self->K_previous_code($KK);
return if ( !$Kp );
my $token_p = $rLL->[$Kp]->[_TOKEN_];
my $type_p = $rLL->[$Kp]->[_TYPE_];
return if ( $type_p ne ',' && $token_p ne '(' );
}
my $bad_name = $check_for_overlapping_variables->( $name, $KK );
return if ($bad_name);
# Store this lexical variable
my $rhash = $rblock_stack->[-1]->{rvars};
$rhash->{$name} = {
count => $my_starting_count,
line_index => $line_index,
keyword => $my_keyword,
package => $current_package,
K => $KK,
};
return;
}; ## end $checkin_new_lexical = sub
#--------------------------------------------------
# sub to update counts for a list of variable names
#--------------------------------------------------
my $update_use_count = sub {
my ( $sigil_string, $word, $bracket ) = @_;
# Given:
# $sigil_string = a string of leading sigils, like '$', '$$', '@$$'
# $word = the following bareword
# $bracket = a following array or hash bracket or brace, if any
# (token types '[' and 'L')
# Note: any braces around the bareword must have been stripped
# by the caller
# Task:
# Form the hash key ($word, @word, or %word) and update the count
return unless ($check_unused);
return unless ( defined($sigil_string) && defined($word) );
my $sigil = substr( $sigil_string, -1, 1 );
return unless ( $is_valid_sigil{$sigil} );
# Examples:
# input => key
# $var $var
# @var @var
# $var[ @var
# $var{ %var
# @$var $var
# ${var} $var (caller must remove the braces)
# @$var[0..2] $var
# @var[0..2] @var array slice
# @var{w1 w2} %var hash slice
# %var{w1 w2} %var hash slice
my $name;
if ( $bracket && length($sigil_string) == 1 ) {
if ( $bracket eq '{' ) { $sigil = '%' }
elsif ( $bracket eq '[' ) { $sigil = '@' }
else { }
}
$name = $sigil . $word;
foreach my $layer ( reverse( @{$rblock_stack} ) ) {
my $rvars = $layer->{rvars};
if ( $rvars->{$name} ) {
$rvars->{$name}->{count}++;
last;
}
}
return;
}; ## end $update_use_count = sub
my $checkin_new_constant = sub {
my ( $KK, $word ) = @_;
my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
my $rvars = {
count => 0,
line_index => $line_index,
package => $current_package,
K => $KK,
};
$rconstant_hash->{$current_package}->{$word} = $rvars;
return;
}; ## end $checkin_new_constant = sub
my $push_new_EXPORT = sub {
my ( $KK, $package ) = @_;
# Save index of any @EXPORT and @EXPORT_OK lists
$package = $current_package unless ($package);
push @{ $rEXPORT_hash->{$package} }, $KK;
return;
}; ## end $push_new_EXPORT = sub
my $scan_use_vars = sub {
my ($KK) = @_;
my $Kn = $self->K_next_code($KK);
return unless ($Kn);
my $rlist = $self->expand_quoted_word_list($Kn);
return unless ($rlist);
my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
$my_keyword = 'use vars';
foreach my $name ( @{$rlist} ) {
my $bad_name = $check_for_overlapping_variables->( $name, $KK );
next if ($bad_name);
my $rvars = {
line_index => $line_index,
package => $current_package,
K => $KK,
};
$ruse_vars_hash->{$current_package}->{$name} = $rvars;
}
return;
}; ## end $scan_use_vars = sub
my $scan_use_constant = sub {
my ($KK) = @_;
my $Kn = $self->K_next_code($KK);
return unless ($Kn);
my $type_n = $rLL->[$Kn]->[_TYPE_];
my $token_n = $rLL->[$Kn]->[_TOKEN_];
# version?
if ( $type_n eq 'n' || $type_n eq 'v' ) {
$Kn = $self->K_next_code($Kn);
$type_n = $rLL->[$Kn]->[_TYPE_];
$token_n = $rLL->[$Kn]->[_TOKEN_];
}
if ( $token_n eq '(' ) {
$Kn = $self->K_next_code($Kn);
$type_n = $rLL->[$Kn]->[_TYPE_];
$token_n = $rLL->[$Kn]->[_TOKEN_];
}
# use constant _meth1_=>1;
if ( $type_n eq 'w' ) {
$checkin_new_constant->( $Kn, $token_n );
}
# use constant '_meth1_',1;
elsif ( $type_n eq 'Q' ) {
# don't try to handle anything strange
if ( length($token_n) < 3 ) { return }
my $name = substr( $token_n, 1, -1 );
$checkin_new_constant->( $Kn, $name );
}
# use constant qw(_meth2_ 2);
elsif ( $type_n eq 'q' ) {
my $name;
if ( $token_n =~ /qw\s*.(\w+)/ ) {
$name = $1;
$checkin_new_constant->( $Kn, $name );
}
}
# A hash ref with multiple definitions:
# use constant { _meth3_=>3, _meth4_=>4};
# use constant { '_meth3_',3, '_meth4_',4};
elsif ( $type_n eq '{' && $token_n eq '{' ) {
my $seqno_n = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
return unless $seqno_n;
my $Kc = $self->[_K_closing_container_]->{$seqno_n};
return unless $Kc;
# loop to collect constants in hash ref
my $Knn = $self->K_next_code($Kn);
my $total_comma_count = 0;
my $last_type = ',';
my $level_start = $rLL->[$Knn]->[_LEVEL_];
foreach my $Kx ( $Knn .. $Kc - 1 ) {
my $type = $rLL->[$Kx]->[_TYPE_];
my $token = $rLL->[$Kx]->[_TOKEN_];
next if ( $type eq 'b' || $type eq '#' );
my $level = $rLL->[$Kx]->[_LEVEL_];
next if ( $level > $level_start );
if ( $level < $level_start ) {
## shouldn't happen
my $lno = $rLL->[$Kx]->[_LINE_INDEX_] + 1;
DEBUG_USE_CONSTANT
&& Fault("$lno: level=$level > start=$level_start\n");
return;
}
if ( $last_type eq ',' && !( $total_comma_count % 2 ) ) {
if ( $type eq 'w' ) {
$checkin_new_constant->( $Kx, $token );
}
elsif ( $type eq 'Q' ) {
if ( length($token) < 3 ) { return }
my $name = substr( $token, 1, -1 );
$checkin_new_constant->( $Kx, $name );
}
else {
my $lno = $rLL->[$Kx]->[_LINE_INDEX_] + 1;
DEBUG_USE_CONSTANT
&& Fault(
"$lno: unexpected type: type=$type token=$token\n");
return;
}
}
else {
if ( $type eq ',' || $type eq '=>' ) {
$total_comma_count++;
}
}
$last_type = $type;
}
}
elsif ( $type_n eq ';' ) {
}
else {
my $ln = $rLL->[$KK]->[_LINE_INDEX_] + 1;
DEBUG_USE_CONSTANT && Fault("$ln: unknown use constant syntax\n");
}
return;
}; ## end $scan_use_constant = sub
my $update_constant_count = sub {
my ( $KK, $word ) = @_;
if ( !defined($word) ) { $word = $rLL->[$KK]->[_TOKEN_] }
my $package = $current_package;
my $pos = rindex( $word, '::' );
if ( $pos >= 0 ) {
$package = $pos > 0 ? substr( $word, 0, $pos ) : 'main';
$word = substr( $word, $pos + 2 );
}
return if ( !defined( $rconstant_hash->{$package} ) );
my $rvars = $rconstant_hash->{$package}->{$word};
return if ( !defined($rvars) );
return if ( $KK <= $rvars->{K} );
$rvars->{count}++;
return;
}; ## end $update_constant_count = sub
#-----------------------------------------------
# sub to check for zero counts when stack closes
#-----------------------------------------------
my $check_for_unused_names = sub {
my ($rhash) = @_;
foreach my $name ( keys %{$rhash} ) {
my $entry = $rhash->{$name};
my $count = $entry->{count};
my $keyword = $entry->{keyword};
if ( !$count ) {
# typically global vars are for external access so we
# do not report them as type 'u' (unused)
next if ( $keyword eq 'our' || $keyword eq 'use vars' );
push @warnings,
{
name => $name,
keyword => $entry->{keyword},
note => EMPTY_STRING,
see_line => 0,
line_number => $entry->{line_index} + 1,
letter => 'u',
K => $entry->{K},
};
}
}
return;
}; ## end $check_for_unused_names = sub
#---------------------------------------
# sub to scan interpolated text for vars
#---------------------------------------
my $scan_quoted_text = sub {
my ($text) = @_;
return unless ($check_unused);
# Looking for something like $word, @word, $word[, $$word, ${word}, ..
while ( $text =~ / ([\$\@] [\$]*) \{?(\w+)\}? ([\[\{]?) /gcx ) {
## ------1------ -2- ---3---
my $sigil_string = $1;
my $word = $2;
my $brace = $3;
$update_use_count->( $sigil_string, $word, $brace );
} ## end while ( $text =~ ...)
return;
}; ## end $scan_quoted_text = sub
#-------------------------------------------------------------
# sub to find the next opening brace seqno of an if-elsif- chain
#-------------------------------------------------------------
my $push_next_if_chain = sub {
my ( $KK, $rpopped_vars ) = @_;
# Given:
# $KK = index of a closing block brace of if/unless/elsif chain
# $rpopped_vars = values just popped off the stack
# Task:
# - do nothing if chain ends, or
# - push $rpopped_vars onto the next block in the chain
# $seqno_block = sequence number of next opening block in the chain,
my $seqno_block;
my $K_n = $self->K_next_code($KK);
return unless ($K_n);
return unless ( $rLL->[$K_n]->[_TYPE_] eq 'k' );
# For an 'elsif' the brace will be after the closing paren
# 'elsif (..) { ... }'
# ^ ^
# | |
# --$KK --$seqno of brace that we want
#
if ( $rLL->[$K_n]->[_TOKEN_] eq 'elsif' ) {
( $seqno_block, my $K_last_iterator_uu ) =
$self->block_seqno_of_paren_keyword($K_n);
}
# For an 'else' the brace will be the next token
# 'else { ... }'
# ^ ^
# | |
# --$KK --$seqno of brace that we want
#
elsif ( $rLL->[$K_n]->[_TOKEN_] eq 'else' ) {
my $K_nn = $self->K_next_code($K_n);
if ( $K_nn
&& $is_opening_token{ $rLL->[$K_nn]->[_TOKEN_] } )
{
$seqno_block = $rLL->[$K_nn]->[_TYPE_SEQUENCE_];
}
}
else {
# chain ends if no elsif/else block
}
if ( $seqno_block
&& $rblock_type_of_seqno->{$seqno_block} )
{
$push_block_stack->( $seqno_block, $rpopped_vars );
}
return;
}; ## end $push_next_if_chain = sub
my $scan_braced_id = sub {
my ($KK) = @_;
# We are at an opening brace and looking for something like this:
# @{word}[@var]
# ${word}
# ^
# |
# -- $KK
return unless ($check_unused);
# Look back for the sigil
my $Kp = $self->K_previous_code($KK);
return unless ( defined($Kp) && $rLL->[$Kp]->[_TYPE_] eq 't' );
my $sigil_string = $rLL->[$Kp]->[_TOKEN_];
# Look forward for the bareword
my $Kn = $self->K_next_code($KK);
return unless ( defined($Kn) && $rLL->[$Kn]->[_TYPE_] eq 'w' );
my $word = $rLL->[$Kn]->[_TOKEN_];
# Look forward for the closing brace
my $Knn = $self->K_next_code($Kn);
return unless ( defined($Knn) && $rLL->[$Knn]->[_TYPE_] eq 'R' );
# Look forward for a possible { or [
my $bracket;
my $Knnn = $self->K_next_code($Knn);
if ( defined($Knnn) ) {
my $next_type = $rLL->[$Knnn]->[_TYPE_];
if ( $next_type eq 'L' || $next_type eq '[' ) {
$bracket = $rLL->[$Knnn]->[_TOKEN_];
}
}
$update_use_count->( $sigil_string, $word, $bracket );
return;
}; ## end $scan_braced_id = sub
my $check_sub_signature = sub {
my ($KK) = @_;
# looking for a sub signature
# sub xxx (...) {
# -------
# | | | |
# $KK $Kn | |
# $K_opening_brace
# Note: this version cannot handle signatures within signatures.
# Inner signatures are currently ignored. For example, only the
# outermost $a below will be checked in this line:
# sub xyz ($a = sub ($a) { $a."z" }) { $a->("a")."y" }
# What happens is that variable $K_end_my is set by the first
# signature, and the second signature is within it and so does
# not get activated. A stack scheme would be necessary to handle
# this, but does not seem necessary because this probably only
# occurs in test code, and the only downside is that we limit
# some checking.
my $Kn = $self->K_next_code($KK);
return unless ( $rLL->[$Kn]->[_TOKEN_] eq '(' );
my $seqno_paren = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
return unless ($seqno_paren);
my $K_closing_paren = $self->[_K_closing_container_]->{$seqno_paren};
my $K_opening_brace = $self->K_next_code($K_closing_paren);
return unless ($K_opening_brace);
my $seqno_brace = $rLL->[$K_opening_brace]->[_TYPE_SEQUENCE_];
my $token_brace = $rLL->[$K_opening_brace]->[_TOKEN_];
return unless ( $seqno_brace && $token_brace eq '{' );
# Treat signature variables like my variables
# Create special block on the stack..see note above for
# $is_if_unless
if ( $K_opening_brace > $K_end_my ) {
$K_end_my = $K_opening_brace;
$my_keyword = 'sub signature';
$in_signature_seqno = $seqno_paren;
$push_block_stack->($seqno_brace);
}
return;
}; ## end $check_sub_signature = sub
my $rkeyword_count = {};
my $rline_type_count = {};
#--------------------
# Loop over all lines
#--------------------
my $ix_line = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$ix_line++;
my $line_type = $line_of_tokens->{_line_type};
if ( $line_type ne 'CODE' ) {
$rline_type_count->{$line_type}++;
next;
}
my ( $Kfirst, $Klast ) = @{ $line_of_tokens->{_rK_range} };
next unless defined($Kfirst);
#----------------------------------
# Loop over all tokens on this line
#----------------------------------
foreach my $KK ( $Kfirst .. $Klast ) {
my $type = $rLL->[$KK]->[_TYPE_];
next if ( $type eq 'b' || $type eq '#' );
my $token = $rLL->[$KK]->[_TOKEN_];
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($seqno) {
my $block_type;
$block_type = $rblock_type_of_seqno->{$seqno} if ($seqno);
my $is_on_stack = ( $seqno == $rblock_stack->[-1]->{seqno} );
if ( $is_opening_token{$token} ) {
# always push a block
if ($block_type) {
# exit signature if we will push a duplicate block
if ( $in_signature_seqno
&& @{$rblock_stack}
&& $seqno == $rblock_stack->[-1]->{seqno} )
{
$in_signature_seqno = 0;
}
$push_block_stack->($seqno);
# update sub count for cross-package checks
if ( $ris_sub_block->{$seqno} ) {
$sub_count_by_package{$current_package}++;
}
}
# look for something like @{word} etc
if ( $type eq 'L' ) {
$scan_braced_id->($KK);
}
}
elsif ( $is_closing_token{$token} ) {
# always pop the stack if this token is on the stack
if ($is_on_stack) {
my $stack_item = pop @{$rblock_stack};
my $rpopped_vars = $stack_item->{rvars};
# if we popped a block token
if ($block_type) {
# the current package gets updated at a block end
$current_package = $stack_item->{package};
# Check for unused vars if requested
if ( $check_unused && $rpopped_vars ) {
$check_for_unused_names->($rpopped_vars);
}
# Check for and propagate an if-chain control layer,
# which will have the same seqno.
if ( @{$rblock_stack}
&& $seqno == $rblock_stack->[-1]->{seqno} )
{
# pop again
$stack_item = pop @{$rblock_stack};
$rpopped_vars = $stack_item->{rvars};
# Check unused vars
# - except for vars in an if-chain control layer
# because they are involved in logic
if ( $check_unused
&& $rpopped_vars
&& !$is_if_unless_elsif_else{$block_type} )
{
$check_for_unused_names->($rpopped_vars);
}
# propagate control layer along if chain
if ( $is_if_unless_elsif{$block_type} ) {
$push_next_if_chain->( $KK, $rpopped_vars );
}
}
}
# error if we just popped a non-block token:
else {
my $K_n = $self->K_next_code($KK);
my $token_n = $rLL->[$K_n]->[_TOKEN_];
my $lno = $ix_line + 1;
DEVEL_MODE && Fault(<[-1]->{seqno};
DEVEL_MODE
&& Fault(
"stack error: seqno=$seqno ne $stack_seqno near line $lno\n"
);
# give up - file may be unbalanced
return;
}
else {
# not a block, not on stack: nothing to do
}
}
else {
# ternary
}
}
#----------
# a keyword
#----------
elsif ( $type eq 'k' ) {
#----------------------------------------------
# look for lexical keyword 'my', 'state', 'our'
#----------------------------------------------
if ( $is_my_state_our{$token} ) {
$my_keyword = $token;
# Set '$K_end_my' to be the last $K index of the variables
# controlled by this 'my' keyword
my $Kn = $self->K_next_code($KK);
$K_end_my = $Kn;
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '(' ) {
my $seqno_next = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
$K_end_my = $K_closing_container->{$seqno_next};
}
# Get initial count
$my_starting_count = 0;
my $K_last_code = $self->K_previous_code($KK);
if ( defined($K_last_code) ) {
my $last_type = $rLL->[$K_last_code]->[_TYPE_];
# A preceding \ implies that this memory can be used
# even if the variable name does not appear again.
# For example: return \my $string_buf;
if ( $last_type eq '\\' ) { $my_starting_count = 1 }
}
}
#--------------------------------------------------
# look for certain keywords which introduce blocks:
# such as 'for my $var (..) { ... }'
#--------------------------------------------------
elsif ( $is_if_unless_while_until_for_foreach{$token} ) {
my ( $seqno_brace, $K_end_iterator ) =
$self->block_seqno_of_paren_keyword($KK);
if ($seqno_brace) {
# Found the brace. Mark an iterator as a new lexical
# variable in order to catch something like:
# my $i;
# foreach $i(...) { }
# where the iterator $i is not the same as the first
# $i, We should be beyond any existing $K_end_my, but
# check anyway:
if ( $K_end_iterator && $K_end_iterator > $K_end_my ) {
$K_end_my = $K_end_iterator;
$my_keyword = $token;
}
# Variables created between these keywords and their
# opening brace have special scope rules. We will
# create a special 'control layer' stack entry for them
# here, with the same block sequence number. When the
# closing block brace arrives, it will look for a
# duplicate stack entry and either close it or,
# for if-elsif-else chain, propagate it onward.
$push_block_stack->($seqno_brace);
}
}
elsif ( $token eq 'sub' ) {
$check_sub_signature->($KK);
}
else {
$rkeyword_count->{$token}++;
}
}
#--------------
# an identifier
#--------------
elsif ( $type eq 'i' || $type eq 'Z' ) {
# Still collecting 'my' vars?
if ( $KK <= $K_end_my ) {
$checkin_new_lexical->($KK);
}
# Not collecting 'my' vars - update counts
elsif ( $check_unused || $check_constant ) {
my $sigil_string = EMPTY_STRING;
my $word = EMPTY_STRING;
# The regex below will match numbers, like '$34x', but that
# should not be a problem because it will not match a hash
# key.
if ( $token =~ /^(\W+)?(\w.*)$/ ) {
$sigil_string = $1 if ($1);
$word = $2;
if ( $check_constant && $word ) {
# look for constant invoked like '&ORD' or '->ORD'
if ( !$sigil_string || $sigil_string eq '&' ) {
$update_constant_count->( $KK, $word );
}
elsif ( $sigil_string eq '@'
&& index( $word, 'EXPORT' ) >= 0 )
{
# Looking for stuff like:
# @EXPORT_OK
# @ALPHA::BETA::EXPORT
my $package = $current_package;
my $name = $word;
my $pos = rindex( $word, '::' );
if ( $pos >= 0 ) {
$package = substr( $word, 0, $pos );
$name = substr( $word, $pos + 2 );
}
if ( $name eq 'EXPORT' || $name eq 'EXPORT_OK' )
{
$push_new_EXPORT->( $KK, $package );
}
}
else { }
}
if ($sigil_string) {
my $sigil = substr( $sigil_string, -1, 1 );
if ( !$is_valid_sigil{$sigil} ) {
$sigil_string = EMPTY_STRING;
$word = EMPTY_STRING;
}
}
}
if ( $check_unused
&& $sigil_string
&& $word
&& $word =~ /\w+/ )
{
my $Kn = $self->K_next_code($KK);
my $bracket;
if ( defined($Kn) ) {
my $next_type = $rLL->[$Kn]->[_TYPE_];
if ( $next_type eq '[' || $next_type eq 'L' ) {
$bracket = $rLL->[$Kn]->[_TOKEN_];
}
}
$update_use_count->( $sigil_string, $word, $bracket );
}
}
else {
# ignore variable if not collecting 'my' or counts
}
}
#----------------
# a sub statement
#----------------
elsif ( $type eq 'S' ) {
$check_sub_signature->($KK);
}
#--------------------
# a package statement
#--------------------
elsif ( $type eq 'P' ) {
my ( $keyword, $package ) = split /\s+/, $token, 2;
# keyword 'package' may be on a previous line
if ( !$package ) { $package = $keyword }
if ( $package ne $current_package ) {
$current_package = $package;
# Look for lexical vars declared in other packages which
# will be accessible in this package. We will limit
# this check to new package statements at the top level
# in order to filter out some common cases.
if ( $check_cross_package && @{$rblock_stack} == 1 ) {
my $rpackage_warnings = $package_warnings{$package};
if ( !defined($rpackage_warnings) ) {
$rpackage_warnings = [];
$package_warnings{$package} = $rpackage_warnings;
}
foreach my $item ( @{$rblock_stack} ) {
my $rhash = $item->{rvars};
foreach my $name ( keys %{$rhash} ) {
my $entry = $rhash->{$name};
my $pkg = $entry->{package};
if ( $pkg ne $package ) {
my $lno = $ix_line + 1;
my $see_line = $lno;
my $note =
"is accessible in later packages, see line $see_line";
push @{$rpackage_warnings},
{
name => $name,
keyword => $entry->{keyword},
note => $note,
see_line => $see_line,
line_number => $entry->{line_index} + 1,
letter => 'p',
K => $entry->{K},
};
}
}
}
}
}
}
#-----------
# a here doc
#-----------
elsif ( $type eq 'h' ) {
# scan here-doc if it is interpolated
if ( $check_unused && is_interpolated_here_doc($token) ) {
my $ix_HERE = max( $ix_HERE_END, $ix_line );
# collect the here doc text
( $ix_HERE_END, my $here_text ) =
$self->get_here_text($ix_HERE);
# scan the here-doc text
$scan_quoted_text->($here_text);
}
}
#---------------------
# a quote of some type
#---------------------
elsif ( $type eq 'Q' ) {
# is this an interpolated quote?
my $interpolated;
if ( $KK == $Kfirst && $line_of_tokens->{_starting_in_quote} ) {
$interpolated = $in_interpolated_quote;
}
else {
# is interpolated if it follow a match operator =~ or !~
my $K_last_code = $self->K_previous_code($KK);
if ( $K_last_code
&& $is_re_match_op{ $rLL->[$K_last_code]->[_TYPE_] } )
{
$interpolated = 1;
}
# is not interpolated for leading operators: qw q tr y '
elsif ( $token =~ /^(qw | q[^qrx] | tr | [y\'] )/x ) {
$interpolated = 0;
}
# is interpolated for everything else
else {
$interpolated = 1;
}
}
if ($interpolated) {
$scan_quoted_text->($token);
}
if ( $KK == $Klast && $line_of_tokens->{_ending_in_quote} ) {
$in_interpolated_quote = $interpolated;
}
else {
$in_interpolated_quote = 0;
}
}
elsif ( $type eq 'w' ) {
if ( $token eq 'vars' ) {
my $Kp = $self->K_previous_code($KK);
if ( defined($Kp)
&& $rLL->[$Kp]->[_TOKEN_] eq 'use'
&& $rLL->[$Kp]->[_TYPE_] eq 'k' )
{
$scan_use_vars->($KK);
}
}
if ($check_constant) {
if ( $token eq 'constant' ) {
my $Kp = $self->K_previous_code($KK);
if ( defined($Kp)
&& $rLL->[$Kp]->[_TOKEN_] eq 'use'
&& $rLL->[$Kp]->[_TYPE_] eq 'k' )
{
$scan_use_constant->($KK);
}
else {
$update_constant_count->($KK);
}
}
else {
$update_constant_count->($KK);
}
}
}
elsif ( $type eq 'C' ) {
if ($check_constant) {
$update_constant_count->($KK);
}
}
elsif ( $type eq 'U' ) {
if ($check_constant) {
$update_constant_count->($KK);
}
}
else {
# skip all other token types
}
}
}
#----------
# Finish up
#----------
# skip final 'c' and 'u' output if this appears to be a snippet
my $is_possible_snippet = $roption->{is_possible_snippet};
my $more_u_checks =
$check_unused
&& @{$rblock_stack} == 1
&& keys %{ $rblock_stack->[0]->{rvars} };
my $more_c_checks = $check_constant && keys %{$rconstant_hash};
if ( $is_possible_snippet
&& ( $more_u_checks || $more_c_checks ) )
{
# the flag $is_possible_snippet = 0:No 1:Uncertain 2:Yes
if ( $is_possible_snippet == 1
&& $self->is_complete_script( $rline_type_count, $rkeyword_count ) )
{
# not a snippet
}
# is possible snippet: deactivate 'c' and 'u
else {
$check_unused = 0;
$check_constant = 0;
}
}
if ( @{$rblock_stack} != 1 ) {
# shouldn't happen for a balanced input file
DEVEL_MODE && Fault("stack error at end of scan\n");
}
else {
if ($check_unused) {
foreach my $item ( @{$rblock_stack} ) {
my $rhash = $item->{rvars};
$check_for_unused_names->($rhash);
}
}
}
if ($check_constant) {
my @warnings_c;
my %packages_with_warnings;
foreach my $package ( keys %{$rconstant_hash} ) {
my $rhash = $rconstant_hash->{$package};
next if ( !defined($rhash) );
foreach my $name ( keys %{$rhash} ) {
my $entry = $rconstant_hash->{$package}->{$name};
next if ( $entry->{count} );
push @warnings_c,
{
name => $name,
keyword => 'use constant',
see_line => EMPTY_STRING,
note => "appears unused in package $package",
line_number => $entry->{line_index} + 1,
letter => 'c',
package => $package,
K => $entry->{K},
};
$packages_with_warnings{$package} = 1;
}
}
# filter out constants found in @EXPORT and @EXPORT_OK
if (@warnings_c) {
# expand relevant EXPORT lists
my $rEXPORT_words_by_package = {};
foreach my $package ( keys %packages_with_warnings ) {
my $rKlist = $rEXPORT_hash->{$package};
next unless ($rKlist);
$rEXPORT_words_by_package->{$package} = {};
foreach my $KK ( @{$rKlist} ) {
$self->expand_EXPORT_list( $KK,
$rEXPORT_words_by_package->{$package} );
}
}
# remove warnings in EXPORT lists
foreach my $rwarning (@warnings_c) {
my $package = $rwarning->{package};
my $name = $rwarning->{name};
my $rhash = $rEXPORT_words_by_package->{$package};
next if ( $rhash && $rhash->{$name} );
push @warnings, $rwarning;
}
}
}
# Merge package issues...
# Only include cross-package warnings for packages which created subs.
# This will limit this type of warning to significant package changes.
my @p_warnings;
foreach my $key ( keys %package_warnings ) {
next if ( !$sub_count_by_package{$key} );
push @p_warnings, @{ $package_warnings{$key} };
}
# Remove duplicate package warnings for the same initial line, which can
# happen if there were multiple packages.
if (@p_warnings) {
my %seen;
# sort on package warning line order
@p_warnings = sort { $a->{see_line} <=> $b->{see_line} } @p_warnings;
# use first package warning for a given variable
foreach my $item (@p_warnings) {
my $key = $item->{line_number} . ':' . $item->{name};
next if ( $seen{$key}++ );
push @warnings, $item;
}
}
if (@warnings) {
# filter out certain common 'our' variables from all warnings
# because they are common and difficult to fix, and
# sort on token index and issue type
my %is_exempted_global_name;
my @q = qw( $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA $AUTOLOAD );
@is_exempted_global_name{@q} = (1) x scalar(@q);
@warnings =
sort { $a->{K} <=> $b->{K} || $a->{letter} cmp $b->{letter} }
# FIXME: this limitation may eventually just be for 'our' vars
# after 'use vars' coding is finalized
grep {
( $_->{keyword} ne 'our' && $_->{keyword} ne 'use vars' )
|| !$is_exempted_global_name{ $_->{name} }
} @warnings;
}
return ( \@warnings, $issue_type_string );
} ## end sub scan_variable_usage
sub dump_unusual_variables {
my ($self) = @_;
# process a --dump-unusual-variables(-duv) command
my ( $rlines, $issue_type_string ) = $self->scan_variable_usage();
return unless ( $rlines && @{$rlines} );
my $input_stream_name = get_input_stream_name();
# output for multiple types
my $output_string = <{line_number};
my $letter = $item->{letter};
my $keyword = $item->{keyword};
my $name = $item->{name};
my $note = $item->{note};
if ($note) { $note = ": $note" }
$output_string .= "$lno:$letter: $keyword $name$note\n";
}
print {*STDOUT} $output_string;
return;
} ## end sub dump_unusual_variables
sub initialize_warn_hash {
my ( $long_name, $default, $rall_opts ) = @_;
# Given:
# $long_name = full option name
# $default = default value
# $rall_opts = all possible options
# Return the corresponding option hash
# Example of all possible options for --warn-variable-types=s
# r - reused scope
# s - reused sigil
# p - package boundaries crossed by lexical variables
# u - unused lexical variable defined by my, state, our
# c - unused constant defined by use constant
# Other warn options use different letters
# Other controls:
# 0 - none of the above
# 1 - all of the above
# * - all of the above
# Example:
# -wvt='s r' : do check types 's' and 'r'
my $rwarn_hash = {};
if ( !$rall_opts || !@{$rall_opts} ) {
Fault("all_options is empty for call with option $long_name\n");
return $rwarn_hash;
}
my $user_option_string = $rOpts->{$long_name};
if ( !defined($user_option_string) ) { $user_option_string = $default }
return $rwarn_hash unless ($user_option_string);
my %is_valid_option;
@is_valid_option{ @{$rall_opts} } = (1) x scalar( @{$rall_opts} );
# allow comma separators
$user_option_string =~ s/,/ /g;
my @opts = split_words($user_option_string);
return $rwarn_hash unless (@opts);
# check a single item
if ( @opts == 1 ) {
my $opt = $opts[0];
# Split a single option of bundled letters like 'rsp' into 'r s p'
# but give a warning because this may not be allowed in the future
if ( length($opt) > 1 ) {
@opts = split //, $opt;
Warn("Please use space-separated letters in --$long_name\n");
}
elsif ( $opt eq '*' || $opt eq '1' ) {
@opts = keys %is_valid_option;
}
elsif ( $opt eq '0' ) {
return $rwarn_hash;
}
else {
# should be one of the allowed letters - catch any error below
}
}
my $msg = EMPTY_STRING;
foreach my $opt (@opts) {
if ( $is_valid_option{$opt} ) {
$rwarn_hash->{$opt} = 1;
next;
}
# invalid option..
if ( $opt =~ /^[01\*]$/ ) {
$msg .=
"--$long_name cannot contain $opt mixed with other options\n";
}
else {
$msg .= "--$long_name has unexpected symbol: '$opt'\n";
}
}
if ($msg) { Die($msg) }
return $rwarn_hash;
} ## end sub initialize_warn_hash
sub make_excluded_name_hash {
my ($option_name) = @_;
# Convert a list of words into a hash ref for an input option
# Given:
# $option_name = the name of an input option
# example: 'warn-variable-exclusion-list'
my $rexcluded_name_hash = {};
my $excluded_names = $rOpts->{$option_name};
if ($excluded_names) {
$excluded_names =~ s/,/ /g;
my @xl = split_words($excluded_names);
my $err_msg = EMPTY_STRING;
foreach my $name (@xl) {
if ( $name =~ /^([\$\@\%\*])?(\w+)?(\*)?$/ ) {
my $left_star = $1;
my $key = $2;
my $right_star = $3;
if ( defined($left_star) ) {
if ( $left_star ne '*' ) {
if ( defined($key) ) {
# append sigil to the bareword
$key = $left_star . $key;
}
else {
# word not given: '$*' is ok but just '$' is not
if ($right_star) { $key = $left_star }
}
$left_star = EMPTY_STRING;
}
}
# Wildcard matching codes:
# 1 = no stars
# 2 = left star only
# 3 = right star only
# 4 = both left and right stars
my $code = 1;
$code += 1 if ($left_star);
$code += 2 if ($right_star);
if ( !defined($key) ) {
$err_msg .= "--$option_name has unexpected name: '$name'\n";
}
else {
$rexcluded_name_hash->{$key} = $code;
}
}
else {
$err_msg .= "--$option_name has unexpected name: '$name'\n";
}
}
if ($err_msg) { Die($err_msg) }
}
return $rexcluded_name_hash;
} ## end sub make_excluded_name_hash
sub wildcard_match {
my ( $name, $rwildcard_match_list ) = @_;
# Given:
# $name = a string to test for a match
# $rwildcard_match_list = a list of [key,code] pairs:
# key = a string to match
# code = 2, 3, or 4 is match type (see comments below)
# Return:
# true for a match
# false for no match
# For example, key='$pack' with code=3 is short for '$pack*'
# which will match '$package', '$packer', etc
# Loop over all possible matches
foreach ( @{$rwildcard_match_list} ) {
my ( $key, $code ) = @{$_};
my $len_key = length($key);
my $len_name = length($name);
next if ( $len_name < $len_key );
# code 2 = left star only
if ( $code == 2 ) {
if ( substr( $name, -$len_key, $len_key ) eq $key ) { return 1 }
}
# code 3 = right star only
elsif ( $code == 3 ) {
if ( substr( $name, 0, $len_key ) eq $key ) { return 1 }
}
# code 4 = both left and right stars
elsif ( $code == 4 ) {
if ( index( $name, $key, 0 ) >= 0 ) { return 1 }
}
else {
DEVEL_MODE && Fault("unexpected code '$code' for '$name'\n");
}
}
return;
} ## end sub wildcard_match
sub initialize_warn_variable_types {
my ( $wvt_in_args, $num_files, $line_range_clipped ) = @_;
# Initialization for:
# --warn-variable-types=s and
# --warn-variable-exclusion-list=s
# Given:
# $wvt_in_args = true if the -wvt parameter was on the command line
# $num_files = number of files on the command line
# $line_range_clipped = true if only part of a file is being formatted
my @all_opts = qw( r s p u c );
$rwarn_variable_types =
initialize_warn_hash( 'warn-variable-types', 0, \@all_opts );
# Check for issues 'u' or 'c' cannot be fully made if we are working
# on a partial file (snippet), so we save info about that.
if ( $rwarn_variable_types->{u} || $rwarn_variable_types->{c} ) {
# Three value switch: 0=NO, 1=MAYBE 2=DEFINITELY
my $is_possible_snippet = 1;
# assume snippet if incomplete line range is being formatted
if ($line_range_clipped) {
$is_possible_snippet = 2;
}
# assume complete script if operating on multiple files or if
# operating on one file and -wvt came in on the command line
if ( $is_possible_snippet == 1 && $num_files ) {
if ( $num_files > 1 || $wvt_in_args && $num_files ) {
$is_possible_snippet = 0;
}
}
$rwarn_variable_types->{is_possible_snippet} = $is_possible_snippet;
}
$ris_warn_variable_excluded_name =
make_excluded_name_hash('warn-variable-exclusion-list');
return;
} ## end sub initialize_warn_variable_types
sub filter_excluded_names {
my ( $rwarnings, $rexcluded_name_hash ) = @_;
# Remove warnings for variable names excluded by user request
# for an operation like --warn-variable-types
# Given:
# $rwarnigns = ref to list of warning info hashes
# $rexcluded_name_hash = ref to hash with excluded names
# Return updated $rwarnings with excluded names removed
if ( @{$rwarnings} && $rexcluded_name_hash ) {
# Check for exact matches
$rwarnings =
[ grep { !$rexcluded_name_hash->{ $_->{name} } } @{$rwarnings} ];
# See if there are any wildcard names
my @excluded_wildcards;
foreach my $key ( keys %{$rexcluded_name_hash} ) {
my $code = $rexcluded_name_hash->{$key};
if ( $code != 1 ) {
push @excluded_wildcards, [ $key, $code ];
}
}
if (@excluded_wildcards) {
my @tmp;
foreach my $item ( @{$rwarnings} ) {
my $name = $item->{name};
if ( wildcard_match( $name, \@excluded_wildcards ) ) {
next;
}
push @tmp, $item;
}
$rwarnings = \@tmp;
}
}
return $rwarnings;
} ## end sub filter_excluded_names
sub warn_variable_types {
my ($self) = @_;
# process a --warn-variable-types command
my $wv_key = 'warn-variable-types';
my $wv_option = $rOpts->{$wv_key};
return unless ( %{$rwarn_variable_types} );
my ( $rwarnings, $issue_type_string ) =
$self->scan_variable_usage($rwarn_variable_types);
return unless ( $rwarnings && @{$rwarnings} );
$rwarnings =
filter_excluded_names( $rwarnings, $ris_warn_variable_excluded_name );
# loop to form error messages
my $message_middle = EMPTY_STRING;
foreach my $item ( @{$rwarnings} ) {
my $name = $item->{name};
my $lno = $item->{line_number};
my $letter = $item->{letter};
my $keyword = $item->{keyword};
my $note = $item->{note};
if ($note) { $note = ": $note" }
$message_middle .= "$lno:$letter: $keyword $name$note\n";
}
if ($message_middle) {
my $message = "Begin scan for --$wv_key=$wv_option\n";
$message .= < return sequno of this brace
# | K_closing_paren
# $seqno_paren = seqno of this paren pair
return unless $seqno_paren;
my $K_closing_paren = $self->[_K_closing_container_]->{$seqno_paren};
return unless ($K_closing_paren);
my $K_opening_brace = $self->K_next_code($K_closing_paren);
return unless ($K_opening_brace);
my $rLL = $self->[_rLL_];
my $seqno_block = $rLL->[$K_opening_brace]->[_TYPE_SEQUENCE_];
return
unless ( $seqno_block
&& $rLL->[$K_opening_brace]->[_TOKEN_] eq '{'
&& $self->[_rblock_type_of_seqno_]->{$seqno_block} );
return $seqno_block;
} ## end sub block_seqno_of_paren_seqno
sub dump_mixed_call_parens {
my ($self) = @_;
# Implent --dump-mixed-call-parens
my $opt_name = 'dump-mixed-call-parens';
return unless $rOpts->{$opt_name};
my $rLL = $self->[_rLL_];
my %skip_keywords;
my @q = qw( my our local state
and cmp continue do else elsif eq ge gt le lt ne not or xor );
@skip_keywords{@q} = (1) x scalar(@q);
my %call_counts;
foreach my $KK ( 0 .. @{$rLL} - 1 ) {
# Types which will be checked:
# 'k'=builtin keyword, 'U'=user defined sub, 'w'=unknown bareword
next unless ( $is_kwU{ $rLL->[$KK]->[_TYPE_] } );
my $type = $rLL->[$KK]->[_TYPE_];
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $type eq 'k' && $skip_keywords{$token} ) { next }
my $Kn = $self->K_next_code($KK);
next unless defined($Kn);
my $token_Kn = $rLL->[$Kn]->[_TOKEN_];
my $have_paren;
if ( $token_Kn eq '=>' ) { next }
elsif ( $token_Kn eq '->' ) { next }
elsif ( $token_Kn eq '(' ) { $have_paren = 1 }
else { $have_paren = 0 }
# return if this is the block form of 'if', 'unless', ..
if ( $have_paren
&& $is_if_unless_while_until_for_foreach{$token} )
{
my $seqno = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
next if ( $self->block_seqno_of_paren_seqno($seqno) );
}
if ( !defined( $call_counts{$token} ) ) {
$call_counts{$token} = [ 0, 0, $type ];
}
$call_counts{$token}->[$have_paren]++;
}
my @mixed_counts;
foreach my $key ( keys %call_counts ) {
my ( $no_count, $yes_count, $type ) = @{ $call_counts{$key} };
next unless ( $no_count && $yes_count );
push @mixed_counts,
{
name => $key,
type => $type,
no_count => $no_count,
yes_count => $yes_count,
};
}
return unless (@mixed_counts);
# sort on lc of type so that user sub type 'U' will come after 'k'
my @sorted =
sort { lc $a->{type} cmp lc $b->{type} || $a->{name} cmp $b->{name} }
@mixed_counts;
my $input_stream_name = get_input_stream_name();
my $output_string = <{type};
my $name = $item->{name};
my $no_count = $item->{no_count};
my $yes_count = $item->{yes_count};
$output_string .= "$type:$name:$yes_count:$no_count\n";
}
print {*STDOUT} $output_string;
return;
} ## end sub dump_mixed_call_parens
sub initialize_call_paren_style {
# parse --want-call-parens=s and --nowant-call-parens=s
# and store results in this global hash:
%call_paren_style = ();
my $iter = -1;
foreach my $opt_name ( 'nowant-call-parens', 'want-call-parens' ) {
$iter++;
my $opt = $rOpts->{$opt_name};
next unless defined($opt);
# allow comma separators
$opt =~ s/,/ /g;
if ( my @q = split_words($opt) ) {
foreach my $word (@q) {
# words must be simple identifiers, or '&'
if ( $word !~ /^(?:\&|\w+)$/ || $word =~ /^\d/ ) {
Die("Unexpected word in --$opt_name: '$word'\n");
}
if ( $iter && defined( $call_paren_style{$word} ) ) {
Warn("'$word' occurs in both -nwcp and -wcp, using -wcp\n");
}
}
@call_paren_style{@q} = ($iter) x scalar(@q);
}
}
return;
} ## end sub initialize_call_paren_style
sub scan_call_parens {
my ($self) = @_;
# Perform a scan requested by --want-call-parens
# We search for selected functions or keywords and for a following paren.
# A warning is issued if the paren existence is not what is wanted
# according to the setting --want-call-parens.
# This routine does not attempt to add or remove parens, it merely
# issues a warning so that the user can make a change if desired.
# It is risky to add or delete parens automatically; see git #128.
return unless (%call_paren_style);
my $opt_name = 'want-call-parens';
my $rwarnings = [];
#---------------------
# Loop over all tokens
#---------------------
my $rLL = $self->[_rLL_];
foreach my $KK ( 0 .. @{$rLL} - 1 ) {
# Types which will be checked:
# 'k'=builtin keyword, 'U'=user defined sub, 'w'=unknown bareword
next unless ( $is_kwU{ $rLL->[$KK]->[_TYPE_] } );
# Are we looking for this word?
my $type = $rLL->[$KK]->[_TYPE_];
my $token = $rLL->[$KK]->[_TOKEN_];
my $want_paren = $call_paren_style{$token};
# Only user-defined subs (type 'U') have defaults.
if ( !defined($want_paren) ) {
$want_paren =
$type eq 'k' ? undef
: $type eq 'U' ? $call_paren_style{'&'}
: undef;
}
next unless defined($want_paren);
# This is a selected word. Look for a '(' at the next token.
my $Kn = $self->K_next_code($KK);
next unless defined($Kn);
my $token_Kn = $rLL->[$Kn]->[_TOKEN_];
if ( $token_Kn eq '=>' ) { next }
elsif ( $token_Kn eq '->' ) { next }
elsif ( $token_Kn eq '(' ) { next if ($want_paren) }
else { next if ( !$want_paren ) }
# return if this is the block form of 'if', 'unless', ..
if ( $token_Kn eq '('
&& $is_if_unless_while_until_for_foreach{$token} )
{
my $seqno = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
next if ( $self->block_seqno_of_paren_seqno($seqno) );
}
# This disagrees with the wanted style; issue a warning.
my $note = $want_paren ? "no call parens" : "has call parens";
my $rwarning = {
token => $token,
token_next => $token_Kn,
want => $want_paren,
note => $note,
line_number => $rLL->[$KK]->[_LINE_INDEX_] + 1,
KK => $KK,
Kn => $Kn,
};
push @{$rwarnings}, $rwarning;
}
# Report any warnings
if ( @{$rwarnings} ) {
my $message = "Begin scan for --$opt_name\n";
$message .= <{token};
my $token_next = $item->{token_next};
my $note = $item->{note};
my $lno = $item->{line_number};
# trim long tokens for the output line
if ( length($token_next) > 23 ) {
$token_next = substr( $token_next, 0, 20 ) . '...';
}
# stop before a ':' to allow use of ':' as spreadsheet col separator
my $ii = index( $token_next, ':' );
if ( $ii >= 0 ) { $token_next = substr( $token_next, 0, $ii ) }
$message .= "$lno:$token $token_next: $note\n";
}
$message .= "End scan for --$opt_name\n";
# Note that this is sent in a single call to warning() in order
# to avoid triggering a stop on large warning count
warning($message);
}
return;
} ## end sub scan_call_parens
sub find_non_indenting_braces {
my ( $self, $rix_side_comments ) = @_;
# Find and mark all non-indenting braces in this file.
# Given:
# $rix_side_comments = index of lines which have side comments
# Find and save the line indexes of these special side comments in:
# $self->[_rseqno_non_indenting_brace_by_ix_];
# Non-indenting braces are opening braces of the form
# { #<<< ...
# which do not cause an increase in indentation level.
# They are enabled with the --non-indenting-braces, or -nib, flag.
return unless ( $rOpts->{'non-indenting-braces'} );
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $rlines = $self->[_rlines_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $rseqno_non_indenting_brace_by_ix =
$self->[_rseqno_non_indenting_brace_by_ix_];
foreach my $ix ( @{$rix_side_comments} ) {
my $line_of_tokens = $rlines->[$ix];
my $line_type = $line_of_tokens->{_line_type};
if ( $line_type ne 'CODE' ) {
# shouldn't happen
DEVEL_MODE && Fault("unexpected line_type=$line_type\n");
next;
}
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
if ( !defined($Kfirst) || $rLL->[$Klast]->[_TYPE_] ne '#' ) {
# shouldn't happen
DEVEL_MODE && Fault("did not get a comment\n");
next;
}
next if ( $Klast <= $Kfirst ); # maybe HSC
my $token_sc = $rLL->[$Klast]->[_TOKEN_];
my $K_m = $Klast - 1;
my $type_m = $rLL->[$K_m]->[_TYPE_];
if ( $type_m eq 'b' && $K_m > $Kfirst ) {
$K_m--;
$type_m = $rLL->[$K_m]->[_TYPE_];
}
my $seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_];
if ($seqno_m) {
my $block_type_m = $rblock_type_of_seqno->{$seqno_m};
# The pattern ends in \s but we have removed the newline, so
# we added it back for the match. That way we require an exact
# match to the special string and also allow additional text.
$token_sc .= "\n";
if ( $block_type_m
&& $is_opening_type{$type_m}
&& $token_sc =~ /$non_indenting_brace_pattern/ )
{
$rseqno_non_indenting_brace_by_ix->{$ix} = $seqno_m;
}
}
}
return;
} ## end sub find_non_indenting_braces
sub interbracket_arrow_check {
my ($self) = @_;
# Implement the options to add or delete optional arrows between brackets
my $rOpts_add = $rOpts->{'add-interbracket-arrows'};
my $rOpts_del = $rOpts->{'delete-interbracket-arrows'};
my $rOpts_warn = $rOpts->{'warn-interbracket-arrows'};
my $rOpts_warn_and_style = $rOpts_warn && %interbracket_arrow_style;
return
unless ( $rOpts_add || $rOpts_del || $rOpts_warn_and_style );
# Method:
# Loop over all opening brackets and look back for a possible arrow
# and closing bracket. If the location between brackets allows an
# optional arrow, then see if one should be added or deleted.
# Set a flag for sub respace_tokens which will make the change.
# Deleting examples:
# $variables->{'a'}->{'b'} $variables->{'a'}{'b'}
# $variables{'a'}->{'b'} $variables{'a'}->{'b'}
# $items[1]->[4]->{red} $items[1][4]{red}
# $items{blue}->[4]->{red} $items{blue}[4]{red}
# Adding examples:
# $variables->{'a'}{'b'} $variables->{'a'}->{'b'}
# $variables{'a'}->{'b'} $variables{'a'}->{'b'}
# $items[1][4]{red} $items[1]->[4]->{red}
# $items{blue}[4]{red} $items{blue}->[4]->{red}
# bracket chain ] { } [ ] [
# | | |
# arrow ok? ? ? ?
# The following chain rule is used to locate optional arrow locations:
# Scanning left to right:
# -arrows can begin once we see an opening token preceded by:
# - an ->, or
# - a simple scalar identifier like '$href{' or '$aryref['
# - Once arrows begin they may continue to the end of the bracket chain.
# To illustrate why we just can't add and remove arrows between
# ']' and '[', for example, consider
# my $v1 = [ 1, 2, [ 3, 4 ] ]->[2]->[0]; # ok
# my $v2 = [ 1, 2, [ 3, 4 ] ]->[2][0]; # ok, keep required arrow
# my $v3 = [ 1, 2, [ 3, 4 ] ][2][0]; # Error
# Note that an arrow does not get placed between '}' and '[' here:
# my $val = ${$x}[1];
# Perltidy marks the '$' as type 't', and since the logic below checks
# for identifiers of type 'i', it will work ok.
# We will maintain the flag for this check in the following hash:
my %trailing_arrow_ok_by_seqno;
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $K_opening_container = $self->[_K_opening_container_];
my @lno_del;
my @lno_add;
my $warn = sub {
# write a warning on changes made or needed if -wia is set
my ( $rlno_list, $first_word ) = @_;
my $str;
my $num_changes = @{$rlno_list};
my @unique_lno = do {
my %seen;
grep { !$seen{$_}++ } @{$rlno_list};
};
my $num_lno = @unique_lno;
my $num_lim = 10;
if ( $num_lno <= $num_lim ) {
$str = join( SPACE, @unique_lno );
}
else {
$str = join( SPACE, @unique_lno[ 0 .. $num_lim - 1 ] ) . " ...";
}
my $ess1 = $num_changes == 1 ? EMPTY_STRING : 's';
my $ess2 = $num_lno == 1 ? EMPTY_STRING : 's';
my $msg = "$first_word $num_changes '->'$ess1 at line$ess2 $str\n";
warning($msg);
return;
}; ## end $warn = sub
# Complexity control flag:
# =0 left container must just contain a single token
# =1 left container must not contain other containers [DEFAULT]
# =2 no complexity constraints
my $complexity = $rOpts->{'interbracket-arrow-complexity'};
if ( !defined($complexity) ) { $complexity = 1 }
#--------------------------------------------
# Main loop over all opening container tokens
#--------------------------------------------
foreach my $seqno ( sort { $a <=> $b } keys %{$K_opening_container} ) {
# We just want opening token types 'L" or '['
# Note: the tokenizer marks hash braces '{' and '}' as 'L' and 'R'
# but we have to be careful because small block braces can also
# get marked 'L' and 'R' for formatting purposes.
my $Ko = $K_opening_container->{$seqno};
my $type = $rLL->[$Ko]->[_TYPE_];
next if ( $type ne 'L' && $type ne '[' );
# Now find the previous nonblank token
my $K_m = $Ko - 1;
next if ( $K_m < 0 );
my $type_m = $rLL->[$K_m]->[_TYPE_];
if ( $type_m eq 'b' && $K_m > 0 ) {
$K_m -= 1;
$type_m = $rLL->[$K_m]->[_TYPE_];
}
# These vars will hold the previous closing bracket, if any;
# initialized to this token but will be moved if it is an arrow
my $K_mm = $K_m;
my $type_mm = $type_m;
# Decide if an inter-bracket arrow could follow the closing token
# of this container..
# preceded by scalar identifier (such as '$array[' or '$hash{') ?
if ( $type_m eq 'i' || $type_m eq 'Z' ) {
my $token_m = $rLL->[$K_m]->[_TOKEN_];
if ( substr( $token_m, 0, 1 ) eq '$' ) {
# arrows can follow the CLOSING bracket of this container
$trailing_arrow_ok_by_seqno{$seqno} = 1;
}
}
# or a closing bracket or hash brace
elsif ( $type_m eq ']' || $type_m eq 'R' ) {
my $seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_];
# propagate the arrow status flag
$trailing_arrow_ok_by_seqno{$seqno} =
$trailing_arrow_ok_by_seqno{$seqno_m};
}
# check a pointer and if found, back up one more token
elsif ( $type_m eq '->' ) {
# arrows can follow the CLOSING bracket of this container
$trailing_arrow_ok_by_seqno{$seqno} = 1;
# back up one token before the arrow
$K_mm = $K_m - 1;
next if ( $K_mm <= 0 );
$type_mm = $rLL->[$K_mm]->[_TYPE_];
if ( $type_mm eq 'b' && $K_mm > 0 ) {
$K_mm -= 1;
$type_mm = $rLL->[$K_mm]->[_TYPE_];
}
}
else {
# something else
}
# now check for a preceding closing bracket or hash brace
next if ( $type_mm ne ']' && $type_mm ne 'R' );
my $seqno_mm = $rLL->[$K_mm]->[_TYPE_SEQUENCE_];
next if ( !$seqno_mm );
$trailing_arrow_ok_by_seqno{$seqno} = 1;
# We are between brackets with these two or three sequential tokens,
# indexes _mm and _m are identical if there is no arrow.
# $type_mm $type_m $type
# R or ] ->? [ or L
# Can an inter-bracket arrow be here?
next unless ( $trailing_arrow_ok_by_seqno{$seqno_mm} );
# If the user defined a style, only continue if this requires
# adding or deleting an '->' to match the style
if (%interbracket_arrow_style) {
my $style = $interbracket_arrow_style{ $type_mm . $type };
next if ( !$style );
next
if ( $style == -1 && $type_m ne '->'
|| $style == 1 && $type_m eq '->' );
}
next if ( $type_m eq '->' && !$rOpts_del && !$rOpts_warn );
next if ( $type_m ne '->' && !$rOpts_add && !$rOpts_warn );
# Do not continue if the left container is too complex..
# complexity flag = 0: only one nonblank token in the brackets
if ( !$complexity ) {
my $count = 0;
my $Ko_mm = $K_opening_container->{$seqno_mm};
next unless defined($Ko_mm);
foreach my $KK ( $Ko_mm + 1 .. $K_mm - 2 ) {
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
$count++;
last if ( $count > 1 );
}
next if ( $count > 1 );
}
# complexity flag = 1: no interior container tokens
elsif ( $complexity == 1 ) {
if ( $seqno_mm ne $seqno - 1 ) {
next;
}
}
else {
# complexity flag >1 => no restriction
}
# set a flag telling sub respace_tokens to actually make the change
my $lno = 1 + $rLL->[$Ko]->[_LINE_INDEX_];
if ( $type_m eq '->' ) {
if ($rOpts_del) {
$self->[_rwant_arrow_before_seqno_]->{$seqno} = -1;
}
if ( $rOpts_del || $rOpts_warn_and_style ) { push @lno_del, $lno }
}
else {
if ($rOpts_add) {
$self->[_rwant_arrow_before_seqno_]->{$seqno} = 1;
}
if ( $rOpts_add || $rOpts_warn_and_style ) { push @lno_add, $lno }
}
}
if ($rOpts_warn) {
my $wia = '--warn-interbracket-arrows report:';
$warn->( \@lno_add, $rOpts_add ? "$wia added" : "$wia: missing" )
if (@lno_add);
$warn->( \@lno_del, $rOpts_del ? "$wia deleted " : "$wia: unwanted " )
if (@lno_del);
}
return;
} ## end sub interbracket_arrow_check
sub delete_side_comments {
my ( $self, $rix_side_comments ) = @_;
# Handle any requested side comment deletions.
# Given:
# $rix_side_comments = ref to list of indexes of lines with side comments
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $rseqno_non_indenting_brace_by_ix =
$self->[_rseqno_non_indenting_brace_by_ix_];
foreach my $ix ( @{$rix_side_comments} ) {
my $line_of_tokens = $rlines->[$ix];
my $line_type = $line_of_tokens->{_line_type};
# This fault shouldn't happen because we only saved CODE lines with
# side comments in the TASK 1 loop above.
if ( $line_type ne 'CODE' ) {
if (DEVEL_MODE) {
my $lno = $ix + 1;
Fault(<{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
if ( !defined($Kfirst) || $rLL->[$Klast]->[_TYPE_] ne '#' ) {
if (DEVEL_MODE) {
my $lno = $ix + 1;
Fault(< $Kfirst || $CODE_type eq 'HSC' )
&& (!$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
|| $CODE_type eq 'NIN' );
# Do not delete special control side comments
if ( $rseqno_non_indenting_brace_by_ix->{$ix} ) {
$delete_side_comment = 0;
}
if (
$rOpts_delete_closing_side_comments
&& !$delete_side_comment
&& $Klast > $Kfirst
&& ( !$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
|| $CODE_type eq 'NIN' )
)
{
my $token = $rLL->[$Klast]->[_TOKEN_];
my $K_m = $Klast - 1;
my $type_m = $rLL->[$K_m]->[_TYPE_];
if ( $type_m eq 'b' && $K_m > $Kfirst ) { $K_m-- }
my $seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_];
# patch to delete asub csc's (c380)
if ( !$seqno_m && $K_m && $rLL->[$K_m]->[_TYPE_] eq ';' ) {
$K_m = $K_m - 1;
$type_m = $rLL->[$K_m]->[_TYPE_];
if ( $type_m eq 'b' && $K_m > $Kfirst ) { $K_m-- }
if ( $K_m == $Kfirst ) {
$seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_];
}
}
if ($seqno_m) {
my $block_type_m = $rblock_type_of_seqno->{$seqno_m};
if ( $block_type_m
&& $token =~ /$closing_side_comment_prefix_pattern/
&& $block_type_m =~ /$closing_side_comment_list_pattern/
&& $block_type_m !~
/$closing_side_comment_exclusion_pattern/ )
{
$delete_side_comment = 1;
}
}
} ## end if ( $rOpts_delete_closing_side_comments...)
if ($delete_side_comment) {
# We are actually just changing the side comment to a blank.
# This may produce multiple blanks in a row, but sub respace_tokens
# will check for this and fix it.
$rLL->[$Klast]->[_TYPE_] = 'b';
$rLL->[$Klast]->[_TOKEN_] = SPACE;
# The -io option outputs the line text, so we have to update
# the line text so that the comment does not reappear.
if ( $CODE_type eq 'IO' ) {
my $line = EMPTY_STRING;
foreach my $KK ( $Kfirst .. $Klast - 1 ) {
$line .= $rLL->[$KK]->[_TOKEN_];
}
$line =~ s/\s+$//;
$line_of_tokens->{_line_text} = $line . "\n";
}
# If we delete a hanging side comment the line becomes blank.
if ( $CODE_type eq 'HSC' ) { $line_of_tokens->{_code_type} = 'BL' }
}
}
return;
} ## end sub delete_side_comments
my %wU;
my %wiq;
my %is_wit;
my %is_sigil;
my %is_nonlist_keyword;
my %is_nonlist_type;
my %is_s_y_m_slash;
my %is_unexpected_equals;
my %is_ascii_type;
BEGIN {
# added 'U' to fix cases b1125 b1126 b1127
my @q = qw( w U );
@wU{@q} = (1) x scalar(@q);
@q = qw( w i q Q G C Z );
@wiq{@q} = (1) x scalar(@q);
@q = qw( w i t ); # for c250: added new types 'P', 'S', formerly 'i'
@is_wit{@q} = (1) x scalar(@q);
@q = qw( $ & % * @ );
@is_sigil{@q} = (1) x scalar(@q);
# Parens following these keywords will not be marked as lists. Note that
# 'for' is not included and is handled separately, by including 'f' in the
# hash %is_counted_type, since it may or may not be a c-style for loop.
@q = qw( if elsif unless and or );
@is_nonlist_keyword{@q} = (1) x scalar(@q);
# Parens following these types will not be marked as lists
@q = qw( && || );
@is_nonlist_type{@q} = (1) x scalar(@q);
@q = qw( s y m / );
@is_s_y_m_slash{@q} = (1) x scalar(@q);
@q = qw( = == != );
@is_unexpected_equals{@q} = (1) x scalar(@q);
# We can always skip expensive length_function->() calls for these
# ascii token types
@q = qw#
b k L R ; ( { [ ? : ] } ) f t n v F p m pp mm
.. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
( ) <= >= == =~ !~ != ++ -- /= x=
... **= <<= >>= &&= ||= //= <=>
+ - / * | % ! x ~ = \ ? : . < > ^ &
#;
push @q, ',';
@is_ascii_type{@q} = (1) x scalar(@q);
} ## end BEGIN
{ #<<< begin closure respace_tokens
my $rLL_new; # This will be the new array of tokens
# These are variables in $self
my $rLL;
my $length_function;
my $K_closing_ternary;
my $K_opening_ternary;
my $rchildren_of_seqno;
my $rhas_broken_code_block;
my $rhas_broken_list;
my $rhas_broken_list_with_lec;
my $rhas_code_block;
my $rhas_list;
my $rhas_ternary;
my $ris_assigned_structure;
my $ris_broken_container;
my $ris_excluded_lp_container;
my $ris_list_by_seqno;
my $ris_permanently_broken;
my $rlec_count_by_seqno;
my $roverride_cab3;
my $rparent_of_seqno;
my $rtype_count_by_seqno;
my $rblock_type_of_seqno;
my $rwant_arrow_before_seqno;
my $ris_sub_block;
my $ris_asub_block;
my $rseqno_arrow_call_chain_start;
my $rarrow_call_chain;
my $K_opening_container;
my $K_closing_container;
my @K_sequenced_token_list;
my @seqno_paren_arrow;
my %K_first_here_doc_by_seqno;
my $last_nonblank_code_type;
my $last_nonblank_code_token;
my $last_nonblank_block_type;
my $last_last_nonblank_code_type;
my $last_last_nonblank_code_token;
my $K_last_S;
my $K_last_S_is_my;
my %seqno_stack;
my %K_old_opening_by_seqno;
my $depth_next;
my $depth_next_max;
my @sub_seqno_stack;
my $current_sub_seqno;
my $cumulative_length;
# Variables holding the current line info
my $Ktoken_vars;
my $Kfirst_old;
my $Klast_old;
my $Klast_old_code;
my $CODE_type;
my $rwhitespace_flags;
# new index K of package or class statements
my $rK_package_list;
# new index K of @_ tokens
my $rK_AT_underscore_by_sub_seqno;
# new index K of first $self tokens for each sub
my $rK_first_self_by_sub_seqno;
# new index K of first 'bless' for each sub
my $rK_bless_by_sub_seqno;
# new index K of 'return' for each sub
my $rK_return_by_sub_seqno;
# new index K of 'wantarray' for each sub
my $rK_wantarray_by_sub_seqno;
# info about list of sub call args
my $rsub_call_paren_info_by_seqno;
my $rDOLLAR_underscore_by_sub_seqno;
# index K of the preceding 'S' token for a sub
my $rK_sub_by_seqno;
# true for a 'my' sub
my $ris_my_sub_by_seqno;
sub initialize_respace_tokens_closure {
my ($self) = @_;
$rLL_new = []; # This is the new array
$rLL = $self->[_rLL_];
$length_function = $self->[_length_function_];
$K_closing_ternary = $self->[_K_closing_ternary_];
$K_opening_ternary = $self->[_K_opening_ternary_];
$rchildren_of_seqno = $self->[_rchildren_of_seqno_];
$rhas_broken_code_block = $self->[_rhas_broken_code_block_];
$rhas_broken_list = $self->[_rhas_broken_list_];
$rhas_broken_list_with_lec = $self->[_rhas_broken_list_with_lec_];
$rhas_code_block = $self->[_rhas_code_block_];
$rhas_list = $self->[_rhas_list_];
$rhas_ternary = $self->[_rhas_ternary_];
$ris_assigned_structure = $self->[_ris_assigned_structure_];
$ris_broken_container = $self->[_ris_broken_container_];
$ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
$ris_list_by_seqno = $self->[_ris_list_by_seqno_];
$ris_permanently_broken = $self->[_ris_permanently_broken_];
$rlec_count_by_seqno = $self->[_rlec_count_by_seqno_];
$roverride_cab3 = $self->[_roverride_cab3_];
$rparent_of_seqno = $self->[_rparent_of_seqno_];
$rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
$rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
$rwant_arrow_before_seqno = $self->[_rwant_arrow_before_seqno_];
$ris_sub_block = $self->[_ris_sub_block_];
$ris_asub_block = $self->[_ris_asub_block_];
$rK_package_list = $self->[_rK_package_list_];
$rK_AT_underscore_by_sub_seqno = $self->[_rK_AT_underscore_by_sub_seqno_];
$rK_first_self_by_sub_seqno = $self->[_rK_first_self_by_sub_seqno_];
$rK_bless_by_sub_seqno = $self->[_rK_bless_by_sub_seqno_];
$rK_return_by_sub_seqno = $self->[_rK_return_by_sub_seqno_];
$rK_wantarray_by_sub_seqno = $self->[_rK_wantarray_by_sub_seqno_];
$rsub_call_paren_info_by_seqno = $self->[_rsub_call_paren_info_by_seqno_];
$rseqno_arrow_call_chain_start = $self->[_rseqno_arrow_call_chain_start_];
$rarrow_call_chain = $self->[_rarrow_call_chain_];
$rDOLLAR_underscore_by_sub_seqno =
$self->[_rDOLLAR_underscore_by_sub_seqno_];
$rK_sub_by_seqno = $self->[_rK_sub_by_seqno_];
$ris_my_sub_by_seqno = $self->[_ris_my_sub_by_seqno_];
%K_first_here_doc_by_seqno = ();
$last_nonblank_code_type = ';';
$last_nonblank_code_token = ';';
$last_nonblank_block_type = EMPTY_STRING;
$last_last_nonblank_code_type = ';';
$last_last_nonblank_code_token = ';';
$K_last_S = 1;
$K_last_S_is_my = undef;
%seqno_stack = ();
%K_old_opening_by_seqno = (); # Note: old K index
$depth_next = 0;
$depth_next_max = 0;
@sub_seqno_stack = ();
$current_sub_seqno = 0;
# we will be setting token lengths as we go
$cumulative_length = 0;
$Ktoken_vars = undef; # the old K value of $rtoken_vars
$Kfirst_old = undef; # min K of old line
$Klast_old = undef; # max K of old line
$Klast_old_code = undef; # K of last token if side comment
$CODE_type = EMPTY_STRING;
# Set the whitespace flags, which indicate the token spacing preference.
$rwhitespace_flags = $self->set_whitespace_flags();
# Note that $K_opening_container and $K_closing_container have values
# defined in sub get_line() for the previous K indexes. They were needed
# in case option 'indent-only' was set, and we didn't get here. We no
# longer need those and will eliminate them now to avoid any possible
# mixing of old and new values. This must be done AFTER the call to
# set_whitespace_flags, which needs these.
$K_opening_container = $self->[_K_opening_container_] = {};
$K_closing_container = $self->[_K_closing_container_] = {};
@K_sequenced_token_list = ();
# array for saving seqno's of ')->' for possible line breaks, git #171
@seqno_paren_arrow = ();
return;
} ## end sub initialize_respace_tokens_closure
sub respace_tokens {
my $self = shift;
# This routine is called once per file to do as much formatting as possible
# before new line breaks are set.
# Returns:
# $severe_error = true if processing must terminate immediately
# $rqw_lines = ref to list of lines with qw quotes (for -qwaf)
my ( $severe_error, $rqw_lines );
# We do not change any spaces in --indent-only mode
if ( $rOpts->{'indent-only'} ) {
# We need to define lengths for -indent-only to avoid undefs, even
# though these values are not actually needed for option --indent-only.
$rLL = $self->[_rLL_];
$cumulative_length = 0;
foreach my $item ( @{$rLL} ) {
my $token = $item->[_TOKEN_];
my $token_length =
$length_function ? $length_function->($token) : length($token);
$cumulative_length += $token_length;
$item->[_TOKEN_LENGTH_] = $token_length;
$item->[_CUMULATIVE_LENGTH_] = $cumulative_length;
}
return ( $severe_error, $rqw_lines );
}
# 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.
# (re-)initialize closure variables for this problem
$self->initialize_respace_tokens_closure();
#--------------------------------
# Main over all lines of the file
#--------------------------------
my $rlines = $self->[_rlines_];
my $line_type = EMPTY_STRING;
my $last_K_out;
foreach my $line_of_tokens ( @{$rlines} ) {
my $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' );
$CODE_type = $line_of_tokens->{_code_type};
if ( $CODE_type eq 'BL' ) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno) ) {
$self->[_rblank_and_comment_count_]->{$seqno} += 1;
if ( !$ris_permanently_broken->{$seqno}
&& $rOpts_maximum_consecutive_blank_lines )
{
$ris_permanently_broken->{$seqno} = 1;
$self->mark_parent_containers( $seqno,
$ris_permanently_broken );
}
}
}
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
next unless defined($Kfirst);
( $Kfirst_old, $Klast_old ) = ( $Kfirst, $Klast );
$Klast_old_code = $Klast_old;
# Be sure an old K value is defined for sub store_token
$Ktoken_vars = $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 we
# get a fault here it has not output a continuous sequence
# of K values. Or a line of CODE may have been mis-marked as
# something else. There is no good way to continue after such an
# error.
if ( defined($last_K_out) ) {
if ( $Kfirst != $last_K_out + 1 ) {
Fault_Warn(
"Program Bug: last K out was $last_K_out but Kfirst=$Kfirst"
);
$severe_error = 1;
return ( $severe_error, $rqw_lines );
}
}
else {
# The first token should always have been given index 0 by sub
# write_line()
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 restrictions
# Copy tokens unchanged
foreach my $KK ( $Kfirst .. $Klast ) {
$Ktoken_vars = $KK;
$self->store_token( $rLL->[$KK] );
}
next;
}
# Handle normal line..
# Define index of last token before any side comment for comma counts
my $type_end = $rLL->[$Klast_old_code]->[_TYPE_];
if ( ( $type_end eq '#' || $type_end eq 'b' )
&& $Klast_old_code > $Kfirst_old )
{
$Klast_old_code--;
if ( $rLL->[$Klast_old_code]->[_TYPE_] eq 'b'
&& $Klast_old_code > $Kfirst_old )
{
$Klast_old_code--;
}
}
# 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.
# Note that we must do this even if --noadd-whitespace is set
if ( $last_line_type eq 'CODE' ) {
if (
is_essential_whitespace(
$last_last_nonblank_code_token,
$last_last_nonblank_code_type,
$last_nonblank_code_token,
$last_nonblank_code_type,
$rLL->[$Kfirst]->[_TOKEN_],
$rLL->[$Kfirst]->[_TYPE_],
)
)
{
$self->store_token();
}
}
#-----------------------------------------------
# Inner loop to respace tokens on a line of code
#-----------------------------------------------
# The inner loop is in a separate sub for clarity
$self->respace_tokens_inner_loop( $Kfirst, $Klast, $input_line_number );
if ( $line_of_tokens->{_ending_in_quote} ) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno) ) {
$ris_permanently_broken->{$seqno} = 1;
$self->mark_parent_containers( $seqno,
$ris_permanently_broken );
}
}
} # End line loop
# finalize data structures
$self->respace_post_loop_ops();
# Reset memory to be the new array
$self->[_rLL_] = $rLL_new;
my $Klimit;
if ( @{$rLL_new} ) { $Klimit = @{$rLL_new} - 1 }
$self->[_Klimit_] = $Klimit;
# During development, verify that the new array still looks okay.
DEVEL_MODE && $self->check_token_array();
# update the token limits of each line
( $severe_error, $rqw_lines ) = $self->resync_lines_and_tokens();
return ( $severe_error, $rqw_lines );
} ## end sub respace_tokens
sub respace_tokens_inner_loop {
my ( $self, $Kfirst, $Klast, $input_line_number ) = @_;
# Loop to copy all tokens on one line, making any spacing changes,
# while also collecting information needed by later subs.
# Given:
# $Kfirst = index of first token on this line
# $Klast = index of last token on this line
# $input_line_number = number of this line in input stream
my $type;
foreach my $KK ( $Kfirst .. $Klast ) {
# Update closure variable needed by sub store_token
$Ktoken_vars = $KK;
my $rtoken_vars = $rLL->[$KK];
# Handle a blank space ...
if ( ( $type = $rtoken_vars->[_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;
if ($rOpts_freeze_whitespace) {
$self->store_token($rtoken_vars);
next;
}
my $ws = $rwhitespace_flags->[$Knext];
if ( $ws == WS_NO
|| $rOpts_delete_old_whitespace )
{
my $token_next = $rLL->[$Knext]->[_TOKEN_];
my $type_next = $rLL->[$Knext]->[_TYPE_];
my $do_not_delete = is_essential_whitespace(
$last_last_nonblank_code_token,
$last_last_nonblank_code_type,
$last_nonblank_code_token,
$last_nonblank_code_type,
$token_next,
$type_next,
);
# Note that repeated blanks will get filtered out here
next unless ($do_not_delete);
}
# make it just one character
$rtoken_vars->[_TOKEN_] = SPACE;
$self->store_token($rtoken_vars);
next;
}
my $token = $rtoken_vars->[_TOKEN_];
# Handle a sequenced token ... i.e. one of ( ) { } [ ] ? :
if ( $rtoken_vars->[_TYPE_SEQUENCE_] ) {
# One of ) ] } ...
if ( $is_closing_token{$token} ) {
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
my $block_type = $rblock_type_of_seqno->{$type_sequence};
#---------------------------------------------
# check for semicolon addition in a code block
#---------------------------------------------
if ($block_type) {
# if not preceded by a ';' ..
if ( $last_nonblank_code_type ne ';' ) {
# tentatively insert a semicolon if appropriate
$self->add_phantom_semicolon($KK)
if $rOpts->{'add-semicolons'};
}
if ( $ris_sub_block->{$type_sequence}
|| $ris_asub_block->{$type_sequence} )
{
$current_sub_seqno = pop @sub_seqno_stack;
}
}
#----------------------------------------------------------
# check for addition/deletion of a trailing comma in a list
#----------------------------------------------------------
else {
# if this looks like a list ..
my $rtype_count = $rtype_count_by_seqno->{$type_sequence};
if ( !$rtype_count
|| !$rtype_count->{';'} && !$rtype_count->{'f'} )
{
# if NOT preceded by a comma..
if ( $last_nonblank_code_type ne ',' ) {
# insert a comma if requested
if (
$rOpts_add_trailing_commas
&& %trailing_comma_rules
# and...
&& (
# ... there is a comma or fat_comma
$rtype_count
&& ( $rtype_count->{','}
|| $rtype_count->{'=>'} )
# ... or exception for nested container
|| (
$rOpts_add_lone_trailing_commas
&& $is_closing_type{
$last_nonblank_code_type}
)
)
# and not preceded by '=>'
# (unusual but can occur in test files)
&& $last_nonblank_code_type ne '=>'
)
{
my $rule = $trailing_comma_rules{add};
if ( $rule && $rule->{$token} ) {
$self->add_trailing_comma( $KK, $Kfirst,
$rule->{$token} );
}
}
}
# if preceded by a comma ..
else {
# delete a trailing comma if requested
my $deleted;
if (
$rOpts_delete_trailing_commas
&& %trailing_comma_rules
&& $rtype_count
&& $rtype_count->{','}
&& ( $rOpts_delete_lone_trailing_commas
|| $rtype_count->{','} > 1
|| $rtype_count->{'=>'} )
# ignore zero-size qw commas
&& $last_nonblank_code_token
)
{
my $rule = $trailing_comma_rules{delete};
if ( $rule && $rule->{$token} ) {
$deleted =
$self->delete_trailing_comma( $KK,
$Kfirst, $rule->{$token} );
}
}
# delete a weld-interfering comma if requested
if ( !$deleted
&& $rOpts_delete_weld_interfering_commas
&& $is_closing_type{
$last_last_nonblank_code_type} )
{
$self->delete_weld_interfering_comma($KK);
}
}
}
}
}
# Opening container
else {
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( $rwant_arrow_before_seqno->{$type_sequence} ) {
# +1 means add -1 means delete previous arrow
if ( $rwant_arrow_before_seqno->{$type_sequence} > 0 ) {
$self->add_interbracket_arrow();
}
else {
$self->delete_interbracket_arrow();
$rwhitespace_flags->[$KK] = WS_NO;
}
}
# Save info for sub call arg count check
if ( $token eq '(' ) {
if (
# function(
$last_nonblank_code_type eq 'U'
|| $last_nonblank_code_type eq 'w'
# ->function(
|| ( $last_nonblank_code_type eq 'i'
&& $last_last_nonblank_code_type eq '->' )
# &function(
|| ( $last_nonblank_code_type eq 'i'
&& substr( $last_nonblank_code_token, 0, 1 ) eq
'&' )
)
{
$rsub_call_paren_info_by_seqno->{$type_sequence} = {
type_mm => $last_last_nonblank_code_type,
token_m => $last_nonblank_code_token,
};
}
}
# At a sub block, save info to cross check arg counts
elsif ( $ris_sub_block->{$type_sequence} ) {
$rK_sub_by_seqno->{$type_sequence} = $K_last_S;
if ($K_last_S_is_my) {
$ris_my_sub_by_seqno->{$type_sequence} = 1;
}
push @sub_seqno_stack, $current_sub_seqno;
$current_sub_seqno = $type_sequence;
}
elsif ( $ris_asub_block->{$type_sequence} ) {
push @sub_seqno_stack, $current_sub_seqno;
$current_sub_seqno = $type_sequence;
}
# Look for '$_[' for mismatched arg checks
elsif ($token eq '['
&& $last_nonblank_code_token eq '$_'
&& $current_sub_seqno )
{
push
@{ $rDOLLAR_underscore_by_sub_seqno->{$current_sub_seqno}
},
$type_sequence;
}
else {
## not a special opening token
}
}
}
# Modify certain tokens here for whitespace
# The following is not yet done, but could be:
# sub (x x x)
# ( $type =~ /^[wit]$/ )
elsif ( $is_wit{$type} ) {
# index() is several times faster than a regex test with \s here
## $token =~ /\s/
if ( index( $token, SPACE ) > 0 || index( $token, "\t" ) > 0 ) {
# change '$ var' to '$var' etc
# change '@ ' to '@'
# Examples: <>
my $ord = ord( substr( $token, 1, 1 ) );
if (
# quick test for possible blank at second char
$ord > 0 && ( $ord < ORD_PRINTABLE_MIN
|| $ord > ORD_PRINTABLE_MAX )
)
{
my ( $sigil, $word ) = split /\s+/, $token, 2;
# $sigil =~ /^[\$\&\%\*\@]$/ )
if ( $is_sigil{$sigil} ) {
$token = $sigil;
$token .= $word if ( defined($word) ); # fix c104
$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 ...
# ...
my $ord_ch = ord( substr( $token, -1, 1 ) );
if (
# quick check for possible ending space
$ord_ch > 0 && ( $ord_ch < ORD_PRINTABLE_MIN
|| $ord_ch > ORD_PRINTABLE_MAX )
)
{
$token =~ s/\s+$//g;
$rtoken_vars->[_TOKEN_] = $token;
}
}
if ( $type eq 'i' ) {
if ( $token eq '@_' && $current_sub_seqno ) {
# remember the new K of this @_; this may be
# off by 1 if a blank gets inserted before it
push
@{ $rK_AT_underscore_by_sub_seqno->{$current_sub_seqno} },
scalar( @{$rLL_new} );
}
# Remember new K of the first '$self' in a sub for -dma option
if ( $token eq '$self' && $current_sub_seqno ) {
$rK_first_self_by_sub_seqno->{$current_sub_seqno} ||=
scalar( @{$rLL_new} );
}
# Remember new K and name of blessed objects for -dma option
if (
(
$last_nonblank_code_token eq 'bless'
&& $last_nonblank_code_type eq 'k'
)
|| (
$last_last_nonblank_code_token eq 'bless'
&& $last_last_nonblank_code_type eq 'k'
&& (
$last_nonblank_code_token eq 'my'
|| $last_nonblank_code_token eq '('
)
)
)
{
push @{ $rK_bless_by_sub_seqno->{$current_sub_seqno} },
[ scalar( @{$rLL_new} ), $token ];
}
}
elsif ( $type eq 'w' ) {
if ( $last_nonblank_code_token eq 'use'
&& $last_nonblank_code_type eq 'k' )
{
if ( $token eq 'strict' ) { $self->[_saw_use_strict_] = 1 }
}
}
else {
# Could be something like '* STDERR' or '$ debug'
}
}
# handle keywords
elsif ( $type eq 'k' ) {
if ( $token eq 'return' ) {
# remember the new K of this 'return; this may be
# off by 1 if a blank gets inserted before it
push
@{ $rK_return_by_sub_seqno->{$current_sub_seqno} },
scalar( @{$rLL_new} );
}
if ( $token eq 'wantarray' ) {
push
@{ $rK_wantarray_by_sub_seqno->{$current_sub_seqno} },
scalar( @{$rLL_new} );
}
}
# handle semicolons
elsif ( $type eq ';' ) {
# Remove unnecessary semicolons, but not after bare
# blocks, where it could be unsafe if the brace is
# mis-tokenized.
if (
$rOpts->{'delete-semicolons'}
&& (
(
$last_nonblank_block_type
&& $last_nonblank_code_type eq '}'
&& (
$is_block_without_semicolon{
$last_nonblank_block_type}
|| $last_nonblank_block_type =~ /$SUB_PATTERN/
|| $last_nonblank_block_type =~ /^\w+:$/
)
)
|| $last_nonblank_code_type eq ';'
)
)
{
# This looks like a deletable semicolon, but even if a
# semicolon can be deleted it is not 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 '}';
}
}
# do not delete only nonblank token in a file
else {
my $Kp = $self->K_previous_code( undef, $rLL_new );
my $Kn = $self->K_next_nonblank($KK);
$ok_to_delete = defined($Kn) || defined($Kp);
}
if ($ok_to_delete) {
$self->note_deleted_semicolon($input_line_number);
next;
}
else {
write_logfile_entry("Extra ';'\n");
}
}
}
elsif ( $type eq '->' ) {
if ( $last_nonblank_code_token eq ')' ) {
# save seqno of closing paren with arrow, ')->', git #171
# (the paren seqno is still on the stack)
my $seqno_paren = $seqno_stack{$depth_next};
if ($seqno_paren) { push @seqno_paren_arrow, $seqno_paren }
}
}
# delete repeated commas if requested
elsif ( $type eq ',' ) {
if ( $last_nonblank_code_type eq ','
&& $rOpts->{'delete-repeated-commas'} )
{
# Do not delete the leading comma of a line with a side
# comment. This could promote the side comment to a block
# comment. See test 'mangle4.in'
my $lno = 1 + $rLL->[$KK]->[_LINE_INDEX_];
if ( $KK eq $Kfirst && $rLL->[$Klast]->[_TYPE_] eq '#' ) {
complain(
"repeated comma before side comment, not deleted\n",
$lno );
}
else {
complain( "deleted repeated ','\n", $lno );
next;
}
}
elsif ($last_nonblank_code_type eq '=>'
&& $rOpts->{'delete-repeated-commas'} )
{
my $lno = 1 + $rLL->[$KK]->[_LINE_INDEX_];
complain( "found '=>,' ... error?\n", $lno );
}
else {
# not a repeated comma type
}
# remember input line index of first comma if -wtc is used
if (%trailing_comma_rules) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno)
&& !defined( $self->[_rfirst_comma_line_index_]->{$seqno} )
)
{
$self->[_rfirst_comma_line_index_]->{$seqno} =
$rtoken_vars->[_LINE_INDEX_];
}
}
}
# check a quote for problems
elsif ( $type eq 'Q' ) {
$self->check_Q( $KK, $Kfirst, $input_line_number )
if ( $self->[_save_logfile_] );
}
# Old patch to add space to something like "x10".
# Note: This is now done in the Tokenizer, but this code remains
# for reference.
elsif ( $type eq 'n' ) {
if ( substr( $token, 0, 1 ) eq 'x' && $token =~ /^x\d+/ ) {
$token =~ s/x/x /;
$rtoken_vars->[_TOKEN_] = $token;
if (DEVEL_MODE) {
Fault(<' ) {
if ( $last_nonblank_code_type eq '=>'
&& $rOpts->{'delete-repeated-commas'} )
{
# Check for repeated '=>'s
# Note that ',=>' is useful and called a winking fat comma
# Do not delete the leading fat comma of a line with a side
# comment. This could promote the side comment to a block
# comment. See test 'mangle4.in'
my $lno = 1 + $rLL->[$KK]->[_LINE_INDEX_];
if ( $KK eq $Kfirst && $rLL->[$Klast]->[_TYPE_] eq '#' ) {
complain(
"-repeated '=>' before side comment, not deleted\n",
$lno );
}
else {
complain( "deleted repeated '=>'\n", $lno );
next;
}
}
# remember input line index of first '=>' if -wtc is used
if (%trailing_comma_rules) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno)
&& !defined( $self->[_rfirst_comma_line_index_]->{$seqno} )
)
{
$self->[_rfirst_comma_line_index_]->{$seqno} =
$rtoken_vars->[_LINE_INDEX_];
}
}
}
# check for a qw quote
elsif ( $type eq 'q' ) {
# Trim spaces from right of qw quotes. Also trim from the left for
# safety (the tokenizer should have done this).
# To avoid trimming qw quotes use -ntqw; this causes the
# tokenizer to set them as type 'Q' instead of 'q'.
$token =~ s/^ \s+ | \s+ $//gx;
$rtoken_vars->[_TOKEN_] = $token;
if ( $self->[_save_logfile_] && $token =~ /\t/ ) {
$self->note_embedded_tab($input_line_number);
}
if ( $rwhitespace_flags->[$KK] == WS_YES
&& @{$rLL_new}
&& $rLL_new->[-1]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace )
{
$self->store_token();
}
$self->store_token($rtoken_vars);
next;
}
# Remove space after '<<'. Note that perl may use a space after
# '<<' to guess tokenization for numeric targets. See git #174.
elsif ( $type eq 'h' ) {
if ( index( $token, SPACE ) > 0 || index( $token, "\t" ) > 0 ) {
if ( $token =~ /^ (\<\<\~?) \s+ ([^\d].*) $/x ) {
$token = $1 . $2;
$rtoken_vars->[_TOKEN_] = $token;
}
}
}
elsif ( $type eq 'S' ) {
# Trim spaces in sub definitions
# save the NEW index of this token which will normally
# be @{$rLL_new} plus 1 because a blank is usually inserted
# ahead of it. The user routine will back up if necessary.
# Note that an isolated prototype starting on new line will
# be marked as 'S' but start with '(' and must be skipped.
if ( substr( $token, 0, 1 ) ne '(' ) {
$K_last_S = @{$rLL_new} + 1;
# also, remember if this is a 'my' sub
$K_last_S_is_my = $last_nonblank_code_type eq 'k'
&& (
$last_nonblank_code_token eq 'my'
|| ( $last_nonblank_code_token eq 'sub'
&& $last_last_nonblank_code_type eq 'k'
&& $last_last_nonblank_code_token eq 'my' )
);
}
# Note: an asub with prototype like this will come this way
# and be partially treated as a named sub
# sub () {
# -spp = 0 : no space before opening prototype paren
# -spp = 1 : stable (follow input spacing)
# -spp = 2 : always space before opening prototype paren
if ( !defined($rOpts_space_prototype_paren)
|| $rOpts_space_prototype_paren == 1 )
{
## default: stable
}
elsif ( $rOpts_space_prototype_paren == 0 ) {
$token =~ s/\s+\(/\(/;
}
elsif ( $rOpts_space_prototype_paren == 2 ) {
$token =~ s/\(/ (/;
}
else {
## should have been caught with the integer range check
## continue with the default
DEVEL_MODE && Fault(<[_TOKEN_] = $token;
$self->[_ris_special_identifier_token_]->{$token} = 'sub';
}
# and trim spaces in package statements (added for c250)
elsif ( $type eq 'P' ) {
# clean up spaces in package identifiers, like
# "package Bob::Dog;"
if ( $token =~ s/\s+/ /g ) {
$rtoken_vars->[_TOKEN_] = $token;
$self->[_ris_special_identifier_token_]->{$token} = 'package';
}
# remember the new K of this package; this may be
# off by 1 if a blank gets inserted before it
push @{$rK_package_list}, scalar( @{$rLL_new} );
}
# change 'LABEL :' to 'LABEL:'
elsif ( $type eq 'J' ) {
$token =~ s/\s+//g;
$rtoken_vars->[_TOKEN_] = $token;
}
else {
# no special processing for this token type
}
# Store this token with possible previous blank
if ( $rwhitespace_flags->[$KK] == WS_YES
&& @{$rLL_new}
&& $rLL_new->[-1]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace )
{
$self->store_token();
}
$self->store_token($rtoken_vars);
} # End token loop
return;
} ## end sub respace_tokens_inner_loop
sub respace_post_loop_ops {
my ($self) = @_;
# We have just completed the 'respace' operation, in which we have made
# a pass through all tokens and set the whitespace between tokens to be
# according to user settings. The new tokens have been placed in the new
# token list '$rLL_new'. Now we have to go through this new list and
# define some indexes which allow quick access into it.
return unless ( @{$rLL_new} );
# Setup array for finding the next sequence number after any token
my @K_next_seqno_by_K;
my $K_last = 0;
foreach my $K (@K_sequenced_token_list) {
push @K_next_seqno_by_K, ($K) x ( $K - $K_last );
$K_last = $K;
}
# Note: here is the slow way to do the above loop (100 ms)
## foreach my $KK ( $K_last .. $K - 1 ) {
## $K_next_seqno_by_K[$KK] = $K;
## }
# This is faster (63 ms)
## my @q = ( $K_last .. $K - 1 );
## @K_next_seqno_by_K[@q] = ($K) x scalar(@q);
# The push method above is fastest, at 37 ms in my benchmark.
$self->[_rK_next_seqno_by_K_] = \@K_next_seqno_by_K;
$self->[_rK_sequenced_token_list_] = \@K_sequenced_token_list;
# Verify that arrays @K_sequenced_token_list and @{$rSS} are parallel
# arrays, meaning that they have a common array index 'I'. This index maybe
# be found by seqno with rI_container and rI_closing.
if (DEVEL_MODE) {
my $num_rSS = @{ $self->[_rSS_] };
my $num_Kseq = @K_sequenced_token_list;
# If this error occurs, we have gained or lost one or more of the
# sequenced tokens received from the tokenizer. This should never
# happen.
if ( $num_rSS != $num_Kseq ) {
Fault(<{$seqno};
next unless defined($K_opening);
# code errors may leave undefined closing tokens
my $K_closing = $K_closing_container->{$seqno};
next unless defined($K_closing);
my $lx_open = $rLL_new->[$K_opening]->[_LINE_INDEX_];
my $lx_close = $rLL_new->[$K_closing]->[_LINE_INDEX_];
my $line_diff = $lx_close - $lx_open;
$ris_broken_container->{$seqno} = $line_diff;
# See if this is a list
my $is_list;
my $rtype_count = $rtype_count_by_seqno->{$seqno};
if ($rtype_count) {
my $comma_count = $rtype_count->{','};
my $fat_comma_count = $rtype_count->{'=>'};
my $semicolon_count = $rtype_count->{';'};
if ( $rtype_count->{'f'} ) {
$semicolon_count += $rtype_count->{'f'};
}
# We will define a list to be a container with one or more commas
# and no semicolons. Note that we have included the semicolons
# in a 'for' container in the semicolon count to keep c-style for
# statements from being formatted as lists.
if ( ( $comma_count || $fat_comma_count ) && !$semicolon_count ) {
$is_list = 1;
# We need to do one more check for a parenthesized list:
# At an opening paren following certain tokens, such as 'if',
# we do not want to format the contents as a list.
if ( $rLL_new->[$K_opening]->[_TOKEN_] eq '(' ) {
my $Kp = $self->K_previous_code( $K_opening, $rLL_new );
if ( defined($Kp) ) {
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
my $token_p = $rLL_new->[$Kp]->[_TOKEN_];
$is_list =
$type_p eq 'k'
? !$is_nonlist_keyword{$token_p}
: !$is_nonlist_type{$type_p};
}
}
}
}
# Look for a block brace marked as uncertain. If the tokenizer thinks
# its guess is uncertain for the type of a brace following an unknown
# bareword then it adds a trailing space as a signal. We can fix the
# type here now that we have had a better look at the contents of the
# container. This fixes case b1085. To find the corresponding code in
# Tokenizer.pm search for 'b1085' with an editor.
my $block_type = $rblock_type_of_seqno->{$seqno};
if ( $block_type && substr( $block_type, -1, 1 ) eq SPACE ) {
# Always remove the trailing space
$block_type =~ s/\s+$//;
# Try to filter out parenless sub calls
my $Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
my $Knn2;
if ( defined($Knn1) ) {
$Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new );
}
my $type_nn1 = defined($Knn1) ? $rLL_new->[$Knn1]->[_TYPE_] : 'b';
my $type_nn2 = defined($Knn2) ? $rLL_new->[$Knn2]->[_TYPE_] : 'b';
# if ( $type_nn1 =~ /^[wU]$/ && $type_nn2 =~ /^[wiqQGCZ]$/ ) {
if ( $wU{$type_nn1} && $wiq{$type_nn2} ) {
$is_list = 0;
}
# Convert to a hash brace if it looks like it holds a list
if ($is_list) {
$block_type = EMPTY_STRING;
}
$rblock_type_of_seqno->{$seqno} = $block_type;
}
# Handle a list container
if ( $is_list && !$block_type ) {
$ris_list_by_seqno->{$seqno} = $seqno;
# Update parent container properties
my $depth = 0;
my $rparent_seqno_list = $self->get_parent_containers($seqno);
foreach my $seqno_parent ( @{$rparent_seqno_list} ) {
$depth++;
# for $rhas_list we need to save the minimum depth
if ( !$rhas_list->{$seqno_parent}
|| $rhas_list->{$seqno_parent} > $depth )
{
$rhas_list->{$seqno_parent} = $depth;
}
if ($line_diff) {
$rhas_broken_list->{$seqno_parent} = 1;
# Patch1: We need to mark broken lists with non-terminal
# line-ending commas for the -bbx=2 parameter. This insures
# that the list will stay broken. Otherwise the flag
# -bbx=2 can be unstable. This fixes case b789 and b938.
# Patch2: Updated to also require either one fat comma or
# one more line-ending comma. Fixes cases b1069 b1070
# b1072 b1076.
if (
$rlec_count_by_seqno->{$seqno}
&& ( $rlec_count_by_seqno->{$seqno} > 1
|| $rtype_count_by_seqno->{$seqno}->{'=>'} )
)
{
$rhas_broken_list_with_lec->{$seqno_parent} = 1;
}
}
}
}
# Handle code blocks ...
# The -lp option needs to know if a container holds a code block
elsif ( $block_type && $rOpts_line_up_parentheses ) {
# Update parent container properties
my $rparent_seqno_list = $self->get_parent_containers($seqno);
foreach my $seqno_parent ( @{$rparent_seqno_list} ) {
$rhas_code_block->{$seqno_parent} = 1;
$rhas_broken_code_block->{$seqno_parent} = $line_diff;
}
}
else {
# nothing special to do for this container token
}
}
# Find containers with ternaries, needed for -lp formatting.
foreach my $seqno ( keys %{$K_opening_ternary} ) {
# Update parent container properties
$self->mark_parent_containers( $seqno, $rhas_ternary );
}
# Turn off -lp for containers with here-docs with text within a container,
# since they have their own fixed indentation. Fixes case b1081.
if ($rOpts_line_up_parentheses) {
foreach my $seqno ( keys %K_first_here_doc_by_seqno ) {
my $Kh = $K_first_here_doc_by_seqno{$seqno};
my $Kc = $K_closing_container->{$seqno};
my $line_Kh = $rLL_new->[$Kh]->[_LINE_INDEX_];
my $line_Kc = $rLL_new->[$Kc]->[_LINE_INDEX_];
next if ( $line_Kh == $line_Kc );
$ris_excluded_lp_container->{$seqno} = 1;
}
}
# Set a flag to turn off -cab=3 in complex structures. Otherwise,
# instability can occur. When it is overridden the behavior of the closest
# match, -cab=2, will be used instead. This fixes cases b1096 b1113.
if ( $rOpts_comma_arrow_breakpoints == 3 ) {
foreach my $seqno ( keys %{$K_opening_container} ) {
my $rtype_count = $rtype_count_by_seqno->{$seqno};
next unless ( $rtype_count && $rtype_count->{'=>'} );
# override -cab=3 if this contains a sub-list
if ( !defined( $roverride_cab3->{$seqno} ) ) {
if ( $rhas_list->{$seqno} ) {
$roverride_cab3->{$seqno} = 2;
}
# or if this is a sub-list of its parent container
else {
my $seqno_parent = $rparent_of_seqno->{$seqno};
if ( defined($seqno_parent)
&& $ris_list_by_seqno->{$seqno_parent} )
{
$roverride_cab3->{$seqno} = 2;
}
}
}
}
}
# Search for chains of method calls of the form (git #171)
# )->xxx( )->xxx( )->
# We have previously saved the seqno of all ')->' combinations
my $in_chain_seqno = 0;
while ( my $seqno = shift @seqno_paren_arrow ) {
# ) -> func (
# ) -> func (
# $Kc--^ ^--$K_test
my $Kc = $K_closing_container->{$seqno};
my $K_arrow = $self->K_next_nonblank( $Kc, $rLL_new );
my $K_func = $self->K_next_nonblank( $K_arrow, $rLL_new );
my $K_test = $self->K_next_nonblank( $K_func, $rLL_new );
last if ( !defined($K_test) );
# ignore index operation like ')->{' or ')->[' and end any chain
my $tok = $rLL_new->[$K_func]->[_TOKEN_];
if ( $tok eq '[' || $tok eq '{' ) { $in_chain_seqno = 0; next }
# mark seqno of parens which are part of a call chain
my $seqno_start = $in_chain_seqno ? $in_chain_seqno : $seqno;
$rseqno_arrow_call_chain_start->{$seqno} = $seqno_start;
# save a list of the arrows, needed to set line breaks
push @{ $rarrow_call_chain->{$seqno_start} }, $K_arrow;
# See if this chain continues
if ( @seqno_paren_arrow
&& defined($K_test)
&& $rLL_new->[$K_test]->[_TOKEN_] eq '('
&& $rLL_new->[$K_test]->[_TYPE_SEQUENCE_] eq $seqno_paren_arrow[0] )
{
$in_chain_seqno ||= $seqno;
}
else { $in_chain_seqno = 0 }
} ## end while ( my $seqno = shift...)
# For efficiency, remove chains with length < 2
foreach my $seqno ( keys %{$rseqno_arrow_call_chain_start} ) {
my $seqno_start = $rseqno_arrow_call_chain_start->{$seqno};
if ( @{ $rarrow_call_chain->{$seqno_start} } < 2 ) {
delete $rseqno_arrow_call_chain_start->{$seqno};
delete $rarrow_call_chain->{$seqno_start};
}
}
return;
} ## end sub respace_post_loop_ops
sub store_token {
my ( $self, ($item) ) = @_;
# Store one token during respace operations
# Given:
# $item =
# if defined => reference to a token to be stored
# if not defined => make and store a blank space
# NOTE: this sub is called once per token so coding efficiency is critical.
# If no arg, then make and store a blank space
if ( !$item ) {
# - Never start the array with a space, and
# - Never store two consecutive spaces
if ( @{$rLL_new} && $rLL_new->[-1]->[_TYPE_] ne 'b' ) {
# Note that the level and ci_level of newly created spaces should
# be the same as the previous token. Otherwise the coding for the
# -lp option can create a blinking state in some rare cases.
# (see b1109, b1110).
$item = [];
$item->[_TYPE_] = 'b';
$item->[_TOKEN_] = SPACE;
$item->[_TYPE_SEQUENCE_] = EMPTY_STRING;
$item->[_LINE_INDEX_] = $rLL_new->[-1]->[_LINE_INDEX_];
$item->[_LEVEL_] = $rLL_new->[-1]->[_LEVEL_];
}
else { return }
}
# The next multiple assignment statements are significantly faster than
# doing them one-by-one.
my (
$type,
$token,
$type_sequence,
) = @{$item}[
_TYPE_,
_TOKEN_,
_TYPE_SEQUENCE_,
];
# Set the token length. Later it may be adjusted again if phantom or
# ignoring side comment lengths. It is always okay to calculate the length
# with $length_function->() if it is defined, but it is extremely slow so
# we avoid it and use the builtin length() for printable ascii tokens.
# Note: non-printable ascii characters (like tab) may get different lengths
# by the two methods, so we have to use $length_function for them.
my $token_length =
( $length_function
&& !$is_ascii_type{$type}
&& $token =~ /[[:^ascii:][:^print:]]/ )
? $length_function->($token)
: length($token);
# handle blanks
if ( $type eq 'b' ) {
# Do not output consecutive blanks. This situation should have been
# prevented earlier, but it is worth checking because later routines
# make this assumption.
if ( @{$rLL_new} && $rLL_new->[-1]->[_TYPE_] eq 'b' ) {
return;
}
}
# handle comments
elsif ( $type eq '#' ) {
# trim comments if necessary
my $ord = ord( substr( $token, -1, 1 ) );
if (
$ord > 0
&& ( $ord < ORD_PRINTABLE_MIN
|| $ord > ORD_PRINTABLE_MAX )
&& $token =~ s/\s+$//
)
{
$token_length =
$length_function ? $length_function->($token) : length($token);
$item->[_TOKEN_] = $token;
}
my $ignore_sc_length = $rOpts_ignore_side_comment_lengths;
# Ignore length of '## no critic' comments even if -iscl is not set
if ( !$ignore_sc_length
&& !$rOpts_ignore_perlcritic_comments
&& $token_length > 10
&& substr( $token, 1, 1 ) eq '#'
&& $token =~ /^##\s*no\s+critic\b/ )
{
# Is it a side comment or a block comment?
if ( $Ktoken_vars > $Kfirst_old ) {
# This is a side comment. If we do not ignore its length, and
# -iscl has not been set, then the line could be broken and
# perlcritic will complain. So this is essential:
$ignore_sc_length ||= 1;
# It would be a good idea to also make this behave like a
# static side comment, but this is not essential and would
# change existing formatting. So we will leave it to the user
# to set -ssc if desired.
}
else {
# This is a full-line (block) comment.
# It would be a good idea to make this behave like a static
# block comment, but this is not essential and would change
# existing formatting. So we will leave it to the user to
# set -sbc if desired
}
}
# Set length of ignored side comments as just 1
if ( $ignore_sc_length && ( !$CODE_type || $CODE_type eq 'HSC' ) ) {
$token_length = 1;
}
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno) ) {
$self->[_rblank_and_comment_count_]->{$seqno} += 1
if ( $CODE_type eq 'BC' );
if ( !$ris_permanently_broken->{$seqno} ) {
$ris_permanently_broken->{$seqno} = 1;
$self->mark_parent_containers( $seqno,
$ris_permanently_broken );
}
}
}
# handle non-blanks and non-comments
else {
my $block_type;
# check for a sequenced item (i.e., container or ?/:)
if ($type_sequence) {
# This will be the index of this item in the new array
my $KK_new = @{$rLL_new};
# remember new K of sequence tokens
push @K_sequenced_token_list, $KK_new;
if ( $is_opening_token{$token} ) {
$K_opening_container->{$type_sequence} = $KK_new;
$block_type = $rblock_type_of_seqno->{$type_sequence};
# Fix for case b1100: Count a line ending in ', [' as having
# a line-ending comma. Otherwise, these commas can be hidden
# with something like --opening-square-bracket-right
if ( $last_nonblank_code_type eq ','
&& $Ktoken_vars == $Klast_old_code
&& $Ktoken_vars > $Kfirst_old )
{
$rlec_count_by_seqno->{$type_sequence}++;
}
if ( $last_nonblank_code_type eq '='
|| $last_nonblank_code_type eq '=>' )
{
$ris_assigned_structure->{$type_sequence} =
$last_nonblank_code_type;
}
my $seqno_parent = $seqno_stack{ $depth_next - 1 };
$seqno_parent = SEQ_ROOT unless defined($seqno_parent);
push @{ $rchildren_of_seqno->{$seqno_parent} }, $type_sequence;
$rparent_of_seqno->{$type_sequence} = $seqno_parent;
$seqno_stack{$depth_next} = $type_sequence;
$K_old_opening_by_seqno{$type_sequence} = $Ktoken_vars;
$depth_next++;
if ( $depth_next > $depth_next_max ) {
$depth_next_max = $depth_next;
}
}
elsif ( $is_closing_token{$token} ) {
$K_closing_container->{$type_sequence} = $KK_new;
$block_type = $rblock_type_of_seqno->{$type_sequence};
# Do not include terminal commas in counts
if ( $last_nonblank_code_type eq ','
|| $last_nonblank_code_type eq '=>' )
{
$rtype_count_by_seqno->{$type_sequence}
->{$last_nonblank_code_type}--;
if ( $Ktoken_vars == $Kfirst_old
&& $last_nonblank_code_type eq ','
&& $rlec_count_by_seqno->{$type_sequence} )
{
$rlec_count_by_seqno->{$type_sequence}--;
}
# set flag to retain trailing comma breaks (b1493, c416)
# length check needed to ignore phantom commas (b1496)
if ( $last_nonblank_code_type eq ','
&& $trailing_comma_break_rules{$token}
&& length($last_nonblank_code_token) )
{
my $rule = $trailing_comma_break_rules{$token};
my ( $letter, $paren_flag ) = @{$rule};
my $match;
if ( $letter eq 'b' ) {
$match = $Ktoken_vars == $Kfirst_old;
}
elsif ( $letter eq 'm' ) {
$match = $K_old_opening_by_seqno{$type_sequence} <
$Kfirst_old;
}
elsif ( $letter eq '1' || $letter eq '*' ) {
$match = 1;
}
else {
## shouldn't happen - treat as 'b' for now
DEVEL_MODE && Fault(<match_paren_control_flag( $type_sequence,
$paren_flag, $rLL_new );
}
if ($match) {
$self->[_rbreak_container_]->{$type_sequence} = 1;
}
}
}
# Update the stack...
$depth_next--;
}
else {
# For ternary, note parent but do not include as child
my $seqno_parent = $seqno_stack{ $depth_next - 1 };
$seqno_parent = SEQ_ROOT unless defined($seqno_parent);
$rparent_of_seqno->{$type_sequence} = $seqno_parent;
# These are not yet used but could be useful
if ( $token eq '?' ) {
$K_opening_ternary->{$type_sequence} = $KK_new;
}
elsif ( $token eq ':' ) {
$K_closing_ternary->{$type_sequence} = $KK_new;
}
else {
# We really shouldn't arrive here, just being cautious:
# The only sequenced types output by the tokenizer are the
# opening & closing containers and the ternary types. Each
# of those was checked above. So we would only get here
# if the tokenizer has been changed to mark some other
# tokens with sequence numbers.
if (DEVEL_MODE) {
Fault(
"Unexpected token type with sequence number: type='$type', seqno='$type_sequence'"
);
}
}
}
}
# Remember the most recent two non-blank, non-comment tokens.
# NOTE: the phantom semicolon code may change the output stack
# without updating these values. Phantom semicolons are considered
# the same as blanks for now, but future needs might change that.
# See the related note in sub 'add_phantom_semicolon'.
$last_last_nonblank_code_type = $last_nonblank_code_type;
$last_last_nonblank_code_token = $last_nonblank_code_token;
$last_nonblank_code_type = $type;
$last_nonblank_code_token = $token;
$last_nonblank_block_type = $block_type;
# count selected types
if ( $is_counted_type{$type} ) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno) ) {
$rtype_count_by_seqno->{$seqno}->{$type}++;
# Count line-ending commas for -bbx
if ( $type eq ',' && $Ktoken_vars == $Klast_old_code ) {
$rlec_count_by_seqno->{$seqno}++;
}
# Remember index of first here doc target
if ( $type eq 'h' && !$K_first_here_doc_by_seqno{$seqno} ) {
my $KK_new = @{$rLL_new};
$K_first_here_doc_by_seqno{$seqno} = $KK_new;
# the here doc which follows makes the container broken
if ( !$ris_permanently_broken->{$seqno} ) {
$ris_permanently_broken->{$seqno} = 1;
$self->mark_parent_containers( $seqno,
$ris_permanently_broken );
}
}
}
}
}
# cumulative length is the length sum including this token
$cumulative_length += $token_length;
$item->[_CUMULATIVE_LENGTH_] = $cumulative_length;
$item->[_TOKEN_LENGTH_] = $token_length;
# For reference, here is how to get the parent sequence number.
# This is not used because it is slower than finding it on the fly
# in sub parent_seqno_by_K:
# my $seqno_parent =
# $type_sequence && $is_opening_token{$token}
# ? $seqno_stack{ $depth_next - 2 }
# : $seqno_stack{ $depth_next - 1 };
# my $KK = @{$rLL_new};
# $rseqno_of_parent_by_K->{$KK} = $seqno_parent;
# and finally, add this item to the new array
push @{$rLL_new}, $item;
return;
} ## end sub store_token
sub add_phantom_semicolon {
my ( $self, $KK ) = @_;
# The token at old index $KK is a closing block brace, and not preceded
# by a semicolon. Before we push it onto the new token list, we may
# want to add a phantom semicolon which can be activated if the the
# block is broken on output.
# We are only adding semicolons for certain block types
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
return unless ($type_sequence);
my $block_type = $rblock_type_of_seqno->{$type_sequence};
return unless ($block_type);
return
unless ( $ok_to_add_semicolon_for_block_type{$block_type}
|| $block_type =~ /^(sub|package)/
|| $block_type =~ /^\w+\:$/ );
# Find the most recent token in the new token list
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) ); # shouldn't happen except for bad input
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
my $token_p = $rLL_new->[$Kp]->[_TOKEN_];
my $type_sequence_p = $rLL_new->[$Kp]->[_TYPE_SEQUENCE_];
# Do not add a semicolon if...
return
if (
# it would follow a comment (and be isolated)
$type_p eq '#'
# it follows a code block ( because they are not always wanted
# there and may add clutter)
|| $type_sequence_p && $rblock_type_of_seqno->{$type_sequence_p}
# it would follow a label
|| $type_p eq 'J'
# it would be inside a 'format' statement (and cause syntax error)
|| ( $type_p eq 'k'
&& $token_p =~ /format/ )
);
# Do not add a semicolon if it would impede a weld with an immediately
# following closing token...like this
# { ( some code ) }
# ^--No semicolon can go here
# look at the previous token... note use of the _NEW rLL array here,
# but sequence numbers are invariant.
my $seqno_inner = $rLL_new->[$Kp]->[_TYPE_SEQUENCE_];
# If it is also a CLOSING token we have to look closer...
if (
$seqno_inner
&& $is_closing_token{$token_p}
# we only need to look if there is just one inner container..
&& defined( $rchildren_of_seqno->{$type_sequence} )
&& @{ $rchildren_of_seqno->{$type_sequence} } == 1
)
{
# Go back and see if the corresponding two OPENING tokens are also
# together. Note that we are using the OLD K indexing here:
my $K_outer_opening = $K_old_opening_by_seqno{$type_sequence};
if ( defined($K_outer_opening) ) {
my $K_nxt = $self->K_next_nonblank($K_outer_opening);
if ( defined($K_nxt) ) {
my $seqno_nxt = $rLL->[$K_nxt]->[_TYPE_SEQUENCE_];
# Is the next token after the outer opening the same as
# our inner closing (i.e. same sequence number)?
# If so, do not insert a semicolon here.
return if ( $seqno_nxt && $seqno_nxt == $seqno_inner );
}
}
}
# 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', SPACE );
# 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 = EMPTY_STRING;
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_] = ';';
$self->[_rtype_count_by_seqno_]->{$type_sequence}->{';'}++;
# NOTE: we are changing the output stack without updating variables
# $last_nonblank_code_type, etc. Future needs might require that
# those variables be updated here. For now, it seems ok to skip
# this.
# Then store a new blank
$self->store_token($rcopy);
}
else {
# Patch for issue c078: keep line indexes in order. If the top
# token is a space that we are keeping (due to '-wls=';') then
# we have to check that old line indexes stay in order.
# In very rare
# instances in which side comments have been deleted and converted
# into blanks, we may have filtered down multiple blanks into just
# one. In that case the top blank may have a higher line number
# than the previous nonblank token. Although the line indexes of
# blanks are not really significant, we need to keep them in order
# in order to pass error checks.
if ( $rLL_new->[$Ktop]->[_TYPE_] eq 'b' ) {
my $old_top_ix = $rLL_new->[$Ktop]->[_LINE_INDEX_];
my $new_top_ix = $rLL_new->[$Kp]->[_LINE_INDEX_];
if ( $new_top_ix < $old_top_ix ) {
$rLL_new->[$Ktop]->[_LINE_INDEX_] = $new_top_ix;
}
}
my $rcopy = copy_token_as_type( $rLL_new->[$Kp], ';', EMPTY_STRING );
$self->store_token($rcopy);
}
return;
} ## end sub add_phantom_semicolon
sub delay_trailing_comma_op {
my ( $self, $if_add, $stable_flag ) = @_;
# Given:
# $if_add = true for add comma operation, false for delete
# $stable_flag = true if -btct setting makes this stable
# Returns:
# true if a trailing comma operation should be skipped
# false otherwise
# This can prevent unwanted path-dependent formatting when both
# line breaks are changing and we are only adding or deleting
# commas, but not both. See git #156
# Get user setting, if any
my $delay = $rOpts->{'delay-trailing-comma-operations'};
# Set default if not defined:
# - if deleting: delay always ok
# - if adding: delay ok unless breaks will be stabilized by -btct setting
# Explanation:
# - deleting can be irreversible, so it is safest to delay
# - adding, along with -btct, can save original line breaks which would
# be lost otherwise, so it may be best not to delay.
if ( !defined($delay) ) {
$delay = $if_add ? !$stable_flag : 1;
}
return if ( !$delay );
# We must be at the first of multiple iterations for a delay
my $it = Perl::Tidy::get_iteration_count();
my $max_iterations = $rOpts->{'iterations'};
if ( $it == 1 && $max_iterations > 1 ) {
# if so, set flag to request another iteration
$self->[_want_second_iteration_] = 1;
return 1;
}
return;
} ## end sub delay_trailing_comma_op
my %is_b_i_h;
BEGIN {
my @q = qw( b i h );
@is_b_i_h{@q} = (1) x scalar(@q);
}
sub add_trailing_comma {
# Implement the --add-trailing-commas flag to the line end before index $KK:
my ( $self, $KK, $Kfirst, $trailing_comma_add_rule ) = @_;
# Input parameter:
# $KK = index of closing token in old ($rLL) token list
# which starts a new line and is not preceded by a comma
# $Kfirst = index of first token on the current line of input tokens
# $trailing_comma_add_rule = user control flags for adding trailng commas
# For example, we might want to add a comma here:
# bless {
# _name => $name,
# _price => $price,
# _rebate => $rebate <------ location of possible bare comma
# }, $pkg;
# ^-------------------closing token at index $KK on new line
# Do not add a comma if it would follow a comment
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
return if ( $type_p eq '#' );
return unless ($trailing_comma_add_rule);
my ( $trailing_comma_style, $paren_flag, $stable_flag ) =
@{$trailing_comma_add_rule};
# see if the user wants a trailing comma here
my $match =
$self->match_trailing_comma_rule( $KK, $Kfirst, $Kp,
$trailing_comma_style, $paren_flag, $stable_flag, 1 );
# Do not add if this would cause excess line length and possible
# instability. This is b1458 fix method 1. This is more general than fix
# method 2, below, which also worked. So this is not needed for b1458 but
# re-activated and updated for b1495.
if ( $match
&& $rOpts_delete_trailing_commas
&& $KK > 0 )
{
if ( !$stable_flag && $is_b_i_h{$trailing_comma_style} ) {
my $line_index = $rLL->[ $KK - 1 ]->[_LINE_INDEX_];
my $rlines = $self->[_rlines_];
my $line_of_tokens = $rlines->[$line_index];
my $input_line = $line_of_tokens->{_line_text};
my $len =
$length_function
? $length_function->($input_line) - 1
: length($input_line) - 1;
my $new_len = $want_left_space{','} ? $len + 2 : $len + 1;
my $level = $rLL->[$Kfirst]->[_LEVEL_];
my $max_len = $maximum_line_length_at_level[$level];
if ( $new_len > $max_len ) {
$match = 0;
}
}
}
# If so, and not delayed, add a comma
if ( $match && !$self->delay_trailing_comma_op( 1, $stable_flag ) ) {
# any blank after the comma will be added before the closing paren,
# below
$self->store_new_token( ',', ',', $Kp );
}
return;
} ## end sub add_trailing_comma
sub delete_trailing_comma {
my ( $self, $KK, $Kfirst, $trailing_comma_delete_rule ) = @_;
# Apply the --delete-trailing-commas flag to the comma before index $KK
# Input parameter:
# $KK = index of a closing token in OLD ($rLL) token list
# which is preceded by a comma on the same line.
# $Kfirst = index of first token on the current line of input tokens
# $delete_option = user control flag
# Returns true if the comma was deleted
# For example, we might want to delete this comma:
# my @asset = ("FASMX", "FASGX", "FASIX",);
# | |^--------token at index $KK
# | ^------comma of interest
# ^-------------token at $Kfirst
# Verify that the previous token is a comma. Note that we are working in
# the new token list $rLL_new.
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
if ( $rLL_new->[$Kp]->[_TYPE_] ne ',' ) {
# there must be a '#' between the ',' and closing token; give up.
return;
}
# Do not delete commas when formatting under stress to avoid instability.
# This fixes b1389, b1390, b1391, b1392. The $high_stress_level has
# been found to work well for trailing commas.
if ( $rLL_new->[$Kp]->[_LEVEL_] >= $high_stress_level ) {
return;
}
return unless ($trailing_comma_delete_rule);
my ( $trailing_comma_style, $paren_flag, $stable_flag ) =
@{$trailing_comma_delete_rule};
# See if the user wants this trailing comma
my $match =
$self->match_trailing_comma_rule( $KK, $Kfirst, $Kp,
$trailing_comma_style, $paren_flag, $stable_flag, 0 );
# Patch: the --noadd-whitespace flag can cause instability in complex
# structures. In this case do not delete the comma. Fixes b1409.
if ( !$match && !$rOpts_add_whitespace ) {
my $Kn = $self->K_next_nonblank($KK);
if ( defined($Kn) ) {
my $type_n = $rLL->[$Kn]->[_TYPE_];
if ( $type_n ne ';' && $type_n ne '#' ) { return }
}
}
# b1458 fix method 2: do not remove a comma after a leading brace type 'R'
# since it is under stress and could become unstable. This is a more
# specific fix but the logic is cleaner than method 1.
if ( !$match
&& $rOpts_add_trailing_commas
&& $rLL->[$Kfirst]->[_TYPE_] eq 'R' )
{
# previous old token should be the comma..
my $Kp_old = $self->K_previous_nonblank( $KK, $rLL );
if ( defined($Kp_old)
&& $Kp_old > $Kfirst
&& $rLL->[$Kp_old]->[_TYPE_] eq ',' )
{
# if the comma follows the first token of the line ..
my $Kpp_old = $self->K_previous_nonblank( $Kp_old, $rLL );
if ( defined($Kpp_old) && $Kpp_old eq $Kfirst ) {
# do not delete it
$match = 1;
}
}
}
# If no match and not delayed
if ( !$match && !$self->delay_trailing_comma_op( 0, $stable_flag ) ) {
# delete it
return $self->unstore_last_nonblank_token(',');
}
return;
} ## end sub delete_trailing_comma
sub delete_weld_interfering_comma {
my ( $self, $KK ) = @_;
# Apply the flag '--delete-weld-interfering-commas' to the comma
# before index $KK
# Input parameter:
# $KK = index of a closing token in OLD ($rLL) token list
# which is preceded by a comma on the same line.
# Returns true if the comma was deleted
# For example, we might want to delete this comma:
# my $tmpl = { foo => {no_override => 1, default => 42}, };
# || ^------$KK
# |^---$Kp
# $Kpp---^
#
# Note that:
# index $KK is in the old $rLL array, but
# indexes $Kp and $Kpp are in the new $rLL_new array.
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
return unless ($type_sequence);
# Find the previous token and verify that it is a comma.
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
if ( $rLL_new->[$Kp]->[_TYPE_] ne ',' ) {
# it is not a comma, so give up ( it is probably a '#' )
return;
}
# This must be the only comma in this list
my $rtype_count = $self->[_rtype_count_by_seqno_]->{$type_sequence};
return
unless ( defined($rtype_count)
&& $rtype_count->{','}
&& $rtype_count->{','} == 1 );
# Back up to the previous closing token
my $Kpp = $self->K_previous_nonblank( $Kp, $rLL_new );
return unless ( defined($Kpp) );
my $seqno_pp = $rLL_new->[$Kpp]->[_TYPE_SEQUENCE_];
my $type_pp = $rLL_new->[$Kpp]->[_TYPE_];
# The containers must be nesting (i.e., sequence numbers must differ by 1 )
if ( $seqno_pp && $is_closing_type{$type_pp} ) {
if ( $seqno_pp == $type_sequence + 1 ) {
# remove the ',' from the top of the new token list
return $self->unstore_last_nonblank_token(',');
}
}
return;
} ## end sub delete_weld_interfering_comma
sub add_interbracket_arrow {
my ($self) = @_;
# Add a new '->' after the last token on the stack
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
# verify that we are adding after a } or ]
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
if ( $type_p ne 'R' && $type_p ne ']' ) {
DEVEL_MODE && Fault("trying to store new arrow after type $type_p");
return;
}
$self->store_new_token( '->', '->', $Kp );
if ( $want_right_space{'->'} == WS_YES ) { $self->store_token() }
return;
} ## end sub add_interbracket_arrow
sub delete_interbracket_arrow {
my ($self) = @_;
# Delete the last nonblank token on the stack which is an '->'
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
# verify that we are deleting an '->'
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
if ( $type_p ne '->' ) {
DEVEL_MODE && Fault("trying to delete arrow but type $type_p");
return;
}
$self->unstore_last_nonblank_token( '->', -1 );
return;
} ## end sub delete_interbracket_arrow
sub unstore_last_nonblank_token {
my ( $self, $type, ($want_space) ) = @_;
# remove the most recent nonblank token from the new token list
# Input parameter:
# $type = type to be removed (for safety check)
# $want_space = telling if a space should remain
# 1 => always
# 0 or undef => only if there was one (used for ',')
# -1 => never (used for '->')
# Returns true if success
# false if error
# This was written and is used for removing commas, but might
# be useful for other tokens. If it is ever used for other tokens
# then the issue of what to do about the other variables, such
# as token counts and the '$last...' vars needs to be considered.
# Safety check, shouldn't happen
if ( @{$rLL_new} < 3 ) {
DEVEL_MODE && Fault("not enough tokens on stack to remove '$type'\n");
return;
}
if ( !defined($want_space) ) { $want_space = 0 }
my ( $rcomma, $rblank );
# Note: originally just for ',' but now also for '->'
# case 1: pop comma from top of stack
if ( $rLL_new->[-1]->[_TYPE_] eq $type ) {
$rcomma = pop @{$rLL_new};
}
# case 2: pop blank and then comma from top of stack
elsif ($rLL_new->[-1]->[_TYPE_] eq 'b'
&& $rLL_new->[-2]->[_TYPE_] eq $type )
{
$rblank = pop @{$rLL_new};
$rcomma = pop @{$rLL_new};
}
# case 3: error, shouldn't happen unless bad call
else {
DEVEL_MODE && Fault("Could not find token type '$type' to remove\n");
return;
}
# A note on updating vars set by sub store_token for this comma: If we
# reduce the comma count by 1 then we also have to change the variable
# $last_nonblank_code_type to be $last_last_nonblank_code_type because
# otherwise sub store_token is going to ALSO reduce the comma count.
# Alternatively, we can leave the count alone and the
# $last_nonblank_code_type alone. Then sub store_token will produce
# the correct result. This is simpler and is done here.
# remove a remaining blank if requested
if ( $rLL_new->[-1]->[_TYPE_] eq 'b' ) {
# current method for deleted '->'
if ( $want_space == -1 ) {
pop @{$rLL_new};
}
}
# add a blank if requested
else {
if ( $want_space == 1 ) {
$self->store_token();
}
elsif ( !$want_space ) {
# add one if there was one (current method for commas)
if ( defined($rblank) ) {
my $len = length($type);
$rblank->[_CUMULATIVE_LENGTH_] -= $len; # fix for deleted comma
push @{$rLL_new}, $rblank;
}
}
else {
# want_space=-1 so do not add a blank
}
}
return 1;
} ## end sub unstore_last_nonblank_token
sub is_list_assignment {
my ( $self, $K_opening ) = @_;
# Given:
# $K_opening = index in $rLL_new of an opening paren
# Return:
# true if this is a list assignment of the form '@xxx = ('
# false otherwise
return unless defined($K_opening);
my $Km = $self->K_previous_nonblank( $K_opening, $rLL_new );
return unless defined($Km);
my $type_m = $rLL_new->[$Km]->[_TYPE_];
# Look for list assignment like '@list = (' or '@{$ref} = ('
# or '%hash = ('
if ( $type_m eq '=' ) {
my $token_m = $rLL_new->[$Km]->[_TOKEN_];
$Km = $self->K_previous_nonblank( $Km, $rLL_new );
return unless defined($Km);
$type_m = $rLL_new->[$Km]->[_TYPE_];
$token_m = $rLL_new->[$Km]->[_TOKEN_];
# backup past a braced item
if ( $token_m eq '}' ) {
my $seqno_m = $rLL_new->[$Km]->[_TYPE_SEQUENCE_];
return unless ($seqno_m);
my $K_opening_m = $self->[_K_opening_container_]->{$seqno_m};
return unless defined($K_opening_m);
$Km = $self->K_previous_nonblank( $K_opening_m, $rLL_new );
return unless defined($Km);
$type_m = $rLL_new->[$Km]->[_TYPE_];
$token_m = $rLL_new->[$Km]->[_TOKEN_];
}
if ( $type_m eq 'i' || $type_m eq 't' ) {
my $sigil = substr( $token_m, 0, 1 );
if ( $sigil eq '@' ) {
return 1;
}
}
}
return;
} ## end sub is_list_assignment
my %is_not_list_paren;
BEGIN {
## trailing comma logic ignores opening parens preceded by these tokens
my @q = qw# if elsif unless while and or err not && | || ? : ! . #;
@is_not_list_paren{@q} = (1) x scalar(@q);
}
sub match_trailing_comma_rule {
my ( $self, $KK, $Kfirst, $Kp, $trailing_comma_style, $paren_flag,
$stable_flag, $if_add )
= @_;
# Decide if a trailing comma rule is matched.
# Input parameter:
# $KK = index of closing token in old ($rLL) token list which follows
# the location of a possible trailing comma. See diagram below.
# $Kfirst = (old) index of first token on the current line of input tokens
# $Kp = index of previous nonblank token in new ($rLL_new) array
# $trailing_comma_rule = packed user control flags
# $if_add = true if adding comma, false if deleting comma
# Returns:
# false if no match
# true if match
# !$if_add to keep the current state unchanged
# For example, we might be checking for addition of a comma here:
# bless {
# _name => $name,
# _price => $price,
# _rebate => $rebate <------ location of possible trailing comma
# }, $pkg;
# ^-------------------closing token at index $KK
# List of $trailing_comma_style values:
# undef stable: do not change
# '1' or '*' : every list should have a trailing comma
# 'm' a multi-line list should have a trailing commas
# 'b' trailing commas should be 'bare' (comma followed by newline)
# 'i' same as s=h but also include any list with no more than about one
# comma per line
# 'h' lists of key=>value pairs with a bare trailing comma
# '0' : no list should have a trailing comma
# ' ' or -wtc not defined : leave trailing commas unchanged [DEFAULT].
# Note the hierarchy:
# '1' includes all 'm' includes all 'b' includes all 'i' includes all 'h'
# Note: an interesting generalization would be to let an upper case
# letter denote the negation of styles 'm', 'b', 'h', 'i'. This might
# be useful for undoing operations. It would be implemented as a wrapper
# around this routine.
# Return !$if_add to keep the current state unchanged
my $no_change = !$if_add;
# If no style defined : do not add or delete
if ( !defined($trailing_comma_style) ) { return $no_change }
#----------------------------------------
# Set some flags describing this location
#----------------------------------------
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
return $no_change unless ($type_sequence);
my $closing_token = $rLL->[$KK]->[_TOKEN_];
# factors which force stability
my $is_permanently_broken =
$self->[_ris_permanently_broken_]->{$type_sequence};
$is_permanently_broken ||= $rOpts_break_at_old_comma_breakpoints
&& !$rOpts_ignore_old_breakpoints;
$is_permanently_broken ||= $stable_flag;
my $K_opening = $self->[_K_opening_container_]->{$type_sequence};
return $no_change if ( !defined($K_opening) );
my $iline_first_comma =
$self->[_rfirst_comma_line_index_]->{$type_sequence};
my $iline_last_comma = $rLL_new->[$Kp]->[_LINE_INDEX_];
my $rtype_count = $self->[_rtype_count_by_seqno_]->{$type_sequence};
my $comma_count = 0;
my $fat_comma_count = 0;
my $has_inner_multiline_structure;
my $has_inner_multiline_commas;
# if outer container is paren, return if this is not a possible list
# For example, return for an if paren 'if ('
my $token = $rLL_new->[$K_opening]->[_TOKEN_];
my $is_arrow_call;
my $is_hash_value;
my $is_paren_list;
if ( $token eq '(' ) {
$is_paren_list = 1;
my $Km = $self->K_previous_nonblank( $K_opening, $rLL_new );
if ( defined($Km) ) {
my $type_m = $rLL_new->[$Km]->[_TYPE_];
my $token_m = $rLL_new->[$Km]->[_TOKEN_];
if ( $type_m eq 'k' ) {
if ( $is_not_list_paren{$token_m} ) { return $no_change }
}
$is_arrow_call = $type_m eq '->';
$is_hash_value = $type_m eq '=>';
}
}
if ($rtype_count) {
$comma_count = $rtype_count->{','};
$fat_comma_count = $rtype_count->{'=>'};
}
my $follows_isolated_closing_token;
#----------------------------------------------------------------
# If no existing commas, see if we have an inner nested container
#----------------------------------------------------------------
if (
!$comma_count
&& $if_add # for safety, should be true if no commas
&& $is_closing_type{$last_nonblank_code_type}
)
{
# check for nesting closing containers
my $Kpp = $self->K_previous_nonblank( undef, $rLL_new );
return if ( !defined($Kpp) );
my $seqno_pp = $rLL_new->[$Kpp]->[_TYPE_SEQUENCE_];
my $type_pp = $rLL_new->[$Kpp]->[_TYPE_];
# nesting containers have sequence numbers which differ by 1
my $is_nesting_right =
$seqno_pp
&& $is_closing_type{$type_pp}
&& ( $seqno_pp == $type_sequence + 1 );
# Do not add a comma which will be deleted by
# --delete-weld-interfering commas (b1471)
if ( $is_nesting_right
&& $rOpts_delete_weld_interfering_commas )
{
return;
}
# Does this trailing comma follow an isolated closing token?
if ($is_nesting_right) {
my $ix_pp = $rLL_new->[$Kpp]->[_LINE_INDEX_];
my $Kpp_m = $self->K_previous_nonblank( $Kpp, $rLL_new );
if ($Kpp_m) {
my $ix_pp_m = $rLL_new->[$Kpp_m]->[_LINE_INDEX_];
$follows_isolated_closing_token = $ix_pp > $ix_pp_m;
}
}
#--------------------------------
# If no comma and no fat comma...
#--------------------------------
if ( !$fat_comma_count ) {
# containers must be nesting on the right
return unless ($is_nesting_right);
# give up if it is a code block
if ( $self->[_rblock_type_of_seqno_]->{$seqno_pp} ) {
return;
}
# if outer container is paren, must be sub call or list assignment
# Note that _ris_function_call_paren_ does not currently include
# calls of the form '->(', so that has to be checked separately.
if ( $token eq '('
&& !$self->[_ris_function_call_paren_]->{$type_sequence}
&& !$is_arrow_call
&& !$is_hash_value
&& !$self->is_list_assignment($K_opening) )
{
return;
}
my $K_opening_pp = $self->[_K_opening_container_]->{$seqno_pp};
return unless defined($K_opening_pp);
my $iline_o = $rLL_new->[$K_opening_pp]->[_LINE_INDEX_];
my $iline_c = $rLL_new->[$Kpp]->[_LINE_INDEX_];
my $rtype_count_pp = $self->[_rtype_count_by_seqno_]->{$seqno_pp};
return unless ($rtype_count_pp);
$has_inner_multiline_structure =
$iline_c > $iline_o
&& ( $rtype_count_pp->{','} || $rtype_count_pp->{'=>'} )
&& !$rtype_count_pp->{';'};
return unless ($has_inner_multiline_structure);
# look for inner multiline commas
$iline_first_comma =
$self->[_rfirst_comma_line_index_]->{$seqno_pp};
return if ( !defined($iline_first_comma) );
my $iline_ppc = $rLL_new->[$Kpp]->[_LINE_INDEX_];
return if ( $iline_ppc <= $iline_first_comma );
$has_inner_multiline_commas = 1;
# OK, we have an inner container with commas
}
}
#--------------------------------
# Characterize the trailing comma
#--------------------------------
if ( !defined($iline_first_comma) ) {
# Shouldn't happen: if this sub was called without any commas in this
# container, then either we should have found one in a nested container
# or already returned.
if (DEVEL_MODE) {
my $type_kp = $rLL_new->[$Kp]->[_TYPE_];
Fault(
"at line $iline_last_comma but line of first comma not defined, at Kp=$Kp, type=$type_kp\n"
);
}
return;
}
# multiline commas: first and last commas on different lines
# Note that _ris_broken_container_ also stores the line diff
# but it is not available at this early stage.
my $line_diff_commas = $iline_last_comma - $iline_first_comma;
my $has_multiline_commas =
$line_diff_commas > 0 || $has_inner_multiline_commas;
# Multiline ('m'): the opening and closing tokens on different lines
my $iline_o = $rLL_new->[$K_opening]->[_LINE_INDEX_];
my $iline_c = $rLL->[$KK]->[_LINE_INDEX_];
my $is_multiline = $iline_c > $iline_o;
# Require additional stability factors when adding commas
if ($if_add) {
# basic stability rules
my $is_stable = (
# has commas not in parens, or multiple lines ending in commas
$comma_count
&& ( !$is_paren_list || $has_multiline_commas )
# or contains an inner multiline structure
|| $has_inner_multiline_structure
# or has other stabilizing factors, like comments and blank lines
|| $is_permanently_broken
);
# special stability rules for fat-commas ...
if ( !$is_stable && $fat_comma_count ) {
# stable if not in paren list
$is_stable ||= !$is_paren_list;
# a paren container must span several lines (b1489, b1490)
# and the trailing comma must follow an isolated closing token if
# just 1 '=>' (b1492 b1493 b1494)
$is_stable ||= ( $iline_c - $iline_o > 1 )
&& ( $follows_isolated_closing_token
|| $fat_comma_count > 1 );
}
$is_multiline &&= $is_stable;
}
# Bare 'b': a multiline where the closing container token starts a new line:
my $is_bare_trailing_comma = $is_multiline && $KK == $Kfirst;
#---------------------
# Check for a match...
#---------------------
my $match;
#----------------------------
# 0 : does not match any list
#----------------------------
if ( $trailing_comma_style eq '0' ) {
$match = 0;
}
#------------------------------
# '*' or '1' : matches any list
#------------------------------
elsif ( $trailing_comma_style eq '*' || $trailing_comma_style eq '1' ) {
$match = 1;
}
#-----------------------------
# 'm' matches a Multiline list
#-----------------------------
elsif ( $trailing_comma_style eq 'm' ) {
$match = $is_multiline;
}
#----------------------------------
# 'b' matches a Bare trailing comma
#----------------------------------
elsif ( $trailing_comma_style eq 'b' ) {
$match = $is_bare_trailing_comma;
}
#--------------------------------------------------------------------------
# 'h' matches a bare hash list with about 1 comma and 1 fat comma per line.
# 'i' matches a bare stable list with about 1 comma per line.
#--------------------------------------------------------------------------
elsif ( $trailing_comma_style eq 'h' || $trailing_comma_style eq 'i' ) {
# We can treat these together because they are similar.
# The set of 'i' matches includes the set of 'h' matches.
# the trailing comma must be bare for both 'h' and 'i'
return if ( !$is_bare_trailing_comma );
# There must be no more than one comma per line for both 'h' and 'i'
# The new_comma_count here will include the trailing comma.
my $new_comma_count = $comma_count;
$new_comma_count += 1 if ($if_add);
my $excess_commas = $new_comma_count - $line_diff_commas - 1;
if ( $excess_commas > 0 ) {
# Exception for a special edge case for option 'i': if the trailing
# comma is followed by a blank line or comment, then it cannot be
# covered. Then we can safely accept a small list to avoid
# instability (issue b1443).
if ( $trailing_comma_style eq 'i'
&& $iline_c - $rLL_new->[$Kp]->[_LINE_INDEX_] > 1
&& $new_comma_count <= 2 )
{
$match = 1;
}
# Patch for instability issue b1456: -boc can trick this test; so
# skip it when deleting commas to avoid possible instability
# with option 'h' in combination with -atc -dtc -boc;
elsif (
$trailing_comma_style eq 'h'
# this is a deletion (due to -dtc)
&& !$if_add
# -atc is also set
&& $rOpts_add_trailing_commas
# -boc is set and active
&& $rOpts_break_at_old_comma_breakpoints
&& !$rOpts_ignore_old_breakpoints
)
{
# ignore this test
}
else {
return 0;
}
}
# check fat commas
if (
!$match
&& $fat_comma_count
&& (
# - a list of key=>value pairs with at least 2 fat commas is a
# match for both 'h' and 'i'
$fat_comma_count >= 2
# - an isolated fat comma is a match for type 'h'
# and also 'i' (see note below)
|| (
$fat_comma_count == 1
&& $new_comma_count == 1
## && $if_add ## removed to fix b1476
## removed so that 'i' and 'h' work the same here
## && $trailing_comma_style eq 'h'
)
)
)
{
# but comma count (including trailer) and fat comma count must
# differ by by no more than 1. This allows for some small
# variations.
my $comma_diff = $new_comma_count - $fat_comma_count;
$match = ( $comma_diff >= -1 && $comma_diff <= 1 );
}
# For 'i' only, a list that can be shown to be stable is a match
if ( !$match && $trailing_comma_style eq 'i' ) {
$match = (
$is_permanently_broken
|| ( $rOpts_break_at_old_comma_breakpoints
&& !$rOpts_ignore_old_breakpoints )
);
}
}
#-------------------------------------------------------------------------
# Unrecognized parameter. This should have been caught in the input check.
#-------------------------------------------------------------------------
else {
DEVEL_MODE && Fault("Unrecognized parameter '$trailing_comma_style'\n");
# do not add or delete
return !$if_add;
}
# Now do any special paren check
if ( $match
&& $paren_flag
&& $paren_flag ne '1'
&& $paren_flag ne '*'
&& $closing_token eq ')' )
{
$match &&=
$self->match_paren_control_flag( $type_sequence, $paren_flag,
$rLL_new );
}
# Fix for b1379, b1380, b1381, b1382, b1384 part 1. Mark trailing commas
# for use by -vtc logic to avoid instability when -dtc and -atc are both
# active.
if ($match) {
if ( $if_add && $rOpts_delete_trailing_commas
|| !$if_add && $rOpts_add_trailing_commas )
{
$self->[_ris_bare_trailing_comma_by_seqno_]->{$type_sequence} = 1;
# The combination of -atc and -dtc and -cab=3 can be unstable
# (b1394). So we deactivate -cab=3 in this case.
# A value of '0' or '4' is required for stability of case b1451.
if ( $rOpts_comma_arrow_breakpoints == 3 ) {
$self->[_roverride_cab3_]->{$type_sequence} = 0;
}
}
}
return $match;
} ## end sub match_trailing_comma_rule
sub store_new_token {
my ( $self, $type, $token, $Kp ) = @_;
# Create and insert a completely new token into the output stream
# Caller must add space after this token if necessary
# Input parameters:
# $type = the token type
# $token = the token text
# $Kp = index of the previous token in the new list, $rLL_new
# This operation is a little tricky because we are creating a new token and
# we have to take care to follow the requested whitespace rules.
my $Ktop = @{$rLL_new} - 1;
my $top_is_space = $Ktop >= 0 && $rLL_new->[$Ktop]->[_TYPE_] eq 'b';
if ( $top_is_space && $want_left_space{$type} == WS_NO ) {
#----------------------------------------------------
# Method 1: Convert the top blank into the new token.
#----------------------------------------------------
# Be Careful: we are working on the top of the new stack, on a token
# which has been stored.
$rLL_new->[$Ktop]->[_TOKEN_] = $token;
$rLL_new->[$Ktop]->[_TOKEN_LENGTH_] = length($token);
$rLL_new->[$Ktop]->[_TYPE_] = $type;
# NOTE: we are changing the output stack without updating variables
# $last_nonblank_code_type, etc. Future needs might require that
# those variables be updated here. For now, we just update the
# type counts as necessary.
if ( $is_counted_type{$type} ) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ($seqno) {
$self->[_rtype_count_by_seqno_]->{$seqno}->{$type}++;
}
}
}
else {
#----------------------------------------
# Method 2: Use the normal storage method
#----------------------------------------
# Patch for issue c078: keep line indexes in order. If the top
# token is a space that we are keeping (due to '-wls=...) then
# we have to check that old line indexes stay in order.
# In very rare
# instances in which side comments have been deleted and converted
# into blanks, we may have filtered down multiple blanks into just
# one. In that case the top blank may have a higher line number
# than the previous nonblank token. Although the line indexes of
# blanks are not really significant, we need to keep them in order
# in order to pass error checks.
if ($top_is_space) {
my $old_top_ix = $rLL_new->[$Ktop]->[_LINE_INDEX_];
my $new_top_ix = $rLL_new->[$Kp]->[_LINE_INDEX_];
if ( $new_top_ix < $old_top_ix ) {
$rLL_new->[$Ktop]->[_LINE_INDEX_] = $new_top_ix;
}
}
else {
if ( $want_left_space{$type} == WS_YES ) {
$self->store_token();
}
}
my $rcopy = copy_token_as_type( $rLL_new->[$Kp], $type, $token );
$self->store_token($rcopy);
}
$last_last_nonblank_code_type = $last_nonblank_code_type;
$last_last_nonblank_code_token = $last_nonblank_code_token;
$last_nonblank_code_type = $type;
$last_nonblank_code_token = $token;
# This sub is currently called to store non-block types ',' and '->', so:
$last_nonblank_block_type = EMPTY_STRING;
return;
} ## end sub store_new_token
sub check_Q {
my ( $self, $KK, $Kfirst, $line_number ) = @_;
# Check that a quote looks okay, and report possible problems
# to the logfile.
# Given:
# $KK = index of the quote token
# $Kfirst = index of first token on the line
# $line_number = number of the line in the input stream
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $token =~ /\t/ ) {
$self->note_embedded_tab($line_number);
}
# The remainder of this routine looks for something like
# '$var = s/xxx/yyy/;'
# in case it should have been '$var =~ s/xxx/yyy/;'
# Start by looking for a token beginning with one of: s y m / tr
return
unless ( $is_s_y_m_slash{ substr( $token, 0, 1 ) }
|| substr( $token, 0, 2 ) eq 'tr' );
# ... and preceded by one of: = == !=
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
my $previous_nonblank_type = $rLL_new->[$Kp]->[_TYPE_];
return unless ( $is_unexpected_equals{$previous_nonblank_type} );
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
my $previous_nonblank_type_2 = 'b';
my $previous_nonblank_token_2 = EMPTY_STRING;
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 $next_nonblank_token = EMPTY_STRING;
my $Kn = $KK + 1;
my $Kmax = @{$rLL} - 1;
if ( $Kn <= $Kmax && $rLL->[$Kn]->[_TYPE_] eq 'b' ) { $Kn += 1 }
if ( $Kn <= $Kmax ) {
$next_nonblank_token = $rLL->[$Kn]->[_TOKEN_];
}
my $token_0 = $rLL->[$Kfirst]->[_TOKEN_];
my $type_0 = $rLL->[$Kfirst]->[_TYPE_];
if (
# 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' && $is_my_our_local{$token_0} )
)
{
my $lno = 1 + $rLL_new->[$Kp]->[_LINE_INDEX_];
my $guess = substr( $previous_nonblank_token, 0, 1 ) . '~';
complain(
"Line $lno: Note: be sure you want '$previous_nonblank_token' instead of '$guess' here\n"
);
}
return;
} ## end sub check_Q
} ## end closure respace_tokens
sub resync_lines_and_tokens {
my $self = shift;
# 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.
# Return parameters:
# set severe_error = true if processing needs to terminate
my $severe_error;
my $rqw_lines = [];
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my $rlines = $self->[_rlines_];
my @Krange_code_without_comments;
my @Klast_valign_code;
# This is the next token and its line index:
my $Knext = 0;
my $Kmax = defined($Klimit) ? $Klimit : -1;
# Verify that old line indexes are in still order. If this error occurs,
# check locations where sub 'respace_tokens' creates new tokens (like
# blank spaces). It must have set a bad old line index.
if ( DEVEL_MODE && defined($Klimit) ) {
my $iline = $rLL->[0]->[_LINE_INDEX_];
foreach my $KK ( 1 .. $Klimit ) {
my $iline_last = $iline;
$iline = $rLL->[$KK]->[_LINE_INDEX_];
if ( $iline < $iline_last ) {
my $KK_m = $KK - 1;
my $token_m = $rLL->[$KK_m]->[_TOKEN_];
my $token = $rLL->[$KK]->[_TOKEN_];
my $type_m = $rLL->[$KK_m]->[_TYPE_];
my $type = $rLL->[$KK]->[_TYPE_];
Fault(<{_line_type} ne 'CODE' );
# Get the old number of tokens on this line
my $rK_range_old = $line_of_tokens->{_rK_range};
my ( $Kfirst_old, $Klast_old ) = @{$rK_range_old};
my $Kdiff_old = 0;
if ( defined($Kfirst_old) ) {
$Kdiff_old = $Klast_old - $Kfirst_old;
}
# Find the range of NEW K indexes for the line:
# $Kfirst = index of first token on line
# $Klast = index of last token on line
my ( $Kfirst, $Klast );
my $Knext_beg = $Knext; # this will be $Kfirst if we find tokens
# Optimization: Although the actual K indexes may be completely
# changed after respacing, the number of tokens on any given line
# will often be nearly unchanged. So we will see if we can start
# our search by guessing that the new line has the same number
# of tokens as the old line.
my $Knext_guess = $Knext + $Kdiff_old;
if ( $Knext_guess > $Knext
&& $Knext_guess < $Kmax
&& $rLL->[$Knext_guess]->[_LINE_INDEX_] <= $iline )
{
# the guess is good, so we can start our search here
$Knext = $Knext_guess + 1;
}
# search for the change in input line number
while ($Knext <= $Kmax
&& $rLL->[$Knext]->[_LINE_INDEX_] <= $iline )
{
$Knext++;
}
if ( $Knext > $Knext_beg ) {
$Klast = $Knext - 1;
# Delete any terminal blank token
if ( $rLL->[$Klast]->[_TYPE_] eq 'b' ) { $Klast -= 1 }
if ( $Klast < $Knext_beg ) {
$Klast = undef;
}
else {
$Kfirst = $Knext_beg;
# Save ranges of non-comment code. This will be used by
# sub keep_old_line_breaks.
if ( $rLL->[$Kfirst]->[_TYPE_] ne '#' ) {
push @Krange_code_without_comments, [ $Kfirst, $Klast ];
}
# Only save ending K indexes of code types which are blank
# or 'VER'. These will be used for a convergence check.
# See related code in sub 'convey_batch_to_vertical_aligner'
my $CODE_type = $line_of_tokens->{_code_type};
if ( !$CODE_type
|| $CODE_type eq 'VER' )
{
push @Klast_valign_code, $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';
}
}
else {
#---------------------------------------------------
# save indexes of all lines with a 'q' at either end
# for later use by sub find_multiline_qw
#---------------------------------------------------
if ( $rLL->[$Kfirst]->[_TYPE_] eq 'q'
|| $rLL->[$Klast]->[_TYPE_] eq 'q' )
{
push @{$rqw_lines}, $iline;
}
}
}
# There shouldn't be any nodes beyond the last one. This routine is
# relinking lines and tokens after the tokens have been respaced. A fault
# here indicates some kind of bug has been introduced into the above loops.
# There is not good way to keep going; we better stop here.
if ( $Knext <= $Kmax ) {
Fault_Warn(
"unexpected tokens at end of file when reconstructing lines");
$severe_error = 1;
return ( $severe_error, $rqw_lines );
}
$self->[_rKrange_code_without_comments_] = \@Krange_code_without_comments;
# Setup the convergence test in the FileWriter based on line-ending indexes
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->setup_convergence_test( \@Klast_valign_code );
return ( $severe_error, $rqw_lines );
} ## end sub resync_lines_and_tokens
sub package_info_maker {
my ( $self, $rK_package_list ) = @_;
# Create a hash of values which can be used to find the package of any
# token. This sub must be called after rLL has been updated because it
# calls parent_seqno_by_K.
# Given:
# @{$rK_package_list} = a simple list of token index K of each 'package'
# statement in the file.
# Returns:
# {
# 'rpackage_info_list' => \@package_info_list,
# 'rpackage_lookup_list' => \@package_lookup_list,
# }
# which are two lists with useful information on all packages
my $rLL = $self->[_rLL_];
my $K_closing_container = $self->[_K_closing_container_];
my $Klimit = @{$rLL} - 1;
# RETURN LIST #1: package_info_list:
# The package of a token at an arbitrary index K is the last entry
# in the list for which K_opening < K < K_closing.
# If no package is found, then the package is 'main'.
# This list is in order of the index K of the package statements.
# so the search can stop if we find K_opening > K.
my @package_info_list;
# Start with an entry for 'main'
push @package_info_list,
{
type => 'package',
name => 'main',
level => 0,
line_start => 0,
K_opening => 0,
K_closing => $Klimit,
is_block => 0,
max_change => 0,
block_count => 0,
};
my @package_stack;
push @package_stack, 0;
# RETURN LIST #2: package_lookup_list:
# A flat list of [$name, $Kbegin, $Kend], where package is name '$name'
# from token index $Kbegin to the index $Kend. This is easier to use than
# LIST #1 since it eliminates the need for a stack.
my @package_lookup_list;
push @package_lookup_list, [ 'main', 0, 0 ];
foreach my $KK ( @{$rK_package_list} ) {
my $item = $rLL->[$KK];
my $type = $item->[_TYPE_];
# Stored K values may be off by 1 due to an added blank
if ( $type eq 'b' ) {
$KK += 1;
$item = $rLL->[$KK];
$type = $item->[_TYPE_];
}
# shouldn't happen:
if ( $type ne 'P' ) {
DEVEL_MODE && Fault("type '$type' expected to be 'P'\n");
next;
}
my $token = $item->[_TOKEN_];
my ( $keyword, $name ) = split /\s+/, $token, 2;
my $K_opening = $KK;
my $lx_start = $item->[_LINE_INDEX_];
# for non-BLOCK form:
my $level = $item->[_LEVEL_];
my $parent_seqno = $self->parent_seqno_by_K($KK);
my $is_block = 0;
# Check for BLOCK form:
# package NAME VERSION BLOCK
# Skip past VERSION
my $Kn = $self->K_next_code($KK);
if ( $Kn && $rLL->[$Kn]->[_TYPE_] eq 'n' ) {
$Kn = $self->K_next_code($Kn);
}
# Look for BLOCK
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '{' ) {
my $seqno_n = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
$level += 1;
$parent_seqno = $seqno_n;
$is_block = $seqno_n;
}
my $K_closing = $Klimit;
if ( $parent_seqno != SEQ_ROOT ) {
my $Kc = $K_closing_container->{$parent_seqno};
if ( defined($Kc) ) {
$K_closing = $Kc;
}
}
# This is the index of this new package in the package_info_list
my $ii_next = @package_info_list;
while (@package_stack) {
my $ii = $package_stack[-1];
my $Kc = $package_info_list[$ii]->{K_closing};
# pop an inactive stack item and keep going
if ( $Kc < $K_opening ) {
pop @package_stack;
my $i_top = $package_stack[-1];
my $name_top = $package_info_list[$i_top]->{name};
push @package_lookup_list, [ $name_top, $Kc + 1 ];
next;
}
# end a stack item at this level
else {
my $level_i = $package_info_list[$ii]->{level};
if ( $level_i == $level ) {
$package_info_list[$ii]->{K_closing} = $K_opening - 1;
pop @package_stack;
}
}
last;
} ## end while (@package_stack)
push @package_lookup_list, [ $name, $K_opening ];
push @package_stack, $ii_next;
# max_change and block_count are for possible future usage
push @package_info_list,
{
type => $keyword,
name => $name,
level => $level,
line_start => $lx_start + 1,
K_opening => $K_opening,
K_closing => $K_closing,
is_block => $is_block,
max_change => 0,
block_count => 0,
};
}
my $imax = @package_lookup_list - 1;
my $Kend = $Klimit;
foreach my $i ( reverse( 0 .. $imax ) ) {
$package_lookup_list[$i]->[2] = $Kend;
$Kend = $package_lookup_list[$i]->[1] - 1;
}
# Eliminate any needless starting package 'main'
if ( @package_lookup_list > 1 && $package_lookup_list[0]->[2] < 0 ) {
shift @package_lookup_list;
}
return {
'rpackage_info_list' => \@package_info_list,
'rpackage_lookup_list' => \@package_lookup_list,
};
} ## end sub package_info_maker
use constant DEBUG_COUNT => 0;
my %is_non_interfering_keyword;
my %is_keyword_returning_scalar;
BEGIN {
# Builtin keywords which do not interfere with counting args.
# They do not produce arrays and do not consume more than one arg, so
# following parens are not required.
my @q = qw(
abs and chr cmp continue cos
defined delete do else elsif eq
exp fc ge gt hex int
lc lcfirst le length local log
lt my ne not oct or
ord ord our pop pos rand
ref scalar shift sin sqrt srand
state uc ucfirst undef xor
);
@is_non_interfering_keyword{@q} = (1) x scalar(@q);
# Builtin keywords possibly taking multiple parameters but returning a
# scalar value. These can be handled if the args are in parens.
@q = qw( substr join atan2 );
@is_keyword_returning_scalar{@q} = (1) x scalar(@q);
}
sub count_list_elements {
my ( $self, $rarg_list ) = @_;
# Given call arg hash containing:
# $seqno_list = sequence number of a paren of list to be counted, or
# $K_list_start = starting index of list (for 'return' lists)
# $shift_count_min = starting min arg count items to include
# $shift_count_max = starting max arg count items to include
# $is_signature = true if this is a sub signature list
# $self_name = name of first arg found
# Return:
# -shift_count_min => starting min arg count items to include, or
# undef if a specific number was not determined
# -shift_count_max => starting max arg count items to include
# undef if a specific number was not determined
# -self_name => possibly updated name of first arg
# -initialized => a hash entry maintained by this routine
# for keeping track of repeated calls for 'return' lists
# Method:
# - The basic method is to count commas, but
# - if we encounter sigils @ or % or other problems which prevent a
# count, then we do a simple return; the count will then be indefinite.
# Set the counts to undef in case we have to do a simple return upon
# encountering an indeterminate list count
my $shift_count_min_input = $rarg_list->{shift_count_min};
## my $shift_count_max_input = $rarg_list->{shift_count_max};
$rarg_list->{shift_count_min} = undef;
$rarg_list->{shift_count_max} = undef;
my $seqno_list = $rarg_list->{seqno_list};
my $K_list_start = $rarg_list->{K_list_start};
my $is_signature = $rarg_list->{is_signature};
my $self_name = $is_signature ? EMPTY_STRING : $rarg_list->{self_name};
my $rLL = $self->[_rLL_];
my $K_list_end;
# Input option 1: $seqno_list is a container
my $is_return_list;
if ( defined($seqno_list) ) {
$K_list_start = $self->[_K_opening_container_]->{$seqno_list};
$K_list_end = $self->[_K_closing_container_]->{$seqno_list};
return unless ( defined($K_list_end) );
}
# Input option 2: $K_list_start is the index of a token,
# such as 'return', which has trailing args to count.
elsif ( defined($K_list_start) ) {
# Skip past a leading blank if necessary
if ( $rLL->[$K_list_start]->[_TYPE_] eq 'b' ) { $K_list_start++ }
$is_return_list = $rLL->[$K_list_start]->[_TYPE_] eq 'k'
&& $rLL->[$K_list_start]->[_TOKEN_] eq 'return';
$K_list_end = @{$rLL} - 1;
# Optimization for common case of simple return
my $Kn = $self->K_next_code($K_list_start);
return unless ($Kn);
my $type_n = $rLL->[$Kn]->[_TYPE_];
if ( $type_n eq ';'
|| $is_closing_type{$type_n}
|| ( $type_n eq 'k' && $is_if_unless{ $rLL->[$Kn]->[_TOKEN_] } ) )
{
$rarg_list->{shift_count_max} = 0;
return;
}
# Check for 'return ()'
if ( $rLL->[$Kn]->[_TOKEN_] eq '(' ) {
my $Knn = $self->K_next_code($Kn);
if ( $Knn && $rLL->[$Knn]->[_TOKEN_] eq ')' ) {
$rarg_list->{shift_count_max} = 0;
return;
}
}
}
else {
DEVEL_MODE && Fault("Neither seqno_list nor K_list_start defined\n");
return;
}
# Initialize the arg count for this call. We start with any 'shift' counts
# previously seen if this is not a signature or 'return' list
my $arg_count = 0;
if ( $seqno_list && $shift_count_min_input && !$is_signature ) {
$arg_count = $shift_count_min_input;
}
# For signature lists we need to remember a minimum
my $arg_count_min;
my @seqno_stack;
if ($seqno_list) { push @seqno_stack, $seqno_list }
my $KK = $K_list_start;
my $KK_last_last_nb;
my $KK_last_nb;
my $KK_this_nb = $K_list_start;
my $backup_on_last = sub {
# exclude the latest token upon encountering end of list
# to avoid adding 1 extra comma at the end
$KK_this_nb = $KK_last_nb;
$KK_last_nb = $KK_last_last_nb;
$KK_last_last_nb = undef;
return;
}; ## end $backup_on_last = sub
#--------------------------------------------------------
# Main loop to scan the container looking for list items.
#--------------------------------------------------------
while ( ++$KK < $K_list_end ) {
# safety check - shouldn't happen
if ( !$KK || $KK <= $KK_this_nb ) {
if (DEVEL_MODE) {
my $lno = $rLL->[$KK_this_nb]->[_LINE_INDEX_] + 1;
Fault("near line $lno: index $KK decreased, was $KK_this_nb\n");
}
return;
}
my $type = $rLL->[$KK]->[_TYPE_];
next if ( $type eq 'b' );
next if ( $type eq '#' );
last if ( $type eq ';' );
return if ( $type eq '..' );
# i.e., ($str=~/(\d+)(\w+)/) may be a list of n items
return if ( $type eq '=~' );
$KK_last_last_nb = $KK_last_nb;
$KK_last_nb = $KK_this_nb;
$KK_this_nb = $KK;
my $token = $rLL->[$KK]->[_TOKEN_];
# Handle a sequenced item
if ( my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_] ) {
if ( $is_opening_type{$type} ) {
if ( $token eq '(' ) {
# Skip past args to args to subs not returning
# lists, like 'pop(' 'length('
if ($KK_last_nb) {
my $token_last = $rLL->[$KK_last_nb]->[_TOKEN_];
my $type_last = $rLL->[$KK_last_nb]->[_TYPE_];
if ( $type_last eq 'k'
&& $is_non_interfering_keyword{$token_last} )
{
$KK = $self->[_K_closing_container_]->{$seqno};
next;
}
}
# If not a list..
if ( !$self->is_list_by_seqno($seqno) ) {
# always enter a container following 'return', as in:
# return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
if ( $is_return_list && $KK_last_nb == $K_list_start ) {
push @seqno_stack, $seqno;
next;
}
my $Kc = $self->[_K_closing_container_]->{$seqno};
if ( !$Kc ) { $backup_on_last->(); last }
# Enter nested parens with inner list
# ( ( $v1, $v2) )
# | | | |
# $KK $Kn $Kc_p $Kc
if ( $self->[_rhas_list_]->{$seqno} ) {
my $Kc_p = $self->K_previous_code($Kc);
if ( $Kc_p && $rLL->[$Kc_p]->[_TOKEN_] eq ')' ) {
my $seqno_c_p =
$rLL->[$Kc_p]->[_TYPE_SEQUENCE_];
if ( $seqno_c_p && $seqno_c_p == $seqno + 1 ) {
my $Kn = $self->K_next_code($KK);
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '(' )
{
push @seqno_stack, $seqno;
next;
}
}
}
}
# enter a list slice, such as '(caller)[1,2]'
my $Kn = $self->K_next_code($Kc);
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '[' ) {
my $seqno_next = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
if ( $seqno_next
&& $self->is_list_by_seqno($seqno_next) )
{
$KK = $Kn;
push @seqno_stack, $seqno_next;
next;
}
}
my $KK_n = $self->K_next_code($KK);
if ($KK_n) {
# look for something like return (@list), which
# will not be marked as a list due to lack of a
# comma
my $type_KK_n = $rLL->[$KK_n]->[_TYPE_];
my $token_KK_n = $rLL->[$KK_n]->[_TOKEN_];
if ( $type_KK_n eq 't' || $type_KK_n eq 'i' ) {
my $sigil = substr( $token_KK_n, 0, 1 );
if ( $sigil eq '@' || $sigil eq '%' ) { return }
}
elsif ( $type_KK_n eq 'k' ) {
# look for something like
# return (map { ...
if ( !$is_non_interfering_keyword{$token_KK_n} )
{
return;
}
}
else { }
}
}
# a list..
else {
# Descend into a paren list in some special cases:
if ($KK_last_nb) {
my $token_last = $rLL->[$KK_last_nb]->[_TOKEN_];
my $type_last = $rLL->[$KK_last_nb]->[_TYPE_];
# 'return (' or 'my ('
my $ok = $type_last eq 'k'
&& ( $token_last eq 'return'
|| $token_last eq 'my' );
# ',('
$ok ||= $type_last eq ',';
# '(('
$ok ||= $token_last eq '(';
# 'wantarray ? ('
$ok ||=
$KK_last_last_nb
&& $is_return_list
&& $rLL->[$KK_last_nb]->[_TYPE_] eq '?'
&& $rLL->[$KK_last_last_nb]->[_TOKEN_] eq
'wantarray';
if ($ok) {
push @seqno_stack, $seqno;
next;
}
}
}
}
# Otherwise skip past this container
$KK = $self->[_K_closing_container_]->{$seqno};
next;
}
elsif ( $is_closing_type{$type} ) {
my $seqno_test = pop @seqno_stack;
if ( $seqno_test && $seqno_test eq $seqno ) {
# hide all closing tokens to avoid adding an extra
# comma at the end at something like '$x,)'
$backup_on_last->();
next;
}
$backup_on_last->();
last;
}
elsif ( $type eq '?' ) {
# continue scanning ternary for 'return wantarray ?'
if ( $rLL->[$KK_last_nb]->[_TOKEN_] eq 'wantarray'
&& $rLL->[$KK_last_nb]->[_TYPE_] eq 'k'
&& $KK_last_last_nb
&& $rLL->[$KK_last_last_nb]->[_TOKEN_] eq 'return'
&& $rLL->[$KK_last_last_nb]->[_TYPE_] eq 'k' )
{
push @seqno_stack, $seqno;
next;
}
# give up in a return list
if ($is_return_list) {
return;
}
# otherwise skip past this ternary
$KK = $self->[_K_closing_ternary_]->{$seqno};
next;
}
elsif ( $type eq ':' ) {
my $seqno_test = pop @seqno_stack;
if ( $seqno_test && $seqno_test eq $seqno ) {
# for wantarray ternary, assume one item after ':'
# TODO: if wantarray was preceded by '!' then we should
# swap the two counts here
$arg_count_min = 1;
$backup_on_last->();
last;
}
$backup_on_last->();
last;
}
else {
DEVEL_MODE
&& Fault("unexpected seqno=$seqno for type='$type'\n");
}
}
# handle identifiers
elsif ( $type eq 'i' || $type eq 't' ) {
my $sigil = substr( $token, 0, 1 );
# give up if we find list sigils not preceded by 'scalar'
if ( $sigil eq '%' || $sigil eq '@' ) {
my $K_last = $self->K_previous_code($KK);
if ( defined($K_last) ) {
my $type_last = $rLL->[$K_last]->[_TYPE_];
next if ( $type_last eq '+' || $type_last eq 'p' );
next if ( $type_last eq q{\\} );
next if ( $type_last eq '!' );
my $token_last = $rLL->[$K_last]->[_TOKEN_];
next if ( $type_last eq 'k' && $token_last eq 'scalar' );
}
return;
}
# remember the name of the first item, maybe something like '$self'
elsif ( $sigil eq '$'
&& !$self_name
&& !$arg_count )
{
$self_name = $token;
$rarg_list->{self_name} = $self_name;
}
else {
# continue search
}
}
# handle commas: count commas separating args in a list
elsif ( $type eq ',' ) {
$arg_count++;
}
# treat fat commas as commas
elsif ( $type eq '=>' ) {
$arg_count++;
}
# an '=' in a signature indicates an optional arg
elsif ( $type eq '=' ) {
if ( $is_signature && !defined($arg_count_min) ) {
$arg_count_min = $arg_count;
}
}
# check for a paren-less call
elsif ( $is_kwU{$type} ) {
# Something like 'length $str' is ok
if ( $type eq 'k' ) {
# Something like 'length $str' is ok
next if ( $is_non_interfering_keyword{$token} );
next if ( $token eq 'wantarray' );
# hop over asubs
next if ( $token eq 'sub' );
# something like return 1 if ...
if ( $is_if_unless{$token} ) {
$backup_on_last->();
last;
}
}
# Certain subsequent tokens prevent problems
my $Kn = $self->K_next_code($KK);
next unless defined($Kn);
my $token_Kn = $rLL->[$Kn]->[_TOKEN_];
my $type_Kn = $rLL->[$Kn]->[_TYPE_];
next
if ( $token_Kn eq ')'
|| $type_Kn eq '=>'
|| $type_Kn eq '->'
|| $type_Kn eq ',' );
# Certain keywords returning scalars are okay if not made
# as paren-less calls
next
if ( $type eq 'k'
&& $token_Kn eq '('
&& $is_keyword_returning_scalar{$token} );
# Otherwise, the safe thing is to give up because a function call:
# -might be paren-less with multiple args, or
# -it might return a list (i.e. splice, split, localtime, ...)
# which will interfere with counting args
if (DEBUG_COUNT) {
my $lno = $rLL->[$KK]->[_LINE_INDEX_] + 1;
my $input_stream_name = get_input_stream_name();
print {*STDERR}
"DEBUG_COUNT: file $input_stream_name line=$lno type=$type tok=$token token_Kn=$token_Kn\n";
}
return;
}
else {
# continue search
}
} ## end while ( ++$KK < $K_list_end)
# Increase the count by 1 if the list does not have a trailing comma
if ( defined($KK_this_nb)
&& $KK_this_nb > $K_list_start
&& $rLL->[$KK_this_nb]->[_TYPE_] ne ',' )
{
$arg_count++;
}
if ( !defined($arg_count_min) ) {
$arg_count_min = $arg_count;
}
$rarg_list->{shift_count_min} = $arg_count_min;
$rarg_list->{shift_count_max} = $arg_count;
return;
} ## end sub count_list_elements
# A constant to limit backward searches
use constant MANY_TOKENS => 100;
my %is_shift_pop;
my %is_scalar_sigil;
my %is_array_sigil;
BEGIN {
my @q = qw( shift pop );
@is_shift_pop{@q} = (1) x scalar(@q);
@q = qw( $ * & );
@is_scalar_sigil{@q} = (1) x scalar(@q);
@q = qw( @ % );
@is_array_sigil{@q} = (1) x scalar(@q);
}
sub count_prototype_args {
my ($string) = @_;
# Given
# $string = a string with a prototype in parens, such as '($$;$)'
# Returns ($count_min, $count_max)
# $count_min = min specific number of args expected, or
# undef if number of args can vary
# $count_max = max specific number of args expected, or
# undef if number of args can vary
my @chars = split //, $string;
my $count_min = 0;
my $count_max = 0;
my $saw_semicolon;
my $bump_count = sub {
$count_max++;
$count_min++ if ( !$saw_semicolon );
return;
};
my $saw_array = sub {
$count_max = undef;
$count_min = undef if ( !$saw_semicolon );
return;
};
while (@chars) {
my $ch = shift @chars;
if ( !defined($ch) ) { $saw_array->(); last }
elsif ( $ch eq '(' ) { last if ($count_min) }
elsif ( $ch eq ')' ) { last }
elsif ( $ch eq ';' && !$saw_semicolon ) { $saw_semicolon = 1 }
elsif ( $ch eq '_' && !$saw_semicolon ) {
$saw_semicolon = 1;
$bump_count->() if ( !$count_min );
}
elsif ( $is_array_sigil{$ch} ) { $saw_array->(); last }
elsif ( $is_scalar_sigil{$ch} ) { $bump_count->(); }
elsif ( $ch eq q{\\} ) {
$ch = shift @chars;
last unless defined($ch);
$bump_count->();
}
else { next }
} ## end while (@chars)
return ( $count_min, $count_max );
} ## end sub count_prototype_args
sub find_sub_token {
my ( $self, $seqno_block ) = @_;
# Given:
# $seqno_block = sequence number of a sub block brace
# Return:
# $Ksub = index of the actual 'sub' token for the sub
# this will include the name of a named sub, and any prototype
# undef if cannot find it; this is not a critical sub, so no heroics
#
# Notation:
#
# sub find_sub_token {
# | |
# $Ksub --$K_opening_container for $seqno_block
my $rLL = $self->[_rLL_];
# See if sub respace_tokens saved the index of the previous type 'S'
# for us. May need to back up 1 token if spaces were deleted.
my $K_sub = $self->[_rK_sub_by_seqno_]->{$seqno_block};
if ( defined($K_sub) ) {
my $type = $rLL->[$K_sub]->[_TYPE_];
if ( $type ne 'S' ) {
$K_sub -= 1;
$type = $rLL->[$K_sub]->[_TYPE_];
if ( $type ne 'S' ) {
if (DEVEL_MODE) {
my $token = $rLL->[$K_sub]->[_TOKEN_];
my $lno = $rLL->[$K_sub]->[_LINE_INDEX_] + 1;
my $block_type =
$self->[_rblock_type_of_seqno_]->{$seqno_block};
Fault(<[_K_opening_container_]->{$seqno_block};
my $Kt_min = $K_opening_block - MANY_TOKENS;
if ( $Kt_min < 0 ) { $Kt_min = 0 }
foreach my $Kt ( reverse( $Kt_min .. $K_opening_block ) ) {
my $token = $rLL->[$Kt]->[_TOKEN_];
my $type = $rLL->[$Kt]->[_TYPE_];
if ( $type eq 'S' ) {
# type 'S' could be 'method xxx' or '$fn=sub () {' - see c372
$K_sub = $Kt;
last;
}
if ( ( $type eq 'k' || $type eq 'i' )
&& substr( $token, 0, 3 ) eq 'sub' )
{
# anonymous subs are type 'k'
$K_sub = $Kt;
last;
}
}
}
return $K_sub;
} ## end sub find_sub_token
sub count_default_sub_args {
my ( $self, $item, $seqno ) = @_;
# Given:
# $item = hash ref with sub arg info
# $seqno => sequence number of a sub block of a paren
# containing possible default args
# Task:
# count default args and update minimum arg count in $item
my $rLL = $self->[_rLL_];
return unless ($seqno);
# The token before the opening must be a ',' or '('
my $K_o = $self->[_K_opening_container_]->{$seqno};
my $K_test = $self->K_previous_code($K_o);
return unless defined($K_test);
my $token_test = $rLL->[$K_test]->[_TOKEN_];
return if ( $token_test ne ',' && $token_test ne '(' );
# Check that an opening token has the previous sequence number
if ( $token_test eq '(' ) {
my $seqno_o = $rLL->[$K_test]->[_TYPE_SEQUENCE_];
if ( !$seqno_o || $seqno_o != $seqno - 1 ) {
# shouldn't happen: may be bad call value since the token
# with '$seqno' was just before a closing paren
DEVEL_MODE && Fault("seqno_o=$seqno_o != $seqno-1\n");
return;
}
}
my $rtype_count = $self->[_rtype_count_by_seqno_]->{$seqno};
my $default_arg_count;
if ($rtype_count) {
# One or more commas, like: ( ... $v1, $v2, ($d1, $d2) )=@_
# Note that the comma_count does not include any trailing comma
# so we always add 1
$default_arg_count = $rtype_count->{','} + 1;
}
if ( !defined($default_arg_count) ) {
# Check for empty parens, like: ( ... $v1, $v2, () )=@_
my $K_n = $self->K_next_code($K_o);
my $K_c = $self->[_K_closing_container_]->{$seqno};
return if ( $K_n == $K_c );
# No commas but not empty, so 1 arg in parens
# Something like: ( ... $v1, $v2, ($d1) )=@_
$default_arg_count = 1;
}
return unless ($default_arg_count);
# Update the minimum count to exclude the defaults
if ( $item->{shift_count_min} >= $default_arg_count ) {
$item->{shift_count_min} -= $default_arg_count;
}
else {
DEVEL_MODE
&& Fault(
"default count is $default_arg_count but total is $item->{shift_count_min}"
);
}
return;
} ## end sub count_default_sub_args
sub count_sub_input_args {
my ( $self, $item ) = @_;
# Given: $item = hash ref with
# seqno => $seqno_block = sequence number of a sub block
# max_arg_count => optional optimization flag, see note below
# Updates hash ref $item with values for keys:
# shift_count_min => minimum absolute number of input args
# shift_count_max => maximum absolute number of input args
# self_name => name of first arg (if it can be determined)
# is_signature => true if args are in a signature
# .. plus several other quantities of interest to the caller
# These keys are left undefined if they cannot be determined.
# 'shift_count_min' and 'shift_count_max' are the same except for
# a signature or prototype.
my $seqno_block = $item->{seqno};
return unless ($seqno_block);
# Pull out optional optimization flag. If this is true then there
# may be calls to this sub with args, so we should to do a full
# search of the entire sub if this would cause a -wma warning.
my $max_arg_count = $item->{max_arg_count};
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $K_opening_block = $self->[_K_opening_container_]->{$seqno_block};
# Find index '$K' of the last '@_' in this sub, if any
# Note on '$K_last_at_underscore': if we exit with only seeing shifts,
# but a pre-scan saw @_ somewhere after the last K, then the count
# is dubious and we do a simple return
my $K_last_at_underscore = 0;
my $rKlist = $self->[_rK_AT_underscore_by_sub_seqno_]->{$seqno_block};
if ( defined($rKlist) ) {
$K_last_at_underscore = $rKlist->[-1];
}
# Note on $_[n]: if there are any shifts of @_ or references to @_, we
# cannot use these for a count. Otherwise, we can use the range of n in
# $_[n] to get an expected arg count if all indexes n are simple integers.
# So for example if we see anything like $_[2+$i] we have to give up.
my $seqno_at_index_min;
my $at_index_min;
my $at_index_max;
my $dollar_underscore_zero_name = sub {
# Find the first arg name for a sub which references $_[0] and does
# not do shifting. There are two possibilities:
# return '$word' in something like '$word = $_[0];'
# return nothing otherwise
return unless ( $seqno_at_index_min && $at_index_min == 0 );
my $Ko = $K_opening_container->{$seqno_at_index_min};
my $Kc = $K_closing_container->{$seqno_at_index_min};
return unless ( $Ko && $Kc );
my $K_semicolon = $self->K_next_code($Kc);
return unless ( $K_semicolon && $rLL->[$K_semicolon]->[_TYPE_] eq ';' );
my $K_m = $self->K_previous_code($Ko);
return unless ( $K_m && $rLL->[$K_m]->[_TOKEN_] eq '$_' );
my $K_mm = $self->K_previous_code($K_m);
return unless ( $K_mm && $rLL->[$K_mm]->[_TYPE_] eq '=' );
my $K_mmm = $self->K_previous_code($K_mm);
return unless ( $K_mmm && $rLL->[$K_mmm]->[_TYPE_] eq 'i' );
my $name = $rLL->[$K_mmm]->[_TOKEN_];
return unless ( $name =~ /^\$\w/ );
return $name;
}; ## end $dollar_underscore_zero_name = sub
my $rseqno_DOLLAR_underscore =
$self->[_rDOLLAR_underscore_by_sub_seqno_]->{$seqno_block};
if ( !defined($rKlist) && $rseqno_DOLLAR_underscore ) {
my $ok;
foreach my $seqno_DOLLAR ( @{$rseqno_DOLLAR_underscore} ) {
$ok = 0;
my $Ko = $K_opening_container->{$seqno_DOLLAR};
my $Kn = $self->K_next_code($Ko);
last unless ($Kn);
last unless ( $rLL->[$Kn]->[_TYPE_] eq 'n' );
my $token = ( $rLL->[$Kn]->[_TOKEN_] );
last unless ( $token =~ /^\d+$/ );
my $Knn = $self->K_next_code($Kn);
my $Kc = $K_closing_container->{$seqno_DOLLAR};
last unless ( $Knn && $Kc && $Knn == $Kc );
if ( !defined($at_index_min) || $token < $at_index_min ) {
$at_index_min = $token;
if ( !defined($seqno_at_index_min) ) {
$seqno_at_index_min = $seqno_DOLLAR;
}
}
if ( !defined($at_index_max) || $token > $at_index_max ) {
$at_index_max = $token;
}
$ok = 1;
}
if ( !$ok ) {
$at_index_min = undef;
$at_index_max = undef;
}
}
# flag indicating we saw a "pop @_" or just "pop;";
my $saw_pop_at_underscore;
my $ix_HERE_END = -1;
my $K_sub = $self->find_sub_token($seqno_block);
# shouldn't happen:
if ( !defined($K_sub) || $K_sub >= $K_opening_block ) {
if ( !defined($K_sub) ) { $K_sub = 'undef' }
DEVEL_MODE && Fault("Bad K_sub=$K_sub, opening=$K_opening_block\n");
return;
}
#----------------------------------
# Check for and process a prototype
#----------------------------------
my $sub_token = $rLL->[$K_sub]->[_TOKEN_];
my $iproto_beg = index( $sub_token, '(' );
if ( $iproto_beg > 0 ) {
my $iproto_end = index( $sub_token, ')', $iproto_beg );
if ( $iproto_end > $iproto_beg ) {
my $prototype =
substr( $sub_token, $iproto_beg, $iproto_end - $iproto_beg + 1 );
my ( $prototype_count_min, $prototype_count_max ) =
count_prototype_args($prototype);
$item->{prototype} = $prototype;
$item->{prototype_count_min} = $prototype_count_min;
$item->{prototype_count_max} = $prototype_count_max;
# Since we don't yet know if we must add 1 for a method call, we
# will just continue normally and let the caller figure it out.
}
}
#---------------------------------------
# Check for and process a signature list
#---------------------------------------
my $Ksub_p = $self->K_next_code($K_sub);
if ( $rLL->[$Ksub_p]->[_TYPE_SEQUENCE_]
&& $rLL->[$Ksub_p]->[_TOKEN_] eq '(' )
{
# Switch to searching the signature container. We will get the
# count when we arrive at the closing token.
my $seqno_list = $rLL->[$Ksub_p]->[_TYPE_SEQUENCE_];
$item->{seqno_list} = $seqno_list;
$item->{is_signature} = 1;
$self->count_list_elements($item);
# We are finished for a signature list
return;
}
#-------------------------------------------------------------
# Main loop: look for =shift; and =@_; within sub block braces
#-------------------------------------------------------------
my $seqno = $seqno_block;
my $K_opening = $self->[_K_opening_container_]->{$seqno};
my $K_closing = $self->[_K_closing_container_]->{$seqno};
return unless defined($K_closing);
my $level_opening = $rLL->[$K_opening]->[_LEVEL_];
# Count number of 'shift;' at the top level
my $shift_count = 0;
my $self_name = EMPTY_STRING;
my $semicolon_count_after_last_shift = 0;
my $in_interpolated_quote;
my $KK = $K_opening;
my $KK_this_nb = $KK;
while ( ++$KK < $K_closing ) {
# safety check - shouldn't happen
if ( !$KK || $KK <= $KK_this_nb ) {
if (DEVEL_MODE) {
my $lno = $rLL->[$KK_this_nb]->[_LINE_INDEX_] + 1;
Fault("near line $lno: index $KK decreased, was $KK_this_nb\n");
}
return;
}
my $type = $rLL->[$KK]->[_TYPE_];
next if ( $type eq 'b' );
next if ( $type eq '#' );
$KK_this_nb = $KK;
my $token = $rLL->[$KK]->[_TOKEN_];
# Note that '$_' here is marked as type 'Z': print $_[0];
if ( $type eq 'i' || $type eq 'Z' ) {
# look for '@_'
if ( $token eq '@_' ) {
# Found '@_': the search will end here
my $level = $rLL->[$KK]->[_LEVEL_];
# Give up upon finding @_ at a lower level
return unless ( $level == $level_opening + 1 );
# Look ahead for ';'
my $K_p = $self->K_next_code($KK);
return unless ($K_p);
return unless ( $rLL->[$K_p]->[_TYPE_] eq ';' );
# Look back for ' = @_'
my $K_m = $self->K_previous_code($KK);
return unless defined($K_m);
my $type_m = $rLL->[$K_m]->[_TYPE_];
return unless ( $type_m eq '=' );
# Look back for ' ) = @_'
my $K_mm = $self->K_previous_code($K_m);
return unless defined($K_mm);
my $token_mm = $rLL->[$K_mm]->[_TOKEN_];
my $seqno_mm = $rLL->[$K_mm]->[_TYPE_SEQUENCE_];
# Count args in the list ( ... ) = @_;
if ( $seqno_mm && $token_mm eq ')' ) {
$item->{seqno_list} = $seqno_mm;
$item->{is_signature} = 0;
$item->{shift_count_min} = $shift_count;
$item->{shift_count_max} = $shift_count;
$self->count_list_elements($item);
# Count default args placed in separate parens, such as:
# .. $v1 ,($def1, $def2)) = @_
# .. $v1 ,($def1, $def2),) = @_
# look at the token before the last ')'
my $K_mm_p = $self->K_previous_code($K_mm);
my $token_mm_p =
$K_mm_p ? $rLL->[$K_mm_p]->[_TOKEN_] : SPACE;
# skip past a trailing comma
if ( $token_mm_p eq ',' ) {
$K_mm_p = $self->K_previous_code($K_mm_p);
$token_mm_p =
$K_mm_p ? $rLL->[$K_mm_p]->[_TOKEN_] : SPACE;
}
# if we find a closing paren, count the items and
# update shift_count_min
if ( $token_mm_p eq ')' ) {
my $seqno_mm_p = $rLL->[$K_mm_p]->[_TYPE_SEQUENCE_];
$self->count_default_sub_args( $item, $seqno_mm_p );
}
# NOTE: this could disagree with $_[n] usage; we
# ignore this for now.
return;
}
# Give up if = @_ is not preceded by a simple list
return;
}
# Give up if we find an indexed ref to $_[..]
elsif ( $token eq '$_' ) {
# Found $_: currently the search ends at '$_['
my $Kn = $self->K_next_code($KK);
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '[' ) {
# Give up unless we might be able to define a count
# when there are just references to $_[n] values
if ( !defined($at_index_max) || $shift_count ) {
return;
}
}
}
# Give up at something like '&func;'
elsif ( substr( $token, 0, 1 ) eq '&' ) {
my $Kn = $self->K_next_code($KK);
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] ne '(' ) {
return;
}
}
else {
# continue search
}
}
#------------------------------
# look for '=shift;' or '=pop;'
#------------------------------
elsif ( $type eq 'k' ) {
if ( $is_shift_pop{$token} ) {
# look for 'shift;' and count as 1 arg
my $Kp = $self->K_next_code($KK);
return unless defined($Kp);
my $type_p = $rLL->[$Kp]->[_TYPE_];
my $token_p = $rLL->[$Kp]->[_TOKEN_];
# look for any of these with shift or pop:
# shift;
# shift @_;
# shift();
# shift(@_);
# remove any opening paren
my $in_parens;
if ( $token_p eq '(' ) {
$in_parens = 1;
$Kp = $self->K_next_code($Kp);
return unless defined($Kp);
$type_p = $rLL->[$Kp]->[_TYPE_];
$token_p = $rLL->[$Kp]->[_TOKEN_];
}
# look for '@_'
if ( $type_p eq 'i' || $type_p eq 't' ) {
# keep going if not @_
next if ( $token_p ne '@_' );
$Kp = $self->K_next_code($Kp);
return unless defined($Kp);
$type_p = $rLL->[$Kp]->[_TYPE_];
$token_p = $rLL->[$Kp]->[_TOKEN_];
}
# remove any closing paren
if ( $in_parens && $token_p eq ')' ) {
$Kp = $self->K_next_code($Kp);
return unless defined($Kp);
$type_p = $rLL->[$Kp]->[_TYPE_];
$token_p = $rLL->[$Kp]->[_TOKEN_];
}
# Just give up if this shift is not followed by a semicolon or
# closing brace or arrow. This is the safe thing to do to avoid
# false errors. There are too many ways for problems to arise.
# Especially if the next token is one of '||' '//' 'or'.
return
if ( $type_p ne ';' && $type_p ne '->' && $Kp ne $K_closing );
my $level = $rLL->[$KK]->[_LEVEL_];
# Give up on lower level shifts
return unless ( $level == $level_opening + 1 );
# If we get to the end without finding '(..) = @_;' then
# we will consider the count unreliable if we saw a 'pop'
# or if a previous block contained other statements.
$saw_pop_at_underscore ||= $token eq 'pop';
$shift_count++;
$semicolon_count_after_last_shift = 0;
# Save self name:
# '$self = shift'
# | | |
# $K_mm $K_m $KK
if ( $shift_count == 1 && !$self_name ) {
my $K_m = $self->K_previous_code($KK);
return unless ( defined($K_m) );
my $type_m = $rLL->[$K_m]->[_TYPE_];
# For something like: sub get_thing {shift->{thing}}
# use $_[0] as the name
if ( $type_p eq '->' ) {
if ( $type_m eq '{' || $type_m eq ';' ) {
$self_name = '$_[0]';
$item->{self_name} = $self_name;
}
}
else {
if ( $type_m eq '=' ) {
my $K_mm = $self->K_previous_code($K_m);
return unless defined($K_mm);
my $type_mm = $rLL->[$K_mm]->[_TYPE_];
my $token_mm = $rLL->[$K_mm]->[_TOKEN_];
my $seqno_mm = $rLL->[$K_mm]->[_TYPE_SEQUENCE_];
# check for $self in parens, like ($self)=shift
if ( $seqno_mm && $token_mm eq ')' ) {
my $Ko = $K_opening_container->{$seqno_mm};
$K_mm = $self->K_next_code($Ko);
if ($K_mm) {
$type_mm = $rLL->[$K_mm]->[_TYPE_];
$token_mm = $rLL->[$K_mm]->[_TOKEN_];
}
}
if ( $type_mm eq 'i' ) {
$self_name = $token_mm;
# we store self_name immediately because it will
# be needed even if we cannot get an arg count
$item->{self_name} = $self_name;
}
}
}
}
# Skip past any parens and @_; let the semicolon be seen next
if ( $KK < $Kp - 1 ) { $KK = $Kp - 1 }
}
elsif ( $token eq 'bless' ) {
# Could look for something like the following:
# my $self = bless {}, $class;
# my $self = bless {}, shift;
}
elsif ( $is_if_unless{$token} ) {
#-------------------------------
# RETURN: Optional early return.
#-------------------------------
# Give up and exit at 'if' or 'unless' if we have seen a few
# semicolons following the last 'shift'. The number '2' here
# has been found to work well.
if ( $semicolon_count_after_last_shift > 2 ) {
if ( !defined($max_arg_count)
|| $max_arg_count <= $shift_count )
{
if ( !$saw_pop_at_underscore
&& $KK >= $K_last_at_underscore )
{
$item->{shift_count_min} = $shift_count;
$item->{shift_count_max} = $shift_count;
}
return;
}
}
}
else {
}
}
# Check for a container boundary
elsif ( $rLL->[$KK]->[_TYPE_SEQUENCE_] ) {
if ( $is_opening_type{$type} ) {
my $seqno_test = $rLL->[$KK]->[_TYPE_SEQUENCE_];
#---------------------------------------------
# Skip past a sub declearation within this sub
#---------------------------------------------
if ( $self->[_ris_sub_block_]->{$seqno_test}
|| $self->[_ris_asub_block_]->{$seqno_test} )
{
my $Kc = $self->[_K_closing_container_]->{$seqno_test};
return if ( !$Kc );
return if ( $Kc <= $KK );
$KK = $Kc;
}
}
}
elsif ( $type eq ';' ) {
$semicolon_count_after_last_shift++;
}
# scan a quote for @_ and $_[
elsif ( $type eq 'Q' ) {
my $K_last_code = $self->K_previous_code($KK);
next unless defined($K_last_code);
my $K_last_type = $rLL->[$K_last_code]->[_TYPE_];
if ( $K_last_type eq 'Q' ) {
# starting in quote : use old interpolation value
}
elsif ( $is_re_match_op{$K_last_type} ) {
$in_interpolated_quote = 1;
}
# is not interpolated for leading operators: qw q tr y '
elsif ( $token =~ /^(qw | q[^qrx] | tr | [y\'] )/x ) {
$in_interpolated_quote = 0;
}
# is interpolated for everything else
else {
$in_interpolated_quote = 1;
}
# look for '@_' and '$_[' in an interpolated quote
next unless ($in_interpolated_quote);
my $pos;
$pos = index( $token, '@_' );
return
if ( $pos == 0
|| $pos > 0 && substr( $token, $pos - 1, 1 ) ne BACKSLASH );
$pos = index( $token, '$_[' );
return
if ( $pos == 0
|| $pos > 0 && substr( $token, $pos - 1, 1 ) ne BACKSLASH );
}
# scan here text for @_ and $_[
elsif ( $type eq 'h' ) {
next if ( !is_interpolated_here_doc($token) );
my $ix_line = $rLL->[$KK]->[_LINE_INDEX_];
my $ix_HERE = max( $ix_HERE_END, $ix_line );
( $ix_HERE_END, my $here_text ) = $self->get_here_text($ix_HERE);
if ($here_text) {
my $pos;
$pos = index( $here_text, '@_' );
return
if (
$pos == 0
|| ( $pos > 0
&& substr( $here_text, $pos - 1, 1 ) ne BACKSLASH )
);
$pos = index( $here_text, '$_[' );
return
if (
$pos == 0
|| ( $pos > 0
&& substr( $here_text, $pos - 1, 1 ) ne BACKSLASH )
);
}
}
else {
# continue search
}
} ## end while ( ++$KK < $K_closing)
#--------------------------------
# the whole file has been scanned
#--------------------------------
# if no shifts @_ and no references to @_, look for $[n]
if ( defined($at_index_max) && !$shift_count ) {
$shift_count = $at_index_max + 1;
# Create a self name like '$_[0]' if we can't find user-defined name.
# Then any sub calls with '$_[0]->' will be recognized as self
# calls by sub cross_check_sub_calls.
if ( !$self_name && $at_index_min == 0 ) {
$self_name = $dollar_underscore_zero_name->();
$self_name = '$_[0]' unless ($self_name);
$item->{self_name} = $self_name;
}
}
if ( !$saw_pop_at_underscore ) {
$item->{shift_count_min} = $shift_count;
$item->{shift_count_max} = $shift_count;
}
return;
} ## end sub count_sub_input_args
use constant DEBUG_RETURN_COUNT => 0;
sub count_sub_return_args {
my ( $self, $item ) = @_;
# Given: $item = hash ref with
# seqno => sequence number of a sub block
# Set values for these keys in '$item':
# return_count_min => minimum number of output args
# = undef if indeterminate, such as @list
# K_return_count_min => K value of the min
# return_count_max => maximum number of output args
# = undef if indeterminate, such as @list
# K_return_count_max => K value of the max
my $seqno_sub = $item->{seqno};
return unless ($seqno_sub);
my $rKlist = $self->[_rK_return_by_sub_seqno_]->{$seqno_sub};
return if ( !defined($rKlist) );
# loop over all return statements in this sub
my $rLL = $self->[_rLL_];
my $rhash = {};
my $rK_return_count_hash = {};
# retain old vars during transition phase
my $return_count_min;
my $return_count_max;
foreach ( @{$rKlist} ) {
my $K_return = $rLL->[$_]->[_TYPE_] eq 'b' ? $_ + 1 : $_;
## my $type = $rLL->[$K_return]->[_TYPE_];
my $token = $rLL->[$K_return]->[_TOKEN_];
if ( $token ne 'return' ) {
DEVEL_MODE && Fault("expecting 'return' but got $token\n");
last;
}
$rhash->{K_list_start} = $K_return;
$self->count_list_elements($rhash);
my $count = $rhash->{shift_count_max};
if ( !defined($count) ) {
$item->{return_count_indefinite} = $K_return;
$item->{return_count_max} = undef;
last;
}
# new count?
if ( !$rK_return_count_hash->{$count} ) {
$rK_return_count_hash->{$count} = $K_return;
}
# retain old vars during transition phase
# Note: using <= to match old results but could use <
if ( !defined($return_count_min) || $count <= $return_count_min ) {
$return_count_min = $count;
$item->{return_count_min} = $count;
$item->{K_return_count_min} = $K_return;
}
# Note: using >= to match old results but could use >
if ( !defined($return_count_max) || $count >= $return_count_max ) {
$return_count_max = $count;
$item->{return_count_max} = $count;
$item->{K_return_count_max} = $K_return;
}
}
$item->{rK_return_count_hash} = $rK_return_count_hash;
if ( DEBUG_RETURN_COUNT > 1 ) {
my $min = $item->{return_count_min};
my $max = $item->{return_count_max};
$min = '*' unless defined($min);
$max = '*' unless defined($max);
print "DEBUG_RETURN: returning min=$min max=$max\n";
}
return;
} ## end sub count_sub_return_args
sub count_return_values_wanted {
my ( $self, $item ) = @_;
# Given: $item = a hash ref with
# seqno_list => sequence number the call arg list of a sub call
# Set value for this key in '$item':
# return_count_wanted => number of return items wanted from the call
# = undef if indeterminate, such as @list
# get the sequence number of the call arg list for this call
my $seqno_list = $item->{seqno_list};
return unless ($seqno_list);
# Give up if call is followed by a bound operator, for example
# my ( $fh, $tmpfile ) = $self->io()->tempfile( DIR => $dir );
# |
# ^--$Kc
my $rLL = $self->[_rLL_];
my $Kc = $self->[_K_closing_container_]->{$seqno_list};
my $Kc_n = $self->K_next_code($Kc);
if ($Kc_n) {
my $type_n = $rLL->[$Kc_n]->[_TYPE_];
my $ok = $type_n eq ';' || $is_closing_type{$type_n};
if ( !$ok && $type_n eq 'k' ) {
my $token_n = $rLL->[$Kc_n]->[_TOKEN_];
$ok ||= $is_if_unless{$token_n};
$ok ||= $is_and_or{$token_n};
}
return unless $ok;
}
my $Ko = $self->[_K_opening_container_]->{$seqno_list};
my $K_m = $self->K_previous_code($Ko);
my $K_mm = $self->K_previous_code($K_m);
return unless ( defined($K_mm) );
my $type_m = $rLL->[$K_m]->[_TYPE_];
my $token_m = $rLL->[$K_m]->[_TOKEN_];
my $type_mm = $rLL->[$K_mm]->[_TYPE_];
# start of backwards search depends on the call type...
# note: see var $rsub_call_paren_info_by_seqno in sub respace_tokens
my $K_equals;
# 'function('
if ( $type_m eq 'U' || $type_m eq 'w' ) {
$K_equals = $K_mm;
}
# '->function('
elsif ( $type_m eq 'i' && $type_mm eq '->' ) {
my $K_mmm = $self->K_previous_code($K_mm);
my $K_mm4 = $self->K_previous_code($K_mmm);
return unless defined($K_mm4);
my $type_mmm = $rLL->[$K_mmm]->[_TYPE_];
# something like '$self->function('
if ( $type_mmm eq 'i' ) {
$K_equals = $K_mm4;
}
# something complex like '$hash_of_objects{my_obj}->function('
else {
# TBD:
return;
}
}
# '&function('
elsif ( $type_m eq 'i' && substr( $token_m, 0, 1 ) eq '&' ) {
$K_equals = $K_mm;
}
# '$function->(' [ TODO: simple anonymous sub call, not used yet ]
elsif ( $type_m eq '->' && $type_mm eq 'i' ) {
my $K_mmm = $self->K_previous_code($K_mm);
$K_equals = $K_mmm;
}
# error
else {
DEVEL_MODE
&& Fault(
"unexpected call with type_m=$type_m token_m=$token_m type_mm=$type_mm\n"
);
return;
}
# look for '='
# Note that this ignores a return via a slice, like
# ($v1,$v2) =(f(x))[1,3]
# because this is an array return, and we just want explicit lists
if ( !$K_equals || $rLL->[$K_equals]->[_TYPE_] ne '=' ) {
return;
}
my $K_c = $self->K_previous_code($K_equals);
return unless ( defined($K_c) );
my $type_c = $rLL->[$K_c]->[_TYPE_];
my $token_c = $rLL->[$K_c]->[_TOKEN_];
if ( $token_c ne ')' ) {
# Handle @array = f(x) or $scalar=f(x), and things like
# $rhash->{vv} = f();
# $hash{vv} = f();
# $array[$index] = f();
if ( $is_closing_type{$type_c} ) {
# backup from the closing brace to any identifier
# Note: currently only going back one index, a sub could
# be written to handle more complex things
my $seqno_c = $rLL->[$K_c]->[_TYPE_SEQUENCE_];
return if ( !$seqno_c );
my $Ko_c = $self->[_K_opening_container_]->{$seqno_c};
return unless defined($Ko_c);
my $K_c_new = $self->K_previous_code($Ko_c);
return unless defined($K_c_new);
$type_c = $rLL->[$K_c_new]->[_TYPE_];
$token_c = $rLL->[$K_c_new]->[_TOKEN_];
if ( $type_c eq '->' ) {
$K_c_new = $self->K_previous_code($K_c_new);
return unless defined($K_c_new);
$type_c = $rLL->[$K_c_new]->[_TYPE_];
$token_c = $rLL->[$K_c_new]->[_TOKEN_];
}
}
if ( $type_c eq 'i' || $type_c eq 't' ) {
my $sigil = substr( $token_c, 0, 1 );
if ( $sigil eq '$' ) {
$item->{return_count_wanted} = 1;
$item->{want_scalar} = 1;
}
}
return;
}
# Count elements in (list of values)=f(x)
my $seqno_lhs = $rLL->[$K_c]->[_TYPE_SEQUENCE_];
return unless ($seqno_lhs);
my $rhash = {};
$rhash->{seqno_list} = $seqno_lhs;
$self->count_list_elements($rhash);
my $return_count_wanted = $rhash->{shift_count_max};
if ( DEBUG_RETURN_COUNT > 1 ) {
print "DEBUG_RETURN_COUNT: want $return_count_wanted\n";
}
$item->{return_count_wanted} = $return_count_wanted;
return;
} ## end sub count_return_values_wanted
sub sub_def_info_maker {
my ( $self, $rpackage_lookup_list, $rprelim_call_info ) = @_;
# Given:
# $rpackage_lookup_list = list with info for finding containing package
# $rprelim_call_info = hash ref with first try at call info
# Returns two hash references:
# \%sub_info_by_seqno,
# \%sub_seqno_by_key,
# where
# $sub_info_by_seqno{seqno} = {
# seqno => $seqno,
# package => $package,
# name => $name,
# seqno_list => $seqno of the paren list of args
# shift_count => number of args
# is_signature => true if seqno_list is a sub signature
# self_name => name of first arg
# }
# and
# $sub_seqno_by_key{'package::name'} = seqno;
# which gives the seqno for a sub name
# TODO: possible future update:
# package name for 'my' sub and anonymous sub will be parent sub seqno
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_sub_block = $self->[_ris_sub_block_];
#----------------------------------
# Main loop over subs to count args
#----------------------------------
my @package_stack = reverse( @{$rpackage_lookup_list} );
my ( $current_package, $Kbegin, $Kend ) = @{ pop @package_stack };
my %sub_info_by_seqno;
my %sub_seqno_by_key;
foreach my $seqno ( sort { $a <=> $b } keys %{$ris_sub_block} ) {
# update the current package
my $Ko = $K_opening_container->{$seqno};
while ( $Ko > $Kend && @package_stack ) {
( $current_package, $Kbegin, $Kend ) = @{ pop @package_stack };
}
my $block_type = $rblock_type_of_seqno->{$seqno};
#-----------------------------
# Get the sub name and package
#-----------------------------
# Examples of what we want to extract from '$block_type':
# $block_type $name
# 'sub setidentifier($)' => 'setidentifier'
# 'method setidentifier($)' => 'setidentifier'
# Examples:
# "sub hello", "sub hello($)", "sub hello ($)"
# There will be a single space after 'sub' but any number before
# prototype
my $name = $block_type;
my $pos_space = index( $block_type, SPACE );
if ( $pos_space > 0 ) {
$name = substr( $block_type, $pos_space + 1 );
}
my $pos_paren = index( $name, '(' );
my $prototype;
if ( $pos_paren > 0 ) {
$prototype = substr( $name, $pos_paren );
$name = substr( $name, 0, $pos_paren );
$name =~ s/\s+$//;
}
my $package = $current_package;
if ( ( index( $name, ':' ) >= 0 || index( $name, "'" ) >= 0 )
&& $name =~ /^(.*\W)(\w+)$/ )
{
$package = $1;
$name = $2;
$package =~ s/\'/::/g;
$package =~ s/::$//;
}
$package = 'main' unless ($package);
# Make a hash of info for this sub
my $lno = $rLL->[$Ko]->[_LINE_INDEX_] + 1;
my $item = {
seqno => $seqno,
package => $package,
name => $name,
line_number => $lno,
};
my $key = $package . '::' . $name;
# Set flag indicating if args may be expected to allow optimization
my $call_item = $rprelim_call_info->{$key};
$item->{max_arg_count} = $call_item->{max_arg_count};
# Add a count of the number of input args
$self->count_sub_input_args($item);
# Add a count of the number of return args
$self->count_sub_return_args($item);
# Store the sub info by sequence number
$sub_info_by_seqno{$seqno} = $item;
# and save the sub sequence number indexed by sub name
$sub_seqno_by_key{$key} = $seqno;
}
return ( \%sub_info_by_seqno, \%sub_seqno_by_key );
} ## end sub sub_def_info_maker
sub update_sub_call_paren_info {
my ( $self, $rpackage_lookup_list ) = @_;
# Given:
# $rpackage_lookup_list = list with info for finding containing package
# Update the hash of info about the call parameters with arg counts
# and package. It contains the sequence number of each paren and
# type of call, and we must add the arg count and package.
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $rsub_call_paren_info_by_seqno =
$self->[_rsub_call_paren_info_by_seqno_];
my @package_stack = reverse( @{$rpackage_lookup_list} );
my ( $current_package, $Kbegin, $Kend ) = @{ pop @package_stack };
my $is_dollar_underscore_zero = sub {
my ($K_closing_bracket) = @_;
# Given:
# $K_closing_bracket - index of a ']'
# Return:
# true of this is the end of '$_[0]'
# false otherwise
#
# return $_[0]->PP_decode_json(...
# |
# ---$K_closing_bracket
return unless ($K_closing_bracket);
my $seqno = $rLL->[$K_closing_bracket]->[_TYPE_SEQUENCE_];
return unless ($seqno);
my $Ko = $K_opening_container->{$seqno};
return unless defined($Ko);
my $Knum = $self->K_next_code($Ko);
return unless ( $Knum && $rLL->[$Knum]->[_TOKEN_] eq '0' );
my $Kc = $self->K_next_code($Knum);
return unless ( $Kc eq $K_closing_bracket );
my $K_p = $self->K_previous_code($Ko);
return unless ( $rLL->[$K_p]->[_TOKEN_] eq '$_' );
return 1;
}; ## end $is_dollar_underscore_zero = sub
#----------------------------------------------
# Loop over sequence numbers of all call parens
#----------------------------------------------
# parens are of the form f( ->f( &f( where 'f' is a bareword
# ^ ^ ^
# Note that we do not handle anonymous subs because it is not possible to
# connect them to the actual sub definition.
foreach
my $seqno ( sort { $a <=> $b } keys %{$rsub_call_paren_info_by_seqno} )
{
# update the current package
my $Ko = $K_opening_container->{$seqno};
while ( $Ko > $Kend && @package_stack ) {
( $current_package, $Kbegin, $Kend ) = @{ pop @package_stack };
}
# get the next call list
my $item = $rsub_call_paren_info_by_seqno->{$seqno};
my $name = $item->{token_m};
my $type_mm = $item->{type_mm};
# find function and package
my $is_ampersand_call;
# name will be like '&function' for an & call
if ( substr( $name, 0, 1 ) eq '&' ) {
$is_ampersand_call = 1;
$name = substr( $name, 1 );
}
my $call_type = $is_ampersand_call ? '&' : EMPTY_STRING;
my $caller_name = EMPTY_STRING;
my $class_name = EMPTY_STRING;
if ( $type_mm eq '->' ) {
$call_type = '->';
my $K_m = $self->K_previous_code($Ko);
my $K_mm = $self->K_previous_code($K_m);
my $K_mmm = $self->K_previous_code($K_mm);
if ( defined($K_mmm) ) {
my $type_mmm = $rLL->[$K_mmm]->[_TYPE_];
my $token_mmm = $rLL->[$K_mmm]->[_TOKEN_];
if ( $type_mmm eq 'i' ) {
$caller_name = $token_mmm;
}
elsif ( $type_mmm eq 'w' ) {
## A::B->do_something( $var1, $var2 );
## wwww->iiiiiiiiiiii{ iiiii, iiiii };
if ( index( $token_mmm, '::' ) >= 0 ) {
$class_name = $token_mmm;
$class_name =~ s/::$//;
}
}
elsif ( $token_mmm eq ']' ) {
if ( $is_dollar_underscore_zero->($K_mmm) ) {
$caller_name = '$_[0]';
}
}
else { }
}
}
# look for explicit package on name
my $package = $current_package;
if ( ( index( $name, ':' ) >= 0 || index( $name, "'" ) >= 0 )
&& $name =~ /^(.*\W)(\w+)$/ )
{
$package = $1;
$name = $2;
$package =~ s/\'/::/g;
$package =~ s/::$//;
}
else {
if ($class_name) {
$package = $class_name;
}
}
if ( !$package ) { $package = 'main' }
# count the args
my $rtype_count = $rtype_count_by_seqno->{$seqno};
my $arg_count = 0;
if ($rtype_count) {
my $comma_count = $rtype_count->{','};
my $fat_comma_count = $rtype_count->{'=>'};
if ($comma_count) { $arg_count += $comma_count }
if ($fat_comma_count) { $arg_count += $fat_comma_count }
}
# The comma count does not include any trailing comma, so add 1..
if ( !$arg_count ) {
# ..but not if parens are empty
my $Kc = $K_closing_container->{$seqno};
my $Kn = $Ko + 1;
if ( $Kn < $Kc ) {
my $type_n = $rLL->[$Kn]->[_TYPE_];
if ( $type_n eq 'b' ) {
$Kn += 1;
$type_n = $rLL->[$Kn]->[_TYPE_];
}
if ( $type_n eq '#' ) {
$Kn = $self->K_next_code($Ko);
}
if ( $Kn != $Kc ) { $arg_count += 1 }
}
}
else {
$arg_count += 1;
}
# The arg count is undefined if there are non-scalars in the list
$item->{seqno_list} = $seqno;
if ($arg_count) {
$item->{is_signature} = 0;
$item->{shift_count_min} = 0;
$item->{self_name} = EMPTY_STRING;
$self->count_list_elements($item);
$arg_count = $item->{shift_count_min};
}
# get the return count expected for this call by scanning to the left
$self->count_return_values_wanted($item);
# update the hash of info for this item
my $line_number = $rLL->[$Ko]->[_LINE_INDEX_] + 1;
$item->{arg_count} = $arg_count;
$item->{package} = $package;
$item->{name} = $name;
$item->{line_number} = $line_number;
$item->{call_type} = $call_type;
$item->{caller_name} = $caller_name;
$item->{class_name} = $class_name;
}
return;
} ## end sub update_sub_call_paren_info
{
#-----------------------------------------------------
# Sub to look at first use of $self in a specified sub
#-----------------------------------------------------
my %self_call_cache;
my %is_oo_call_cache;
sub initialize_self_call_cache {
my $self = shift;
# must be called once per file before first call to sub self_call_check
%self_call_cache = ();
%is_oo_call_cache = ();
return;
} ## end sub initialize_self_call_cache
sub self_call_check {
my ( $self, $seqno_sub ) = @_;
# Try to decide if a sub call with '$self->' is a call to an
# internal sub by looking at the first '$self' usage.
# Given:
# $seqno_sub = sequence number of sub to be checked
# Return:
# $is_self_call = true if this is an internal $self-> call
# based on the first $self in the sub.
# $is_oo_call = true if a call '$self->' appears to be
# within an OO framework which hides the $self arg.
# This uses the variable _rK_first_self_by_sub_seqno_ which
# is set by sub respace_tokens.
my $is_self_call = $self_call_cache{$seqno_sub};
my $is_oo_call = $is_oo_call_cache{$seqno_sub};
if ( !defined($is_self_call) ) {
$is_self_call = 0;
$is_oo_call = 0;
my $rLL = $self->[_rLL_];
my $K_first_self =
$self->[_rK_first_self_by_sub_seqno_]->{$seqno_sub};
# an index K stored by respace_tokens may be 1 low
$K_first_self++
if ( $K_first_self
&& $rLL->[$K_first_self]->[_TYPE_] eq 'b' );
my $Kn = $self->K_next_code($K_first_self);
my $type_n = $Kn ? $rLL->[$Kn]->[_TYPE_] : 'b';
#-----------------------------------------
# Try 3a. if "$self->" then assume OO call
#-----------------------------------------
if ( $type_n eq '->' ) {
$is_self_call = 1;
# Also set a flag to reduce the call arg count by 1
# because it looks this is an OO system which
# hides the $self call arg.
# NOTE: to be sure, we could scan all sub args
# in advance to check that all first sub args
# are not named $self
$is_oo_call = 1;
}
#--------------------------
# Try 3b. "$self = bless"
#--------------------------
elsif ( $type_n eq '=' ) {
my $Knn = $self->K_next_code($Kn);
$is_self_call = $Knn && $rLL->[$Knn]->[_TOKEN_] eq 'bless';
}
# none of the above
else { }
$self_call_cache{$seqno_sub} = $is_self_call;
$is_oo_call_cache{$seqno_sub} = $is_oo_call;
}
return ( $is_self_call, $is_oo_call );
} ## end sub self_call_check
}
use constant DEBUG_SELF => 0;
sub cross_check_sub_calls {
my ($self) = @_;
# This routine looks for issues for these parameters:
# --dump-mismatched-args
# --warn-mismatched-args
# --dump-mismatched-returns
# --warn-mismatched-returns
# It returns a hash of values with any warnings found
my $rLL = $self->[_rLL_];
# The mismatched-args checks are indicated by these letters:
# a = both method and non-method calls to a sub
# - even for two subs in a different package
# o = overcount: call arg counts exceed number expected by a sub
# u = undercount: call arg counts less than number expected by a sub
# - except if expecting N or less (N=4 by default)
# i = indeterminate: expected number of args was not determined
my %call_arg_issue_note = (
a => "both method and non-method calls to a sub",
o => "excess args passed",
u => "fewer args than expected passed",
i => "indeterminate sub arg count",
);
my %do_mismatched_call_type = %call_arg_issue_note;
my $mismatched_arg_undercount_cutoff = 0;
my $mismatched_arg_overcount_cutoff = 0;
my $ris_mismatched_call_excluded_name = {};
# The mismatched-returns checks are indicated by these letters:
my %return_issue_note = (
x => "want array but no return seen",
y => "want scalar but no return seen",
o => "want array with excess count",
u => "want array with count not matched by sub",
s => "want scalar but sub only returns arrays with count >1",
);
my %do_mismatched_return_type = %return_issue_note;
my $ris_mismatched_return_excluded_name = {};
# initialize a cache used for efficiency
$self->initialize_self_call_cache();
my $is_dump =
$rOpts->{'dump-mismatched-args'} || $rOpts->{'dump-mismatched-returns'};
# initialize if not in a dump mode
if ( !$is_dump ) {
%do_mismatched_call_type = %{$rwarn_mismatched_arg_types};
$mismatched_arg_undercount_cutoff =
$rOpts->{'warn-mismatched-arg-undercount-cutoff'};
$mismatched_arg_overcount_cutoff =
$rOpts->{'warn-mismatched-arg-overcount-cutoff'};
$ris_mismatched_call_excluded_name =
$ris_warn_mismatched_arg_excluded_name;
%do_mismatched_return_type = %{$rwarn_mismatched_return_types};
$ris_mismatched_return_excluded_name =
$ris_warn_mismatched_return_excluded_name;
}
# hardwired name exclusions
$ris_mismatched_call_excluded_name->{AUTOLOAD} = 1;
$ris_mismatched_call_excluded_name->{DESTROY} = 1;
my $K_opening_container = $self->[_K_opening_container_];
my $rK_package_list = $self->[_rK_package_list_];
my $ris_my_sub_by_seqno = $self->[_ris_my_sub_by_seqno_];
my $rsub_call_paren_info_by_seqno =
$self->[_rsub_call_paren_info_by_seqno_];
my $rK_bless_by_sub_seqno = $self->[_rK_bless_by_sub_seqno_];
#----------------------------
# Make a package lookup table
#----------------------------
my $rpackage_lists = $self->package_info_maker($rK_package_list);
my $rpackage_lookup_list = $rpackage_lists->{'rpackage_lookup_list'};
#-------------------------------------------
# Update sub call paren info with arg counts
#-------------------------------------------
$self->update_sub_call_paren_info($rpackage_lookup_list);
#----------------------------------
# Preliminary min and max call args
#----------------------------------
# This is preliminary because some of the calls will eventually be
# rejected if they appear to be to external objects. This info is
# needed to optimize the sub arg search in the case of zero args.
my %upper_bound_call_info;
foreach my $seqno ( keys %{$rsub_call_paren_info_by_seqno} ) {
my $rcall_item = $rsub_call_paren_info_by_seqno->{$seqno};
my $call_type = $rcall_item->{call_type};
my $package = $rcall_item->{package};
my $name = $rcall_item->{name};
my $arg_count = $rcall_item->{arg_count};
my $key = $package . '::' . $name;
next unless defined($arg_count);
if ( $call_type eq '->' ) {
$arg_count += 1;
$upper_bound_call_info{$key}->{method_call_count}++;
}
else {
$upper_bound_call_info{$key}->{direct_call_count}++;
}
my $max = $upper_bound_call_info{$key}->{max_arg_count};
my $min = $upper_bound_call_info{$key}->{min_arg_count};
if ( !defined($max) || $arg_count > $max ) {
$upper_bound_call_info{$key}->{max_arg_count} = $arg_count;
}
if ( !defined($min) || $arg_count < $min ) {
$upper_bound_call_info{$key}->{min_arg_count} = $arg_count;
}
}
#-----------------------------------
# Get arg counts for sub definitions
#-----------------------------------
my ( $rsub_info_by_seqno, $rsub_seqno_by_key ) =
$self->sub_def_info_maker( $rpackage_lookup_list,
\%upper_bound_call_info );
# Hash to hold combined info for subs and calls
my %common_hash;
#---------------------------------------------
# First split the calls into direct and method
#---------------------------------------------
my @method_call_seqnos;
foreach my $seqno ( keys %{$rsub_call_paren_info_by_seqno} ) {
my $rcall_item = $rsub_call_paren_info_by_seqno->{$seqno};
my $package = $rcall_item->{package};
my $name = $rcall_item->{name};
my $key = $package . '::' . $name;
if ( $rcall_item->{call_type} eq '->' ) {
push @method_call_seqnos, $seqno;
}
else {
push @{ $common_hash{$key}->{direct_calls} }, $rcall_item;
}
}
#----------------------------------------------
# Now split method calls into self and external
#----------------------------------------------
my @debug_warnings;
foreach my $seqno (@method_call_seqnos) {
my $rcall_item = $rsub_call_paren_info_by_seqno->{$seqno};
my $package = $rcall_item->{package};
my $name = $rcall_item->{name};
my $caller_name = $rcall_item->{caller_name};
my $class_name = $rcall_item->{class_name};
my $key_receiver_sub = $package . '::' . $name;
my $is_self_call;
# Find the sub which contains this call
my $seqno_sub_parent = $self->parent_sub_seqno($seqno);
if ($seqno_sub_parent) {
my $item = $rsub_info_by_seqno->{$seqno_sub_parent};
if ($item) {
my $key_parent_sub = $item->{package} . '::' . $item->{name};
my $parent_self_name = $item->{self_name};
my $caller_is_dollar_self = $caller_name eq '$self';
# Decide if this method call is to an internal sub:
# Try 1 and Try 2 are general, for any object name
# Try 3 and Try 4 are guesses for common uses of '$self'
#------------------------------------------------
# Try 1: Parent sub self name matches caller name
#------------------------------------------------
if ($parent_self_name) {
# and the only calls to parent sub (if any) are arrow calls.
if (
$parent_self_name eq $caller_name
&& ( !$common_hash{$key_parent_sub}->{direct_calls}
|| $caller_is_dollar_self )
)
{
$is_self_call = 1;
}
}
#---------------------------------------------------------
# Try 2. See if the name was blessed in the containing sub
#---------------------------------------------------------
if ( !$is_self_call ) {
my $item_self = $item->{self_name};
$item_self = 'undef' unless $item_self;
my $rK_bless_list =
$rK_bless_by_sub_seqno->{$seqno_sub_parent};
if ($rK_bless_list) {
my $Ko = $K_opening_container->{$seqno};
foreach my $blessing ( @{$rK_bless_list} ) {
# Index K and blessed name were stored with sub.
# $K_blessed may be 1 token before K of '$self'
my ( $K_blessed, $name_blessed ) = @{$blessing};
# name of blessed object must match
next if ( $name_blessed ne $caller_name );
# keyword 'bless' must be at top sub level. We have
# to back up 1 token in case $self is in parens.
my $Kp = $self->K_previous_code($K_blessed);
next if ( !$Kp );
my $parent_seqno = $self->parent_seqno_by_K($Kp);
next
if (!$parent_seqno
|| $parent_seqno != $seqno_sub_parent );
# bless must be before the call
next if ( $K_blessed > $Ko );
$is_self_call = 1;
last;
}
}
}
#-------------------------------------------------------
# Try 3. Caller is '$self'; look at first '$self' in sub
#-------------------------------------------------------
if ( !$is_self_call && $caller_is_dollar_self ) {
( $is_self_call, $rcall_item->{is_oo_call} ) =
$self->self_call_check($seqno_sub_parent);
}
#-------------------------------------------------------------
# Try 4. caller is '$self': receiver='$self', '$class', '$_[0]'
#-------------------------------------------------------------
if ( !$is_self_call && $caller_is_dollar_self ) {
my $seqno_sub_called =
$rsub_seqno_by_key->{$key_receiver_sub};
if ($seqno_sub_called) {
my $item_called =
$rsub_info_by_seqno->{$seqno_sub_called};
my $receiver = $item_called->{self_name};
#------------------------------------------------
# Try 4a: receiver has some recognized self names
#------------------------------------------------
if (
$receiver
&& ( $receiver eq $caller_name
|| $receiver eq '$class'
|| $receiver eq '$_[0]' )
)
{
$is_self_call = 1;
}
#-----------------------------------
# Try 4b: check for a recursive call
#-----------------------------------
else {
$is_self_call =
$seqno_sub_called == $seqno_sub_parent;
}
}
}
if ( DEBUG_SELF
&& !$is_self_call
&& $caller_is_dollar_self
&& $seqno_sub_parent )
{
my $Ko_sub = $K_opening_container->{$seqno_sub_parent};
my $ln_parent = $rLL->[$Ko_sub]->[_LINE_INDEX_] + 1;
my $Ko = $K_opening_container->{$seqno};
my $ln = $rLL->[$Ko]->[_LINE_INDEX_] + 1;
my $parent_self = $item->{self_name};
my $receiver_self = 'missing';
my $ln_receiver = 'undef';
my $seqno_sub_called =
$rsub_seqno_by_key->{$key_receiver_sub};
if ($seqno_sub_called) {
my $item_called =
$rsub_info_by_seqno->{$seqno_sub_called};
$receiver_self = $item_called->{self_name};
my $Ko_receiver =
$K_opening_container->{$seqno_sub_called};
$ln_receiver = $rLL->[$Ko_receiver]->[_LINE_INDEX_] + 1;
}
# use DEBUG_SELF=3 to see missing subs
else {
next if ( DEBUG_SELF < 3 );
}
# use DEBUG_SELF=2 to see undef-self-undef
next
if ( DEBUG_SELF < 2 && !$parent_self && !$receiver_self );
if ( !$parent_self ) { $parent_self = 'undef' }
if ( !$receiver_self ) { $receiver_self = 'undef' }
push @debug_warnings,
{
Ko => $Ko,
caller_name => $caller_name,
parent_self => $parent_self,
receiver_self => $receiver_self,
sub_called => $name,
line_number => $ln,
ln_parent => $ln_parent,
ln_receiver => $ln_receiver,
};
}
}
}
# Save this method call as either an internal (self) or external call
if ($is_self_call) {
push @{ $common_hash{$key_receiver_sub}->{self_calls} },
$rcall_item;
}
else {
# mark calls made by unknown (non-self) objects, we can't track
# them, but we can track calls at the class level.
if ( !$class_name ) {
$rcall_item->{is_unknown_object_call} = 1;
}
}
}
if ( DEBUG_SELF && @debug_warnings ) {
@debug_warnings = sort { $a->{Ko} <=> $b->{Ko} } @debug_warnings;
my $output_string = EMPTY_STRING;
foreach my $item (@debug_warnings) {
## my $caller_name = $item->{caller_name};
my $parent_self = $item->{parent_self};
my $receiver_self = $item->{receiver_self};
my $sub_called = $item->{sub_called};
my $line_number = $item->{line_number};
my $ln_parent = $item->{ln_parent};
my $ln_receiver = $item->{ln_receiver};
$output_string .=
"$line_number: \$self->$sub_called in parent line $ln_parent with self=$parent_self to receiver line $ln_receiver with self=$receiver_self\n";
}
warning($output_string);
}
#-------------------------------
# Loop to merge prototype counts
#-------------------------------
foreach my $key ( keys %common_hash ) {
my $seqno_sub = $rsub_seqno_by_key->{$key};
next if ( !defined($seqno_sub) );
my $rsub_item = $rsub_info_by_seqno->{$seqno_sub};
next if ( !$rsub_item->{prototype} );
my $item = $common_hash{$key};
my $rdirect_calls = $item->{direct_calls};
my $rself_calls = $item->{self_calls};
my $num_direct = defined($rdirect_calls) ? @{$rdirect_calls} : 0;
my $num_self = defined($rself_calls) ? @{$rself_calls} : 0;
# Use prototype values if given and all calls are direct
# Otherwise, ignore the prototype.
next if ($num_self);
next if ( !$num_direct );
my $shift_count_min = $rsub_item->{prototype_count_min};
my $shift_count_max = $rsub_item->{prototype_count_max};
if ($num_self) {
if ( defined($shift_count_min) ) { $shift_count_min++ }
if ( defined($shift_count_max) ) { $shift_count_max++ }
}
# For calls with '&' to subs with prototypes, use the upper bound of
# the prototype max and the max found by scanning the script.
my $shift_count_max_amp = $shift_count_max;
if ( defined($shift_count_max) ) {
my $standard_max = $rsub_item->{shift_count_max};
if ( !defined($standard_max) || $standard_max > $shift_count_max ) {
$shift_count_max_amp = $standard_max;
}
}
$rsub_item->{shift_count_max_amp} = $shift_count_max_amp;
# overwrite values found by scanning the script with prototype values
$rsub_item->{shift_count_min} = $shift_count_min;
$rsub_item->{shift_count_max} = $shift_count_max;
}
#--------------------------------------------------------------
# Loop over all sub calls to compare call and return arg counts
#--------------------------------------------------------------
foreach my $seqno ( keys %{$rsub_call_paren_info_by_seqno} ) {
my $rcall_item = $rsub_call_paren_info_by_seqno->{$seqno};
# Skip method calls by unknown objects
next if ( $rcall_item->{is_unknown_object_call} );
my $arg_count = $rcall_item->{arg_count};
my $return_count_wanted = $rcall_item->{return_count_wanted};
my $want_scalar = $rcall_item->{want_scalar};
my $package = $rcall_item->{package};
my $name = $rcall_item->{name};
my $call_type = $rcall_item->{call_type};
my $key = $package . '::' . $name;
my ( $shift_count_min, $shift_count_max, $self_name );
my ( $return_count_min, $return_count_max, $return_count_indefinite );
my ($rK_return_count_hash);
# look for the sub ..
my $seqno_sub = $rsub_seqno_by_key->{$key};
my $rK_return_list;
my $saw_wantarray;
if ( defined($seqno_sub) ) {
my $rsub_item = $rsub_info_by_seqno->{$seqno_sub};
$saw_wantarray =
defined( $self->[_rK_wantarray_by_sub_seqno_]->{$seqno_sub} );
# skip 'my' subs for now, they need special treatment. If
# anonymous subs are added, 'my' subs could also be added then.
if ( !$ris_my_sub_by_seqno->{$seqno_sub} ) {
$common_hash{$key}->{rsub_item} = $rsub_item;
$shift_count_min = $rsub_item->{shift_count_min};
$shift_count_max = $rsub_item->{shift_count_max};
if ( $call_type eq '&' && $rsub_item->{prototype} ) {
$shift_count_max = $rsub_item->{shift_count_max_amp};
}
$self_name = $rsub_item->{self_name};
$return_count_min = $rsub_item->{return_count_min};
$return_count_max = $rsub_item->{return_count_max};
$return_count_indefinite =
$rsub_item->{return_count_indefinite};
$rK_return_list =
$self->[_rK_return_by_sub_seqno_]->{$seqno_sub};
$common_hash{$key}->{rK_return_list} = $rK_return_list;
$rK_return_count_hash = $rsub_item->{rK_return_count_hash};
}
}
#------------------------------------
# compare caller/sub input arg counts
#------------------------------------
if ( defined($shift_count_min) && defined($arg_count) ) {
if ( $call_type eq '->' && !$rcall_item->{is_oo_call} ) {
$arg_count += 1;
}
my $excess = $arg_count - $shift_count_min;
my $max = $common_hash{$key}->{max_arg_count};
my $min = $common_hash{$key}->{min_arg_count};
if ( !defined($max) || $arg_count > $max ) {
$common_hash{$key}->{max_arg_count} = $arg_count;
}
if ( !defined($min) || $arg_count < $min ) {
$common_hash{$key}->{min_arg_count} = $arg_count;
}
if ( $excess < 0 ) {
push @{ $common_hash{$key}->{under_count} }, $rcall_item;
}
elsif ( $excess > 0 ) {
if ( defined($shift_count_max) ) {
$excess = $arg_count - $shift_count_max;
if ( $excess > 0 ) {
push @{ $common_hash{$key}->{over_count} }, $rcall_item;
}
}
}
else {
## $excess = 0
}
}
#---------------------------------------------
# compare caller/sub return counts if possible
#---------------------------------------------
# rhs check: only check subs returning finite lists (i.e. not '@list');
next if ($return_count_indefinite);
# lhs check: only check when a finite return list is wanted
next if ( !$return_count_wanted );
# ignore scalar if wantarray seen
next if ( $want_scalar && $saw_wantarray );
# update min-max want ranges for the output report
my $max = $common_hash{$key}->{want_count_max};
my $min = $common_hash{$key}->{want_count_min};
if ( !defined($max) || $return_count_wanted > $max ) {
$common_hash{$key}->{want_count_max} = $return_count_wanted;
}
if ( !defined($min) || $return_count_wanted < $min ) {
$common_hash{$key}->{want_count_min} = $return_count_wanted;
}
# return issue 'x': want array but no return seen
# return issue 'y': want scalar but no return seen
if ( !defined($rK_return_list) ) {
if ($want_scalar) {
push @{ $common_hash{$key}->{return_issues}->{y} }, $rcall_item;
}
else {
push @{ $common_hash{$key}->{return_issues}->{x} }, $rcall_item;
}
}
# safety check
elsif ( !defined($return_count_max) ) {
# shouldn't happen-should be defined if $rK_return_list is defined
DEVEL_MODE && Fault("return_count_max should be defined here\n");
}
# check for exact match
elsif ( $return_count_wanted == $return_count_max ) {
## ok
}
# return issue 'o': overwant
elsif ( $return_count_wanted > $return_count_max ) {
# but no error for scalar request of 1 when max 0 returned
if ( !$want_scalar ) {
push @{ $common_hash{$key}->{return_issues}->{o} }, $rcall_item;
}
}
# if want less than max...
else {
# issue 'u': want array for an unmatched count less than max
# issue 's': want scalar but all return counts are >1
if ( defined($rK_return_count_hash) ) {
my $K_return = $rK_return_count_hash->{$return_count_wanted};
if ( !defined($K_return) ) {
if ($want_scalar) {
push @{ $common_hash{$key}->{return_issues}->{s} },
$rcall_item;
}
else {
push @{ $common_hash{$key}->{return_issues}->{u} },
$rcall_item;
}
}
}
else {
## safety check, shouldn't happen
DEVEL_MODE && Fault("return count hash not defined\n");
}
}
}
#------------------------------------
# Construct one-line warning messages
#------------------------------------
my @call_arg_warnings;
my @return_warnings;
my $max_shift_count_with_undercount = 0;
my $number_of_undercount_warnings = 0;
# variables with information about a sub needed for warning output:
my (
$lno, $name,
$shift_count_min, $shift_count_max,
$min_arg_count, $max_arg_count,
$return_count_min, $return_count_max,
$want_count_min, $want_count_max,
);
my $push_call_arg_warning = sub {
my ( $letter, $note ) = @_;
my $shift_count = $shift_count_min;
if ( $shift_count_min ne '*' && $shift_count_min ne $shift_count_max ) {
$shift_count = "$shift_count_min-$shift_count_max";
}
my $output_line =
"$lno:$letter:$name:$shift_count:$min_arg_count:$max_arg_count: $note\n";
push @call_arg_warnings,
{
line_number => $lno,
letter => $letter,
name => $name,
output_line => $output_line,
};
return;
}; ## end $push_call_arg_warning = sub
my $push_return_warning = sub {
my ( $letter, $note, $lno_return ) = @_;
my $return_count = $return_count_min;
if ( $return_count_min ne '*'
&& $return_count_min ne $return_count_max )
{
$return_count = "$return_count_min-$return_count_max";
}
my $output_line =
"$lno_return:$letter:$name:$return_count:$want_count_min:$want_count_max: $note\n";
push @return_warnings,
{
line_number => $lno_return,
letter => $letter,
name => $name,
output_line => $output_line,
};
return;
}; ## end $push_return_warning = sub
#-------------------
# Loop over each sub
#-------------------
foreach my $key ( keys %common_hash ) {
my $item = $common_hash{$key};
# Check for mixed method/direct calls:
my $rsub_item = $item->{rsub_item};
next unless defined($rsub_item);
$name = $rsub_item->{name};
$lno = $rsub_item->{line_number};
## my $rK_return_list = $item->{rK_return_list};
my $rself_calls = $item->{self_calls};
my $rdirect_calls = $item->{direct_calls};
my $num_self = defined($rself_calls) ? @{$rself_calls} : 0;
my $num_direct = defined($rdirect_calls) ? @{$rdirect_calls} : 0;
## my $K_return_count_min = $rsub_item->{K_return_count_min};
my $K_return_count_max = $rsub_item->{K_return_count_max};
$shift_count_min = $rsub_item->{shift_count_min};
$shift_count_max = $rsub_item->{shift_count_max};
$return_count_min = $rsub_item->{return_count_min};
$return_count_max = $rsub_item->{return_count_max};
$min_arg_count = $item->{min_arg_count};
$max_arg_count = $item->{max_arg_count};
$want_count_min = $item->{want_count_min};
$want_count_max = $item->{want_count_max};
# change undefs to '*' for the output text
foreach (
$shift_count_min, $shift_count_max,
$return_count_min, $return_count_max,
$min_arg_count, $max_arg_count,
$want_count_min, $want_count_max,
)
{
$_ = '*' unless defined($_);
}
#-----------------------------------------------------------------
# Make a one-line message for each mismatch call issue of this sub
#-----------------------------------------------------------------
my $rover_count = $item->{over_count};
my $runder_count = $item->{under_count};
my $num_over_count = defined($rover_count) ? @{$rover_count} : 0;
my $num_under_count = defined($runder_count) ? @{$runder_count} : 0;
#--------------------------------------------------
# issue 'a': subs with both self-> and direct calls
#--------------------------------------------------
if ( $num_self && $num_direct && $do_mismatched_call_type{'a'} ) {
my $letter = 'a';
my $lines_self_calls = stringify_line_range($rself_calls);
my $lines_direct_calls = stringify_line_range($rdirect_calls);
my $self_name = $rsub_item->{self_name};
if ( !defined($self_name) ) { $self_name = EMPTY_STRING }
my $ess1 = $num_self > 1 ? 's' : EMPTY_STRING;
my $ess2 = $num_direct > 1 ? 's' : EMPTY_STRING;
my $str = $self_name . '->call' . $ess1;
my $note =
"$num_self $str($lines_self_calls) and $num_direct call$ess2($lines_direct_calls)";
$push_call_arg_warning->( $letter, $note );
}
#---------------------------------------------------------
# Ignore calls to a sub which was not defined in this file
#---------------------------------------------------------
if ( !defined($rsub_item) ) {
next;
}
#-------------------------------------------------------------------
# issue 'i': indeterminate. Could not determine a specific arg count
#-------------------------------------------------------------------
if ( $shift_count_min eq '*' ) {
my $letter = 'i';
if ( $do_mismatched_call_type{$letter} ) {
# skip *:*:* (no disagreement - call counts also indeterminate)
next
if ( $shift_count_min eq $min_arg_count
&& $shift_count_min eq $max_arg_count );
my $note = $call_arg_issue_note{$letter};
$push_call_arg_warning->( $letter, $note );
}
}
# otherwise check call arg counts
else {
#---------------------
# issue 'o': overcount
#---------------------
if ( $num_over_count
&& $do_mismatched_call_type{'o'}
&& $shift_count_max >= $mismatched_arg_overcount_cutoff )
{
my $letter = 'o';
my $line_range = stringify_line_range($rover_count);
my $total = $num_direct + $num_self;
my $note = $call_arg_issue_note{$letter};
$note .=
$total > 1
? " at $num_over_count of $total calls ($line_range)"
: " at $line_range";
$push_call_arg_warning->( $letter, $note );
}
#----------------------
# issue 'u': undercount
#----------------------
if ($num_under_count) {
if ( $shift_count_min > $max_shift_count_with_undercount ) {
$max_shift_count_with_undercount = $shift_count_min;
}
# Skip the warning for small lists with undercount
if ( $do_mismatched_call_type{'u'}
&& $shift_count_min >= $mismatched_arg_undercount_cutoff )
{
my $letter = 'u';
my $line_range = stringify_line_range($runder_count);
my $total = $num_direct + $num_self;
my $note = $call_arg_issue_note{$letter};
$note .=
$total > 1
? " at $num_under_count of $total calls ($line_range)"
: " at $line_range";
$number_of_undercount_warnings++;
$push_call_arg_warning->( $letter, $note );
}
}
}
#-------------------------------------------------------------------
# Make a one-line message for each mismatch return issue of this sub
#-------------------------------------------------------------------
my $return_issues = $item->{return_issues};
if ($return_issues) {
foreach my $letter ( keys %return_issue_note ) {
next if ( !$do_mismatched_return_type{$letter} );
my $rissues = $return_issues->{$letter};
my $number = defined($rissues) ? @{$rissues} : 0;
next unless ($number);
my $line_range = stringify_line_range($rissues);
my $total = $num_direct + $num_self;
my $note = $return_issue_note{$letter};
$note .=
$total > 1
? " at $number of $total calls ($line_range)"
: " at $line_range";
# The one-line message shows the line number of the return
# with the maximum count if there are returns. If no returns
# (types 'x' and 'y') it shows the first line of the sub ($lno).
my $lno_return =
defined($K_return_count_max)
? $rLL->[$K_return_count_max]->[_LINE_INDEX_] + 1
: $lno;
$push_return_warning->( $letter, $note, $lno_return );
} ## end loop to save one line for mismatched returns
}
}
#-----------------------------------------------
# Make the sorted/filtered call arg issue report
#-----------------------------------------------
my $rcall_arg_warnings = sort_warnings( \@call_arg_warnings );
$rcall_arg_warnings = filter_excluded_names( $rcall_arg_warnings,
$ris_mismatched_call_excluded_name );
my $call_arg_warning_output = EMPTY_STRING;
my $call_arg_hint = EMPTY_STRING;
if ( @{$rcall_arg_warnings} ) {
my $header =
"Issue types are 'a'=arrow mismatch 'u'=undercount 'o'=overcount";
if ($is_dump) { $header .= " 'i'=indeterminate" }
$call_arg_warning_output = <{output_line};
}
if ( !$is_dump && $number_of_undercount_warnings ) {
my $wmauc_min = $max_shift_count_with_undercount + 1;
$call_arg_hint = <{output_line};
}
}
return {
call_arg_warning_output => $call_arg_warning_output,
return_warning_output => $return_warning_output,
};
} ## end sub cross_check_sub_calls
sub sort_warnings {
my ($rwarnings) = @_;
# Given:
# $rwarnigns = ref to list of warning info hashes
# Return updated $rwarnings
# - Sorted by line number
if ( @{$rwarnings} ) {
# sort by line number
$rwarnings = [
sort {
$a->{line_number} <=> $b->{line_number}
|| $a->{letter} cmp $b->{letter}
} @{$rwarnings}
];
}
return $rwarnings;
} ## end sub sort_warnings
sub stringify_line_range {
my ($rcalls) = @_;
# Given:
# $rcalls = ref to list of call info
# Return:
# $string = single line of text with just the line range
my $string = EMPTY_STRING;
if ( $rcalls && @{$rcalls} ) {
my @sorted =
sort { $a->{line_number} <=> $b->{line_number} } @{$rcalls};
my $num = @sorted;
my $lno_beg = $sorted[0]->{line_number};
my $lno_end = $sorted[-1]->{line_number};
if ( $num == 1 ) {
$string = "line $lno_beg";
}
elsif ( $num == 2 ) {
$string = "lines $lno_beg,$lno_end";
}
else {
$string = "lines $lno_beg..$lno_end";
}
}
return $string;
} ## end sub stringify_line_range
sub initialize_warn_mismatched {
# a - mismatched arrow operator calls
# o - overcount
# u - undercount
$rwarn_mismatched_arg_types =
initialize_warn_hash( 'warn-mismatched-arg-types', 1, [qw( a o u )] );
$ris_warn_mismatched_arg_excluded_name =
make_excluded_name_hash('warn-mismatched-arg-exclusion-list');
# x - want array but no return seen
# o - want array with excess count
# u - want array with unmatched count
# y - want scalar but no return seen
# s - want scalar but only arrays with count > 1 returned
$rwarn_mismatched_return_types =
initialize_warn_hash( 'warn-mismatched-return-types',
1, [qw( x o u y s )] );
$ris_warn_mismatched_return_excluded_name =
make_excluded_name_hash('warn-mismatched-return-exclusion-list');
return;
} ## end sub initialize_warn_mismatched
sub warn_mismatched {
my ($self) = @_;
# process both --warn-mismatched-args and --warn-mismatched-returns,
my $rhash = $self->cross_check_sub_calls();
my $wma_key = 'warn-mismatched-args';
if ( $rOpts->{$wma_key} ) {
my $output_lines = $rhash->{call_arg_warning_output};
if ($output_lines) {
chomp $output_lines;
warning(<{$wmr_key} ) {
my $output_lines = $rhash->{return_warning_output};
if ($output_lines) {
chomp $output_lines;
warning(<cross_check_sub_calls();
my $output_string = $rhash->{call_arg_warning_output};
if ($output_string) {
my $input_stream_name = get_input_stream_name();
chomp $output_string;
print {*STDOUT} <cross_check_sub_calls();
my $output_string = $rhash->{return_warning_output};
if ($output_string) {
my $input_stream_name = get_input_stream_name();
chomp $output_string;
print {*STDOUT} <
my $rLL = $self->[_rLL_];
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
# non-container tokens use the type as the key
if ( !$seqno ) {
my $type = $rLL->[$KK]->[_TYPE_];
if ( $rkeep_break_hash->{$type} ) {
$rbreak_hash->{$KK} = $is_soft_keep_break_type{$type} ? 2 : 1;
}
}
# container tokens use the token as the key
else {
my $token = $rLL->[$KK]->[_TOKEN_];
my $flag = $rkeep_break_hash->{$token};
if ($flag) {
my $match = $flag eq '1' || $flag eq '*';
# check for special matching codes
if ( !$match ) {
if ( $token eq '(' || $token eq ')' ) {
$match = $self->match_paren_control_flag( $seqno, $flag );
}
elsif ( $token eq '{' || $token eq '}' ) {
# These tentative codes 'b' and 'B' for brace types are
# placeholders for possible future brace types. They
# are not documented and may be changed.
my $block_type = $self->[_rblock_type_of_seqno_]->{$seqno};
if ( $flag eq 'b' ) { $match = $block_type }
elsif ( $flag eq 'B' ) { $match = !$block_type }
else {
## unknown code - no match
DEVEL_MODE && Fault(<[$KK]->[_TYPE_];
$rbreak_hash->{$KK} = $is_soft_keep_break_type{$type} ? 2 : 1;
}
}
}
return;
} ## end sub check_for_old_break
sub keep_old_line_breaks {
my ($self) = @_;
# Called once per file to find and mark any old line breaks which
# should be kept. We will be translating the input hashes into
# token indexes.
# A flag is set as follows:
# = 1 make a hard break (flush the current batch)
# best for something like leading commas (-kbb=',')
# = 2 make a soft break (keep building current batch)
# best for something like leading ->
my $rLL = $self->[_rLL_];
my $rKrange_code_without_comments =
$self->[_rKrange_code_without_comments_];
my $rbreak_before_Kfirst = $self->[_rbreak_before_Kfirst_];
my $rbreak_after_Klast = $self->[_rbreak_after_Klast_];
my $rbreak_container = $self->[_rbreak_container_];
#----------------------------------------
# Apply --break-at-old-method-breakpoints
#----------------------------------------
# This code moved here from sub break_lists to fix b1120
if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
foreach my $item ( @{$rKrange_code_without_comments} ) {
my ( $Kfirst, $Klast ) = @{$item};
my $type = $rLL->[$Kfirst]->[_TYPE_];
my $token = $rLL->[$Kfirst]->[_TOKEN_];
# leading '->' use a value of 2 which causes a soft
# break rather than a hard break
if ( $type eq '->' ) {
# ignore -bom after an opening token ( a syntax error, b1475 )
my $Kp = $self->K_previous_nonblank($Kfirst);
next if ( !defined($Kp) );
next if ( $is_opening_type{ $rLL->[$Kp]->[_TYPE_] } );
# ignore -bom if this does not look like a method call; c426
my $Kn = $self->K_next_nonblank($Kfirst);
next if ( !defined($Kn) );
my $token_n = $rLL->[$Kn]->[_TYPE_];
next if ( $token_n eq '{' || $token_n eq '[' );
$rbreak_before_Kfirst->{$Kfirst} = 2;
}
# leading ')->' use a special flag to insure that both
# opening and closing parens get opened
# Fix for b1120: only for parens, not braces
elsif ( $token eq ')' ) {
my $Kn = $self->K_next_nonblank($Kfirst);
next if ( !defined($Kn) );
next if ( $Kn > $Klast );
next if ( $rLL->[$Kn]->[_TYPE_] ne '->' );
my $seqno = $rLL->[$Kfirst]->[_TYPE_SEQUENCE_];
next if ( !$seqno );
# Note: in previous versions there was a fix here to avoid
# instability between conflicting -bom and -pvt or -pvtc flags.
# The fix skipped -bom for a small line difference. But this
# was troublesome, and instead the fix has been moved to
# sub set_vertical_tightness_flags where priority is given to
# the -bom flag over -pvt and -pvtc flags. Both opening and
# closing paren flags are involved because even though -bom only
# requests breaking before the closing paren, automated logic
# opens the opening paren when the closing paren opens.
# Relevant cases are b977, b1215, b1270, b1303
# ignore -bom if this does not look like a method call; c426
$Kn = $self->K_next_nonblank($Kn);
next if ( !defined($Kn) );
my $token_n = $rLL->[$Kn]->[_TYPE_];
next if ( $token_n eq '{' || $token_n eq '[' );
$rbreak_container->{$seqno} = 1;
}
else {
# not a special case
}
}
}
#---------------------------------------------------------------------
# Apply --keep-old-breakpoints-before and --keep-old-breakpoints-after
#---------------------------------------------------------------------
return unless ( %keep_break_before_type || %keep_break_after_type );
foreach my $item ( @{$rKrange_code_without_comments} ) {
my ( $Kfirst, $Klast ) = @{$item};
$self->check_for_old_break( $Kfirst, \%keep_break_before_type,
$rbreak_before_Kfirst );
$self->check_for_old_break( $Klast, \%keep_break_after_type,
$rbreak_after_Klast );
}
return;
} ## end sub keep_old_line_breaks
sub weld_containers {
my ($self) = @_;
# Called once per file to do any welding operations requested by --weld*
# flags.
# This count is used to eliminate needless calls for weld checks elsewhere
$total_weld_count = 0;
return if ( $rOpts->{'indent-only'} );
return unless ($rOpts_add_newlines);
# Important: sub 'weld_cuddled_blocks' must be called before
# sub 'weld_nested_containers'. This is because the cuddled option needs to
# use the original _LEVEL_ values of containers, but the weld nested
# containers changes _LEVEL_ of welded containers.
# Here is a good test case to be sure that both cuddling and welding
# are working and not interfering with each other: <>
# perltidy -wn -ce
# if ($BOLD_MATH) { (
# $labels, $comment,
# join( '', '', &make_math( $mode, '', '', $_ ), '' )
# ) } else { (
# &process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ),
# $after
# ) }
$self->weld_cuddled_blocks() if ( %{$rcuddled_block_types} );
if ( $rOpts->{'weld-nested-containers'} ) {
$self->weld_nested_containers();
$self->weld_nested_quotes();
}
#-------------------------------------------------------------
# All welding is done. Finish setting up weld data structures.
#-------------------------------------------------------------
my $rLL = $self->[_rLL_];
my $rK_weld_left = $self->[_rK_weld_left_];
my $rK_weld_right = $self->[_rK_weld_right_];
my $rweld_len_right_at_K = $self->[_rweld_len_right_at_K_];
my @K_multi_weld;
my @keys = keys %{$rK_weld_right};
$total_weld_count = @keys;
# First pass to process binary welds.
# This loop is processed in unsorted order for efficiency.
foreach my $Kstart (@keys) {
my $Kend = $rK_weld_right->{$Kstart};
# An error here would be due to an incorrect initialization introduced
# in one of the above weld routines, like sub weld_nested.
if ( $Kend <= $Kstart ) {
Fault("Bad weld link: Kend=$Kend <= Kstart=$Kstart\n")
if (DEVEL_MODE);
next;
}
# Set weld values for all tokens this welded pair
foreach ( $Kstart + 1 .. $Kend ) {
$rK_weld_left->{$_} = $Kstart;
}
foreach my $Kx ( $Kstart .. $Kend - 1 ) {
$rK_weld_right->{$Kx} = $Kend;
$rweld_len_right_at_K->{$Kx} =
$rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kx]->[_CUMULATIVE_LENGTH_];
}
# Remember the leftmost index of welds which continue to the right
if ( defined( $rK_weld_right->{$Kend} )
&& !defined( $rK_weld_left->{$Kstart} ) )
{
push @K_multi_weld, $Kstart;
}
}
# Second pass to process chains of welds (these are rare).
# This has to be processed in sorted order.
if (@K_multi_weld) {
my $Kend = -1;
foreach my $Kstart ( sort { $a <=> $b } @K_multi_weld ) {
# Skip any interior K which was originally missing a left link
next if ( $Kstart <= $Kend );
# Find the end of this chain
$Kend = $rK_weld_right->{$Kstart};
my $Knext = $rK_weld_right->{$Kend};
while ( defined($Knext) ) {
if ( $Knext <= $Kend ) {
## shouldn't happen: K should increase for right weld
DEVEL_MODE && Fault(<{$Kend} is not increasing
EOM
last;
}
$Kend = $Knext;
$Knext = $rK_weld_right->{$Kend};
} ## end while ( defined($Knext) )
# Set weld values this chain
foreach ( $Kstart + 1 .. $Kend ) {
$rK_weld_left->{$_} = $Kstart;
}
foreach my $Kx ( $Kstart .. $Kend - 1 ) {
$rK_weld_right->{$Kx} = $Kend;
$rweld_len_right_at_K->{$Kx} =
$rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kx]->[_CUMULATIVE_LENGTH_];
}
}
}
return;
} ## end sub weld_containers
sub weld_cuddled_blocks {
my ($self) = @_;
# Called once per file to handle cuddled formatting
my $rK_weld_left = $self->[_rK_weld_left_];
my $rK_weld_right = $self->[_rK_weld_right_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
# 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 $ris_broken_container = $self->[_ris_broken_container_];
my $ris_cuddled_closing_brace = $self->[_ris_cuddled_closing_brace_];
my $K_closing_container = $self->[_K_closing_container_];
# A stack to remember open chains at all levels: This is a hash rather than
# an array for safety because negative levels can occur in files with
# errors. This allows us to keep processing with negative 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;
foreach my $KK ( @{ $self->[_rK_sequenced_token_list_] } ) {
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
# A fault here implies that an error was made in the little loop at
# the bottom of sub 'respace_tokens' which set the values of
# _rK_sequenced_token_list_. Or an error has been introduced in
# the loop control lines above.
Fault("sequence = $type_sequence not defined at K=$KK")
if (DEVEL_MODE);
next;
}
# NOTE: we must use the original levels here. They can get changed
# by sub 'weld_nested_containers', so this routine must be called
# before sub 'weld_nested_containers'.
my $last_level = $level;
$level = $rtoken_vars->[_LEVEL_];
if ( $level < $last_level ) { $in_chain{$last_level} = undef }
elsif ( $level > $last_level ) { $in_chain{$level} = undef }
else {
# level unchanged
}
# 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 = $rblock_type_of_seqno->{$type_sequence};
if ( !$block_type ) {
# patch for unrecognized block types which may not be labeled
my $Kp = $self->K_previous_code($KK);
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 ( !$ris_broken_container->{$closing_seqno}
&& !$rbreak_container->{$closing_seqno} )
{
next unless ( $CBO == 2 );
$rbreak_container->{$closing_seqno} = 1;
}
# We can weld the closing brace to its following word ..
my $Ko = $K_closing_container->{$closing_seqno};
my $Kon;
if ( defined($Ko) ) {
$Kon = $self->K_next_nonblank($Ko);
}
# ..unless it is a comment
if ( defined($Kon) && $rLL->[$Kon]->[_TYPE_] ne '#' ) {
# OK to weld these two tokens...
$rK_weld_right->{$Ko} = $Kon;
$rK_weld_left->{$Kon} = $Ko;
# Set flag that we want to break the next container
# so that the cuddled line is balanced.
$rbreak_container->{$opening_seqno} = 1
if ($CBO);
# Remember which braces are cuddled.
# The closing brace is used to set adjusted indentations.
# The opening brace is not yet used but might eventually
# be needed in setting adjusted indentation.
$ris_cuddled_closing_brace->{$closing_seqno} = 1;
}
}
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 }
}
}
else {
# not a curly brace
}
}
return;
} ## end sub weld_cuddled_blocks
sub find_nested_pairs {
my ($self) = @_;
# This routine is called once per file to do preliminary work needed for
# the --weld-nested option. This information is also needed for adding
# semicolons.
# Returns:
# \@nested_pairs = ref to a list in which each item is a ref to
# to the sequence numbers of two nested containers:
# [ $seqno_inner, $seqno_outer ]
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $Num = @{$rLL};
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $rK_next_seqno_by_K = $self->[_rK_next_seqno_by_K_];
# We define an array of pairs of nested containers
my @nested_pairs;
# 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,
};
# Loop over all closing container tokens
foreach my $inner_seqno ( keys %{$K_closing_container} ) {
my $K_inner_closing = $K_closing_container->{$inner_seqno};
# See if it is immediately followed by another, outer closing token
my $K_outer_closing = $K_inner_closing + 1;
$K_outer_closing += 1
if ( $K_outer_closing < $Num
&& $rLL->[$K_outer_closing]->[_TYPE_] eq 'b' );
next if ( $K_outer_closing >= $Num );
my $outer_seqno = $rLL->[$K_outer_closing]->[_TYPE_SEQUENCE_];
next if ( !$outer_seqno );
my $token_outer_closing = $rLL->[$K_outer_closing]->[_TOKEN_];
next if ( !$is_closing_token{$token_outer_closing} );
# Simple filter: No commas or semicolons in the outer container
my $rtype_count = $self->[_rtype_count_by_seqno_]->{$outer_seqno};
if ($rtype_count) {
next if ( $rtype_count->{','} || $rtype_count->{';'} );
}
# Now we have to check the opening tokens.
my $K_outer_opening = $K_opening_container->{$outer_seqno};
my $K_inner_opening = $K_opening_container->{$inner_seqno};
next if ( !defined($K_outer_opening) );
next if ( !defined($K_inner_opening) );
my $inner_blocktype = $rblock_type_of_seqno->{$inner_seqno};
my $outer_blocktype = $rblock_type_of_seqno->{$outer_seqno};
# Verify that the inner opening token is the next container after the
# outer opening token.
my $K_io_check = $rK_next_seqno_by_K->[$K_outer_opening];
next unless defined($K_io_check);
if ( $K_io_check != $K_inner_opening ) {
# The inner opening container does not immediately follow the outer
# opening container, but we may still allow a weld if they are
# separated by a sub signature. For example, we may have something
# like this, where $K_io_check may be at the first 'x' instead of
# 'io'. So we need to hop over the signature and see if we arrive
# at 'io'.
# oo io
# | x x |
# $obj->then( sub ( $code ) {
# ...
# return $c->render(text => '', status => $code);
# } );
# | |
# ic oc
next if ( !$inner_blocktype || $inner_blocktype ne 'sub' );
next if $rLL->[$K_io_check]->[_TOKEN_] ne '(';
my $seqno_signature = $rLL->[$K_io_check]->[_TYPE_SEQUENCE_];
next unless defined($seqno_signature);
my $K_signature_closing = $K_closing_container->{$seqno_signature};
next unless defined($K_signature_closing);
my $K_test = $rK_next_seqno_by_K->[$K_signature_closing];
next
unless ( defined($K_test) && $K_test == $K_inner_opening );
# OK, we have arrived at 'io' in the above diagram. We should put
# a limit on the length or complexity of the signature here. There
# is no perfect way to do this, one way is to put a limit on token
# count. For consistency with older versions, we should allow a
# signature with a single variable to weld, but not with
# multiple variables. A single variable as in 'sub ($code) {' can
# have a $Kdiff of 2 to 4, depending on spacing.
# But two variables like 'sub ($v1,$v2) {' can have a diff of 4 to
# 7, depending on spacing. So to keep formatting consistent with
# previous versions, we will also avoid welding if there is a comma
# in the signature.
my $Kdiff = $K_signature_closing - $K_io_check;
next if ( $Kdiff > 4 );
# backup comma count test; but we cannot get here with Kdiff<=4
my $rtc = $self->[_rtype_count_by_seqno_]->{$seqno_signature};
next if ( $rtc && $rtc->{','} );
}
# Yes .. this is a possible nesting pair.
# They can be separated by a small amount.
my $K_diff = $K_inner_opening - $K_outer_opening;
# Count the number of nonblank characters separating them.
# Note: the $nonblank_count includes the inner opening container
# but not the outer opening container, so it will be >= 1.
if ( $K_diff < 0 ) {
# Shouldn't happen
DEVEL_MODE
&& Fault(
"unexpected negative index diff=$K_diff = Kio-Koo =$K_inner_opening - $K_outer_opening"
);
next;
}
my $nonblank_count = 0;
my $type;
my $is_name;
# Here is an example of a long identifier chain which counts as a
# single nonblank here (this spans about 10 K indexes):
# if ( !Boucherot::SetOfConnections->new->handler->execute(
# ^--K_o_o ^--K_i_o
# @array) )
my $Kn_first = $K_outer_opening;
my $Kn_last_nonblank;
my $saw_comment;
foreach my $Kn ( $K_outer_opening + 1 .. $K_inner_opening ) {
next if ( $rLL->[$Kn]->[_TYPE_] eq 'b' );
if ( !$nonblank_count ) { $Kn_first = $Kn }
if ( $Kn eq $K_inner_opening ) { $nonblank_count++; last; }
$Kn_last_nonblank = $Kn;
# skip chain of identifier tokens
my $last_type = $type;
my $last_is_name = $is_name;
$type = $rLL->[$Kn]->[_TYPE_];
if ( $type eq '#' ) { $saw_comment = 1; last }
$is_name = $is_name_type->{$type};
next if ( $is_name && $last_is_name );
# do not count a possible leading - of bareword hash key
next if ( $type eq 'm' && !$last_type );
$nonblank_count++;
last if ( $nonblank_count > 2 );
}
# Do not weld across a comment .. fix for c058.
next if ($saw_comment);
# Patch for b1104: do not weld to a paren preceded by sort/map/grep
# because the special line break rules may cause a blinking state
if ( defined($Kn_last_nonblank)
&& $rLL->[$K_inner_opening]->[_TOKEN_] eq '('
&& $rLL->[$Kn_last_nonblank]->[_TYPE_] eq 'k' )
{
my $token = $rLL->[$Kn_last_nonblank]->[_TOKEN_];
# Turn off welding at sort/map/grep (
if ( $is_sort_map_grep{$token} ) { $nonblank_count = 10 }
}
my $token_oo = $rLL->[$K_outer_opening]->[_TOKEN_];
if (
# 1: adjacent opening containers, like: do {{
$nonblank_count == 1
# 2. anonymous sub + prototype or sig: )->then( sub ($code) {
# ... but it seems best not to stack two structural blocks, like
# this
# sub make_anon_with_my_sub { sub {
# because it probably hides the structure a little too much.
|| ( $inner_blocktype
&& $inner_blocktype eq 'sub'
&& $rLL->[$Kn_first]->[_TOKEN_] eq 'sub'
&& !$outer_blocktype )
# 3. short item following opening paren, like: fun( yyy (
|| $nonblank_count == 2 && $token_oo eq '('
# 4. weld around fat commas, if requested (git #108), such as
# elf->call_method( method_name_foo => {
|| ( $type eq '=>'
&& $nonblank_count <= 3
&& %weld_fat_comma_rules
&& $weld_fat_comma_rules{$token_oo} )
)
{
push @nested_pairs,
[ $inner_seqno, $outer_seqno, $K_inner_closing ];
}
next;
}
#------------------------------------
# Make the final list of nested pairs
#------------------------------------
# The weld routine expects the pairs in order in the form
# [$seqno_inner, $seqno_outer]
# And they must be in the same order as the inner closing tokens
# (otherwise, welds of three or more adjacent tokens will not work). The K
# value of this inner closing token has temporarily been stored for
# sorting.
@nested_pairs =
# Drop the K index after sorting (it would cause trouble downstream)
map { [ $_->[0], $_->[1] ] }
# Sort on the K values
sort { $a->[2] <=> $b->[2] } @nested_pairs;
return \@nested_pairs;
} ## end sub find_nested_pairs
sub match_paren_control_flag {
my ( $self, $seqno, $flag, ($rLL) ) = @_;
# Input parameters:
# $seqno = sequence number of the container (should be paren)
# $flag = the flag which defines what matches
# $rLL = an optional alternate token list needed for respace operations
# Decide if this paren is excluded by user request:
# undef matches no parens
# '*' matches all parens
# 'k' matches only if the previous nonblank token is a perl builtin
# keyword (such as 'if', 'while'),
# 'K' matches if 'k' does not, meaning if the previous token is not a
# keyword.
# 'f' matches if the previous token is a function other than a keyword.
# 'F' matches if 'f' does not.
# 'w' matches if either 'k' or 'f' match.
# 'W' matches if 'w' does not.
$rLL = $self->[_rLL_] unless ( defined($rLL) );
return 0 unless ( defined($flag) );
return 0 if $flag eq '0';
return 1 if $flag eq '1';
return 1 if $flag eq '*';
return 0 unless ($seqno);
my $K_opening = $self->[_K_opening_container_]->{$seqno};
return unless ( defined($K_opening) );
my ( $is_f, $is_k, $is_w );
my $Kp = $self->K_previous_nonblank( $K_opening, $rLL );
if ( defined($Kp) ) {
my $type_p = $rLL->[$Kp]->[_TYPE_];
# keyword?
$is_k = $type_p eq 'k';
# function call?
$is_f = $self->[_ris_function_call_paren_]->{$seqno};
# either keyword or function call?
$is_w = $is_k || $is_f;
}
my $match;
if ( $flag eq 'k' ) { $match = $is_k }
elsif ( $flag eq 'K' ) { $match = !$is_k }
elsif ( $flag eq 'f' ) { $match = $is_f }
elsif ( $flag eq 'F' ) { $match = !$is_f }
elsif ( $flag eq 'w' ) { $match = $is_w }
elsif ( $flag eq 'W' ) { $match = !$is_w }
else {
## no match
DEVEL_MODE && Fault(<[_rLL_];
my $rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
my $rflags = $weld_nested_exclusion_rules{$token};
return 0 unless ( defined($rflags) );
my $flag = $is_leading ? $rflags->[0] : $rflags->[1];
return 0 unless ( defined($flag) );
return 1 if $flag eq '*';
my $seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
return $self->match_paren_control_flag( $seqno, $flag );
} ## end sub is_excluded_weld
# hashes to simplify welding logic
my %type_ok_after_bareword;
my %has_tight_paren;
BEGIN {
# types needed for welding RULE 6
my @q = qw# => -> { ( [ #;
@type_ok_after_bareword{@q} = (1) x scalar(@q);
# these types do not 'like' to be separated from a following paren
@q = qw( w i q Q G C Z U );
@has_tight_paren{@q} = (1) x scalar(@q);
} ## end BEGIN
use constant DEBUG_WELD => 0;
sub setup_new_weld_measurements {
my ( $self, $Kouter_opening, $Kinner_opening ) = @_;
# Define quantities to check for excess line lengths when welded.
# Called by sub 'weld_nested_containers' and sub 'weld_nested_quotes'
# Given:
# ($Kouter_opening, $Kinner_opening) = indexes of outer and inner opening
# containers to be welded
# Returns these variables:
# $new_weld_ok = true (new weld ok) or false (do not start new weld)
# $starting_indent = starting indentation
# $starting_lentot = starting cumulative length
# $msg = diagnostic message for debugging
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $rK_next_seqno_by_K = $self->[_rK_next_seqno_by_K_];
my $starting_level;
my $starting_ci;
my $starting_lentot;
my $maximum_text_length;
my $msg = EMPTY_STRING;
my $iline_oo = $rLL->[$Kouter_opening]->[_LINE_INDEX_];
my $rK_range = $rlines->[$iline_oo]->{_rK_range};
my ( $Kfirst, $Klast_uu ) = @{$rK_range};
#-------------------------------------------------------------------------
# We now define a reference index, '$Kref', from which to start measuring
# This choice turns out to be critical for keeping welds stable during
# iterations, so we go through a number of STEPS...
#-------------------------------------------------------------------------
# STEP 1: Our starting guess is to use measure from the first token of the
# current line. This is usually a good guess.
my $Kref = $Kfirst;
# STEP 2: See if we should go back a little farther
my $Kprev = $self->K_previous_nonblank($Kfirst);
if ( defined($Kprev) ) {
# Avoid measuring from between an opening paren and a previous token
# which should stay close to it ... fixes b1185
my $token_oo = $rLL->[$Kouter_opening]->[_TOKEN_];
my $type_prev = $rLL->[$Kprev]->[_TYPE_];
if ( $Kouter_opening == $Kfirst
&& $token_oo eq '('
&& $has_tight_paren{$type_prev} )
{
$Kref = $Kprev;
}
# Back up and count length from a token like '=' or '=>' if -lp
# is used (this fixes b520)
# ...or if a break is wanted before there
elsif ($rOpts_line_up_parentheses
|| $want_break_before{$type_prev} )
{
# If there are other sequence items between the start of this line
# and the opening token in question, then do not include tokens on
# the previous line in length calculations. This check added to
# fix case b1174 which had a '?' on the line
my $no_previous_seq_item = $Kref == $Kouter_opening
|| $rK_next_seqno_by_K->[$Kref] == $Kouter_opening;
if ( $no_previous_seq_item
&& substr( $type_prev, 0, 1 ) eq '=' )
{
$Kref = $Kprev;
# Fix for b1144 and b1112: backup to the first nonblank
# character before the =>, or to the start of its line.
if ( $type_prev eq '=>' ) {
my $iline_prev = $rLL->[$Kprev]->[_LINE_INDEX_];
my $rK_range_prev = $rlines->[$iline_prev]->{_rK_range};
my ( $Kfirst_prev, $Klast_prev_uu ) = @{$rK_range_prev};
my $nb_count = 0;
foreach my $KK ( reverse( $Kfirst_prev .. $Kref - 1 ) ) {
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
$Kref = $KK;
# Continue at type 'w' to get previous dash. Example:
# -classification => [ qw(
# This fixes b1502.
last if ( $nb_count || $rLL->[$KK]->[_TYPE_] ne 'w' );
$nb_count++;
}
}
}
}
else {
# do not need to backup
}
}
# STEP 3: Now look ahead for a ternary and, if found, use it.
# This fixes case b1182.
# Also look for a ')' at the same level and, if found, use it.
# This fixes case b1224.
if ( $Kref < $Kouter_opening ) {
my $Knext = $rK_next_seqno_by_K->[$Kref];
my $level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
my $Knext_last = $Knext;
while ( $Knext && $Knext < $Kouter_opening ) {
if ( $rLL->[$Knext]->[_LEVEL_] == $level_oo ) {
if ( $is_ternary{ $rLL->[$Knext]->[_TYPE_] }
|| $rLL->[$Knext]->[_TOKEN_] eq ')' )
{
$Kref = $Knext;
last;
}
}
$Knext = $rK_next_seqno_by_K->[$Knext];
if ( $Knext <= $Knext_last ) {
## shouldn't happen: $rK_next_seqno_by_K is corrupted
DEVEL_MODE && Fault(<= Knext=$Knext
EOM
last;
}
$Knext_last = $Knext;
} ## end while ( $Knext && $Knext ...)
}
# fix c1468 - do not measure from a leading opening block brace -
# which is not a one-line block
if ( $Kref < $Kouter_opening
&& $Kref == $Kfirst
&& $rLL->[$Kref]->[_TOKEN_] eq '{' )
{
my $seqno_ref = $rLL->[$Kref]->[_TYPE_SEQUENCE_];
if ($seqno_ref) {
my $block_type = $self->[_rblock_type_of_seqno_]->{$seqno_ref};
if ($block_type) {
my $Kref_c = $self->[_K_closing_container_]->{$seqno_ref};
my $ln_ref_o = $rLL->[$Kref]->[_LINE_INDEX_];
my $ln_ref_c = $rLL->[$Kref_c]->[_LINE_INDEX_];
if ( $ln_ref_c > $ln_ref_o ) {
$Kref = $self->K_next_nonblank($Kref);
}
}
}
}
# Define the starting measurements we will need
$starting_lentot =
$Kref <= 0 ? 0 : $rLL->[ $Kref - 1 ]->[_CUMULATIVE_LENGTH_];
$starting_level = $rLL->[$Kref]->[_LEVEL_];
$starting_ci = $rLL->[$Kref]->[_CI_LEVEL_];
$maximum_text_length = $maximum_text_length_at_level[$starting_level] -
$starting_ci * $rOpts_continuation_indentation;
# STEP 4: Switch to using the outer opening token as the reference
# point if a line break before it would make a longer line.
# Fixes case b1055 and is also an alternate fix for b1065.
my $starting_level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
if ( $Kref < $Kouter_opening ) {
my $starting_ci_oo = $rLL->[$Kouter_opening]->[_CI_LEVEL_];
my $lentot_oo = $rLL->[ $Kouter_opening - 1 ]->[_CUMULATIVE_LENGTH_];
my $maximum_text_length_oo =
$maximum_text_length_at_level[$starting_level_oo] -
$starting_ci_oo * $rOpts_continuation_indentation;
# The excess length to any cumulative length K = lenK is either
# $excess = $lenk - ($lentot + $maximum_text_length), or
# $excess = $lenk - ($lentot_oo + $maximum_text_length_oo),
# so the worst case (maximum excess) corresponds to the configuration
# with minimum value of the sum: $lentot + $maximum_text_length
if ( $lentot_oo + $maximum_text_length_oo <
$starting_lentot + $maximum_text_length )
{
$Kref = $Kouter_opening;
$starting_level = $starting_level_oo;
$starting_ci = $starting_ci_oo;
$starting_lentot = $lentot_oo;
$maximum_text_length = $maximum_text_length_oo;
}
}
my $new_weld_ok = 1;
# STEP 5, fix b1020: Avoid problem areas with the -wn -lp combination. The
# combination -wn -lp -dws -naws does not work well and can cause blinkers.
# It will probably only occur in stress testing. For this situation we
# will only start a new weld if we start at a 'good' location.
# - Added 'if' to fix case b1032.
# - Require blank before certain previous characters to fix b1111.
# - Add ';' to fix case b1139
# - Convert from '$ok_to_weld' to '$new_weld_ok' to fix b1162.
# - relaxed constraints for b1227
# - added skip if type is 'q' for b1349 and b1350 b1351 b1352 b1353
# - added skip if type is 'Q' for b1447
if ( $starting_ci
&& $rOpts_line_up_parentheses
&& $rOpts_delete_old_whitespace
&& !$rOpts_add_whitespace
&& $rLL->[$Kinner_opening]->[_TYPE_] ne 'q'
&& $rLL->[$Kinner_opening]->[_TYPE_] ne 'Q'
&& defined($Kprev) )
{
my $type_first = $rLL->[$Kfirst]->[_TYPE_];
my $token_first = $rLL->[$Kfirst]->[_TOKEN_];
my $type_prev = $rLL->[$Kprev]->[_TYPE_];
my $type_pp = 'b';
if ( $Kprev >= 0 ) { $type_pp = $rLL->[ $Kprev - 1 ]->[_TYPE_] }
my $is_good_location =
$type_prev =~ /^[\,\.\;]/
|| ( $type_prev =~ /^[=\{\[\(\L]/
&& ( $type_pp eq 'b' || $type_pp eq '}' || $type_first eq 'k' ) )
|| $type_first =~ /^[=\,\.\;\{\[\(\L]/
|| $type_first eq '||'
|| (
$type_first eq 'k'
&& ( $token_first eq 'if'
|| $token_first eq 'or' )
);
if ( !$is_good_location ) {
$msg =
"Skipping weld: poor break with -lp and ci at type_first='$type_first' type_prev='$type_prev' type_pp=$type_pp\n";
$new_weld_ok = 0;
}
}
return ( $new_weld_ok, $maximum_text_length, $starting_lentot, $msg );
} ## end sub setup_new_weld_measurements
sub excess_line_length_for_Krange {
my ( $self, $Kfirst, $Klast ) = @_;
# returns $excess_length =
# by how many characters a line composed of tokens $Kfirst .. $Klast will
# exceed the allowed line length
my $rLL = $self->[_rLL_];
my $length_before_Kfirst =
$Kfirst <= 0
? 0
: $rLL->[ $Kfirst - 1 ]->[_CUMULATIVE_LENGTH_];
# backup before a side comment if necessary
my $Kend = $Klast;
if ( $rOpts_ignore_side_comment_lengths
&& $rLL->[$Klast]->[_TYPE_] eq '#' )
{
my $Kprev = $self->K_previous_nonblank($Klast);
if ( defined($Kprev) && $Kprev >= $Kfirst ) { $Kend = $Kprev }
}
# get the length of the text
my $length = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] - $length_before_Kfirst;
# get the size of the text window
my $level = $rLL->[$Kfirst]->[_LEVEL_];
my $ci_level = $rLL->[$Kfirst]->[_CI_LEVEL_];
my $max_text_length = $maximum_text_length_at_level[$level] -
$ci_level * $rOpts_continuation_indentation;
my $excess_length = $length - $max_text_length;
DEBUG_WELD
&& print
"Kfirst=$Kfirst, Klast=$Klast, Kend=$Kend, level=$level, ci=$ci_level, max_text_length=$max_text_length, length=$length\n";
return ($excess_length);
} ## end sub excess_line_length_for_Krange
sub weld_nested_containers {
my ($self) = @_;
# Called once per file for option '--weld-nested-containers'
my $rK_weld_left = $self->[_rK_weld_left_];
my $rK_weld_right = $self->[_rK_weld_right_];
# 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 $rlines = $self->[_rlines_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rK_next_seqno_by_K = $self->[_rK_next_seqno_by_K_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_asub_block = $self->[_ris_asub_block_];
my $rmax_vertical_tightness = $self->[_rmax_vertical_tightness_];
my $rOpts_asbl = $rOpts->{'opening-anonymous-sub-brace-on-new-line'};
# Find nested pairs of container tokens for any welding.
my $rnested_pairs = $self->find_nested_pairs();
# Return unless there are nested pairs to weld
return unless ( defined($rnested_pairs) && @{$rnested_pairs} );
# NOTE: It would be nice to apply RULE 5 right here by deleting unwanted
# pairs. But it isn't clear if this is possible because we don't know
# which sequences might actually start a weld.
my $rOpts_break_at_old_method_breakpoints =
$rOpts->{'break-at-old-method-breakpoints'};
# This array will hold the sequence numbers of the tokens to be welded.
my @welds;
# Variables needed for estimating line lengths
my $maximum_text_length; # maximum spaces available for text
my $starting_lentot; # cumulative text to start of current line
my $iline_outer_opening = -1;
my $weld_count_this_start = 0;
my $weld_starts_in_block = 0;
# OLD: $single_line_tol added to fix cases b1180 b1181
# = $rOpts_continuation_indentation > $rOpts_indent_columns ? 1 : 0;
# NEW: $single_line_tol=0 fixes b1212; and b1180-1181 work ok now
# =1 for -vmll and -lp; fixes b1452, b1453, b1454
# NOTE: the combination -vmll and -lp can be unstable, especially when
# also combined with -wn. It may eventually be necessary to turn off -vmll
# if -lp is set. For now, this works. The value '1' is a minimum which
# works but can be increased if necessary.
my $single_line_tol =
$rOpts_variable_maximum_line_length && $rOpts_line_up_parentheses
? 1
: 0;
my $multiline_tol = $single_line_tol + 1 +
max( $rOpts_indent_columns, $rOpts_continuation_indentation );
# Define a welding cutoff level: do not start a weld if the inside
# container level equals or exceeds this level.
# We use the minimum of two criteria, either of which may be more
# restrictive. The 'alpha' value is more restrictive in (b1206, b1252) and
# the 'beta' value is more restrictive in other cases (b1243).
# Reduced beta term from beta+3 to beta+2 to fix b1401. Previously:
# my $weld_cutoff_level = min($stress_level_alpha, $stress_level_beta + 2);
# This is now '$high_stress_level'.
# The vertical tightness flags can throw off line length calculations.
# This patch was added to fix instability issue b1284.
# It works to always use a tol of 1 for 1 line block length tests, but
# this restricted value keeps test case wn6.wn working as before.
# It may be necessary to include '[' and '{' here in the future.
my $one_line_tol = $opening_vertical_tightness{'('} ? 1 : 0;
# 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;
# Main loop over nested pairs...
# We are working from outermost to innermost pairs so that
# level changes will be complete when we arrive at the inner pairs.
while ( @{$rnested_pairs} ) {
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};
# RULE: do not weld if inner container has <= 3 tokens unless the next
# token is a heredoc (so we know there will be multiple lines)
if ( $Kinner_closing - $Kinner_opening <= 4 ) {
my $Knext_nonblank = $self->K_next_nonblank($Kinner_opening);
next unless defined($Knext_nonblank);
my $type = $rLL->[$Knext_nonblank]->[_TYPE_];
next unless ( $type eq 'h' );
}
my $outer_opening = $rLL->[$Kouter_opening];
my $inner_opening = $rLL->[$Kinner_opening];
my $outer_closing = $rLL->[$Kouter_closing];
my $inner_closing = $rLL->[$Kinner_closing];
# RULE: do not weld to a hash brace. The reason is that it has a very
# strong bond strength to the next token, so a line break after it
# may not work. Previously we allowed welding to something like @{
# but that caused blinking states (cases b751, b779).
if ( $inner_opening->[_TYPE_] eq 'L' ) {
next;
}
# RULE: do not weld to a square bracket which does not contain commas
if ( $inner_opening->[_TYPE_] eq '[' ) {
my $rtype_count = $self->[_rtype_count_by_seqno_]->{$inner_seqno};
next unless ( $rtype_count && $rtype_count->{','} );
# Do not weld if there is text before a '[' such as here:
# curr_opt ( @beg [2,5] )
# It will not break into the desired sandwich structure.
# This fixes case b109, 110.
my $Kdiff = $Kinner_opening - $Kouter_opening;
next if ( $Kdiff > 2 );
next
if ( $Kdiff == 2
&& $rLL->[ $Kouter_opening + 1 ]->[_TYPE_] ne 'b' );
}
# RULE: Avoid welding under stress. The idea is that we need to have a
# little space* within a welded container to avoid instability. Note
# that after each weld the level values are reduced, so long multiple
# welds can still be made. This rule will seldom be a limiting factor
# in actual working code. Fixes b1206, b1243.
my $inner_level = $inner_opening->[_LEVEL_];
if ( $inner_level >= $high_stress_level ) { next }
# extra tolerance added under high stress to fix b1481
my $stress_tol = ( $high_stress_level - $inner_level <= 1 ) ? 1 : 0;
# 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;
my $do_not_weld_rule = 0;
my $Msg = EMPTY_STRING;
my $is_one_line_weld;
my $iline_oo = $outer_opening->[_LINE_INDEX_];
my $iline_io = $inner_opening->[_LINE_INDEX_];
my $iline_ic = $inner_closing->[_LINE_INDEX_];
my $iline_oc = $outer_closing->[_LINE_INDEX_];
my $token_oo = $outer_opening->[_TOKEN_];
my $token_io = $inner_opening->[_TOKEN_];
# DO-NOT-WELD RULE 7: Do not weld if this conflicts with -bom
# Added for case b973. Moved here from below to fix b1423.
if ( !$do_not_weld_rule
&& $rOpts_break_at_old_method_breakpoints
&& $iline_io > $iline_oo )
{
foreach my $iline ( $iline_oo + 1 .. $iline_io ) {
my $rK_range = $rlines->[$iline]->{_rK_range};
next unless defined($rK_range);
my ( $Kfirst, $Klast_uu ) = @{$rK_range};
next unless defined($Kfirst);
if ( $rLL->[$Kfirst]->[_TYPE_] eq '->' ) {
$do_not_weld_rule = 7;
last;
}
}
}
next if ($do_not_weld_rule);
# Turn off vertical tightness at possible one-line welds. Fixes b1402,
# b1419, b1421, b1424, b1425. This also fixes issues b1338, b1339,
# b1340, b1341, b1342, b1343, which previously used a separate fix.
# Issue c161 is the latest and simplest check, using
# $iline_ic==$iline_io as the test.
if ( %opening_vertical_tightness
&& $iline_ic == $iline_io
&& $opening_vertical_tightness{$token_oo} )
{
$rmax_vertical_tightness->{$outer_seqno} = 0;
}
my $is_multiline_weld =
$iline_oo == $iline_io
&& $iline_ic == $iline_oc
&& $iline_io != $iline_ic;
if (DEBUG_WELD) {
my $len_oo = $rLL->[$Kouter_opening]->[_CUMULATIVE_LENGTH_];
my $len_io = $rLL->[$Kinner_opening]->[_CUMULATIVE_LENGTH_];
$Msg .= < $iline_outer_opening )
)
{
# Remember the line we are using as a reference
$iline_outer_opening = $iline_oo;
$weld_count_this_start = 0;
$weld_starts_in_block = 0;
( my $new_weld_ok, $maximum_text_length, $starting_lentot, my $msg )
= $self->setup_new_weld_measurements( $Kouter_opening,
$Kinner_opening );
if (
!$new_weld_ok
&& ( $iline_oo != $iline_io
|| $iline_ic != $iline_oc )
)
{
if (DEBUG_WELD) { print {*STDOUT} $msg }
next;
}
my $rK_range = $rlines->[$iline_oo]->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
# An existing one-line weld is a line in which
# (1) the containers are all on one line, and
# (2) the line does not exceed the allowable length
if ( $iline_oo == $iline_oc ) {
# All the tokens are on one line, now check their length.
# Start with the full line index range. We will reduce this
# in the coding below in some cases.
my $Kstart = $Kfirst;
my $Kstop = $Klast;
# Note that the following minimal choice for measuring will
# work and will not cause any instabilities because it is
# invariant:
## my $Kstart = $Kouter_opening;
## my $Kstop = $Kouter_closing;
# But that can lead to some undesirable welds. So a little
# more complicated method has been developed.
# We are trying to avoid creating bad two-line welds when we are
# working on long, previously un-welded input text, such as
# INPUT (example of a long input line weld candidate):
## $mutation->transpos( $self->RNA->position($mutation->label, $atg_label));
# GOOD two-line break: (not welded; result marked too long):
## $mutation->transpos(
## $self->RNA->position($mutation->label, $atg_label));
# BAD two-line break: (welded; result if we weld):
## $mutation->transpos($self->RNA->position(
## $mutation->label, $atg_label));
# We can only get an approximate estimate of the final length,
# since the line breaks may change, and for -lp mode because
# even the indentation is not yet known.
my $level_first = $rLL->[$Kfirst]->[_LEVEL_];
my $level_last = $rLL->[$Klast]->[_LEVEL_];
my $level_oo = $rLL->[$Kouter_opening]->[_LEVEL_];
my $level_oc = $rLL->[$Kouter_closing]->[_LEVEL_];
# - measure to the end of the original line if balanced
# - measure to the closing container if unbalanced (fixes b1230)
#if ( $level_first != $level_last ) { $Kstop = $Kouter_closing }
if ( $level_oc > $level_last ) { $Kstop = $Kouter_closing }
# - measure from the start of the original line if balanced
# - measure from the most previous token with same level
# if unbalanced (b1232)
if ( $Kouter_opening > $Kfirst && $level_oo > $level_first ) {
$Kstart = $Kouter_opening;
foreach
my $KK ( reverse( $Kfirst + 1 .. $Kouter_opening - 1 ) )
{
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
last if ( $rLL->[$KK]->[_LEVEL_] < $level_oo );
$Kstart = $KK;
}
}
my $excess =
$self->excess_line_length_for_Krange( $Kstart, $Kstop );
# Coding simplified here for case b1219.
# Increased tol from 0 to 1 when pvt>0 to fix b1284.
$is_one_line_weld = $excess <= $one_line_tol;
}
# 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'. 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.") );
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 = $rK_next_seqno_by_K->[$Kinner_opening];
if ( $Knext_seq_item == $Kinner_closing ) {
$do_not_weld_rule = 1;
}
}
}
} ## end starting new weld sequence
else {
# set the 1-line flag if continuing a weld sequence; fixes b1239
$is_one_line_weld = ( $iline_oo == $iline_oc );
}
# 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]->();
# } );
# Updated to fix cases b1082 b1102 b1106 b1115:
# Also, do not weld to an intact inner block if the outer opening token
# is on a different line. For example, this prevents oscillation
# between these two states in case b1106:
# return map{
# ($_,[$self->$_(@_[1..$#_])])
# }@every;
# return map { (
# $_, [ $self->$_( @_[ 1 .. $#_ ] ) ]
# ) } @every;
# The effect of this change on typical code is very minimal. Sometimes
# it may take a second iteration to converge, but this gives protection
# against blinking.
if ( !$do_not_weld_rule
&& !$is_one_line_weld
&& $iline_ic == $iline_io )
{
$do_not_weld_rule = 2
if ( $token_oo eq '(' || $iline_oo != $iline_io );
}
# DO-NOT-WELD RULE 2A:
# Do not weld an opening asub brace in -lp mode if -asbl is set. This
# helps avoid instabilities in one-line block formation, and fixes
# b1241. Previously, the '$is_one_line_weld' flag was tested here
# instead of -asbl, and this fixed most cases. But it turns out that
# the real problem was the -asbl flag, and switching to this was
# necessary to fixe b1268. This also fixes b1269, b1277, b1278.
if ( !$do_not_weld_rule
&& $rOpts_line_up_parentheses
&& $rOpts_asbl
&& $ris_asub_block->{$outer_seqno} )
{
$do_not_weld_rule = '2A';
}
# DO-NOT-WELD RULE 3:
# Do not weld if this makes our line too long.
# Use a tolerance which depends on if the old tokens were welded
# (fixes cases b746 b748 b749 b750 b752 b753 b754 b755 b756 b758 b759)
if ( !$do_not_weld_rule ) {
# Measure to a little beyond the inner opening token if it is
# followed by a bare word, which may have unusual line break rules.
# NOTE: Originally this was OLD RULE 6: do not weld to a container
# which is followed on the same line by an unknown bareword token.
# This can cause blinkers (cases b626, b611). But OK to weld one
# line welds to fix cases b1057 b1064. For generality, OLD RULE 6
# has been merged into RULE 3 here to also fix cases b1078 b1091.
my $K_for_length = $Kinner_opening;
my $Knext_io = $self->K_next_nonblank($Kinner_opening);
next unless ( defined($Knext_io) ); # shouldn't happen
my $type_io_next = $rLL->[$Knext_io]->[_TYPE_];
# Note: may need to eventually also include other types here,
# such as 'Z' and 'Y': if ($type_io_next =~ /^[ZYw]$/) {
if ( $type_io_next eq 'w' ) {
my $Knext_io2 = $self->K_next_nonblank($Knext_io);
next unless ( defined($Knext_io2) );
my $type_io_next2 = $rLL->[$Knext_io2]->[_TYPE_];
if ( !$type_ok_after_bareword{$type_io_next2} ) {
$K_for_length = $Knext_io2;
}
}
# Use a tolerance for welds over multiple lines to avoid blinkers.
# We can use zero tolerance if it looks like we are working on an
# existing weld.
my $tol =
$is_one_line_weld || $is_multiline_weld
? $single_line_tol
: $multiline_tol;
$tol += $stress_tol;
# By how many characters does this exceed the text window?
my $excess =
$self->cumulative_length_before_K($K_for_length) -
$starting_lentot + 1 + $tol -
$maximum_text_length;
# Old patch: Use '>=0' instead of '> 0' here to fix cases b995 b998
# b1000 b1001 b1007 b1008 b1009 b1010 b1011 b1012 b1016 b1017 b1018
# Revised patch: New tolerance definition allows going back to '> 0'
# here. This fixes case b1124. See also cases b1087 and b1087a.
if ( $excess > 0 ) { $do_not_weld_rule = 3 }
if (DEBUG_WELD) {
$Msg .=
"RULE 3 test: excess length to K=$Kinner_opening is $excess > 0 with tol= $tol ?) \n";
}
}
# 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 ( !$do_not_weld_rule && $rOpts->{'cuddled-else'} ) {
my $block_type = $rblock_type_of_seqno->{$outer_seqno};
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_];
if ( $oo_line < $io_line && $ic_line == $io_line ) {
$do_not_weld_rule = 4;
}
}
}
# DO-NOT-WELD RULE 5: do not include welds excluded by user
if (
!$do_not_weld_rule
&& %weld_nested_exclusion_rules
&& ( $self->is_excluded_weld( $Kouter_opening, $starting_new_weld )
|| $self->is_excluded_weld( $Kinner_opening, 0 ) )
)
{
$do_not_weld_rule = 5;
}
# DO-NOT-WELD RULE 6: This has been merged into RULE 3 above.
if ($do_not_weld_rule) {
# After neglecting a pair, we start measuring from start of point
# io ... but not if previous type does not like to be separated
# from its container (fixes case b1184)
my $Kprev = $self->K_previous_nonblank($Kinner_opening);
my $type_prev = defined($Kprev) ? $rLL->[$Kprev]->[_TYPE_] : 'w';
if ( !$has_tight_paren{$type_prev} ) {
my $starting_level = $inner_opening->[_LEVEL_];
my $starting_ci_level = $inner_opening->[_CI_LEVEL_];
$starting_lentot =
$self->cumulative_length_before_K($Kinner_opening);
$maximum_text_length =
$maximum_text_length_at_level[$starting_level] -
$starting_ci_level * $rOpts_continuation_indentation;
}
if (DEBUG_WELD) {
$Msg .= "Not welding due to RULE $do_not_weld_rule\n";
print {*STDOUT} $Msg;
}
# 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) {
$weld_count_this_start++;
if (DEBUG_WELD) {
$Msg .= "Starting new weld\n";
print {*STDOUT} $Msg;
}
push @welds, $item;
my $parent_seqno = $self->parent_seqno_by_K($Kouter_closing);
$weld_starts_in_block = $parent_seqno == SEQ_ROOT
|| $rblock_type_of_seqno->{$parent_seqno};
$rK_weld_right->{$Kouter_opening} = $Kinner_opening;
$rK_weld_left->{$Kinner_opening} = $Kouter_opening;
$rK_weld_right->{$Kinner_closing} = $Kouter_closing;
$rK_weld_left->{$Kouter_closing} = $Kinner_closing;
}
# ... or extend current weld
else {
$weld_count_this_start++;
if (DEBUG_WELD) {
$Msg .= "Extending current weld\n";
print {*STDOUT} $Msg;
}
unshift @{ $welds[-1] }, $inner_seqno;
$rK_weld_right->{$Kouter_opening} = $Kinner_opening;
$rK_weld_left->{$Kinner_opening} = $Kouter_opening;
$rK_weld_right->{$Kinner_closing} = $Kouter_closing;
$rK_weld_left->{$Kouter_closing} = $Kinner_closing;
# Keep a broken container broken at multiple welds. This might
# also be useful for simple welds, but for now it is restricted
# to multiple welds to minimize changes to existing coding. This
# fixes b1429, b1430. Updated for issue c198: but allow a
# line differences of 1 (simple shear) so that a simple shear
# can remain or become a single line.
if ( $iline_ic - $iline_io > 1 ) {
# Only set this break if it is the last possible weld in this
# chain. This will keep some extreme test cases unchanged.
my $is_chain_end = !@{$rnested_pairs}
|| $rnested_pairs->[-1]->[1] != $inner_seqno;
if ($is_chain_end) {
$self->[_rbreak_container_]->{$inner_seqno} = 1;
}
}
}
# 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;
foreach my $KK ( $Kstart .. $Kstop ) {
$rLL->[$KK]->[_LEVEL_] += $dlevel;
}
# Copy opening ci level to help break at = for -lp mode (case b1124)
$rLL->[$Kinner_opening]->[_CI_LEVEL_] =
$rLL->[$Kouter_opening]->[_CI_LEVEL_];
# But only copy the closing ci level if the outer container is
# in a block; otherwise poor results can be produced.
if ($weld_starts_in_block) {
$rLL->[$Kinner_closing]->[_CI_LEVEL_] =
$rLL->[$Kouter_closing]->[_CI_LEVEL_];
}
}
} ## end while ( @{$rnested_pairs})
return;
} ## end sub weld_nested_containers
sub weld_nested_quotes {
my $self = shift;
# Called once per file for option '--weld-nested-containers'. This
# does welding on qw quotes.
# See if quotes are excluded from welding
my $rflags = $weld_nested_exclusion_rules{'q'};
return if ( defined($rflags) && defined( $rflags->[1] ) );
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $Num = @{$rLL};
my $rK_weld_left = $self->[_rK_weld_left_];
my $rK_weld_right = $self->[_rK_weld_right_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rlines = $self->[_rlines_];
my $starting_lentot;
my $maximum_text_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;
}; ## end $is_single_quote = sub
# Length tolerance - same as previously used for sub weld_nested
my $multiline_tol =
1 + max( $rOpts_indent_columns, $rOpts_continuation_indentation );
# look for single qw quotes nested in containers
foreach my $outer_seqno ( keys %{$K_opening_container} ) {
my $Kouter_opening = $K_opening_container->{$outer_seqno};
# see if the next token is a quote of some type
my $Kn = $Kouter_opening + 1;
next if ( $Kn >= $Num - 1 );
my $next_type = $rLL->[$Kn]->[_TYPE_];
if ( $next_type eq 'b' ) {
$next_type = $rLL->[ ++$Kn ]->[_TYPE_];
}
next if ( $next_type ne 'q' && $next_type ne 'Q' );
my $next_token = $rLL->[$Kn]->[_TOKEN_];
next if ( substr( $next_token, 0, 1 ) ne 'q' );
# The token before the closing container must also be a quote
my $Kouter_closing = $K_closing_container->{$outer_seqno};
my $Kinner_closing = $self->K_previous_nonblank($Kouter_closing);
next unless ( $rLL->[$Kinner_closing]->[_TYPE_] eq $next_type );
# This is an inner opening container
my $Kinner_opening = $Kn;
# Do not weld to single-line quotes. Nothing is gained, and it may
# look bad.
next if ( $Kinner_closing == $Kinner_opening );
# RULE: Avoid welding under stress. This is an alternate b1502 fix.
my $inner_level = $rLL->[$Kinner_opening]->[_LEVEL_];
if ( $inner_level >= $high_stress_level ) { next }
# 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->[$Kinner_closing]->[_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->(
$Kinner_opening + 1,
$Kinner_closing - 1,
$next_type
)
);
# OK: This is a candidate for welding
my $Msg = EMPTY_STRING;
my $do_not_weld;
my $iline_oo = $rLL->[$Kouter_opening]->[_LINE_INDEX_];
my $iline_io = $rLL->[$Kinner_opening]->[_LINE_INDEX_];
my $iline_oc = $rLL->[$Kouter_closing]->[_LINE_INDEX_];
my $iline_ic = $rLL->[$Kinner_closing]->[_LINE_INDEX_];
my $is_old_weld = ( $iline_oo == $iline_io && $iline_ic == $iline_oc );
# Fix for case b1189. If quote is marked as type 'Q' then only weld
# if the two closing tokens are on the same input line. Otherwise,
# the closing line will be output earlier in the pipeline than
# other CODE lines and welding will not actually occur. This will
# leave a half-welded structure with potential formatting
# instability. This might be fixed by adding a check for a weld on
# a closing Q token and sending it down the normal channel, but it
# would complicate the code and is potentially risky.
next
if (!$is_old_weld
&& $next_type eq 'Q'
&& $iline_ic != $iline_oc );
# If welded, the line must not exceed allowed line length
( my $ok_to_weld, $maximum_text_length, $starting_lentot, my $msg ) =
$self->setup_new_weld_measurements( $Kouter_opening,
$Kinner_opening );
if ( !$ok_to_weld ) {
if (DEBUG_WELD) { print {*STDOUT} $msg }
next;
}
my $length =
$rLL->[$Kinner_opening]->[_CUMULATIVE_LENGTH_] - $starting_lentot;
my $excess = $length + $multiline_tol - $maximum_text_length;
my $excess_max = ( $is_old_weld ? $multiline_tol : 0 );
if ( $excess >= $excess_max ) {
$do_not_weld = 1;
}
if (DEBUG_WELD) {
if ( !$is_old_weld ) { $is_old_weld = EMPTY_STRING }
$Msg .=
"excess=$excess>=$excess_max, multiline_tol=$multiline_tol, is_old_weld='$is_old_weld'\n";
}
# Check weld exclusion rules for outer container
if ( !$do_not_weld ) {
my $is_leading = !defined( $rK_weld_left->{$Kouter_opening} );
if ( $self->is_excluded_weld( $Kouter_opening, $is_leading ) ) {
if (DEBUG_WELD) {
$Msg .=
"No qw weld due to weld exclusion rules for outer container\n";
}
$do_not_weld = 1;
}
}
# Check the length of the last line (fixes case b1039)
if ( !$do_not_weld ) {
my $rK_range_ic = $rlines->[$iline_ic]->{_rK_range};
my ( $Kfirst_ic, $Klast_ic_uu ) = @{$rK_range_ic};
my $excess_ic =
$self->excess_line_length_for_Krange( $Kfirst_ic,
$Kouter_closing );
# Allow extra space for additional welded closing container(s)
# and a space and comma or semicolon.
# NOTE: weld len has not been computed yet. Use 2 spaces
# for now, correct for a single weld. This estimate could
# be made more accurate if necessary.
my $weld_len = defined( $rK_weld_right->{$Kouter_closing} ) ? 2 : 0;
if ( $excess_ic + $weld_len + 2 > 0 ) {
if (DEBUG_WELD) {
$Msg .=
"No qw weld due to excess ending line length=$excess_ic + $weld_len + 2 > 0\n";
}
$do_not_weld = 1;
}
}
if ($do_not_weld) {
if (DEBUG_WELD) {
$Msg .= "Not Welding QW\n";
print {*STDOUT} $Msg;
}
next;
}
# OK to weld
if (DEBUG_WELD) {
$Msg .= "Welding QW\n";
print {*STDOUT} $Msg;
}
$rK_weld_right->{$Kouter_opening} = $Kinner_opening;
$rK_weld_left->{$Kinner_opening} = $Kouter_opening;
$rK_weld_right->{$Kinner_closing} = $Kouter_closing;
$rK_weld_left->{$Kouter_closing} = $Kinner_closing;
# Undo one indentation level if an extra level was added to this
# multiline quote
my $qw_seqno =
$self->[_rstarting_multiline_qw_seqno_by_K_]->{$Kinner_opening};
if ( $qw_seqno
&& $self->[_rmultiline_qw_has_extra_level_]->{$qw_seqno} )
{
foreach my $K ( $Kinner_opening + 1 .. $Kinner_closing - 1 ) {
$rLL->[$K]->[_LEVEL_] -= 1;
}
$rLL->[$Kinner_opening]->[_CI_LEVEL_] = 0;
$rLL->[$Kinner_closing]->[_CI_LEVEL_] = 0;
}
# undo CI for other welded quotes
else {
foreach my $K ( $Kinner_opening .. $Kinner_closing ) {
$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.
# Patch to fix c002: but not if it contains text
if ( length( $rLL->[$Kinner_closing]->[_TOKEN_] ) == 1 ) {
$rLL->[$Kinner_closing]->[_LEVEL_] =
$rLL->[$Kouter_closing]->[_LEVEL_];
}
}
return;
} ## end sub weld_nested_quotes
sub is_welded_at_seqno {
my ( $self, $seqno ) = @_;
# Given:
# $seqno = a sequence number:
# Return:
# true if it is welded either left or right
# false otherwise
return unless ( $total_weld_count && defined($seqno) );
my $KK_o = $self->[_K_opening_container_]->{$seqno};
return unless defined($KK_o);
return defined( $self->[_rK_weld_left_]->{$KK_o} )
|| defined( $self->[_rK_weld_right_]->{$KK_o} );
} ## end sub is_welded_at_seqno
sub mark_short_nested_blocks {
my $self = shift;
# 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 existence 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'
return if $rOpts->{'indent-only'};
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 $ris_broken_container = $self->[_ris_broken_container_];
my $rshort_nested = $self->[_rshort_nested_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $rK_sequenced_token_list = $self->[_rK_sequenced_token_list_];
# Variables needed for estimating line lengths
my $maximum_text_length;
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 = $length + $length_tol - $maximum_text_length;
return ($excess_length);
}; ## end $excess_length_to_K = sub
# loop over all containers
my @open_block_stack;
my $iline = -1;
foreach my $KK ( @{$rK_sequenced_token_list} ) {
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
# A fault here implies that an error was made in the little loop at
# the bottom of sub 'respace_tokens' which set the values of
# $rK_sequenced_token_list. Or an error has been introduced in the
# loop control lines above.
Fault("sequence = $type_sequence not defined at K=$KK")
if (DEVEL_MODE);
next;
}
# Patch: do not mark short blocks with welds.
# In some cases blinkers can form (case b690).
if ( $total_weld_count && $self->is_welded_at_seqno($type_sequence) ) {
next;
}
# We are just looking at code blocks
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
next unless ( $type eq $token );
next unless ( $rblock_type_of_seqno->{$type_sequence} );
# 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 ( $ris_broken_container->{$type_sequence}
|| $rbreak_container->{$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_];
my $level = $rLL->[$KK]->[_LEVEL_];
my $ci_level = $rLL->[$KK]->[_CI_LEVEL_];
$maximum_text_length =
$maximum_text_length_at_level[$level] -
$ci_level * $rOpts_continuation_indentation;
# 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 if ( @open_block_stack <= 1 );
# Looks OK, mark this as a short nested block
$rshort_nested->{$type_sequence} = 1;
}
return;
} ## end sub mark_short_nested_blocks
sub special_indentation_adjustments {
my ($self) = @_;
# Called once per file to define the levels to be used for computing
# actual indentation. These levels are initialized to be the structural
# levels and then are adjusted if necessary for special purposes.
# The adjustments are made either by changing _CI_LEVEL_ directly or
# by setting modified levels in the array $self->[_radjusted_levels_].
# NOTE: This routine is called after the weld routines, which may have
# already adjusted the initial values of _LEVEL_, so we are making
# adjustments on top of those levels. It would be nicer to have the
# weld routines also use this adjustment, but that gets complicated
# when we combine -gnu -wn and also have some welded quotes.
my $rLL = $self->[_rLL_];
return unless ( @{$rLL} );
# Initialize the adjusted levels to be the structural levels
my @adjusted_levels = map { $_->[_LEVEL_] } @{$rLL};
$self->[_radjusted_levels_] = \@adjusted_levels;
my $min_starting_level = min(@adjusted_levels);
# First set adjusted levels for any non-indenting braces.
$self->do_non_indenting_braces();
# Adjust breaks and indentation list containers
$self->break_before_list_opening_containers();
# Set adjusted levels for the whitespace cycle option.
$self->whitespace_cycle_adjustment();
$self->braces_left_setup();
# Adjust continuation indentation if -bli is set
$self->bli_adjustment();
$self->extended_ci()
if ($rOpts_extended_continuation_indentation);
# Now clip any starting or adjusted levels to be non-negative
$self->clip_adjusted_levels($min_starting_level);
return;
} ## end sub special_indentation_adjustments
sub clip_adjusted_levels {
my ( $self, $min_starting_level ) = @_;
# Replace any negative adjusted levels with zero.
# Negative levels can only occur in files with brace errors.
# Given:
# $min_starting_level = minimum (adjusted) level of the input stream
# Clip the original _LEVEL_ values to zero if necessary
my $rLL = $self->[_rLL_];
if ( $min_starting_level < 0 ) {
foreach my $item ( @{$rLL} ) {
if ( $item->[_LEVEL_] < 0 ) { $item->[_LEVEL_] = 0 }
}
}
# Clip the adjusted levels to zero if necessary
my $radjusted_levels = $self->[_radjusted_levels_];
return unless ( defined($radjusted_levels) && @{$radjusted_levels} );
my $min = min( @{$radjusted_levels} ); # fast check for min
if ( $min < 0 ) {
# slow loop, but rarely needed
foreach ( @{$radjusted_levels} ) { $_ = 0 if ( $_ < 0 ) }
}
return;
} ## end sub clip_adjusted_levels
sub do_non_indenting_braces {
my ($self) = @_;
# Called once per file to handle the --non-indenting-braces parameter.
# Remove indentation within marked braces if requested
# Any non-indenting braces have been found by sub find_non_indenting_braces
# and are defined by the following hash:
my $rseqno_non_indenting_brace_by_ix =
$self->[_rseqno_non_indenting_brace_by_ix_];
return unless ( %{$rseqno_non_indenting_brace_by_ix} );
my $rlines = $self->[_rlines_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rspecial_side_comment_type = $self->[_rspecial_side_comment_type_];
my $radjusted_levels = $self->[_radjusted_levels_];
# First locate all of the marked blocks
my @K_stack;
foreach my $ix ( keys %{$rseqno_non_indenting_brace_by_ix} ) {
my $seqno = $rseqno_non_indenting_brace_by_ix->{$ix};
my $KK = $K_opening_container->{$seqno};
my $line_of_tokens = $rlines->[$ix];
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst_uu, $Klast ) = @{$rK_range};
$rspecial_side_comment_type->{$Klast} = 'NIB';
push @K_stack, [ $KK, 1 ];
my $Kc = $K_closing_container->{$seqno};
push @K_stack, [ $Kc, -1 ] if ( defined($Kc) );
}
return unless (@K_stack);
@K_stack = sort { $a->[0] <=> $b->[0] } @K_stack;
# Then loop to remove indentation within marked blocks
my $KK_last = 0;
my $ndeep = 0;
foreach my $item (@K_stack) {
my ( $KK, $inc ) = @{$item};
if ( $ndeep > 0 ) {
foreach ( $KK_last + 1 .. $KK ) {
$radjusted_levels->[$_] -= $ndeep;
}
# We just subtracted the old $ndeep value, which only applies to a
# '{'. The new $ndeep applies to a '}', so we undo the error.
if ( $inc < 0 ) { $radjusted_levels->[$KK] += 1 }
}
$ndeep += $inc;
$KK_last = $KK;
}
return;
} ## end sub do_non_indenting_braces
sub whitespace_cycle_adjustment {
my $self = shift;
# Called once per file to implement the --whitespace-cycle option
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $radjusted_levels = $self->[_radjusted_levels_];
my $maximum_level = $self->[_maximum_level_];
if ( $rOpts_whitespace_cycle
&& $rOpts_whitespace_cycle > 0
&& $rOpts_whitespace_cycle < $maximum_level )
{
my $Kmax = @{$rLL} - 1;
my $whitespace_last_level = -1;
my @whitespace_level_stack = ();
my $last_nonblank_type = 'b';
my $last_nonblank_token = EMPTY_STRING;
foreach my $KK ( 0 .. $Kmax ) {
my $level_abs = $radjusted_levels->[$KK];
my $level = $level_abs;
if ( $level_abs < $whitespace_last_level ) {
pop(@whitespace_level_stack);
}
if ( !@whitespace_level_stack ) {
push @whitespace_level_stack, $level_abs;
}
else {
if ( $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;
}
}
}
return;
} ## end sub whitespace_cycle_adjustment
use constant DEBUG_BBX => 0;
sub break_before_list_opening_containers {
my ($self) = @_;
# This routine is called once per batch to implement parameters:
# --break-before-hash-brace=n and similar -bbx=n flags
# and their associated indentation flags:
# --break-before-hash-brace-and-indent and similar -bbxi=n
# Nothing to do if none of the -bbx=n parameters has been set
return unless %break_before_container_types;
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
# Loop over all opening container tokens
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $ris_broken_container = $self->[_ris_broken_container_];
my $ris_permanently_broken = $self->[_ris_permanently_broken_];
my $rhas_list = $self->[_rhas_list_];
my $rhas_broken_list_with_lec = $self->[_rhas_broken_list_with_lec_];
my $radjusted_levels = $self->[_radjusted_levels_];
my $rparent_of_seqno = $self->[_rparent_of_seqno_];
my $rlines = $self->[_rlines_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $rlec_count_by_seqno = $self->[_rlec_count_by_seqno_];
my $rno_xci_by_seqno = $self->[_rno_xci_by_seqno_];
my $rK_weld_right = $self->[_rK_weld_right_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $length_tol =
max( 1, $rOpts_continuation_indentation, $rOpts_indent_columns );
if ($rOpts_ignore_old_breakpoints) {
# Patch suggested by b1231; the old tol was excessive.
## $length_tol += $rOpts_maximum_line_length;
$length_tol *= 2;
}
#-------------------------------------------------------
# These arrays are used to mark the affected containers:
#-------------------------------------------------------
my $rbreak_before_container_by_seqno = {};
my $rwant_reduced_ci = {};
#------------------------------
# Main loop over all containers
#------------------------------
foreach my $seqno ( keys %{$K_opening_container} ) {
#----------------------------------------------------------------
# Part 1: Examine any -bbx=n flags
#----------------------------------------------------------------
next if ( $rblock_type_of_seqno->{$seqno} );
my $KK = $K_opening_container->{$seqno};
# This must be a list or contain a list.
# Note1: switched from 'has_broken_list' to 'has_list' to fix b1024.
# Note2: 'has_list' holds the depth to the sub-list. We will require
# a depth of just 1
my $is_list = $self->is_list_by_seqno($seqno);
my $has_list = $rhas_list->{$seqno};
# Fix for b1173: if welded opening container, use flag of innermost
# seqno. Otherwise, the restriction $has_list==1 prevents triple and
# higher welds from following the -BBX parameters.
if ($total_weld_count) {
my $KK_test = $rK_weld_right->{$KK};
if ( defined($KK_test) ) {
my $seqno_inner = $rLL->[$KK_test]->[_TYPE_SEQUENCE_];
$is_list ||= $self->is_list_by_seqno($seqno_inner);
$has_list = $rhas_list->{$seqno_inner};
}
}
next unless ( $is_list || $has_list && $has_list == 1 );
my $has_list_with_lec = $rhas_broken_list_with_lec->{$seqno};
# Only for types of container tokens with a non-default break option
my $token = $rLL->[$KK]->[_TOKEN_];
my $break_option = $break_before_container_types{$token};
next unless ($break_option);
# Do not use -bbx under stress for stability ... fixes b1300
# TODO: review this; do we also need to look at stress_level_lalpha?
my $level = $rLL->[$KK]->[_LEVEL_];
if ( $level >= $stress_level_beta ) {
DEBUG_BBX
&& print
"BBX: Switching off at $seqno: level=$level exceeds beta stress level=$stress_level_beta\n";
next;
}
# Require previous nonblank to be '=' or '=>'
my $Kprev = $KK - 1;
next if ( $Kprev < 0 );
my $prev_type = $rLL->[$Kprev]->[_TYPE_];
if ( $prev_type eq 'b' ) {
$Kprev--;
next if ( $Kprev < 0 );
$prev_type = $rLL->[$Kprev]->[_TYPE_];
}
next unless ( $is_equal_or_fat_comma{$prev_type} );
my $ci = $rLL->[$KK]->[_CI_LEVEL_];
#--------------------------------------------
# New coding for option 2 (break if complex).
#--------------------------------------------
# This new coding uses clues which are invariant under formatting to
# decide if a list is complex. For now it is only applied when -lp
# and -vmll are used, but eventually it may become the standard method.
# Fixes b1274, b1275, and others, including b1099.
# Update: case b1469 also had this type of problem; it had the
# combination ci>i and used -xci. This is just a band-aid; eventually
# it might be best if all cases use this logic, but that would change
# existing formatting.
if ( $break_option == 2 ) {
my $b1469 = $rOpts_continuation_indentation > $rOpts_indent_columns
&& $rOpts_extended_continuation_indentation;
if ( $rOpts_line_up_parentheses
|| $rOpts_variable_maximum_line_length
|| $b1469 )
{
# Start with the basic definition of a complex list...
my $is_complex = $is_list && $has_list;
# and it is also complex if the parent is a list
if ( !$is_complex ) {
my $parent = $rparent_of_seqno->{$seqno};
if ( $self->is_list_by_seqno($parent) ) {
$is_complex = 1;
}
}
# finally, we will call it complex if there are inner opening
# and closing container tokens, not parens, within the outer
# container tokens.
if ( !$is_complex ) {
my $Kp = $self->K_next_nonblank($KK);
my $token_p = defined($Kp) ? $rLL->[$Kp]->[_TOKEN_] : 'b';
if ( $is_opening_token{$token_p} && $token_p ne '(' ) {
my $Kc = $K_closing_container->{$seqno};
my $Km = $self->K_previous_nonblank($Kc);
my $token_m = 'b';
my $type_m = SPACE;
if ( defined($Km) ) {
$token_m = $rLL->[$Km]->[_TOKEN_];
$type_m = $rLL->[$Km]->[_TYPE_];
}
# ignore any optional ending comma
if ( $type_m eq ',' ) {
$Km = $self->K_previous_nonblank($Km);
$token_m =
defined($Km) ? $rLL->[$Km]->[_TOKEN_] : 'b';
}
$is_complex ||=
$is_closing_token{$token_m} && $token_m ne ')';
}
}
# Convert to option 3 (always break) if complex
next unless ($is_complex);
$break_option = 3;
}
}
# Fix for b1231: the has_list_with_lec does not cover all cases.
# A broken container containing a list and with line-ending commas
# will stay broken, so can be treated as if it had a list with lec.
$has_list_with_lec ||=
$has_list
&& $ris_broken_container->{$seqno}
&& $rlec_count_by_seqno->{$seqno};
DEBUG_BBX
&& print {*STDOUT}
"BBX: Looking at seqno=$seqno, token = $token with option=$break_option\n";
# -bbx=1 = stable, try to follow input
if ( $break_option == 1 ) {
my $iline = $rLL->[$KK]->[_LINE_INDEX_];
my $rK_range = $rlines->[$iline]->{_rK_range};
my ( $Kfirst, $Klast_uu ) = @{$rK_range};
next unless ( $KK == $Kfirst );
}
# -bbx=2 => apply this style only for a 'complex' list
elsif ( $break_option == 2 ) {
# break if this list contains a broken list with line-ending comma
my $ok_to_break;
my $Msg = EMPTY_STRING;
if ($has_list_with_lec) {
$ok_to_break = 1;
DEBUG_BBX && do { $Msg = "has list with lec;" };
}
if ( !$ok_to_break ) {
# Turn off -xci if -bbx=2 and this container has a sublist but
# not a broken sublist. This avoids creating blinkers. The
# problem is that -xci can cause one-line lists to break open,
# and thereby creating formatting instability.
# This fixes cases b1033 b1036 b1037 b1038 b1042 b1043 b1044
# b1045 b1046 b1047 b1051 b1052 b1061.
if ($has_list) { $rno_xci_by_seqno->{$seqno} = 1 }
my $parent = $rparent_of_seqno->{$seqno};
if ( $self->is_list_by_seqno($parent) ) {
DEBUG_BBX && do { $Msg = "parent is list" };
$ok_to_break = 1;
}
}
if ( !$ok_to_break ) {
DEBUG_BBX
&& print {*STDOUT} "Not breaking at seqno=$seqno: $Msg\n";
next;
}
DEBUG_BBX
&& print {*STDOUT} "OK to break at seqno=$seqno: $Msg\n";
# Patch: turn off -xci if -bbx=2 and -lp
# This fixes cases b1090 b1095 b1101 b1116 b1118 b1121 b1122
$rno_xci_by_seqno->{$seqno} = 1 if ($rOpts_line_up_parentheses);
}
# -bbx=3 = always break
elsif ( $break_option == 3 ) {
# ok to break
}
# Bad flag, this shouldn't happen because of the integer range checks.
# Continue using behavior same as option 3 if not in DEVEL_MODE
else {
DEVEL_MODE && Fault(<{$seqno} = 1;
DEBUG_BBX
&& print {*STDOUT} "BBX: ok to break at seqno=$seqno\n";
# -bbxi=0: Nothing more to do if the ci value remains unchanged
my $ci_flag = $container_indentation_options{$token};
next unless ($ci_flag);
# -bbxi=1: This option removes ci and is handled in
# later sub get_final_indentation
if ( $ci_flag == 1 ) {
$rwant_reduced_ci->{$seqno} = 1;
next;
}
# -bbxi=2: This option changes the level ...
# This option can conflict with -xci in some cases. We can turn off
# -xci for this container to avoid blinking. For now, only do this if
# -vmll is set. ( fixes b1335, b1336 )
if ($rOpts_variable_maximum_line_length) {
$rno_xci_by_seqno->{$seqno} = 1;
}
#----------------------------------------------------------------
# Part 2: Perform tests before committing to changing ci and level
#----------------------------------------------------------------
# Before changing the ci level of the opening container, we need
# to be sure that the container will be broken in the later stages of
# formatting. We have to do this because we are working early in the
# formatting pipeline. A problem can occur if we change the ci or
# level of the opening token but do not actually break the container
# open as expected. In most cases it wouldn't make any difference if
# we changed ci or not, but there are some edge cases where this
# can cause blinking states, so we need to try to only change ci if
# the container will really be broken.
# Only consider containers already broken
next if ( !$ris_broken_container->{$seqno} );
# Patch to fix issue b1305: the combination of -naws and ci>i appears
# to cause an instability. It should almost never occur in practice.
next
if (!$rOpts_add_whitespace
&& $rOpts_continuation_indentation > $rOpts_indent_columns );
# Always ok to change ci for permanently broken containers
if ( $ris_permanently_broken->{$seqno} ) { }
# Always OK if this list contains a broken sub-container with
# a non-terminal line-ending comma
elsif ($has_list_with_lec) { }
# Otherwise, we are considering a single container...
else {
# A single container must have at least 1 line-ending comma:
next unless ( $rlec_count_by_seqno->{$seqno} );
my $OK;
# Since it has a line-ending comma, it will stay broken if the
# -boc flag is set
if ($rOpts_break_at_old_comma_breakpoints) { $OK = 1 }
# OK if the container contains multiple fat commas
# Better: multiple lines with fat commas
if ( !$OK && !$rOpts_ignore_old_breakpoints ) {
my $rtype_count = $rtype_count_by_seqno->{$seqno};
next unless ($rtype_count);
my $fat_comma_count = $rtype_count->{'=>'};
DEBUG_BBX
&& print {*STDOUT} "BBX: fat comma count=$fat_comma_count\n";
if ( $fat_comma_count && $fat_comma_count >= 2 ) { $OK = 1 }
}
# The last check we can make is to see if this container could
# fit on a single line. Use the least possible indentation
# estimate, ci=0, so we are not subtracting $ci *
# $rOpts_continuation_indentation from tabulated
# $maximum_text_length value.
if ( !$OK ) {
my $maximum_text_length = $maximum_text_length_at_level[$level];
my $K_closing = $K_closing_container->{$seqno};
my $length = $self->cumulative_length_before_K($K_closing) -
$self->cumulative_length_before_K($KK);
my $excess_length = $length - $maximum_text_length;
DEBUG_BBX
&& print {*STDOUT}
"BBX: excess=$excess_length: maximum_text_length=$maximum_text_length, length=$length, ci=$ci\n";
# OK if the net container definitely breaks on length
if ( $excess_length > $length_tol ) {
$OK = 1;
DEBUG_BBX
&& print {*STDOUT} "BBX: excess_length=$excess_length\n";
}
# Otherwise skip it
else { next }
}
}
#------------------------------------------------------------
# Part 3: Looks OK: apply -bbx=n and any related -bbxi=n flag
#------------------------------------------------------------
DEBUG_BBX && print {*STDOUT} "BBX: OK to break\n";
# -bbhbi=n
# -bbsbi=n
# -bbpi=n
# where:
# n=0 default indentation (usually one ci)
# n=1 outdent one ci
# n=2 indent one level (minus one ci)
# NOTE: We are adjusting indentation of the opening container. The
# closing container will normally follow the indentation of the opening
# container automatically, so this is not currently done.
next unless ($ci);
# option 1: outdent
if ( $ci_flag == 1 ) {
$ci -= 1;
}
# option 2: indent one level
elsif ( $ci_flag == 2 ) {
$ci -= 1;
$radjusted_levels->[$KK] += 1;
}
# unknown option
else {
# Shouldn't happen - leave ci unchanged
DEVEL_MODE && Fault(<[$KK]->[_CI_LEVEL_] = $ci if ( $ci >= 0 );
}
#------------------
# Store the results
#------------------
$self->[_rbreak_before_container_by_seqno_] =
$rbreak_before_container_by_seqno;
$self->[_rwant_reduced_ci_] = $rwant_reduced_ci;
return;
} ## end sub break_before_list_opening_containers
use constant DEBUG_XCI => 0;
sub extended_ci {
my ($self) = @_;
# This routine implements the -xci (--extended-continuation-indentation)
# flag. We add CI to interior tokens of a container which itself has CI but
# only if a token does not already have CI.
# To do this, we will locate opening tokens which themselves have
# continuation indentation (CI). We track them with their sequence
# numbers. These sequence numbers are called 'controlling sequence
# numbers'. They apply continuation indentation to the tokens that they
# contain. These inner tokens remember their controlling sequence numbers.
# Later, when these inner tokens are output, they have to see if the output
# lines with their controlling tokens were output with CI or not. If not,
# then they must remove their CI too.
# The controlling CI concept works hierarchically. But CI itself is not
# hierarchical; it is either on or off. There are some rare instances where
# it would be best to have hierarchical CI too, but not enough to be worth
# the programming effort.
# The operations to remove unwanted CI are done in sub 'undo_ci'.
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $ris_seqno_controlling_ci = $self->[_ris_seqno_controlling_ci_];
my $rseqno_controlling_my_ci = $self->[_rseqno_controlling_my_ci_];
my $rno_xci_by_seqno = $self->[_rno_xci_by_seqno_];
my $ris_bli_container = $self->[_ris_bli_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my %available_space;
# Loop over all opening container tokens
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rK_sequenced_token_list = $self->[_rK_sequenced_token_list_];
my @seqno_stack;
my $seqno_top;
my $K_last;
# The following variable can be used to allow a little extra space to
# avoid blinkers. A value $len_tol = 20 fixed the following
# fixes cases: b1025 b1026 b1027 b1028 b1029 b1030 but NOT b1031.
# It turned out that the real problem was mis-parsing a list brace as
# a code block in a 'use' statement when the line length was extremely
# small. A value of 0 works now, but a slightly larger value can
# be used to minimize the chance of a blinker.
my $len_tol = 0;
foreach my $KK ( @{$rK_sequenced_token_list} ) {
# Fix all tokens up to the next sequence item if we are changing CI
if ($seqno_top) {
my $is_list = $ris_list_by_seqno->{$seqno_top};
my $space = $available_space{$seqno_top};
my $count = 0;
foreach my $Kt ( $K_last + 1 .. $KK - 1 ) {
next if ( $rLL->[$Kt]->[_CI_LEVEL_] );
# But do not include tokens which might exceed the line length
# and are not in a list.
# ... This fixes case b1031
if ( $is_list
|| $rLL->[$Kt]->[_TOKEN_LENGTH_] < $space
|| $rLL->[$Kt]->[_TYPE_] eq '#' )
{
$rLL->[$Kt]->[_CI_LEVEL_] = 1;
$rseqno_controlling_my_ci->{$Kt} = $seqno_top;
$count++;
}
}
$ris_seqno_controlling_ci->{$seqno_top} += $count;
}
$K_last = $KK;
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
# see if we have reached the end of the current controlling container
if ( $seqno_top && $seqno == $seqno_top ) {
$seqno_top = pop @seqno_stack;
}
# Patch to fix some block types...
# Certain block types arrive from the tokenizer without CI but should
# have it for this option. These include anonymous subs and
# do sort map grep eval
my $block_type = $rblock_type_of_seqno->{$seqno};
if ( $block_type && $is_block_with_ci{$block_type} ) {
$rLL->[$KK]->[_CI_LEVEL_] = 1;
if ($seqno_top) {
$rseqno_controlling_my_ci->{$KK} = $seqno_top;
$ris_seqno_controlling_ci->{$seqno_top}++;
}
}
# If this does not have ci, update ci if necessary and continue looking
else {
if ( !$rLL->[$KK]->[_CI_LEVEL_] ) {
if ($seqno_top) {
$rLL->[$KK]->[_CI_LEVEL_] = 1;
$rseqno_controlling_my_ci->{$KK} = $seqno_top;
$ris_seqno_controlling_ci->{$seqno_top}++;
}
next;
}
}
# We are looking for opening container tokens with ci
my $K_opening = $K_opening_container->{$seqno};
next unless ( defined($K_opening) && $KK == $K_opening );
# Make sure there is a corresponding closing container
# (could be missing if the script has a brace error)
my $K_closing = $K_closing_container->{$seqno};
next unless defined($K_closing);
# Skip if requested by -bbx to avoid blinkers
next if ( $rno_xci_by_seqno->{$seqno} );
# Skip if this is a -bli container (this fixes case b1065) Note: case
# b1065 is also fixed by the update for b1055, so this update is not
# essential now. But there does not seem to be a good reason to add
# xci and bli together, so the update is retained.
next if ( $ris_bli_container->{$seqno} );
# Require different input lines. This will filter out a large number
# of small hash braces and array brackets. If we accidentally filter
# out an important container, it will get fixed on the next pass.
if (
$rLL->[$K_opening]->[_LINE_INDEX_] ==
$rLL->[$K_closing]->[_LINE_INDEX_]
&& ( $rLL->[$K_closing]->[_CUMULATIVE_LENGTH_] -
$rLL->[$K_opening]->[_CUMULATIVE_LENGTH_] >
$rOpts_maximum_line_length )
)
{
DEBUG_XCI
&& print "XCI: Skipping seqno=$seqno, require different lines\n";
next;
}
# Do not apply -xci if adding extra ci will put the container contents
# beyond the line length limit (fixes cases b899 b935)
my $level = $rLL->[$K_opening]->[_LEVEL_];
my $ci_level = $rLL->[$K_opening]->[_CI_LEVEL_];
my $maximum_text_length =
$maximum_text_length_at_level[$level] -
$ci_level * $rOpts_continuation_indentation;
# Fix for b1197 b1198 b1199 b1200 b1201 b1202
# Do not apply -xci if we are running out of space
# TODO: review this; do we also need to look at stress_level_alpha?
if ( $level >= $stress_level_beta ) {
DEBUG_XCI
&& print
"XCI: Skipping seqno=$seqno, level=$level exceeds stress level=$stress_level_beta\n";
next;
}
# remember how much space is available for patch b1031 above
my $space =
$maximum_text_length - $len_tol - $rOpts_continuation_indentation;
if ( $space < 0 ) {
DEBUG_XCI && print "XCI: Skipping seqno=$seqno, space=$space\n";
next;
}
DEBUG_XCI && print "XCI: OK seqno=$seqno, space=$space\n";
$available_space{$seqno} = $space;
# This becomes the next controlling container
push @seqno_stack, $seqno_top if ($seqno_top);
$seqno_top = $seqno;
}
return;
} ## end sub extended_ci
sub braces_left_setup {
# Called once per file to mark all -bl, -sbl, and -asbl containers
my $self = shift;
my $rOpts_bl = $rOpts->{'opening-brace-on-new-line'};
my $rOpts_sbl = $rOpts->{'opening-sub-brace-on-new-line'};
my $rOpts_asbl = $rOpts->{'opening-anonymous-sub-brace-on-new-line'};
return unless ( $rOpts_bl || $rOpts_sbl || $rOpts_asbl );
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
# We will turn on this hash for braces controlled by these flags:
my $rbrace_left = $self->[_rbrace_left_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_asub_block = $self->[_ris_asub_block_];
my $ris_sub_block = $self->[_ris_sub_block_];
foreach my $seqno ( keys %{$rblock_type_of_seqno} ) {
my $block_type = $rblock_type_of_seqno->{$seqno};
# use -asbl flag for an anonymous sub block
if ( $ris_asub_block->{$seqno} ) {
if ($rOpts_asbl) {
$rbrace_left->{$seqno} = 1;
}
}
# use -sbl flag for a named sub
elsif ( $ris_sub_block->{$seqno} ) {
if ($rOpts_sbl) {
$rbrace_left->{$seqno} = 1;
}
}
# use -bl flag if not a sub block of any type
else {
if ( $rOpts_bl
&& $block_type =~ /$bl_pattern/
&& $block_type !~ /$bl_exclusion_pattern/ )
{
$rbrace_left->{$seqno} = 1;
}
}
}
return;
} ## end sub braces_left_setup
sub bli_adjustment {
# Called once per file to implement the --brace-left-and-indent option.
# 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 $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $ris_bli_container = $self->[_ris_bli_container_];
my $rbrace_left = $self->[_rbrace_left_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
foreach my $seqno ( keys %{$rblock_type_of_seqno} ) {
my $block_type = $rblock_type_of_seqno->{$seqno};
if ( $block_type
&& $block_type =~ /$bli_pattern/
&& $block_type !~ /$bli_exclusion_pattern/ )
{
$ris_bli_container->{$seqno} = 1;
$rbrace_left->{$seqno} = 1;
my $Ko = $K_opening_container->{$seqno};
my $Kc = $K_closing_container->{$seqno};
if ( defined($Ko) && defined($Kc) ) {
$rLL->[$Kc]->[_CI_LEVEL_] = ++$rLL->[$Ko]->[_CI_LEVEL_];
}
}
}
return;
} ## end sub bli_adjustment
sub find_multiline_qw {
my ( $self, $rqw_lines ) = @_;
# Multiline qw quotes are not sequenced items like containers { [ (
# but behave in some respects in a similar way. So this routine finds them
# and creates a separate sequence number system for later use.
# This is straightforward because they always begin at the end of one line
# and end at the beginning of a later line. This is true no matter how we
# finally make our line breaks, so we can find them before deciding on new
# line breaks.
# Input parameter:
# if $rqw_lines is defined it is a ref to array of all line index numbers
# for which there is a type 'q' qw quote at either end of the line. This
# was defined by sub resync_lines_and_tokens for efficiency.
#
my $rlines = $self->[_rlines_];
# if $rqw_lines is not defined (this will occur with -io option) then we
# will have to scan all lines.
if ( !defined($rqw_lines) ) {
$rqw_lines = [ 0 .. @{$rlines} - 1 ];
}
# if $rqw_lines is defined but empty, just return because there are no
# multiline qw's
else {
if ( !@{$rqw_lines} ) { return }
}
my $rstarting_multiline_qw_seqno_by_K = {};
my $rending_multiline_qw_seqno_by_K = {};
my $rKrange_multiline_qw_by_seqno = {};
my $rmultiline_qw_has_extra_level = {};
my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
my $rLL = $self->[_rLL_];
my $qw_seqno;
my $num_qw_seqno = 0;
my $K_start_multiline_qw;
# For reference, here is the old loop, before $rqw_lines became available:
## foreach my $line_of_tokens ( @{$rlines} ) {
foreach my $iline ( @{$rqw_lines} ) {
my $line_of_tokens = $rlines->[$iline];
# Note that these first checks are required in case we have to scan
# all lines, not just lines with type 'q' at the ends.
my $line_type = $line_of_tokens->{_line_type};
next unless ( $line_type eq 'CODE' );
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
next unless ( defined($Kfirst) && defined($Klast) ); # skip blank line
# Continuing a sequence of qw lines ...
if ( defined($K_start_multiline_qw) ) {
my $type = $rLL->[$Kfirst]->[_TYPE_];
# shouldn't happen
if ( $type ne 'q' ) {
DEVEL_MODE && print {*STDERR} <K_previous_nonblank($Kfirst);
my $Knext = $self->K_next_nonblank($Kfirst);
my $type_m = defined($Kprev) ? $rLL->[$Kprev]->[_TYPE_] : 'b';
my $type_p = defined($Knext) ? $rLL->[$Knext]->[_TYPE_] : 'b';
if ( $type_m eq 'q' && $type_p ne 'q' ) {
$rending_multiline_qw_seqno_by_K->{$Kfirst} = $qw_seqno;
$rKrange_multiline_qw_by_seqno->{$qw_seqno} =
[ $K_start_multiline_qw, $Kfirst ];
$K_start_multiline_qw = undef;
$qw_seqno = undef;
}
}
# Starting a new a sequence of qw lines ?
if ( !defined($K_start_multiline_qw)
&& $rLL->[$Klast]->[_TYPE_] eq 'q' )
{
my $Kprev = $self->K_previous_nonblank($Klast);
my $Knext = $self->K_next_nonblank($Klast);
my $type_m = defined($Kprev) ? $rLL->[$Kprev]->[_TYPE_] : 'b';
my $type_p = defined($Knext) ? $rLL->[$Knext]->[_TYPE_] : 'b';
if ( $type_m ne 'q' && $type_p eq 'q' ) {
$num_qw_seqno++;
$qw_seqno = 'q' . $num_qw_seqno;
$K_start_multiline_qw = $Klast;
$rstarting_multiline_qw_seqno_by_K->{$Klast} = $qw_seqno;
}
}
}
# Give multiline qw lists extra indentation instead of CI. This option
# works well but is currently only activated when the -xci flag is set.
# The reason is to avoid unexpected changes in formatting.
if ($rOpts_extended_continuation_indentation) {
foreach my $qw_seqno_x ( keys %{$rKrange_multiline_qw_by_seqno} ) {
my $rKrange = $rKrange_multiline_qw_by_seqno->{$qw_seqno_x};
my ( $Kbeg, $Kend ) = @{$rKrange};
# require isolated closing token
my $token_end = $rLL->[$Kend]->[_TOKEN_];
my $is_isolated_closing = length($token_end) == 1
&& ( $is_closing_token{$token_end} || $token_end eq '>' );
next unless ($is_isolated_closing);
# require isolated opening token
my $token_beg = $rLL->[$Kbeg]->[_TOKEN_];
# allow space(s) after the qw
if ( length($token_beg) > 3 && substr( $token_beg, 2, 1 ) =~ m/\s/ )
{
$token_beg =~ s/\s+//;
}
next unless ( length($token_beg) == 3 );
foreach my $KK ( $Kbeg + 1 .. $Kend - 1 ) {
$rLL->[$KK]->[_LEVEL_]++;
$rLL->[$KK]->[_CI_LEVEL_] = 0;
}
# set flag for -wn option, which will remove the level
$rmultiline_qw_has_extra_level->{$qw_seqno_x} = 1;
}
}
# For the -lp option we need to mark all parent containers of
# multiline quotes
if ( $rOpts_line_up_parentheses && !$rOpts_extended_line_up_parentheses ) {
foreach my $qw_seqno_x ( keys %{$rKrange_multiline_qw_by_seqno} ) {
my $rKrange = $rKrange_multiline_qw_by_seqno->{$qw_seqno_x};
my ( $Kbeg, $Kend ) = @{$rKrange};
my $parent_seqno = $self->parent_seqno_by_K($Kend);
next unless ($parent_seqno);
# If the parent container exactly surrounds this qw, then -lp
# formatting seems to work so we will not mark it.
my $is_tightly_contained;
my $Kn = $self->K_next_nonblank($Kend);
my $seqno_n = defined($Kn) ? $rLL->[$Kn]->[_TYPE_SEQUENCE_] : undef;
if ( defined($seqno_n) && $seqno_n eq $parent_seqno ) {
my $Kp = $self->K_previous_nonblank($Kbeg);
my $seqno_p =
defined($Kp) ? $rLL->[$Kp]->[_TYPE_SEQUENCE_] : undef;
if ( defined($seqno_p) && $seqno_p eq $parent_seqno ) {
$is_tightly_contained = 1;
}
}
$ris_excluded_lp_container->{$parent_seqno} = 1
unless ($is_tightly_contained);
# continue up the tree marking parent containers
$self->mark_parent_containers( $parent_seqno,
$ris_excluded_lp_container );
}
}
$self->[_rstarting_multiline_qw_seqno_by_K_] =
$rstarting_multiline_qw_seqno_by_K;
$self->[_rending_multiline_qw_seqno_by_K_] =
$rending_multiline_qw_seqno_by_K;
$self->[_rKrange_multiline_qw_by_seqno_] = $rKrange_multiline_qw_by_seqno;
$self->[_rmultiline_qw_has_extra_level_] = $rmultiline_qw_has_extra_level;
return;
} ## end sub find_multiline_qw
use constant DEBUG_COLLAPSED_LENGTHS => 0;
# Minimum space reserved for contents of a code block. A value of 40 has given
# reasonable results. With a large line length, say -l=120, this will not
# normally be noticeable but it will prevent making a mess in some edge cases.
use constant MIN_BLOCK_LEN => 40;
my %is_handle_type;
BEGIN {
my @q = qw( w C U G i k => );
@is_handle_type{@q} = (1) x scalar(@q);
my $i = 0;
use constant {
_max_prong_len_ => $i++,
_handle_len_ => $i++,
_seqno_o_ => $i++,
_iline_o_ => $i++,
_K_o_ => $i++,
_K_c_ => $i++,
_interrupted_list_rule_ => $i++,
};
} ## end BEGIN
sub is_fragile_block_type {
my ( $self, $block_type, $seqno ) = @_;
# Given:
# $block_type = the block type of a token, and
# $seqno = its sequence number
# Return:
# true if this block type stays broken after being broken,
# false otherwise
# This sub has been added to isolate a tricky decision needed
# to fix issue b1428.
# The coding here needs to agree with:
# - sub process_line where variable '$rbrace_follower' is set
# - sub process_line_inner_loop where variable '$is_opening_BLOCK' is set,
if ( $is_sort_map_grep_eval{$block_type}
|| $block_type eq 't'
|| $self->[_rshort_nested_]->{$seqno} )
{
return 0;
}
return 1;
} ## end sub is_fragile_block_type
{ ## closure xlp_collapsed_lengths
my $max_prong_len;
my $len;
my $last_nonblank_type;
my @stack;
sub xlp_collapsed_lengths_initialize {
$max_prong_len = 0;
$len = 0;
$last_nonblank_type = 'b';
@stack = ();
push @stack, [
0, # $max_prong_len,
0, # $handle_len,
SEQ_ROOT, # $seqno,
undef, # $iline,
undef, # $KK,
undef, # $K_c,
undef, # $interrupted_list_rule
];
return;
} ## end sub xlp_collapsed_lengths_initialize
sub cumulative_length_to_comma {
my ( $self, $KK, $K_comma, $K_closing ) = @_;
# Given:
# $KK = index of starting token, or blank before start
# $K_comma = index of line-ending comma
# $K_closing = index of the container closing token
# Return:
# $length = cumulative length of the term
my $rLL = $self->[_rLL_];
if ( $rLL->[$KK]->[_TYPE_] eq 'b' ) { $KK++ }
my $length = 0;
if (
$KK < $K_comma
&& $rLL->[$K_comma]->[_TYPE_] eq ',' # should be true
# Ignore if terminal comma, causes instability (b1297,
# b1330)
&& (
$K_closing - $K_comma > 2
|| ( $K_closing - $K_comma == 2
&& $rLL->[ $K_comma + 1 ]->[_TYPE_] ne 'b' )
)
# The comma should be in this container
&& ( $rLL->[$K_comma]->[_LEVEL_] - 1 ==
$rLL->[$K_closing]->[_LEVEL_] )
)
{
# An additional check: if line ends in ), and the ) has vtc then
# skip this estimate. Otherwise, vtc can give oscillating results.
# Fixes b1448. For example, this could be unstable:
# ( $os ne 'win' ? ( -selectcolor => "red" ) : () ),
# | |^--K_comma
# | ^-- K_prev
# ^--- KK
# An alternative, possibly better strategy would be to try to turn
# off -vtc locally, but it turns out to be difficult to locate the
# appropriate closing token when it is not on the same line as its
# opening token.
my $K_prev = $self->K_previous_nonblank($K_comma);
if ( defined($K_prev)
&& $K_prev >= $KK
&& $rLL->[$K_prev]->[_TYPE_SEQUENCE_] )
{
my $token = $rLL->[$K_prev]->[_TOKEN_];
my $type = $rLL->[$K_prev]->[_TYPE_];
if ( $closing_vertical_tightness{$token} && $type ne 'R' ) {
## type 'R' does not normally get broken, so ignore
## skip length calculation
return 0;
}
}
my $starting_len =
$KK >= 0 ? $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_] : 0;
$length = $rLL->[$K_comma]->[_CUMULATIVE_LENGTH_] - $starting_len;
}
return $length;
} ## end sub cumulative_length_to_comma
sub xlp_collapsed_lengths {
my $self = shift;
#----------------------------------------------------------------
# Define the collapsed lengths of containers for -xlp indentation
#----------------------------------------------------------------
# We need an estimate of the minimum required line length starting at
# any opening container for the -xlp style. This is needed to avoid
# using too much indentation space for lower level containers and
# thereby running out of space for outer container tokens due to the
# maximum line length limit.
# The basic idea is that at each node in the tree we imagine that we
# have a fork with a handle and collapsible prongs:
#
# |------------
# |--------
# ------------|-------
# handle |------------
# |--------
# prongs
#
# Each prong has a minimum collapsed length. The collapsed length at a
# node is the maximum of these minimum lengths, plus the handle length.
# Each of the prongs may itself be a tree node.
# This is just a rough calculation to get an approximate starting point
# for indentation. Later routines will be more precise. It is
# important that these estimates be independent of the line breaks of
# the input stream in order to avoid instabilities.
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
my $rcollapsed_length_by_seqno = $self->[_rcollapsed_length_by_seqno_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $rK_next_seqno_by_K = $self->[_rK_next_seqno_by_K_];
my $K_start_multiline_qw;
my $level_start_multiline_qw = 0;
xlp_collapsed_lengths_initialize();
#--------------------------------
# Loop over all lines in the file
#--------------------------------
my $iline = -1;
my $skip_next_line;
foreach my $line_of_tokens ( @{$rlines} ) {
$iline++;
if ($skip_next_line) {
$skip_next_line = 0;
next;
}
my $line_type = $line_of_tokens->{_line_type};
next if ( $line_type ne 'CODE' );
my $CODE_type = $line_of_tokens->{_code_type};
# Always skip blank lines
next if ( $CODE_type eq 'BL' );
# Note on other line types:
# 'FS' (Format Skipping) lines may contain opening/closing tokens so
# we have to process them to keep the stack correctly sequenced
# 'VB' (Verbatim) lines could be skipped, but testing shows that
# results look better if we include their lengths.
# Also note that we could exclude -xlp formatting of containers with
# 'FS' and 'VB' lines, but in testing that was not really beneficial
# So we process tokens in 'FS' and 'VB' lines like all the rest...
my $rK_range = $line_of_tokens->{_rK_range};
my ( $K_first, $K_last ) = @{$rK_range};
next unless ( defined($K_first) && defined($K_last) );
my $has_comment = $rLL->[$K_last]->[_TYPE_] eq '#';
# Always ignore block comments
next if ( $has_comment && $K_first == $K_last );
# Handle an intermediate line of a multiline qw quote. These may
# require including some -ci or -i spaces. See cases c098/x063.
# Updated to check all lines (not just $K_first==$K_last) to fix
# b1316
my $K_begin_loop = $K_first;
if ( $rLL->[$K_first]->[_TYPE_] eq 'q' ) {
my $KK = $K_first;
my $level = $rLL->[$KK]->[_LEVEL_];
my $ci_level = $rLL->[$KK]->[_CI_LEVEL_];
# remember the level of the start
if ( !defined($K_start_multiline_qw) ) {
$K_start_multiline_qw = $K_first;
$level_start_multiline_qw = $level;
my $seqno_qw =
$self->[_rstarting_multiline_qw_seqno_by_K_]
->{$K_start_multiline_qw};
if ( !$seqno_qw ) {
my $Kp = $self->K_previous_nonblank($K_first);
if ( defined($Kp) && $rLL->[$Kp]->[_TYPE_] eq 'q' ) {
$K_start_multiline_qw = $Kp;
$level_start_multiline_qw =
$rLL->[$K_start_multiline_qw]->[_LEVEL_];
}
else {
# Fix for b1319, b1320
$K_start_multiline_qw = undef;
}
}
}
if ( defined($K_start_multiline_qw) ) {
$len = $rLL->[$KK]->[_CUMULATIVE_LENGTH_] -
$rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
# We may have to add the spaces of one level or ci level
# ... it depends depends on the -xci flag, the -wn flag,
# and if the qw uses a container token as the quote
# delimiter.
# First rule: add ci if there is a $ci_level
if ($ci_level) {
$len += $rOpts_continuation_indentation;
}
# Second rule: otherwise, look for an extra indentation
# level from the start and add one indentation level if
# found.
else {
if ( $level > $level_start_multiline_qw ) {
$len += $rOpts_indent_columns;
}
}
if ( $len > $max_prong_len ) { $max_prong_len = $len }
$last_nonblank_type = 'q';
$K_begin_loop = $K_first + 1;
# We can skip to the next line if more tokens
next if ( $K_begin_loop > $K_last );
}
}
# If starting in quote type Q we have no control over indentation
# so just ignore the length of this token (see git #138)
elsif ( $rLL->[$K_first]->[_TYPE_] eq 'Q' ) {
if ( $line_of_tokens->{_starting_in_quote} ) {
$K_begin_loop = $K_first + 1;
next if ( $K_begin_loop > $K_last );
}
}
else {
}
$K_start_multiline_qw = undef;
# Find the terminal token, before any side comment
my $K_terminal = $K_last;
if ($has_comment) {
$K_terminal -= 1;
$K_terminal -= 1
if ( $rLL->[$K_terminal]->[_TYPE_] eq 'b'
&& $K_terminal > $K_first );
}
# Use length to terminal comma if interrupted list rule applies
if ( @stack && $stack[-1]->[_interrupted_list_rule_] ) {
my $K_c = $stack[-1]->[_K_c_];
if ( defined($K_c) ) {
#----------------------------------------------------------
# BEGIN patch for issue b1408: If this line ends in an
# opening token, look for the closing token and comma at
# the end of the next line. If so, combine the two lines to
# get the correct sums. This problem seems to require -xlp
# -vtc=2 and blank lines to occur. Use %is_opening_type to
# fix b1431.
#----------------------------------------------------------
if ( $is_opening_type{ $rLL->[$K_terminal]->[_TYPE_] }
&& !$has_comment )
{
my $seqno_end = $rLL->[$K_terminal]->[_TYPE_SEQUENCE_];
my $Kc_test = $rK_next_seqno_by_K->[$K_terminal];
# We are looking for a short broken remnant on the next
# line; something like the third line here (b1408):
# parent =>
# Moose::Util::TypeConstraints::find_type_constraint(
# 'RefXX' ),
# or this
#
# Help::WorkSubmitter->_filter_chores_and_maybe_warn_user(
# $story_set_all_chores),
# or this (b1431):
# $issue->{
# 'borrowernumber'}, # borrowernumber
if ( defined($Kc_test)
&& $seqno_end == $rLL->[$Kc_test]->[_TYPE_SEQUENCE_]
&& $rLL->[$Kc_test]->[_LINE_INDEX_] == $iline + 1 )
{
my $line_of_tokens_next = $rlines->[ $iline + 1 ];
my $rtype_count =
$rtype_count_by_seqno->{$seqno_end};
my ( $K_first_next, $K_terminal_next ) =
@{ $line_of_tokens_next->{_rK_range} };
# backup at a side comment
if ( defined($K_terminal_next)
&& $rLL->[$K_terminal_next]->[_TYPE_] eq '#' )
{
my $Kprev =
$self->K_previous_nonblank($K_terminal_next);
if ( defined($Kprev)
&& $Kprev >= $K_first_next )
{
$K_terminal_next = $Kprev;
}
}
if (
defined($K_terminal_next)
# next line ends with a comma
&& $rLL->[$K_terminal_next]->[_TYPE_] eq ','
# which follows the closing container token
&& (
$K_terminal_next - $Kc_test == 1
|| ( $K_terminal_next - $Kc_test == 2
&& $rLL->[ $K_terminal_next - 1 ]
->[_TYPE_] eq 'b' )
)
# no commas in the container
&& ( !defined($rtype_count)
|| !$rtype_count->{','} )
# for now, restrict this to a container with
# just 1 or two tokens
&& $K_terminal_next - $K_terminal <= 5
)
{
# combine the next line with the current line
$K_terminal = $K_terminal_next;
$skip_next_line = 1;
if (DEBUG_COLLAPSED_LENGTHS) {
print "Combining lines at line $iline\n";
}
}
}
}
#--------------------------
# END patch for issue b1408
#--------------------------
if ( $rLL->[$K_terminal]->[_TYPE_] eq ',' ) {
my $length =
$self->cumulative_length_to_comma( $K_first,
$K_terminal, $K_c );
# Fix for b1331: at a broken => item, include the
# length of the previous half of the item plus one for
# the missing space
if ( $last_nonblank_type eq '=>' ) {
$length += $len + 1;
}
if ( $length > $max_prong_len ) {
$max_prong_len = $length;
}
}
}
}
#----------------------------------
# Loop over all tokens on this line
#----------------------------------
$self->xlp_collapse_lengths_inner_loop( $iline, $K_begin_loop,
$K_terminal, $K_last );
# Now take care of any side comment;
if ($has_comment) {
if ($rOpts_ignore_side_comment_lengths) {
$len = 0;
}
else {
# For a side comment when -iscl is not set, measure length from
# the start of the previous nonblank token
my $len0 =
$K_terminal > 0
? $rLL->[ $K_terminal - 1 ]->[_CUMULATIVE_LENGTH_]
: 0;
$len = $rLL->[$K_last]->[_CUMULATIVE_LENGTH_] - $len0;
if ( $len > $max_prong_len ) { $max_prong_len = $len }
}
}
} ## end loop over lines
if (DEBUG_COLLAPSED_LENGTHS) {
print "\nCollapsed lengths--\n";
foreach
my $key ( sort { $a <=> $b } keys %{$rcollapsed_length_by_seqno} )
{
my $clen = $rcollapsed_length_by_seqno->{$key};
print "$key -> $clen\n";
}
}
return;
} ## end sub xlp_collapsed_lengths
sub xlp_collapse_lengths_inner_loop {
my ( $self, $iline, $K_begin_loop, $K_terminal, $K_last ) = @_;
# Loop over tokens on a line for sub xlp_collapse_lengths
# Given:
# $iline = line number in input stream
# ($K_begin_loop, $K_terminal) = token index range to scan
# $K_last = last token index on this line
my $rLL = $self->[_rLL_];
my $K_closing_container = $self->[_K_closing_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $rcollapsed_length_by_seqno = $self->[_rcollapsed_length_by_seqno_];
my $ris_permanently_broken = $self->[_ris_permanently_broken_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $rhas_broken_list = $self->[_rhas_broken_list_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
#----------------------------------
# Loop over tokens on this line ...
#----------------------------------
my $type;
foreach my $KK ( $K_begin_loop .. $K_terminal ) {
next if ( ( $type = $rLL->[$KK]->[_TYPE_] ) eq 'b' );
#------------------------
# Handle sequenced tokens
#------------------------
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($seqno) {
my $token = $rLL->[$KK]->[_TOKEN_];
#----------------------------
# Entering a new container...
#----------------------------
if ( $is_opening_token{$token}
&& defined( $K_closing_container->{$seqno} ) )
{
# save current prong length
$stack[-1]->[_max_prong_len_] = $max_prong_len;
$max_prong_len = 0;
# Start new prong one level deeper
my $handle_len = 0;
if ( $rblock_type_of_seqno->{$seqno} ) {
# code blocks do not use -lp indentation, but behave as
# if they had a handle of one indentation length
$handle_len = $rOpts_indent_columns;
}
else {
if ( $is_handle_type{$last_nonblank_type} ) {
$handle_len = $len;
$handle_len += 1
if ( $KK > 0
&& $rLL->[ $KK - 1 ]->[_TYPE_] eq 'b' );
}
}
# Set a flag if the 'Interrupted List Rule' will be applied
# (see sub copy_old_breakpoints).
# - Added check on has_broken_list to fix issue b1298
my $interrupted_list_rule =
$ris_permanently_broken->{$seqno}
&& $ris_list_by_seqno->{$seqno}
&& !$rhas_broken_list->{$seqno}
&& !$rOpts_ignore_old_breakpoints;
# NOTES: Since we are looking at old line numbers we have
# to be very careful not to introduce an instability.
# This following causes instability (b1288-b1296):
# $interrupted_list_rule ||=
# $rOpts_break_at_old_comma_breakpoints;
# - We could turn off the interrupted list rule if there is
# a broken sublist, to follow 'Compound List Rule 1'.
# - We could use the _rhas_broken_list_ flag for this.
# - But it seems safer not to do this, to avoid
# instability, since the broken sublist could be
# temporary. It seems better to let the formatting
# stabilize by itself after one or two iterations.
# - So, not doing this for now
# Turn off the interrupted list rule if -vmll is set and a
# list has '=>' characters. This avoids instabilities due
# to dependence on old line breaks; issue b1325.
if ( $interrupted_list_rule
&& $rOpts_variable_maximum_line_length )
{
my $rtype_count = $rtype_count_by_seqno->{$seqno};
if ( $rtype_count && $rtype_count->{'=>'} ) {
$interrupted_list_rule = 0;
}
}
my $K_c = $K_closing_container->{$seqno};
# Add length of any terminal list item if interrupted
# so that the result is the same as if the term is
# in the next line (b1446).
if (
$interrupted_list_rule
&& $KK < $K_terminal
# The line should end in a comma
# NOTE: this currently assumes break after comma.
# As long as the other call to cumulative_length..
# makes the same assumption we should remain stable.
&& $rLL->[$K_terminal]->[_TYPE_] eq ','
)
{
$max_prong_len =
$self->cumulative_length_to_comma( $KK + 1,
$K_terminal, $K_c );
}
push @stack, [
$max_prong_len,
$handle_len,
$seqno,
$iline,
$KK,
$K_c,
$interrupted_list_rule
];
}
#--------------------
# Exiting a container
#--------------------
elsif ( $is_closing_token{$token} && @stack ) {
# The current prong ends - get its handle
my $item = pop @stack;
my $handle_len = $item->[_handle_len_];
my $seqno_o = $item->[_seqno_o_];
my $iline_o = $item->[_iline_o_];
my $K_o = $item->[_K_o_];
my $K_c_expect = $item->[_K_c_];
my $collapsed_len = $max_prong_len;
if ( $seqno_o ne $seqno ) {
# This can happen if input file has brace errors.
# Otherwise it shouldn't happen. Not fatal but -lp
# formatting could get messed up.
if ( DEVEL_MODE && !get_saw_brace_error() ) {
Fault(<{$seqno};
if ($block_type) {
my $K_c = $KK;
my $block_length = MIN_BLOCK_LEN;
my $is_one_line_block;
my $level = $rLL->[$K_o]->[_LEVEL_];
if ( defined($K_o) && defined($K_c) ) {
# note: fixed 3 May 2022 (removed 'my')
$block_length =
$rLL->[ $K_c - 1 ]->[_CUMULATIVE_LENGTH_] -
$rLL->[$K_o]->[_CUMULATIVE_LENGTH_];
$is_one_line_block = $iline == $iline_o;
}
# Code block rule 1: Use the total block length if
# it is less than the minimum.
if ( $block_length < MIN_BLOCK_LEN ) {
$collapsed_len = $block_length;
}
# Code block rule 2: Use the full length of a
# one-line block to avoid breaking it, unless
# extremely long. We do not need to do a precise
# check here, because if it breaks then it will
# stay broken on later iterations.
elsif (
$is_one_line_block
&& $block_length <
$maximum_line_length_at_level[$level]
# But skip this for blocks types which can reform,
# like sort/map/grep/eval blocks, to avoid
# instability (b1345, b1428)
&& $self->is_fragile_block_type( $block_type,
$seqno )
)
{
$collapsed_len = $block_length;
}
# Code block rule 3: Otherwise the length should be
# at least MIN_BLOCK_LEN to avoid scrunching code
# blocks.
elsif ( $collapsed_len < MIN_BLOCK_LEN ) {
$collapsed_len = MIN_BLOCK_LEN;
}
else {
# none of these rules applies
}
}
# Store the result. Some extra space, '2', allows for
# length of an opening token, inside space, comma, ...
# This constant has been tuned to give good overall
# results.
$collapsed_len += 2;
$rcollapsed_length_by_seqno->{$seqno} = $collapsed_len;
# Restart scanning the lower level prong
if (@stack) {
$max_prong_len = $stack[-1]->[_max_prong_len_];
$collapsed_len += $handle_len;
if ( $collapsed_len > $max_prong_len ) {
$max_prong_len = $collapsed_len;
}
}
}
# it is a ternary or input file is unbalanced
else {
}
$len = 0;
$last_nonblank_type = $type;
next;
}
#----------------------------
# Handle non-container tokens
#----------------------------
my $token_length = $rLL->[$KK]->[_TOKEN_LENGTH_];
# Count lengths of things like 'xx => yy' as a single item
if ( $type eq '=>' ) {
$len += $token_length + 1;
# fix $len for -naws, issue b1457
if ( !$rOpts_add_whitespace ) {
if ( defined( $rLL->[ $KK + 1 ] )
&& $rLL->[ $KK + 1 ]->[_TYPE_] ne 'b' )
{
$len -= 1;
}
}
if ( $len > $max_prong_len ) { $max_prong_len = $len }
}
elsif ( $last_nonblank_type eq '=>' ) {
$len += $token_length;
if ( $len > $max_prong_len ) { $max_prong_len = $len }
# but only include one => per item
$len = $token_length;
}
# include everything to end of line after a here target
elsif ( $type eq 'h' ) {
$len = $rLL->[$K_last]->[_CUMULATIVE_LENGTH_] -
$rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
if ( $len > $max_prong_len ) { $max_prong_len = $len }
}
# for everything else just use the token length
else {
$len = $token_length;
if ( $len > $max_prong_len ) { $max_prong_len = $len }
}
$last_nonblank_type = $type;
} ## end loop over tokens on this line
return;
} ## end sub xlp_collapse_lengths_inner_loop
} ## end closure xlp_collapsed_lengths
sub is_excluded_lp {
my ( $self, $KK ) = @_;
# Decide if this container is excluded by user request
# Given:
# $KK = index of the container opening token
# Return:
# true if this token is excluded (i.e., may not use -lp)
# false otherwise
# The control hash can either describe:
# what to exclude: $line_up_parentheses_control_is_lpxl = 1, or
# what to include: $line_up_parentheses_control_is_lpxl = 0
my $rLL = $self->[_rLL_];
my $rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
my $rflags = $line_up_parentheses_control_hash{$token};
#-----------------------------------------------
# TEST #1: check match to listed container types
#-----------------------------------------------
if ( !defined($rflags) ) {
# There is no entry for this container, so we are done
return !$line_up_parentheses_control_is_lpxl;
}
my ( $flag1, $flag2 ) = @{$rflags};
#-----------------------------------------------------------
# TEST #2: check match to flag1, the preceding nonblank word
#-----------------------------------------------------------
my $match_flag1 = !defined($flag1) || $flag1 eq '*';
if ( !$match_flag1 ) {
# Find the previous token
my ( $is_f, $is_k, $is_w );
my $Kp = $self->K_previous_nonblank($KK);
if ( defined($Kp) ) {
my $type_p = $rLL->[$Kp]->[_TYPE_];
my $seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
# keyword?
$is_k = $type_p eq 'k';
# function call?
$is_f = $self->[_ris_function_call_paren_]->{$seqno};
# either keyword or function call?
$is_w = $is_k || $is_f;
}
# Check for match based on flag1 and the previous token:
if ( $flag1 eq 'k' ) { $match_flag1 = $is_k }
elsif ( $flag1 eq 'K' ) { $match_flag1 = !$is_k }
elsif ( $flag1 eq 'f' ) { $match_flag1 = $is_f }
elsif ( $flag1 eq 'F' ) { $match_flag1 = !$is_f }
elsif ( $flag1 eq 'w' ) { $match_flag1 = $is_w }
elsif ( $flag1 eq 'W' ) { $match_flag1 = !$is_w }
else {
## no match
DEVEL_MODE && Fault(<[_TYPE_SEQUENCE_];
my $is_list = $self->[_ris_list_by_seqno_]->{$seqno};
my $has_list = $self->[_rhas_list_]->{$seqno};
my $has_code_block = $self->[_rhas_code_block_]->{$seqno};
my $has_ternary = $self->[_rhas_ternary_]->{$seqno};
if ( !$is_list
|| $has_list
|| $flag2 eq '2' && ( $has_code_block || $has_ternary ) )
{
$match_flag2 = 1;
}
}
return $match_flag2;
} ## end sub is_excluded_lp
sub set_excluded_lp_containers {
my ($self) = @_;
return unless ($rOpts_line_up_parentheses);
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $K_opening_container = $self->[_K_opening_container_];
my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
foreach my $seqno ( keys %{$K_opening_container} ) {
# code blocks are always excluded by the -lp coding so we can skip them
next if ( $rblock_type_of_seqno->{$seqno} );
my $KK = $K_opening_container->{$seqno};
next unless defined($KK);
# see if a user exclusion rule turns off -lp for this container
if ( $self->is_excluded_lp($KK) ) {
$ris_excluded_lp_container->{$seqno} = 1;
}
}
return;
} ## end sub set_excluded_lp_containers
######################################
# CODE SECTION 6: Process line-by-line
######################################
sub process_all_lines {
my $self = shift;
#----------------------------------------------------------
# Main loop to format all lines of a file according to type
#----------------------------------------------------------
my $rlines = $self->[_rlines_];
my $rOpts_keep_old_blank_lines = $rOpts->{'keep-old-blank-lines'};
my $file_writer_object = $self->[_file_writer_object_];
my $logger_object = $self->[_logger_object_];
my $vertical_aligner_object = $self->[_vertical_aligner_object_];
my $save_logfile = $self->[_save_logfile_];
# 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 = EMPTY_STRING;
my $i_last_POD_END = -10;
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
# insert blank lines requested for keyword sequences
if ( defined( $rwant_blank_line_after->{$i} )
&& $rwant_blank_line_after->{$i} == 1 )
{
$self->want_blank_line();
}
$i++;
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, '.'
# SKIP - code skipping section
# SKIP_END - last line of code skipping section, '#>>V'
# 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' && !$self->[_saw_END_or_DATA_] ) {
$i_last_POD_END = $i;
$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' ) {
# Keep this blank? Start with the flag -kbl=n, where
# n=0 ignore all old blank lines
# n=1 stable: keep old blanks, but limited by -mbl=n
# n=2 keep all old blank lines, regardless of -mbl=n
# If n=0 we delete all old blank lines and let blank line
# rules generate any needed blank lines.
my $kgb_keep = $rOpts_keep_old_blank_lines;
# Then delete lines requested by the keyword-group logic if
# allowed
if ( $kgb_keep == 1
&& defined( $rwant_blank_line_after->{$i} )
&& $rwant_blank_line_after->{$i} == 2 )
{
$kgb_keep = 0;
}
# But always keep a blank line following an =cut
if ( $i - $i_last_POD_END < 3 && !$kgb_keep ) {
$kgb_keep = 1;
}
if ($kgb_keep) {
$self->flush($CODE_type);
$file_writer_object->write_blank_code_line(
$rOpts_keep_old_blank_lines == 2 );
$self->[_last_line_leading_type_] = 'b';
}
next;
}
else {
# Let logger see all non-blank lines of code. This is a slow
# operation so we avoid it if it is not going to be saved.
if ( $save_logfile && $logger_object ) {
# get updated indentation levels
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast_uu ) = @{$rK_range};
if ( defined($Kfirst) ) {
my $level_0 = $self->[_radjusted_levels_]->[$Kfirst];
my $ci_level_0 =
$self->[_rLL_]->[$Kfirst]->[_CI_LEVEL_];
$line_of_tokens->{_level_0} = $level_0;
$line_of_tokens->{_ci_level_0} = $ci_level_0;
}
$logger_object->black_box( $line_of_tokens,
$vertical_aligner_object->get_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 ( substr( $line_type, 0, 3 ) eq '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'} ) {
chomp $input_line;
$input_line =~ s/\s+$//;
$input_line .= "\n";
}
if ( !$skip_line
&& !$in_format_skipping_section
&& $line_type eq 'POD_START'
&& !$self->[_saw_END_or_DATA_] )
{
$self->want_blank_line();
}
}
# leave the blank counters in a predictable state
# after __END__ or __DATA__
elsif ( $line_type eq 'END_START' || $line_type eq 'DATA_START' ) {
$file_writer_object->reset_consecutive_blank_lines();
$self->[_saw_END_or_DATA_] = 1;
}
# Patch to avoid losing blank lines after a code-skipping block;
# fixes case c047.
elsif ( $line_type eq 'SKIP_END' ) {
$file_writer_object->reset_consecutive_blank_lines();
}
else {
## some other line type
}
# write unindented non-code line
if ( !$skip_line ) {
$self->write_unindented_line($input_line);
}
}
}
return;
} ## end sub process_all_lines
{ ## closure keyword_group_scan
# this is the return var
my $rhash_of_desires;
# user option variables for -kgb
my (
$rOpts_kgb_after,
$rOpts_kgb_before,
$rOpts_kgb_delete,
$rOpts_kgb_inside,
$rOpts_kgb_size_max,
$rOpts_kgb_size_min,
);
# group variables, initialized by kgb_initialize_group_vars
my ( $ibeg, $iend, $count, $level_beg, $K_closing );
my ( @iblanks, @group, @subgroup );
# line variables, updated by sub keyword_group_scan
my ( $line_type, $CODE_type, $K_first, $K_last );
my $number_of_groups_seen;
#------------------------
# -kgb helper subroutines
#------------------------
sub kgb_initialize_options {
# check and initialize user options for -kgb
# return error flag:
# true for some input error, do not continue
# false if ok
# Local copies of the various control parameters
$rOpts_kgb_after = $rOpts->{'keyword-group-blanks-after'}; # '-kgba'
$rOpts_kgb_before = $rOpts->{'keyword-group-blanks-before'}; # '-kgbb'
$rOpts_kgb_delete = $rOpts->{'keyword-group-blanks-delete'}; # '-kgbd'
$rOpts_kgb_inside = $rOpts->{'keyword-group-blanks-inside'}; # '-kgbi'
# 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 $rOpts_kgb_size = $rOpts->{'keyword-group-blanks-size'}; # '-kgbs'
( $rOpts_kgb_size_min, $rOpts_kgb_size_max ) = split /\.+/,
$rOpts_kgb_size;
if ( $rOpts_kgb_size_min && $rOpts_kgb_size_min !~ /^\d+$/
|| $rOpts_kgb_size_max && $rOpts_kgb_size_max !~ /^\d+$/ )
{
Warn(<{'keyword-group-blanks-size'} = EMPTY_STRING;
return $rhash_of_desires;
}
$rOpts_kgb_size_min = 1 unless ($rOpts_kgb_size_min);
if ( $rOpts_kgb_size_max && $rOpts_kgb_size_max < $rOpts_kgb_size_min )
{
return $rhash_of_desires;
}
# check codes for $rOpts_kgb_before and
# $rOpts_kgb_after:
# 0 = never (delete if exist)
# 1 = stable (keep unchanged)
# 2 = always (insert if missing)
my $ok = $rOpts_kgb_size_min > 0
&& ( $rOpts_kgb_before != 1
|| $rOpts_kgb_after != 1
|| $rOpts_kgb_inside
|| $rOpts_kgb_delete );
return $rhash_of_desires if ( !$ok );
# The following parameter combination can be unstable (c302):
if ( $rOpts_kgb_size_max
&& $rOpts_kgb_after == INSERT
&& $rOpts_kgb_before == DELETE )
{
# We reset kgb_before=STABLE to fix and continue
$rOpts_kgb_before = STABLE;
}
return;
} ## end sub kgb_initialize_options
sub kgb_initialize_group_vars {
# Definitions:
# $ibeg = first line index of this entire group
# $iend = last line index of this entire group
# $count = total number of keywords seen in this entire group
# $level_beg = indentation 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
$ibeg = -1;
$iend = undef;
$level_beg = -1;
$K_closing = undef;
$count = 0;
@group = ();
@subgroup = ();
@iblanks = ();
return;
} ## end sub kgb_initialize_group_vars
sub kgb_initialize_line_vars {
$CODE_type = EMPTY_STRING;
$K_first = undef;
$K_last = undef;
$line_type = EMPTY_STRING;
return;
} ## end sub kgb_initialize_line_vars
sub kgb_initialize {
# initialize all closure variables for -kgb
# return:
# true to cause immediate exit (something is wrong)
# false to continue ... all is okay
# This is the return variable:
$rhash_of_desires = {};
# initialize and check user options;
my $quit = kgb_initialize_options();
if ($quit) { return $quit }
# initialize variables for the current group and subgroups:
kgb_initialize_group_vars();
# initialize variables for the most recently seen line:
kgb_initialize_line_vars();
$number_of_groups_seen = 0;
# all okay
return;
} ## end sub kgb_initialize
sub kgb_insert_blank_after {
my ($i) = @_;
# Given:
# $i = line number after which blank is requested
$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;
} ## end sub kgb_insert_blank_after
sub kgb_split_into_sub_groups {
# place blanks around long sub-groups of keywords
# ...if requested
return unless ($rOpts_kgb_inside);
# loop over sub-groups, index k
push @subgroup, scalar(@group);
my $kbeg = 1;
my $kend = @subgroup - 1;
foreach my $k ( $kbeg .. $kend ) {
# 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_uu, $count_b ) = @{ $group[$j_b] };
my ( $i_e_uu, $tok_e_uu, $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 >= $rOpts_kgb_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 && !$rOpts_kgb_delete ) {
my $j_bb = $j_b + $num - 1;
my ( $i_bb_uu, $tok_bb_uu, $count_bb ) = @{ $group[$j_bb] };
$nog_b = $count_bb - $count_b + 1 == $num;
my $j_ee = $j_e - ( $num - 1 );
my ( $i_ee_uu, $tok_ee_uu, $count_ee ) = @{ $group[$j_ee] };
$nog_e = $count_e - $count_ee + 1 == $num;
}
if ( $nog_b && $k > $kbeg ) {
kgb_insert_blank_after( $i_b - 1 );
}
if ( $nog_e && $k < $kend ) {
my ( $i_ep, $tok_ep_uu, $count_ep_uu ) =
@{ $group[ $j_e + 1 ] };
kgb_insert_blank_after( $i_ep - 1 );
}
}
}
return;
} ## end sub kgb_split_into_sub_groups
sub kgb_delete_if_blank {
my ( $self, $i ) = @_;
# delete line $i if it is blank
my $rlines = $self->[_rlines_];
return if ( $i < 0 || $i >= @{$rlines} );
return if ( $rlines->[$i]->{_line_type} ne 'CODE' );
my $code_type = $rlines->[$i]->{_code_type};
if ( $code_type eq 'BL' ) { $rhash_of_desires->{$i} = 2; }
return;
} ## end sub kgb_delete_if_blank
sub kgb_delete_inner_blank_lines {
# always remove unwanted trailing blank lines from our list
return unless (@iblanks);
while (@iblanks) {
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 ($rOpts_kgb_delete);
while (@iblanks) {
my $ibl = pop @iblanks;
$rhash_of_desires->{$ibl} = 2;
}
return;
} ## end sub kgb_delete_inner_blank_lines
sub kgb_end_group {
my ( $self, ($bad_ending) ) = @_;
# End a group of keywords
# Given:
# $bad_ending = false if group ends ok
# true if group ends badly (strange pattern)
if ( defined($ibeg) && $ibeg >= 0 ) {
# then handle sufficiently large groups
if ( $count >= $rOpts_kgb_size_min ) {
$number_of_groups_seen++;
# do any blank deletions regardless of the count
kgb_delete_inner_blank_lines();
my $rlines = $self->[_rlines_];
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 ( $rOpts_kgb_before == INSERT ) {
kgb_insert_blank_after( $ibeg - 1 );
}
elsif ( $rOpts_kgb_before == DELETE ) {
$self->kgb_delete_if_blank( $ibeg - 1 );
}
else {
## == STABLE
}
}
}
# 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 = <[_rLL_];
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 ( $rOpts_kgb_after == INSERT ) {
kgb_insert_blank_after($iend);
}
elsif ( $rOpts_kgb_after == DELETE ) {
$self->kgb_delete_if_blank( $iend + 1 );
}
else {
## == STABLE
}
}
}
}
kgb_split_into_sub_groups();
}
# reset for another group
kgb_initialize_group_vars();
return;
} ## end sub kgb_end_group
sub kgb_find_container_end {
my ($self) = @_;
# If the keyword line is continued onto subsequent lines, find the
# closing token '$K_closing' so that we can easily skip past the
# contents of the container.
# We only set this value if we find a simple list, meaning
# -contents only one level deep
# -not welded
# First check: skip if next line is not one deeper
my $Knext_nonblank = $self->K_next_nonblank($K_last);
return if ( !defined($Knext_nonblank) );
my $rLL = $self->[_rLL_];
my $level_next = $rLL->[$Knext_nonblank]->[_LEVEL_];
return if ( $level_next != $level_beg + 1 );
# Find the parent container of the first token on the next line
my $parent_seqno = $self->parent_seqno_by_K($Knext_nonblank);
return unless ( defined($parent_seqno) );
# Must not be a weld (can be unstable)
return
if ( $total_weld_count
&& $self->is_welded_at_seqno($parent_seqno) );
# Opening container must exist and be on this line
my $Ko = $self->[_K_opening_container_]->{$parent_seqno};
return if ( !defined($Ko) || $Ko <= $K_first || $Ko > $K_last );
# Verify that the closing container exists and is on a later line
my $Kc = $self->[_K_closing_container_]->{$parent_seqno};
return if ( !defined($Kc) || $Kc <= $K_last );
# That's it
$K_closing = $Kc;
return;
} ## end sub kgb_find_container_end
sub kgb_add_to_group {
my ( $self, $i, $token, $level ) = @_;
# End the previous group if we have reached the maximum
# group size
if ( $rOpts_kgb_size_max && @group >= $rOpts_kgb_size_max ) {
$self->kgb_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
$self->kgb_find_container_end();
return;
} ## end sub kgb_add_to_group
sub keyword_group_scan {
my $self = shift;
# Called once per file to process --keyword-group-blanks-* parameters.
# This is the main subroutine for the -kgb option
# Task:
# 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.
# Returns:
# 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
# Nothing to do if no blanks can be output. This test added to fix
# case b760.
if ( !$rOpts_maximum_consecutive_blank_lines ) {
return $rhash_of_desires;
}
#---------------
# initialization
#---------------
my $quit = kgb_initialize();
if ($quit) { return $rhash_of_desires }
my $rLL = $self->[_rLL_];
my $rlines = $self->[_rlines_];
$self->kgb_end_group();
my $i = -1;
my $Opt_repeat_count =
$rOpts->{'keyword-group-blanks-repeat-count'}; # '-kgbr'
#----------------------------------
# loop over all lines of the source
#----------------------------------
foreach my $line_of_tokens ( @{$rlines} ) {
$i++;
last
if ( $Opt_repeat_count > 0
&& $number_of_groups_seen >= $Opt_repeat_count );
kgb_initialize_line_vars();
$line_type = $line_of_tokens->{_line_type};
# always end a group at non-CODE
if ( $line_type ne 'CODE' ) { $self->kgb_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' ) {
$self->kgb_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) ) {
# Somewhat unexpected blank line..
# $rK_range is normally defined for line type CODE, but this can
# happen for example if the input line was a single semicolon
# which is being deleted. In that case there was code in the
# input file but it is not being retained. So we can silently
# return.
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_];
# End a group 'badly' at an unexpected level. This will prevent
# blank lines being incorrectly placed after the end of the group.
# We are looking for any deviation from two acceptable patterns:
# PATTERN 1: a simple list; secondary lines are at level+1
# PATTERN 2: a long statement; all secondary lines same level
# This was added as a fix for case b1177, in which a complex
# structure got incorrectly inserted blank lines.
if ( $ibeg >= 0 ) {
# Check for deviation from PATTERN 1, simple list:
if ( defined($K_closing) && $K_first < $K_closing ) {
$self->kgb_end_group(1) if ( $level != $level_beg + 1 );
}
# Check for deviation from PATTERN 2, single statement:
elsif ( $level != $level_beg ) { $self->kgb_end_group(1) }
else {
## no deviation
}
}
# Do not look for keywords in lists ( keyword 'my' can occur in
# lists, see case b760); fixed for c048.
# Switch from ->is_list_by_K to !->is_in_block_by_K to fix b1464
if ( !$self->is_in_block_by_K($K_first) ) {
if ( $ibeg >= 0 ) { $iend = $i }
next;
}
# see if this is a code type we seek (i.e. comment)
if ( $CODE_type
&& $keyword_group_list_comment_pattern
&& $CODE_type =~ /$keyword_group_list_comment_pattern/ )
{
my $tok = $CODE_type;
# Continuing a group
if ( $ibeg >= 0 && $level == $level_beg ) {
$self->kgb_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 ) { $self->kgb_end_group(); }
$self->kgb_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 =~ /$keyword_group_list_pattern/ )
{
# Continuing a keyword group
if ( $ibeg >= 0 && $level == $level_beg ) {
$self->kgb_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 ) { $self->kgb_end_group(); }
$self->kgb_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 anonymous sub code.
if ( $level > $level_beg + 1 || $level < $level_beg ) {
$self->kgb_end_group(1);
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 '#' )
{
$self->kgb_end_group(1);
next;
}
}
$iend = $i;
next;
}
$self->kgb_end_group(1);
next;
}
# - end the group if none of the above
$self->kgb_end_group();
next;
}
# not in a keyword group; continue
else { next }
} ## end of loop over all lines
$self->kgb_end_group();
return $rhash_of_desires;
} ## end sub keyword_group_scan
} ## end closure keyword_group_scan
#######################################
# CODE SECTION 7: Process lines of code
#######################################
{ ## begin closure process_line_of_CODE
# The routines in this closure receive lines of code and combine them into
# 'batches' and send them along. A 'batch' is the unit of code which can be
# processed further as a unit. It has the property that it is the largest
# amount of code into which which perltidy is free to place one or more
# line breaks within it without violating any constraints.
# When a new batch is formed it is sent to sub 'grind_batch_of_code'.
# flags needed by the store routine
my $line_of_tokens;
my $no_internal_newlines;
my $CODE_type;
my $current_line_starts_in_quote;
# range of K of tokens for the current line
my ( $K_first, $K_last );
my ( $rLL, $radjusted_levels, $rparent_of_seqno, $rdepth_of_opening_seqno,
$rblock_type_of_seqno, $ri_starting_one_line_block );
# past stored nonblank tokens and flags
my (
$K_last_nonblank_code, $K_dangling_elsif,
$is_static_block_comment, $last_CODE_type,
$last_line_had_side_comment, $next_parent_seqno,
$next_slevel,
);
# Called once at the start of a new file
sub initialize_process_line_of_CODE {
$K_last_nonblank_code = undef;
$K_dangling_elsif = 0;
$is_static_block_comment = 0;
$last_line_had_side_comment = 0;
$next_parent_seqno = SEQ_ROOT;
$next_slevel = undef;
return;
} ## end sub initialize_process_line_of_CODE
# Batch variables: these describe the current batch of code being formed
# and sent down the pipeline. They are initialized in the next
# sub.
my (
$rbrace_follower, $index_start_one_line_block,
$starting_in_quote, $ending_in_quote,
);
# Called before the start of each new batch
sub initialize_batch_variables {
# Initialize array values for a new batch. Any changes here must be
# carefully coordinated with sub store_token_to_go.
$max_index_to_go = UNDEFINED_INDEX;
$summed_lengths_to_go[0] = 0;
$nesting_depth_to_go[0] = 0;
$ri_starting_one_line_block = [];
# Redefine some sparse arrays.
# It is more efficient to redefine these sparse arrays and rely on
# undef's instead of initializing to 0's. Testing showed that using
# @array=() is more efficient than $#array=-1
@old_breakpoint_to_go = ();
@forced_breakpoint_to_go = ();
@block_type_to_go = ();
@mate_index_to_go = ();
@type_sequence_to_go = ();
# NOTE: @nobreak_to_go is sparse and could be treated this way, but
# testing showed that there would be very little efficiency gain
# because an 'if' test must be added in store_token_to_go.
# The initialization code for the remaining batch arrays is as follows
# and can be activated for testing. But profiling shows that it is
# time-consuming to re-initialize the batch arrays and is not necessary
# because the maximum valid token, $max_index_to_go, is carefully
# controlled. This means however that it is not possible to do any
# type of filter or map operation directly on these arrays. And it is
# not possible to use negative indexes. As a precaution against program
# changes which might do this, sub pad_array_to_go adds some undefs at
# the end of the current batch of data.
## 0 && do { #<<<
## @nobreak_to_go = ();
## @token_lengths_to_go = ();
## @levels_to_go = ();
## @ci_levels_to_go = ();
## @tokens_to_go = ();
## @K_to_go = ();
## @types_to_go = ();
## @leading_spaces_to_go = ();
## @reduced_spaces_to_go = ();
## @inext_to_go = ();
## @parent_seqno_to_go = ();
## };
$rbrace_follower = undef;
$ending_in_quote = 0;
$index_start_one_line_block = undef;
# initialize forced breakpoint vars associated with each output batch
$forced_breakpoint_count = 0;
$index_max_forced_break = UNDEFINED_INDEX;
$forced_breakpoint_undo_count = 0;
return;
} ## end sub initialize_batch_variables
sub leading_spaces_to_go {
my ($ii) = @_;
# Return the number of indentation spaces for token at index $ii
# in the output stream
return 0 if ( $ii < 0 );
my $indentation = $leading_spaces_to_go[$ii];
return ref($indentation) ? $indentation->get_spaces() : $indentation;
} ## end sub leading_spaces_to_go
sub create_one_line_block {
# note that this updates a closure variable
$index_start_one_line_block = shift;
# Set index starting next one-line block
# Given:
# $index_start_one_line_block = starting index in _to_go array
# undef => end current one-line block
#
# call with no args to delete the current one-line block
return;
} ## end sub create_one_line_block
# Routine to place the current token into the output stream.
# Called once per output token.
use constant DEBUG_STORE => 0;
sub store_token_to_go {
my ( $self, $Ktoken_vars, $rtoken_vars ) = @_;
#-------------------------------------------------------
# Token storage utility for sub process_line_of_CODE.
# Add one token to the next batch of '_to_go' variables.
#-------------------------------------------------------
# Input parameters:
# $Ktoken_vars = the index K in the global token array
# $rtoken_vars = $rLL->[$Ktoken_vars] = the corresponding token values
# unless they are temporarily being overridden
#------------------------------------------------------------------
# NOTE: called once per token so coding efficiency is critical here.
# All changes need to be benchmarked with Devel::NYTProf.
#------------------------------------------------------------------
my (
$type,
$token,
$ci_level,
$level,
$seqno,
$length,
) = @{$rtoken_vars}[
_TYPE_,
_TOKEN_,
_CI_LEVEL_,
_LEVEL_,
_TYPE_SEQUENCE_,
_TOKEN_LENGTH_,
];
# Check for emergency flush...
# The K indexes in the batch must always be a continuous sequence of
# the global token array. The batch process programming assumes this.
# If storing this token would cause this relation to fail we must dump
# the current batch before storing the new token. It is extremely rare
# for this to happen. One known example is the following two-line
# snippet when run with parameters
# --noadd-newlines --space-terminal-semicolon:
# if ( $_ =~ /PENCIL/ ) { $pencil_flag= 1 } ; ;
# $yy=1;
if ( $max_index_to_go >= 0 ) {
if ( $Ktoken_vars != $K_to_go[$max_index_to_go] + 1 ) {
$self->flush_batch_of_CODE();
}
# Do not output consecutive blank tokens ... this should not
# happen, but it is worth checking. Later code can then make the
# simplifying assumption that blank tokens are not consecutive.
elsif ( $type eq 'b' && $types_to_go[$max_index_to_go] eq 'b' ) {
if (DEVEL_MODE) {
# if this happens, it is may be that consecutive blanks
# were inserted into the token stream in 'respace_tokens'
my $lno = $rLL->[$Ktoken_vars]->[_LINE_INDEX_] + 1;
Fault("consecutive blanks near line $lno; please fix");
}
return;
}
else {
## all ok
}
}
# Do not start a batch with a blank token.
# Fixes cases b149 b888 b984 b985 b986 b987
else {
if ( $type eq 'b' ) { return }
}
# Update counter and do initializations if first token of new batch
if ( !++$max_index_to_go ) {
# Reset flag '$starting_in_quote' for a new batch. It must be set
# to the value of '$in_continued_quote', but here for efficiency we
# set it to zero, which is its normal value. Then in coding below
# we will change it if we find we are actually in a continued quote.
$starting_in_quote = 0;
# Update the next parent sequence number for each new batch.
#----------------------------------------
# Begin coding from sub parent_seqno_by_K
#----------------------------------------
# The following is equivalent to this call but much faster:
# $next_parent_seqno = $self->parent_seqno_by_K($Ktoken_vars);
$next_parent_seqno = SEQ_ROOT;
if ($seqno) {
$next_parent_seqno = $rparent_of_seqno->{$seqno};
}
else {
my $Kt = $self->[_rK_next_seqno_by_K_]->[$Ktoken_vars];
if ( defined($Kt) ) {
# if next container token is closing, it is the parent seqno
if ( $is_closing_type{ $rLL->[$Kt]->[_TYPE_] } ) {
$next_parent_seqno = $rLL->[$Kt]->[_TYPE_SEQUENCE_];
}
# otherwise we want its parent container
else {
$next_parent_seqno =
$rparent_of_seqno->{ $rLL->[$Kt]->[_TYPE_SEQUENCE_] };
}
}
}
$next_parent_seqno = SEQ_ROOT
if ( !defined($next_parent_seqno) );
#--------------------------------------
# End coding from sub parent_seqno_by_K
#--------------------------------------
$next_slevel = $rdepth_of_opening_seqno->[$next_parent_seqno] + 1;
}
# Safety check that length is defined. This is slow and should not be
# needed now, so just do it in DEVEL_MODE to check programming changes.
# Formerly needed for --indent-only, in which the entire set of tokens
# is normally turned into type 'q'. Lengths are now defined in sub
# 'respace_tokens' so this check is no longer needed.
if ( DEVEL_MODE && !defined($length) ) {
my $lno = $rLL->[$Ktoken_vars]->[_LINE_INDEX_] + 1;
$length = length($token);
Fault(<{$seqno};
if ( $is_opening_token{$token} ) {
my $slevel = $rdepth_of_opening_seqno->[$seqno];
$nesting_depth_to_go[$max_index_to_go] = $slevel;
$next_slevel = $slevel + 1;
$next_parent_seqno = $seqno;
}
elsif ( $is_closing_token{$token} ) {
$next_slevel = $rdepth_of_opening_seqno->[$seqno];
my $slevel = $next_slevel + 1;
$nesting_depth_to_go[$max_index_to_go] = $slevel;
my $parent_seqno = $rparent_of_seqno->{$seqno};
$parent_seqno = SEQ_ROOT unless defined($parent_seqno);
$parent_seqno_to_go[$max_index_to_go] = $parent_seqno;
$next_parent_seqno = $parent_seqno;
}
else {
# ternary token: nothing to do
}
}
# Define the indentation that this token will have in two cases:
# Without CI = reduced_spaces_to_go
# With CI = leading_spaces_to_go
$leading_spaces_to_go[$max_index_to_go] =
$reduced_spaces_to_go[$max_index_to_go] =
$rOpts_indent_columns * $radjusted_levels->[$Ktoken_vars];
if ($ci_level) {
$leading_spaces_to_go[$max_index_to_go] +=
$rOpts_continuation_indentation;
}
# Correct these values if we are starting in a continued quote
if ( $current_line_starts_in_quote
&& $Ktoken_vars == $K_first )
{
# in a continued quote - correct value set above if first token
if ( $max_index_to_go == 0 ) { $starting_in_quote = 1 }
$leading_spaces_to_go[$max_index_to_go] = 0;
$reduced_spaces_to_go[$max_index_to_go] = 0;
}
DEBUG_STORE && do {
my ( $pkg, $file_uu, $lno ) = caller();
print {*STDOUT}
"STORE: from $pkg $lno: storing token $token type $type lev=$level at $max_index_to_go\n";
};
return;
} ## end sub store_token_to_go
sub flush_batch_of_CODE {
my ($self) = @_;
# Finish and process the current batch.
# This must be the only call to grind_batch_of_CODE()
return if ( $max_index_to_go < 0 );
# Create an array to hold variables for this batch
my $this_batch = $self->[_this_batch_] = [];
$this_batch->[_starting_in_quote_] = 1 if ($starting_in_quote);
$this_batch->[_ending_in_quote_] = 1 if ($ending_in_quote);
if ( $CODE_type || $last_CODE_type ) {
$this_batch->[_batch_CODE_type_] =
$K_to_go[$max_index_to_go] >= $K_first
? $CODE_type
: $last_CODE_type;
}
$last_line_had_side_comment =
( $max_index_to_go > 0 && $types_to_go[$max_index_to_go] eq '#' );
# The flag $is_static_block_comment applies to the line which just
# arrived. So it only applies if we are outputting that line.
if ( $is_static_block_comment && !$last_line_had_side_comment ) {
$this_batch->[_is_static_block_comment_] = $K_to_go[0] == $K_first;
}
$this_batch->[_ri_starting_one_line_block_] =
$ri_starting_one_line_block;
#-------------------
# process this batch
#-------------------
$self->grind_batch_of_CODE();
# Done .. this batch is history
initialize_batch_variables();
return;
} ## end sub flush_batch_of_CODE
sub end_batch {
# End the current batch, EXCEPT for a few special cases
my ($self) = @_;
if ( $max_index_to_go < 0 ) {
# nothing to do .. this is harmless but wastes time.
if (DEVEL_MODE) {
Fault("sub end_batch called with nothing to do; please fix\n");
}
return;
}
# Exceptions when a line does not end with a comment... (fixes c058)
if ( $types_to_go[$max_index_to_go] ne '#' ) {
# Exception 1: Do not end line in a weld
return
if ( $total_weld_count
&& $self->[_rK_weld_right_]->{ $K_to_go[$max_index_to_go] } );
# Exception 2: just set a tentative breakpoint if we might be in a
# one-line block
if ( defined($index_start_one_line_block) ) {
$self->set_forced_breakpoint($max_index_to_go);
return;
}
}
$self->flush_batch_of_CODE();
return;
} ## end sub end_batch
sub flush_vertical_aligner {
my ($self) = @_;
my $vao = $self->[_vertical_aligner_object_];
$vao->flush();
return;
} ## end sub flush_vertical_aligner
sub flush {
my ( $self, ($CODE_type_flush) ) = @_;
# Sub flush is called to output any tokens in the pipeline, so that
# an alternate source of lines can be written in the correct order
# Optional parameter:
# $CODE_type_flush = 'BL' for flushing to insert a blank line
$index_start_one_line_block = undef;
# End the current batch, if it holds any tokens, with 1 exception
if ( $max_index_to_go >= 0 ) {
# 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_flush && $CODE_type_flush eq 'BL' ) {
$self->end_batch();
}
# otherwise, we have to shut things down completely.
else { $self->flush_batch_of_CODE() }
}
$self->flush_vertical_aligner();
return;
} ## end sub flush
my %is_assignment_or_fat_comma;
BEGIN {
%is_assignment_or_fat_comma = %is_assignment;
$is_assignment_or_fat_comma{'=>'} = 1;
}
sub add_missing_else {
my ($self) = @_;
# Add a missing 'else' block.
# $K_dangling_elsif = index of closing elsif brace not followed by else
# Make sure everything looks okay
if ( !$K_dangling_elsif
|| $K_dangling_elsif < $K_first
|| $rLL->[$K_dangling_elsif]->[_TYPE_] ne '}' )
{
DEVEL_MODE && Fault("could not find closing elsif brace\n");
}
my $comment = $rOpts->{'add-missing-else-comment'};
# Safety check
if ( substr( $comment, 0, 1 ) ne '#' ) { $comment = '#' . $comment }
# Calculate indentation
my $level = $radjusted_levels->[$K_dangling_elsif];
my $spaces = SPACE x ( $level * $rOpts_indent_columns );
my $line1 = $spaces . "else {\n";
my $line3 = $spaces . "}\n";
$spaces .= SPACE x $rOpts_indent_columns;
my $line2 = $spaces . $comment . "\n";
# clear the output pipeline
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_code_line($line1);
$file_writer_object->write_code_line($line2);
$file_writer_object->write_code_line($line3);
return;
} ## end sub add_missing_else
sub process_line_of_CODE {
my ( $self, $my_line_of_tokens ) = @_;
#----------------------------------------------------------------
# This routine is called once per INPUT line to format all of the
# tokens on that line.
#----------------------------------------------------------------
# It outputs full-line comments and blank lines immediately.
# For lines of code:
# - Tokens are copied one-by-one from the global token
# array $rLL to a set of '_to_go' arrays which collect batches of
# tokens. This is done with calls to 'store_token_to_go'.
# - A batch is closed and processed upon reaching a well defined
# structural break point (i.e. code block boundary) or forced
# breakpoint (i.e. side comment or special user controls).
# - Subsequent stages of formatting make additional line breaks
# appropriate for lists and logical structures, and as necessary to
# keep line lengths below the requested maximum line length.
#-----------------------------------
# begin initialize closure variables
#-----------------------------------
$line_of_tokens = $my_line_of_tokens;
my $rK_range = $line_of_tokens->{_rK_range};
if ( !defined( $rK_range->[0] ) ) {
# Empty line: This can happen if tokens are deleted, for example
# with the -mangle parameter
return;
}
( $K_first, $K_last ) = @{$rK_range};
$last_CODE_type = $CODE_type;
$CODE_type = $line_of_tokens->{_code_type};
$current_line_starts_in_quote = $line_of_tokens->{_starting_in_quote};
$rLL = $self->[_rLL_];
$radjusted_levels = $self->[_radjusted_levels_];
$rparent_of_seqno = $self->[_rparent_of_seqno_];
$rdepth_of_opening_seqno = $self->[_rdepth_of_opening_seqno_];
$rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
#---------------------------------
# end initialize closure variables
#---------------------------------
# This flag will become nobreak_to_go and should be set to 2 to prevent
# a line break AFTER the current token.
$no_internal_newlines = 0;
if ( !$rOpts_add_newlines || $CODE_type eq 'NIN' ) {
$no_internal_newlines = 2;
}
my $input_line = $line_of_tokens->{_line_text};
my ( $is_block_comment, $has_side_comment );
if ( $rLL->[$K_last]->[_TYPE_] eq '#' ) {
if ( $K_last == $K_first && $CODE_type ne 'HSC' ) {
$is_block_comment = 1;
}
else { $has_side_comment = 1 }
}
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;
# check for a $VERSION statement
if ( $CODE_type eq 'VER' ) {
$self->[_saw_VERSION_in_this_file_] = 1;
$no_internal_newlines = 2;
}
# Add interline blank if any
my $last_old_nonblank_type = "b";
my $first_new_nonblank_token = EMPTY_STRING;
my $K_first_true = $K_first;
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_block_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;
#------------------------------------
# Handle a block (full-line) comment.
#------------------------------------
if ($is_block_comment) {
if ( $rOpts->{'delete-block-comments'} ) {
$self->flush();
return;
}
$index_start_one_line_block = undef;
$self->end_batch() if ( $max_index_to_go >= 0 );
# output a blank line before block comments
if (
# unless we follow a blank or comment line
$self->[_last_line_leading_type_] ne '#'
&& $self->[_last_line_leading_type_] ne 'b'
# only if allowed
&& $rOpts->{'blanks-before-comments'}
# if this is NOT an empty comment, unless it follows a side
# comment and could become a hanging side comment.
&& (
$rtok_first->[_TOKEN_] ne '#'
|| ( $last_line_had_side_comment
&& $rLL->[$K_first]->[_LEVEL_] > 0 )
)
# 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.
&& !$self->[_last_output_short_opening_token_]
# never before static block comments
&& !$is_static_block_comment
)
{
$self->flush(); # switching to new output stream
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_blank_code_line();
$self->[_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;
my $rtoken_vars = $rLL->[$Ktoken_vars];
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
$self->end_batch();
}
else {
# switching to new output stream
$self->flush();
# Note that last arg in call here is 'undef' for comments
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_code_line(
$rtok_first->[_TOKEN_] . "\n", undef );
$self->[_last_line_leading_type_] = '#';
}
return;
}
#--------------------------------------------
# Compare input/output indentation in logfile
#--------------------------------------------
if ( $self->[_save_logfile_] ) {
my $guessed_indentation_level =
$line_of_tokens->{_guessed_indentation_level};
# Compare input/output indentation except for:
# - hanging side comments
# - continuation lines (have unknown leading blank space)
# - and lines which are quotes (they may have been outdented)
my $exception =
$CODE_type eq 'HSC'
|| $rtok_first->[_CI_LEVEL_] > 0
|| $guessed_indentation_level == 0
&& $rtok_first->[_TYPE_] eq 'Q';
if ( !$exception ) {
my $input_line_number = $line_of_tokens->{_line_number};
$self->compare_indentation_levels( $K_first,
$guessed_indentation_level, $input_line_number );
}
}
#-----------------------------------------
# Handle a line marked as indentation-only
#-----------------------------------------
if ( $CODE_type eq 'IO' ) {
$self->flush();
my $line = $input_line;
# Fix for rt #125506 Unexpected string formatting
# 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 but must be defined
$rtoken_vars->[_TOKEN_LENGTH_] = length($line);
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
$self->end_batch();
return;
}
#---------------------------
# Handle all other lines ...
#---------------------------
$K_dangling_elsif = 0;
# This is a good place to kill incomplete one-line blocks
if ( $max_index_to_go >= 0 ) {
# For -iob and -lp, mark essential old breakpoints.
# Fixes b1021 b1023 b1034 b1048 b1049 b1050 b1056 b1058
# See related code below.
if ( $rOpts_ignore_old_breakpoints && $rOpts_line_up_parentheses ) {
my $type_first = $rLL->[$K_first_true]->[_TYPE_];
if ( $is_assignment_or_fat_comma{$type_first} ) {
$old_breakpoint_to_go[$max_index_to_go] = 1;
}
}
if (
# this check needed -mangle (for example rt125012)
(
( !$index_start_one_line_block )
&& ( $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
&& $last_old_nonblank_type eq ',' )
)
{
$forced_breakpoint_to_go[$max_index_to_go] = 1
if ($rOpts_break_at_old_comma_breakpoints);
$index_start_one_line_block = undef;
$self->end_batch();
}
# Keep any requested breaks before this line. Note that we have to
# use the original K_first because it may have been reduced above
# to add a blank. The value of the flag is as follows:
# 1 => hard break, flush the batch
# 2 => soft break, set breakpoint and continue building the batch
# added check on max_index_to_go for c177
if ( $max_index_to_go >= 0
&& $self->[_rbreak_before_Kfirst_]->{$K_first_true} )
{
$index_start_one_line_block = undef;
if ( $self->[_rbreak_before_Kfirst_]->{$K_first_true} == 2 ) {
$self->set_forced_breakpoint($max_index_to_go);
}
else {
$self->end_batch();
}
}
}
#--------------------------------------
# loop to process the tokens one-by-one
#--------------------------------------
$self->process_line_inner_loop($has_side_comment);
# if there is anything left in the output buffer ...
if ( $max_index_to_go >= 0 ) {
my $type = $rLL->[$K_last]->[_TYPE_];
my $break_flag = $self->[_rbreak_after_Klast_]->{$K_last};
# we have to flush ..
if (
# if there is a side comment...
$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
|| $CODE_type eq 'VER'
# to keep a label at the end of a line
|| ( $type eq 'J' && $rOpts_break_after_labels != 2 )
# if we have a hard break request
|| $break_flag && $break_flag != 2
# if we are instructed to keep all old line breaks
|| !$rOpts->{'delete-old-newlines'}
# if this is a line of the form 'use overload'. A break here in
# the input file is a good break because it will allow the
# operators which follow to be formatted well. Without this
# break the formatting with -ci=4 -xci is poor, for example.
# use overload
# '+' => sub {
# print length $_[2], "\n";
# my ( $x, $y ) = _order(@_);
# Number::Roman->new( int $x + $y );
# },
# '-' => sub {
# my ( $x, $y ) = _order(@_);
# Number::Roman->new( int $x - $y );
# };
|| ( $max_index_to_go == 2
&& $types_to_go[0] eq 'k'
&& $tokens_to_go[0] eq 'use'
&& $tokens_to_go[$max_index_to_go] eq 'overload' )
)
{
$index_start_one_line_block = undef;
$self->end_batch();
}
else {
# Check for a soft break request
if ( $break_flag && $break_flag == 2 ) {
$self->set_forced_breakpoint($max_index_to_go);
}
# mark old line breakpoints in current output stream
if (
!$rOpts_ignore_old_breakpoints
# Mark essential old breakpoints if combination -iob -lp is
# used. These two options do not work well together, but
# we can avoid turning -iob off by ignoring -iob at certain
# essential line breaks. See also related code above.
# Fixes b1021 b1023 b1034 b1048 b1049 b1050 b1056 b1058
|| ( $rOpts_line_up_parentheses
&& $is_assignment_or_fat_comma{$type} )
)
{
$old_breakpoint_to_go[$max_index_to_go] = 1;
}
}
}
if ( $K_dangling_elsif && $rOpts_add_missing_else ) {
$self->add_missing_else();
}
return;
} ## end sub process_line_of_CODE
sub process_line_inner_loop {
my ( $self, $has_side_comment ) = @_;
#--------------------------------------------------------------------
# Loop to move all tokens from one input line to a newly forming batch
#--------------------------------------------------------------------
# Do not start a new batch with a blank space
if ( $max_index_to_go < 0 && $rLL->[$K_first]->[_TYPE_] eq 'b' ) {
$K_first++;
}
foreach my $Ktoken_vars ( $K_first .. $K_last ) {
my $rtoken_vars = $rLL->[$Ktoken_vars];
#--------------
# handle blanks
#--------------
if ( $rtoken_vars->[_TYPE_] eq 'b' ) {
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
next;
}
#------------------
# handle non-blanks
#------------------
my $type = $rtoken_vars->[_TYPE_];
# 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) {
my $token = $rtoken_vars->[_TOKEN_];
if ( !$rbrace_follower->{$token} ) {
$self->end_batch() if ( $max_index_to_go >= 0 );
}
$rbrace_follower = undef;
}
my (
$block_type, $type_sequence,
$is_opening_BLOCK, $is_closing_BLOCK,
$nobreak_BEFORE_BLOCK
);
if ( $rtoken_vars->[_TYPE_SEQUENCE_] ) {
my $token = $rtoken_vars->[_TOKEN_];
$type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
$block_type = $rblock_type_of_seqno->{$type_sequence};
if ( $block_type
&& $token eq $type
&& $block_type ne 't'
&& !$self->[_rshort_nested_]->{$type_sequence} )
{
if ( $type eq '{' ) {
$is_opening_BLOCK = 1;
$nobreak_BEFORE_BLOCK = $no_internal_newlines;
}
elsif ( $type eq '}' ) {
$is_closing_BLOCK = 1;
$nobreak_BEFORE_BLOCK = $no_internal_newlines;
}
else {
## error - block should be enclosed by curly brace
DEVEL_MODE && Fault(<